From 6fa06b7a786e78987546455e683891e074a69c10 Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga Date: Mon, 25 Jul 2022 14:44:41 -0400 Subject: [PATCH 01/37] Added initialization of certain structures to test_output_yaml.F90. --- test_fms/parser/test_output_yaml.F90 | 74 ++++++++++++++++++++++++++++ 1 file changed, 74 insertions(+) diff --git a/test_fms/parser/test_output_yaml.F90 b/test_fms/parser/test_output_yaml.F90 index 9acf928bb7..9abc21c3f2 100644 --- a/test_fms/parser/test_output_yaml.F90 +++ b/test_fms/parser/test_output_yaml.F90 @@ -55,6 +55,7 @@ !! \end verbatim !! Great, now I have to create this long yaml for testing, lol. program test_output_yaml +#define use_yaml #ifdef use_yaml use fms_yaml_output_mod @@ -96,6 +97,35 @@ program test_output_yaml allocate(k3(a3)) allocate(v3(a3)) +!> Initialize all the above allocated structures +!! to have "" in character arrays. Needed for correct +!! running in Intel compiler +do i = 1, a1size + call initialize_key_struct(k1(i)) +end do + +do i = 1, a2 + call initialize_key_struct(k2(i)) +end do + +do i = 1, a3 + call initialize_key_struct(k3(i)) +end do + +do i = 1, a1size + call initialize_val_struct(v1(i)) +end do + +do i = 1, a2 + call initialize_val_struct(v2(i)) +end do + +do i = 1, a3 + call initialize_val_struct(v3(i)) +end do + + + !> Copy the strings into the key/value pairings call fms_f2c_string (k1(1)%key1,"name") call fms_f2c_string (v1(1)%val1,"time to eat") @@ -185,6 +215,50 @@ program test_output_yaml endif endif call fms_end + +CONTAINS + +!! Initialize one instance of the fmsYamlOutKeys_type structure. +subroutine initialize_key_struct( yk ) + type (fmsYamlOutKeys_type), intent(inout) :: yk !< Instance of the stucture + call fms_f2c_string (yk%key1,"") + call fms_f2c_string (yk%key2,"") + call fms_f2c_string (yk%key3,"") + call fms_f2c_string (yk%key4,"") + call fms_f2c_string (yk%key5,"") + call fms_f2c_string (yk%key6,"") + call fms_f2c_string (yk%key7,"") + call fms_f2c_string (yk%key8,"") + call fms_f2c_string (yk%key9,"") + call fms_f2c_string (yk%key10,"") + call fms_f2c_string (yk%key11,"") + call fms_f2c_string (yk%key12,"") + call fms_f2c_string (yk%key13,"") + call fms_f2c_string (yk%key14,"") + call fms_f2c_string (yk%key15,"") + call fms_f2c_string(yk%level2key,"") +end subroutine initialize_key_struct + +!! Initialize one instance of the fmsYamlOutValues_type structure. +subroutine initialize_val_struct( yv) + type (fmsYamlOutValues_type), intent(inout):: yv !< Instance of the stucture + call fms_f2c_string (yv%val1,"") + call fms_f2c_string (yv%val2,"") + call fms_f2c_string (yv%val3,"") + call fms_f2c_string (yv%val4,"") + call fms_f2c_string (yv%val5,"") + call fms_f2c_string (yv%val6,"") + call fms_f2c_string (yv%val7,"") + call fms_f2c_string (yv%val8,"") + call fms_f2c_string (yv%val9,"") + call fms_f2c_string (yv%val10,"") + call fms_f2c_string (yv%val11,"") + call fms_f2c_string (yv%val12,"") + call fms_f2c_string (yv%val13,"") + call fms_f2c_string (yv%val14,"") + call fms_f2c_string (yv%val15,"") +end subroutine initialize_val_struct + #endif end program test_output_yaml From c7b4687c866dfa2efffcf584d557a75b0f806699 Mon Sep 17 00:00:00 2001 From: Miguel R Zuniga Date: Mon, 25 Jul 2022 14:55:02 -0400 Subject: [PATCH 02/37] Added initialization of certain structures to test_output_yaml.F90; also corrected new #define typo from last pull. --- test_fms/parser/test_output_yaml.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/test_fms/parser/test_output_yaml.F90 b/test_fms/parser/test_output_yaml.F90 index 9abc21c3f2..3f00213524 100644 --- a/test_fms/parser/test_output_yaml.F90 +++ b/test_fms/parser/test_output_yaml.F90 @@ -55,7 +55,6 @@ !! \end verbatim !! Great, now I have to create this long yaml for testing, lol. program test_output_yaml -#define use_yaml #ifdef use_yaml use fms_yaml_output_mod From f120ca25407dfc280d0262870a8bfac5f30490af Mon Sep 17 00:00:00 2001 From: ngs333 Date: Wed, 21 Dec 2022 14:49:37 -0500 Subject: [PATCH 03/37] Adding code from previous work. --- diag_manager/diag_manager.F90 | 583 +++++++++ diag_manager/fms_diag_fieldbuff_update.F90 | 98 ++ .../include/fms_diag_fieldbuff_update.fh | 1158 +++++++++++++++++ .../include/fms_diag_fieldbuff_update.inc | 39 + 4 files changed, 1878 insertions(+) create mode 100644 diag_manager/fms_diag_fieldbuff_update.F90 create mode 100644 diag_manager/include/fms_diag_fieldbuff_update.fh create mode 100644 diag_manager/include/fms_diag_fieldbuff_update.inc diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 01f0ad6f8b..d8d8cd7349 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -3119,6 +3119,589 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & DEALLOCATE(oor_mask) END FUNCTION send_data_3d + + !> @return true if send is successful + LOGICAL FUNCTION send_data_3d_refac(diag_field_id, field, time, is_in, js_in, ks_in, & + & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) + INTEGER, INTENT(in) :: diag_field_id + CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field + CLASS(*), INTENT(in), OPTIONAL :: weight + TYPE (time_type), INTENT(in), OPTIONAL :: time + INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask + CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg + + REAL :: weight1 + REAL :: missvalue + INTEGER :: pow_value + INTEGER :: ksr, ker + INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4 + INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k + INTEGER, DIMENSION(3) :: l_start !< local start indices on 3 axes for regional output + INTEGER, DIMENSION(3) :: l_end !< local end indices on 3 axes for regional output + INTEGER :: hi !< halo size in x direction + INTEGER :: hj !< halo size in y direction + INTEGER :: twohi !< halo size in x direction + INTEGER :: twohj !< halo size in y direction + INTEGER :: sample !< index along the diurnal time axis + INTEGER :: day !< components of the current date + INTEGER :: second !< components of the current date + INTEGER :: tick !< components of the current date + INTEGER :: status + INTEGER :: numthreads + INTEGER :: active_omp_level +#if defined(_OPENMP) + INTEGER :: omp_get_num_threads !< OMP function + INTEGER :: omp_get_level !< OMP function +#endif + LOGICAL :: average, phys_window, need_compute + LOGICAL :: reduced_k_range, local_output + LOGICAL :: time_max, time_min, time_rms, time_sum + LOGICAL :: missvalue_present + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: oor_mask + CHARACTER(len=256) :: err_msg_local + CHARACTER(len=128) :: error_string, error_string1 + + REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field + + ! If diag_field_id is < 0 it means that this field is not registered, simply return + IF ( diag_field_id <= 0 ) THEN + send_data_3d = .FALSE. + RETURN + ELSE + send_data_3d = .TRUE. + END IF + + IF ( PRESENT(err_msg) ) err_msg = '' + IF ( .NOT.module_is_initialized ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'diag_manager NOT initialized', err_msg) ) RETURN + END IF + err_msg_local = '' + ! The following lines are commented out as they have not been included in the code prior to now, + ! and there are a lot of send_data calls before register_diag_field calls. A method to do this safely + ! needs to be developed. + ! + ! Set first_send_data_call to .FALSE. on first non-static field. +!!$ IF ( .NOT.input_fields(diag_field_id)%static .AND. first_send_data_call ) THEN +!!$ first_send_data_call = .FALSE. +!!$ END IF + + ! First copy the data to a three d array + ALLOCATE(field_out(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) + IF ( status .NE. 0 ) THEN + WRITE (err_msg_local, FMT='("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')& + & SIZE(field,1), SIZE(field,2), SIZE(field,3), status + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN + END IF + SELECT TYPE (field) + TYPE IS (real(kind=r4_kind)) + field_out = field + TYPE IS (real(kind=r8_kind)) + field_out = real(field) + CLASS DEFAULT + CALL error_mesg ('diag_manager_mod::send_data_3d',& + & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + + ! oor_mask is only used for checking out of range values. + ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) + IF ( status .NE. 0 ) THEN + WRITE (err_msg_local, FMT='("Unable to allocate oor_mask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')& + & SIZE(field,1), SIZE(field,2), SIZE(field,3), status + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN + END IF + + IF ( PRESENT(mask) ) THEN + oor_mask = mask + ELSE + oor_mask = .TRUE. + END IF + + IF ( PRESENT(rmask) ) THEN + SELECT TYPE (rmask) + TYPE IS (real(kind=r4_kind)) + WHERE ( rmask < 0.5_r4_kind ) oor_mask = .FALSE. + TYPE IS (real(kind=r8_kind)) + WHERE ( rmask < 0.5_r8_kind ) oor_mask = .FALSE. + CLASS DEFAULT + CALL error_mesg ('diag_manager_mod::send_data_3d',& + & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + END IF + + ! send_data works in either one or another of two modes. + ! 1. Input field is a window (e.g. FMS physics) + ! 2. Input field includes halo data + ! It cannot handle a window of data that has halos. + ! (A field with no windows or halos can be thought of as a special case of either mode.) + ! The logic for indexing is quite different for these two modes, but is not clearly separated. + ! If both the beggining and ending indices are present, then field is assumed to have halos. + ! If only beggining indices are present, then field is assumed to be a window. + + ! There are a number of ways a user could mess up this logic, depending on the combination + ! of presence/absence of is,ie,js,je. The checks below should catch improper combinations. + IF ( PRESENT(ie_in) ) THEN + IF ( .NOT.PRESENT(is_in) ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'ie_in present without is_in', err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN + IF ( fms_error_handler('diag_manager_modsend_data_3d',& + & 'is_in and ie_in present, but js_in present without je_in', err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + IF ( PRESENT(je_in) ) THEN + IF ( .NOT.PRESENT(js_in) ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'je_in present without js_in', err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d',& + & 'js_in and je_in present, but is_in present without ie_in', err_msg)) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + + ! If is, js, or ks not present default them to 1 + is = 1 + js = 1 + ks = 1 + IF ( PRESENT(is_in) ) is = is_in + IF ( PRESENT(js_in) ) js = js_in + IF ( PRESENT(ks_in) ) ks = ks_in + n1 = SIZE(field, 1) + n2 = SIZE(field, 2) + n3 = SIZE(field, 3) + ie = is+n1-1 + je = js+n2-1 + ke = ks+n3-1 + IF ( PRESENT(ie_in) ) ie = ie_in + IF ( PRESENT(je_in) ) je = je_in + IF ( PRESENT(ke_in) ) ke = ke_in + twohi = n1-(ie-is+1) + IF ( MOD(twohi,2) /= 0 ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in first dimension', & + & err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + twohj = n2-(je-js+1) + IF ( MOD(twohj,2) /= 0 ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in second dimension', & + & err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + hi = twohi/2 + hj = twohj/2 + + ! The next line is necessary to ensure that is,ie,js,ie are relative to field(1:,1:) + ! But this works only when there is no windowing. + IF ( PRESENT(ie_in) .AND. PRESENT(je_in) ) THEN + is=1+hi + ie=n1-hi + js=1+hj + je=n2-hj + END IF + + ! used for field, mask and rmask bounds + f1=1+hi + f2=n1-hi + f3=1+hj + f4=n2-hj + + ! weight is for time averaging where each time level may has a different weight + IF ( PRESENT(weight) ) THEN + SELECT TYPE (weight) + TYPE IS (real(kind=r4_kind)) + weight1 = weight + TYPE IS (real(kind=r8_kind)) + weight1 = real(weight) + CLASS DEFAULT + CALL error_mesg ('diag_manager_mod::send_data_3d',& + & 'The weight is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + ELSE + weight1 = 1. + END IF + + ! Is there a missing_value? + missvalue_present = input_fields(diag_field_id)%missing_value_present + IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value + + number_of_outputs = input_fields(diag_field_id)%num_output_fields +!$OMP CRITICAL + input_fields(diag_field_id)%numthreads = 1 + active_omp_level=0 +#if defined(_OPENMP) + input_fields(diag_field_id)%numthreads = omp_get_num_threads() + input_fields(diag_field_id)%active_omp_level = omp_get_level() +#endif + numthreads = input_fields(diag_field_id)%numthreads + active_omp_level = input_fields(diag_field_id)%active_omp_level +!$OMP END CRITICAL + + if(present(time)) input_fields(diag_field_id)%time = time + + ! Issue a warning if any value in field is outside the valid range + IF ( input_fields(diag_field_id)%range_present ) THEN + IF ( ISSUE_OOR_WARNINGS .OR. OOR_WARNINGS_FATAL ) THEN + WRITE (error_string, '("[",ES14.5E3,",",ES14.5E3,"]")')& + & input_fields(diag_field_id)%range(1:2) + WRITE (error_string1, '("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')& + & MINVAL(field_out(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)),& + & MAXVAL(field_out(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)) + IF ( missvalue_present ) THEN + IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.& + & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.& + & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.& + & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) ) THEN + ! + ! A value for in field (Min: , Max: ) + ! is outside the range [,] and not equal to the missing + ! value. + ! + CALL error_mesg('diag_manager_mod::send_data_3d',& + & 'A value for '//& + &TRIM(input_fields(diag_field_id)%module_name)//' in field '//& + &TRIM(input_fields(diag_field_id)%field_name)//' '& + &//TRIM(error_string1)//& + &' is outside the range '//TRIM(error_string)//',& + & and not equal to the missing value.',& + &OOR_WARNING) + END IF + ELSE + IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.& + & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.& + & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) ) THEN + ! + ! A value for in field (Min: , Max: ) + ! is outside the range [,]. + ! + CALL error_mesg('diag_manager_mod::send_data_3d',& + & 'A value for '//& + &TRIM(input_fields(diag_field_id)%module_name)//' in field '//& + &TRIM(input_fields(diag_field_id)%field_name)//' '& + &//TRIM(error_string1)//& + &' is outside the range '//TRIM(error_string)//'.',& + &OOR_WARNING) + END IF + END IF + END IF + END IF + + ! Loop through each output field that depends on this input field + num_out_fields: DO ii = 1, number_of_outputs + ! Get index to an output field + out_num = input_fields(diag_field_id)%output_fields(ii) + + ! is this field output on a local domain only? + local_output = output_fields(out_num)%local_output + ! if local_output, does the current PE take part in send_data? + need_compute = output_fields(out_num)%need_compute + + reduced_k_range = output_fields(out_num)%reduced_k_range + + ! skip all PEs not participating in outputting this field + IF ( local_output .AND. (.NOT.need_compute) ) CYCLE + + ! Get index to output file for this field + file_num = output_fields(out_num)%output_file + IF(file_num == max_files) CYCLE + ! Output frequency and units for this file is + freq = files(file_num)%output_freq + units = files(file_num)%output_units + ! Is this output field being time averaged? + average = output_fields(out_num)%time_average + ! Is this output field the rms? + ! If so, then average is also .TRUE. + time_rms = output_fields(out_num)%time_rms + ! Power value for rms or pow(x) calculations + pow_value = output_fields(out_num)%pow_value + ! Looking for max and min value of this field over the sampling interval? + time_max = output_fields(out_num)%time_max + time_min = output_fields(out_num)%time_min + ! Sum output over time interval + time_sum = output_fields(out_num)%time_sum + IF ( output_fields(out_num)%total_elements > SIZE(field_out(f1:f2,f3:f4,ks:ke)) ) THEN + output_fields(out_num)%phys_window = .TRUE. + ELSE + output_fields(out_num)%phys_window = .FALSE. + END IF + phys_window = output_fields(out_num)%phys_window + IF ( need_compute ) THEN + l_start = output_fields(out_num)%output_grid%l_start_indx + l_end = output_fields(out_num)%output_grid%l_end_indx + END IF + + ! compute the diurnal index + sample = 1 + IF ( PRESENT(time) ) THEN + CALL get_time(time,second,day,tick) ! current date + sample = floor( (second+real(tick)/get_ticks_per_second()) & + & * output_fields(out_num)%n_diurnal_samples/SECONDS_PER_DAY) + 1 + END IF + + ! Get the vertical layer start and end index. + IF ( reduced_k_range ) THEN +!---------- +!ug support + if (output_fields(out_num)%reduced_k_unstruct) then + js = output_fields(out_num)%output_grid%l_start_indx(2) + je = output_fields(out_num)%output_grid%l_end_indx(2) + endif + l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3) + l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3) +!---------- + END IF + ksr= l_start(3) + ker= l_end(3) + + ! Initialize output time for fields output every time step + IF ( freq == EVERY_TIME .AND. .NOT.output_fields(out_num)%static ) THEN + IF (output_fields(out_num)%next_output == output_fields(out_num)%last_output) THEN + IF(PRESENT(time)) THEN + output_fields(out_num)%next_output = time + ELSE + WRITE (error_string,'(a,"/",a)')& + & TRIM(input_fields(diag_field_id)%module_name),& + & TRIM(output_fields(out_num)%output_name) + IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& + & ', time must be present when output frequency = EVERY_TIME', err_msg)) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + END IF + IF ( .NOT.output_fields(out_num)%static .AND. .NOT.PRESENT(time) ) THEN + WRITE (error_string,'(a,"/",a)')& + & TRIM(input_fields(diag_field_id)%module_name), & + & TRIM(output_fields(out_num)%output_name) + IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& + & ', time must be present for nonstatic field', err_msg)) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + + ! Is it time to output for this field; CAREFUL ABOUT > vs >= HERE + !--- The fields send out within openmp parallel region will be written out in + !--- diag_send_complete. + IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) ) then + IF ( .NOT.output_fields(out_num)%static .AND. freq /= END_OF_RUN ) THEN + IF ( time > output_fields(out_num)%next_output ) THEN + ! A non-static field that has skipped a time level is an error + IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 ) THEN + IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN + WRITE (error_string,'(a,"/",a)')& + & TRIM(input_fields(diag_field_id)%module_name), & + & TRIM(output_fields(out_num)%output_name) + IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//& + & TRIM(error_string)//' is skipped one time level in output data', err_msg)) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + + status = writing_field(out_num, .FALSE., error_string, time) + IF(status == -1) THEN + IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN + IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//TRIM(error_string)& + & //', write EMPTY buffer', err_msg)) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + END IF !time > output_fields(out_num)%next_output + END IF !.not.output_fields(out_num)%static .and. freq /= END_OF_RUN + ! Finished output of previously buffered data, now deal with buffering new data + END IF + + IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN + CALL check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg=err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + + !!CALL FIELD WHEITING FUNCTIONS:!!START REFACTORED SECTION WITH WEIGHTING FUNCTIONS.!! + ALLOCATE(sprocs_obj) + CALL sprocs_obj%initialize(is, js, ks, ie, je, ke, & + & hi, hj, f1, f2, f3, f4, & + & output_fields(out_num)%pow_value, output_fields(out_num)%phys_window, & + & output_fields(out_num)%need_compute,output_fields(out_num)%reduced_k_range, & + & output_fields(out_num)%time_rms, output_fields(out_num)%time_max, & + & output_fields(out_num)%time_min, output_fields(out_num)%time_sum) + + ! Take care of submitted field data + IF ( average ) THEN + temp_result = sprocs_obj%average_the_field(diag_field_id, field_out, sample, & + & output_fields(out_num)%buffer, output_fields(out_num)%counter, & + & output_fields(out_num)%ntval, output_fields(out_num)%count_0d(sample), & + & output_fields(out_num)%num_elements(sample), output_fields(out_num)%output_name, & + & input_fields(diag_field_id)%field_name, input_fields(diag_field_id)%module_name, & + & input_fields(diag_field_id)%issued_mask_ignore_warning, & + & mask, weight1, missvalue, missvalue_present, & + & l_start, l_end, err_msg, err_msg_local ) + IF (temp_result .eqv. .FALSE.) THEN + DEALLOCATE(oor_mask) + RETURN + END IF + ! Add processing for Max and Min + ELSE !!.NOT. average + temp_result = sprocs_obj%sample_the_field(diag_field_id, field_out, & + & sample, output_fields(out_num)%buffer, output_fields(out_num)%ntval, & + & output_fields(out_num)%count_0d(sample), & + & output_fields(out_num)%output_name,input_fields(diag_field_id)%module_name, mask, & + & missvalue, missvalue_present, l_start, l_end, err_msg, err_msg_local) + IF (temp_result .eqv. .FALSE.) THEN + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + DEALLOCATE(sprocs_obj) + !!END REFACTORED SECTION WITH WEIGHTING FUNCTIONS - END + + IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN + CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg)) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + END IF + + ! If rmask and missing value present, then insert missing value + IF ( PRESENT(rmask) .AND. missvalue_present ) THEN + IF ( need_compute ) THEN + SELECT TYPE (rmask) + TYPE IS (real(kind=r4_kind)) + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) & + & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue + END IF + END DO + END DO + END DO + TYPE IS (real(kind=r8_kind)) + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) & + & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue + END IF + END DO + END DO + END DO + CLASS DEFAULT + CALL error_mesg ('diag_manager_mod::send_data_3d',& + & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + SELECT TYPE (rmask) + TYPE IS (real(kind=r4_kind)) + DO k= ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) & + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue + END DO + END DO + END DO + TYPE IS (real(kind=r8_kind)) + DO k= ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) & + & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue + END DO + END DO + END DO + CLASS DEFAULT + CALL error_mesg ('diag_manager_mod::send_data_3d',& + & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + ELSE + SELECT TYPE (rmask) + TYPE IS (real(kind=r4_kind)) + DO k=ks, ke + DO j=js, je + DO i=is, ie + IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) & + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue + END DO + END DO + END DO + TYPE IS (real(kind=r8_kind)) + DO k=ks, ke + DO j=js, je + DO i=is, ie + IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) & + & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue + END DO + END DO + END DO + CLASS DEFAULT + CALL error_mesg ('diag_manager_mod::send_data_3d',& + & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + END SELECT + END IF + END IF + + END DO num_out_fields + + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + END FUNCTION send_data_3d_refac + + !> @return true if send is successful LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask ) INTEGER, INTENT(in) :: id !< id od the diagnostic field diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 new file mode 100644 index 0000000000..d382bb6716 --- /dev/null +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -0,0 +1,98 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_fieldbuff_update_mod fms_diag_fieldbuff_update_mod +!> @ingroup diag_manager +!> @brief fms_diag_fieldbuff_update_mod Contains routines for updating the +!! buffer (array) of field data statistics (e.g. average, rms) with new field data. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_fieldbuff_update_mod contains routines for updating the buffer +!!(array) of field data statistics (e.g. average, rms) with new field data. These +!! routines are called by the send_data routines in the diag_manager. +!! +!> @file +!> @brief File for @ref fms_diag_fieldbuff_update_mod +!> @addtogroup fms_diag_fieldbuff_update_mod +!> @{ +MODULE fms_diag_fieldbuff_update_mod +#ifdef use_yaml + USE platform_mod + USE mpp_mod, ONLY: mpp_pe, mpp_root_pe + USE time_manager_mod, ONLY: time_type + USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,fms_error_handler + USE diag_data_mod, ONLY: debug_diag_manager, fms_diag_buff_intervals_t + USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_type, fms_diag_outfield_index_type + USE diag_util_mod, ONLY: check_out_of_bounds_m, update_bounds_m + USE fms_diag_field_object_mod, ONLY: fmsDiagField_type + + implicit none + + !> @brief Interface fieldbuff_update updates elements of field output buffer based on input field + !! data and mathematical operations on the field data. + !> @ingroup fms_diag_fieldbuff_update_mod + interface fieldbuff_update + !< r4 version of the interface + module procedure fieldbuff_update_r4 + !< r8 version of the interface + module procedure fieldbuff_update_r8 + !< i4 version of the interface + module procedure fieldbuff_update_i4 + !< i8 version of the interface + module procedure fieldbuff_update_i8 + end interface + + !> @brief Interface fieldbuff_copy_misvals updates elements of the field output buffer with + !! with the missvalue input argument. + !> @ingroup fms_diag_fieldbuff_update_mod + interface fieldbuff_copy_misvals + !< r4 version of the interface + module procedure fieldbuff_copy_misvals_r4 + !< r8 version of the interface + module procedure fieldbuff_copy_misvals_r8 + !< i4 version of the interface + module procedure fieldbuff_copy_misvals_i4 + !< i8 version of the interface + module procedure fieldbuff_copy_misvals_i8 + end interface + + !> @brief Interface fieldbuff_copy_fieldvals updates elements of the field output buffer with + !! with copies of correspondind element values in the input field data. + !> @ingroup fms_diag_fieldbuff_update_mod + interface fieldbuff_copy_fieldvals + !< r4 version of the interface + module procedure fieldbuff_copy_fieldvals_r4 + !< r8 version of the interface + module procedure fieldbuff_copy_fieldvals_r8 + !< i4 version of the interface + module procedure fieldbuff_copy_fieldvals_i4 + !< i8 version of the interface + module procedure fieldbuff_copy_fieldvals_i8 + end interface + +contains + +#include + +#endif + +END MODULE fms_diag_fieldbuff_update_mod +!> @} +! close documentation grouping diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh new file mode 100644 index 0000000000..9a80547000 --- /dev/null +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -0,0 +1,1158 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** +!! +!> @brief Updates elements of the running field output buffer (argument ofb) +!! and counter (argument ofc) based on the input field data array (argument field_d). +!! In general the formulas are : +!! A) ofb(l) = ofb(l) + (weight * field(l))**pow_value +!! B) ofc(l) = ofc(l) + weight +!! where l is a standing for some set of indecies in multiple dimensions. +!! Note this function may set field object members active_omp_level and num_threads. +!> @addtogroup fms_diag_fieldbuff_update_mod +!> @{ + FUNCTION FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_obj, field_d, sample, & + & ofb, ofc, ntval, count_0d, num_elements, mask, weight1, missvalue, missvalue_present, & + & l_start, l_end, err_msg, err_msg_local ) result( succeded ) + TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object + TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object + TYPE(fmsDiagField_type), INTENT(inout) :: field_obj !< The field object + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< Output Field Buffer + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofc !< Output Field Counter + TYPE(fms_diag_buff_intervals_t), INTENT(inout) :: ntval !< An instance of the class fms_diag_buff_intervals_t + INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. + INTEGER, INTENT(inout) :: num_elements + + LOGICAL, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask !< mask + REAL, INTENT(in) :: weight1 !< Field data is multiplied by weight !!TODO: Change to same type as field data? + FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. + LOGICAL, INTENT(in) :: missvalue_present !< .true. if missvalue is present. + INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on 3 axes for regional output + INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on 3 axes for regional output + CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg + CHARACTER(len=*), INTENT(inout) :: err_msg_local + + INTEGER :: pow_value !< A copy of same variable in ofield_cfg + CHARACTER(:), ALLOCATABLE :: output_name !< A copy of same variable in ofield_cfg + CHARACTER(:), ALLOCATABLE :: field_name !< A copy of same variable in ofield_cfg + CHARACTER(:), ALLOCATABLE :: module_name !< A copy of same variable in ofield_cfg + LOGICAL :: phys_window !< A copy of same variable in ofield_cfg + LOGICAL :: need_compute !< A copy of same variable in ofield_cfg + LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg + + !> The indecies copied directly from the ofield_index_cfg: + INTEGER:: is, js, ks, ls, ie, je, ke, le, hi, hj, f1, f2, f3, f4 + + INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations + !> Looping indecies, derived from ofield_index_cfg: + INTEGER :: i, j, k, i1, j1, k1 + + LOGICAL :: succeded !> True iff no errors encountered. + CHARACTER(len=128):: error_string + + INTEGER :: numthreads + INTEGER :: active_omp_level +#if defined(_OPENMP) + INTEGER :: omp_get_num_threads !< OMP function + INTEGER :: omp_get_level !< OMP function +#endif + + !!TODO: Update all of 4th dim via ":", or pass "ls:le" of L do loop" ? + !!Currently see where clause in loops, optionally use ls = 1, le = SIZE(field_d, 4) + + ksr= l_start(3) + ker= l_end(3) + is = ofield_index_cfg%is + js = ofield_index_cfg%js + ks = ofield_index_cfg%ks + ie = ofield_index_cfg%ie + je = ofield_index_cfg%je + ke = ofield_index_cfg%ke + hi = ofield_index_cfg%hi + hj = ofield_index_cfg%hj + f1 = ofield_index_cfg%f1 + f2 = ofield_index_cfg%f2 + f3 = ofield_index_cfg%f3 + f4 = ofield_index_cfg%f4 + + output_name = trim(ofield_cfg%output_name) + field_name = trim(ofield_cfg%field_name) + module_name = trim(ofield_cfg%module_name) + pow_value = ofield_cfg%pow_value + phys_window = ofield_cfg%phys_window + reduced_k_range = ofield_cfg%reduced_k_range + need_compute = ofield_cfg%need_compute + +!$OMP CRITICAL + call field_obj%set_num_threads (1) + call field_obj%set_active_omp_level (0) +#if defined(_OPENMP) + call field_obj%set_num_threads (omp_get_num_threads()) + call field_obj%set_active_omp_level (omp_get_level()) +#endif + numthreads = field_obj%get_num_threads() + active_omp_level = field_obj%get_active_omp_level() +!$OMP END CRITICAL + + MASK_VAR_IF: IF ( field_obj%has_mask_variant() ) THEN + IF ( need_compute ) THEN + WRITE (error_string,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& + & ', regional output NOT supported with mask_variant', err_msg)) THEN + !!DEALLOCATE(oor_mask) + succeded = .FALSE. + RETURN + END IF + END IF + + ! Should reduced_k_range data be supported with the mask_variant option ????? + ! If not, error message should be produced and the reduced_k_range loop below eliminated + MASK_PR_1_IF: IF ( PRESENT(mask) ) THEN + MISSVAL_PR_1_IF: IF ( missvalue_present ) THEN !!(section: mask_varian .eq. true + mask present) + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + !! + IF( numthreads>1 .AND. phys_window ) then + REDU_KR1_IF: IF ( reduced_k_range ) THEN + DO k= ksr, ker + k1= k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) +& + & (field_d(i-is+1+hi, j-js+1+hj, k, :) * weight1) ** pow_value + ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 + END where + END DO + END DO + END DO + ELSE REDU_KR1_IF + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) + & + & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofc(i-hi,j-hj,k,:,sample) = ofc(i-hi,j-hj,k,:,sample) + weight1 + END where + END DO + END DO + END DO + END IF REDU_KR1_IF + ELSE +!$OMP CRITICAL + REDU_KR2_IF: IF ( reduced_k_range ) THEN + DO k= ksr, ker + k1= k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) + & + & (field_d(i-is+1+hi, j-js+1+hj, k, :) * weight1) ** pow_value + ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 + END where + END DO + END DO + END DO + ELSE REDU_KR2_IF + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) + & + & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofc(i-hi,j-hj,k,:,sample) = ofc(i-hi,j-hj,k,:,sample) + weight1 + END where + END DO + END DO + END DO + END IF REDU_KR2_IF +!$OMP END CRITICAL + END IF + ELSE MISSVAL_PR_1_IF + WRITE (error_string,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + IF(fms_error_handler('diag_manager_mod::send_data_3d', & + & 'module/output_field '//TRIM(error_string)//', variable mask but no missing value defined', & + & err_msg)) THEN + succeded = .FALSE. + RETURN + END IF + END IF MISSVAL_PR_1_IF + ELSE MASK_PR_1_IF ! no mask present + WRITE (error_string,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//TRIM(error_string)//& + & ', variable mask but no mask given', err_msg)) THEN + succeded = .FALSE. + RETURN + END IF + END IF MASK_PR_1_IF + ELSE MASK_VAR_IF + MASK_PR_2_IF: IF ( PRESENT(mask) ) THEN + MISSVAL_PR_2_IF: IF ( missvalue_present ) THEN !!section:(mask_var false +mask present +missval prsnt) + NDCMP_RKR_1_IF: IF ( need_compute ) THEN + IF (numthreads>1 .AND. phys_window) then + DO k = l_start(3), l_end(3) + k1 = k-l_start(3)+1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i1,j1,k1,:,sample) = ofb(i1,j1,k1,:,sample) +& + & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k = l_start(3), l_end(3) + k1 = k-l_start(3)+1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) + ofb(i1,j1,k1,:,sample) = ofb(i1,j1,k1,:,sample) + & + & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ENDIF +!$OMP CRITICAL + DO j = js, je + DO i = is, ie + 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 + num_elements = num_elements + l_end(3) - l_start(3) + 1 + END IF + END DO + END DO +!$OMP END CRITICAL + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_1_IF + IF (numthreads>1 .AND. phys_window) then + DO k=ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) + & + & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i-hi,j-hj,k1,:,sample)= missvalue + END where + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k=ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) + & + & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i-hi,j-hj,k1,:,sample)= missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF + ELSE NDCMP_RKR_1_IF + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF (numthreads>1 .AND. phys_window) then + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) + & + & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i-hi,j-hj,k,:,sample)= missvalue + END where + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) + ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) + & + & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i-hi,j-hj,k,:,sample)= missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF + END IF NDCMP_RKR_1_IF +!$OMP CRITICAL + IF ( need_compute .AND. .NOT.phys_window ) THEN + 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), :)) ) & + count_0d = count_0d + weight1 + ELSE + IF ( ANY(mask(f1:f2,f3:f4,ks:ke,:)) ) count_0d = count_0d + weight1 + END IF +!$OMP END CRITICAL + ELSE MISSVAL_PR_2_IF !! (section: mask_varian .eq. false + mask present + miss value not present) + IF ( (.NOT.ALL(mask(f1:f2,f3:f4,ks:ke,:)) .AND. mpp_pe() .EQ. mpp_root_pe()).AND.& + & .NOT. field_obj%get_issued_mask_ignore_warning() ) THEN + ! + ! Mask will be ignored since missing values were not specified for field + ! in module + ! + CALL error_mesg('diag_manager_mod::send_data_3d',& + & 'Mask will be ignored since missing values were not specified for field '//& + & trim(field_name)//' in module '//& + & trim(module_name), WARNING) + CALL field_obj%set_issued_mask_ignore_warning(.TRUE.) + END IF + NDCMP_RKR_2_IF: IF ( need_compute ) THEN + IF (numthreads>1 .AND. phys_window) then + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + ofb(i1,j1,:,:,sample)= ofb(i1,j1,:,:,sample)+ & + & (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value + END IF + END DO + END DO + ELSE +!$OMP CRITICAL + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + ofb(i1,j1,:,:,sample) = ofb(i1,j1,:,:,sample) + & + & (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value + END IF + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO j = js, je + DO i = is, ie + 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 + num_elements = num_elements + l_end(3)-l_start(3)+1 + END IF + END DO + END DO +!$OMP END CRITICAL + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_2_IF + IF (numthreads>1 .AND. phys_window) then + ksr= l_start(3) + ker= l_end(3) + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) +& + & (field_d(f1:f2,f3:f4,ksr:ker, :) * weight1) ** pow_value + ELSE +!$OMP CRITICAL + ksr= l_start(3) + ker= l_end(3) + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) +& + & (field_d(f1:f2,f3:f4,ksr:ker,:) * weight1) ** pow_value +!$OMP END CRITICAL + END IF + ELSE NDCMP_RKR_2_IF + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '') THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF (numthreads>1 .AND. phys_window) then + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) +& + & (field_d(f1:f2,f3:f4,ks:ke,:) * weight1) ** pow_value + ELSE +!$OMP CRITICAL + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) +& + & (field_d(f1:f2,f3:f4,ks:ke,:) * weight1) ** pow_value +!$OMP END CRITICAL + END IF + END IF NDCMP_RKR_2_IF +!$OMP CRITICAL + IF ( .NOT.phys_window ) count_0d = count_0d + weight1 +!$OMP END CRITICAL + END IF MISSVAL_PR_2_IF + ELSE MASK_PR_2_IF !!(section: mask_variant .eq. false + mask not present + missvalue) + MISSVAL_PR_3_IF: IF (missvalue_present ) THEN + NDCMP_RKR_3_IF: IF ( need_compute ) THEN + NTAPW_IF: If( numthreads>1 .AND. phys_window ) then + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i1,j1,k1,:,sample) = ofb(i1,j1,k1,:,sample) + & + & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO + ELSE NTAPW_IF +!$OMP CRITICAL + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i1,j1,k1,:,sample) = ofb(i1,j1,k1,:,sample) + & + & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i1,j1,k1,:,sample) = missvalue + END where + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + END IF NTAPW_IF +!$OMP CRITICAL + DO j = js, je + DO i = is, ie + 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 + num_elements = num_elements + l_end(3) - l_start(3) + 1 + END IF + END DO + END DO + IF ( .NOT.phys_window ) THEN + DO k = l_start(3), l_end(3) + DO j=l_start(2)+hj, l_end(2)+hj + DO i=l_start(1)+hi, l_end(1)+hi + IF ( ANY (field_d(i,j, k, :) /= missvalue )) THEN + count_0d = count_0d + weight1 + EXIT + END IF + END DO + END DO + END DO + END IF +!$OMP END CRITICAL + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_3_IF + if( numthreads>1 .AND. phys_window ) then + ksr= l_start(3) + ker= l_end(3) + DO k = ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) + & + & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i-hi,j-hj,k1,:,sample) = missvalue + END where + END DO + END DO + END DO + else +!$OMP CRITICAL + ksr= l_start(3) + ker= l_end(3) + DO k = ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) +& + & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i-hi,j-hj,k1,:,sample) = missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO k = ksr, ker + k1=k-ksr+1 + DO j=f3, f4 + DO i=f1, f2 + !! TODO: verify this below + IF ( ANY (field_d(i,j, k, :) /= missvalue )) THEN + count_0d = count_0d + weight1 + EXIT + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + ELSE NDCMP_RKR_3_IF + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF( numthreads > 1 .AND. phys_window ) then + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) +& + & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i-hi,j-hj,k,:,sample) = missvalue + END where + END DO + END DO + END DO + ELSE +!$OMP CRITICAL + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) + ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) +& + & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + elsewhere + ofb(i-hi,j-hj,k,:,sample) = missvalue + END where + END DO + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO k=ks, ke + DO j=f3, f4 + DO i=f1, f2 + IF ( any (field_d(i,j, k, :) /= missvalue )) THEN + count_0d = count_0d + weight1 + EXIT + END IF + END DO + END DO + END DO +!$OMP END CRITICAL + END IF NDCMP_RKR_3_IF + ELSE MISSVAL_PR_3_IF !!(section: mask_variant .eq. false + mask not present + missvalue not present) + NDCMP_RKR_4_IF: IF ( need_compute ) THEN + IF( numthreads > 1 .AND. phys_window ) then + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + ofb(i1,j1,:,:,sample) = ofb(i1,j1,:,:,sample) + & + & (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value + END IF + END DO + END DO + ELSE +!$OMP CRITICAL + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + ofb(i1,j1,:,:,sample)= ofb(i1,j1,:,:,sample) +& + & (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value + END IF + END DO + END DO +!$OMP END CRITICAL + END IF +!$OMP CRITICAL + DO j = js, je + DO i = is, ie + 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 + num_elements = num_elements + l_end(3)-l_start(3)+1 + END IF + END DO + END DO +!$OMP END CRITICAL + ! Accumulate time average + ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_4_IF + ksr= l_start(3) + ker= l_end(3) + IF( numthreads > 1 .AND. phys_window ) then + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) =& + & ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & + & (field_d(f1:f2,f3:f4,ksr:ker, :) * weight1) ** pow_value + ELSE +!$OMP CRITICAL + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) =& + & ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & + & (field_d(f1:f2,f3:f4,ksr:ker, :) * weight1) ** pow_value +!$OMP END CRITICAL + END IF + + ELSE NDCMP_RKR_4_IF + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF (fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + IF( numthreads > 1 .AND. phys_window ) then + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) +& + & (field_d(f1:f2,f3:f4,ks:ke, :) * weight1) ** pow_value + ELSE +!$OMP CRITICAL + ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& + & ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) +& + & (field_d(f1:f2,f3:f4,ks:ke, :) * weight1) ** pow_value + !! +!$OMP END CRITICAL + END IF + END IF NDCMP_RKR_4_IF +!$OMP CRITICAL + IF ( .NOT.phys_window ) count_0d = count_0d + weight1 +!$OMP END CRITICAL + END IF MISSVAL_PR_3_IF + END IF MASK_PR_2_IF ! if mask present + END IF MASK_VAR_IF + +!$OMP CRITICAL + IF ( .NOT.need_compute .AND. .NOT.reduced_k_range ) num_elements = num_elements + (ie-is+1)*(je-js+1)*(ke-ks+1) + IF ( reduced_k_range ) num_elements = num_elements + (ie-is+1)*(je-js+1)*(ker-ksr+1) +!$OMP END CRITICAL + + succeded = .TRUE. + RETURN + + END FUNCTION FMS_DIAG_FBU_PNAME_ + + +!> \Description May set or add to the output field buffer (argument ofb) with the input +!! field data array (argument field) +FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & + & ntval, count_0d, mask, missvalue, missvalue_present, & + & l_start, l_end, err_msg, err_msg_local) result( succeded ) + TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object + TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:), INTENT(in) :: field !< The field value array. + INTEGER, INTENT(in) :: sample !< index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< The Output Field Buffer + TYPE(fms_diag_buff_intervals_t), INTENT(inout) :: ntval + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !> Normally the member of the buffer of same name, + LOGICAL, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !> buffer may be set to this value where mask is false. + LOGICAL, INTENT(in) :: missvalue_present + INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output + INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output + CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg + CHARACTER(len=*), INTENT(inout) :: err_msg_local + LOGICAL :: succeded !> Return true iff errors are not encounterd. + !! + !! + !> The indecies copied directly from the ofield_index_cfg + INTEGER :: is, js, ks, ie, je, ke, hi, hj, f1, f2, f3, f4 + + LOGICAL :: need_compute !< A copy of same variable in ofield_cfg + LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg + + INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations + !> Looping indecies, derived from ofield_index_cfg: + INTEGER :: i, j, k, i1, j1, k1 + + CHARACTER(:), ALLOCATABLE :: output_name + CHARACTER(:), ALLOCATABLE :: module_name + LOGICAL :: time_max, time_min, time_sum + + ksr= l_start(3) + ker= l_end(3) + + is = ofield_index_cfg%is + js = ofield_index_cfg%js + ks = ofield_index_cfg%ks + ie = ofield_index_cfg%ie + je = ofield_index_cfg%je + ke = ofield_index_cfg%ke + hi = ofield_index_cfg%hi + hj = ofield_index_cfg%hj + f1 = ofield_index_cfg%f1 + f2 = ofield_index_cfg%f2 + f3 = ofield_index_cfg%f3 + f4 = ofield_index_cfg%f4 + + time_max = ofield_cfg%time_reduction%is_time_max() !!TODO: + time_min = ofield_cfg%time_reduction%is_time_min() + time_sum = ofield_cfg%time_reduction%is_time_sum() + + output_name = trim(ofield_cfg%output_name) + module_name = trim(ofield_cfg%module_name) + reduced_k_range = ofield_cfg%reduced_k_range + need_compute = ofield_cfg%need_compute + + ! Add processing for Max and Min + TIME_IF: IF ( time_max ) THEN + MASK_PRSNT_1_IF: IF ( PRESENT(mask) ) THEN + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .AND.& + & field(i-is+1+hi,j-js+1+hj,k,:)>OFB(i1,j1,k1,:,sample)) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Maximum time value with masking + ELSE IF ( reduced_k_range ) THEN + ksr = l_start(3) + ker = l_end(3) + WHERE ( mask(f1:f2,f3:f4,ksr:ker,:) .AND. & + & field(f1:f2,f3:f4,ksr:ker,:) > OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE ( mask(f1:f2,f3:f4,ks:ke,:) .AND.& + & field(f1:f2,f3:f4,ks:ke,:)>OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + ELSE MASK_PRSNT_1_IF + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + WHERE ( field(i-is+1+hi,j-js+1+hj,k,:) > OFB(i1,j1,k1,:,sample) ) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Maximum time value + ELSE IF ( reduced_k_range ) THEN + ksr = l_start(3) + ker = l_end(3) + WHERE ( field(f1:f2,f3:f4,ksr:ker,:) > OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) )& + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE (field(f1:f2,f3:f4,ks:ke,:) > OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + END IF MASK_PRSNT_1_IF + count_0d = 1 + !END TIME MAX + ELSE IF ( time_min ) THEN TiME_IF + MASK_PRSNT_2_IF: IF ( PRESENT(mask) ) THEN + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .AND.& + & field(i-is+1+hi,j-js+1+hj,k,:) < OFB(i1,j1,k1,:,sample) ) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Minimum time value with masking + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + WHERE ( mask(f1:f2,f3:f4,ksr:ker,:) .AND.& + & field(f1:f2,f3:f4,ksr:ker,:) < OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample)) & + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE ( mask(f1:f2,f3:f4,ks:ke,:) .AND.& + & field(f1:f2,f3:f4,ks:ke,:) < OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + ELSE MASK_PRSNT_2_IF + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + WHERE ( field(i-is+1+hi,j-js+1+hj,k,:) < OFB(i1,j1,k1,:,sample) ) + OFB(i1,j1,k1,:,sample) = field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Minimum time value + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + WHERE ( field(f1:f2,f3:f4,ksr:ker,:) < OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) )& + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE (field(f1:f2,f3:f4,ks:ke,:) < OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample))& + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + END IF MASK_PRSNT_2_IF + count_0d = 1 + + !! END_TIME_MIN + ELSE IF ( time_sum ) THEN TIME_IF + MASK_PRSNT_3_IF: IF ( PRESENT(mask) ) THEN + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) ) + OFB(i1,j1,k1,:,sample) = OFB(i1,j1,k1,:,sample) + field(i-is+1+hi,j-js+1+hj,k,:) + END WHERE + END IF + END DO + END DO + END DO + ! Minimum time value with masking + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = & + & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & + & field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + WHERE ( mask(f1:f2,f3:f4,ks:ke,:) ) & + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = & + & OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) + & + & field(f1:f2,f3:f4,ks:ke,:) + END IF + ELSE MASK_PRSNT_3_IF + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1= j-l_start(2)-hj+1 + OFB(i1,j1,k1,:,sample) = OFB(i1,j1,k1,:,sample) + field(i-is+1+hi,j-js+1+hj,k,:) + END IF + END DO + END DO + END DO + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & + & field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) + & + & field(f1:f2,f3:f4,ks:ke, :) + END IF + END IF MASK_PRSNT_3_IF + count_0d = 1 + !END time_sum + ELSE TIME_IF !! ( not average, not min, not max, not sum ) + count_0d = 1 + IF ( need_compute ) THEN + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + OFB(i1,j1,:,:,sample) = field(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3),:) + END IF + END DO + END DO + ! instantaneous output + ELSE IF ( reduced_k_range ) THEN + ksr = l_start(3) + ker = l_end(3) + OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) + ELSE + IF ( debug_diag_manager ) THEN + CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN + succeded = .FALSE. + RETURN + END IF + END IF + END IF + OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) + END IF + + IF ( PRESENT(mask) .AND. missvalue_present ) THEN + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + !!TODO: Make sure this where is appropritate with .NOT. + WHERE ( .NOT.mask(i-is+1+hi,j-js+1+hj,k,:) ) & + & OFB(i1,j1,k1,:,sample) = missvalue + END IF + END DO + END DO + END DO + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + DO k=ksr, ker + k1= k - ksr + 1 + DO j=js, je + DO i=is, ie + !!TODO: Make sure this where is appropritate with .NOT. + WHERE ( mask(i-is+1+hi,j-js+1+hj,k,:) .eqv. .false.) & + & OFB(i-hi,j-hj,k1,:,sample)= missvalue + END DO + END DO + END DO + ELSE + DO k=ks, ke + DO j=js, je + DO i=is, ie + !!TODO: Make sure this where is appropritate with .NOT. + WHERE ( .NOT. mask(i-is+1+hi,j-js+1+hj,k,:) )& + & OFB(i-hi,j-hj,k,:,sample)= missvalue + END DO + END DO + END DO + END IF + END IF + END IF TIME_IF + succeded = .TRUE. + RETURN + + END FUNCTION FMS_DIAG_FBCF_PNAME_ + + + !> \Description Updates where appropriate and depending on the rmask argument, + !! elements of the running field output buffer (argument buffer) with value missvalue. + !! NOTE: It appears these OFB updates were introcuded by EMC MM into the tail end of the + !! legacy send_data_3d. + SUBROUTINE FMS_DIAG_FBCM_PNAME_ (is, js, ks, & + & ie, je, ke, hi, hj, sample, l_start, l_end, & + & buffer, rmask, rmask_thresh, missvalue, & + & need_compute, reduced_k_range) + INTEGER, INTENT(in):: is, js, ks, ie, je, ke, hi, hj + INTEGER, INTENT(in) :: sample !< index along the diurnal time axis + INTEGER, INTENT(in), DIMENSION(3):: l_start !< local start indices on 3 axes for regional output + INTEGER, INTENT(in), DIMENSION(3):: l_end !< local end indices on 3 axes for regional output + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in), DIMENSION(:,:,:,:):: rmask !< Updates where rmask < rmask_thresh + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout), DIMENSION(:,:,:,:,:) :: buffer !< the buffer to update + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in), TARGET :: missvalue !< Value used to update the buffer. + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in), TARGET :: rmask_thresh !< Updates where rmask < rmask_thresh + LOGICAL, INTENT(in) :: need_compute + LOGICAL, INTENT(in) :: reduced_k_range + !! + !! + INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations + !> Looping indecies, derived from ofield_index_cfg: + INTEGER :: i, j, k, i1, j1, k1 + + associate(ofb => buffer) + + ! If rmask and missing value present, then insert missing value + IF ( need_compute ) THEN + DO k = l_start(3), l_end(3) + k1 = k - l_start(3) + 1 + DO j = js, je + DO i = is, ie + 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 + i1 = i-l_start(1)-hi+1 + j1 = j-l_start(2)-hj+1 + where ( rmask(i-is+1+hi,j-js+1+hj,k,:) <= rmask_thresh ) + ofb(i1,j1,k1,:,sample) = missvalue + end where + END IF + END DO + END DO + END DO + ELSE IF ( reduced_k_range ) THEN + ksr= l_start(3) + ker= l_end(3) + DO k= ksr, ker + k1 = k - ksr + 1 + DO j=js, je + DO i=is, ie + where ( rmask(i-is+1+hi,j-js+1+hj,k,:) <= rmask_thresh ) + ofb(i-hi,j-hj,k1,:,sample)= missvalue + endwhere + END DO + END DO + END DO + ELSE + DO k=ks, ke + DO j=js, je + DO i=is, ie + where ( rmask(i-is+1+hi,j-js+1+hj,k,:) <= rmask_thresh ) + ofb(i-hi,j-hj,k,:,sample)= missvalue + endwhere + END DO + END DO + END DO + END IF + end associate + END SUBROUTINE FMS_DIAG_FBCM_PNAME_ + !> @} diff --git a/diag_manager/include/fms_diag_fieldbuff_update.inc b/diag_manager/include/fms_diag_fieldbuff_update.inc new file mode 100644 index 0000000000..52363beca1 --- /dev/null +++ b/diag_manager/include/fms_diag_fieldbuff_update.inc @@ -0,0 +1,39 @@ +#undef FMS_DIAG_FBU_DATA_TYPE_ +#define FMS_DIAG_FBU_DATA_TYPE_ REAL(r4_kind) +#undef FMS_DIAG_FBU_PNAME_ +#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r4 +#undef FMS_DIAG_FBCF_PNAME_ +#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r4 +#undef FMS_DIAG_FBCM_PNAME_ +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_r4 +#include + +#undef FMS_DIAG_FBU_DATA_TYPE_ +#define FMS_DIAG_FBU_DATA_TYPE_ REAL(r8_kind) +#undef FMS_DIAG_FBU_PNAME_ +#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r8 +#undef FMS_DIAG_FBCF_PNAME_ +#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r8 +#undef FMS_DIAG_FBCM_PNAME_ +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_r8 +#include + +#undef FMS_DIAG_FBU_DATA_TYPE_ +#define FMS_DIAG_FBU_DATA_TYPE_ INTEGER(i4_kind) +#undef FMS_DIAG_FBU_PNAME_ +#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_i4 +#undef FMS_DIAG_FBCF_PNAME_ +#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_i4 +#undef FMS_DIAG_FBCM_PNAME_ +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_i4 +#include + +#undef FMS_DIAG_FBU_DATA_TYPE_ +#define FMS_DIAG_FBU_DATA_TYPE_ INTEGER(i8_kind) +#undef FMS_DIAG_FBU_PNAME_ +#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_i8 +#undef FMS_DIAG_FBCF_PNAME_ +#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_i8 +#undef FMS_DIAG_FBCM_PNAME_ +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_i8 +#include From f3ddae92203de7490268a0973343f767ee191b53 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Tue, 3 Jan 2023 23:50:30 -0500 Subject: [PATCH 04/37] Added math (field buffer update) functions that use 4D fields to the lagacy diag_manager. Adds a refactored version of send_data_3d, modified the buffer bounds checking functions, and necessary changes in diag_data and diag_util. --- CMakeLists.txt | 3 +- diag_manager/Makefile.am | 31 +- diag_manager/diag_data.F90 | 36 +- diag_manager/diag_manager.F90 | 98 +++-- diag_manager/diag_util.F90 | 373 +++++++++++------- diag_manager/fms_diag_fieldbuff_update.F90 | 21 +- diag_manager/fms_diag_outfield.F90 | 256 ++++++++++++ diag_manager/fms_diag_time_reduction.F90 | 215 ++++++++++ .../include/fms_diag_fieldbuff_update.fh | 111 +++--- .../include/fms_diag_fieldbuff_update.inc | 20 - 10 files changed, 896 insertions(+), 268 deletions(-) create mode 100644 diag_manager/fms_diag_outfield.F90 create mode 100644 diag_manager/fms_diag_time_reduction.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 6a28c81da5..3ac2a35b61 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -328,7 +328,8 @@ foreach(kind ${kinds}) $ $ $ - $) + $ + $) target_include_directories(${libTgt} INTERFACE $ diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 295b4e3bb5..cfba07e75b 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -23,7 +23,7 @@ # Ed Hartnett 2/22/19 # Include .h and .mod files. -AM_CPPFLAGS = -I$(top_srcdir)/include +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager/include -I$(top_srcdir)/diag_manager AM_FCFLAGS = $(FC_MODINC). $(FC_MODOUT)$(MODDIR) # Build these uninstalled convenience libraries. @@ -37,15 +37,28 @@ libdiag_manager_la_SOURCES = \ diag_manager.F90 \ diag_output.F90 \ diag_table.F90 \ - diag_util.F90 + diag_util.F90 \ + fms_diag_time_reduction.F90 \ + fms_diag_outfield.F90 \ + fms_diag_fieldbuff_update.F90 \ + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh # Some mods are dependant on other mods in this dir. diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) -diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) +diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \ + diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) +fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) +fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ - diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) + diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ + fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) + # Mod files are built and then installed as headers. MODFILES = \ @@ -55,8 +68,14 @@ MODFILES = \ diag_output_mod.$(FC_MODEXT) \ diag_util_mod.$(FC_MODEXT) \ diag_table_mod.$(FC_MODEXT) \ - diag_manager_mod.$(FC_MODEXT) -nodist_include_HEADERS = $(MODFILES) + fms_diag_time_reduction_mod.$(FC_MODEXT) \ + fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ + diag_manager_mod.$(FC_MODEXT) \ + include/fms_diag_fieldbuff_update.inc \ + include/fms_diag_fieldbuff_update.fh + + nodist_include_HEADERS = $(MODFILES) BUILT_SOURCES = $(MODFILES) include $(top_srcdir)/mkmods.mk diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 486930940d..ebe354621e 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -115,6 +115,8 @@ MODULE diag_data_mod INTEGER, allocatable, DIMENSION(:) :: iatt !< INTEGER array to hold value of INTEGER attributes END TYPE diag_atttype + !!TODO: coord_type deserves a better name, like coord_interval_type or coord_bbox_type. + !! additionally, consider using a 2D array. !> @brief Define the region for field output !> @ingroup diag_data_mod TYPE coord_type @@ -126,6 +128,23 @@ MODULE diag_data_mod REAL :: zend END TYPE coord_type +!!TODO: consider using an array for this. + !> @brief Data structure holding intervals (or interval bounds or limits). + !! Used for checking the bounds of the field output buffer arrays. +TYPE, public :: fms_diag_ibounds_type + INTEGER :: imin !< Lower i bound. + INTEGER :: imax !< Upper i bound. + INTEGER :: jmin !< Lower j bound. + INTEGER :: jmax !< Upper j bound. + INTEGER :: kmin !< Lower k bound. + INTEGER :: kmax !< Upper k bound. + contains + procedure :: reset => ibounds_reset +END TYPE fms_diag_ibounds_type + + + + !> @brief Type to define the diagnostic files that will be written as defined by the diagnostic table. !> @ingroup diag_data_mod TYPE file_type @@ -240,7 +259,7 @@ MODULE diag_data_mod TYPE(diag_grid) :: output_grid LOGICAL :: local_output, need_compute, phys_window, written_once LOGICAL :: reduced_k_range - INTEGER :: imin, imax, jmin, jmax, kmin, kmax + TYPE(fms_diag_ibounds_type) :: buff_bounds TYPE(time_type) :: Time_of_prev_field_data TYPE(diag_atttype), allocatable, dimension(:) :: attributes INTEGER :: num_attributes @@ -384,6 +403,21 @@ SUBROUTINE diag_data_init() call write_version_number("DIAG_DATA_MOD", version) END SUBROUTINE diag_data_init + +!> @brief Sets the lower and upper bounds to lower_val and upper_val, respectively. + SUBROUTINE ibounds_reset (this, lower_val, upper_val) + class (fms_diag_ibounds_type), target, intent(inout) :: this !< ibounds instance + integer, intent(in) :: lower_val !< value for the lower bounds in each dimension + integer, intent(in) :: upper_val !< value for the upper bounds in each dimension + this%imin = lower_val + this%jmin = lower_val + this%kmin = lower_val + this%imax = upper_val + this%jmax = upper_val + this%kmax = upper_val +end SUBROUTINE ibounds_reset + + END MODULE diag_data_mod !> @} ! close documentation grouping diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index d8d8cd7349..915503ded0 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -239,6 +239,7 @@ MODULE diag_manager_mod USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end USE constants_mod, ONLY: SECONDS_PER_DAY + USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_index_type, fms_diag_outfield_type #ifdef use_netCDF USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR @@ -3165,12 +3166,22 @@ LOGICAL FUNCTION send_data_3d_refac(diag_field_id, field, time, is_in, js_in, ks REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field + TYPE(fms_diag_outfield_index_type), ALLOCATABLE:: ofield_index_cfg + TYPE(fms_diag_outfield_type), ALLOCATABLE:: ofield_cfg + + REAL, dimension(:,:,:,:), pointer::field_ptr => null() !< Ptr to field data array + REAL, dimension(:,:,:,:), pointer::mask_ptr => null() !< Ptr to field data mask array + REAL, dimension(:,:,:,:), pointer::rmask_ptr => null() !< Ptr to field data rmask array + REAL, dimension(:,:,:,:,:), pointer::ofb_ptr => null() ! null() ! output_fields(out_num)%buffer, & + & ofc => output_fields(out_num)%counter) + + IF ( average ) THEN + field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field + rmask_ptr(1:size(rmask,1),1:size(rmask,2),1:size(rmask,3),1:1) => rmask + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3),1:1) => ofb + ofc_ptr(1:size(ofc,1),1:size(ofc,2),1:size(ofc,3),1:1) => ofc + IF(PRESENT ( mask) ) THEN + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ENDIF + + IF(PRESENT ( mask) ) THEN + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ENDIF + + temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_ptr, sample, & + & ofb_ptr,ofc_ptr, ofield_cfg%buff_bounds, & + & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & + & mask, weight, missval_r4_ptr, missvalue_present, & + & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& + & has_mask_variant, input_fields(diag_field_id)%issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) IF (temp_result .eqv. .FALSE.) THEN - DEALLOCATE(oor_mask) - RETURN + DEALLOCATE(oor_mask) + RETURN END IF - ! Add processing for Max and Min - ELSE !!.NOT. average - temp_result = sprocs_obj%sample_the_field(diag_field_id, field_out, & - & sample, output_fields(out_num)%buffer, output_fields(out_num)%ntval, & - & output_fields(out_num)%count_0d(sample), & - & output_fields(out_num)%output_name,input_fields(diag_field_id)%module_name, mask, & - & missvalue, missvalue_present, l_start, l_end, err_msg, err_msg_local) - IF (temp_result .eqv. .FALSE.) THEN - DEALLOCATE(oor_mask) - RETURN - END IF + ELSE !!NOT AVERAGE + !!fieldbuff_sample + IF (temp_result .eqv. .FALSE.) THEN + DEALLOCATE(oor_mask) + RETURN END IF - DEALLOCATE(sprocs_obj) + END IF + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + END ASSOCIATE + + !!END REFACTORED SECTION WITH WEIGHTING FUNCTIONS - END IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index a676fefede..6e1acfa440 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -49,7 +49,7 @@ MODULE diag_util_mod & mix_snapshot_average_fields, global_descriptor, CMOR_MISSING_VALUE, use_cmor, pack_size,& & debug_diag_manager, flush_nc_files, output_field_type, max_field_attributes, max_file_attributes,& & file_type, prepend_date, region_out_use_alt_value, GLO_REG_VAL, GLO_REG_VAL_ALT,& - & DIAG_FIELD_NOT_FOUND, diag_init_time + & DIAG_FIELD_NOT_FOUND, diag_init_time, fms_diag_ibounds_type USE diag_data_mod, ONLY: fileobjU, fileobj, fnum_for_domain, fileobjND USE diag_axis_mod, ONLY: get_diag_axis_data, get_axis_global_length, get_diag_axis_cart,& & get_domain1d, get_domain2d, diag_subaxes_init, diag_axis_init, get_diag_axis, get_axis_aux,& @@ -740,15 +740,28 @@ SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, u INTEGER, INTENT(in) :: upper_j !< Upper j bound. INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. - - output_fields(out_num)%imin = MIN(output_fields(out_num)%imin, lower_i) - output_fields(out_num)%imax = MAX(output_fields(out_num)%imax, upper_i) - output_fields(out_num)%jmin = MIN(output_fields(out_num)%jmin, lower_j) - output_fields(out_num)%jmax = MAX(output_fields(out_num)%jmax, upper_j) - output_fields(out_num)%kmin = MIN(output_fields(out_num)%kmin, lower_k) - output_fields(out_num)%kmax = MAX(output_fields(out_num)%kmax, upper_k) + CALL update_bounds_imp(output_fields(out_num)%buff_bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) END SUBROUTINE update_bounds + !> @brief Update the output_fields x, y, and z (and optionally l) min and + !! max boundaries (array indices). +SUBROUTINE update_bounds_imp(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) + TYPE (fms_diag_ibounds_type) :: bounds !< the bounding box of the output field buffer inindex space. + INTEGER, INTENT(in) :: lower_i !< Lower i bound. + INTEGER, INTENT(in) :: upper_i !< Upper i bound. + INTEGER, INTENT(in) :: lower_j !< Lower j bound. + INTEGER, INTENT(in) :: upper_j !< Upper j bound. + INTEGER, INTENT(in) :: lower_k !< Lower k bound. + INTEGER, INTENT(in) :: upper_k !< Upper k bound. + bounds%imin = MIN(bounds%imin, lower_i) + bounds%imax = MAX(bounds%imax, upper_i) + bounds%jmin = MIN(bounds%jmin, lower_j) + bounds%jmax = MAX(bounds%jmax, upper_j) + bounds%kmin = MIN(bounds%kmin, lower_k) + bounds%kmax = MAX(bounds%kmax, upper_k) +END SUBROUTINE update_bounds_imp + + !> @brief Checks if the array indices for output_fields(out_num) are outside the !! output_fields(out_num)%buffer upper !! and lower bounds. @@ -757,112 +770,191 @@ SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the - !! buffer array boundaries. - - CHARACTER(len=128) :: error_string1, error_string2 - - IF ( output_fields(out_num)%imin < LBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%imax > UBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%jmin < LBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%jmax > UBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%kmin < LBOUND(output_fields(out_num)%buffer,3) .OR.& - & output_fields(out_num)%kmax > UBOUND(output_fields(out_num)%buffer,3) ) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin - WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax - WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin - WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax - WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin - WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax - err_msg = 'module/output_field='//TRIM(error_string1)//& - & ' Bounds of buffer exceeded. '//TRIM(error_string2) - ! imax, imin, etc need to be reset in case the program is not terminated. - output_fields(out_num)%imax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmax = 0 - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmax = 0 - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH - ELSE - err_msg = '' - END IF - + !! buffer array boundaries. + CALL check_out_of_bounds_imp(output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds, & + & output_fields(out_num)%output_name, input_fields(diag_field_id)%module_name, err_msg) END SUBROUTINE check_out_of_bounds - !> @brief Check if the array indices for output_fields(out_num) are equal to the - !! output_fields(out_num)%buffer - !! upper and lower bounds. - SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) - INTEGER, INTENT(in) :: out_num !< Output field ID number. - INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if - !! output_fields(out_num)%Time_of_prev_field_data is not - !! equal to Time or Time_zero. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. - !! An empty error string indicates the x, y, and z indices are - !! equal to the buffer array boundaries. + !> @brief Compares the indecies in bounds to the corresponding lower and upper bounds of array buffer. +!! Comparison is done by the two user specified input functions lowerb_comp and upperb_comp. +!! If any compariosn function returns true, then, after filling error_str, this routine returns +!! false indicating one of the comparison tests indicated a problem. So the comparison test should +!! return true for errors : for indecies out of bounds, or indecies are not equal when expected to +!! be equal. +LOGICAL FUNCTION compare_buffer_bounds_to_size(buffer, bounds, output_name, module_name, error_str, & + & lowerb_comp, upperb_comp) + CLASS(*), INTENT(in), DIMENSION(:,:,:,:) :: buffer + TYPE (fms_diag_ibounds_type) :: bounds + CHARACTER(len=*), INTENT(in) :: output_name + CHARACTER(len=*), INTENT(in) :: module_name + CHARACTER(len=*), INTENT(inout) :: error_str + + !> @brief Interface lowerb_comp should be used for comparison to lower bounds of buffer. + INTERFACE + LOGICAL FUNCTION lowerb_comp(a , b) + INTEGER, INTENT(IN) :: a, b + END FUNCTION lowerb_comp + END INTERFACE + + !> @brief Interface lowerb_comp should be used for comparison to upper bounds of buffer. + INTERFACE + LOGICAL FUNCTION upperb_comp(a, b) + INTEGER, INTENT(IN) :: a, b + END FUNCTION upperb_comp + END INTERFACE + + compare_buffer_bounds_to_size = .TRUE. + + IF (lowerb_comp( bounds%imin, LBOUND(buffer,1)) .OR.& + upperb_comp( bounds%imax , UBOUND(buffer,1)) .OR.& + lowerb_comp( bounds%jmin , LBOUND(buffer,2)) .OR.& + upperb_comp( bounds%jmax , UBOUND(buffer,2)) .OR.& + lowerb_comp( bounds%kmin , LBOUND(buffer,3)) .OR.& + upperb_comp( bounds%kmax , UBOUND(buffer,3))) THEN + compare_buffer_bounds_to_size = .FALSE. + error_str ='Buffer bounds= : , : , : Actual bounds= : , : , : ' + WRITE(error_str(15:17),'(i3)') LBOUND(buffer,1) + WRITE(error_str(19:21),'(i3)') UBOUND(buffer,1) + WRITE(error_str(23:25),'(i3)') LBOUND(buffer,2) + WRITE(error_str(27:29),'(i3)') UBOUND(buffer,2) + WRITE(error_str(31:33),'(i3)') LBOUND(buffer,3) + WRITE(error_str(35:37),'(i3)') UBOUND(buffer,3) + WRITE(error_str(54:56),'(i3)') bounds%imin + WRITE(error_str(58:60),'(i3)') bounds%imax + WRITE(error_str(62:64),'(i3)') bounds%jmin + WRITE(error_str(66:68),'(i3)') bounds%jmax + WRITE(error_str(70:72),'(i3)') bounds%kmin + WRITE(error_str(74:76),'(i3)') bounds%kmax + ELSE + error_str = '' + END IF +END FUNCTION compare_buffer_bounds_to_size + +!> @brief return true iff a @brief return true iff a>b. +LOGICAL FUNCTION a_greaterthan_b(a, b) + INTEGER, INTENT(IN) :: a, b + a_greaterthan_b = A > B +END FUNCTION a_greaterthan_b + +!> @brief return true iff a != b +LOGICAL FUNCTION a_noteq_b(a, b) +INTEGER, INTENT(IN) :: a, b +a_noteq_b = a /= b +END FUNCTION a_noteq_b - CHARACTER(len=128) :: error_string1, error_string2 - LOGICAL :: do_check - err_msg = '' - ! Check bounds only when the value of Time changes. When windows are used, - ! a change in Time indicates that a new loop through the windows has begun, - ! so a check of the previous loop can be done. - IF ( Time == output_fields(out_num)%Time_of_prev_field_data ) THEN - do_check = .FALSE. - ELSE - IF ( output_fields(out_num)%Time_of_prev_field_data == Time_zero ) THEN - ! It may or may not be OK to check, I don't know how to tell. - ! Check will be done on subsequent calls anyway. - do_check = .FALSE. - ELSE - do_check = .TRUE. - END IF - output_fields(out_num)%Time_of_prev_field_data = Time - END IF - - IF ( do_check ) THEN - IF ( output_fields(out_num)%imin /= LBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%imax /= UBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%jmin /= LBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%jmax /= UBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%kmin /= LBOUND(output_fields(out_num)%buffer,3) .OR.& - & output_fields(out_num)%kmax /= UBOUND(output_fields(out_num)%buffer,3) ) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin - WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax - WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin - WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax - WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin - WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax - err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) - END IF - output_fields(out_num)%imax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmax = 0 - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmax = 0 - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH - END IF - END SUBROUTINE check_bounds_are_exact_dynamic + !> @brief Checks if the array indices for output_fields(out_num) are outside the +!! output_fields(out_num)%buffer upper and lower bounds. +SUBROUTINE check_out_of_bounds_imp(buffer, bounds, output_name, module_name, err_msg) + REAL, INTENT(in), DIMENSION(:,:,:,:) :: buffer + TYPE (fms_diag_ibounds_type) :: bounds + CHARACTER(len=*), INTENT(in) :: output_name + CHARACTER(len=*), INTENT(in) :: module_name + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds_imp. An empty + !! error string indicates the x, y, and z indices are not outside the + !! buffer array boundaries. + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + + out_of_bounds = compare_buffer_bounds_to_size(buffer, bounds, output_name, module_name, & + & error_string2, a_lessthan_b, a_greaterthan_b) + + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + err_msg = 'module/output_field='//TRIM(error_string1)//& + & ' Bounds of buffer exceeded. '//TRIM(error_string2) + ! imax, imin, etc need to be reset in case the program is not terminated. + bounds%imax = 0 + bounds%imin = VERY_LARGE_AXIS_LENGTH + bounds%jmax = 0 + bounds%jmin = VERY_LARGE_AXIS_LENGTH + bounds%kmax = 0 + bounds%kmin = VERY_LARGE_AXIS_LENGTH + ELSE + err_msg = '' + END IF +END SUBROUTINE check_out_of_bounds_imp + +SUBROUTINE check_bounds_are_exact_dynamic_imp(buffer, bounds, output_name, module_name, & + & Time, field_prev_Time, err_msg) + CLASS(*), INTENT(in), DIMENSION(:,:,:,:) :: buffer + TYPE (fms_diag_ibounds_type) :: bounds + CHARACTER(len=*), INTENT(in) :: output_name + CHARACTER(len=*), INTENT(in) :: module_name + TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if + !! output_fields(out_num)%Time_of_prev_field_data is not + !! equal to Time or Time_zero. + TYPE(time_type), INTENT(inout) :: field_prev_Time !< output_fields(out_num)%Time_of_prev_field_data + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + !! An empty error string indicates the x, y, and z indices are + !! equal to the buffer array boundaries. + + CHARACTER(len=128), ALLOCATABLE :: error_string1, error_string2 + LOGICAL :: do_check + LOGICAL :: lims_not_exact = .true. + + err_msg = '' + + ! Check bounds only when the value of Time changes. When windows are used, + ! a change in Time indicates that a new loop through the windows has begun, + ! so a check of the previous loop can be done. + IF ( Time == field_prev_Time ) THEN + do_check = .FALSE. + ELSE + IF ( field_prev_Time == Time_zero ) THEN + ! It may or may not be OK to check, I don't know how to tell. + ! Check will be done on subsequent calls anyway. + do_check = .FALSE. + ELSE + do_check = .TRUE. + END IF + field_prev_Time = Time + END IF + + IF ( do_check ) THEN + lims_not_exact = compare_buffer_bounds_to_size(buffer, bounds, output_name, module_name, & + & error_string2, a_noteq_b, a_noteq_b) + IF( lims_not_exact .eqv. .TRUE.) THEN + err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) + END IF + bounds%imax = 0 + bounds%imin = VERY_LARGE_AXIS_LENGTH + bounds%jmax = 0 + bounds%jmin = VERY_LARGE_AXIS_LENGTH + bounds%kmax = 0 + bounds%kmin = VERY_LARGE_AXIS_LENGTH + END IF +END SUBROUTINE check_bounds_are_exact_dynamic_imp + + + !> @brief This is an adaptor to the check_out_of_bounds function to +!! maintain an interface servicing the older diag_manager (particularly the +!! send_data_3d function) and maintain a version of it as unchaged as possible. + +SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) + INTEGER, INTENT(in) :: out_num !< Output field ID number. + INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. + TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if + !! output_fields(out_num)%Time_of_prev_field_data is not + !! equal to Time or Time_zero. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + !! An empty error string indicates the x, y, and z indices are + !! equal to the buffer array boundaries. + + !!TODO: pass not the buffer but a pointer to a higher rank array + CALL check_bounds_are_exact_dynamic_imp(output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds, & + & output_fields(out_num)%output_name, input_fields(diag_field_id)%module_name, & + & Time, output_fields(out_num)%Time_of_prev_field_data, err_msg) + +END SUBROUTINE check_bounds_are_exact_dynamic + !> @brief Check if the array indices for output_fields(out_num) are equal to the !! output_fields(out_num)%buffer @@ -873,40 +965,38 @@ SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg) CHARACTER(len=*), INTENT(out) :: err_msg CHARACTER(len=128) :: error_string1, error_string2 + !!call... + END SUBROUTINE check_bounds_are_exact_static - err_msg = '' - IF ( output_fields(out_num)%imin /= LBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%imax /= UBOUND(output_fields(out_num)%buffer,1) .OR.& - & output_fields(out_num)%jmin /= LBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%jmax /= UBOUND(output_fields(out_num)%buffer,2) .OR.& - & output_fields(out_num)%kmin /= LBOUND(output_fields(out_num)%buffer,3) .OR.& - & output_fields(out_num)%kmax /= UBOUND(output_fields(out_num)%buffer,3) ) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - error_string2 ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_string2(15:17),'(i3)') LBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(19:21),'(i3)') UBOUND(output_fields(out_num)%buffer,1) - WRITE(error_string2(23:25),'(i3)') LBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(27:29),'(i3)') UBOUND(output_fields(out_num)%buffer,2) - WRITE(error_string2(31:33),'(i3)') LBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(35:37),'(i3)') UBOUND(output_fields(out_num)%buffer,3) - WRITE(error_string2(54:56),'(i3)') output_fields(out_num)%imin - WRITE(error_string2(58:60),'(i3)') output_fields(out_num)%imax - WRITE(error_string2(62:64),'(i3)') output_fields(out_num)%jmin - WRITE(error_string2(66:68),'(i3)') output_fields(out_num)%jmax - WRITE(error_string2(70:72),'(i3)') output_fields(out_num)%kmin - WRITE(error_string2(74:76),'(i3)') output_fields(out_num)%kmax + !> @brief Check if the array indices for output_fields are equal to the + !! buffer upper and lower bounds. + SUBROUTINE check_bounds_are_exact_static_imp(buffer, bounds, output_name, module_name, err_msg) + CLASS(*), INTENT(in), DIMENSION(:,:,:,:) :: buffer + TYPE (fms_diag_ibounds_type) :: bounds + CHARACTER(len=*), INTENT(in) :: output_name + CHARACTER(len=*), INTENT(in) :: module_name + CHARACTER(len=*), INTENT(out) :: err_msg + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: lims_not_exact = .true. + + err_msg = '' + lims_not_exact = compare_buffer_bounds_to_size(buffer, bounds, output_name, module_name, & + & error_string2, a_noteq_b, a_noteq_b) + IF( lims_not_exact .eqv. .TRUE.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) END IF - output_fields(out_num)%imax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmax = 0 - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmax = 0 - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH - END SUBROUTINE check_bounds_are_exact_static + bounds%imax = 0 + bounds%imin = VERY_LARGE_AXIS_LENGTH + bounds%jmax = 0 + bounds%jmin = VERY_LARGE_AXIS_LENGTH + bounds%kmax = 0 + bounds%kmin = VERY_LARGE_AXIS_LENGTH + END SUBROUTINE check_bounds_are_exact_static_imp + !> @brief Initialize the output file. SUBROUTINE init_file(name, output_freq, output_units, format, time_units, long_name, tile_count,& @@ -1391,12 +1481,7 @@ SUBROUTINE init_output_field(module_name, field_name, output_name, output_file,& output_fields(out_num)%num_axes = 0 output_fields(out_num)%total_elements = 0 output_fields(out_num)%region_elements = 0 - output_fields(out_num)%imax = 0 - output_fields(out_num)%jmax = 0 - output_fields(out_num)%kmax = 0 - output_fields(out_num)%imin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%jmin = VERY_LARGE_AXIS_LENGTH - output_fields(out_num)%kmin = VERY_LARGE_AXIS_LENGTH + call output_fields(out_num)%buff_bounds%reset(0, VERY_LARGE_AXIS_LENGTH) ! initialize the size of the diurnal axis to 1 output_fields(out_num)%n_diurnal_samples = 1 diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index d382bb6716..1719cf5341 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -33,15 +33,13 @@ !> @addtogroup fms_diag_fieldbuff_update_mod !> @{ MODULE fms_diag_fieldbuff_update_mod -#ifdef use_yaml USE platform_mod USE mpp_mod, ONLY: mpp_pe, mpp_root_pe USE time_manager_mod, ONLY: time_type USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,fms_error_handler - USE diag_data_mod, ONLY: debug_diag_manager, fms_diag_buff_intervals_t - USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_type, fms_diag_outfield_index_type - USE diag_util_mod, ONLY: check_out_of_bounds_m, update_bounds_m - USE fms_diag_field_object_mod, ONLY: fmsDiagField_type + USE diag_data_mod, ONLY: debug_diag_manager, fms_diag_ibounds_type + USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_index_type, fms_diag_outfield_type + USE diag_util_mod, ONLY: check_out_of_bounds, update_bounds implicit none @@ -54,9 +52,9 @@ MODULE fms_diag_fieldbuff_update_mod !< r8 version of the interface module procedure fieldbuff_update_r8 !< i4 version of the interface - module procedure fieldbuff_update_i4 + !module procedure fieldbuff_update_i4 !< i8 version of the interface - module procedure fieldbuff_update_i8 + ! module procedure fieldbuff_update_i8 end interface !> @brief Interface fieldbuff_copy_misvals updates elements of the field output buffer with @@ -68,9 +66,9 @@ MODULE fms_diag_fieldbuff_update_mod !< r8 version of the interface module procedure fieldbuff_copy_misvals_r8 !< i4 version of the interface - module procedure fieldbuff_copy_misvals_i4 + !module procedure fieldbuff_copy_misvals_i4 !< i8 version of the interface - module procedure fieldbuff_copy_misvals_i8 + !module procedure fieldbuff_copy_misvals_i8 end interface !> @brief Interface fieldbuff_copy_fieldvals updates elements of the field output buffer with @@ -82,16 +80,15 @@ MODULE fms_diag_fieldbuff_update_mod !< r8 version of the interface module procedure fieldbuff_copy_fieldvals_r8 !< i4 version of the interface - module procedure fieldbuff_copy_fieldvals_i4 + !module procedure fieldbuff_copy_fieldvals_i4 !< i8 version of the interface - module procedure fieldbuff_copy_fieldvals_i8 + !module procedure fieldbuff_copy_fieldvals_i8 end interface contains #include -#endif END MODULE fms_diag_fieldbuff_update_mod !> @} diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 new file mode 100644 index 0000000000..2d2c7e1fd7 --- /dev/null +++ b/diag_manager/fms_diag_outfield.F90 @@ -0,0 +1,256 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_outfield_mod fms_diag_outfield_mod +!> @ingroup diag_manager +!> @brief fms_diag_outfield_mod defines data types and utility or auxiliary routines +!! useful in updating the output buffer. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_outfield_mod The output buffer updating routines are passed configuration +!! and control data with types defined in this module; and some utility functions called by the +!! updating routines are +!! defined here. +!! +!> @file +!> @brief File for @ref fms_diag_outfield_mod +!> @addtogroup fms_diag_outfield_mod +!> @{ +MODULE fms_diag_outfield_mod + + USE mpp_mod, only :FATAL + USE fms_mod, only :lowercase, uppercase, error_mesg, fms_error_handler + + + !! TODO: these might need removal or replacement + USE diag_data_mod, only:Time_zero + USE diag_data_mod, only: GLO_REG_VAL, GLO_REG_VAL_ALT, region_out_use_alt_value, VERY_LARGE_AXIS_LENGTH, coord_type + USE diag_data_mod, only: fms_diag_ibounds_type, input_field_type, output_field_type + USE fms_diag_time_reduction_mod, only: time_reduction_type + + !!TODO: for modern diag: if use_yaml then + !! USE fms_diag_yaml_mod, only : diagYamlFiles_type, diagYamlFilesVar_type + !!USE fms_diag_field_object_mod, only: fmsDiagField_type + !!USE diag_data_mod, only: fms_diag_buff_intervals_t, diag_grid + !!USE time_manager_mod,ONLY: time_type, OPERATOR(==), OPERATOR(>), NO_CALENDAR, increment_date,& + !!& increment_time, get_calendar_type, get_date, get_time, leap_year, OPERATOR(-),& + !!& OPERATOR(<), OPERATOR(>=), OPERATOR(<=), OPERATOR(==) + + implicit none + + ABSTRACT INTERFACE + PURE FUNCTION weight_the_field ( field_val, weight, pow_value ) + REAL, INTENT(in) :: field_val + REAL, INTENT(in) :: weight + INTEGER, INTENT(in) :: pow_value + REAL :: weight_the_field + END FUNCTION + END INTERFACE + + + TYPE fms_diag_field_weighting_type + PROCEDURE (weight_the_field), NOPASS, POINTER::fwf_ptr=>null() !! A pointer to the field weighting function. + CONTAINS + PROCEDURE, PASS :: WF + END TYPE + + + + !> @brief Class fms_diag_outfield_type (along with class ms_diag_outfield_index_type ) + !! contain information used in updating the output buffers by the diag_manager + !! send_data routines. In some sense they can be seen as encapsulating related + !! information in a convenient way (e.g. to pass to functions and for do loop + !! controls. + !! + !! Class fms_diag_outfield_type also contains a significant subset of the fields + !! and routines of of the legacy class output_field_type + !! TODO: Developemnt of this class is in a seperate and future PR. For its development, + !! consider the legacy diag_util::init_output_field already in place. Fields added so + !! are uesd the the field buffer math/dupdate functions. + !> @ingroup fms_diag_outfield_mod + TYPE fms_diag_outfield_type + CHARACTER(len=:), ALLOCATABLE :: module_name !< Module name. + CHARACTER(len=:), ALLOCATABLE :: field_name !< Output field name. + CHARACTER(len=:), ALLOCATABLE :: output_name !< Output name written to file. + CHARACTER(len=:), ALLOCATABLE :: output_file !< File where field should be written. + + !!Major outer loop controls in send_data functions. + INTEGER :: pow_value !< Power value for rms or pow(x) calculations + LOGICAL :: phys_window !< TODO: Rename? OMP subsetted data, See output_fields + LOGICAL :: need_compute !< True iff is local_output and current PE take part in send_data. + LOGICAL :: reduced_k_range !< If true, the local start and end indecies are used in k (i.e. 3rd) dim. + LOGICAL :: mask_variant + LOGICAL :: mask_present !< True iff mars arguemnt is present in user-facing send function call. + !< Note this field exist since the actual mask argument in the send + !< function call may be downstream replaced by a null pointer which + !< is considered present. + + TYPE(time_reduction_type) :: time_reduction !< Instance of the time_reduction_type. + + TYPE(fms_diag_ibounds_type) :: buff_bounds !< Instance of a fms_diag_buff_intervals_t type. + + !!TODO: Is nopass really needed here? Note that the functions are being passed pow_val, which + !! may not be necessary is designed in a cenetain way as power value is also a member + ! of fms_diag_outfield_type. + !! PROCEDURE (weight_the_field), POINTER, NOPASS::fwf_ptr=>null() !! A pointer to the field weighting function. + TYPE (fms_diag_field_weighting_type) :: wf + + !! possibly useful in modern: + !! INTEGER :: n_diurnal_samples !< Size of diurnal axis (also number of diurnal samples).value is >= 1 + + !LOGICAL :: static !< True iff the field is static. + !TYPE(time_type) :: last_output, next_output, next_next_output + !INTEGER :: pack !< The packing method. + + ! TYPE(diag_grid) :: output_grid + ! LOGICAL :: local_output !< True if the field output is on a local domain only. + ! TYPE(time_type) :: Time_of_prev_field_data + + ! logical :: reduced_k_unstruct = .false. !!Related to unstructured grid support + ! INTEGER :: total_elements + CONTAINS + procedure, public :: initialize => initialize_outfield_imp + END TYPE fms_diag_outfield_type + + + !> @brief Class fms_diag_outfield_index_type which (along with class fms_diag_outfield_type) + !! encapsulate related information used in updating the output buffers by the diag_manager + !! send_data routines. This class in particular focuses on do loop index controls or settings. + !! Note that the index names in this class should be indentical to the names used in the + !! diag_manager send_data functions and in the "math" buffer update functions. The purpose + !! of this class is also to allow for a smaller call function signature for the math/buffer + !! update functions. + !> @ingroup fms_diag_outfield_mod + TYPE, public :: fms_diag_outfield_index_type + INTEGER :: f1,f2 !< Indecies used specify 1st dim bounds of field, mask and rmask. + INTEGER :: f3,f4 !< Indecies used specify 2st dim bounds of field, mask and rmask. + INTEGER :: is, js, ks !< Start indecies in each spatial dim of the field_data; and + !! may be user provided in send_data + Integer :: ie, je, ke !< End indecies in each spatial dim of the field_data; and + !! may be user provided in send_data + INTEGER :: hi !< halo size in x direction. Same name as in send_data + INTEGER :: hj !< halo size in y direction. Same + CONTAINS + procedure :: initialize => initialize_outfield_index_type + END TYPE fms_diag_outfield_index_type + +CONTAINS + !!TODO: In the modern diag, the field_val and weight may also be of integer type, + !! and so may need to use the pre-processor. + + +!> #brief initialize all the memebers of the class. + SUBROUTINE initialize_outfield_index_type(this, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + CLASS(fms_diag_outfield_index_type), INTENT(inout) :: this + INTEGER, INTENT(in) :: is, js, ks !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: ie, je, ke !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: hi, hj !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: f1, f2, f3, f4 !< Variable used to update class member of same names. + + this%is = is + this%js = js + this%ks = ks + this%ie = ie + this%je = je + this%ke = ke + + this%hi = hi + this%hj = hj + + this%f1 = f1 + this%f2 = f2 + this%f3 = f3 + this%f4 = f4 + END SUBROUTINE initialize_outfield_index_type + + + !!output_frequency in file_type; + !! num_elements in output_field; possibly pass by itself to update_field. + !!output_frequecy in file_type. + !> @brief Update with those fields used in the legacy diag manager. + SUBROUTINE initialize_outfield_imp(this, input_field, output_field ) + CLASS(fms_diag_outfield_type), INTENT(inout) :: this + TYPE(input_field_type), INTENT(in) :: input_field + TYPE(output_field_type), INTENT(in) :: output_field + + this%module_name = input_field%module_name + this%field_name = input_field%field_name +1 this%output_name = output_field%output_name + + this%pow_value = output_field%pow_value + this%phys_window = output_field%phys_window + this%need_compute =output_field%need_compute + this%reduced_k_range = output_field%reduced_k_range + this%mask_variant = input_field%mask_variant + + + !!And set the power function + if ( this%pow_value == 1) then + this%wf%fwf_ptr => weight_the_field_p1 + else if ( this%pow_value == 2 ) then + this%wf%fwf_ptr => weight_the_field_p2 + else + this%wf%fwf_ptr => weight_the_field_pp + end if + !!TODO: + !!init the time_reduction, using + !!possibly using output_field%time_rms, output_field%time_max output_field%time_min, + !! and output_field%time_sum ? + END SUBROUTINE initialize_outfield_imp + + ELEMENTAL PURE REAL FUNCTION wf(this, field_val, weight, pow_value ) + CLASS( fms_diag_field_weighting_type), INTENT (in) :: this + REAL, INTENT(in) :: field_val + REAL, INTENT(in) :: weight + INTEGER, INTENT(in) :: pow_value + wf = this%fwf_ptr(field_val, weight, pow_value) +END FUNCTION + + PURE REAL FUNCTION weight_the_field_p1 (field_val, weight, pow_value ) + REAL, INTENT(in) :: field_val !< The field values. + REAL, INTENT(in) :: weight !< The weighting coefficient. + INTEGER, INTENT(in) :: pow_value !< The weighting exponent. + weight_the_field_p1 = field_val * weight + END FUNCTION weight_the_field_p1 + +!> A function to quadraticaly weight scalar fields. + PURE REAL FUNCTION weight_the_field_p2 (field_val, weight, pow_value ) + REAL, INTENT(in) :: field_val !< The field values. + REAL, INTENT(in) :: weight !< The weighting coefficient. + INTEGER, INTENT(in) :: pow_value !< The weighting exponent. + REAL :: fTw + fTw = field_val * weight + weight_the_field_p2 = fTw * fTw + END FUNCTION weight_the_field_p2 + +!> A function to weight scalar fields by a an exponent. + PURE REAL FUNCTION weight_the_field_pp (field_val, weight, pow_value ) + !!CLASS(fms_diag_field_weighting_type), INTENT(in) :: this + REAL, INTENT(in) :: field_val !< The field values. + REAL, INTENT(in) :: weight !< The weighting coefficient. + INTEGER, INTENT(in) :: pow_value !< The weighting exponent. + weight_the_field_pp = (field_val * weight) ** pow_value + END FUNCTION weight_the_field_pp + +END MODULE fms_diag_outfield_mod +!> @} +! close documentation grouping + + diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 new file mode 100644 index 0000000000..0fbbcd596b --- /dev/null +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -0,0 +1,215 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_time_reduction_mod fms_diag_time_reduction_mod +!> @ingroup diag_manager +!> @brief fms_diag_time_reduction_mod defines classes encapsulating the diag_manager +!! time redution types. +!! +!> @author Miguel Zuniga +!! +!> @file +!> @brief File for @ref fms_diag_time_reduction_mod +!> @addtogroup fms_diag_time_reduction_mod +!> @{ +MODULE fms_diag_time_reduction_mod + + USE diag_data_mod, only: EVERY_TIME + !!use diag_data_mod, only: time_min, time_max, time_sum, time_rms, time_average, time_none, time_power, & + !!& time_diurnal, every_time + USE fms_mod, ONLY: error_mesg, FATAL + + implicit none + + !!These parametes may be put in diag_data? + INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method + INTEGER, PARAMETER :: time_average = 1 !< The reduction method is avera + INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms + INTEGER, PARAMETER :: time_max = 3 !< The reduction method is max + INTEGER, PARAMETER :: time_min = 4 !< The reduction method is min + INTEGER, PARAMETER :: time_sum = 5 !< The reudction method is sum + INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal + INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power + +!> @brief Class time_reduction_type has an encapsulation of the "Fortran enum" time +!! reduction integer parameters, plus an encapsulation of the groupings of +!! the time reduction types. It is inteded to provide some of the functionality +!! that was coded in the legacy function diag_data.F90:init_output_fields. +!! The functionality in the end is used by send_data in (EFFICIENT) do loops calling +!! the weighting or math functions to update buffers. +!! the The integer parameters above are the legal time_reduction_types, +!! but they are not necessarily mutually exclusive in some contexts. +!! +!> @addtogroup fms_diag_time_reduction_mod + TYPE time_reduction_type + integer , private :: the_type !< The time reduction type; integer as per diag_data_mod entries. + logical , private :: time_averaging !< Set true iff time_average, time_rms, time_power or time_diurnal is true + logical , private :: time_ops !< Set true iff time_min, time_max, time_rms or time_average is true. + CONTAINS + procedure, public :: do_time_averaging => do_time_averaging_imp + procedure, public :: has_time_ops => has_time_ops_imp + procedure, public :: is_time_none => is_time_none_imp + procedure, public :: is_time_average => is_time_average_imp + procedure, public :: is_time_rms => is_time_rms_imp + procedure, public :: is_time_max => is_time_max_imp + procedure, public :: is_time_min => is_time_min_imp + procedure, public :: is_time_sum => is_time_sum_imp + procedure, public :: is_time_diurnal => is_time_diurnal_imp + procedure, public :: is_time_power => is_time_power_imp + procedure, public :: initialize + END TYPE time_reduction_type + +!> @brief This interface is for the class constructor. +!> @addtogroup fms_diag_time_reduction_mod + interface time_reduction_type + procedure :: time_reduction_type_constructor + end interface time_reduction_type + +CONTAINS + + !> @brief The class contructors. Just allocates the class and calls an initializer + function time_reduction_type_constructor(dt, out_frequency) result(time_redux) + integer, intent(in) :: dt !> The redution type (time_rms, time_porer, etc) + integer, intent(in) :: out_frequency !> The output frequency. + class (time_reduction_type), allocatable :: time_redux + allocate(time_redux) + call time_redux%initialize(dt, out_frequency) + end function time_reduction_type_constructor + +!> @brief Initialize the object. + subroutine initialize(this, dt, out_frequency) + class (time_reduction_type), intent(inout) :: this !> The time_reduction_type object + integer, intent(in) :: dt !> The redution type (time_rms, time_porer, etc) + integer, intent(in) :: out_frequency !> The output frequency. + + this%the_type = dt + + !! set the time_averaging flag + !! See legacy init_ouput_fields function, lines 1470ff + IF(( dt .EQ. time_average) .OR. (dt .EQ. time_rms) .OR. (dt .EQ. time_power) .OR. & + & (dt .EQ. time_diurnal)) THEN + this%time_averaging = .true. + ELSE + this%time_averaging= .false. + IF(out_frequency .NE. EVERY_TIME) THEN + CALL error_mesg('time_reduction_type:time_reduction_type_new', & + & 'time_averaging=.false. but out_frequency .ne. EVERY_TIME', FATAL) + ENDIF + IF((dt .NE. time_max) .AND. (dt .ne. time_min) .AND. (dt .NE. time_sum) & + & .AND. (dt .NE. time_none)) THEN + CALL error_mesg('time_reduction_type: time_reduction_type_new', & + & 'time_averaging=.false. but reduction type not compatible', FATAL) + ENDIF + END IF + + !!See legacy init_output_fields concerning time_ops + !!TODO: how about time_rms ... + IF((dt .EQ. time_min) .OR. (dt .EQ. time_max) .OR. & + & ( dt .EQ. time_average) .OR. (dt .EQ. time_sum) ) THEN + this%time_ops = .true. + ELSE + this%time_ops = .false. + END IF + end subroutine initialize + + + +!> \brief Returns true if any of time_min, time_max, time_rms or time_average is true. +!! @return true if if any of time_min, time_max, time_rms or time_average is true. + pure function has_time_ops_imp (this) + class (time_reduction_type), intent(in) :: this ! \brief Returns true iff time_averaging is true. + !! @return true iff time_averaging is true. + pure function do_time_averaging_imp (this) + class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_average + !! @return true iff the_type is time_average + pure function is_time_average_imp (this) + class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_none + !! @return true iff the_type is time_none + pure function is_time_none_imp (this) + class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_rms + !! @return true iff the_type is time_rms + pure function is_time_rms_imp (this) + class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_max + !! @return true iff the_type is time_max + pure function is_time_max_imp (this) + class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_min + !! @return true iff the_type is time_min + pure function is_time_min_imp (this) + class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_sum + !! @return true iff the_type is time_sum + pure function is_time_sum_imp (this) + class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_diurnal + !! @return true iff the_type is time_diurnal + pure function is_time_diurnal_imp (this) + class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_power + !! @return true iff the_type is time_power + pure function is_time_power_imp (this) + class (time_reduction_type), intent(in) :: this ! @} +! close documentation grouping diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 9a80547000..9e7969788b 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -26,16 +26,16 @@ !! Note this function may set field object members active_omp_level and num_threads. !> @addtogroup fms_diag_fieldbuff_update_mod !> @{ - FUNCTION FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_obj, field_d, sample, & - & ofb, ofc, ntval, count_0d, num_elements, mask, weight1, missvalue, missvalue_present, & + FUNCTION FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_d, sample, & + & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, missvalue_present, & + & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object - TYPE(fmsDiagField_type), INTENT(inout) :: field_obj !< The field object FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< Output Field Buffer FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofc !< Output Field Counter - TYPE(fms_diag_buff_intervals_t), INTENT(inout) :: ntval !< An instance of the class fms_diag_buff_intervals_t + TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. INTEGER, INTENT(inout) :: num_elements @@ -44,6 +44,10 @@ REAL, INTENT(in) :: weight1 !< Field data is multiplied by weight !!TODO: Change to same type as field data? FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. LOGICAL, INTENT(in) :: missvalue_present !< .true. if missvalue is present. + INTEGER, INTENT(inout) :: field_num_threads + INTEGER, INTENT(inout) :: field_active_omp_level + + LOGICAL, INTENT(inout) :: issued_mask_ignore_warning INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on 3 axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on 3 axes for regional output CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg @@ -56,6 +60,8 @@ LOGICAL :: phys_window !< A copy of same variable in ofield_cfg LOGICAL :: need_compute !< A copy of same variable in ofield_cfg LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg + LOGICAL :: mask_variant !< A copy of same variable in ofield_cfg + LOGICAL :: mask_present !< A copy of same variable in ofield_cfg !> The indecies copied directly from the ofield_index_cfg: INTEGER:: is, js, ks, ls, ie, je, ke, le, hi, hj, f1, f2, f3, f4 @@ -64,11 +70,12 @@ !> Looping indecies, derived from ofield_index_cfg: INTEGER :: i, j, k, i1, j1, k1 + INTEGER :: numthreads + INTEGER :: active_omp_level + LOGICAL :: succeded !> True iff no errors encountered. CHARACTER(len=128):: error_string - INTEGER :: numthreads - INTEGER :: active_omp_level #if defined(_OPENMP) INTEGER :: omp_get_num_threads !< OMP function INTEGER :: omp_get_level !< OMP function @@ -99,19 +106,21 @@ phys_window = ofield_cfg%phys_window reduced_k_range = ofield_cfg%reduced_k_range need_compute = ofield_cfg%need_compute + mask_variant = ofield_cfg%mask_variant + mask_present = ofield_cfg%mask_present !$OMP CRITICAL - call field_obj%set_num_threads (1) - call field_obj%set_active_omp_level (0) + field_num_threads = 1 + active_omp_level = 0 #if defined(_OPENMP) - call field_obj%set_num_threads (omp_get_num_threads()) - call field_obj%set_active_omp_level (omp_get_level()) + field_num_threads = omp_get_num_threads() + field_active_omp_level = omp_get_level() #endif - numthreads = field_obj%get_num_threads() - active_omp_level = field_obj%get_active_omp_level() + numthreads = field_num_threads + active_omp_level = field_active_omp_level !$OMP END CRITICAL - MASK_VAR_IF: IF ( field_obj%has_mask_variant() ) THEN + MASK_VAR_IF: IF ( mask_variant ) THEN IF ( need_compute ) THEN WRITE (error_string,'(a,"/",a)') TRIM(module_name), TRIM(output_name) IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& @@ -124,11 +133,11 @@ ! Should reduced_k_range data be supported with the mask_variant option ????? ! If not, error message should be produced and the reduced_k_range loop below eliminated - MASK_PR_1_IF: IF ( PRESENT(mask) ) THEN + MASK_PR_1_IF: IF (mask_present ) THEN MISSVAL_PR_1_IF: IF ( missvalue_present ) THEN !!(section: mask_varian .eq. true + mask present) IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -212,7 +221,7 @@ END IF END IF MASK_PR_1_IF ELSE MASK_VAR_IF - MASK_PR_2_IF: IF ( PRESENT(mask) ) THEN + MASK_PR_2_IF: IF (mask_present ) THEN MISSVAL_PR_2_IF: IF ( missvalue_present ) THEN !!section:(mask_var false +mask present +missval prsnt) NDCMP_RKR_1_IF: IF ( need_compute ) THEN IF (numthreads>1 .AND. phys_window) then @@ -300,8 +309,8 @@ END IF ELSE NDCMP_RKR_1_IF IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -349,7 +358,7 @@ !$OMP END CRITICAL ELSE MISSVAL_PR_2_IF !! (section: mask_varian .eq. false + mask present + miss value not present) IF ( (.NOT.ALL(mask(f1:f2,f3:f4,ks:ke,:)) .AND. mpp_pe() .EQ. mpp_root_pe()).AND.& - & .NOT. field_obj%get_issued_mask_ignore_warning() ) THEN + & .NOT. issued_mask_ignore_warning) THEN ! ! Mask will be ignored since missing values were not specified for field ! in module @@ -358,7 +367,7 @@ & 'Mask will be ignored since missing values were not specified for field '//& & trim(field_name)//' in module '//& & trim(module_name), WARNING) - CALL field_obj%set_issued_mask_ignore_warning(.TRUE.) + issued_mask_ignore_warning = .TRUE. END IF NDCMP_RKR_2_IF: IF ( need_compute ) THEN IF (numthreads>1 .AND. phys_window) then @@ -414,8 +423,8 @@ END IF ELSE NDCMP_RKR_2_IF IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '') THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -557,8 +566,8 @@ !$OMP END CRITICAL ELSE NDCMP_RKR_3_IF IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -665,8 +674,8 @@ ELSE NDCMP_RKR_4_IF IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF (fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -708,14 +717,14 @@ !> \Description May set or add to the output field buffer (argument ofb) with the input !! field data array (argument field) FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & - & ntval, count_0d, mask, missvalue, missvalue_present, & + & bbounds, count_0d, mask, missvalue, missvalue_present, & & l_start, l_end, err_msg, err_msg_local) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:), INTENT(in) :: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< The Output Field Buffer - TYPE(fms_diag_buff_intervals_t), INTENT(inout) :: ntval + TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !> Normally the member of the buffer of same name, LOGICAL, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !> buffer may be set to this value where mask is false. @@ -730,15 +739,17 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, !> The indecies copied directly from the ofield_index_cfg INTEGER :: is, js, ks, ie, je, ke, hi, hj, f1, f2, f3, f4 + CHARACTER(:), ALLOCATABLE :: output_name !< A copy of same variable in ofield_cfg + CHARACTER(:), ALLOCATABLE :: module_name !< A copy of same variable in ofield_cfg LOGICAL :: need_compute !< A copy of same variable in ofield_cfg LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg + LOGICAL :: mask_present !< A copy of same variable in ofield_cfg INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations !> Looping indecies, derived from ofield_index_cfg: INTEGER :: i, j, k, i1, j1, k1 - CHARACTER(:), ALLOCATABLE :: output_name - CHARACTER(:), ALLOCATABLE :: module_name + LOGICAL :: time_max, time_min, time_sum ksr= l_start(3) @@ -765,10 +776,12 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, module_name = trim(ofield_cfg%module_name) reduced_k_range = ofield_cfg%reduced_k_range need_compute = ofield_cfg%need_compute + mask_present = ofield_cfg%mask_present + ! Add processing for Max and Min TIME_IF: IF ( time_max ) THEN - MASK_PRSNT_1_IF: IF ( PRESENT(mask) ) THEN + MASK_PRSNT_1_IF: IF (mask_present ) THEN IF ( need_compute ) THEN DO k = l_start(3), l_end(3) k1 = k - l_start(3) + 1 @@ -795,8 +808,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -833,8 +846,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -849,7 +862,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, count_0d = 1 !END TIME MAX ELSE IF ( time_min ) THEN TiME_IF - MASK_PRSNT_2_IF: IF ( PRESENT(mask) ) THEN + MASK_PRSNT_2_IF: IF (mask_present ) THEN IF ( need_compute ) THEN DO k = l_start(3), l_end(3) k1 = k - l_start(3) + 1 @@ -876,8 +889,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -913,8 +926,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -930,7 +943,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, !! END_TIME_MIN ELSE IF ( time_sum ) THEN TIME_IF - MASK_PRSNT_3_IF: IF ( PRESENT(mask) ) THEN + MASK_PRSNT_3_IF: IF (mask_present ) THEN IF ( need_compute ) THEN DO k = l_start(3), l_end(3) k1 = k - l_start(3) + 1 @@ -956,8 +969,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -991,8 +1004,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1025,8 +1038,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(ntval, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, ntval, output_name, module_name, err_msg_local) + CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1037,7 +1050,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, OFB(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) = field(f1:f2,f3:f4,ks:ke,:) END IF - IF ( PRESENT(mask) .AND. missvalue_present ) THEN + IF (mask_present .AND. missvalue_present ) THEN IF ( need_compute ) THEN DO k = l_start(3), l_end(3) k1 = k - l_start(3) + 1 diff --git a/diag_manager/include/fms_diag_fieldbuff_update.inc b/diag_manager/include/fms_diag_fieldbuff_update.inc index 52363beca1..b053a5a275 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.inc +++ b/diag_manager/include/fms_diag_fieldbuff_update.inc @@ -17,23 +17,3 @@ #undef FMS_DIAG_FBCM_PNAME_ #define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_r8 #include - -#undef FMS_DIAG_FBU_DATA_TYPE_ -#define FMS_DIAG_FBU_DATA_TYPE_ INTEGER(i4_kind) -#undef FMS_DIAG_FBU_PNAME_ -#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_i4 -#undef FMS_DIAG_FBCF_PNAME_ -#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_i4 -#undef FMS_DIAG_FBCM_PNAME_ -#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_i4 -#include - -#undef FMS_DIAG_FBU_DATA_TYPE_ -#define FMS_DIAG_FBU_DATA_TYPE_ INTEGER(i8_kind) -#undef FMS_DIAG_FBU_PNAME_ -#define FMS_DIAG_FBU_PNAME_ fieldbuff_update_i8 -#undef FMS_DIAG_FBCF_PNAME_ -#define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_i8 -#undef FMS_DIAG_FBCM_PNAME_ -#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_i8 -#include From a7bc2905dd949c668072bba02a538505747decd6 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Wed, 4 Jan 2023 16:31:35 -0500 Subject: [PATCH 05/37] First version that compiles (with gcc). --- diag_manager/diag_manager.F90 | 57 +++++++---------- diag_manager/fms_diag_fieldbuff_update.F90 | 6 +- diag_manager/fms_diag_outfield.F90 | 9 ++- .../include/fms_diag_fieldbuff_update.fh | 64 +++++++++++++++++-- .../include/fms_diag_fieldbuff_update.inc | 4 ++ 5 files changed, 97 insertions(+), 43 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 915503ded0..15883b9a30 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -240,6 +240,8 @@ MODULE diag_manager_mod USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end USE constants_mod, ONLY: SECONDS_PER_DAY USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_index_type, fms_diag_outfield_type + USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_misvals, & + & fieldbuff_copy_fieldvals #ifdef use_netCDF USE netcdf, ONLY: NF90_INT, NF90_FLOAT, NF90_CHAR @@ -3125,11 +3127,11 @@ END FUNCTION send_data_3d LOGICAL FUNCTION send_data_3d_refac(diag_field_id, field, time, is_in, js_in, ks_in, & & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) INTEGER, INTENT(in) :: diag_field_id - CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field + CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field CLASS(*), INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in - LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg @@ -3168,12 +3170,9 @@ LOGICAL FUNCTION send_data_3d_refac(diag_field_id, field, time, is_in, js_in, ks TYPE(fms_diag_outfield_index_type), ALLOCATABLE:: ofield_index_cfg TYPE(fms_diag_outfield_type), ALLOCATABLE:: ofield_cfg + LOGICAL :: temp_result - REAL, dimension(:,:,:,:), pointer::field_ptr => null() !< Ptr to field data array - REAL, dimension(:,:,:,:), pointer::mask_ptr => null() !< Ptr to field data mask array REAL, dimension(:,:,:,:), pointer::rmask_ptr => null() !< Ptr to field data rmask array - REAL, dimension(:,:,:,:,:), pointer::ofb_ptr => null() ! null() ! output_fields(out_num)%buffer, & - & ofc => output_fields(out_num)%counter) + !! TODO: Question: note that mask was declared allocatable in order to call fieldbuff_update (which + !! in tuen needs mask to be allocatable for pointer remapping). Is this an issue as + !! original send_data_3d did not have mask as so. IF ( average ) THEN - field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field - rmask_ptr(1:size(rmask,1),1:size(rmask,2),1:size(rmask,3),1:1) => rmask - ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3),1:1) => ofb - ofc_ptr(1:size(ofc,1),1:size(ofc,2),1:size(ofc,3),1:1) => ofc - IF(PRESENT ( mask) ) THEN - mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask - ENDIF - - IF(PRESENT ( mask) ) THEN - mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask - ENDIF - - temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_ptr, sample, & - & ofb_ptr,ofc_ptr, ofield_cfg%buff_bounds, & + !!TODO: the copy that is filed_out should not be necessary + temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & + & output_fields(out_num)%buffer, output_fields(out_num)%counter , ofield_cfg%buff_bounds, & & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & - & mask, weight, missval_r4_ptr, missvalue_present, & + & mask, weight1 ,missvalue, & & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& - & has_mask_variant, input_fields(diag_field_id)%issued_mask_ignore_warning, & + & input_fields(diag_field_id)%issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) - IF (temp_result .eqv. .FALSE.) THEN - DEALLOCATE(oor_mask) - RETURN - END IF + IF (temp_result .eqv. .FALSE.) THEN + DEALLOCATE(oor_mask) + RETURN + END IF ELSE !!NOT AVERAGE + !!rmask_ptr(1:size(rmask,1),1:size(rmask,2),1:size(rmask,3),1:1) => rmask + !!fieldbuff_sample IF (temp_result .eqv. .FALSE.) THEN DEALLOCATE(oor_mask) @@ -3614,7 +3601,7 @@ LOGICAL FUNCTION send_data_3d_refac(diag_field_id, field, time, is_in, js_in, ks END IF DEALLOCATE(ofield_index_cfg) DEALLOCATE(ofield_cfg) - END ASSOCIATE + !!END REFACTORED SECTION WITH WEIGHTING FUNCTIONS - END diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index 1719cf5341..e159e8c344 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -51,7 +51,11 @@ MODULE fms_diag_fieldbuff_update_mod module procedure fieldbuff_update_r4 !< r8 version of the interface module procedure fieldbuff_update_r8 - !< i4 version of the interface + !< r4 version of the interface, where the field is 3D + module procedure fieldbuff_update_3d_r4 + !< r8 version of the interface + module procedure fieldbuff_update_3d_r8 + !< i4 version of the interface, , where the field is 3D !module procedure fieldbuff_update_i4 !< i8 version of the interface ! module procedure fieldbuff_update_i8 diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index 2d2c7e1fd7..3040049457 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -96,12 +96,14 @@ PURE FUNCTION weight_the_field ( field_val, weight, pow_value ) LOGICAL :: phys_window !< TODO: Rename? OMP subsetted data, See output_fields LOGICAL :: need_compute !< True iff is local_output and current PE take part in send_data. LOGICAL :: reduced_k_range !< If true, the local start and end indecies are used in k (i.e. 3rd) dim. + LOGICAL :: missvalue_present !< LOGICAL :: mask_variant LOGICAL :: mask_present !< True iff mars arguemnt is present in user-facing send function call. !< Note this field exist since the actual mask argument in the send !< function call may be downstream replaced by a null pointer which !< is considered present. + TYPE(time_reduction_type) :: time_reduction !< Instance of the time_reduction_type. TYPE(fms_diag_ibounds_type) :: buff_bounds !< Instance of a fms_diag_buff_intervals_t type. @@ -185,10 +187,11 @@ END SUBROUTINE initialize_outfield_index_type !! num_elements in output_field; possibly pass by itself to update_field. !!output_frequecy in file_type. !> @brief Update with those fields used in the legacy diag manager. - SUBROUTINE initialize_outfield_imp(this, input_field, output_field ) + SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_present) CLASS(fms_diag_outfield_type), INTENT(inout) :: this TYPE(input_field_type), INTENT(in) :: input_field TYPE(output_field_type), INTENT(in) :: output_field + LOGICAL, INTENT(in) :: mask_present this%module_name = input_field%module_name this%field_name = input_field%field_name @@ -199,6 +202,10 @@ SUBROUTINE initialize_outfield_imp(this, input_field, output_field ) this%need_compute =output_field%need_compute this%reduced_k_range = output_field%reduced_k_range this%mask_variant = input_field%mask_variant + !!Note: in legacy diag manager, presence of missing value vs presence of mask + !! is determined in different ways (diag table vs send function call) + this%missvalue_present = input_field%missing_value_present + this%mask_present = mask_present !!And set the power function diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 9e7969788b..e7d07010cc 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -17,6 +17,55 @@ !* License along with FMS. If not, see . !*********************************************************************** !! +FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & + & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & + & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) result( succeded ) + TYPE(fms_diag_outfield_type), INTENT(inout), ALLOCATABLE:: ofield_cfg !< The ofield_cfg object + TYPE(fms_diag_outfield_index_type) , INTENT(inout), ALLOCATABLE :: ofield_index_cfg !< The ofield_index_cfg object + FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), target :: field_d !< The input field data array. + INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:), INTENT(inout), target :: ofb !< Output Field Buffer + FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:), INTENT(inout), target :: ofc !< Output Field Counter + TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t + FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. + INTEGER, INTENT(inout) :: num_elements + + + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask !< mask + REAL, INTENT(in) :: weight1 !< Field data is multiplied by weight !!TODO: Change to same type as field data? + FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. + + INTEGER, INTENT(inout) :: field_num_threads + INTEGER, INTENT(inout) :: field_active_omp_level + + LOGICAL, INTENT(inout) :: issued_mask_ignore_warning + INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on 3 axes for regional output + INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on 3 axes for regional output + CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg + CHARACTER(len=256), INTENT(inout) :: err_msg_local + + !! For pointer bounds remapping + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr !< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr !< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr !< + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< + + LOGICAL :: succeded !> True iff no errors encountered. + + !!TODO: Why did field_d, ofb, and ofc need to be allocatable"? + field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d(:,:,:) + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:size(ofb,4),1:1) => ofb + ofc_ptr(1:size(ofc,1),1:size(ofc,2),1:size(ofc,3), 1:size(ofc,4),1:1) => ofc + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + + succeded = FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & + & ofb_ptr, ofc_ptr, bbounds, count_0d, num_elements, mask_ptr, weight1, missvalue, & + & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local) + END FUNCTION FMS_DIAG_FBU_3D_PNAME_ + + !> @brief Updates elements of the running field output buffer (argument ofb) !! and counter (argument ofc) based on the input field data array (argument field_d). !! In general the formulas are : @@ -27,7 +76,7 @@ !> @addtogroup fms_diag_fieldbuff_update_mod !> @{ FUNCTION FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_d, sample, & - & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, missvalue_present, & + & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object @@ -43,7 +92,7 @@ LOGICAL, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask !< mask REAL, INTENT(in) :: weight1 !< Field data is multiplied by weight !!TODO: Change to same type as field data? FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. - LOGICAL, INTENT(in) :: missvalue_present !< .true. if missvalue is present. + INTEGER, INTENT(inout) :: field_num_threads INTEGER, INTENT(inout) :: field_active_omp_level @@ -51,7 +100,7 @@ INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on 3 axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on 3 axes for regional output CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg - CHARACTER(len=*), INTENT(inout) :: err_msg_local + CHARACTER(len=256), INTENT(inout) :: err_msg_local INTEGER :: pow_value !< A copy of same variable in ofield_cfg CHARACTER(:), ALLOCATABLE :: output_name !< A copy of same variable in ofield_cfg @@ -62,6 +111,7 @@ LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg LOGICAL :: mask_variant !< A copy of same variable in ofield_cfg LOGICAL :: mask_present !< A copy of same variable in ofield_cfg + LOGICAL :: missvalue_present !< A copy of same variable in ofield_cfg !> The indecies copied directly from the ofield_index_cfg: INTEGER:: is, js, ks, ls, ie, je, ke, le, hi, hj, f1, f2, f3, f4 @@ -108,6 +158,7 @@ need_compute = ofield_cfg%need_compute mask_variant = ofield_cfg%mask_variant mask_present = ofield_cfg%mask_present + missvalue_present = ofield_cfg%missvalue_present !$OMP CRITICAL field_num_threads = 1 @@ -717,7 +768,7 @@ !> \Description May set or add to the output field buffer (argument ofb) with the input !! field data array (argument field) FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & - & bbounds, count_0d, mask, missvalue, missvalue_present, & + & bbounds, count_0d, mask, missvalue, & & l_start, l_end, err_msg, err_msg_local) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object @@ -728,11 +779,10 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !> Normally the member of the buffer of same name, LOGICAL, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !> buffer may be set to this value where mask is false. - LOGICAL, INTENT(in) :: missvalue_present INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg - CHARACTER(len=*), INTENT(inout) :: err_msg_local + CHARACTER(len=256), INTENT(inout) :: err_msg_local LOGICAL :: succeded !> Return true iff errors are not encounterd. !! !! @@ -744,6 +794,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, LOGICAL :: need_compute !< A copy of same variable in ofield_cfg LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg LOGICAL :: mask_present !< A copy of same variable in ofield_cfg + LOGICAL :: missvalue_present !< A copy of same variable in ofield_cfg INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations !> Looping indecies, derived from ofield_index_cfg: @@ -777,6 +828,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, reduced_k_range = ofield_cfg%reduced_k_range need_compute = ofield_cfg%need_compute mask_present = ofield_cfg%mask_present + missvalue_present = ofield_cfg%missvalue_present ! Add processing for Max and Min diff --git a/diag_manager/include/fms_diag_fieldbuff_update.inc b/diag_manager/include/fms_diag_fieldbuff_update.inc index b053a5a275..2aca8cc221 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.inc +++ b/diag_manager/include/fms_diag_fieldbuff_update.inc @@ -3,6 +3,8 @@ #undef FMS_DIAG_FBU_PNAME_ #define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r4 #undef FMS_DIAG_FBCF_PNAME_ +#define FMS_DIAG_FBU_3D_PNAME_ fieldbuff_update_3d_r4 +#undef FMS_DIAG_FBCF_3D_PNAME_ #define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r4 #undef FMS_DIAG_FBCM_PNAME_ #define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_r4 @@ -12,6 +14,8 @@ #define FMS_DIAG_FBU_DATA_TYPE_ REAL(r8_kind) #undef FMS_DIAG_FBU_PNAME_ #define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r8 +#undef FMS_DIAG_FBU_3D_PNAME_ +#define FMS_DIAG_FBU_3D_PNAME_ fieldbuff_update_3d_r8 #undef FMS_DIAG_FBCF_PNAME_ #define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r8 #undef FMS_DIAG_FBCM_PNAME_ From 46c909c616c0eb92771a0f29e7815f76c57adba5 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Thu, 5 Jan 2023 16:22:49 -0500 Subject: [PATCH 06/37] Moved elemental math function to own module (fms_diag_elem_weight_procs.F90). Fixed CMakeLists.txt; cleaned up fms_diag_outfield_mod. --- CMakeLists.txt | 5 + diag_manager/Makefile.am | 8 +- diag_manager/diag_manager.F90 | 4 +- diag_manager/fms_diag_elem_weight_procs.F90 | 77 ++++++++++++++++ diag_manager/fms_diag_fieldbuff_update.F90 | 1 + diag_manager/fms_diag_outfield.F90 | 92 ++----------------- .../include/fms_diag_fieldbuff_update.fh | 8 +- 7 files changed, 106 insertions(+), 89 deletions(-) create mode 100644 diag_manager/fms_diag_elem_weight_procs.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 3ac2a35b61..7fd8ad633c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -124,6 +124,10 @@ list(APPEND fms_fortran_src_files diag_manager/diag_output.F90 diag_manager/diag_table.F90 diag_manager/diag_util.F90 + diag_manager/fms_diag_time_reduction.F90 + diag_manager/fms_diag_outfield.F90 + diag_manager/fms_diag_elem_weight_procs.F90 + diag_manager/fms_diag_fieldbuff_update.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 @@ -292,6 +296,7 @@ foreach(kind ${kinds}) fms fms2_io/include mpp/include + diag_manager/include constants4 constants) target_compile_definitions(${libTgt}_f PRIVATE "${fms_defs}") diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index cfba07e75b..21a6300335 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -40,6 +40,7 @@ libdiag_manager_la_SOURCES = \ diag_util.F90 \ fms_diag_time_reduction.F90 \ fms_diag_outfield.F90 \ + fms_diag_elem_weight_procs.F90 \ fms_diag_fieldbuff_update.F90 \ include/fms_diag_fieldbuff_update.inc \ include/fms_diag_fieldbuff_update.fh @@ -52,8 +53,10 @@ diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) -fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) -fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) +fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) +fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) +fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_elem_weight_procs_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ @@ -70,6 +73,7 @@ MODFILES = \ diag_table_mod.$(FC_MODEXT) \ fms_diag_time_reduction_mod.$(FC_MODEXT) \ fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ diag_manager_mod.$(FC_MODEXT) \ include/fms_diag_fieldbuff_update.inc \ diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 15883b9a30..ff936c8b1f 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -3539,8 +3539,8 @@ LOGICAL FUNCTION send_data_3d_refac(diag_field_id, field, time, is_in, js_in, ks status = writing_field(out_num, .FALSE., error_string, time) IF(status == -1) THEN IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN - IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '//TRIM(error_string)& - & //', write EMPTY buffer', err_msg)) THEN + IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '& + &//TRIM(error_string)//', write EMPTY buffer', err_msg)) THEN DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN diff --git a/diag_manager/fms_diag_elem_weight_procs.F90 b/diag_manager/fms_diag_elem_weight_procs.F90 new file mode 100644 index 0000000000..0d7b33f54d --- /dev/null +++ b/diag_manager/fms_diag_elem_weight_procs.F90 @@ -0,0 +1,77 @@ +MODULE fms_diag_elem_weight_procs_mod + USE platform_mod + + implicit none + INTERFACE addwf + module procedure addwf_r4 + module procedure addwf_r8 + module procedure addwf_i4 + module procedure addwf_i8 + END INTERFACE + +CONTAINS + + ELEMENTAL PURE SUBROUTINE addwf_r4(buff, field, weight, pow_value ) + REAL(r4_kind), INTENT(inout) :: buff + REAL(r4_kind), INTENT(IN) :: field + REAL, INTENT(IN) :: weight + INTEGER, INTENT(IN) :: pow_value + + SELECT CASE(pow_value) + CASE (1) + buff = buff + weight * field + CASE (2) + buff = buff + (weight * field) * (weight * field) + CASE default + buff = buff + (weight * field) ** pow_value + END SELECT + END SUBROUTINE addwf_r4 + + ELEMENTAL PURE SUBROUTINE addwf_r8(buff, field, weight, pow_value ) + REAL(r8_kind), INTENT(inout) :: buff + REAL(r8_kind) ,INTENT(IN) :: field + REAL, INTENT(IN) :: weight + INTEGER, INTENT(IN) :: pow_value + + SELECT CASE(pow_value) + CASE (1) + buff = buff + weight * field + CASE (2) + buff = buff + (weight * field) * (weight * field) + CASE default + buff = buff + (weight * field) ** pow_value + END SELECT + END SUBROUTINE addwf_r8 + + ELEMENTAL PURE SUBROUTINE addwf_i4(buff, field, weight, pow_value ) + INTEGER(i4_kind), INTENT(inout) :: buff + INTEGER(i4_kind), INTENT(IN) :: field + INTEGER, INTENT(IN) :: weight + INTEGER, INTENT(IN) :: pow_value + SELECT CASE(pow_value) + CASE (1) + buff = buff + weight * field + CASE (2) + buff = buff + (weight * field) * (weight * field) + CASE default + buff = buff + (weight * field) ** pow_value + END SELECT + END SUBROUTINE addwf_i4 + + ELEMENTAL PURE SUBROUTINE addwf_i8(buff, field, weight, pow_value ) + INTEGER(i8_kind), INTENT(inout) :: buff + INTEGER(i8_kind) ,INTENT(IN) :: field + INTEGER, INTENT(IN) :: weight + INTEGER, INTENT(IN) :: pow_value + + SELECT CASE(pow_value) + CASE (1) + buff = buff + weight * field + CASE (2) + buff = buff + (weight * field) * (weight * field) + CASE default + buff = buff + (weight * field) ** pow_value + END SELECT + END SUBROUTINE addwf_i8 +END MODULE fms_diag_elem_weight_procs_mod + diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index e159e8c344..fcb4e91432 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -40,6 +40,7 @@ MODULE fms_diag_fieldbuff_update_mod USE diag_data_mod, ONLY: debug_diag_manager, fms_diag_ibounds_type USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_index_type, fms_diag_outfield_type USE diag_util_mod, ONLY: check_out_of_bounds, update_bounds + USE fms_diag_elem_weight_procs_mod, ONLY: addwf implicit none diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index 3040049457..69ef0fe702 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -34,7 +34,7 @@ !> @addtogroup fms_diag_outfield_mod !> @{ MODULE fms_diag_outfield_mod - + USE platform_mod USE mpp_mod, only :FATAL USE fms_mod, only :lowercase, uppercase, error_mesg, fms_error_handler @@ -55,24 +55,6 @@ MODULE fms_diag_outfield_mod implicit none - ABSTRACT INTERFACE - PURE FUNCTION weight_the_field ( field_val, weight, pow_value ) - REAL, INTENT(in) :: field_val - REAL, INTENT(in) :: weight - INTEGER, INTENT(in) :: pow_value - REAL :: weight_the_field - END FUNCTION - END INTERFACE - - - TYPE fms_diag_field_weighting_type - PROCEDURE (weight_the_field), NOPASS, POINTER::fwf_ptr=>null() !! A pointer to the field weighting function. - CONTAINS - PROCEDURE, PASS :: WF - END TYPE - - - !> @brief Class fms_diag_outfield_type (along with class ms_diag_outfield_index_type ) !! contain information used in updating the output buffers by the diag_manager !! send_data routines. In some sense they can be seen as encapsulating related @@ -103,30 +85,13 @@ PURE FUNCTION weight_the_field ( field_val, weight, pow_value ) !< function call may be downstream replaced by a null pointer which !< is considered present. - TYPE(time_reduction_type) :: time_reduction !< Instance of the time_reduction_type. TYPE(fms_diag_ibounds_type) :: buff_bounds !< Instance of a fms_diag_buff_intervals_t type. - !!TODO: Is nopass really needed here? Note that the functions are being passed pow_val, which - !! may not be necessary is designed in a cenetain way as power value is also a member - ! of fms_diag_outfield_type. - !! PROCEDURE (weight_the_field), POINTER, NOPASS::fwf_ptr=>null() !! A pointer to the field weighting function. - TYPE (fms_diag_field_weighting_type) :: wf - - !! possibly useful in modern: - !! INTEGER :: n_diurnal_samples !< Size of diurnal axis (also number of diurnal samples).value is >= 1 - - !LOGICAL :: static !< True iff the field is static. - !TYPE(time_type) :: last_output, next_output, next_next_output - !INTEGER :: pack !< The packing method. - - ! TYPE(diag_grid) :: output_grid - ! LOGICAL :: local_output !< True if the field output is on a local domain only. - ! TYPE(time_type) :: Time_of_prev_field_data + !! gcc error: Interface ‘addwf’ at (1) must be explicit + ! procedure (addwf), pointer, nopass :: f_ptr => null () !!A pointer to the field weighing procedure - ! logical :: reduced_k_unstruct = .false. !!Related to unstructured grid support - ! INTEGER :: total_elements CONTAINS procedure, public :: initialize => initialize_outfield_imp END TYPE fms_diag_outfield_type @@ -207,54 +172,15 @@ SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_presen this%missvalue_present = input_field%missing_value_present this%mask_present = mask_present + !!And set the power function ? + !! if ( this%pow_value == 1) then + ! this%f_ptr => ? + !! else end etc. - !!And set the power function - if ( this%pow_value == 1) then - this%wf%fwf_ptr => weight_the_field_p1 - else if ( this%pow_value == 2 ) then - this%wf%fwf_ptr => weight_the_field_p2 - else - this%wf%fwf_ptr => weight_the_field_pp - end if - !!TODO: - !!init the time_reduction, using - !!possibly using output_field%time_rms, output_field%time_max output_field%time_min, - !! and output_field%time_sum ? + !!TODO: init the time_reduction, possibly using output_field%time_rms, + !! output_field%time_max output_field%time_min, and output_field%time_sum ? END SUBROUTINE initialize_outfield_imp - ELEMENTAL PURE REAL FUNCTION wf(this, field_val, weight, pow_value ) - CLASS( fms_diag_field_weighting_type), INTENT (in) :: this - REAL, INTENT(in) :: field_val - REAL, INTENT(in) :: weight - INTEGER, INTENT(in) :: pow_value - wf = this%fwf_ptr(field_val, weight, pow_value) -END FUNCTION - - PURE REAL FUNCTION weight_the_field_p1 (field_val, weight, pow_value ) - REAL, INTENT(in) :: field_val !< The field values. - REAL, INTENT(in) :: weight !< The weighting coefficient. - INTEGER, INTENT(in) :: pow_value !< The weighting exponent. - weight_the_field_p1 = field_val * weight - END FUNCTION weight_the_field_p1 - -!> A function to quadraticaly weight scalar fields. - PURE REAL FUNCTION weight_the_field_p2 (field_val, weight, pow_value ) - REAL, INTENT(in) :: field_val !< The field values. - REAL, INTENT(in) :: weight !< The weighting coefficient. - INTEGER, INTENT(in) :: pow_value !< The weighting exponent. - REAL :: fTw - fTw = field_val * weight - weight_the_field_p2 = fTw * fTw - END FUNCTION weight_the_field_p2 - -!> A function to weight scalar fields by a an exponent. - PURE REAL FUNCTION weight_the_field_pp (field_val, weight, pow_value ) - !!CLASS(fms_diag_field_weighting_type), INTENT(in) :: this - REAL, INTENT(in) :: field_val !< The field values. - REAL, INTENT(in) :: weight !< The weighting coefficient. - INTEGER, INTENT(in) :: pow_value !< The weighting exponent. - weight_the_field_pp = (field_val * weight) ** pow_value - END FUNCTION weight_the_field_pp END MODULE fms_diag_outfield_mod !> @} diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index e7d07010cc..8f4c62ae09 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -206,6 +206,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) +& & (field_d(i-is+1+hi, j-js+1+hj, k, :) * weight1) ** pow_value + !ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) +& + !& ofield_cfg%wf%fwf_ptr (field_d(i-is+1+hi, j-js+1+hj, k, :), weight1, pow_value) ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 END where END DO @@ -690,8 +692,10 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & j <= l_end(2)+hj ) THEN i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 - ofb(i1,j1,:,:,sample)= ofb(i1,j1,:,:,sample) +& - & (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value + !ofb(i1,j1,:,:,sample)= ofb(i1,j1,:,:,sample) +& + !& (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value + call addwf(ofb(i1,j1,:,:,sample), & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :), weight1, pow_value) END IF END DO END DO From cd133a3c8d578b19d310549d70eaa1af61409699 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Thu, 5 Jan 2023 17:13:22 -0500 Subject: [PATCH 07/37] Shortening source code line length below 120 lines. --- diag_manager/include/fms_diag_fieldbuff_update.fh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 8f4c62ae09..8ec3d07c98 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -22,8 +22,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout), ALLOCATABLE:: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(inout), ALLOCATABLE :: ofield_index_cfg !< The ofield_index_cfg object - FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), target :: field_d !< The input field data array. + TYPE(fms_diag_outfield_index_type) , INTENT(inout), ALLOCATABLE :: ofield_index_cfg ! Date: Tue, 10 Jan 2023 13:57:53 -0500 Subject: [PATCH 08/37] First compiling version with refactored_send option and refactored meth functions. --- diag_manager/diag_data.F90 | 1 + diag_manager/diag_manager.F90 | 77 ++++- diag_manager/diag_util.F90 | 284 +++++++++++++----- diag_manager/fms_diag_elem_weight_procs.F90 | 48 +-- diag_manager/fms_diag_fieldbuff_update.F90 | 5 +- .../include/fms_diag_fieldbuff_update.fh | 100 +++--- .../include/fms_diag_fieldbuff_update.inc | 20 +- 7 files changed, 386 insertions(+), 149 deletions(-) diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index ebe354621e..bde45d42a8 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -346,6 +346,7 @@ MODULE diag_data_mod !! .TRUE. is only supported if the diag_manager_init !! routine is called with the optional time_init parameter. LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io + LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons. ! diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index ff936c8b1f..9c96964f1d 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -233,7 +233,7 @@ MODULE diag_manager_mod & use_cmor, issue_oor_warnings, oor_warnings_fatal, oor_warning, pack_size,& & max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes, output_field_type,& & max_file_attributes, max_axis_attributes, prepend_date, DIAG_FIELD_NOT_FOUND, diag_init_time, diag_data_init,& - & use_mpp_io + & use_mpp_io, use_refactored_send USE diag_data_mod, ONLY: fileobj, fileobjU, fnum_for_domain, fileobjND USE diag_table_mod, ONLY: parse_diag_table USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att @@ -1328,7 +1328,7 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out !< Local copy of field - LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out !< Local copy of mask + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: mask_out !< Local copy of mask ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1347,6 +1347,8 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT + ALLOCATE(mask_out(SIZE(field(:)), 1, 1)) + ! Default values for mask IF ( PRESENT(mask) ) THEN mask_out(:, 1, 1) = mask @@ -1397,7 +1399,7 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out !< Local copy of field - LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out !< Local copy of mask + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: mask_out !< Local copy of mask ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1416,6 +1418,7 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT + ALLOCATE(mask_out(SIZE(field,1),SIZE(field,2),1)) ! Default values for mask IF ( PRESENT(mask) ) THEN mask_out(:, :, 1) = mask @@ -1452,7 +1455,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CLASS(*), INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in - LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg @@ -1489,6 +1492,10 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field + TYPE(fms_diag_outfield_index_type), ALLOCATABLE:: ofield_index_cfg + TYPE(fms_diag_outfield_type), ALLOCATABLE:: ofield_cfg + LOGICAL :: temp_result + ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN send_data_3d = .FALSE. @@ -1877,6 +1884,50 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF END IF + IF (USE_REFACTORED_SEND) THEN + ALLOCATE( ofield_index_cfg ) + CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, & + & hi, hj, f1, f2, f3, f4) + + ALLOCATE( ofield_cfg ) + CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num), PRESENT(mask)) + !! TODO: missing time_reduction + + !! TODO: Question: note that mask was declared allocatable in order to call fieldbuff_update (which + !! in tuen needs mask to be allocatable for pointer remapping). Is this an issue as + !! original send_data_3d did not have mask as so. + IF ( average ) THEN + !!TODO: the copy that is filed_out should not be necessary + temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & + & output_fields(out_num)%buffer, output_fields(out_num)%counter , ofield_cfg%buff_bounds, & + & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & + & mask, weight1 ,missvalue, & + & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& + & input_fields(diag_field_id)%issued_mask_ignore_warning, & + & l_start, l_end, err_msg, err_msg_local ) + IF (temp_result .eqv. .FALSE.) THEN + DEALLOCATE(oor_mask) + RETURN + END IF + ELSE !!NOT AVERAGE + + temp_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_out, sample, & + & output_fields(out_num)%buffer, ofield_cfg%buff_bounds, output_fields(out_num)%count_0d(sample), & + & mask, missvalue, l_start, l_end, err_msg, err_msg_local) + IF (temp_result .eqv. .FALSE.) THEN + DEALLOCATE(oor_mask) + RETURN + END IF + END IF + IF ( PRESENT(rmask) .AND. missvalue_present ) THEN + temp_result = .true. !!TODO call :fieldbuff_copy_misvals() + END IF + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + + CYCLE !!. I.e. skip src code below and go to the next output field + END IF !! END USE_REFACTORED_SEND + ! Take care of submitted field data IF ( average ) THEN IF ( input_fields(diag_field_id)%mask_variant ) THEN @@ -3723,7 +3774,8 @@ LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask ) REAL, INTENT(in) :: field(:,:) !< field to average and send REAL, INTENT(in) :: area (:,:) !< area of tiles (== averaging weights), arbitrary units TYPE(time_type), INTENT(in) :: time !< current time - LOGICAL, INTENT(in),OPTIONAL :: mask (:,:) !< land mask + LOGICAL, ALLOCATABLE, INTENT(in),OPTIONAL :: mask (:,:) !< land mask + !!TODO: make_mask allocatable or send copy to allocatable? RE user interface. REAL, DIMENSION(SIZE(field,1)) :: out(SIZE(field,1)) @@ -3790,7 +3842,9 @@ LOGICAL FUNCTION send_tile_averaged_data2d ( id, field, area, time, mask ) REAL, INTENT(in) :: field(:,:,:) !< field to average and send REAL, INTENT(in) :: area (:,:,:) !< area of tiles (== averaging weights), arbitrary units TYPE(time_type), INTENT(in) :: time !< current time - LOGICAL, INTENT(in),OPTIONAL :: mask (:,:,:) !< land mask + LOGICAL, ALLOCATABLE, INTENT(in),OPTIONAL :: mask (:,:,:) !< land mask + !!TODO: make_mask allocatable or send copy to allocatable? RE user interface. + !!LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: mask_out REAL, DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(SIZE(field,1), SIZE(field,2)) @@ -3800,6 +3854,7 @@ LOGICAL FUNCTION send_tile_averaged_data2d ( id, field, area, time, mask ) RETURN END IF + CALL average_tiles(id, field, area, mask, out) send_tile_averaged_data2d = send_data(id, out, time, mask=ANY(mask,DIM=3)) END FUNCTION send_tile_averaged_data2d @@ -3811,10 +3866,14 @@ LOGICAL FUNCTION send_tile_averaged_data3d( id, field, area, time, mask ) REAL, DIMENSION(:,:,:), INTENT(in) :: area (:,:,:) !< (lon, lat, tile) tile areas ( == averaging !! weights), arbitrary units TYPE(time_type), INTENT(in) :: time !< current time - LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask !< (lon, lat, tile) land mask + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask !< (lon, lat, tile) land mask + !!TODO: make_mask allocatable or send copy to allocatable? RE user interface. + !!LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: mask_out REAL, DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out - LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3 + !!LOGICAL ,DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3 + LOGICAL, ALLOCATABLE,DIMENSION(:,:,:) :: mask3 + INTEGER :: it ! If id is < 0 it means that this field is not registered, simply return @@ -3827,6 +3886,8 @@ LOGICAL FUNCTION send_tile_averaged_data3d( id, field, area, time, mask ) CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) ) END DO + ALLOCATE( mask3 (SIZE(field,1),SIZE(field,2),SIZE(field,4))) + mask3(:,:,1) = ANY(mask,DIM=3) DO it = 2, SIZE(field,4) mask3(:,:,it) = mask3(:,:,1) diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 6e1acfa440..8280ff384e 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -77,7 +77,7 @@ MODULE diag_util_mod IMPLICIT NONE PRIVATE - PUBLIC get_subfield_size, log_diag_field_info, update_bounds, check_out_of_bounds,& + PUBLIC get_subfield_size, log_diag_field_info, bounds_from_array, update_bounds, check_out_of_bounds,& & check_bounds_are_exact_dynamic, check_bounds_are_exact_static, init_file, diag_time_inc,& & find_input_field, init_input_field, init_output_field, diag_data_out, write_static,& & check_duplicate_output_fields, get_date_dif, get_subfield_vert_size, sync_file_times,& @@ -98,6 +98,33 @@ MODULE diag_util_mod MODULE PROCEDURE attribute_init_file END INTERFACE attribute_init + INTERFACE update_bounds + module procedure update_bounds_legacy + module procedure update_bounds_modern + END INTERFACE update_bounds + + INTERFACE check_out_of_bounds + module procedure check_out_of_bounds_legacy + module procedure check_out_of_bounds_modern_r4 + module procedure check_out_of_bounds_modern_r8 + END INTERFACE check_out_of_bounds + + INTERFACE check_bounds_are_exact_dynamic + module procedure check_bounds_are_exact_dynamic_legacy + !!TODO: module procedure check_bounds_are_exact_dynamic_modern ? + END INTERFACE check_bounds_are_exact_dynamic + + INTERFACE check_bounds_are_exact_static + module procedure check_bounds_are_exact_static_legacy + !! TODO: module procedure check_bounds_are_exact_static_modern + END INTERFACE check_bounds_are_exact_static + + INTERFACE bounds_from_array + module procedure bounds_from_array_legacy + module procedure bounds_from_array_modern + END INTERFACE bounds_from_array + + !> @addtogroup diag_util_mod !> @{ @@ -731,8 +758,32 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& & TRIM(axes_list) END SUBROUTINE log_diag_field_info + !!3D spatial bounds + SUBROUTINE bounds_from_array_legacy(bounds, array) + REAL, INTENT( in), DIMENSION(:,:,:,:) :: array + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds + bounds%imin = LBOUND(array,1) + bounds%imax = UBOUND(array,1) + bounds%jmin = LBOUND(array,2) + bounds%jmax = UBOUND(array,2) + bounds%kmin = LBOUND(array,3) + bounds%kmax = UBOUND(array,3) + END SUBROUTINE bounds_from_array_legacy + + + SUBROUTINE bounds_from_array_modern(bounds, array) + CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds + bounds%imin = LBOUND(array,1) + bounds%imax = UBOUND(array,1) + bounds%jmin = LBOUND(array,2) + bounds%jmax = UBOUND(array,2) + bounds%kmin = LBOUND(array,3) + bounds%kmax = UBOUND(array,3) + END SUBROUTINE bounds_from_array_modern + !> @brief Update the output_fields x, y, and z min and max boundaries (array indices). - SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) + SUBROUTINE update_bounds_legacy(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) INTEGER, INTENT(in) :: out_num !< output field ID INTEGER, INTENT(in) :: lower_i !< Lower i bound. INTEGER, INTENT(in) :: upper_i !< Upper i bound. @@ -741,11 +792,11 @@ SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, u INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. CALL update_bounds_imp(output_fields(out_num)%buff_bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) - END SUBROUTINE update_bounds + END SUBROUTINE update_bounds_legacy !> @brief Update the output_fields x, y, and z (and optionally l) min and !! max boundaries (array indices). -SUBROUTINE update_bounds_imp(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) +SUBROUTINE update_bounds_modern(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) TYPE (fms_diag_ibounds_type) :: bounds !< the bounding box of the output field buffer inindex space. INTEGER, INTENT(in) :: lower_i !< Lower i bound. INTEGER, INTENT(in) :: upper_i !< Upper i bound. @@ -759,21 +810,9 @@ SUBROUTINE update_bounds_imp(bounds, lower_i, upper_i, lower_j, upper_j, lower_k bounds%jmax = MAX(bounds%jmax, upper_j) bounds%kmin = MIN(bounds%kmin, lower_k) bounds%kmax = MAX(bounds%kmax, upper_k) -END SUBROUTINE update_bounds_imp +END SUBROUTINE update_bounds_modern - !> @brief Checks if the array indices for output_fields(out_num) are outside the - !! output_fields(out_num)%buffer upper - !! and lower bounds. - SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) - INTEGER, INTENT(in) :: out_num !< Output field ID number. - INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty - !! error string indicates the x, y, and z indices are not outside the - !! buffer array boundaries. - CALL check_out_of_bounds_imp(output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds, & - & output_fields(out_num)%output_name, input_fields(diag_field_id)%module_name, err_msg) - END SUBROUTINE check_out_of_bounds !> @brief Compares the indecies in bounds to the corresponding lower and upper bounds of array buffer. !! Comparison is done by the two user specified input functions lowerb_comp and upperb_comp. @@ -781,10 +820,10 @@ END SUBROUTINE check_out_of_bounds !! false indicating one of the comparison tests indicated a problem. So the comparison test should !! return true for errors : for indecies out of bounds, or indecies are not equal when expected to !! be equal. -LOGICAL FUNCTION compare_buffer_bounds_to_size(buffer, bounds, output_name, module_name, error_str, & +LOGICAL FUNCTION compare_buffer_bounds_to_size(array_bounds, bounds, output_name, module_name, error_str, & & lowerb_comp, upperb_comp) - CLASS(*), INTENT(in), DIMENSION(:,:,:,:) :: buffer - TYPE (fms_diag_ibounds_type) :: bounds + TYPE (fms_diag_ibounds_type), INTENT(in) :: array_bounds + TYPE (fms_diag_ibounds_type), INTENT(in):: bounds CHARACTER(len=*), INTENT(in) :: output_name CHARACTER(len=*), INTENT(in) :: module_name CHARACTER(len=*), INTENT(inout) :: error_str @@ -805,20 +844,20 @@ END FUNCTION upperb_comp compare_buffer_bounds_to_size = .TRUE. - IF (lowerb_comp( bounds%imin, LBOUND(buffer,1)) .OR.& - upperb_comp( bounds%imax , UBOUND(buffer,1)) .OR.& - lowerb_comp( bounds%jmin , LBOUND(buffer,2)) .OR.& - upperb_comp( bounds%jmax , UBOUND(buffer,2)) .OR.& - lowerb_comp( bounds%kmin , LBOUND(buffer,3)) .OR.& - upperb_comp( bounds%kmax , UBOUND(buffer,3))) THEN + IF (lowerb_comp( bounds%imin , array_bounds%imin) .OR. & + upperb_comp( bounds%imax , array_bounds%imax).OR.& + lowerb_comp( bounds%jmin , array_bounds%jmin) .OR.& + upperb_comp( bounds%jmax , array_bounds%jmax) .OR.& + lowerb_comp( bounds%kmin , array_bounds%kmin) .OR.& + upperb_comp( bounds%kmax , array_bounds%kmax)) THEN compare_buffer_bounds_to_size = .FALSE. error_str ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_str(15:17),'(i3)') LBOUND(buffer,1) - WRITE(error_str(19:21),'(i3)') UBOUND(buffer,1) - WRITE(error_str(23:25),'(i3)') LBOUND(buffer,2) - WRITE(error_str(27:29),'(i3)') UBOUND(buffer,2) - WRITE(error_str(31:33),'(i3)') LBOUND(buffer,3) - WRITE(error_str(35:37),'(i3)') UBOUND(buffer,3) + WRITE(error_str(15:17),'(i3)') array_bounds%imin + WRITE(error_str(19:21),'(i3)') array_bounds%imax + WRITE(error_str(23:25),'(i3)') array_bounds%jmin + WRITE(error_str(27:29),'(i3)') array_bounds%jmax + WRITE(error_str(31:33),'(i3)') array_bounds%kmin + WRITE(error_str(35:37),'(i3)') array_bounds%kmax WRITE(error_str(54:56),'(i3)') bounds%imin WRITE(error_str(58:60),'(i3)') bounds%imax WRITE(error_str(62:64),'(i3)') bounds%jmin @@ -848,51 +887,128 @@ LOGICAL FUNCTION a_noteq_b(a, b) a_noteq_b = a /= b END FUNCTION a_noteq_b + !> @brief Checks if the array indices for output_fields(out_num) are outside the + !! output_fields(out_num)%buffer upper and lower bounds. +SUBROUTINE check_out_of_bounds_legacy(out_num, diag_field_id, err_msg) + INTEGER, INTENT(in) :: out_num !< Output field ID number. + INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fms_diag_ibounds_type) :: array_bounds + TYPE (fms_diag_ibounds_type), ALLOCATABLE :: buff_bounds - !> @brief Checks if the array indices for output_fields(out_num) are outside the -!! output_fields(out_num)%buffer upper and lower bounds. -SUBROUTINE check_out_of_bounds_imp(buffer, bounds, output_name, module_name, err_msg) - REAL, INTENT(in), DIMENSION(:,:,:,:) :: buffer - TYPE (fms_diag_ibounds_type) :: bounds - CHARACTER(len=*), INTENT(in) :: output_name - CHARACTER(len=*), INTENT(in) :: module_name - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds_imp. An empty + buff_bounds = output_fields(out_num)%buff_bounds + + CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) + + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & + & output_fields(out_num)%output_name, input_fields(diag_field_id)%module_name,& + & error_string2, a_lessthan_b, a_greaterthan_b) + + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') input_fields(diag_field_id)%module_name, output_fields(out_num)%output_name + err_msg = 'module/output_field='//TRIM(error_string1)//& + & ' Bounds of buffer exceeded. '//TRIM(error_string2) + ! imax, imin, etc need to be reset in case the program is not terminated. + buff_bounds%imax = 0 + buff_bounds%imin = VERY_LARGE_AXIS_LENGTH + buff_bounds%jmax = 0 + buff_bounds%jmin = VERY_LARGE_AXIS_LENGTH + buff_bounds%kmax = 0 + buff_bounds%kmin = VERY_LARGE_AXIS_LENGTH + ELSE + err_msg = '' + END IF +END SUBROUTINE check_out_of_bounds_legacy + + !> @brief Checks if the array indices for output_fields(out_num) are outside the + !! output_fields(out_num)%buffer upper and lower bounds. +SUBROUTINE check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name + CHARACTER(len=256), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the - !! buffer array boundaries. + CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: out_of_bounds = .true. + TYPE (fms_diag_ibounds_type) :: array_bounds + TYPE (fms_diag_ibounds_type), ALLOCATABLE :: buff_bounds - out_of_bounds = compare_buffer_bounds_to_size(buffer, bounds, output_name, module_name, & - & error_string2, a_lessthan_b, a_greaterthan_b) + CALL bounds_from_array(array_bounds, ofb) + + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & + & output_name, module_name, error_string2, a_lessthan_b, a_greaterthan_b) IF (out_of_bounds .EQV. .true.) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) err_msg = 'module/output_field='//TRIM(error_string1)//& & ' Bounds of buffer exceeded. '//TRIM(error_string2) ! imax, imin, etc need to be reset in case the program is not terminated. - bounds%imax = 0 - bounds%imin = VERY_LARGE_AXIS_LENGTH - bounds%jmax = 0 - bounds%jmin = VERY_LARGE_AXIS_LENGTH - bounds%kmax = 0 - bounds%kmin = VERY_LARGE_AXIS_LENGTH + buff_bounds%imax = 0 + buff_bounds%imin = VERY_LARGE_AXIS_LENGTH + buff_bounds%jmax = 0 + buff_bounds%jmin = VERY_LARGE_AXIS_LENGTH + buff_bounds%kmax = 0 + buff_bounds%kmin = VERY_LARGE_AXIS_LENGTH + ELSE + err_msg = '' + END IF +END SUBROUTINE check_out_of_bounds_modern_r4 + + !> @brief Checks if the array indices for output_fields(out_num) are outside the + !! output_fields(out_num)%buffer upper and lower bounds. +SUBROUTINE check_out_of_bounds_modern_r8(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name + CHARACTER(len=256), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + !! error string indicates the x, y, and z indices are not outside the + + CHARACTER(len=128) :: error_string1, error_string2 + LOGICAL :: out_of_bounds = .true. + TYPE (fms_diag_ibounds_type) :: array_bounds + TYPE (fms_diag_ibounds_type), ALLOCATABLE :: buff_bounds + + CALL bounds_from_array(array_bounds, ofb) + + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & + & output_name, module_name, error_string2, a_lessthan_b, a_greaterthan_b) + + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) + err_msg = 'module/output_field='//TRIM(error_string1)//& + & ' Bounds of buffer exceeded. '//TRIM(error_string2) + ! imax, imin, etc need to be reset in case the program is not terminated. + buff_bounds%imax = 0 + buff_bounds%imin = VERY_LARGE_AXIS_LENGTH + buff_bounds%jmax = 0 + buff_bounds%jmin = VERY_LARGE_AXIS_LENGTH + buff_bounds%kmax = 0 + buff_bounds%kmin = VERY_LARGE_AXIS_LENGTH ELSE err_msg = '' END IF -END SUBROUTINE check_out_of_bounds_imp +END SUBROUTINE check_out_of_bounds_modern_r8 + -SUBROUTINE check_bounds_are_exact_dynamic_imp(buffer, bounds, output_name, module_name, & + +SUBROUTINE check_bounds_are_exact_dynamic_modern(array_bounds, bounds, output_name, module_name, & & Time, field_prev_Time, err_msg) - CLASS(*), INTENT(in), DIMENSION(:,:,:,:) :: buffer - TYPE (fms_diag_ibounds_type) :: bounds - CHARACTER(len=*), INTENT(in) :: output_name - CHARACTER(len=*), INTENT(in) :: module_name + TYPE (fms_diag_ibounds_type), INTENT(in) :: array_bounds + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if !! output_fields(out_num)%Time_of_prev_field_data is not !! equal to Time or Time_zero. TYPE(time_type), INTENT(inout) :: field_prev_Time !< output_fields(out_num)%Time_of_prev_field_data - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + CHARACTER(len=256), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. !! An empty error string indicates the x, y, and z indices are !! equal to the buffer array boundaries. @@ -919,7 +1035,7 @@ SUBROUTINE check_bounds_are_exact_dynamic_imp(buffer, bounds, output_name, modul END IF IF ( do_check ) THEN - lims_not_exact = compare_buffer_bounds_to_size(buffer, bounds, output_name, module_name, & + lims_not_exact = compare_buffer_bounds_to_size(array_bounds, bounds, output_name, module_name, & & error_string2, a_noteq_b, a_noteq_b) IF( lims_not_exact .eqv. .TRUE.) THEN err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) @@ -931,14 +1047,14 @@ SUBROUTINE check_bounds_are_exact_dynamic_imp(buffer, bounds, output_name, modul bounds%kmax = 0 bounds%kmin = VERY_LARGE_AXIS_LENGTH END IF -END SUBROUTINE check_bounds_are_exact_dynamic_imp +END SUBROUTINE check_bounds_are_exact_dynamic_modern !> @brief This is an adaptor to the check_out_of_bounds function to !! maintain an interface servicing the older diag_manager (particularly the !! send_data_3d function) and maintain a version of it as unchaged as possible. -SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) +SUBROUTINE check_bounds_are_exact_dynamic_legacy(out_num, diag_field_id, Time, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID number. INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if @@ -947,42 +1063,58 @@ SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. !! An empty error string indicates the x, y, and z indices are !! equal to the buffer array boundaries. + CHARACTER(:), ALLOCATABLE :: output_name + CHARACTER(:), ALLOCATABLE :: module_name + TYPE (fms_diag_ibounds_type) :: array_bounds - !!TODO: pass not the buffer but a pointer to a higher rank array - CALL check_bounds_are_exact_dynamic_imp(output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds, & - & output_fields(out_num)%output_name, input_fields(diag_field_id)%module_name, & + output_name = output_fields(out_num)%output_name + module_name = input_fields(diag_field_id)%module_name + + CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) + + CALL check_bounds_are_exact_dynamic_modern(array_bounds, output_fields(out_num)%buff_bounds, & + & output_name, module_name, & & Time, output_fields(out_num)%Time_of_prev_field_data, err_msg) -END SUBROUTINE check_bounds_are_exact_dynamic +END SUBROUTINE check_bounds_are_exact_dynamic_legacy !> @brief Check if the array indices for output_fields(out_num) are equal to the !! output_fields(out_num)%buffer !! upper and lower bounds. - SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg) + SUBROUTINE check_bounds_are_exact_static_legacy(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID INTEGER, INTENT(in) :: diag_field_id !< Input field ID. - CHARACTER(len=*), INTENT(out) :: err_msg - + CHARACTER(len=256), INTENT(out) :: err_msg + CHARACTER(:), ALLOCATABLE :: output_name + CHARACTER(:), ALLOCATABLE :: module_name CHARACTER(len=128) :: error_string1, error_string2 - !!call... - END SUBROUTINE check_bounds_are_exact_static + TYPE (fms_diag_ibounds_type) :: array_bounds + + output_name = output_fields(out_num)%output_name + module_name = input_fields(diag_field_id)%module_name + + CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) + + CALL check_bounds_are_exact_static_modern(array_bounds, output_fields(out_num)%buff_bounds, & + & output_name, module_name, err_msg) + END SUBROUTINE check_bounds_are_exact_static_legacy !> @brief Check if the array indices for output_fields are equal to the !! buffer upper and lower bounds. - SUBROUTINE check_bounds_are_exact_static_imp(buffer, bounds, output_name, module_name, err_msg) - CLASS(*), INTENT(in), DIMENSION(:,:,:,:) :: buffer - TYPE (fms_diag_ibounds_type) :: bounds - CHARACTER(len=*), INTENT(in) :: output_name - CHARACTER(len=*), INTENT(in) :: module_name + SUBROUTINE check_bounds_are_exact_static_modern(array_bounds, bounds, output_name, module_name, err_msg) + TYPE (fms_diag_ibounds_type), INTENT(in) :: array_bounds + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name CHARACTER(len=*), INTENT(out) :: err_msg CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: lims_not_exact = .true. err_msg = '' - lims_not_exact = compare_buffer_bounds_to_size(buffer, bounds, output_name, module_name, & + lims_not_exact = compare_buffer_bounds_to_size(array_bounds, bounds, output_name, module_name, & & error_string2, a_noteq_b, a_noteq_b) IF( lims_not_exact .eqv. .TRUE.) THEN WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) @@ -995,7 +1127,7 @@ SUBROUTINE check_bounds_are_exact_static_imp(buffer, bounds, output_name, module bounds%jmin = VERY_LARGE_AXIS_LENGTH bounds%kmax = 0 bounds%kmin = VERY_LARGE_AXIS_LENGTH - END SUBROUTINE check_bounds_are_exact_static_imp + END SUBROUTINE check_bounds_are_exact_static_modern !> @brief Initialize the output file. diff --git a/diag_manager/fms_diag_elem_weight_procs.F90 b/diag_manager/fms_diag_elem_weight_procs.F90 index 0d7b33f54d..495feb0f3b 100644 --- a/diag_manager/fms_diag_elem_weight_procs.F90 +++ b/diag_manager/fms_diag_elem_weight_procs.F90 @@ -11,67 +11,67 @@ MODULE fms_diag_elem_weight_procs_mod CONTAINS - ELEMENTAL PURE SUBROUTINE addwf_r4(buff, field, weight, pow_value ) - REAL(r4_kind), INTENT(inout) :: buff + ELEMENTAL PURE REAL(r4_kind) FUNCTION addwf_r4(buff, field, weight, pow_value ) + REAL(r4_kind), INTENT(in) :: buff REAL(r4_kind), INTENT(IN) :: field REAL, INTENT(IN) :: weight INTEGER, INTENT(IN) :: pow_value SELECT CASE(pow_value) CASE (1) - buff = buff + weight * field + addwf_r4 = buff + weight * field CASE (2) - buff = buff + (weight * field) * (weight * field) + addwf_r4 = buff + (weight * field) * (weight * field) CASE default - buff = buff + (weight * field) ** pow_value + addwf_r4 = buff + (weight * field) ** pow_value END SELECT - END SUBROUTINE addwf_r4 + END FUNCTION addwf_r4 - ELEMENTAL PURE SUBROUTINE addwf_r8(buff, field, weight, pow_value ) - REAL(r8_kind), INTENT(inout) :: buff + ELEMENTAL PURE REAL(r8_kind) FUNCTION addwf_r8(buff, field, weight, pow_value ) + REAL(r8_kind), INTENT(in) :: buff REAL(r8_kind) ,INTENT(IN) :: field REAL, INTENT(IN) :: weight INTEGER, INTENT(IN) :: pow_value SELECT CASE(pow_value) CASE (1) - buff = buff + weight * field + addwf_r8 = buff + weight * field CASE (2) - buff = buff + (weight * field) * (weight * field) + addwf_r8 = buff + (weight * field) * (weight * field) CASE default - buff = buff + (weight * field) ** pow_value + addwf_r8 = buff + (weight * field) ** pow_value END SELECT - END SUBROUTINE addwf_r8 + END FUNCTION addwf_r8 - ELEMENTAL PURE SUBROUTINE addwf_i4(buff, field, weight, pow_value ) - INTEGER(i4_kind), INTENT(inout) :: buff + ELEMENTAL PURE INTEGER(i4_kind) FUNCTION addwf_i4(buff, field, weight, pow_value ) + INTEGER(i4_kind), INTENT(in) :: buff INTEGER(i4_kind), INTENT(IN) :: field INTEGER, INTENT(IN) :: weight INTEGER, INTENT(IN) :: pow_value SELECT CASE(pow_value) CASE (1) - buff = buff + weight * field + addwf_i4 = buff + weight * field CASE (2) - buff = buff + (weight * field) * (weight * field) + addwf_i4 = buff + (weight * field) * (weight * field) CASE default - buff = buff + (weight * field) ** pow_value + addwf_i4 = buff + (weight * field) ** pow_value END SELECT - END SUBROUTINE addwf_i4 + END FUNCTION addwf_i4 - ELEMENTAL PURE SUBROUTINE addwf_i8(buff, field, weight, pow_value ) - INTEGER(i8_kind), INTENT(inout) :: buff + ELEMENTAL PURE INTEGER(i8_kind) FUNCTION addwf_i8(buff, field, weight, pow_value ) + INTEGER(i8_kind), INTENT(in) :: buff INTEGER(i8_kind) ,INTENT(IN) :: field INTEGER, INTENT(IN) :: weight INTEGER, INTENT(IN) :: pow_value SELECT CASE(pow_value) CASE (1) - buff = buff + weight * field + addwf_i8 = buff + weight * field CASE (2) - buff = buff + (weight * field) * (weight * field) + addwf_i8 = buff + (weight * field) * (weight * field) CASE default - buff = buff + (weight * field) ** pow_value + addwf_i8 = buff + (weight * field) ** pow_value END SELECT - END SUBROUTINE addwf_i8 + END FUNCTION addwf_i8 END MODULE fms_diag_elem_weight_procs_mod diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index fcb4e91432..9a95e91061 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -84,6 +84,10 @@ MODULE fms_diag_fieldbuff_update_mod module procedure fieldbuff_copy_fieldvals_r4 !< r8 version of the interface module procedure fieldbuff_copy_fieldvals_r8 + !< r4 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_fieldvals_3d_r4 + !< r8 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_fieldvals_3d_r8 !< i4 version of the interface !module procedure fieldbuff_copy_fieldvals_i4 !< i8 version of the interface @@ -94,7 +98,6 @@ MODULE fms_diag_fieldbuff_update_mod #include - END MODULE fms_diag_fieldbuff_update_mod !> @} ! close documentation grouping diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 8ec3d07c98..db88f35f59 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -30,8 +30,6 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. INTEGER, INTENT(inout) :: num_elements - - LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask !< mask REAL, INTENT(in) :: weight1 !< Field data is multiplied by weight !!TODO: Change to same type as field data? FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. @@ -46,9 +44,9 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & CHARACTER(len=256), INTENT(inout) :: err_msg_local !! For pointer bounds remapping - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr !< - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr !< - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr !< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null()!< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null()!< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr => null()!< LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< LOGICAL :: succeded !> True iff no errors encountered. @@ -187,8 +185,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & MASK_PR_1_IF: IF (mask_present ) THEN MISSVAL_PR_1_IF: IF ( missvalue_present ) THEN !!(section: mask_varian .eq. true + mask present) IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -204,10 +202,11 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) - ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) +& - & (field_d(i-is+1+hi, j-js+1+hj, k, :) * weight1) ** pow_value + !!TODO: we can use the power function, or elem function addfw (or pointer ?) !ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) +& - !& ofield_cfg%wf%fwf_ptr (field_d(i-is+1+hi, j-js+1+hj, k, :), weight1, pow_value) + !& (field_d(i-is+1+hi, j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample), & + & field_d(i-is+1+hi, j-js+1+hj, k, :), weight1, pow_value) ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 END where END DO @@ -362,8 +361,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END IF ELSE NDCMP_RKR_1_IF IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -476,8 +475,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END IF ELSE NDCMP_RKR_2_IF IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '') THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -619,8 +618,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL ELSE NDCMP_RKR_3_IF IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -694,8 +693,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & j1= j-l_start(2)-hj+1 !ofb(i1,j1,:,:,sample)= ofb(i1,j1,:,:,sample) +& !& (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value - call addwf(ofb(i1,j1,:,:,sample), & - & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :), weight1, pow_value) + ofb(i1,j1,:,:,sample) = addwf(ofb(i1,j1,:,:,sample), & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :), weight1, pow_value) END IF END DO END DO @@ -729,8 +728,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ELSE NDCMP_RKR_4_IF IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF (fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -768,6 +767,39 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END FUNCTION FMS_DIAG_FBU_PNAME_ + FUNCTION FMS_DIAG_FBCF_3D_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & + & bbounds, count_0d, mask, missvalue, & + & l_start, l_end, err_msg, err_msg_local) result( succeded ) + TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object + TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object + FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), target:: field !< The field value array. + INTEGER, INTENT(in) :: sample !< index along the diurnal time axis + FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:), INTENT(inout), target :: ofb !< The Output Field Buffer + TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !> Normally the member of the buffer of same name, + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !> buffer may be set to this value where mask is false. + INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output + INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output + CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg + CHARACTER(len=256), INTENT(inout) :: err_msg_local + + !! For pointer bounds remapping + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr !< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr !< + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< + + LOGICAL :: succeded !> True iff no errors encountered. + + field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field(:,:,:) + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:size(ofb,4),1:1) => ofb + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + + succeded = FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & + & ofb_ptr, bbounds, count_0d, mask_ptr, missvalue, & + & l_start, l_end, err_msg, err_msg_local) + END FUNCTION FMS_DIAG_FBCF_3D_PNAME_ + !> \Description May set or add to the output field buffer (argument ofb) with the input !! field data array (argument field) @@ -864,8 +896,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -902,8 +934,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -945,8 +977,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -982,8 +1014,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1025,8 +1057,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1060,8 +1092,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1094,8 +1126,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds_m(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds_m(ofb, bbounds, output_name, module_name, err_msg_local) + CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. diff --git a/diag_manager/include/fms_diag_fieldbuff_update.inc b/diag_manager/include/fms_diag_fieldbuff_update.inc index 2aca8cc221..7bc3432ad0 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.inc +++ b/diag_manager/include/fms_diag_fieldbuff_update.inc @@ -2,22 +2,30 @@ #define FMS_DIAG_FBU_DATA_TYPE_ REAL(r4_kind) #undef FMS_DIAG_FBU_PNAME_ #define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r4 -#undef FMS_DIAG_FBCF_PNAME_ +#undef FMS_DIAG_FBU_3D_PNAME_ #define FMS_DIAG_FBU_3D_PNAME_ fieldbuff_update_3d_r4 -#undef FMS_DIAG_FBCF_3D_PNAME_ +#undef FMS_DIAG_FBCF_PNAME_ #define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r4 -#undef FMS_DIAG_FBCM_PNAME_ +#undef FMS_DIAG_FBCF_3D_PNAME_ +#define FMS_DIAG_FBCF_3D_PNAME_ fieldbuff_copy_fieldvals_3d_r4 +#undef FMS_DIAG_FBCM_PNAME_ #define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_r4 +#undef FMS_DIAG_FBCM_3D_PNAME_ +#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_misvals_3d_r4 #include #undef FMS_DIAG_FBU_DATA_TYPE_ #define FMS_DIAG_FBU_DATA_TYPE_ REAL(r8_kind) #undef FMS_DIAG_FBU_PNAME_ #define FMS_DIAG_FBU_PNAME_ fieldbuff_update_r8 -#undef FMS_DIAG_FBU_3D_PNAME_ +#undef FMS_DIAG_FBU_3D_PNAME_ #define FMS_DIAG_FBU_3D_PNAME_ fieldbuff_update_3d_r8 -#undef FMS_DIAG_FBCF_PNAME_ +#undef FMS_DIAG_FBCF_PNAME_ #define FMS_DIAG_FBCF_PNAME_ fieldbuff_copy_fieldvals_r8 -#undef FMS_DIAG_FBCM_PNAME_ +#undef FMS_DIAG_FBCF_3D_PNAME_ +#define FMS_DIAG_FBCF_3D_PNAME_ fieldbuff_copy_fieldvals_3d_r8 +#undef FMS_DIAG_FBCM_PNAME_ #define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_r8 +#undef FMS_DIAG_FBCM_3D_PNAME_ +#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_misvals_3d_r8 #include From 08cacb871aec0a3c48f879609ed963b71a47e8f4 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Tue, 10 Jan 2023 15:19:23 -0500 Subject: [PATCH 09/37] Fixing code line lenght > 120 chars; Fixing reference to update_bounds_imp. --- diag_manager/diag_util.F90 | 2 +- diag_manager/include/fms_diag_fieldbuff_update.fh | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 8280ff384e..12cfbde2e3 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -791,7 +791,7 @@ SUBROUTINE update_bounds_legacy(out_num, lower_i, upper_i, lower_j, upper_j, low INTEGER, INTENT(in) :: upper_j !< Upper j bound. INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. - CALL update_bounds_imp(output_fields(out_num)%buff_bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) + CALL update_bounds_modern(output_fields(out_num)%buff_bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) END SUBROUTINE update_bounds_legacy !> @brief Update the output_fields x, y, and z (and optionally l) min and diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index db88f35f59..c94e22aeb3 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -772,9 +772,9 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & l_start, l_end, err_msg, err_msg_local) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object - FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), target:: field !< The field value array. + FMS_DIAG_FBU_DATA_TYPE_ ,ALLOCATABLE,DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis - FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:), INTENT(inout), target :: ofb !< The Output Field Buffer + FMS_DIAG_FBU_DATA_TYPE_ ,ALLOCATABLE,DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! Normally the member of the buffer of same name, LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask From 8f819cbf7ce77c20a286793d23e2e96b8045bc52 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Wed, 11 Jan 2023 18:04:54 -0500 Subject: [PATCH 10/37] Changes to replace ALLOCATABLE in certain lower-level functions doing bointer remapping; plus moving back to original interface some diag_manager.F90 routines. Also removing send_dada_3d_refac() routine from diag_manager.F90. --- diag_manager/diag_manager.F90 | 754 ++---------------- diag_manager/diag_util.F90 | 20 +- diag_manager/fms_diag_elem_weight_procs.F90 | 10 +- .../include/fms_diag_fieldbuff_update.fh | 47 +- 4 files changed, 113 insertions(+), 718 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 9c96964f1d..cf2f260f0e 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1328,7 +1328,7 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out !< Local copy of field - LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: mask_out !< Local copy of mask + LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out !< Local copy of mask ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1347,8 +1347,6 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT - ALLOCATE(mask_out(SIZE(field(:)), 1, 1)) - ! Default values for mask IF ( PRESENT(mask) ) THEN mask_out(:, 1, 1) = mask @@ -1399,7 +1397,7 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out !< Local copy of field - LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: mask_out !< Local copy of mask + LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out !< Local copy of mask ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1418,7 +1416,6 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT - ALLOCATE(mask_out(SIZE(field,1),SIZE(field,2),1)) ! Default values for mask IF ( PRESENT(mask) ) THEN mask_out(:, :, 1) = mask @@ -1455,7 +1452,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CLASS(*), INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in - LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg @@ -3173,691 +3170,92 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & DEALLOCATE(oor_mask) END FUNCTION send_data_3d + !> @return true if send is successful + LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask ) + INTEGER, INTENT(in) :: id !< id od the diagnostic field + REAL, INTENT(in) :: field(:,:) !< field to average and send + REAL, INTENT(in) :: area (:,:) !< area of tiles (== averaging weights), arbitrary units + TYPE(time_type), INTENT(in) :: time !< current time + LOGICAL, INTENT(in),OPTIONAL :: mask (:,:) !< land mask - !> @return true if send is successful - LOGICAL FUNCTION send_data_3d_refac(diag_field_id, field, time, is_in, js_in, ks_in, & - & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) - INTEGER, INTENT(in) :: diag_field_id - CLASS(*), DIMENSION(:,:,:), INTENT(in) :: field - CLASS(*), INTENT(in), OPTIONAL :: weight - TYPE (time_type), INTENT(in), OPTIONAL :: time - INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in - LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask - CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask - CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - - REAL :: weight1 - REAL :: missvalue - INTEGER :: pow_value - INTEGER :: ksr, ker - INTEGER :: i, out_num, file_num, n1, n2, n3, number_of_outputs, ii,f1,f2,f3,f4 - INTEGER :: freq, units, is, js, ks, ie, je, ke, i1, j1,k1, j, k - INTEGER, DIMENSION(3) :: l_start !< local start indices on 3 axes for regional output - INTEGER, DIMENSION(3) :: l_end !< local end indices on 3 axes for regional output - INTEGER :: hi !< halo size in x direction - INTEGER :: hj !< halo size in y direction - INTEGER :: twohi !< halo size in x direction - INTEGER :: twohj !< halo size in y direction - INTEGER :: sample !< index along the diurnal time axis - INTEGER :: day !< components of the current date - INTEGER :: second !< components of the current date - INTEGER :: tick !< components of the current date - INTEGER :: status - INTEGER :: numthreads - INTEGER :: active_omp_level -#if defined(_OPENMP) - INTEGER :: omp_get_num_threads !< OMP function - INTEGER :: omp_get_level !< OMP function -#endif - LOGICAL :: average, phys_window, need_compute - LOGICAL :: reduced_k_range, local_output - LOGICAL :: time_max, time_min, time_rms, time_sum - LOGICAL :: missvalue_present - LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: oor_mask - CHARACTER(len=256) :: err_msg_local - CHARACTER(len=128) :: error_string, error_string1 + REAL, DIMENSION(SIZE(field,1)) :: out(SIZE(field,1)) - REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field + ! If id is < 0 it means that this field is not registered, simply return + IF ( id <= 0 ) THEN + send_tile_averaged_data1d = .FALSE. + RETURN + END IF - TYPE(fms_diag_outfield_index_type), ALLOCATABLE:: ofield_index_cfg - TYPE(fms_diag_outfield_type), ALLOCATABLE:: ofield_cfg - LOGICAL :: temp_result + CALL average_tiles1d (id, field, area, mask, out) + send_tile_averaged_data1d = send_data(id, out, time=time, mask=ANY(mask,DIM=2)) + END FUNCTION send_tile_averaged_data1d - REAL, dimension(:,:,:,:), pointer::rmask_ptr => null() !< Ptr to field data rmask array + !> @brief Calculates average for a field with the given area and land mask + SUBROUTINE average_tiles1d(diag_field_id, x, area, mask, out) + INTEGER, INTENT(in) :: diag_field_id + REAL, DIMENSION(:,:), INTENT(in) :: x !< (ug_index, tile) field to average + REAL, DIMENSION(:,:), INTENT(in) :: area !< (ug_index, tile) fractional area + LOGICAL, DIMENSION(:,:), INTENT(in) :: mask !< (ug_index, tile) land mask + REAL, DIMENSION(:), INTENT(out) :: out !< (ug_index) result of averaging + INTEGER :: it !< iterator over tile number + REAL, DIMENSION(SIZE(x,1)) :: s !< area accumulator + REAL :: local_missing_value - ! If diag_field_id is < 0 it means that this field is not registered, simply return + ! # FATAL if diag_field_id is less than 0, indicates field was not in diag_table. + ! The calling functions should not have passed in an invalid diag_field_id IF ( diag_field_id <= 0 ) THEN - send_data_3d_refac = .FALSE. - RETURN - ELSE - send_data_3d_refac = .TRUE. - END IF - - IF ( PRESENT(err_msg) ) err_msg = '' - IF ( .NOT.module_is_initialized ) THEN - IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'diag_manager NOT initialized', err_msg) ) RETURN + ! + ! diag_field_id less than 0. Contact developers. + ! + CALL error_mesg('diag_manager_mod::average_tiles1d',& + & "diag_field_id less than 0. Contact developers.", FATAL) END IF - err_msg_local = '' - ! The following lines are commented out as they have not been included in the code prior to now, - ! and there are a lot of send_data calls before register_diag_field calls. A method to do this safely - ! needs to be developed. - ! - ! Set first_send_data_call to .FALSE. on first non-static field. -!!$ IF ( .NOT.input_fields(diag_field_id)%static .AND. first_send_data_call ) THEN -!!$ first_send_data_call = .FALSE. -!!$ END IF - ! First copy the data to a three d array - ALLOCATE(field_out(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) - IF ( status .NE. 0 ) THEN - WRITE (err_msg_local, FMT='("Unable to allocate field_out(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')& - & SIZE(field,1), SIZE(field,2), SIZE(field,3), status - IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN + ! Initialize local_missing_value + IF ( input_fields(diag_field_id)%missing_value_present ) THEN + local_missing_value = input_fields(diag_field_id)%missing_value + ELSE + local_missing_value = 0.0 END IF - SELECT TYPE (field) - TYPE IS (real(kind=r4_kind)) - field_out = field - TYPE IS (real(kind=r8_kind)) - field_out = real(field) - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - ! oor_mask is only used for checking out of range values. - ALLOCATE(oor_mask(SIZE(field,1),SIZE(field,2),SIZE(field,3)), STAT=status) - IF ( status .NE. 0 ) THEN - WRITE (err_msg_local, FMT='("Unable to allocate oor_mask(",I5,",",I5,",",I5,"). (STAT: ",I5,")")')& - & SIZE(field,1), SIZE(field,2), SIZE(field,3), status - IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) RETURN - END IF + ! Initialize s and out to zero. + s(:) = 0.0 + out(:) = 0.0 - IF ( PRESENT(mask) ) THEN - oor_mask = mask - ELSE - oor_mask = .TRUE. - END IF + DO it = 1, SIZE(area,dim=2) + WHERE ( mask(:,it) ) + out(:) = out(:) + x(:,it)*area(:,it) + s(:) = s(:) + area(:,it) + END WHERE + END DO - IF ( PRESENT(rmask) ) THEN - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - WHERE ( rmask < 0.5_r4_kind ) oor_mask = .FALSE. - TYPE IS (real(kind=r8_kind)) - WHERE ( rmask < 0.5_r8_kind ) oor_mask = .FALSE. - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - END IF + WHERE ( s(:) > 0 ) + out(:) = out(:)/s(:) + ELSEWHERE + out(:) = local_missing_value + END WHERE + END SUBROUTINE average_tiles1d - ! send_data works in either one or another of two modes. - ! 1. Input field is a window (e.g. FMS physics) - ! 2. Input field includes halo data - ! It cannot handle a window of data that has halos. - ! (A field with no windows or halos can be thought of as a special case of either mode.) - ! The logic for indexing is quite different for these two modes, but is not clearly separated. - ! If both the beggining and ending indices are present, then field is assumed to have halos. - ! If only beggining indices are present, then field is assumed to be a window. + !> @return true if send is successful + LOGICAL FUNCTION send_tile_averaged_data2d ( id, field, area, time, mask ) + INTEGER, INTENT(in) :: id !< id od the diagnostic field + REAL, INTENT(in) :: field(:,:,:) !< field to average and send + REAL, INTENT(in) :: area (:,:,:) !< area of tiles (== averaging weights), arbitrary units + TYPE(time_type), INTENT(in) :: time !< current time + LOGICAL, INTENT(in),OPTIONAL :: mask (:,:,:) !< land mask - ! There are a number of ways a user could mess up this logic, depending on the combination - ! of presence/absence of is,ie,js,je. The checks below should catch improper combinations. - IF ( PRESENT(ie_in) ) THEN - IF ( .NOT.PRESENT(is_in) ) THEN - IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'ie_in present without is_in', err_msg) ) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - IF ( PRESENT(js_in) .AND. .NOT.PRESENT(je_in) ) THEN - IF ( fms_error_handler('diag_manager_modsend_data_3d',& - & 'is_in and ie_in present, but js_in present without je_in', err_msg) ) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - END IF - IF ( PRESENT(je_in) ) THEN - IF ( .NOT.PRESENT(js_in) ) THEN - IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'je_in present without js_in', err_msg) ) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - IF ( PRESENT(is_in) .AND. .NOT.PRESENT(ie_in) ) THEN - IF ( fms_error_handler('diag_manager_mod::send_data_3d',& - & 'js_in and je_in present, but is_in present without ie_in', err_msg)) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - END IF + REAL, DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(SIZE(field,1), SIZE(field,2)) - ! If is, js, or ks not present default them to 1 - is = 1 - js = 1 - ks = 1 - IF ( PRESENT(is_in) ) is = is_in - IF ( PRESENT(js_in) ) js = js_in - IF ( PRESENT(ks_in) ) ks = ks_in - n1 = SIZE(field, 1) - n2 = SIZE(field, 2) - n3 = SIZE(field, 3) - ie = is+n1-1 - je = js+n2-1 - ke = ks+n3-1 - IF ( PRESENT(ie_in) ) ie = ie_in - IF ( PRESENT(je_in) ) je = je_in - IF ( PRESENT(ke_in) ) ke = ke_in - twohi = n1-(ie-is+1) - IF ( MOD(twohi,2) /= 0 ) THEN - IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in first dimension', & - & err_msg) ) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - twohj = n2-(je-js+1) - IF ( MOD(twohj,2) /= 0 ) THEN - IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'non-symmetric halos in second dimension', & - & err_msg) ) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF + ! If id is < 0 it means that this field is not registered, simply return + IF ( id <= 0 ) THEN + send_tile_averaged_data2d = .FALSE. + RETURN END IF - hi = twohi/2 - hj = twohj/2 - ! The next line is necessary to ensure that is,ie,js,ie are relative to field(1:,1:) - ! But this works only when there is no windowing. - IF ( PRESENT(ie_in) .AND. PRESENT(je_in) ) THEN - is=1+hi - ie=n1-hi - js=1+hj - je=n2-hj - END IF - - ! used for field, mask and rmask bounds - f1=1+hi - f2=n1-hi - f3=1+hj - f4=n2-hj - - ! weight is for time averaging where each time level may has a different weight - IF ( PRESENT(weight) ) THEN - SELECT TYPE (weight) - TYPE IS (real(kind=r4_kind)) - weight1 = weight - TYPE IS (real(kind=r8_kind)) - weight1 = real(weight) - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The weight is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - ELSE - weight1 = 1. - END IF - - ! Is there a missing_value? - missvalue_present = input_fields(diag_field_id)%missing_value_present - IF ( missvalue_present ) missvalue = input_fields(diag_field_id)%missing_value - - number_of_outputs = input_fields(diag_field_id)%num_output_fields -!$OMP CRITICAL - input_fields(diag_field_id)%numthreads = 1 - active_omp_level=0 -#if defined(_OPENMP) - input_fields(diag_field_id)%numthreads = omp_get_num_threads() - input_fields(diag_field_id)%active_omp_level = omp_get_level() -#endif - numthreads = input_fields(diag_field_id)%numthreads - active_omp_level = input_fields(diag_field_id)%active_omp_level -!$OMP END CRITICAL - - if(present(time)) input_fields(diag_field_id)%time = time - - ! Issue a warning if any value in field is outside the valid range - IF ( input_fields(diag_field_id)%range_present ) THEN - IF ( ISSUE_OOR_WARNINGS .OR. OOR_WARNINGS_FATAL ) THEN - WRITE (error_string, '("[",ES14.5E3,",",ES14.5E3,"]")')& - & input_fields(diag_field_id)%range(1:2) - WRITE (error_string1, '("(Min: ",ES14.5E3,", Max: ",ES14.5E3, ")")')& - & MINVAL(field_out(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)),& - & MAXVAL(field_out(f1:f2,f3:f4,ks:ke),MASK=oor_mask(f1:f2,f3:f4,ks:ke)) - IF ( missvalue_present ) THEN - IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.& - & ((field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.& - & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2)).AND.& - & field_out(f1:f2,f3:f4,ks:ke) .NE. missvalue)) ) THEN - ! - ! A value for in field (Min: , Max: ) - ! is outside the range [,] and not equal to the missing - ! value. - ! - CALL error_mesg('diag_manager_mod::send_data_3d',& - & 'A value for '//& - &TRIM(input_fields(diag_field_id)%module_name)//' in field '//& - &TRIM(input_fields(diag_field_id)%field_name)//' '& - &//TRIM(error_string1)//& - &' is outside the range '//TRIM(error_string)//',& - & and not equal to the missing value.',& - &OOR_WARNING) - END IF - ELSE - IF ( ANY(oor_mask(f1:f2,f3:f4,ks:ke) .AND.& - & (field_out(f1:f2,f3:f4,ks:ke) < input_fields(diag_field_id)%range(1) .OR.& - & field_out(f1:f2,f3:f4,ks:ke) > input_fields(diag_field_id)%range(2))) ) THEN - ! - ! A value for in field (Min: , Max: ) - ! is outside the range [,]. - ! - CALL error_mesg('diag_manager_mod::send_data_3d',& - & 'A value for '//& - &TRIM(input_fields(diag_field_id)%module_name)//' in field '//& - &TRIM(input_fields(diag_field_id)%field_name)//' '& - &//TRIM(error_string1)//& - &' is outside the range '//TRIM(error_string)//'.',& - &OOR_WARNING) - END IF - END IF - END IF - END IF - - ! Loop through each output field that depends on this input field - num_out_fields: DO ii = 1, number_of_outputs - ! Get index to an output field - out_num = input_fields(diag_field_id)%output_fields(ii) - - ! is this field output on a local domain only? - local_output = output_fields(out_num)%local_output - ! if local_output, does the current PE take part in send_data? - need_compute = output_fields(out_num)%need_compute - - reduced_k_range = output_fields(out_num)%reduced_k_range - - ! skip all PEs not participating in outputting this field - IF ( local_output .AND. (.NOT.need_compute) ) CYCLE - - ! Get index to output file for this field - file_num = output_fields(out_num)%output_file - IF(file_num == max_files) CYCLE - ! Output frequency and units for this file is - freq = files(file_num)%output_freq - units = files(file_num)%output_units - ! Is this output field being time averaged? - average = output_fields(out_num)%time_average - ! Is this output field the rms? - ! If so, then average is also .TRUE. - time_rms = output_fields(out_num)%time_rms - ! Power value for rms or pow(x) calculations - pow_value = output_fields(out_num)%pow_value - ! Looking for max and min value of this field over the sampling interval? - time_max = output_fields(out_num)%time_max - time_min = output_fields(out_num)%time_min - ! Sum output over time interval - time_sum = output_fields(out_num)%time_sum - IF ( output_fields(out_num)%total_elements > SIZE(field_out(f1:f2,f3:f4,ks:ke)) ) THEN - output_fields(out_num)%phys_window = .TRUE. - ELSE - output_fields(out_num)%phys_window = .FALSE. - END IF - phys_window = output_fields(out_num)%phys_window - IF ( need_compute ) THEN - l_start = output_fields(out_num)%output_grid%l_start_indx - l_end = output_fields(out_num)%output_grid%l_end_indx - END IF - - ! compute the diurnal index - sample = 1 - IF ( PRESENT(time) ) THEN - CALL get_time(time,second,day,tick) ! current date - sample = floor( (second+real(tick)/get_ticks_per_second()) & - & * output_fields(out_num)%n_diurnal_samples/SECONDS_PER_DAY) + 1 - END IF - - ! Get the vertical layer start and end index. - IF ( reduced_k_range ) THEN -!---------- -!ug support - if (output_fields(out_num)%reduced_k_unstruct) then - js = output_fields(out_num)%output_grid%l_start_indx(2) - je = output_fields(out_num)%output_grid%l_end_indx(2) - endif - l_start(3) = output_fields(out_num)%output_grid%l_start_indx(3) - l_end(3) = output_fields(out_num)%output_grid%l_end_indx(3) -!---------- - END IF - ksr= l_start(3) - ker= l_end(3) - - ! Initialize output time for fields output every time step - IF ( freq == EVERY_TIME .AND. .NOT.output_fields(out_num)%static ) THEN - IF (output_fields(out_num)%next_output == output_fields(out_num)%last_output) THEN - IF(PRESENT(time)) THEN - output_fields(out_num)%next_output = time - ELSE - WRITE (error_string,'(a,"/",a)')& - & TRIM(input_fields(diag_field_id)%module_name),& - & TRIM(output_fields(out_num)%output_name) - IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& - & ', time must be present when output frequency = EVERY_TIME', err_msg)) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - END IF - END IF - IF ( .NOT.output_fields(out_num)%static .AND. .NOT.PRESENT(time) ) THEN - WRITE (error_string,'(a,"/",a)')& - & TRIM(input_fields(diag_field_id)%module_name), & - & TRIM(output_fields(out_num)%output_name) - IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& - & ', time must be present for nonstatic field', err_msg)) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - - ! Is it time to output for this field; CAREFUL ABOUT > vs >= HERE - !--- The fields send out within openmp parallel region will be written out in - !--- diag_send_complete. - IF ( (numthreads == 1) .AND. (active_omp_level.LE.1) ) then - IF ( .NOT.output_fields(out_num)%static .AND. freq /= END_OF_RUN ) THEN - IF ( time > output_fields(out_num)%next_output ) THEN - ! A non-static field that has skipped a time level is an error - IF ( time > output_fields(out_num)%next_next_output .AND. freq > 0 ) THEN - IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN - WRITE (error_string,'(a,"/",a)')& - & TRIM(input_fields(diag_field_id)%module_name), & - & TRIM(output_fields(out_num)%output_name) - IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//& - & TRIM(error_string)//' is skipped one time level in output data', err_msg)) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - END IF - - status = writing_field(out_num, .FALSE., error_string, time) - IF(status == -1) THEN - IF ( mpp_pe() .EQ. mpp_root_pe() ) THEN - IF(fms_error_handler('diag_manager_mod::send_data_3d','module/output_field '& - &//TRIM(error_string)//', write EMPTY buffer', err_msg)) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - END IF - END IF !time > output_fields(out_num)%next_output - END IF !.not.output_fields(out_num)%static .and. freq /= END_OF_RUN - ! Finished output of previously buffered data, now deal with buffering new data - END IF - - IF ( .NOT.output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN - CALL check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg=err_msg_local) - IF ( err_msg_local /= '' ) THEN - IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - END IF - - - !!START REFACTORED SECTION WITH WEIGHTING FUNCTIONS.!! - ALLOCATE( ofield_index_cfg ) - CALL ofield_index_cfg%initialize( is, js, ks, ie, je, ke, & - & hi, hj, f1, f2, f3, f4) - - ALLOCATE( ofield_cfg ) - CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num), PRESENT(mask)) - !! TODO: missing time_reduction - - - !! TODO: Question: note that mask was declared allocatable in order to call fieldbuff_update (which - !! in tuen needs mask to be allocatable for pointer remapping). Is this an issue as - !! original send_data_3d did not have mask as so. - IF ( average ) THEN - !!TODO: the copy that is filed_out should not be necessary - temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & - & output_fields(out_num)%buffer, output_fields(out_num)%counter , ofield_cfg%buff_bounds, & - & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & - & mask, weight1 ,missvalue, & - & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& - & input_fields(diag_field_id)%issued_mask_ignore_warning, & - & l_start, l_end, err_msg, err_msg_local ) - IF (temp_result .eqv. .FALSE.) THEN - DEALLOCATE(oor_mask) - RETURN - END IF - ELSE !!NOT AVERAGE - !!rmask_ptr(1:size(rmask,1),1:size(rmask,2),1:size(rmask,3),1:1) => rmask - - !!fieldbuff_sample - IF (temp_result .eqv. .FALSE.) THEN - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - DEALLOCATE(ofield_index_cfg) - DEALLOCATE(ofield_cfg) - - - - !!END REFACTORED SECTION WITH WEIGHTING FUNCTIONS - END - - IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN - CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local) - IF ( err_msg_local /= '' ) THEN - IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg)) THEN - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - RETURN - END IF - END IF - END IF - - ! If rmask and missing value present, then insert missing value - IF ( PRESENT(rmask) .AND. missvalue_present ) THEN - IF ( need_compute ) THEN - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - DO k = l_start(3), l_end(3) - k1 = k - l_start(3) + 1 - DO j = js, je - DO i = is, ie - 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 - i1 = i-l_start(1)-hi+1 - j1 = j-l_start(2)-hj+1 - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) & - & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue - END IF - END DO - END DO - END DO - TYPE IS (real(kind=r8_kind)) - DO k = l_start(3), l_end(3) - k1 = k - l_start(3) + 1 - DO j = js, je - DO i = is, ie - 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 - i1 = i-l_start(1)-hi+1 - j1 = j-l_start(2)-hj+1 - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) & - & output_fields(out_num)%buffer(i1,j1,k1,sample) = missvalue - END IF - END DO - END DO - END DO - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - ELSE IF ( reduced_k_range ) THEN - ksr= l_start(3) - ker= l_end(3) - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - DO k= ksr, ker - k1 = k - ksr + 1 - DO j=js, je - DO i=is, ie - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) & - & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue - END DO - END DO - END DO - TYPE IS (real(kind=r8_kind)) - DO k= ksr, ker - k1 = k - ksr + 1 - DO j=js, je - DO i=is, ie - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) & - & output_fields(out_num)%buffer(i-hi,j-hj,k1,sample)= missvalue - END DO - END DO - END DO - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - ELSE - SELECT TYPE (rmask) - TYPE IS (real(kind=r4_kind)) - DO k=ks, ke - DO j=js, je - DO i=is, ie - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r4_kind ) & - & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue - END DO - END DO - END DO - TYPE IS (real(kind=r8_kind)) - DO k=ks, ke - DO j=js, je - DO i=is, ie - IF ( rmask(i-is+1+hi,j-js+1+hj,k) < 0.5_r8_kind ) & - & output_fields(out_num)%buffer(i-hi,j-hj,k,sample)= missvalue - END DO - END DO - END DO - CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d',& - & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) - END SELECT - END IF - END IF - - END DO num_out_fields - - DEALLOCATE(field_out) - DEALLOCATE(oor_mask) - END FUNCTION send_data_3d_refac - - - !> @return true if send is successful - LOGICAL FUNCTION send_tile_averaged_data1d ( id, field, area, time, mask ) - INTEGER, INTENT(in) :: id !< id od the diagnostic field - REAL, INTENT(in) :: field(:,:) !< field to average and send - REAL, INTENT(in) :: area (:,:) !< area of tiles (== averaging weights), arbitrary units - TYPE(time_type), INTENT(in) :: time !< current time - LOGICAL, ALLOCATABLE, INTENT(in),OPTIONAL :: mask (:,:) !< land mask - !!TODO: make_mask allocatable or send copy to allocatable? RE user interface. - - REAL, DIMENSION(SIZE(field,1)) :: out(SIZE(field,1)) - - ! If id is < 0 it means that this field is not registered, simply return - IF ( id <= 0 ) THEN - send_tile_averaged_data1d = .FALSE. - RETURN - END IF - - CALL average_tiles1d (id, field, area, mask, out) - send_tile_averaged_data1d = send_data(id, out, time=time, mask=ANY(mask,DIM=2)) - END FUNCTION send_tile_averaged_data1d - - !> @brief Calculates average for a field with the given area and land mask - SUBROUTINE average_tiles1d(diag_field_id, x, area, mask, out) - INTEGER, INTENT(in) :: diag_field_id - REAL, DIMENSION(:,:), INTENT(in) :: x !< (ug_index, tile) field to average - REAL, DIMENSION(:,:), INTENT(in) :: area !< (ug_index, tile) fractional area - LOGICAL, DIMENSION(:,:), INTENT(in) :: mask !< (ug_index, tile) land mask - REAL, DIMENSION(:), INTENT(out) :: out !< (ug_index) result of averaging - - INTEGER :: it !< iterator over tile number - REAL, DIMENSION(SIZE(x,1)) :: s !< area accumulator - REAL :: local_missing_value - - ! # FATAL if diag_field_id is less than 0, indicates field was not in diag_table. - ! The calling functions should not have passed in an invalid diag_field_id - IF ( diag_field_id <= 0 ) THEN - ! - ! diag_field_id less than 0. Contact developers. - ! - CALL error_mesg('diag_manager_mod::average_tiles1d',& - & "diag_field_id less than 0. Contact developers.", FATAL) - END IF - - ! Initialize local_missing_value - IF ( input_fields(diag_field_id)%missing_value_present ) THEN - local_missing_value = input_fields(diag_field_id)%missing_value - ELSE - local_missing_value = 0.0 - END IF - - ! Initialize s and out to zero. - s(:) = 0.0 - out(:) = 0.0 - - DO it = 1, SIZE(area,dim=2) - WHERE ( mask(:,it) ) - out(:) = out(:) + x(:,it)*area(:,it) - s(:) = s(:) + area(:,it) - END WHERE - END DO - - WHERE ( s(:) > 0 ) - out(:) = out(:)/s(:) - ELSEWHERE - out(:) = local_missing_value - END WHERE - END SUBROUTINE average_tiles1d - - !> @return true if send is successful - LOGICAL FUNCTION send_tile_averaged_data2d ( id, field, area, time, mask ) - INTEGER, INTENT(in) :: id !< id od the diagnostic field - REAL, INTENT(in) :: field(:,:,:) !< field to average and send - REAL, INTENT(in) :: area (:,:,:) !< area of tiles (== averaging weights), arbitrary units - TYPE(time_type), INTENT(in) :: time !< current time - LOGICAL, ALLOCATABLE, INTENT(in),OPTIONAL :: mask (:,:,:) !< land mask - !!TODO: make_mask allocatable or send copy to allocatable? RE user interface. - !!LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: mask_out - - REAL, DIMENSION(SIZE(field,1),SIZE(field,2)) :: out(SIZE(field,1), SIZE(field,2)) - - ! If id is < 0 it means that this field is not registered, simply return - IF ( id <= 0 ) THEN - send_tile_averaged_data2d = .FALSE. - RETURN - END IF - - - CALL average_tiles(id, field, area, mask, out) - send_tile_averaged_data2d = send_data(id, out, time, mask=ANY(mask,DIM=3)) - END FUNCTION send_tile_averaged_data2d + CALL average_tiles(id, field, area, mask, out) + send_tile_averaged_data2d = send_data(id, out, time, mask=ANY(mask,DIM=3)) + END FUNCTION send_tile_averaged_data2d !> @return true if send is successful LOGICAL FUNCTION send_tile_averaged_data3d( id, field, area, time, mask ) @@ -3866,14 +3264,10 @@ LOGICAL FUNCTION send_tile_averaged_data3d( id, field, area, time, mask ) REAL, DIMENSION(:,:,:), INTENT(in) :: area (:,:,:) !< (lon, lat, tile) tile areas ( == averaging !! weights), arbitrary units TYPE(time_type), INTENT(in) :: time !< current time - LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask !< (lon, lat, tile) land mask - !!TODO: make_mask allocatable or send copy to allocatable? RE user interface. - !!LOGICAL, ALLOCATABLE, DIMENSION(:,:,:) :: mask_out + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask !< (lon, lat, tile) land mask REAL, DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: out - !!LOGICAL ,DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3 - LOGICAL, ALLOCATABLE,DIMENSION(:,:,:) :: mask3 - + LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),SIZE(field,4)) :: mask3 INTEGER :: it ! If id is < 0 it means that this field is not registered, simply return @@ -3886,8 +3280,6 @@ LOGICAL FUNCTION send_tile_averaged_data3d( id, field, area, time, mask ) CALL average_tiles(id, field(:,:,:,it), area, mask, out(:,:,it) ) END DO - ALLOCATE( mask3 (SIZE(field,1),SIZE(field,2),SIZE(field,4))) - mask3(:,:,1) = ANY(mask,DIM=3) DO it = 2, SIZE(field,4) mask3(:,:,it) = mask3(:,:,1) diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 12cfbde2e3..9114cf757f 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -120,7 +120,7 @@ MODULE diag_util_mod END INTERFACE check_bounds_are_exact_static INTERFACE bounds_from_array - module procedure bounds_from_array_legacy + module procedure fms_bounds_from_array_4D module procedure bounds_from_array_modern END INTERFACE bounds_from_array @@ -133,7 +133,6 @@ MODULE diag_util_mod LOGICAL :: module_initialized = .FALSE. - CONTAINS !> @brief Write the version number of this file to the log file. @@ -758,8 +757,8 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& & TRIM(axes_list) END SUBROUTINE log_diag_field_info - !!3D spatial bounds - SUBROUTINE bounds_from_array_legacy(bounds, array) + !!TODO: Rename like this: not with _legacy and _modern + SUBROUTINE fms_bounds_from_array_4D(bounds, array) REAL, INTENT( in), DIMENSION(:,:,:,:) :: array TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds bounds%imin = LBOUND(array,1) @@ -768,7 +767,7 @@ SUBROUTINE bounds_from_array_legacy(bounds, array) bounds%jmax = UBOUND(array,2) bounds%kmin = LBOUND(array,3) bounds%kmax = UBOUND(array,3) - END SUBROUTINE bounds_from_array_legacy + END SUBROUTINE fms_bounds_from_array_4D SUBROUTINE bounds_from_array_modern(bounds, array) @@ -816,10 +815,9 @@ END SUBROUTINE update_bounds_modern !> @brief Compares the indecies in bounds to the corresponding lower and upper bounds of array buffer. !! Comparison is done by the two user specified input functions lowerb_comp and upperb_comp. -!! If any compariosn function returns true, then, after filling error_str, this routine returns -!! false indicating one of the comparison tests indicated a problem. So the comparison test should -!! return true for errors : for indecies out of bounds, or indecies are not equal when expected to -!! be equal. +!! If any compariosn function returns true, then, after filling error_str, this routine also returns +!! true. The suplied comparison functions should return true for errors : for indecies out of bounds, +!! or indecies are not equal when expected to be equal. LOGICAL FUNCTION compare_buffer_bounds_to_size(array_bounds, bounds, output_name, module_name, error_str, & & lowerb_comp, upperb_comp) TYPE (fms_diag_ibounds_type), INTENT(in) :: array_bounds @@ -842,7 +840,7 @@ LOGICAL FUNCTION upperb_comp(a, b) END FUNCTION upperb_comp END INTERFACE - compare_buffer_bounds_to_size = .TRUE. + compare_buffer_bounds_to_size = .FALSE. IF (lowerb_comp( bounds%imin , array_bounds%imin) .OR. & upperb_comp( bounds%imax , array_bounds%imax).OR.& @@ -850,7 +848,7 @@ END FUNCTION upperb_comp upperb_comp( bounds%jmax , array_bounds%jmax) .OR.& lowerb_comp( bounds%kmin , array_bounds%kmin) .OR.& upperb_comp( bounds%kmax , array_bounds%kmax)) THEN - compare_buffer_bounds_to_size = .FALSE. + compare_buffer_bounds_to_size = .TRUE. error_str ='Buffer bounds= : , : , : Actual bounds= : , : , : ' WRITE(error_str(15:17),'(i3)') array_bounds%imin WRITE(error_str(19:21),'(i3)') array_bounds%imax diff --git a/diag_manager/fms_diag_elem_weight_procs.F90 b/diag_manager/fms_diag_elem_weight_procs.F90 index 495feb0f3b..0139b3e694 100644 --- a/diag_manager/fms_diag_elem_weight_procs.F90 +++ b/diag_manager/fms_diag_elem_weight_procs.F90 @@ -11,7 +11,7 @@ MODULE fms_diag_elem_weight_procs_mod CONTAINS - ELEMENTAL PURE REAL(r4_kind) FUNCTION addwf_r4(buff, field, weight, pow_value ) + ELEMENTAL REAL(r4_kind) FUNCTION addwf_r4(buff, field, weight, pow_value ) REAL(r4_kind), INTENT(in) :: buff REAL(r4_kind), INTENT(IN) :: field REAL, INTENT(IN) :: weight @@ -27,10 +27,10 @@ ELEMENTAL PURE REAL(r4_kind) FUNCTION addwf_r4(buff, field, weight, pow_value END SELECT END FUNCTION addwf_r4 - ELEMENTAL PURE REAL(r8_kind) FUNCTION addwf_r8(buff, field, weight, pow_value ) + ELEMENTAL REAL(r8_kind) FUNCTION addwf_r8(buff, field, weight, pow_value ) REAL(r8_kind), INTENT(in) :: buff REAL(r8_kind) ,INTENT(IN) :: field - REAL, INTENT(IN) :: weight + REAL, INTENT(IN) :: weight INTEGER, INTENT(IN) :: pow_value SELECT CASE(pow_value) @@ -43,7 +43,7 @@ ELEMENTAL PURE REAL(r8_kind) FUNCTION addwf_r8(buff, field, weight, pow_value END SELECT END FUNCTION addwf_r8 - ELEMENTAL PURE INTEGER(i4_kind) FUNCTION addwf_i4(buff, field, weight, pow_value ) + ELEMENTAL INTEGER(i4_kind) FUNCTION addwf_i4(buff, field, weight, pow_value ) INTEGER(i4_kind), INTENT(in) :: buff INTEGER(i4_kind), INTENT(IN) :: field INTEGER, INTENT(IN) :: weight @@ -58,7 +58,7 @@ ELEMENTAL PURE INTEGER(i4_kind) FUNCTION addwf_i4(buff, field, weight, pow_valu END SELECT END FUNCTION addwf_i4 - ELEMENTAL PURE INTEGER(i8_kind) FUNCTION addwf_i8(buff, field, weight, pow_value ) + ELEMENTAL INTEGER(i8_kind) FUNCTION addwf_i8(buff, field, weight, pow_value ) INTEGER(i8_kind), INTENT(in) :: buff INTEGER(i8_kind) ,INTENT(IN) :: field INTEGER, INTENT(IN) :: weight diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index c94e22aeb3..3e5d82fdd9 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -21,16 +21,16 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) result( succeded ) - TYPE(fms_diag_outfield_type), INTENT(inout), ALLOCATABLE:: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(inout), ALLOCATABLE :: ofield_index_cfg ! null()!< FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null()!< FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr => null()!< - LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null()!< LOGICAL :: succeded !> True iff no errors encountered. @@ -55,7 +55,9 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d(:,:,:) ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:size(ofb,4),1:1) => ofb ofc_ptr(1:size(ofc,1),1:size(ofc,2),1:size(ofc,3), 1:size(ofc,4),1:1) => ofc - mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + IF (PRESENT (mask)) THEN + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ENDIF succeded = FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & & ofb_ptr, ofc_ptr, bbounds, count_0d, num_elements, mask_ptr, weight1, missvalue, & @@ -772,32 +774,35 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & l_start, l_end, err_msg, err_msg_local) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object - FMS_DIAG_FBU_DATA_TYPE_ ,ALLOCATABLE,DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis - FMS_DIAG_FBU_DATA_TYPE_ ,ALLOCATABLE,DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! Normally the member of the buffer of same name, - LOGICAL, ALLOCATABLE, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !> buffer may be set to this value where mask is false. INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg CHARACTER(len=256), INTENT(inout) :: err_msg_local - !! For pointer bounds remapping - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr !< - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr !< - LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< + !! For pointer bounds remapping + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null() !< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null() !< + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null() !< LOGICAL :: succeded !> True iff no errors encountered. - field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field(:,:,:) - ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:size(ofb,4),1:1) => ofb - mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field(:,:,:) + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:size(ofb,4),1:1) => ofb + + IF (PRESENT (mask)) THEN + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ENDIF - succeded = FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & - & ofb_ptr, bbounds, count_0d, mask_ptr, missvalue, & - & l_start, l_end, err_msg, err_msg_local) + succeded = FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & + & ofb_ptr, bbounds, count_0d, mask_ptr, missvalue, & + & l_start, l_end, err_msg, err_msg_local) END FUNCTION FMS_DIAG_FBCF_3D_PNAME_ From 4324b3eb30eb6ddd1fcd993e7eb40126b25a9642 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Wed, 18 Jan 2023 12:35:49 -0500 Subject: [PATCH 11/37] First version passing all unit tests but without USE_REFACTORED_SEND. --- diag_manager/diag_manager.F90 | 6 +- diag_manager/diag_util.F90 | 81 ++++++++---------------- diag_manager/fms_diag_outfield.F90 | 61 +++++++++++++----- diag_manager/fms_diag_time_reduction.F90 | 7 +- 4 files changed, 76 insertions(+), 79 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index cf2f260f0e..5c98f7df12 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1887,12 +1887,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & hi, hj, f1, f2, f3, f4) ALLOCATE( ofield_cfg ) - CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num), PRESENT(mask)) - !! TODO: missing time_reduction + CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num), PRESENT(mask), freq) - !! TODO: Question: note that mask was declared allocatable in order to call fieldbuff_update (which - !! in tuen needs mask to be allocatable for pointer remapping). Is this an issue as - !! original send_data_3d did not have mask as so. IF ( average ) THEN !!TODO: the copy that is filed_out should not be necessary temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 9114cf757f..49fc37b369 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -818,13 +818,10 @@ END SUBROUTINE update_bounds_modern !! If any compariosn function returns true, then, after filling error_str, this routine also returns !! true. The suplied comparison functions should return true for errors : for indecies out of bounds, !! or indecies are not equal when expected to be equal. -LOGICAL FUNCTION compare_buffer_bounds_to_size(array_bounds, bounds, output_name, module_name, error_str, & - & lowerb_comp, upperb_comp) +LOGICAL FUNCTION compare_buffer_bounds_to_size(array_bounds, bounds, error_str, lowerb_comp, upperb_comp) TYPE (fms_diag_ibounds_type), INTENT(in) :: array_bounds TYPE (fms_diag_ibounds_type), INTENT(in):: bounds - CHARACTER(len=*), INTENT(in) :: output_name - CHARACTER(len=*), INTENT(in) :: module_name - CHARACTER(len=*), INTENT(inout) :: error_str + CHARACTER(*), INTENT(inout) :: error_str !> @brief Interface lowerb_comp should be used for comparison to lower bounds of buffer. INTERFACE @@ -863,7 +860,8 @@ END FUNCTION upperb_comp WRITE(error_str(70:72),'(i3)') bounds%kmin WRITE(error_str(74:76),'(i3)') bounds%kmax ELSE - error_str = '' + compare_buffer_bounds_to_size = .FALSE. + error_str = '' END IF END FUNCTION compare_buffer_bounds_to_size @@ -903,20 +901,15 @@ SUBROUTINE check_out_of_bounds_legacy(out_num, diag_field_id, err_msg) CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & - & output_fields(out_num)%output_name, input_fields(diag_field_id)%module_name,& & error_string2, a_lessthan_b, a_greaterthan_b) IF (out_of_bounds .EQV. .true.) THEN - WRITE(error_string1,'(a,"/",a)') input_fields(diag_field_id)%module_name, output_fields(out_num)%output_name + WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name), & + & TRIM(output_fields(out_num)%output_name) err_msg = 'module/output_field='//TRIM(error_string1)//& & ' Bounds of buffer exceeded. '//TRIM(error_string2) ! imax, imin, etc need to be reset in case the program is not terminated. - buff_bounds%imax = 0 - buff_bounds%imin = VERY_LARGE_AXIS_LENGTH - buff_bounds%jmax = 0 - buff_bounds%jmin = VERY_LARGE_AXIS_LENGTH - buff_bounds%kmax = 0 - buff_bounds%kmin = VERY_LARGE_AXIS_LENGTH + call buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) ELSE err_msg = '' END IF @@ -929,30 +922,24 @@ SUBROUTINE check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name - CHARACTER(len=256), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: out_of_bounds = .true. TYPE (fms_diag_ibounds_type) :: array_bounds - TYPE (fms_diag_ibounds_type), ALLOCATABLE :: buff_bounds CALL bounds_from_array(array_bounds, ofb) - out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & - & output_name, module_name, error_string2, a_lessthan_b, a_greaterthan_b) + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, bounds, & + & error_string2, a_lessthan_b, a_greaterthan_b) IF (out_of_bounds .EQV. .true.) THEN WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) err_msg = 'module/output_field='//TRIM(error_string1)//& & ' Bounds of buffer exceeded. '//TRIM(error_string2) ! imax, imin, etc need to be reset in case the program is not terminated. - buff_bounds%imax = 0 - buff_bounds%imin = VERY_LARGE_AXIS_LENGTH - buff_bounds%jmax = 0 - buff_bounds%jmin = VERY_LARGE_AXIS_LENGTH - buff_bounds%kmax = 0 - buff_bounds%kmin = VERY_LARGE_AXIS_LENGTH + call bounds%reset(VERY_LARGE_AXIS_LENGTH,0) ELSE err_msg = '' END IF @@ -965,30 +952,24 @@ SUBROUTINE check_out_of_bounds_modern_r8(ofb, bounds, output_name, module_name, TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name - CHARACTER(len=256), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: out_of_bounds = .true. TYPE (fms_diag_ibounds_type) :: array_bounds - TYPE (fms_diag_ibounds_type), ALLOCATABLE :: buff_bounds CALL bounds_from_array(array_bounds, ofb) - out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & - & output_name, module_name, error_string2, a_lessthan_b, a_greaterthan_b) + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, bounds, & + & error_string2, a_lessthan_b, a_greaterthan_b) IF (out_of_bounds .EQV. .true.) THEN WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) err_msg = 'module/output_field='//TRIM(error_string1)//& & ' Bounds of buffer exceeded. '//TRIM(error_string2) ! imax, imin, etc need to be reset in case the program is not terminated. - buff_bounds%imax = 0 - buff_bounds%imin = VERY_LARGE_AXIS_LENGTH - buff_bounds%jmax = 0 - buff_bounds%jmin = VERY_LARGE_AXIS_LENGTH - buff_bounds%kmax = 0 - buff_bounds%kmin = VERY_LARGE_AXIS_LENGTH + call bounds%reset(VERY_LARGE_AXIS_LENGTH,0) ELSE err_msg = '' END IF @@ -1006,16 +987,17 @@ SUBROUTINE check_bounds_are_exact_dynamic_modern(array_bounds, bounds, output_na !! output_fields(out_num)%Time_of_prev_field_data is not !! equal to Time or Time_zero. TYPE(time_type), INTENT(inout) :: field_prev_Time !< output_fields(out_num)%Time_of_prev_field_data - CHARACTER(len=256), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. !! An empty error string indicates the x, y, and z indices are !! equal to the buffer array boundaries. - CHARACTER(len=128), ALLOCATABLE :: error_string1, error_string2 + CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: do_check LOGICAL :: lims_not_exact = .true. err_msg = '' + ! Check bounds only when the value of Time changes. When windows are used, ! a change in Time indicates that a new loop through the windows has begun, ! so a check of the previous loop can be done. @@ -1033,17 +1015,13 @@ SUBROUTINE check_bounds_are_exact_dynamic_modern(array_bounds, bounds, output_na END IF IF ( do_check ) THEN - lims_not_exact = compare_buffer_bounds_to_size(array_bounds, bounds, output_name, module_name, & + lims_not_exact = compare_buffer_bounds_to_size(array_bounds, bounds, & & error_string2, a_noteq_b, a_noteq_b) IF( lims_not_exact .eqv. .TRUE.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) END IF - bounds%imax = 0 - bounds%imin = VERY_LARGE_AXIS_LENGTH - bounds%jmax = 0 - bounds%jmin = VERY_LARGE_AXIS_LENGTH - bounds%kmax = 0 - bounds%kmin = VERY_LARGE_AXIS_LENGTH + call bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) END IF END SUBROUTINE check_bounds_are_exact_dynamic_modern @@ -1058,7 +1036,7 @@ SUBROUTINE check_bounds_are_exact_dynamic_legacy(out_num, diag_field_id, Time, e TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if !! output_fields(out_num)%Time_of_prev_field_data is not !! equal to Time or Time_zero. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_bounds_are_exact_dynamic. !! An empty error string indicates the x, y, and z indices are !! equal to the buffer array boundaries. CHARACTER(:), ALLOCATABLE :: output_name @@ -1083,10 +1061,9 @@ END SUBROUTINE check_bounds_are_exact_dynamic_legacy SUBROUTINE check_bounds_are_exact_static_legacy(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID INTEGER, INTENT(in) :: diag_field_id !< Input field ID. - CHARACTER(len=256), INTENT(out) :: err_msg + CHARACTER(len=*), INTENT(out) :: err_msg CHARACTER(:), ALLOCATABLE :: output_name CHARACTER(:), ALLOCATABLE :: module_name - CHARACTER(len=128) :: error_string1, error_string2 TYPE (fms_diag_ibounds_type) :: array_bounds output_name = output_fields(out_num)%output_name @@ -1112,19 +1089,13 @@ SUBROUTINE check_bounds_are_exact_static_modern(array_bounds, bounds, output_nam LOGICAL :: lims_not_exact = .true. err_msg = '' - lims_not_exact = compare_buffer_bounds_to_size(array_bounds, bounds, output_name, module_name, & + lims_not_exact = compare_buffer_bounds_to_size(array_bounds, bounds, & & error_string2, a_noteq_b, a_noteq_b) IF( lims_not_exact .eqv. .TRUE.) THEN WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) err_msg = TRIM(error_string1)//' Bounds of data do not match those of buffer. '//TRIM(error_string2) END IF - - bounds%imax = 0 - bounds%imin = VERY_LARGE_AXIS_LENGTH - bounds%jmax = 0 - bounds%jmin = VERY_LARGE_AXIS_LENGTH - bounds%kmax = 0 - bounds%kmin = VERY_LARGE_AXIS_LENGTH + call bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) END SUBROUTINE check_bounds_are_exact_static_modern @@ -1611,7 +1582,7 @@ SUBROUTINE init_output_field(module_name, field_name, output_name, output_file,& output_fields(out_num)%num_axes = 0 output_fields(out_num)%total_elements = 0 output_fields(out_num)%region_elements = 0 - call output_fields(out_num)%buff_bounds%reset(0, VERY_LARGE_AXIS_LENGTH) + call output_fields(out_num)%buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) ! initialize the size of the diurnal axis to 1 output_fields(out_num)%n_diurnal_samples = 1 diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index 69ef0fe702..bef5bc41ca 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -43,7 +43,8 @@ MODULE fms_diag_outfield_mod USE diag_data_mod, only:Time_zero USE diag_data_mod, only: GLO_REG_VAL, GLO_REG_VAL_ALT, region_out_use_alt_value, VERY_LARGE_AXIS_LENGTH, coord_type USE diag_data_mod, only: fms_diag_ibounds_type, input_field_type, output_field_type - USE fms_diag_time_reduction_mod, only: time_reduction_type + USE fms_diag_time_reduction_mod, only: time_reduction_type, time_none , time_average, time_rms + USE fms_diag_time_reduction_mod, only: time_max, time_min, time_sum, time_power !!TODO: for modern diag: if use_yaml then !! USE fms_diag_yaml_mod, only : diagYamlFiles_type, diagYamlFilesVar_type @@ -89,6 +90,9 @@ MODULE fms_diag_outfield_mod TYPE(fms_diag_ibounds_type) :: buff_bounds !< Instance of a fms_diag_buff_intervals_t type. + !!TODO : a pointer for time_min and time_max comparison function + !! min_max_f_ptr => (should point to < or > operators) + !! gcc error: Interface ‘addwf’ at (1) must be explicit ! procedure (addwf), pointer, nopass :: f_ptr => null () !!A pointer to the field weighing procedure @@ -148,23 +152,24 @@ SUBROUTINE initialize_outfield_index_type(this, is, js , ks, ie, je, ke, hi, hj, END SUBROUTINE initialize_outfield_index_type - !!output_frequency in file_type; - !! num_elements in output_field; possibly pass by itself to update_field. - !!output_frequecy in file_type. !> @brief Update with those fields used in the legacy diag manager. - SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_present) + !! Note that this is initializing from the legacy structures. + !! Note that output_frequency came from file_type; + SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_present, freq) CLASS(fms_diag_outfield_type), INTENT(inout) :: this TYPE(input_field_type), INTENT(in) :: input_field TYPE(output_field_type), INTENT(in) :: output_field LOGICAL, INTENT(in) :: mask_present + INTEGER, INTENT(in) :: freq + INTEGER :: time_redux - this%module_name = input_field%module_name - this%field_name = input_field%field_name -1 this%output_name = output_field%output_name + this%module_name = TRIM(input_field%module_name) + this%field_name = TRIM(input_field%field_name) + this%output_name = TRIM(output_field%output_name) - this%pow_value = output_field%pow_value + this%pow_value = output_field%pow_value this%phys_window = output_field%phys_window - this%need_compute =output_field%need_compute + this%need_compute = output_field%need_compute this%reduced_k_range = output_field%reduced_k_range this%mask_variant = input_field%mask_variant !!Note: in legacy diag manager, presence of missing value vs presence of mask @@ -172,16 +177,40 @@ SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_presen this%missvalue_present = input_field%missing_value_present this%mask_present = mask_present - !!And set the power function ? - !! if ( this%pow_value == 1) then - ! this%f_ptr => ? - !! else end etc. + time_redux = get_output_field_time_reduction (output_field) + call this%time_reduction%initialize( time_redux , freq) + + !!TODO: the time_min and time_max buffer update code is almost the exact same src code, except + !! for the compariosn function. Simplify code and set comparison function: + !!TODO: If possible add to the power function. See issue with pointers and elemental functions - !!TODO: init the time_reduction, possibly using output_field%time_rms, - !! output_field%time_max output_field%time_min, and output_field%time_sum ? END SUBROUTINE initialize_outfield_imp + !> \brief Get the time reduction from a legacy output field. + !! Note we do not place this in the time_reduction class to avoid circular dependencies. + function get_output_field_time_reduction(ofield) result (rslt) + TYPE(output_field_type), INTENT(in) :: ofield + INTEGER :: rslt + if(ofield%time_max) then + rslt = time_max + elseif(ofield%time_min)then + rslt = time_min + else if (ofield%time_sum) then + rslt = time_sum + else if (ofield%time_rms) then + rslt = time_rms + else if (ofield%time_average) then + rslt = time_average + else + rslt = time_none + if(.NOT. ofield%static) then + CALL error_mesg('fms_diag_outfield:get_output_field_time_reduction', & + & 'result is time_none but out_field%static is not true', FATAL) + end if + endif + end function get_output_field_time_reduction + END MODULE fms_diag_outfield_mod !> @} ! close documentation grouping diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 index 0fbbcd596b..ddc9ca961e 100644 --- a/diag_manager/fms_diag_time_reduction.F90 +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -38,6 +38,7 @@ MODULE fms_diag_time_reduction_mod implicit none !!These parametes may be put in diag_data? + !!TODO: time_diurnal "not really" same kind as others, so remove? INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method INTEGER, PARAMETER :: time_average = 1 !< The reduction method is avera INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms @@ -85,7 +86,7 @@ MODULE fms_diag_time_reduction_mod !> @brief The class contructors. Just allocates the class and calls an initializer function time_reduction_type_constructor(dt, out_frequency) result(time_redux) - integer, intent(in) :: dt !> The redution type (time_rms, time_porer, etc) + integer, intent(in) :: dt !> The redution type (time_rms, time_power, etc) integer, intent(in) :: out_frequency !> The output frequency. class (time_reduction_type), allocatable :: time_redux allocate(time_redux) @@ -118,8 +119,6 @@ subroutine initialize(this, dt, out_frequency) ENDIF END IF - !!See legacy init_output_fields concerning time_ops - !!TODO: how about time_rms ... IF((dt .EQ. time_min) .OR. (dt .EQ. time_max) .OR. & & ( dt .EQ. time_average) .OR. (dt .EQ. time_sum) ) THEN this%time_ops = .true. @@ -130,6 +129,7 @@ end subroutine initialize + !> \brief Returns true if any of time_min, time_max, time_rms or time_average is true. !! @return true if if any of time_min, time_max, time_rms or time_average is true. pure function has_time_ops_imp (this) @@ -210,6 +210,7 @@ pure function is_time_power_imp (this) is_time_power_imp = this%the_type .EQ. time_power end function is_time_power_imp + end module fms_diag_time_reduction_mod !> @} ! close documentation grouping From 79cd0266970da256ef0f59ba6fc2202a710c4dbe Mon Sep 17 00:00:00 2001 From: ngs333 Date: Mon, 30 Jan 2023 19:25:11 -0500 Subject: [PATCH 12/37] First version with all unit tests passing with use_refactored_send==true. Fixes bug of incorrect pointer bounds remapping (switching order of last two coordinates). --- diag_manager/diag_data.F90 | 2 +- diag_manager/diag_manager.F90 | 37 +- diag_manager/diag_util.F90 | 23 +- diag_manager/fms_diag_outfield.F90 | 13 +- diag_manager/fms_diag_time_reduction.F90 | 16 +- .../include/fms_diag_fieldbuff_update.fh | 34 +- test_fms/diag_manager/Makefile.am | 5 +- test_fms/diag_manager/test_diag_manager2.sh | 8 +- .../diag_manager/test_diag_update_buffer.F90 | 523 ++++++++++++++++++ 9 files changed, 611 insertions(+), 50 deletions(-) create mode 100644 test_fms/diag_manager/test_diag_update_buffer.F90 diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index bde45d42a8..4f5a4284fb 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -346,7 +346,7 @@ MODULE diag_data_mod !! .TRUE. is only supported if the diag_manager_init !! routine is called with the optional time_init parameter. LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io - LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons. + LOGICAL :: use_refactored_send = .true. !< Namelist flag to use refactored send_data math funcitons. ! diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 5c98f7df12..c54d61a53b 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1452,7 +1452,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CLASS(*), INTENT(in), OPTIONAL :: weight TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in - LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL :: mask + LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg @@ -1493,6 +1493,9 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & TYPE(fms_diag_outfield_type), ALLOCATABLE:: ofield_cfg LOGICAL :: temp_result + LOGICAL, DIMENSION(1,1,1), target :: mask_dummy + LOGICAL , pointer, DIMENSION(:,:,:) :: mask_ptr => null() + ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN send_data_3d = .FALSE. @@ -1889,25 +1892,41 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ALLOCATE( ofield_cfg ) CALL ofield_cfg%initialize( input_fields(diag_field_id), output_fields(out_num), PRESENT(mask), freq) + IF (PRESENT (mask)) THEN + mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3)) => mask + else + mask_ptr(1:size(mask_dummy,1),1:size(mask_dummy,2),1:size(mask_dummy,3)) => mask_dummy + ENDIF + + !! ofield_cfg%buff_bounds, & IF ( average ) THEN + CALL error_mesg('send_data_3d','flag 1', NOTE) !!TODO: the copy that is filed_out should not be necessary temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & - & output_fields(out_num)%buffer, output_fields(out_num)%counter , ofield_cfg%buff_bounds, & + & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,& & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & - & mask, weight1 ,missvalue, & + & mask_ptr, weight1 ,missvalue, & & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& & input_fields(diag_field_id)%issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) IF (temp_result .eqv. .FALSE.) THEN + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF ELSE !!NOT AVERAGE temp_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_out, sample, & - & output_fields(out_num)%buffer, ofield_cfg%buff_bounds, output_fields(out_num)%count_0d(sample), & - & mask, missvalue, l_start, l_end, err_msg, err_msg_local) + & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , & + & output_fields(out_num)%count_0d(sample), & + & mask_ptr, missvalue, l_start, l_end, err_msg, err_msg_local) + CALL error_mesg('send_data_3d','flag 3', NOTE) IF (temp_result .eqv. .FALSE.) THEN + DEALLOCATE(ofield_index_cfg) + DEALLOCATE(ofield_cfg) + DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF @@ -1915,8 +1934,12 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & IF ( PRESENT(rmask) .AND. missvalue_present ) THEN temp_result = .true. !!TODO call :fieldbuff_copy_misvals() END IF - DEALLOCATE(ofield_index_cfg) - DEALLOCATE(ofield_cfg) + IF(ALLOCATED(ofield_index_cfg)) THEN + DEALLOCATE(ofield_index_cfg) + ENDIF + IF(ALLOCATED(ofield_cfg)) THEN + DEALLOCATE(ofield_cfg) + ENDIF CYCLE !!. I.e. skip src code below and go to the next output field END IF !! END USE_REFACTORED_SEND diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 49fc37b369..b3a1b071df 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -796,7 +796,7 @@ END SUBROUTINE update_bounds_legacy !> @brief Update the output_fields x, y, and z (and optionally l) min and !! max boundaries (array indices). SUBROUTINE update_bounds_modern(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) - TYPE (fms_diag_ibounds_type) :: bounds !< the bounding box of the output field buffer inindex space. + TYPE (fms_diag_ibounds_type), intent(inout) :: bounds !< the bounding box of the output field buffer inindex space. INTEGER, INTENT(in) :: lower_i !< Lower i bound. INTEGER, INTENT(in) :: upper_i !< Upper i bound. INTEGER, INTENT(in) :: lower_j !< Lower j bound. @@ -888,21 +888,20 @@ END FUNCTION a_noteq_b SUBROUTINE check_out_of_bounds_legacy(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID number. INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: out_of_bounds = .true. TYPE (fms_diag_ibounds_type) :: array_bounds - TYPE (fms_diag_ibounds_type), ALLOCATABLE :: buff_bounds - - buff_bounds = output_fields(out_num)%buff_bounds + associate (buff_bounds => output_fields(out_num)%buff_bounds) - CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) + CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) - out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & + out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & & error_string2, a_lessthan_b, a_greaterthan_b) + IF (out_of_bounds .EQV. .true.) THEN WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name), & & TRIM(output_fields(out_num)%output_name) @@ -913,6 +912,7 @@ SUBROUTINE check_out_of_bounds_legacy(out_num, diag_field_id, err_msg) ELSE err_msg = '' END IF + end associate END SUBROUTINE check_out_of_bounds_legacy !> @brief Checks if the array indices for output_fields(out_num) are outside the @@ -922,7 +922,7 @@ SUBROUTINE check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the CHARACTER(len=128) :: error_string1, error_string2 @@ -987,7 +987,7 @@ SUBROUTINE check_bounds_are_exact_dynamic_modern(array_bounds, bounds, output_na !! output_fields(out_num)%Time_of_prev_field_data is not !! equal to Time or Time_zero. TYPE(time_type), INTENT(inout) :: field_prev_Time !< output_fields(out_num)%Time_of_prev_field_data - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_bounds_are_exact_dynamic. !! An empty error string indicates the x, y, and z indices are !! equal to the buffer array boundaries. @@ -1061,7 +1061,7 @@ END SUBROUTINE check_bounds_are_exact_dynamic_legacy SUBROUTINE check_bounds_are_exact_static_legacy(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID INTEGER, INTENT(in) :: diag_field_id !< Input field ID. - CHARACTER(len=*), INTENT(out) :: err_msg + CHARACTER(len=*), INTENT(inout) :: err_msg CHARACTER(:), ALLOCATABLE :: output_name CHARACTER(:), ALLOCATABLE :: module_name TYPE (fms_diag_ibounds_type) :: array_bounds @@ -1083,7 +1083,7 @@ SUBROUTINE check_bounds_are_exact_static_modern(array_bounds, bounds, output_nam TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name - CHARACTER(len=*), INTENT(out) :: err_msg + CHARACTER(len=*), INTENT(inout) :: err_msg CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: lims_not_exact = .true. @@ -1582,6 +1582,7 @@ SUBROUTINE init_output_field(module_name, field_name, output_name, output_file,& output_fields(out_num)%num_axes = 0 output_fields(out_num)%total_elements = 0 output_fields(out_num)%region_elements = 0 + call output_fields(out_num)%buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) ! initialize the size of the diurnal axis to 1 diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index bef5bc41ca..006135c32a 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -35,7 +35,7 @@ !> @{ MODULE fms_diag_outfield_mod USE platform_mod - USE mpp_mod, only :FATAL + USE mpp_mod, only :FATAL, WARNING USE fms_mod, only :lowercase, uppercase, error_mesg, fms_error_handler @@ -88,8 +88,6 @@ MODULE fms_diag_outfield_mod TYPE(time_reduction_type) :: time_reduction !< Instance of the time_reduction_type. - TYPE(fms_diag_ibounds_type) :: buff_bounds !< Instance of a fms_diag_buff_intervals_t type. - !!TODO : a pointer for time_min and time_max comparison function !! min_max_f_ptr => (should point to < or > operators) @@ -163,9 +161,9 @@ SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_presen INTEGER, INTENT(in) :: freq INTEGER :: time_redux - this%module_name = TRIM(input_field%module_name) - this%field_name = TRIM(input_field%field_name) - this%output_name = TRIM(output_field%output_name) + this%module_name = input_field%module_name + this%field_name = input_field%field_name + this%output_name = output_field%output_name this%pow_value = output_field%pow_value this%phys_window = output_field%phys_window @@ -205,8 +203,9 @@ function get_output_field_time_reduction(ofield) result (rslt) else rslt = time_none if(.NOT. ofield%static) then + !!TODO: Set error to FATAL. When legacy diag_manager is removed? CALL error_mesg('fms_diag_outfield:get_output_field_time_reduction', & - & 'result is time_none but out_field%static is not true', FATAL) + & 'result is time_none but out_field%static is not true', WARNING) end if endif end function get_output_field_time_reduction diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 index ddc9ca961e..f305f55f24 100644 --- a/diag_manager/fms_diag_time_reduction.F90 +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -37,7 +37,10 @@ MODULE fms_diag_time_reduction_mod implicit none - !!These parametes may be put in diag_data? + !!These parametes are the possible kinds of time reduction operations. + !!Note that sometimes one kind inplies another. + !!TODO: should they be put in diag_data ? + !!TODO: !!TODO: time_diurnal "not really" same kind as others, so remove? INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method INTEGER, PARAMETER :: time_average = 1 !< The reduction method is avera @@ -101,24 +104,23 @@ subroutine initialize(this, dt, out_frequency) this%the_type = dt - !! set the time_averaging flag + !! Set the time_averaging flag !! See legacy init_ouput_fields function, lines 1470ff IF(( dt .EQ. time_average) .OR. (dt .EQ. time_rms) .OR. (dt .EQ. time_power) .OR. & & (dt .EQ. time_diurnal)) THEN this%time_averaging = .true. ELSE this%time_averaging= .false. - IF(out_frequency .NE. EVERY_TIME) THEN - CALL error_mesg('time_reduction_type:time_reduction_type_new', & - & 'time_averaging=.false. but out_frequency .ne. EVERY_TIME', FATAL) - ENDIF IF((dt .NE. time_max) .AND. (dt .ne. time_min) .AND. (dt .NE. time_sum) & & .AND. (dt .NE. time_none)) THEN - CALL error_mesg('time_reduction_type: time_reduction_type_new', & + CALL error_mesg('time_reduction_type: initialize', & & 'time_averaging=.false. but reduction type not compatible', FATAL) ENDIF END IF + !!TODO: Add other checks? E.g. If time_averaging == .false., then + !! out_frequency == EVERY_TIME + IF((dt .EQ. time_min) .OR. (dt .EQ. time_max) .OR. & & ( dt .EQ. time_average) .OR. (dt .EQ. time_sum) ) THEN this%time_ops = .true. diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 3e5d82fdd9..7b15462ec9 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -26,7 +26,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), target :: field_d !< The input field data INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(inout), target :: ofb !< Output Field Buffer - FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(inout), target :: ofc !< Output Field Counter + FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:), INTENT(inout), target :: ofc !< Output Field Counter TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. INTEGER, INTENT(inout) :: num_elements @@ -43,6 +43,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg CHARACTER(len=256), INTENT(inout) :: err_msg_local + FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),target :: ofc_dummy + !! For pointer bounds remapping FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null()!< FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null()!< @@ -52,9 +54,17 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL :: succeded !> True iff no errors encountered. !!TODO: Why did field_d, ofb, and ofc need to be allocatable"? - field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d(:,:,:) - ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:size(ofb,4),1:1) => ofb - ofc_ptr(1:size(ofc,1),1:size(ofc,2),1:size(ofc,3), 1:size(ofc,4),1:1) => ofc + field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3),1:1, 1:size(ofb,4)) => ofb + + !!Note that diag manager does not allocate the ofc in all situations + if(allocated(ofc)) then + ofc_ptr(1:size(ofc,1),1:size(ofc,2),1:size(ofc,3), 1:1, 1:size(ofc,4)) => ofc + else + allocate(ofc_dummy(1,1,1,1)) + ofc_ptr(1:1,1:1,1:1, 1:1,1:1) => ofc_dummy + endif + IF (PRESENT (mask)) THEN mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask ENDIF @@ -81,7 +91,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & l_start, l_end, err_msg, err_msg_local ) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object - FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< Output Field Buffer FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofc !< Output Field Counter TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t @@ -89,7 +99,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. INTEGER, INTENT(inout) :: num_elements - LOGICAL, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask !< mask + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask !< mask REAL, INTENT(in) :: weight1 !< Field data is multiplied by weight !!TODO: Change to same type as field data? FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. @@ -176,7 +186,6 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & WRITE (error_string,'(a,"/",a)') TRIM(module_name), TRIM(output_name) IF ( fms_error_handler('diag_manager_mod::send_data_3d', 'module/output_field '//TRIM(error_string)//& & ', regional output NOT supported with mask_variant', err_msg)) THEN - !!DEALLOCATE(oor_mask) succeded = .FALSE. RETURN END IF @@ -774,9 +783,9 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & l_start, l_end, err_msg, err_msg_local) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object - FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis - FMS_DIAG_FBU_DATA_TYPE_ ,CONTIGUOUS,DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! Normally the member of the buffer of same name, LOGICAL, CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask @@ -794,7 +803,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL :: succeded !> True iff no errors encountered. field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field(:,:,:) - ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:size(ofb,4),1:1) => ofb + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:1, 1:size(ofb,4)) => ofb IF (PRESENT (mask)) THEN mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask @@ -813,12 +822,12 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & l_start, l_end, err_msg, err_msg_local) result( succeded ) TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object - FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:), INTENT(in) :: field !< The field value array. + FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< The Output Field Buffer TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !> Normally the member of the buffer of same name, - LOGICAL, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !> buffer may be set to this value where mask is false. INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output @@ -871,7 +880,6 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, mask_present = ofield_cfg%mask_present missvalue_present = ofield_cfg%missvalue_present - ! Add processing for Max and Min TIME_IF: IF ( time_max ) THEN MASK_PRSNT_1_IF: IF (mask_present ) THEN diff --git a/test_fms/diag_manager/Makefile.am b/test_fms/diag_manager/Makefile.am index ed45102f7f..f5e646cd27 100644 --- a/test_fms/diag_manager/Makefile.am +++ b/test_fms/diag_manager/Makefile.am @@ -22,17 +22,18 @@ # uramirez, Ed Hartnett # Find the needed mod and .inc files. -AM_CPPFLAGS = -I$(top_srcdir)/include -I$(MODDIR) +AM_CPPFLAGS = -I$(top_srcdir)/include -I$(top_srcdir)/diag_manager/include -I$(MODDIR) # Link to the FMS library. LDADD = $(top_builddir)/libFMS/libFMS.la # Build this test program. -check_PROGRAMS = test_diag_manager test_diag_manager_time +check_PROGRAMS = test_diag_manager test_diag_manager_time test_diag_update_buffer # This is the source code for the test. test_diag_manager_SOURCES = test_diag_manager.F90 test_diag_manager_time_SOURCES = test_diag_manager_time.F90 +test_diag_update_buffer_SOURCES= test_diag_update_buffer.F90 TEST_EXTENSIONS = .sh SH_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ diff --git a/test_fms/diag_manager/test_diag_manager2.sh b/test_fms/diag_manager/test_diag_manager2.sh index a4d36cf52b..747be8e691 100755 --- a/test_fms/diag_manager/test_diag_manager2.sh +++ b/test_fms/diag_manager/test_diag_manager2.sh @@ -500,5 +500,9 @@ _EOF test_expect_success "diurnal test (test $my_test_count)" ' mpirun -n 1 ../test_diag_manager_time ' - -test_done +setup_test +my_test_count=`expr $my_test_count + 1` +test_expect_success "Test the diag update_buffer (test $my_test_count)" ' + mpirun -n 1 ../test_diag_update_buffer +' + test_done diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 new file mode 100644 index 0000000000..9a02ff5e5e --- /dev/null +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -0,0 +1,523 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @brief This programs tests the update of field data buffers with +!! the "math" functions in module fms_diag_fieldbuff_update_mod. It mimics +!! the daig_manager::send_4d operation of calling those functions. +program test_diag_update_buffer +#ifdef use_yaml + use platform_mod + use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated + use mpp_io_mod, only: mpp_io_init !!TODO: To be removed (?) 2022.05 + use fms_mod, ONLY: error_mesg, FATAL,NOTE + + USE fms_diag_buffer_mod + USE diag_data_mod, ONLY: i4, i8, r4, r8, time_average, time_rms, fms_diag_buff_intervals_t + + use fms_diag_field_object_mod, only : fmsDiagField_type + USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_type, fms_diag_outfield_index_type + USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_misvals, & + & fieldbuff_copy_fieldvals + USE fms_diag_time_reduction_mod, ONLY: time_reduction_type + + implicit none + + !! Class diag_buffer_type is here only for temporary use for modern diag_manager + !! development until the real buffer class is sufficiently ready and merged. + TYPE diag_buffer_type + CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: buffer + CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: counter + CLASS(*), ALLOCATABLE, DIMENSION(:) :: count_0d + INTEGER, ALLOCATABLE, dimension(:) :: num_elements + END TYPE diag_buffer_type + + integer,parameter :: SZ=10 ! to be allocated of rype data (e.g. r4. i8) + !! to be used thought. + + !!Diag_manager::send_data uses CLASS(*) in function signature, SO + !! we mimic the resulting operations. The set of ClASS(*) data needs to be allocated of same + !! type in order to be able to call the math/buffer update funtions. + CLASS(*), ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: field_data + CLASS(*), ALLOCATABLE, TARGET, DIMENSION(:,:,:,:) :: rmask + CLASS(*), ALLOCATABLE, TARGET :: missvalue + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: mask + LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: oor_mask + TYPE(diag_buffer_type), ALLOCATABLE, TARGET :: buff_obj + + !! In principle, the field_data can be r4,r8,i4,i8,but we will only rest r4,i8 + !!These belwo will be pointers to the data + REAL (kind=r4_kind),dimension (:,:,:,:),pointer::field_r4_ptr => null() !< Ptr to r4 field data array + REAL (kind=r4_kind),dimension (:,:,:,:),pointer::rmask_r4_ptr => null() !< Ptr to r4 field data rmask array + REAL (kind=r4_kind),pointer::missval_r4_ptr => null() !< Ptr to r4 missing value data. + INTEGER (kind=i8_kind),dimension (:,:,:,:),pointer::field_i8_ptr => null() !< Ptr to i8 field data array + INTEGER (kind=i8_kind),dimension (:,:,:,:),pointer::rmask_i8_ptr => null() !< Ptr to i8 field data rmask array + INTEGER (kind=i8_kind),pointer::missval_i8_ptr => null() !< Ptr to i8 missing value data. + + !! Typed pointers to buffer class(*) data will be needed + REAL (kind=r4_kind),dimension (:,:,:,:,:),pointer::ofb_r4_ptr => null() ! null() ! null() !< Ptr to r4 count0d member of buffer obj. + !! Typed pointers to buffer class(*) data will be needed + INTEGER (kind=i8_kind),dimension (:,:,:,:,:),pointer::ofb_i8_ptr => null() ! null() ! null() ! buffobj5%remap_buffer(fname) + !! buffer => buffer_obj%remap_buffer("dummy_name") + + !!In this version, we will meerely set type specific pointers to data. Some will be + !! null, but at the end either the r4 pointers are non-null or the i8 pointers are not null + SELECT TYPE ( field_data ) + TYPE IS (real(kind=r4_kind)) + SELECT TYPE ( rmask ) + TYPE IS (real(kind=r4_kind)) + SELECT TYPE ( missvalue ) + TYPE IS (real(kind=r4_kind)) + field_r4_ptr => field_data + rmask_r4_ptr => rmask + missval_r4_ptr => missvalue + END SELECT + END SELECT + TYPE IS (integer(kind=i8_kind)) + SELECT TYPE ( rmask ) + TYPE IS (INTEGER(kind=i8_kind)) + SELECT TYPE ( missvalue ) + TYPE IS (INTEGER(kind=i8_kind)) + field_i8_ptr => field_data + rmask_i8_ptr => rmask + missval_i8_ptr => missvalue + END SELECT + END SELECT + CLASS DEFAULT + CALL error_mesg ('test_update_buffers_with_field','ptr assignemnt unsupported type', FATAL) + END SELECT + + SELECT TYPE ( ofb => buff_obj%buffer ) + TYPE IS (real(kind=r4_kind)) + SELECT TYPE ( ofc => buff_obj%counter ) + TYPE IS (real(kind=r4_kind)) + SELECT TYPE ( ofb0d => buff_obj%count_0d ) + TYPE IS (real(kind=r4_kind)) + ofb_r4_ptr => ofb + ofc_r4_ptr => ofc + ofb0d_r4_ptr => ofb0d + END SELECT + END SELECT + TYPE IS (integer(kind=i8_kind)) + SELECT TYPE ( ofc => buff_obj%counter ) + TYPE IS (INTEGER(kind=i8_kind)) + SELECT TYPE ( ofb0d => buff_obj%count_0d ) + TYPE IS (INTEGER(kind=i8_kind)) + ofb_i8_ptr => ofb + ofc_i8_ptr => ofc + ofb0d_i8_ptr => ofb0d + END SELECT + END SELECT + CLASS DEFAULT + CALL error_mesg ('diag_manager_mod::send_data_4d', 'ptr assigenment error', FATAL) + END SELECT + + + diag_field_id = 1 + sample = 1 + weight = 1.0 + missvalue = 1.0e-5 + pow_value = 1 + phys_window = .false. + num_elems = 0 + + call init_buff_values_1 (buff_obj%buffer, buff_obj%counter, buff_obj%count_0d, buff_obj%num_elements) + + hi = 0 !!halo size i + hj = 0 !!halo size j + l_start(1) = 1 !!local (to PE) start inddex + l_start(2) = 1 + l_start(3) = 1 + l_end(1) = SZ + l_end(2) = SZ + l_end(3) = SZ + + + ALLOCATE( ofield_cfg ) + call init_ofield_cfg(ofield_cfg, module_name1, field_name1, output_name1, pow_value, & + & phys_window, need_compute, reduced_k_range , num_elems, time_reduction_type1, output_freq1 ) + ALLOCATE( ofield_index_cfg ) + CALL init_ofield_index_cfg(ofield_index_cfg, 1+hi, 1+hj, 1, SZ - hi, SZ - hj, SZ,& + & hi, hj, 1 + hi, SZ - hi, 1 + hj, SZ - hj) + + !!First make sure buffer vals are all zero + call check_results_2(ofb_r4_ptr, 1, 0) + + !! Update the buffer values with the fieldbuff_update function. + !! Case: mask_var=false & missval not present & mask not present & not_reduced_k_range + test_passed = .true. !! will be set to false if there are any issues. + + temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field, field_r4_ptr, sample, & + & ofb_r4_ptr,ofc_r4_ptr, & + & ofield_cfg%ntval, ofb0d_r4_ptr (sample), & + & buff_obj%num_elements(sample), & + & mask, weight, missval_r4_ptr, missvalue_present, & + & l_start, l_end, err_msg, err_msg_local ) + + call check_results_1(ofb_r4_ptr, 1, "Tets01") + !!call print_output_field_values( buff_obj%buffer, 1 ) + + !! ************ 2ND TEST: ********************** + !!First make sure buffer vals are all zero + ofb_r4_ptr = 0 + call check_results_2(ofb_r4_ptr, 1, 0) + + !! Update the buffer values with the copy_fieldvals function. + ! missvalue_present = .true. TBD + call print_output_field_values( buff_obj%buffer, 1 ) + temp_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_r4_ptr, sample, & + & ofb_r4_ptr, ofield_cfg%ntval, ofb0d_r4_ptr(sample), mask, missval_r4_ptr, missvalue_present, & + & l_start, l_end, err_msg, err_msg_local ) + + call print_output_field_values( buff_obj%buffer, 1 ) + + call check_results_1(ofb_r4_ptr, 1, "Test02") + + call error_mesg('test_diag_update_buffer', 'Test has finished',NOTE) + + call MPI_finalize(ierr) + + +CONTAINS + !! The fied object in these tests are not really used, except that + !! the buffer update functions may get and set memebers + !! active_omp_level and num_threads + subroutine init_field_obj( field, field_id) + type(fmsDiagField_type) , intent(inout):: field + integer, intent(in):: field_id + call field%setID (field_id) + end subroutine init_field_obj + + !> @brief Initialized an fms_diag_outfield_type as needed in the test. + !! TODO in future PR: There may in the future ne a member function of fms_diag_outfield_type + !! to call. + subroutine init_ofield_cfg( of_cfg, module_name, field_name, output_name, & + & power_val, phys_window, need_compute, reduced_k_range, num_elems, & + & time_reduction_type,output_freq) + type(fms_diag_outfield_type) :: of_cfg + CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fms_diag_outfield_type + CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fms_diag_outfield_type + CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fms_diag_outfield_type + INTEGER, INTENT(in) :: power_val !< Var with same name in fms_diag_outfield_type + LOGICAL, INTENT(in) :: phys_window !< Var with same name in fms_diag_outfield_type + LOGICAL, INTENT(in) :: need_compute !< Var with same name in fms_diag_outfield_type + LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fms_diag_outfield_type + INTEGER, INTENT(in) :: num_elems !< Var with same name in fms_diag_outfield_type + INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fms_diag_outfield_type + INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type + of_cfg%module_name = module_name + of_cfg%field_name = field_name + of_cfg%output_name = output_name + of_cfg%pow_value = pow_value + of_cfg%phys_window = phys_window + of_cfg%need_compute = need_compute + of_cfg%reduced_k_range = reduced_k_range + call of_cfg%time_reduction%initialize(time_reduction_type, output_freq) + end subroutine init_ofield_cfg + + !> @brief Initialized an fms_diag_outfield_index_type by calling member funtion of + !! fms_diag_outfield_index_type input object. + SUBROUTINE init_ofield_index_cfg(idx_cfg, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + type(fms_diag_outfield_index_type), INTENT(inout) :: idx_cfg !< The object to initialize. + INTEGER, INTENT(in) :: is, js, ks !< Var with same name in fms_diag_outfield_index_type + INTEGER, INTENT(in) :: ie, je, ke !< Var with same name in fms_diag_outfield_index_type + INTEGER, INTENT(in) :: hi, hj !< Var with same name in fms_diag_outfield_index_type + INTEGER, INTENT(in) :: f1, f2, f3, f4 !< Var with same name in fms_diag_outfield_index_type + call idx_cfg%initialize ( is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + end subroutine init_ofield_index_cfg + + SUBROUTINE init_field_values (field) + CLASS(*), DIMENSION(:,:,:,:), INTENT(INOUT) :: field + INTEGER :: NX,NY,NZ, NL + INTEGER :: i,j,k,l + INTEGER :: itemp + NX = size(field,1) + NY= size(field,2) + NZ= size(field,3) + NL= size(field,4) + DO l = 1, NL + DO k = 1, NZ + DO j = 1, NY + DO i = 1, NX + SELECT TYPE ( field) + TYPE IS (real(kind=r4_kind)) + itemp = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) +1 TYPE IS (integer(kind=i8_kind)) + field(i,j,k,l) = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + END SELECT + END DO + END DO + END DO + END DO + END SUBROUTINE init_field_values + + !> @brief Init to zero the buffer, counter , an + SUBROUTINE init_buff_values_1 (buffer, counter, count_0d, num_elems) + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: buffer + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: counter + CLASS(*), DIMENSION(:), INTENT(INOUT) :: count_0d + INTEGER, DIMENSION(:), INTENT(INOUT) :: num_elems + INTEGER, PARAMETER :: sample = 1 + + SELECT TYPE ( buffer) + TYPE IS (real(kind=r4_kind)) + buffer = 0 + TYPE IS (integer(kind=i8_kind)) + buffer = 0 + END SELECT + + SELECT TYPE ( counter) + TYPE IS (real(kind=r4_kind)) + counter = 0 + TYPE IS (integer(kind=i8_kind)) + counter = 0 + END SELECT + + SELECT TYPE ( count_0d) + TYPE IS (real(kind=r4_kind)) + count_0d = 0 + TYPE IS (integer(kind=i8_kind)) + count_0d = 0 + end select + + num_elems = 0 + END SUBROUTINE init_buff_values_1 + + + SUBROUTINE print_output_field_values (buffer, onum) + CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,: ) :: buffer + INTEGER, INTENT(IN) :: onum + INTEGER :: i,j,k + INTEGER :: ti + REAL :: tr + print *, "Start of print_output_field_values" + k = 1 + DO j =1 ,10 + DO i = 1,10 + SELECT TYPE ( buffer) + TYPE IS (real(kind=r4_kind)) + !print "(10f10.1)", buffer(:,j,k,1,1) + tr = buffer(i,j,k,1,1) + print "(f10.1)", tr + TYPE IS (integer(kind=i8_kind)) + !print "(10I10)", buffer(:,j,k,1,1) + !print "(I8))", buffer(i,j,k,1,1) + print "(I8)", ti + END SELECT + end do + print *, "************************" + end do + print *, "End of print_output_field_values" + END SUBROUTINE print_output_field_values + +!> @brief Verify that the buffer data is equal to the expected index value + SUBROUTINE check_results_1(buff, sample, test_name) + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(IN) :: buff !< The 5D buffer + INTEGER, INTENT(in) :: sample !< The diurnal sample + CHARACTER(*), INTENT(in) :: test_name !< The test name + INTEGER :: NX,NY,NZ, NL + INTEGER :: i,j,k,l + LOGICAL :: pass + + pass = .true. + NX = size(buff,1) + NY= size(buff,2) + NZ= size(buff,3) + NL= size(buff,4) + DO l = 1, NL + DO k = 1, NZ + DO j = 1, NY + DO i = 1, NX + SELECT TYPE ( buff) + TYPE IS (real(kind=r4_kind)) + if ( get_array_index_from_4D(i,j,k,l,NX,NY,NZ) /= buff(i,j,k,l,sample) ) then + pass = .false. + endif + TYPE IS (integer(kind=i8_kind)) + if ( get_array_index_from_4D(i,j,k,l,NX,NY,NZ) /= buff(i,j,k,l,sample) ) then + pass = .false. + endif + END SELECT + END DO + END DO + END DO + END DO + if ( pass .eqv. .false.) then + call error_mesg('check_results_1', test_name//" has failed.",FATAL) + end if + end subroutine check_results_1 + + SUBROUTINE check_results_2(buff, sample, val) + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(IN) :: buff + INTEGER, INTENT(in) :: sample + INTEGER, INTENT(in) :: val + INTEGER :: NX,NY,NZ, NL + INTEGER :: i,j,k,l + LOGICAL :: pass + + pass = .true. + NX = size(buff,1) + NY= size(buff,2) + NZ= size(buff,3) + NL= size(buff,4) + DO l = 1, NL + DO k = 1, NZ + DO j = 1, NY + DO i = 1, NX + SELECT TYPE ( buff) + TYPE IS (real(kind=r4_kind)) + if ( buff(i,j,k,l,sample) /= val ) then + pass = .false. + endif + TYPE IS (integer(kind=i8_kind)) + if ( buff(i,j,k,l,sample) /= val ) then + pass = .false. + endif + END SELECT + END DO + END DO + END DO + END DO + if ( pass .eqv. .false.) then + call error_mesg('check_results_2', 'Test has failed',FATAL) + end if + end subroutine check_results_2 + + !> @brief Calculate the unique index into a 4D array given the first four indecies + !! i,j,k,l and the with in the fist three dimensions. + pure integer function get_array_index_from_4D(i,j,k, l, NX,NY,NZ) + INTEGER, INTENT(IN) :: i, j, k, l !> The three spatial dimentsions plus another + INTEGER, INTENT(IN) :: NX, NY, NZ !> The size of the spatial dimentions. + get_array_index_from_4D = (l-1)* (NX * NY * NZ) + (k-1) * NX * NY + (j-1) * NX + i + end function get_array_index_from_4D + + subroutine allocate_input_data_and_ptrs(datapoint, field_data, rmask, missvalue, mask, NX,NY,NZ, NL) + CLASS(*), INTENT(in) :: datapoint !!The type of data we want + CLASS(*), ALLOCATABLE, INTENT(inout), DIMENSION(:,:,:,:) :: field_data + CLASS(*), ALLOCATABLE, INTENT(inout), DIMENSION(:,:,:,:) :: rmask + CLASS(*), ALLOCATABLE, INTENT(inout) :: missvalue + LOGICAL, ALLOCATABLE, INTENT(inout), DIMENSION(:,:,:,:) :: mask + INTEGER , INTENT(in) :: NX,NY,NZ, NL + select type (datapoint) + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: field_data(NX,NY,NZ,NL)) + allocate(integer(kind=i8_kind) :: rmask(NX,NY,NZ,NL)) + allocate(integer(kind=i8_kind) :: missvalue) + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: field_data(NX,NY,NZ,NL)) + allocate(real(kind=r4_kind) :: rmask(NX,NY,NZ,NL)) + allocate(real(kind=r4_kind) :: missvalue) + class default + call error_mesg("allocate input data", "The input data type is not a r4 or i8", FATAL) + end select + + allocate(mask(NX,NY,NZ,NL)) + END subroutine allocate_input_data_and_ptrs + + + subroutine allocate_buffer_obj( data_point, bo, NX,NY,NZ, NL, NDI) + TYPE(diag_buffer_type), INTENT(inout), allocatable :: bo + CLASS(*), INTENT(in) :: data_point !> Sample point allocated to the type being tested. + INTEGER, INTENT(IN) :: NX, NY, NZ !> The three spatial dimensions. + INTEGER, INTENT(IN) :: NL !> Size of the 4th dimentions + INTEGER, INTENT(IN) :: NDI !> Diurnal axis length, + allocate (bo) + select type (data_point) + type is (integer(kind=i8_kind)) + allocate(integer(kind=i8_kind) :: buff_obj%buffer(NX,NY,NZ,NL, NDI)) + allocate(integer(kind=i8_kind) :: buff_obj%counter(NX,NY,NZ,NL, NDI)) + allocate(integer(kind=i8_kind) :: buff_obj%count_0d(NDI)) + type is (real(kind=r4_kind)) + allocate(real(kind=r4_kind) :: buff_obj%buffer(NX,NY,NZ,NL,NDI)) + allocate(real(kind=r4_kind) :: buff_obj%counter(NX,NY,NZ,NL,NDI)) + allocate(real(kind=r4_kind) :: buff_obj%count_0d(NDI)) + class default + call error_mesg("allocate buffer obj", "The input data type is not a r4 or i8", FATAL) + end select + + allocate( buff_obj%num_elements(NDI)) + + END subroutine allocate_buffer_obj +#endif +end program test_diag_update_buffer + + From 4430ab2fe1cb56666a5f5fc5c293c3a42a56e4a3 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Mon, 30 Jan 2023 20:25:36 -0500 Subject: [PATCH 13/37] Removing reference to unavailable module from test_disg_update_buffer. --- test_fms/diag_manager/test_diag_update_buffer.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 9a02ff5e5e..5c7f0f6efc 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -27,7 +27,6 @@ program test_diag_update_buffer use mpp_io_mod, only: mpp_io_init !!TODO: To be removed (?) 2022.05 use fms_mod, ONLY: error_mesg, FATAL,NOTE - USE fms_diag_buffer_mod USE diag_data_mod, ONLY: i4, i8, r4, r8, time_average, time_rms, fms_diag_buff_intervals_t use fms_diag_field_object_mod, only : fmsDiagField_type From 91049f51ab25523625256df8aaa4ba2dc1f86fd6 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Mon, 30 Jan 2023 20:39:03 -0500 Subject: [PATCH 14/37] Removing reference to another unavail module in test_diag_update_buffer. --- test_fms/diag_manager/test_diag_update_buffer.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 5c7f0f6efc..21055a4a9e 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -29,7 +29,6 @@ program test_diag_update_buffer USE diag_data_mod, ONLY: i4, i8, r4, r8, time_average, time_rms, fms_diag_buff_intervals_t - use fms_diag_field_object_mod, only : fmsDiagField_type USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_type, fms_diag_outfield_index_type USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_misvals, & & fieldbuff_copy_fieldvals From f8ada4529d1d4dd7657cffdebdce6332e9a26f20 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Tue, 31 Jan 2023 12:55:22 -0500 Subject: [PATCH 15/37] Removed references to modern diag structures from test_diag_update_buffer --- .../diag_manager/test_diag_update_buffer.F90 | 46 +++++++++---------- 1 file changed, 21 insertions(+), 25 deletions(-) diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 21055a4a9e..8dca41050c 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -21,18 +21,15 @@ !! the "math" functions in module fms_diag_fieldbuff_update_mod. It mimics !! the daig_manager::send_4d operation of calling those functions. program test_diag_update_buffer -#ifdef use_yaml use platform_mod use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated use mpp_io_mod, only: mpp_io_init !!TODO: To be removed (?) 2022.05 use fms_mod, ONLY: error_mesg, FATAL,NOTE - - USE diag_data_mod, ONLY: i4, i8, r4, r8, time_average, time_rms, fms_diag_buff_intervals_t - + use diag_data_mod, ONLY: fms_diag_ibounds_type, VERY_LARGE_AXIS_LENGTH USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_type, fms_diag_outfield_index_type USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_misvals, & & fieldbuff_copy_fieldvals - USE fms_diag_time_reduction_mod, ONLY: time_reduction_type + USE fms_diag_time_reduction_mod, ONLY: time_reduction_type, time_average, time_rms implicit none @@ -51,6 +48,8 @@ program test_diag_update_buffer CLASS(*), ALLOCATABLE :: r4_datapoint, i8_datapoint !> to be allocated of rype data (e.g. r4. i8) !! to be used thought. + TYPE(fms_diag_ibounds_type) :: buff_bounds + !!Diag_manager::send_data uses CLASS(*) in function signature, SO !! we mimic the resulting operations. The set of ClASS(*) data needs to be allocated of same !! type in order to be able to call the math/buffer update funtions. @@ -83,7 +82,6 @@ program test_diag_update_buffer logical :: test_passed !< Flag indicating if the test_passed logical :: temp_result !< Set to result of one of the update functions. - TYPE(fmsDiagField_type) :: field CHARACTER(LEN=*), PARAMETER :: module_name1 = "modX" !< Some dummy valuel CHARACTER(LEN=*), PARAMETER:: field_name1 = "fieldX" !< Some dummy valuel CHARACTER(LEN=*), PARAMETER :: output_name1 = "ofieldX" !< Some dummy valuel @@ -100,8 +98,12 @@ program test_diag_update_buffer INTEGER:: sample !!diurnal_index REAL :: weight INTEGER:: hi, hj !!for halo sizes + integer num_threads + integer active_omp_level + logical issued_mask_ignore_warning - CHARACTER(len=128) :: err_msg, err_msg_local + + CHARACTER(len=256) :: err_msg, err_msg_local integer, dimension(3) :: l_start, l_end LOGICAL :: missvalue_present = .false. @@ -123,8 +125,7 @@ program test_diag_update_buffer call allocate_input_data_and_ptrs(r4_datapoint, field_data, rmask, missvalue, mask, SZ,SZ,SZ,SL) call allocate_buffer_obj(r4_datapoint, buff_obj, SZ, SZ, SZ, SL, NDI) - - call init_field_obj(field, diag_field_id ) + call buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) call init_field_values (field_data) @@ -196,6 +197,9 @@ program test_diag_update_buffer pow_value = 1 phys_window = .false. num_elems = 0 + num_threads = 1 + active_omp_level = 0 + issued_mask_ignore_warning = .false. call init_buff_values_1 (buff_obj%buffer, buff_obj%counter, buff_obj%count_0d, buff_obj%num_elements) @@ -223,11 +227,12 @@ program test_diag_update_buffer !! Case: mask_var=false & missval not present & mask not present & not_reduced_k_range test_passed = .true. !! will be set to false if there are any issues. - temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field, field_r4_ptr, sample, & - & ofb_r4_ptr,ofc_r4_ptr, & - & ofield_cfg%ntval, ofb0d_r4_ptr (sample), & - & buff_obj%num_elements(sample), & - & mask, weight, missval_r4_ptr, missvalue_present, & + temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_r4_ptr, sample, & + & ofb_r4_ptr, ofc_r4_ptr, buff_bounds, & + & ofb0d_r4_ptr (sample), buff_obj%num_elements(sample), & + & mask, weight, missval_r4_ptr, & + & num_threads, active_omp_level, & + & issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) call check_results_1(ofb_r4_ptr, 1, "Tets01") @@ -242,7 +247,8 @@ program test_diag_update_buffer ! missvalue_present = .true. TBD call print_output_field_values( buff_obj%buffer, 1 ) temp_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_r4_ptr, sample, & - & ofb_r4_ptr, ofield_cfg%ntval, ofb0d_r4_ptr(sample), mask, missval_r4_ptr, missvalue_present, & + & ofb_r4_ptr, buff_bounds, & + & ofb0d_r4_ptr(sample), mask, missval_r4_ptr, & & l_start, l_end, err_msg, err_msg_local ) call print_output_field_values( buff_obj%buffer, 1 ) @@ -255,15 +261,6 @@ program test_diag_update_buffer CONTAINS - !! The fied object in these tests are not really used, except that - !! the buffer update functions may get and set memebers - !! active_omp_level and num_threads - subroutine init_field_obj( field, field_id) - type(fmsDiagField_type) , intent(inout):: field - integer, intent(in):: field_id - call field%setID (field_id) - end subroutine init_field_obj - !> @brief Initialized an fms_diag_outfield_type as needed in the test. !! TODO in future PR: There may in the future ne a member function of fms_diag_outfield_type !! to call. @@ -515,7 +512,6 @@ subroutine allocate_buffer_obj( data_point, bo, NX,NY,NZ, NL, NDI) allocate( buff_obj%num_elements(NDI)) END subroutine allocate_buffer_obj -#endif end program test_diag_update_buffer From 5dbee60c8313b8d3f3b05b3f76b24cbb585ce943 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Tue, 31 Jan 2023 13:14:39 -0500 Subject: [PATCH 16/37] Removing repeating warning mesage. --- diag_manager/fms_diag_outfield.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index 006135c32a..93eef2e80c 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -202,11 +202,11 @@ function get_output_field_time_reduction(ofield) result (rslt) rslt = time_average else rslt = time_none - if(.NOT. ofield%static) then + !if(.NOT. ofield%static) then !!TODO: Set error to FATAL. When legacy diag_manager is removed? - CALL error_mesg('fms_diag_outfield:get_output_field_time_reduction', & - & 'result is time_none but out_field%static is not true', WARNING) - end if + ! CALL error_mesg('fms_diag_outfield:get_output_field_time_reduction', & + ! & 'result is time_none but out_field%static is not true', WARNING) + !end if endif end function get_output_field_time_reduction From 71bbd48cda71394da8b3de947cd381746719809c Mon Sep 17 00:00:00 2001 From: ngs333 Date: Tue, 31 Jan 2023 13:25:51 -0500 Subject: [PATCH 17/37] Removing repeating output temporarily used in debugging. --- diag_manager/diag_manager.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index c54d61a53b..387da4ca41 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1900,7 +1900,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & !! ofield_cfg%buff_bounds, & IF ( average ) THEN - CALL error_mesg('send_data_3d','flag 1', NOTE) !!TODO: the copy that is filed_out should not be necessary temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,& @@ -1922,7 +1921,6 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , & & output_fields(out_num)%count_0d(sample), & & mask_ptr, missvalue, l_start, l_end, err_msg, err_msg_local) - CALL error_mesg('send_data_3d','flag 3', NOTE) IF (temp_result .eqv. .FALSE.) THEN DEALLOCATE(ofield_index_cfg) DEALLOCATE(ofield_cfg) From 8eed2272ec90ea099726f022f24a98fa3c8f4a5e Mon Sep 17 00:00:00 2001 From: ngs333 Date: Tue, 31 Jan 2023 15:12:02 -0500 Subject: [PATCH 18/37] Removing note at end of test (unexplicably) causing unit test failure. --- test_fms/diag_manager/test_diag_update_buffer.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 8dca41050c..274644799e 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -235,7 +235,7 @@ program test_diag_update_buffer & issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) - call check_results_1(ofb_r4_ptr, 1, "Tets01") + call check_results_1(ofb_r4_ptr, 1, "Buffer_update_test01") !!call print_output_field_values( buff_obj%buffer, 1 ) !! ************ 2ND TEST: ********************** @@ -245,17 +245,18 @@ program test_diag_update_buffer !! Update the buffer values with the copy_fieldvals function. ! missvalue_present = .true. TBD - call print_output_field_values( buff_obj%buffer, 1 ) + !!call print_output_field_values( buff_obj%buffer, 1 ) temp_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_r4_ptr, sample, & & ofb_r4_ptr, buff_bounds, & & ofb0d_r4_ptr(sample), mask, missval_r4_ptr, & & l_start, l_end, err_msg, err_msg_local ) - call print_output_field_values( buff_obj%buffer, 1 ) + !!call print_output_field_values( buff_obj%buffer, 1 ) - call check_results_1(ofb_r4_ptr, 1, "Test02") + call check_results_1(ofb_r4_ptr, 1, "Buffer_update_test02") - call error_mesg('test_diag_update_buffer', 'Test has finished',NOTE) + !!TODO: Why is it that just printing this note makes the unit test fail? + !! call error_mesg('test_diag_update_buffer', 'Test has finished',NOTE) call MPI_finalize(ierr) From 7e51b8f9964a3bba6fecf70eb2cd0f55d70f85b6 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Tue, 31 Jan 2023 16:54:17 -0500 Subject: [PATCH 19/37] Fixing test_diag_update_buffer : setting unitialized vars. --- .../diag_manager/test_diag_update_buffer.F90 | 66 ++++++++++--------- 1 file changed, 34 insertions(+), 32 deletions(-) diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 274644799e..ca491f7478 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -23,8 +23,7 @@ program test_diag_update_buffer use platform_mod use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated - use mpp_io_mod, only: mpp_io_init !!TODO: To be removed (?) 2022.05 - use fms_mod, ONLY: error_mesg, FATAL,NOTE + use fms_mod, ONLY: fms_init, fms_end, error_mesg, FATAL,NOTE use diag_data_mod, ONLY: fms_diag_ibounds_type, VERY_LARGE_AXIS_LENGTH USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_type, fms_diag_outfield_index_type USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_misvals, & @@ -35,12 +34,12 @@ program test_diag_update_buffer !! Class diag_buffer_type is here only for temporary use for modern diag_manager !! development until the real buffer class is sufficiently ready and merged. - TYPE diag_buffer_type + TYPE diag_test_buffer_type CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: buffer CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: counter CLASS(*), ALLOCATABLE, DIMENSION(:) :: count_0d INTEGER, ALLOCATABLE, dimension(:) :: num_elements - END TYPE diag_buffer_type + END TYPE diag_test_buffer_type integer,parameter :: SZ=10 ! buffobj5%remap_buffer(fname) - !! buffer => buffer_obj%remap_buffer("dummy_name") + !!TODO:: Can switch to final diang_manager buffer_object type in modern diag effort. !!In this version, we will meerely set type specific pointers to data. Some will be !! null, but at the end either the r4 pointers are non-null or the i8 pointers are not null @@ -196,10 +187,15 @@ program test_diag_update_buffer missvalue = 1.0e-5 pow_value = 1 phys_window = .false. + need_compute = .false. + mask_variant = .false. + reduced_k_range = .false. num_elems = 0 num_threads = 1 active_omp_level = 0 issued_mask_ignore_warning = .false. + mask = .true. + call init_buff_values_1 (buff_obj%buffer, buff_obj%counter, buff_obj%count_0d, buff_obj%num_elements) @@ -215,7 +211,8 @@ program test_diag_update_buffer ALLOCATE( ofield_cfg ) call init_ofield_cfg(ofield_cfg, module_name1, field_name1, output_name1, pow_value, & - & phys_window, need_compute, reduced_k_range , num_elems, time_reduction_type1, output_freq1 ) + & phys_window, need_compute, mask_variant, reduced_k_range , & + & num_elems, time_reduction_type1, output_freq1 ) ALLOCATE( ofield_index_cfg ) CALL init_ofield_index_cfg(ofield_index_cfg, 1+hi, 1+hj, 1, SZ - hi, SZ - hj, SZ,& & hi, hj, 1 + hi, SZ - hi, 1 + hj, SZ - hj) @@ -236,7 +233,7 @@ program test_diag_update_buffer & l_start, l_end, err_msg, err_msg_local ) call check_results_1(ofb_r4_ptr, 1, "Buffer_update_test01") - !!call print_output_field_values( buff_obj%buffer, 1 ) + call print_output_field_values( buff_obj%buffer, 1 ) !! ************ 2ND TEST: ********************** !!First make sure buffer vals are all zero @@ -255,18 +252,16 @@ program test_diag_update_buffer call check_results_1(ofb_r4_ptr, 1, "Buffer_update_test02") - !!TODO: Why is it that just printing this note makes the unit test fail? - !! call error_mesg('test_diag_update_buffer', 'Test has finished',NOTE) - - call MPI_finalize(ierr) + call error_mesg('test_diag_update_buffer', 'Test has finished',NOTE) + call fms_end CONTAINS !> @brief Initialized an fms_diag_outfield_type as needed in the test. !! TODO in future PR: There may in the future ne a member function of fms_diag_outfield_type !! to call. subroutine init_ofield_cfg( of_cfg, module_name, field_name, output_name, & - & power_val, phys_window, need_compute, reduced_k_range, num_elems, & + & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & & time_reduction_type,output_freq) type(fms_diag_outfield_type) :: of_cfg CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fms_diag_outfield_type @@ -275,10 +270,12 @@ subroutine init_ofield_cfg( of_cfg, module_name, field_name, output_name, & INTEGER, INTENT(in) :: power_val !< Var with same name in fms_diag_outfield_type LOGICAL, INTENT(in) :: phys_window !< Var with same name in fms_diag_outfield_type LOGICAL, INTENT(in) :: need_compute !< Var with same name in fms_diag_outfield_type + LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fms_diag_outfield_type LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fms_diag_outfield_type INTEGER, INTENT(in) :: num_elems !< Var with same name in fms_diag_outfield_type INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fms_diag_outfield_type INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type + of_cfg%module_name = module_name of_cfg%field_name = field_name of_cfg%output_name = output_name @@ -286,6 +283,7 @@ subroutine init_ofield_cfg( of_cfg, module_name, field_name, output_name, & of_cfg%phys_window = phys_window of_cfg%need_compute = need_compute of_cfg%reduced_k_range = reduced_k_range + of_cfg%mask_variant = mask_variant call of_cfg%time_reduction%initialize(time_reduction_type, output_freq) end subroutine init_ofield_cfg @@ -393,18 +391,22 @@ SUBROUTINE check_results_1(buff, sample, test_name) INTEGER :: NX,NY,NZ, NL INTEGER :: i,j,k,l LOGICAL :: pass - + integer :: idx + real :: bv pass = .true. NX = size(buff,1) NY= size(buff,2) NZ= size(buff,3) NL= size(buff,4) + DO l = 1, NL DO k = 1, NZ DO j = 1, NY DO i = 1, NX SELECT TYPE ( buff) TYPE IS (real(kind=r4_kind)) + idx = get_array_index_from_4D(i,j,k,l,NX,NY,NZ) + bv = buff(i,j,k,l,sample) if ( get_array_index_from_4D(i,j,k,l,NX,NY,NZ) /= buff(i,j,k,l,sample) ) then pass = .false. endif @@ -491,7 +493,7 @@ END subroutine allocate_input_data_and_ptrs subroutine allocate_buffer_obj( data_point, bo, NX,NY,NZ, NL, NDI) - TYPE(diag_buffer_type), INTENT(inout), allocatable :: bo + TYPE(diag_test_buffer_type), INTENT(inout), allocatable :: bo CLASS(*), INTENT(in) :: data_point !> Sample point allocated to the type being tested. INTEGER, INTENT(IN) :: NX, NY, NZ !> The three spatial dimensions. INTEGER, INTENT(IN) :: NL !> Size of the 4th dimentions @@ -499,18 +501,18 @@ subroutine allocate_buffer_obj( data_point, bo, NX,NY,NZ, NL, NDI) allocate (bo) select type (data_point) type is (integer(kind=i8_kind)) - allocate(integer(kind=i8_kind) :: buff_obj%buffer(NX,NY,NZ,NL, NDI)) - allocate(integer(kind=i8_kind) :: buff_obj%counter(NX,NY,NZ,NL, NDI)) - allocate(integer(kind=i8_kind) :: buff_obj%count_0d(NDI)) + allocate(integer(kind=i8_kind) :: bo%buffer(NX,NY,NZ,NL, NDI)) + allocate(integer(kind=i8_kind) :: bo%counter(NX,NY,NZ,NL, NDI)) + allocate(integer(kind=i8_kind) :: bo%count_0d(NDI)) type is (real(kind=r4_kind)) - allocate(real(kind=r4_kind) :: buff_obj%buffer(NX,NY,NZ,NL,NDI)) - allocate(real(kind=r4_kind) :: buff_obj%counter(NX,NY,NZ,NL,NDI)) - allocate(real(kind=r4_kind) :: buff_obj%count_0d(NDI)) + allocate(real(kind=r4_kind) :: bo%buffer(NX,NY,NZ,NL,NDI)) + allocate(real(kind=r4_kind) :: bo%counter(NX,NY,NZ,NL,NDI)) + allocate(real(kind=r4_kind) :: bo%count_0d(NDI)) class default call error_mesg("allocate buffer obj", "The input data type is not a r4 or i8", FATAL) end select - allocate( buff_obj%num_elements(NDI)) + allocate( bo%num_elements(NDI)) END subroutine allocate_buffer_obj end program test_diag_update_buffer From c9c38d5dcb23d6cb1c3267b4921681dca493d42e Mon Sep 17 00:00:00 2001 From: ngs333 Date: Thu, 2 Feb 2023 01:35:38 -0500 Subject: [PATCH 20/37] Completed working version, but missing removal of copy of field_out in sned_data_3d and missing some documentation. --- diag_manager/diag_manager.F90 | 80 ++++++-- diag_manager/fms_diag_elem_weight_procs.F90 | 88 ++++++-- diag_manager/fms_diag_fieldbuff_update.F90 | 6 +- .../include/fms_diag_fieldbuff_update.fh | 192 ++++++++++-------- 4 files changed, 246 insertions(+), 120 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 387da4ca41..5863b86311 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1453,7 +1453,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & TYPE (time_type), INTENT(in), OPTIONAL :: time INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ks_in,ie_in,je_in, ke_in LOGICAL, DIMENSION(:,:,:), INTENT(in), OPTIONAL, contiguous, target :: mask - CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL :: rmask + CLASS(*), DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg REAL :: weight1 @@ -1489,12 +1489,15 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field - TYPE(fms_diag_outfield_index_type), ALLOCATABLE:: ofield_index_cfg - TYPE(fms_diag_outfield_type), ALLOCATABLE:: ofield_cfg - LOGICAL :: temp_result + REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 => null() !< A pointer to r4 type of rmask + REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 => null() ! null() !< A pointer to mask + TYPE(fms_diag_outfield_index_type), ALLOCATABLE:: ofield_index_cfg ! null() + REAL :: rmask_threshold ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1553,8 +1556,12 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) WHERE ( rmask < 0.5_r4_kind ) oor_mask = .FALSE. + rmask_threshold = 0.5_r4_kind + rmask_ptr_r4 => rmask TYPE IS (real(kind=r8_kind)) WHERE ( rmask < 0.5_r8_kind ) oor_mask = .FALSE. + rmask_threshold = 0.5_r8_kind + rmask_ptr_r8 => rmask CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_3d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1898,49 +1905,76 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & mask_ptr(1:size(mask_dummy,1),1:size(mask_dummy,2),1:size(mask_dummy,3)) => mask_dummy ENDIF - !! ofield_cfg%buff_bounds, & - IF ( average ) THEN + IF ( average ) THEN !!TODO: the copy that is filed_out should not be necessary - temp_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & + mf_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,& & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & & mask_ptr, weight1 ,missvalue, & & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& & input_fields(diag_field_id)%issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) - IF (temp_result .eqv. .FALSE.) THEN + IF (mf_result .eqv. .FALSE.) THEN DEALLOCATE(ofield_index_cfg) DEALLOCATE(ofield_cfg) DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF - ELSE !!NOT AVERAGE - - temp_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_out, sample, & + ELSE !!NOT AVERAGE + mf_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_out, sample, & & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , & & output_fields(out_num)%count_0d(sample), & & mask_ptr, missvalue, l_start, l_end, err_msg, err_msg_local) - IF (temp_result .eqv. .FALSE.) THEN + IF (mf_result .eqv. .FALSE.) THEN DEALLOCATE(ofield_index_cfg) DEALLOCATE(ofield_cfg) DEALLOCATE(field_out) DEALLOCATE(oor_mask) RETURN END IF + END IF + + IF ( output_fields(out_num)%static .AND. .NOT.need_compute .AND. debug_diag_manager ) THEN + CALL check_bounds_are_exact_static(out_num, diag_field_id, err_msg=err_msg_local) + IF ( err_msg_local /= '' ) THEN + IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg)) THEN + DEALLOCATE(field_out) + DEALLOCATE(oor_mask) + RETURN + END IF END IF - IF ( PRESENT(rmask) .AND. missvalue_present ) THEN - temp_result = .true. !!TODO call :fieldbuff_copy_misvals() - END IF - IF(ALLOCATED(ofield_index_cfg)) THEN + END IF + + !!TODO: One (or the other) of the calls below will not compile depending + !! on the value of REAL. This is to the mixed use of REAL, R4, R8 and CLASS(*) + !! in send_data_3d. A copy of rmask can be made to avoid but it would be wasteful. + !! Instead, the original functionality is used at the end. + !IF ( PRESENT(rmask) .AND. missvalue_present ) THEN + ! SELECT TYPE (rmask) + ! TYPE IS (real(kind=r4_kind)) + ! call fieldbuff_copy_misvals(ofield_cfg, ofield_index_cfg, & + ! & output_fields(out_num)%buffer, sample, & + ! & l_start, l_end, rmask_ptr_r4, rmask_threshold, missvalue) + ! TYPE IS (real(kind=r8_kind)) + ! call fieldbuff_copy_misvals(ofield_cfg, ofield_index_cfg, & + ! & output_fields(out_num)%buffer, sample, & + ! & l_start, l_end, rmask_ptr_r8, rmask_threshold, missvalue) + ! CLASS DEFAULT + ! CALL error_mesg ('diag_manager_mod::send_data_3d',& + ! & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) + ! END SELECT + !END IF + + IF(ALLOCATED(ofield_index_cfg)) THEN DEALLOCATE(ofield_index_cfg) - ENDIF - IF(ALLOCATED(ofield_cfg)) THEN + ENDIF + IF(ALLOCATED(ofield_cfg)) THEN DEALLOCATE(ofield_cfg) - ENDIF + ENDIF - CYCLE !!. I.e. skip src code below and go to the next output field - END IF !! END USE_REFACTORED_SEND + !!CYCLE !!. I.e. skip src code below and go to the next output field + ELSE !! END USE_REFACTORED_SEND ! Take care of submitted field data IF ( average ) THEN @@ -3088,6 +3122,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF END IF + END IF !! END OF IS_USE_REFACTORED SEND + ! If rmask and missing value present, then insert missing value IF ( PRESENT(rmask) .AND. missvalue_present ) THEN IF ( need_compute ) THEN diff --git a/diag_manager/fms_diag_elem_weight_procs.F90 b/diag_manager/fms_diag_elem_weight_procs.F90 index 0139b3e694..987f544b48 100644 --- a/diag_manager/fms_diag_elem_weight_procs.F90 +++ b/diag_manager/fms_diag_elem_weight_procs.F90 @@ -1,7 +1,45 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_elem_weight_procs_mod fms_diag_elem_weight_procs_mod +!> @ingroup diag_manager +!> @brief fms_diag_elem_weight_procs_mod Contains elemental functions for uddating +!! one element of a buffer array with field data. +!! +!> @author Miguel Zuniga +!! +!! fms_diag_elem_weight_procs_mod Contains elemental functions for uddating +!! one element of a buffer array with field data, +!! +!> @file +!> @brief File for @ref fms_diag_elem_weight_procs_mod +!> @addtogroup fms_diag_elem_weight_procs_mod +!> @{ MODULE fms_diag_elem_weight_procs_mod USE platform_mod implicit none + + !> @brief Interface for the elemental function addwf, whihc + !! Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !> @ingroup fms_diag_elem_weight_procs_mod INTERFACE addwf module procedure addwf_r4 module procedure addwf_r8 @@ -11,11 +49,18 @@ MODULE fms_diag_elem_weight_procs_mod CONTAINS + !!TODO: Note that in the functions below, the case for pow_value == 2 was + !! not in the original send_data_3d code and the power function was used. + !! So this case may need to be deleted is reproducability is an issue. + + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. ELEMENTAL REAL(r4_kind) FUNCTION addwf_r4(buff, field, weight, pow_value ) - REAL(r4_kind), INTENT(in) :: buff - REAL(r4_kind), INTENT(IN) :: field - REAL, INTENT(IN) :: weight - INTEGER, INTENT(IN) :: pow_value + REAL(r4_kind), INTENT(in) :: buff !< The buffer cell (point) value + REAL(r4_kind), INTENT(IN) :: field !< The field value + REAL, INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function SELECT CASE(pow_value) CASE (1) @@ -27,11 +72,14 @@ ELEMENTAL REAL(r4_kind) FUNCTION addwf_r4(buff, field, weight, pow_value ) END SELECT END FUNCTION addwf_r4 + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. ELEMENTAL REAL(r8_kind) FUNCTION addwf_r8(buff, field, weight, pow_value ) - REAL(r8_kind), INTENT(in) :: buff - REAL(r8_kind) ,INTENT(IN) :: field - REAL, INTENT(IN) :: weight - INTEGER, INTENT(IN) :: pow_value + REAL(r8_kind), INTENT(in) :: buff !< The buffer cell (point) value + REAL(r8_kind) ,INTENT(IN) :: field !< The field value + REAL, INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function SELECT CASE(pow_value) CASE (1) @@ -43,11 +91,14 @@ ELEMENTAL REAL(r8_kind) FUNCTION addwf_r8(buff, field, weight, pow_value ) END SELECT END FUNCTION addwf_r8 + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. ELEMENTAL INTEGER(i4_kind) FUNCTION addwf_i4(buff, field, weight, pow_value ) - INTEGER(i4_kind), INTENT(in) :: buff - INTEGER(i4_kind), INTENT(IN) :: field - INTEGER, INTENT(IN) :: weight - INTEGER, INTENT(IN) :: pow_value + INTEGER(i4_kind), INTENT(in) :: buff !< The buffer cell (point) value + INTEGER(i4_kind), INTENT(IN) :: field !< The field value + INTEGER, INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function SELECT CASE(pow_value) CASE (1) addwf_i4 = buff + weight * field @@ -58,11 +109,14 @@ ELEMENTAL INTEGER(i4_kind) FUNCTION addwf_i4(buff, field, weight, pow_value ) END SELECT END FUNCTION addwf_i4 + !> @brief Calculates and returns the value given by this formula: + !! returned_value = buff + (weight * field)**pow_value + !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. ELEMENTAL INTEGER(i8_kind) FUNCTION addwf_i8(buff, field, weight, pow_value ) - INTEGER(i8_kind), INTENT(in) :: buff - INTEGER(i8_kind) ,INTENT(IN) :: field - INTEGER, INTENT(IN) :: weight - INTEGER, INTENT(IN) :: pow_value + INTEGER(i8_kind), INTENT(in) :: buff !< The buffer cell (point) value + INTEGER(i8_kind) ,INTENT(IN) :: field !< The field value + INTEGER, INTENT(IN) :: weight !< The weight factor for the field + INTEGER, INTENT(IN) :: pow_value !< The power value for the power function SELECT CASE(pow_value) CASE (1) @@ -74,4 +128,6 @@ ELEMENTAL INTEGER(i8_kind) FUNCTION addwf_i8(buff, field, weight, pow_value ) END SELECT END FUNCTION addwf_i8 END MODULE fms_diag_elem_weight_procs_mod +!> @} +! close documentation grouping diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index 9a95e91061..da52d16859 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -70,6 +70,10 @@ MODULE fms_diag_fieldbuff_update_mod module procedure fieldbuff_copy_misvals_r4 !< r8 version of the interface module procedure fieldbuff_copy_misvals_r8 + !< r4 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_misvals_3d_r4 + !< r8 version of the interface, , where the field is 3D + module procedure fieldbuff_copy_misvals_3d_r8 !< i4 version of the interface !module procedure fieldbuff_copy_misvals_i4 !< i8 version of the interface @@ -84,7 +88,7 @@ MODULE fms_diag_fieldbuff_update_mod module procedure fieldbuff_copy_fieldvals_r4 !< r8 version of the interface module procedure fieldbuff_copy_fieldvals_r8 - !< r4 version of the interface, , where the field is 3D + !< r4 version of the interface, , where the field is 3D module procedure fieldbuff_copy_fieldvals_3d_r4 !< r8 version of the interface, , where the field is 3D module procedure fieldbuff_copy_fieldvals_3d_r8 diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 7b15462ec9..cb4dba15b9 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -21,8 +21,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) result( succeded ) - TYPE(fms_diag_outfield_type), INTENT(inout):: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg ! True iff no errors encountered. - !!TODO: Why did field_d, ofb, and ofc need to be allocatable"? field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3),1:1, 1:size(ofb,4)) => ofb @@ -89,8 +88,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) result( succeded ) - TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object + TYPE(fms_diag_outfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object + TYPE(fms_diag_outfield_index_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< Output Field Buffer FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofc !< Output Field Counter @@ -213,12 +212,9 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) - !!TODO: we can use the power function, or elem function addfw (or pointer ?) - !ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) +& - !& (field_d(i-is+1+hi, j-js+1+hj, k, :) * weight1) ** pow_value - ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample), & + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample), & & field_d(i-is+1+hi, j-js+1+hj, k, :), weight1, pow_value) - ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 + ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 END where END DO END DO @@ -228,8 +224,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) - ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) + & - & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) ofc(i-hi,j-hj,k,:,sample) = ofc(i-hi,j-hj,k,:,sample) + weight1 END where END DO @@ -244,8 +240,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) - ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) + & - & (field_d(i-is+1+hi, j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi, j-js+1+hj, k, :) , weight1, pow_value) ofc(i-hi,j-hj,k1,:,sample) = ofc(i-hi,j-hj,k1,:,sample) + weight1 END where END DO @@ -256,8 +252,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) - ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) + & - & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) ofc(i-hi,j-hj,k,:,sample) = ofc(i-hi,j-hj,k,:,sample) + weight1 END where END DO @@ -297,8 +293,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) - ofb(i1,j1,k1,:,sample) = ofb(i1,j1,k1,:,sample) +& - & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i1,j1,k1,:,sample) = missvalue END where @@ -317,8 +313,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 where ( mask(i-is+1+hi, j-js+1+hj, k, :) ) - ofb(i1,j1,k1,:,sample) = ofb(i1,j1,k1,:,sample) + & - & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i1,j1,k1,:,sample) = missvalue END where @@ -345,8 +341,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) - ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) + & - & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i-hi,j-hj,k1,:,sample)= missvalue END where @@ -360,8 +356,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) - ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) + & - & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i-hi,j-hj,k1,:,sample)= missvalue END where @@ -386,8 +382,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) - ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) + & - & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i-hi,j-hj,k,:,sample)= missvalue END where @@ -400,8 +396,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( mask(i-is+1+hi,j-js+1+hj, k, :) ) - ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) + & - & ( field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i-hi,j-hj,k,:,sample)= missvalue END where @@ -440,8 +436,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & j <= l_end(2)+hj ) THEN i1 = i-l_start(1)-hi+1 j1 = j-l_start(2)-hj+1 - ofb(i1,j1,:,:,sample)= ofb(i1,j1,:,:,sample)+ & - & (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value + ofb(i1,j1,:,:,sample)= addwf(ofb(i1,j1,:,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) , weight1, pow_value) END IF END DO END DO @@ -453,8 +449,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & j <= l_end(2)+hj ) THEN i1 = i-l_start(1)-hi+1 j1 = j-l_start(2)-hj+1 - ofb(i1,j1,:,:,sample) = ofb(i1,j1,:,:,sample) + & - & (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value + ofb(i1,j1,:,:,sample) = addwf( ofb(i1,j1,:,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) , weight1, pow_value) END IF END DO END DO @@ -474,14 +470,14 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & IF (numthreads>1 .AND. phys_window) then ksr= l_start(3) ker= l_end(3) - ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) +& - & (field_d(f1:f2,f3:f4,ksr:ker, :) * weight1) ** pow_value + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker, :) , weight1, pow_value) ELSE !$OMP CRITICAL ksr= l_start(3) ker= l_end(3) - ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) +& - & (field_d(f1:f2,f3:f4,ksr:ker,:) * weight1) ** pow_value + ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker,:) , weight1, pow_value) !$OMP END CRITICAL END IF ELSE NDCMP_RKR_2_IF @@ -497,13 +493,13 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END IF IF (numthreads>1 .AND. phys_window) then ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& - & ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) +& - & (field_d(f1:f2,f3:f4,ks:ke,:) * weight1) ** pow_value + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke,:) , weight1, pow_value) ELSE !$OMP CRITICAL ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& - & ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) +& - & (field_d(f1:f2,f3:f4,ks:ke,:) * weight1) ** pow_value + & addwf(ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke,:) , weight1, pow_value) !$OMP END CRITICAL END IF END IF NDCMP_RKR_2_IF @@ -524,8 +520,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) - ofb(i1,j1,k1,:,sample) = ofb(i1,j1,k1,:,sample) + & - & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i1,j1,k1,:,sample) = missvalue END where @@ -544,8 +540,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) - ofb(i1,j1,k1,:,sample) = ofb(i1,j1,k1,:,sample) + & - & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i1,j1,k1,:,sample) = addwf( ofb(i1,j1,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i1,j1,k1,:,sample) = missvalue END where @@ -586,8 +582,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) - ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) + & - & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k1,:,sample) = addwf(ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i-hi,j-hj,k1,:,sample) = missvalue END where @@ -603,8 +599,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) - ofb(i-hi,j-hj,k1,:,sample) = ofb(i-hi,j-hj,k1,:,sample) +& - & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k1,:,sample) = addwf( ofb(i-hi,j-hj,k1,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i-hi,j-hj,k1,:,sample) = missvalue END where @@ -643,8 +639,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) - ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) +& - & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i-hi,j-hj,k,:,sample) = missvalue END where @@ -657,8 +653,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & DO j=js, je DO i=is, ie where ( field_d(i-is+1+hi,j-js+1+hj, k, :) /= missvalue ) - ofb(i-hi,j-hj,k,:,sample) = ofb(i-hi,j-hj,k,:,sample) +& - & (field_d(i-is+1+hi,j-js+1+hj, k, :) * weight1) ** pow_value + ofb(i-hi,j-hj,k,:,sample) = addwf( ofb(i-hi,j-hj,k,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj, k, :) , weight1, pow_value) elsewhere ofb(i-hi,j-hj,k,:,sample) = missvalue END where @@ -689,8 +685,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & j <= l_end(2)+hj ) THEN i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 - ofb(i1,j1,:,:,sample) = ofb(i1,j1,:,:,sample) + & - & (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value + ofb(i1,j1,:,:,sample) = addwf( ofb(i1,j1,:,:,sample) , & + & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) , weight1, pow_value) END IF END DO END DO @@ -702,8 +698,6 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & j <= l_end(2)+hj ) THEN i1 = i-l_start(1)-hi+1 j1= j-l_start(2)-hj+1 - !ofb(i1,j1,:,:,sample)= ofb(i1,j1,:,:,sample) +& - !& (field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :) * weight1) ** pow_value ofb(i1,j1,:,:,sample) = addwf(ofb(i1,j1,:,:,sample), & & field_d(i-is+1+hi,j-js+1+hj,l_start(3):l_end(3), :), weight1, pow_value) END IF @@ -727,13 +721,13 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ker= l_end(3) IF( numthreads > 1 .AND. phys_window ) then ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) =& - & ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & - & (field_d(f1:f2,f3:f4,ksr:ker, :) * weight1) ** pow_value + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker, :) , weight1, pow_value) ELSE !$OMP CRITICAL ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) =& - & ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) + & - & (field_d(f1:f2,f3:f4,ksr:ker, :) * weight1) ** pow_value + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,:,:,sample) , & + & field_d(f1:f2,f3:f4,ksr:ker, :) , weight1, pow_value) !$OMP END CRITICAL END IF @@ -750,13 +744,13 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END IF IF( numthreads > 1 .AND. phys_window ) then ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& - & ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) +& - & (field_d(f1:f2,f3:f4,ks:ke, :) * weight1) ** pow_value + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke, :) , weight1, pow_value) ELSE !$OMP CRITICAL ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) =& - & ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) +& - & (field_d(f1:f2,f3:f4,ks:ke, :) * weight1) ** pow_value + & addwf( ofb(is-hi:ie-hi,js-hj:je-hj,ks:ke,:,sample) , & + & field_d(f1:f2,f3:f4,ks:ke, :) , weight1, pow_value) !! !$OMP END CRITICAL END IF @@ -781,8 +775,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FUNCTION FMS_DIAG_FBCF_3D_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & & bbounds, count_0d, mask, missvalue, & & l_start, l_end, err_msg, err_msg_local) result( succeded ) - TYPE(fms_diag_outfield_type), INTENT(inout) :: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(inout) :: ofield_index_cfg !< The ofield_index_cfg object + TYPE(fms_diag_outfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object + TYPE(fms_diag_outfield_index_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! null() !< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: rmask_ptr => null() !< + + ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:1, 1:size(ofb,4)) => ofb + rmask_ptr(1:size(rmask,1),1:size(rmask,2),1:size(rmask,3),1:1) => rmask + + call FMS_DIAG_FBCM_PNAME_ (ofield_cfg, ofield_index_cfg, ofb_ptr, sample, & + & l_start, l_end, rmask_ptr, rmask_thresh, missvalue) + END SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ + + !> \Description Updates where appropriate and depending on the rmask argument, !! elements of the running field output buffer (argument buffer) with value missvalue. !! NOTE: It appears these OFB updates were introcuded by EMC MM into the tail end of the !! legacy send_data_3d. - SUBROUTINE FMS_DIAG_FBCM_PNAME_ (is, js, ks, & - & ie, je, ke, hi, hj, sample, l_start, l_end, & - & buffer, rmask, rmask_thresh, missvalue, & - & need_compute, reduced_k_range) - INTEGER, INTENT(in):: is, js, ks, ie, je, ke, hi, hj + SUBROUTINE FMS_DIAG_FBCM_PNAME_ (ofield_cfg, ofield_index_cfg, buffer, sample, & + & l_start, l_end, rmask, rmask_thresh, missvalue) + TYPE(fms_diag_outfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object + TYPE(fms_diag_outfield_index_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout), DIMENSION(:,:,:,:,:) :: buffer !< the buffer to update INTEGER, INTENT(in) :: sample !< index along the diurnal time axis INTEGER, INTENT(in), DIMENSION(3):: l_start !< local start indices on 3 axes for regional output INTEGER, INTENT(in), DIMENSION(3):: l_end !< local end indices on 3 axes for regional output FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in), DIMENSION(:,:,:,:):: rmask !< Updates where rmask < rmask_thresh - FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout), DIMENSION(:,:,:,:,:) :: buffer !< the buffer to update - FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in), TARGET :: missvalue !< Value used to update the buffer. - FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in), TARGET :: rmask_thresh !< Updates where rmask < rmask_thresh - LOGICAL, INTENT(in) :: need_compute - LOGICAL, INTENT(in) :: reduced_k_range - !! - !! + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: rmask_thresh !< Updates where rmask < rmask_thresh + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< Value used to update the buffer. + + INTEGER :: is, js, ks, ie, je, ke, hi, hj + LOGICAL :: need_compute + LOGICAL :: reduced_k_range INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations - !> Looping indecies, derived from ofield_index_cfg: + !> Looping indecies, derived from ofield_index_cfg info: INTEGER :: i, j, k, i1, j1, k1 + is = ofield_index_cfg%is + js = ofield_index_cfg%js + ks = ofield_index_cfg%ks + ie = ofield_index_cfg%ie + je = ofield_index_cfg%je + ke = ofield_index_cfg%ke + hi = ofield_index_cfg%hi + hj = ofield_index_cfg%hj + + reduced_k_range = ofield_cfg%reduced_k_range + need_compute = ofield_cfg%need_compute + associate(ofb => buffer) ! If rmask and missing value present, then insert missing value From 8190672c5f1b838bc33dc6d62d907c7436ad0102 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Thu, 2 Feb 2023 23:24:36 -0500 Subject: [PATCH 21/37] Improved documentation in various places. Improved following of naming conventions. --- diag_manager/diag_data.F90 | 3 +- diag_manager/diag_manager.F90 | 10 +- diag_manager/diag_util.F90 | 224 +++++++++--------- diag_manager/fms_diag_elem_weight_procs.F90 | 4 +- diag_manager/fms_diag_fieldbuff_update.F90 | 4 +- .../include/fms_diag_fieldbuff_update.fh | 148 +++++++----- .../diag_manager/test_diag_update_buffer.F90 | 3 +- 7 files changed, 222 insertions(+), 174 deletions(-) diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 4f5a4284fb..9315b3a774 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -128,7 +128,6 @@ MODULE diag_data_mod REAL :: zend END TYPE coord_type -!!TODO: consider using an array for this. !> @brief Data structure holding intervals (or interval bounds or limits). !! Used for checking the bounds of the field output buffer arrays. TYPE, public :: fms_diag_ibounds_type @@ -348,6 +347,8 @@ MODULE diag_data_mod LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io LOGICAL :: use_refactored_send = .true. !< Namelist flag to use refactored send_data math funcitons. + !!TODO: leave use_refactored_send as false + ! #ifdef use_netCDF diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 5863b86311..e87a1ea95b 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1906,7 +1906,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & ENDIF IF ( average ) THEN - !!TODO: the copy that is filed_out should not be necessary + !!TODO (Future work): the copy that is filed_out should not be necessary mf_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,& & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & @@ -1946,10 +1946,11 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END IF END IF - !!TODO: One (or the other) of the calls below will not compile depending + !!TODO: (Discusssion) One of the calls below will not compile depending !! on the value of REAL. This is to the mixed use of REAL, R4, R8 and CLASS(*) !! in send_data_3d. A copy of rmask can be made to avoid but it would be wasteful. - !! Instead, the original functionality is used at the end. + !! The option used for now is that the original code to copy missing values is + !! is used at the end of this procedure. !IF ( PRESENT(rmask) .AND. missvalue_present ) THEN ! SELECT TYPE (rmask) ! TYPE IS (real(kind=r4_kind)) @@ -1973,8 +1974,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & DEALLOCATE(ofield_cfg) ENDIF - !!CYCLE !!. I.e. skip src code below and go to the next output field - ELSE !! END USE_REFACTORED_SEND + ELSE !! END USE_REFACTORED_SEND; Don''t use CYCLE option. ! Take care of submitted field data IF ( average ) THEN diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index b3a1b071df..f91563d4b7 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -99,29 +99,29 @@ MODULE diag_util_mod END INTERFACE attribute_init INTERFACE update_bounds - module procedure update_bounds_legacy - module procedure update_bounds_modern + module procedure fms_update_bounds_legacy + module procedure fms_update_bounds_modern END INTERFACE update_bounds INTERFACE check_out_of_bounds module procedure check_out_of_bounds_legacy - module procedure check_out_of_bounds_modern_r4 - module procedure check_out_of_bounds_modern_r8 + module procedure fms_check_out_of_bounds_modern_r4 + module procedure fms_check_out_of_bounds_modern_r8 END INTERFACE check_out_of_bounds INTERFACE check_bounds_are_exact_dynamic module procedure check_bounds_are_exact_dynamic_legacy - !!TODO: module procedure check_bounds_are_exact_dynamic_modern ? + !!TODO: (MDM) module procedure check_bounds_are_exact_dynamic_modern ? END INTERFACE check_bounds_are_exact_dynamic INTERFACE check_bounds_are_exact_static - module procedure check_bounds_are_exact_static_legacy - !! TODO: module procedure check_bounds_are_exact_static_modern + module procedure fms_check_bounds_are_exact_static_legacy + !! TODO: (MDM) module procedure check_bounds_are_exact_static_modern END INTERFACE check_bounds_are_exact_static INTERFACE bounds_from_array module procedure fms_bounds_from_array_4D - module procedure bounds_from_array_modern + module procedure fms_bounds_from_array_5D END INTERFACE bounds_from_array @@ -757,10 +757,11 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& & TRIM(axes_list) END SUBROUTINE log_diag_field_info - !!TODO: Rename like this: not with _legacy and _modern + !> @brief Determine the dounds of the first three dimentions + !! of the "array" argument and store it the bounding box argument "bounds" SUBROUTINE fms_bounds_from_array_4D(bounds, array) - REAL, INTENT( in), DIMENSION(:,:,:,:) :: array - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds + REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. bounds%imin = LBOUND(array,1) bounds%imax = UBOUND(array,1) bounds%jmin = LBOUND(array,2) @@ -769,20 +770,22 @@ SUBROUTINE fms_bounds_from_array_4D(bounds, array) bounds%kmax = UBOUND(array,3) END SUBROUTINE fms_bounds_from_array_4D - - SUBROUTINE bounds_from_array_modern(bounds, array) - CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds + !> @brief Determine the dounds of the first three dimentions + !! of the "array" argument and store it the bounding box argument "bounds" + SUBROUTINE fms_bounds_from_array_5D(bounds, array) + CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 4D input array. + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. bounds%imin = LBOUND(array,1) bounds%imax = UBOUND(array,1) bounds%jmin = LBOUND(array,2) bounds%jmax = UBOUND(array,2) bounds%kmin = LBOUND(array,3) bounds%kmax = UBOUND(array,3) - END SUBROUTINE bounds_from_array_modern + END SUBROUTINE fms_bounds_from_array_5D - !> @brief Update the output_fields x, y, and z min and max boundaries (array indices). - SUBROUTINE update_bounds_legacy(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) + !> @brief Update the output_fields x, y, and z min and max boundaries (array indices) + !! with the six specified bounds values. + SUBROUTINE fms_update_bounds_legacy(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) INTEGER, INTENT(in) :: out_num !< output field ID INTEGER, INTENT(in) :: lower_i !< Lower i bound. INTEGER, INTENT(in) :: upper_i !< Upper i bound. @@ -790,12 +793,13 @@ SUBROUTINE update_bounds_legacy(out_num, lower_i, upper_i, lower_j, upper_j, low INTEGER, INTENT(in) :: upper_j !< Upper j bound. INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. - CALL update_bounds_modern(output_fields(out_num)%buff_bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) - END SUBROUTINE update_bounds_legacy + CALL fms_update_bounds_modern(output_fields(out_num)%buff_bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) + END SUBROUTINE fms_update_bounds_legacy - !> @brief Update the output_fields x, y, and z (and optionally l) min and - !! max boundaries (array indices). -SUBROUTINE update_bounds_modern(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) + !> @brief Update the the first three (normally x, y, and z) min and + !! max boundaries (array indices) of the input bounding box "bounds" with + !! the six specified bounds values. +SUBROUTINE fms_update_bounds_modern(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) TYPE (fms_diag_ibounds_type), intent(inout) :: bounds !< the bounding box of the output field buffer inindex space. INTEGER, INTENT(in) :: lower_i !< Lower i bound. INTEGER, INTENT(in) :: upper_i !< Upper i bound. @@ -809,19 +813,20 @@ SUBROUTINE update_bounds_modern(bounds, lower_i, upper_i, lower_j, upper_j, lowe bounds%jmax = MAX(bounds%jmax, upper_j) bounds%kmin = MIN(bounds%kmin, lower_k) bounds%kmax = MAX(bounds%kmax, upper_k) -END SUBROUTINE update_bounds_modern - - +END SUBROUTINE fms_update_bounds_modern - !> @brief Compares the indecies in bounds to the corresponding lower and upper bounds of array buffer. + !> @brief Compares the dounding indecies of an array specified in "current_bounds" +!! to the corresponding lower and upper bounds specified in "bounds" !! Comparison is done by the two user specified input functions lowerb_comp and upperb_comp. !! If any compariosn function returns true, then, after filling error_str, this routine also returns !! true. The suplied comparison functions should return true for errors : for indecies out of bounds, !! or indecies are not equal when expected to be equal. -LOGICAL FUNCTION compare_buffer_bounds_to_size(array_bounds, bounds, error_str, lowerb_comp, upperb_comp) - TYPE (fms_diag_ibounds_type), INTENT(in) :: array_bounds - TYPE (fms_diag_ibounds_type), INTENT(in):: bounds - CHARACTER(*), INTENT(inout) :: error_str +LOGICAL FUNCTION compare_buffer_bounds_to_size(current_bounds, bounds, error_str, lowerb_comp, upperb_comp) + TYPE (fms_diag_ibounds_type), INTENT(in) :: current_bounds ! @brief Interface lowerb_comp should be used for comparison to lower bounds of buffer. INTERFACE @@ -839,20 +844,20 @@ END FUNCTION upperb_comp compare_buffer_bounds_to_size = .FALSE. - IF (lowerb_comp( bounds%imin , array_bounds%imin) .OR. & - upperb_comp( bounds%imax , array_bounds%imax).OR.& - lowerb_comp( bounds%jmin , array_bounds%jmin) .OR.& - upperb_comp( bounds%jmax , array_bounds%jmax) .OR.& - lowerb_comp( bounds%kmin , array_bounds%kmin) .OR.& - upperb_comp( bounds%kmax , array_bounds%kmax)) THEN + IF (lowerb_comp( bounds%imin , current_bounds%imin) .OR. & + upperb_comp( bounds%imax , current_bounds%imax).OR.& + lowerb_comp( bounds%jmin , current_bounds%jmin) .OR.& + upperb_comp( bounds%jmax , current_bounds%jmax) .OR.& + lowerb_comp( bounds%kmin , current_bounds%kmin) .OR.& + upperb_comp( bounds%kmax , current_bounds%kmax)) THEN compare_buffer_bounds_to_size = .TRUE. error_str ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_str(15:17),'(i3)') array_bounds%imin - WRITE(error_str(19:21),'(i3)') array_bounds%imax - WRITE(error_str(23:25),'(i3)') array_bounds%jmin - WRITE(error_str(27:29),'(i3)') array_bounds%jmax - WRITE(error_str(31:33),'(i3)') array_bounds%kmin - WRITE(error_str(35:37),'(i3)') array_bounds%kmax + WRITE(error_str(15:17),'(i3)') current_bounds%imin + WRITE(error_str(19:21),'(i3)') current_bounds%imax + WRITE(error_str(23:25),'(i3)') current_bounds%jmin + WRITE(error_str(27:29),'(i3)') current_bounds%jmax + WRITE(error_str(31:33),'(i3)') current_bounds%kmin + WRITE(error_str(35:37),'(i3)') current_bounds%kmax WRITE(error_str(54:56),'(i3)') bounds%imin WRITE(error_str(58:60),'(i3)') bounds%imax WRITE(error_str(62:64),'(i3)') bounds%jmin @@ -885,6 +890,7 @@ END FUNCTION a_noteq_b !> @brief Checks if the array indices for output_fields(out_num) are outside the !! output_fields(out_num)%buffer upper and lower bounds. + !! If there is an error then error message will be filled. SUBROUTINE check_out_of_bounds_legacy(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID number. INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. @@ -901,27 +907,27 @@ SUBROUTINE check_out_of_bounds_legacy(out_num, diag_field_id, err_msg) out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & & error_string2, a_lessthan_b, a_greaterthan_b) - - IF (out_of_bounds .EQV. .true.) THEN - WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name), & - & TRIM(output_fields(out_num)%output_name) - err_msg = 'module/output_field='//TRIM(error_string1)//& + IF (out_of_bounds .EQV. .true.) THEN + WRITE(error_string1,'(a,"/",a)') TRIM(input_fields(diag_field_id)%module_name), & + & TRIM(output_fields(out_num)%output_name) + err_msg = 'module/output_field='//TRIM(error_string1)//& & ' Bounds of buffer exceeded. '//TRIM(error_string2) - ! imax, imin, etc need to be reset in case the program is not terminated. - call buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) - ELSE - err_msg = '' - END IF + ! imax, imin, etc need to be reset in case the program is not terminated. + call buff_bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) + ELSE + err_msg = '' + END IF end associate END SUBROUTINE check_out_of_bounds_legacy !> @brief Checks if the array indices for output_fields(out_num) are outside the !! output_fields(out_num)%buffer upper and lower bounds. -SUBROUTINE check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, err_msg) - REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds - CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name - CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name + !! If there is an error then error message will be filled. +SUBROUTINE fms_check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The bounding box to check against + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the @@ -943,21 +949,23 @@ SUBROUTINE check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, ELSE err_msg = '' END IF -END SUBROUTINE check_out_of_bounds_modern_r4 +END SUBROUTINE fms_check_out_of_bounds_modern_r4 - !> @brief Checks if the array indices for output_fields(out_num) are outside the - !! output_fields(out_num)%buffer upper and lower bounds. -SUBROUTINE check_out_of_bounds_modern_r8(ofb, bounds, output_name, module_name, err_msg) - REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds - CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name - CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name + !> @brief Checks if the array indices for output_field buffer (ofb) are outside the + !! are outside the bounding box (bounds). + !! If there is an error then error message will be filled. + +SUBROUTINE fms_check_out_of_bounds_modern_r8(ofb, bounds, output_name, module_name, err_msg) + REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check + TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The bounding box to check against + CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: out_of_bounds = .true. - TYPE (fms_diag_ibounds_type) :: array_bounds + TYPE (fms_diag_ibounds_type) :: array_bounds ! @brief Checks that array indecies specified in the bounding box "current_bounds" +!! are identical to those in the bounding box "bounds" match exactly. The check +!! occurs only when the time changed. +!! If there is an error then error message will be filled. +SUBROUTINE check_bounds_are_exact_dynamic_modern(current_bounds, bounds, output_name, module_name, & & Time, field_prev_Time, err_msg) - TYPE (fms_diag_ibounds_type), INTENT(in) :: array_bounds - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds - CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name - CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name + TYPE (fms_diag_ibounds_type), INTENT(in) :: current_bounds !output_fields(out_num)%Time_of_prev_field_data is not !! equal to Time or Time_zero. @@ -997,7 +1009,6 @@ SUBROUTINE check_bounds_are_exact_dynamic_modern(array_bounds, bounds, output_na err_msg = '' - ! Check bounds only when the value of Time changes. When windows are used, ! a change in Time indicates that a new loop through the windows has begun, ! so a check of the previous loop can be done. @@ -1015,7 +1026,7 @@ SUBROUTINE check_bounds_are_exact_dynamic_modern(array_bounds, bounds, output_na END IF IF ( do_check ) THEN - lims_not_exact = compare_buffer_bounds_to_size(array_bounds, bounds, & + lims_not_exact = compare_buffer_bounds_to_size(current_bounds, bounds, & & error_string2, a_noteq_b, a_noteq_b) IF( lims_not_exact .eqv. .TRUE.) THEN WRITE(error_string1,'(a,"/",a)') TRIM(module_name), TRIM(output_name) @@ -1026,10 +1037,8 @@ SUBROUTINE check_bounds_are_exact_dynamic_modern(array_bounds, bounds, output_na END SUBROUTINE check_bounds_are_exact_dynamic_modern - !> @brief This is an adaptor to the check_out_of_bounds function to -!! maintain an interface servicing the older diag_manager (particularly the -!! send_data_3d function) and maintain a version of it as unchaged as possible. - +!> @brief This is an adaptor to the check_bounds_are_exact_dynamic_modern function to +!! maintain an interface servicing the legacy diag_manager. SUBROUTINE check_bounds_are_exact_dynamic_legacy(out_num, diag_field_id, Time, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID number. INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. @@ -1038,17 +1047,17 @@ SUBROUTINE check_bounds_are_exact_dynamic_legacy(out_num, diag_field_id, Time, e !! equal to Time or Time_zero. CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_bounds_are_exact_dynamic. !! An empty error string indicates the x, y, and z indices are - !! equal to the buffer array boundaries. - CHARACTER(:), ALLOCATABLE :: output_name - CHARACTER(:), ALLOCATABLE :: module_name - TYPE (fms_diag_ibounds_type) :: array_bounds + !! equal to the buffer array boundaries. + CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE :: module_name !< module name for placing in error message + TYPE (fms_diag_ibounds_type) :: current_bounds !< a bounding box to store the current bounds of the array. output_name = output_fields(out_num)%output_name module_name = input_fields(diag_field_id)%module_name - CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) + CALL bounds_from_array(current_bounds, output_fields(out_num)%buffer) - CALL check_bounds_are_exact_dynamic_modern(array_bounds, output_fields(out_num)%buff_bounds, & + CALL check_bounds_are_exact_dynamic_modern(current_bounds, output_fields(out_num)%buff_bounds, & & output_name, module_name, & & Time, output_fields(out_num)%Time_of_prev_field_data, err_msg) @@ -1056,47 +1065,50 @@ END SUBROUTINE check_bounds_are_exact_dynamic_legacy !> @brief Check if the array indices for output_fields(out_num) are equal to the - !! output_fields(out_num)%buffer - !! upper and lower bounds. - SUBROUTINE check_bounds_are_exact_static_legacy(out_num, diag_field_id, err_msg) + !! output_fields(out_num)%buffer upper and lower bounds. + SUBROUTINE fms_check_bounds_are_exact_static_legacy(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID INTEGER, INTENT(in) :: diag_field_id !< Input field ID. - CHARACTER(len=*), INTENT(inout) :: err_msg - CHARACTER(:), ALLOCATABLE :: output_name - CHARACTER(:), ALLOCATABLE :: module_name - TYPE (fms_diag_ibounds_type) :: array_bounds + CHARACTER(len=*), INTENT(inout) :: err_msg !< The return status, which is set to non-empty message + !! if the check fails. + CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message + CHARACTER(:), ALLOCATABLE :: module_name !< output name for placing in error message + TYPE (fms_diag_ibounds_type) :: current_bounds !< a bounding box to store the current bounds of the array. output_name = output_fields(out_num)%output_name module_name = input_fields(diag_field_id)%module_name - CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) + CALL bounds_from_array(current_bounds, output_fields(out_num)%buffer) - CALL check_bounds_are_exact_static_modern(array_bounds, output_fields(out_num)%buff_bounds, & + CALL fms_check_bounds_are_exact_static_modern(current_bounds, output_fields(out_num)%buff_bounds, & & output_name, module_name, err_msg) - END SUBROUTINE check_bounds_are_exact_static_legacy + END SUBROUTINE fms_check_bounds_are_exact_static_legacy - !> @brief Check if the array indices for output_fields are equal to the - !! buffer upper and lower bounds. - SUBROUTINE check_bounds_are_exact_static_modern(array_bounds, bounds, output_name, module_name, err_msg) - TYPE (fms_diag_ibounds_type), INTENT(in) :: array_bounds - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds - CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name - CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name - CHARACTER(len=*), INTENT(inout) :: err_msg + !> @brief Check if the array indices specified in the bounding box "current_bounds" are equal to those + !! specified in the bounding box "bounds" output_fields are equal to the buffer upper and lower bounds. + !! If there is an error then error message will be filled. + SUBROUTINE fms_check_bounds_are_exact_static_modern(current_bounds, bounds, output_name, module_name, err_msg) + TYPE (fms_diag_ibounds_type), INTENT(in) :: current_bounds ! @brief Initialize the output file. diff --git a/diag_manager/fms_diag_elem_weight_procs.F90 b/diag_manager/fms_diag_elem_weight_procs.F90 index 987f544b48..53dbf062ba 100644 --- a/diag_manager/fms_diag_elem_weight_procs.F90 +++ b/diag_manager/fms_diag_elem_weight_procs.F90 @@ -59,7 +59,7 @@ MODULE fms_diag_elem_weight_procs_mod ELEMENTAL REAL(r4_kind) FUNCTION addwf_r4(buff, field, weight, pow_value ) REAL(r4_kind), INTENT(in) :: buff !< The buffer cell (point) value REAL(r4_kind), INTENT(IN) :: field !< The field value - REAL, INTENT(IN) :: weight !< The weight factor for the field + REAL(r4_kind), INTENT(IN) :: weight !< The weight factor for the field INTEGER, INTENT(IN) :: pow_value !< The power value for the power function SELECT CASE(pow_value) @@ -78,7 +78,7 @@ END FUNCTION addwf_r4 ELEMENTAL REAL(r8_kind) FUNCTION addwf_r8(buff, field, weight, pow_value ) REAL(r8_kind), INTENT(in) :: buff !< The buffer cell (point) value REAL(r8_kind) ,INTENT(IN) :: field !< The field value - REAL, INTENT(IN) :: weight !< The weight factor for the field + REAL(r8_kind), INTENT(IN) :: weight !< The weight factor for the field INTEGER, INTENT(IN) :: pow_value !< The power value for the power function SELECT CASE(pow_value) diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index da52d16859..e7f257ef67 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -44,6 +44,8 @@ MODULE fms_diag_fieldbuff_update_mod implicit none + !!TODO: (MDM) Remove commented integer versions. + !> @brief Interface fieldbuff_update updates elements of field output buffer based on input field !! data and mathematical operations on the field data. !> @ingroup fms_diag_fieldbuff_update_mod @@ -100,7 +102,7 @@ MODULE fms_diag_fieldbuff_update_mod contains -#include +#include "fms_diag_fieldbuff_update.inc" END MODULE fms_diag_fieldbuff_update_mod !> @} diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index cb4dba15b9..93f7a6ab36 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -16,7 +16,10 @@ !* You should have received a copy of the GNU Lesser General Public !* License along with FMS. If not, see . !*********************************************************************** -!! + + !> @brief This code will be used by the preprecessor to generate an implementation + !! to the module procudure for the fieldbuff_update interface. The + !! generated function is a wrapper calling 4D field/5D buffer version of the same. FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & @@ -31,7 +34,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. INTEGER, INTENT(inout) :: num_elements LOGICAL, CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask !< mask - REAL, INTENT(in) :: weight1 !< Field data is multiplied by weight !!TODO: Change to same type as field data? + FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight. FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. INTEGER, INTENT(inout) :: field_num_threads @@ -75,7 +78,9 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END FUNCTION FMS_DIAG_FBU_3D_PNAME_ -!> @brief Updates elements of the running field output buffer (argument ofb) +!> @brief This code will be used by the preprecessor to generate an implementation +!! to the module procudure for the fieldbuff_update interface. +!! Updates elements of the running field output buffer (argument ofb) !! and counter (argument ofc) based on the input field data array (argument field_d). !! In general the formulas are : !! A) ofb(l) = ofb(l) + (weight * field(l))**pow_value @@ -99,7 +104,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & INTEGER, INTENT(inout) :: num_elements LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask !< mask - REAL, INTENT(in) :: weight1 !< Field data is multiplied by weight !!TODO: Change to same type as field data? + FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. INTEGER, INTENT(inout) :: field_num_threads @@ -123,11 +128,12 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL :: missvalue_present !< A copy of same variable in ofield_cfg !> The indecies copied directly from the ofield_index_cfg: - INTEGER:: is, js, ks, ls, ie, je, ke, le, hi, hj, f1, f2, f3, f4 + INTEGER:: is, js, ks, ie, je, ke, hi, hj, f1, f2, f3, f4 + INTEGER:: ls, le !> start and end indecies for the 4th dimension. INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations !> Looping indecies, derived from ofield_index_cfg: - INTEGER :: i, j, k, i1, j1, k1 + INTEGER :: i, j, k, l, i1, j1, k1 INTEGER :: numthreads INTEGER :: active_omp_level @@ -140,8 +146,9 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & INTEGER :: omp_get_level !< OMP function #endif - !!TODO: Update all of 4th dim via ":", or pass "ls:le" of L do loop" ? - !!Currently see where clause in loops, optionally use ls = 1, le = SIZE(field_d, 4) + !!TODO: (MDM) Will the interface allow passing in is, ie? + ls = 1 + le = SIZE(field_d, 4) ksr= l_start(3) ker= l_end(3) @@ -325,13 +332,15 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL ENDIF !$OMP CRITICAL - DO j = js, je - DO i = is, ie - 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 - num_elements = num_elements + l_end(3) - l_start(3) + 1 - END IF - END DO + DO l = ls, le + DO j = js, je + DO i = is, ie + 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 + num_elements = num_elements + l_end(3) - l_start(3) + 1 + END IF + END DO + END DO END DO !$OMP END CRITICAL ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_1_IF @@ -457,13 +466,15 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL END IF !$OMP CRITICAL - DO j = js, je - DO i = is, ie + DO l = ls, le + DO j = js, je + DO i = is, ie 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 - num_elements = num_elements + l_end(3)-l_start(3)+1 + & j <= l_end(2)+hj ) THEN + num_elements = num_elements + l_end(3)-l_start(3)+1 END IF - END DO + END DO + END DO END DO !$OMP END CRITICAL ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_2_IF @@ -552,25 +563,29 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL END IF NTAPW_IF !$OMP CRITICAL - DO j = js, je - DO i = is, ie + DO l = ls, le + DO j = js, je + DO i = is, ie 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 - num_elements = num_elements + l_end(3) - l_start(3) + 1 + & j <= l_end(2)+hj) THEN + num_elements = num_elements + l_end(3) - l_start(3) + 1 END IF - END DO + END DO + END DO END DO IF ( .NOT.phys_window ) THEN - DO k = l_start(3), l_end(3) - DO j=l_start(2)+hj, l_end(2)+hj - DO i=l_start(1)+hi, l_end(1)+hi - IF ( ANY (field_d(i,j, k, :) /= missvalue )) THEN - count_0d = count_0d + weight1 - EXIT + DO l = ls, le + DO k = l_start(3), l_end(3) + DO j=l_start(2)+hj, l_end(2)+hj + DO i=l_start(1)+hi, l_end(1)+hi + IF (field_d(i,j, k, l) /= missvalue ) THEN + count_0d = count_0d + weight1 + EXIT END IF - END DO - END DO - END DO + END DO + END DO + END DO + END DO END IF !$OMP END CRITICAL ELSE IF ( reduced_k_range ) THEN NDCMP_RKR_3_IF @@ -610,18 +625,20 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL END IF !$OMP CRITICAL - DO k = ksr, ker - k1=k-ksr+1 - DO j=f3, f4 + DO l = ls, le + DO k = ksr, ker + k1=k-ksr+1 + DO j=f3, f4 DO i=f1, f2 - !! TODO: verify this below - IF ( ANY (field_d(i,j, k, :) /= missvalue )) THEN + !!TODO: verify this and similar ones. Note the EXIT statement + IF ( field_d(i,j, k, l) /= missvalue ) THEN count_0d = count_0d + weight1 EXIT END IF END DO END DO END DO + END DO !$OMP END CRITICAL ELSE NDCMP_RKR_3_IF IF ( debug_diag_manager ) THEN @@ -664,15 +681,17 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL END IF !$OMP CRITICAL - DO k=ks, ke - DO j=f3, f4 - DO i=f1, f2 - IF ( any (field_d(i,j, k, :) /= missvalue )) THEN + DO l = ls, le + DO k=ks, ke + DO j=f3, f4 + DO i=f1, f2 + IF ( field_d(i,j, k, l) /= missvalue ) THEN count_0d = count_0d + weight1 EXIT - END IF - END DO - END DO + END IF + END DO + END DO + END DO END DO !$OMP END CRITICAL END IF NDCMP_RKR_3_IF @@ -706,13 +725,15 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL END IF !$OMP CRITICAL - DO j = js, je - DO i = is, ie + DO l = ls, le + DO j = js, je + DO i = is, ie 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 - num_elements = num_elements + l_end(3)-l_start(3)+1 + & j <= l_end(2)+hj ) THEN + num_elements = num_elements + l_end(3)-l_start(3)+1 END IF - END DO + END DO + END DO END DO !$OMP END CRITICAL ! Accumulate time average @@ -763,8 +784,10 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END IF MASK_VAR_IF !$OMP CRITICAL - IF ( .NOT.need_compute .AND. .NOT.reduced_k_range ) num_elements = num_elements + (ie-is+1)*(je-js+1)*(ke-ks+1) - IF ( reduced_k_range ) num_elements = num_elements + (ie-is+1)*(je-js+1)*(ker-ksr+1) + IF ( .NOT.need_compute .AND. .NOT.reduced_k_range ) num_elements = num_elements + & + & (ie-is+1)*(je-js+1)*(ke-ks+1)*(le-ls+1) + IF ( reduced_k_range ) num_elements = num_elements + & + & (ie-is+1)*(je-js+1)*(ker-ksr+1)*(le-ls+1) !$OMP END CRITICAL succeded = .TRUE. @@ -772,6 +795,10 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END FUNCTION FMS_DIAG_FBU_PNAME_ + + !> @brief This code will be used by the preprecessor to generate an implementation + !! to the module procudure for the fieldbuff_copy_fieldvals interface. The + !! generated function is a wrapper calling 4D field/5D buffer version of the same. FUNCTION FMS_DIAG_FBCF_3D_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & & bbounds, count_0d, mask, missvalue, & & l_start, l_end, err_msg, err_msg_local) result( succeded ) @@ -808,8 +835,9 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & l_start, l_end, err_msg, err_msg_local) END FUNCTION FMS_DIAG_FBCF_3D_PNAME_ - -!> \Description May set or add to the output field buffer (argument ofb) with the input +!> @brief This code will be used by the preprecessor to generate an implementation +!! to the module procudure for the fieldbuff_copy_fieldvals interface. +!! The function may set or add to the output field buffer (argument ofb) with the input !! field data array (argument field) FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & & bbounds, count_0d, mask, missvalue, & @@ -863,7 +891,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, f3 = ofield_index_cfg%f3 f4 = ofield_index_cfg%f4 - time_max = ofield_cfg%time_reduction%is_time_max() !!TODO: + time_max = ofield_cfg%time_reduction%is_time_max() time_min = ofield_cfg%time_reduction%is_time_min() time_sum = ofield_cfg%time_reduction%is_time_sum() @@ -1194,6 +1222,10 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, END FUNCTION FMS_DIAG_FBCF_PNAME_ + + !> @brief This code will be used by the preprecessor to generate an implementation + !! to the module procudure for the fieldbuff_copy_misvals interface. The + !! generated function is a wrapper calling 4D field/5D buffer version of the same. SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ (ofield_cfg, ofield_index_cfg, ofb, sample, & & l_start, l_end, rmask, rmask_thresh, missvalue) TYPE(fms_diag_outfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object @@ -1219,7 +1251,9 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, END SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ - !> \Description Updates where appropriate and depending on the rmask argument, + !> @brief This code will be used by the preprecessor to generate an implementation + !! to the module procudure for the fieldbuff_copy_misvals interface. + !! The function updates where appropriate and depending on the rmask argument, !! elements of the running field output buffer (argument buffer) with value missvalue. !! NOTE: It appears these OFB updates were introcuded by EMC MM into the tail end of the !! legacy send_data_3d. diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index ca491f7478..f91e3c929a 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -96,13 +96,12 @@ program test_diag_update_buffer INTEGER:: diag_field_id INTEGER:: sample !!diurnal_index - REAL :: weight + REAL(kind=r4_kind) :: weight INTEGER:: hi, hj !!for halo sizes integer num_threads integer active_omp_level logical issued_mask_ignore_warning - CHARACTER(len=256) :: err_msg, err_msg_local integer, dimension(3) :: l_start, l_end From 2b45ca61655057d19f54de8edc08c2b25c029e3e Mon Sep 17 00:00:00 2001 From: ngs333 Date: Fri, 3 Feb 2023 00:13:23 -0500 Subject: [PATCH 22/37] Fixing line longer than 120 chars. Improved some comments. --- diag_manager/diag_util.F90 | 5 +++-- diag_manager/fms_diag_outfield.F90 | 17 ++++++----------- 2 files changed, 9 insertions(+), 13 deletions(-) diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index f91563d4b7..d45e43728d 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -793,14 +793,15 @@ SUBROUTINE fms_update_bounds_legacy(out_num, lower_i, upper_i, lower_j, upper_j, INTEGER, INTENT(in) :: upper_j !< Upper j bound. INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. - CALL fms_update_bounds_modern(output_fields(out_num)%buff_bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) + CALL fms_update_bounds_modern(output_fields(out_num)%buff_bounds, & + & lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) END SUBROUTINE fms_update_bounds_legacy !> @brief Update the the first three (normally x, y, and z) min and !! max boundaries (array indices) of the input bounding box "bounds" with !! the six specified bounds values. SUBROUTINE fms_update_bounds_modern(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) - TYPE (fms_diag_ibounds_type), intent(inout) :: bounds !< the bounding box of the output field buffer inindex space. + TYPE (fms_diag_ibounds_type), intent(inout) :: bounds !), NO_CALENDAR, increment_date,& - !!& increment_time, get_calendar_type, get_date, get_time, leap_year, OPERATOR(-),& - !!& OPERATOR(<), OPERATOR(>=), OPERATOR(<=), OPERATOR(==) + implicit none @@ -64,9 +58,9 @@ MODULE fms_diag_outfield_mod !! !! Class fms_diag_outfield_type also contains a significant subset of the fields !! and routines of of the legacy class output_field_type - !! TODO: Developemnt of this class is in a seperate and future PR. For its development, - !! consider the legacy diag_util::init_output_field already in place. Fields added so - !! are uesd the the field buffer math/dupdate functions. + !! TODO: (MDM) This class will need further developemnt for the modern_diag effor. + !! For its development, but consider the legacy diag_util::init_output_field already + !! in place. Fields added so are uesd the the field buffer math/dupdate functions. !> @ingroup fms_diag_outfield_mod TYPE fms_diag_outfield_type CHARACTER(len=:), ALLOCATABLE :: module_name !< Module name. @@ -88,7 +82,8 @@ MODULE fms_diag_outfield_mod TYPE(time_reduction_type) :: time_reduction !< Instance of the time_reduction_type. - !!TODO : a pointer for time_min and time_max comparison function + !!TODO (Future effort? ) : a pointer for time_min and time_max comparison function + !! If possible, this can reove the innermost if/then/else construct in the buffer update loops. !! min_max_f_ptr => (should point to < or > operators) !! gcc error: Interface ‘addwf’ at (1) must be explicit From 87adf191e6c55f017ba6cc8efcca3fe1290d2772 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Wed, 8 Feb 2023 18:57:14 -0500 Subject: [PATCH 23/37] Numerous changes based oncode review. --- diag_manager/diag_data.F90 | 25 +- diag_manager/diag_manager.F90 | 12 +- diag_manager/diag_util.F90 | 58 ++--- diag_manager/fms_diag_elem_weight_procs.F90 | 4 +- diag_manager/fms_diag_fieldbuff_update.F90 | 24 +- diag_manager/fms_diag_outfield.F90 | 142 ++++++++++-- diag_manager/fms_diag_time_reduction.F90 | 112 +++++---- .../include/fms_diag_fieldbuff_update.fh | 216 ++++++++++-------- .../include/fms_diag_fieldbuff_update.inc | 8 +- .../diag_manager/test_diag_update_buffer.F90 | 46 ++-- 10 files changed, 382 insertions(+), 265 deletions(-) diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 9315b3a774..1829b0d597 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -345,7 +345,7 @@ MODULE diag_data_mod !! .TRUE. is only supported if the diag_manager_init !! routine is called with the optional time_init parameter. LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io - LOGICAL :: use_refactored_send = .true. !< Namelist flag to use refactored send_data math funcitons. + LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons. !!TODO: leave use_refactored_send as false @@ -406,19 +406,18 @@ SUBROUTINE diag_data_init() END SUBROUTINE diag_data_init -!> @brief Sets the lower and upper bounds to lower_val and upper_val, respectively. + !> @brief Sets the lower and upper bounds to lower_val and upper_val, respectively. SUBROUTINE ibounds_reset (this, lower_val, upper_val) - class (fms_diag_ibounds_type), target, intent(inout) :: this !< ibounds instance - integer, intent(in) :: lower_val !< value for the lower bounds in each dimension - integer, intent(in) :: upper_val !< value for the upper bounds in each dimension - this%imin = lower_val - this%jmin = lower_val - this%kmin = lower_val - this%imax = upper_val - this%jmax = upper_val - this%kmax = upper_val -end SUBROUTINE ibounds_reset - + class (fms_diag_ibounds_type), target, intent(inout) :: this !< ibounds instance + integer, intent(in) :: lower_val !< value for the lower bounds in each dimension + integer, intent(in) :: upper_val !< value for the upper bounds in each dimension + this%imin = lower_val + this%jmin = lower_val + this%kmin = lower_val + this%imax = upper_val + this%jmax = upper_val + this%kmax = upper_val + END SUBROUTINE ibounds_reset END MODULE diag_data_mod !> @} diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index e87a1ea95b..ed5374b16b 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -239,8 +239,8 @@ MODULE diag_manager_mod USE diag_output_mod, ONLY: get_diag_global_att, set_diag_global_att USE diag_grid_mod, ONLY: diag_grid_init, diag_grid_end USE constants_mod, ONLY: SECONDS_PER_DAY - USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_index_type, fms_diag_outfield_type - USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_misvals, & + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type + USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & & fieldbuff_copy_fieldvals #ifdef use_netCDF @@ -1493,8 +1493,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 => null() ! null() !< A pointer to mask - TYPE(fms_diag_outfield_index_type), ALLOCATABLE:: ofield_index_cfg ! @brief Prepend a value to a string attribute in the output field or output file. @@ -103,11 +104,11 @@ MODULE diag_util_mod module procedure fms_update_bounds_modern END INTERFACE update_bounds - INTERFACE check_out_of_bounds - module procedure check_out_of_bounds_legacy - module procedure fms_check_out_of_bounds_modern_r4 - module procedure fms_check_out_of_bounds_modern_r8 - END INTERFACE check_out_of_bounds + INTERFACE fms_diag_check_out_of_bounds + !!module procedure check_out_of_bounds_legacy + module procedure fms_diag_check_out_of_bounds_modern_r4 + module procedure fms_diag_check_out_of_bounds_modern_r8 + END INTERFACE fms_diag_check_out_of_bounds INTERFACE check_bounds_are_exact_dynamic module procedure check_bounds_are_exact_dynamic_legacy @@ -757,7 +758,7 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& & TRIM(axes_list) END SUBROUTINE log_diag_field_info - !> @brief Determine the dounds of the first three dimentions + !> @brief Determine the bounds of the first three dimentions !! of the "array" argument and store it the bounding box argument "bounds" SUBROUTINE fms_bounds_from_array_4D(bounds, array) REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. @@ -770,7 +771,7 @@ SUBROUTINE fms_bounds_from_array_4D(bounds, array) bounds%kmax = UBOUND(array,3) END SUBROUTINE fms_bounds_from_array_4D - !> @brief Determine the dounds of the first three dimentions + !> @brief Determine the bounds of the first three dimentions !! of the "array" argument and store it the bounding box argument "bounds" SUBROUTINE fms_bounds_from_array_5D(bounds, array) CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 4D input array. @@ -816,12 +817,12 @@ SUBROUTINE fms_update_bounds_modern(bounds, lower_i, upper_i, lower_j, upper_j, bounds%kmax = MAX(bounds%kmax, upper_k) END SUBROUTINE fms_update_bounds_modern - !> @brief Compares the dounding indecies of an array specified in "current_bounds" + !> @brief Compares the bounding indices of an array specified in "current_bounds" !! to the corresponding lower and upper bounds specified in "bounds" !! Comparison is done by the two user specified input functions lowerb_comp and upperb_comp. !! If any compariosn function returns true, then, after filling error_str, this routine also returns -!! true. The suplied comparison functions should return true for errors : for indecies out of bounds, -!! or indecies are not equal when expected to be equal. +!! true. The suplied comparison functions should return true for errors : for indices out of bounds, +!! or indices are not equal when expected to be equal. LOGICAL FUNCTION compare_buffer_bounds_to_size(current_bounds, bounds, error_str, lowerb_comp, upperb_comp) TYPE (fms_diag_ibounds_type), INTENT(in) :: current_bounds ! @brief Interface lowerb_comp should be used for comparison to lower bounds of buffer. INTERFACE LOGICAL FUNCTION lowerb_comp(a , b) - INTEGER, INTENT(IN) :: a, b + INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other. END FUNCTION lowerb_comp END INTERFACE !> @brief Interface lowerb_comp should be used for comparison to upper bounds of buffer. INTERFACE LOGICAL FUNCTION upperb_comp(a, b) - INTEGER, INTENT(IN) :: a, b + INTEGER, INTENT(IN) :: a !< One of the two args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< One of the two args that are to be compared to each other. END FUNCTION upperb_comp END INTERFACE @@ -873,26 +876,29 @@ END FUNCTION compare_buffer_bounds_to_size !> @brief return true iff a @brief return true iff a>b. LOGICAL FUNCTION a_greaterthan_b(a, b) - INTEGER, INTENT(IN) :: a, b + INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other. + INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other. a_greaterthan_b = A > B END FUNCTION a_greaterthan_b -!> @brief return true iff a != b +!> @brief return true iff a /= b LOGICAL FUNCTION a_noteq_b(a, b) -INTEGER, INTENT(IN) :: a, b +INTEGER, INTENT(IN) :: a !< The first of the two integer args that are to be compared to each other. +INTEGER, INTENT(IN) :: b !< The first of the two integer args that are to be compared to each other. a_noteq_b = a /= b END FUNCTION a_noteq_b !> @brief Checks if the array indices for output_fields(out_num) are outside the !! output_fields(out_num)%buffer upper and lower bounds. !! If there is an error then error message will be filled. -SUBROUTINE check_out_of_bounds_legacy(out_num, diag_field_id, err_msg) +SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID number. INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty @@ -919,12 +925,12 @@ SUBROUTINE check_out_of_bounds_legacy(out_num, diag_field_id, err_msg) err_msg = '' END IF end associate -END SUBROUTINE check_out_of_bounds_legacy +END SUBROUTINE check_out_of_bounds !> @brief Checks if the array indices for output_fields(out_num) are outside the !! output_fields(out_num)%buffer upper and lower bounds. !! If there is an error then error message will be filled. -SUBROUTINE fms_check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, err_msg) +SUBROUTINE fms_diag_check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, err_msg) REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The bounding box to check against CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message @@ -950,18 +956,18 @@ SUBROUTINE fms_check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_na ELSE err_msg = '' END IF -END SUBROUTINE fms_check_out_of_bounds_modern_r4 +END SUBROUTINE fms_diag_check_out_of_bounds_modern_r4 !> @brief Checks if the array indices for output_field buffer (ofb) are outside the !! are outside the bounding box (bounds). !! If there is an error then error message will be filled. -SUBROUTINE fms_check_out_of_bounds_modern_r8(ofb, bounds, output_name, module_name, err_msg) +SUBROUTINE fms_diag_check_out_of_bounds_modern_r8(ofb, bounds, output_name, module_name, err_msg) REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The bounding box to check against CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message - CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty + CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the CHARACTER(len=128) :: error_string1, error_string2 @@ -982,10 +988,10 @@ SUBROUTINE fms_check_out_of_bounds_modern_r8(ofb, bounds, output_name, module_na ELSE err_msg = '' END IF -END SUBROUTINE fms_check_out_of_bounds_modern_r8 +END SUBROUTINE fms_diag_check_out_of_bounds_modern_r8 -!> @brief Checks that array indecies specified in the bounding box "current_bounds" +!> @brief Checks that array indices specified in the bounding box "current_bounds" !! are identical to those in the bounding box "bounds" match exactly. The check !! occurs only when the time changed. !! If there is an error then error message will be filled. @@ -1083,7 +1089,7 @@ SUBROUTINE fms_check_bounds_are_exact_static_legacy(out_num, diag_field_id, err_ CALL fms_check_bounds_are_exact_static_modern(current_bounds, output_fields(out_num)%buff_bounds, & & output_name, module_name, err_msg) - END SUBROUTINE fms_check_bounds_are_exact_static_legacy + END SUBROUTINE fms_check_bounds_are_exact_static_legacy !> @brief Check if the array indices specified in the bounding box "current_bounds" are equal to those diff --git a/diag_manager/fms_diag_elem_weight_procs.F90 b/diag_manager/fms_diag_elem_weight_procs.F90 index 53dbf062ba..14d0d79d4c 100644 --- a/diag_manager/fms_diag_elem_weight_procs.F90 +++ b/diag_manager/fms_diag_elem_weight_procs.F90 @@ -36,7 +36,7 @@ MODULE fms_diag_elem_weight_procs_mod implicit none - !> @brief Interface for the elemental function addwf, whihc + !> @brief Interface for the elemental function addwf, which !! Calculates and returns the value given by this formula: !! returned_value = buff + (weight * field)**pow_value !> @ingroup fms_diag_elem_weight_procs_mod @@ -51,7 +51,7 @@ MODULE fms_diag_elem_weight_procs_mod !!TODO: Note that in the functions below, the case for pow_value == 2 was !! not in the original send_data_3d code and the power function was used. - !! So this case may need to be deleted is reproducability is an issue. + !! So this case may need to be deleted if reproducability is an issue. !> @brief Calculates and returns the value given by this formula: !! returned_value = buff + (weight * field)**pow_value diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index e7f257ef67..4442e021a7 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -38,8 +38,8 @@ MODULE fms_diag_fieldbuff_update_mod USE time_manager_mod, ONLY: time_type USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,fms_error_handler USE diag_data_mod, ONLY: debug_diag_manager, fms_diag_ibounds_type - USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_index_type, fms_diag_outfield_type - USE diag_util_mod, ONLY: check_out_of_bounds, update_bounds + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type + USE diag_util_mod, ONLY: fms_diag_check_out_of_bounds, update_bounds USE fms_diag_elem_weight_procs_mod, ONLY: addwf implicit none @@ -64,26 +64,26 @@ MODULE fms_diag_fieldbuff_update_mod ! module procedure fieldbuff_update_i8 end interface - !> @brief Interface fieldbuff_copy_misvals updates elements of the field output buffer with - !! with the missvalue input argument. + !> @brief Interface fieldbuff_copy_missvals updates elements of the field output buffer with + !! the missvalue input argument. !> @ingroup fms_diag_fieldbuff_update_mod - interface fieldbuff_copy_misvals + interface fieldbuff_copy_missvals !< r4 version of the interface - module procedure fieldbuff_copy_misvals_r4 + module procedure fieldbuff_copy_missvals_r4 !< r8 version of the interface - module procedure fieldbuff_copy_misvals_r8 + module procedure fieldbuff_copy_missvals_r8 !< r4 version of the interface, , where the field is 3D - module procedure fieldbuff_copy_misvals_3d_r4 + module procedure fieldbuff_copy_missvals_3d_r4 !< r8 version of the interface, , where the field is 3D - module procedure fieldbuff_copy_misvals_3d_r8 + module procedure fieldbuff_copy_missvals_3d_r8 !< i4 version of the interface - !module procedure fieldbuff_copy_misvals_i4 + !module procedure fieldbuff_copy_missvals_i4 !< i8 version of the interface - !module procedure fieldbuff_copy_misvals_i8 + !module procedure fieldbuff_copy_missvals_i8 end interface !> @brief Interface fieldbuff_copy_fieldvals updates elements of the field output buffer with - !! with copies of correspondind element values in the input field data. + !! copies of corresponding element values in the input field data. !> @ingroup fms_diag_fieldbuff_update_mod interface fieldbuff_copy_fieldvals !< r4 version of the interface diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index 3615b9f8bb..463b0827f1 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -43,7 +43,7 @@ MODULE fms_diag_outfield_mod USE diag_data_mod, only:Time_zero USE diag_data_mod, only: GLO_REG_VAL, GLO_REG_VAL_ALT, region_out_use_alt_value, VERY_LARGE_AXIS_LENGTH, coord_type USE diag_data_mod, only: fms_diag_ibounds_type, input_field_type, output_field_type - USE fms_diag_time_reduction_mod, only: time_reduction_type, time_none , time_average, time_rms + USE fms_diag_time_reduction_mod, only: fmsDiagTimeReduction_type, time_none , time_average, time_rms USE fms_diag_time_reduction_mod, only: time_max, time_min, time_sum, time_power @@ -58,11 +58,11 @@ MODULE fms_diag_outfield_mod !! !! Class fms_diag_outfield_type also contains a significant subset of the fields !! and routines of of the legacy class output_field_type - !! TODO: (MDM) This class will need further developemnt for the modern_diag effor. - !! For its development, but consider the legacy diag_util::init_output_field already - !! in place. Fields added so are uesd the the field buffer math/dupdate functions. + !! TODO: (MDM) This class will need further development for the modern_diag effort. + !! For its development, consider the legacy diag_util::init_output_field already + !! in place. Fields added so are used the the field buffer math/dmUpdate functions. !> @ingroup fms_diag_outfield_mod - TYPE fms_diag_outfield_type + TYPE fmsDiagOutfield_type CHARACTER(len=:), ALLOCATABLE :: module_name !< Module name. CHARACTER(len=:), ALLOCATABLE :: field_name !< Output field name. CHARACTER(len=:), ALLOCATABLE :: output_name !< Output name written to file. @@ -80,7 +80,7 @@ MODULE fms_diag_outfield_mod !< function call may be downstream replaced by a null pointer which !< is considered present. - TYPE(time_reduction_type) :: time_reduction !< Instance of the time_reduction_type. + TYPE(fmsDiagTimeReduction_type) :: time_reduction !< Instance of the fmsDiagTimeTeduction_type. !!TODO (Future effort? ) : a pointer for time_min and time_max comparison function !! If possible, this can reove the innermost if/then/else construct in the buffer update loops. @@ -91,7 +91,7 @@ MODULE fms_diag_outfield_mod CONTAINS procedure, public :: initialize => initialize_outfield_imp - END TYPE fms_diag_outfield_type + END TYPE fmsDiagOutfield_type !> @brief Class fms_diag_outfield_index_type which (along with class fms_diag_outfield_type) @@ -102,7 +102,8 @@ MODULE fms_diag_outfield_mod !! of this class is also to allow for a smaller call function signature for the math/buffer !! update functions. !> @ingroup fms_diag_outfield_mod - TYPE, public :: fms_diag_outfield_index_type + TYPE, public :: fmsDiagOutfieldIndex_type + PRIVATE INTEGER :: f1,f2 !< Indecies used specify 1st dim bounds of field, mask and rmask. INTEGER :: f3,f4 !< Indecies used specify 2st dim bounds of field, mask and rmask. INTEGER :: is, js, ks !< Start indecies in each spatial dim of the field_data; and @@ -113,16 +114,113 @@ MODULE fms_diag_outfield_mod INTEGER :: hj !< halo size in y direction. Same CONTAINS procedure :: initialize => initialize_outfield_index_type - END TYPE fms_diag_outfield_index_type + procedure :: get_f1 + procedure :: get_f2 + procedure :: get_f3 + procedure :: get_f4 + procedure :: get_is + procedure :: get_js + procedure :: get_ks + procedure :: get_ie + procedure :: get_je + procedure :: get_ke + procedure :: get_hi + procedure :: get_hj + + END TYPE fmsDiagOutfieldIndex_type CONTAINS - !!TODO: In the modern diag, the field_val and weight may also be of integer type, - !! and so may need to use the pre-processor. + + !> @brief Gets f1 + !! @return copy of integer memeber f1 + pure integer function get_f1 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%f1 + end function get_f1 + + !> @brief Gets f2 + !! @return copy of integer memeber f2 + pure integer function get_f2 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%f2 + end function get_f2 + + !> @brief Gets f3 + !! @return copy of integer memeber f3 + pure integer function get_f3 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%f3 + end function get_f3 + + !> @brief Gets f4 + !! @return copy of integer memeber f4 + pure integer function get_f4 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%f4 + end function get_f4 + + !> @brief Gets is + !! @return copy of integer memeber is + pure integer function get_is (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%is + end function get_is + + !> @brief Gets js + !! @return copy of integer memeber js + pure integer function get_js (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%js + end function get_js + + !> @brief Gets ks + !! @return copy of integer memeber ks + pure integer function get_ks (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%ks + end function get_ks + + + !> @brief Gets ie + !! @return copy of integer memeber ie + pure integer function get_ie (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%ie + end function get_ie + + !> @brief Gets je + !! @return copy of integer memeber je + pure integer function get_je (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%je + end function get_je + + !> @brief Gets ke + !! @return copy of integer memeber ke + pure integer function get_ke (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%ke + end function get_ke + + !> @brief Gets hi + !! @return copy of integer memeber hi + pure integer function get_hi (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%hi + end function get_hi + + !> @brief Gets hj + !! @return copy of integer memeber hj + pure integer function get_hj (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object + rslt = this%hj + end function get_hj + !> #brief initialize all the memebers of the class. SUBROUTINE initialize_outfield_index_type(this, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) - CLASS(fms_diag_outfield_index_type), INTENT(inout) :: this + CLASS(fmsDiagOutfieldIndex_type), INTENT(inout) :: this INTEGER, INTENT(in) :: is, js, ks !< Variable used to update class member of same names. INTEGER, INTENT(in) :: ie, je, ke !< Variable used to update class member of same names. INTEGER, INTENT(in) :: hi, hj !< Variable used to update class member of same names. @@ -145,16 +243,16 @@ SUBROUTINE initialize_outfield_index_type(this, is, js , ks, ie, je, ke, hi, hj, END SUBROUTINE initialize_outfield_index_type - !> @brief Update with those fields used in the legacy diag manager. + !> @brief Update the fmsDiagOutfield_type instance with those fields used in the legacy diag manager. !! Note that this is initializing from the legacy structures. !! Note that output_frequency came from file_type; SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_present, freq) - CLASS(fms_diag_outfield_type), INTENT(inout) :: this - TYPE(input_field_type), INTENT(in) :: input_field - TYPE(output_field_type), INTENT(in) :: output_field - LOGICAL, INTENT(in) :: mask_present - INTEGER, INTENT(in) :: freq - INTEGER :: time_redux + CLASS(fmsDiagOutfield_type), INTENT(inout) :: this !< An instance of the fmsDiagOutfield_type + TYPE(input_field_type), INTENT(in) :: input_field !< An instance of the input_field_type + TYPE(output_field_type), INTENT(in) :: output_field !< An instance of the output_field_type + LOGICAL, INTENT(in) :: mask_present !< Was the mask present in the call to send_data? + INTEGER, INTENT(in) :: freq !< The output frequency. + INTEGER :: time_redux !< The time reduction type integer. this%module_name = input_field%module_name this%field_name = input_field%field_name @@ -181,10 +279,10 @@ END SUBROUTINE initialize_outfield_imp !> \brief Get the time reduction from a legacy output field. - !! Note we do not place this in the time_reduction class to avoid circular dependencies. + !\note Note we do not place this in the time_reduction class to avoid circular dependencies. function get_output_field_time_reduction(ofield) result (rslt) - TYPE(output_field_type), INTENT(in) :: ofield - INTEGER :: rslt + TYPE(output_field_type), INTENT(in) :: ofield !< An instance of the output_field_type + INTEGER :: rslt !< The result integer which is the time reduction. if(ofield%time_max) then rslt = time_max elseif(ofield%time_min)then diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 index f305f55f24..7a80ffdfc5 100644 --- a/diag_manager/fms_diag_time_reduction.F90 +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -31,19 +31,16 @@ MODULE fms_diag_time_reduction_mod USE diag_data_mod, only: EVERY_TIME - !!use diag_data_mod, only: time_min, time_max, time_sum, time_rms, time_average, time_none, time_power, & - !!& time_diurnal, every_time USE fms_mod, ONLY: error_mesg, FATAL implicit none !!These parametes are the possible kinds of time reduction operations. - !!Note that sometimes one kind inplies another. !!TODO: should they be put in diag_data ? !!TODO: !!TODO: time_diurnal "not really" same kind as others, so remove? INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method - INTEGER, PARAMETER :: time_average = 1 !< The reduction method is avera + INTEGER, PARAMETER :: time_average = 1 !< The reduction method is average INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms INTEGER, PARAMETER :: time_max = 3 !< The reduction method is max INTEGER, PARAMETER :: time_min = 4 !< The reduction method is min @@ -51,18 +48,18 @@ MODULE fms_diag_time_reduction_mod INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power -!> @brief Class time_reduction_type has an encapsulation of the "Fortran enum" time +!> @brief Class fmsDiagTimeReduction_type has an encapsulation of the "Fortran enum" time !! reduction integer parameters, plus an encapsulation of the groupings of !! the time reduction types. It is inteded to provide some of the functionality !! that was coded in the legacy function diag_data.F90:init_output_fields. !! The functionality in the end is used by send_data in (EFFICIENT) do loops calling !! the weighting or math functions to update buffers. -!! the The integer parameters above are the legal time_reduction_types, +!! the The integer parameters above are the legal time reduction types, !! but they are not necessarily mutually exclusive in some contexts. !! !> @addtogroup fms_diag_time_reduction_mod - TYPE time_reduction_type - integer , private :: the_type !< The time reduction type; integer as per diag_data_mod entries. + TYPE fmsDiagTimeReduction_type + integer , private :: the_time_reduction !< The time reduction type, as an integer defined above. logical , private :: time_averaging !< Set true iff time_average, time_rms, time_power or time_diurnal is true logical , private :: time_ops !< Set true iff time_min, time_max, time_rms or time_average is true. CONTAINS @@ -77,32 +74,33 @@ MODULE fms_diag_time_reduction_mod procedure, public :: is_time_diurnal => is_time_diurnal_imp procedure, public :: is_time_power => is_time_power_imp procedure, public :: initialize - END TYPE time_reduction_type + END TYPE fmsDiagTimeReduction_type !> @brief This interface is for the class constructor. !> @addtogroup fms_diag_time_reduction_mod - interface time_reduction_type - procedure :: time_reduction_type_constructor - end interface time_reduction_type + interface fmsDiagTimeReduction_type + procedure :: fmsDiagTimeReduction_type_constructor + end interface fmsDiagTimeReduction_type CONTAINS !> @brief The class contructors. Just allocates the class and calls an initializer - function time_reduction_type_constructor(dt, out_frequency) result(time_redux) - integer, intent(in) :: dt !> The redution type (time_rms, time_power, etc) - integer, intent(in) :: out_frequency !> The output frequency. - class (time_reduction_type), allocatable :: time_redux + function fmsDiagTimeReduction_type_constructor(dt, out_frequency) result(time_redux) + integer, intent(in) :: dt !< The redution type (time_rms, time_power, etc) + integer, intent(in) :: out_frequency !< The output frequency. + class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type class + !! allocated and returned by this constructor. allocate(time_redux) call time_redux%initialize(dt, out_frequency) - end function time_reduction_type_constructor + end function fmsDiagTimeReduction_type_constructor !> @brief Initialize the object. subroutine initialize(this, dt, out_frequency) - class (time_reduction_type), intent(inout) :: this !> The time_reduction_type object - integer, intent(in) :: dt !> The redution type (time_rms, time_porer, etc) - integer, intent(in) :: out_frequency !> The output frequency. + class (fmsDiagTimeReduction_type), intent(inout) :: this !< The fmsDiagTimeReduction_type object + integer, intent(in) :: dt !< The redution type (time_rms, time_porer, etc) + integer, intent(in) :: out_frequency !< The output frequency. - this%the_type = dt + this%the_time_reduction = dt !! Set the time_averaging flag !! See legacy init_ouput_fields function, lines 1470ff @@ -113,7 +111,7 @@ subroutine initialize(this, dt, out_frequency) this%time_averaging= .false. IF((dt .NE. time_max) .AND. (dt .ne. time_min) .AND. (dt .NE. time_sum) & & .AND. (dt .NE. time_none)) THEN - CALL error_mesg('time_reduction_type: initialize', & + CALL error_mesg('fmsDiagTimeReduction_type: initialize', & & 'time_averaging=.false. but reduction type not compatible', FATAL) ENDIF END IF @@ -133,9 +131,9 @@ end subroutine initialize !> \brief Returns true if any of time_min, time_max, time_rms or time_average is true. -!! @return true if if any of time_min, time_max, time_rms or time_average is true. +!! @return true if any of time_min, time_max, time_rms or time_average is true. pure function has_time_ops_imp (this) - class (time_reduction_type), intent(in) :: this ! \brief Returns true iff time_averaging is true. !! @return true iff time_averaging is true. pure function do_time_averaging_imp (this) - class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_average - !! @return true iff the_type is time_average + !> \brief Returns true iff the_time_reduction is time_average + !! @return true iff the_time_reduction is time_average pure function is_time_average_imp (this) - class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_none - !! @return true iff the_type is time_none + !> \brief Returns true iff the_time_reduction is time_none + !! @return true iff the_time_reduction is time_none pure function is_time_none_imp (this) - class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_rms - !! @return true iff the_type is time_rms + !> \brief Returns true iff the_time_reduction is time_rms + !! @return true iff the_time_reduction is time_rms pure function is_time_rms_imp (this) - class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_max - !! @return true iff the_type is time_max + !> \brief Returns true iff the_time_reduction is time_max + !! @return true iff the_time_reduction is time_max pure function is_time_max_imp (this) - class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_min - !! @return true iff the_type is time_min + !> \brief Returns true iff the_time_reduction is time_min + !! @return true iff the_time_reduction is time_min pure function is_time_min_imp (this) - class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_sum - !! @return true iff the_type is time_sum + !> \brief Returns true iff the_time_reduction is time_sum + !! @return true iff the_time_reduction is time_sum pure function is_time_sum_imp (this) - class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_diurnal - !! @return true iff the_type is time_diurnal + !> \brief Returns true iff the_time_reduction is time_diurnal + !! @return true iff the_time_reduction is time_diurnal pure function is_time_diurnal_imp (this) - class (time_reduction_type), intent(in) :: this ! \brief Returns true iff the_type is time_power - !! @return true iff the_type is time_power + !> \brief Returns true iff the_time_reduction is time_power + !! @return true iff the_time_reduction is time_power pure function is_time_power_imp (this) - class (time_reduction_type), intent(in) :: this ! @brief This code will be used by the preprecessor to generate an implementation - !! to the module procudure for the fieldbuff_update interface. The + !! to the module procedure for the fieldbuff_update interface. The !! generated function is a wrapper calling 4D field/5D buffer version of the same. FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) result( succeded ) - TYPE(fms_diag_outfield_type), INTENT(in):: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(in) :: ofield_index_cfg ! null()!< - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null()!< - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr => null()!< - LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null()!< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null()!< Pointer to the field + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null()!< Pointer to the outfield buffer. + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr => null()!< Pointer to the outfield counter. + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null()!< Pointer to the mask. - LOGICAL :: succeded !> True iff no errors encountered. + LOGICAL :: succeded !< True iff no errors encountered. field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3),1:1, 1:size(ofb,4)) => ofb @@ -79,22 +82,25 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !> @brief This code will be used by the preprecessor to generate an implementation -!! to the module procudure for the fieldbuff_update interface. +!! to the module procedure for the fieldbuff_update interface. !! Updates elements of the running field output buffer (argument ofb) !! and counter (argument ofc) based on the input field data array (argument field_d). !! In general the formulas are : !! A) ofb(l) = ofb(l) + (weight * field(l))**pow_value !! B) ofc(l) = ofc(l) + weight -!! where l is a standing for some set of indecies in multiple dimensions. +!! where l is a standing for some set of indices in multiple dimensions. !! Note this function may set field object members active_omp_level and num_threads. +!! TODO: (MDM) revisit passing in and need of field_num_threads and field_active_omp_level !> @addtogroup fms_diag_fieldbuff_update_mod !> @{ FUNCTION FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_d, sample, & & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) result( succeded ) - TYPE(fms_diag_outfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !!where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !! where "cfg" is short for configuration FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< Output Field Buffer FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofc !< Output Field Counter @@ -113,8 +119,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL, INTENT(inout) :: issued_mask_ignore_warning INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on 3 axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on 3 axes for regional output - CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg - CHARACTER(len=256), INTENT(inout) :: err_msg_local + CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !!Possibly passed by the caller, and sent to error handler + CHARACTER(len=256), INTENT(inout) :: err_msg_local !!Possibly set by bounds checker, and sent to error handler INTEGER :: pow_value !< A copy of same variable in ofield_cfg CHARACTER(:), ALLOCATABLE :: output_name !< A copy of same variable in ofield_cfg @@ -127,18 +133,18 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL :: mask_present !< A copy of same variable in ofield_cfg LOGICAL :: missvalue_present !< A copy of same variable in ofield_cfg - !> The indecies copied directly from the ofield_index_cfg: + !< The indices copied directly from the ofield_index_cfg: INTEGER:: is, js, ks, ie, je, ke, hi, hj, f1, f2, f3, f4 - INTEGER:: ls, le !> start and end indecies for the 4th dimension. + INTEGER:: ls, le !< start and end indices for the 4th dimension. - INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations - !> Looping indecies, derived from ofield_index_cfg: + INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations + !< Looping indices, derived from ofield_index_cfg: INTEGER :: i, j, k, l, i1, j1, k1 INTEGER :: numthreads INTEGER :: active_omp_level - LOGICAL :: succeded !> True iff no errors encountered. + LOGICAL :: succeded !< True iff no errors encountered. CHARACTER(len=128):: error_string #if defined(_OPENMP) @@ -152,18 +158,18 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ksr= l_start(3) ker= l_end(3) - is = ofield_index_cfg%is - js = ofield_index_cfg%js - ks = ofield_index_cfg%ks - ie = ofield_index_cfg%ie - je = ofield_index_cfg%je - ke = ofield_index_cfg%ke - hi = ofield_index_cfg%hi - hj = ofield_index_cfg%hj - f1 = ofield_index_cfg%f1 - f2 = ofield_index_cfg%f2 - f3 = ofield_index_cfg%f3 - f4 = ofield_index_cfg%f4 + is = ofield_index_cfg%get_is() + js = ofield_index_cfg%get_js() + ks = ofield_index_cfg%get_ks() + ie = ofield_index_cfg%get_ie() + je = ofield_index_cfg%get_je() + ke = ofield_index_cfg%get_ke() + hi = ofield_index_cfg%get_hi() + hj = ofield_index_cfg%get_hj() + f1 = ofield_index_cfg%get_f1() + f2 = ofield_index_cfg%get_f2() + f3 = ofield_index_cfg%get_f3() + f4 = ofield_index_cfg%get_f4() output_name = trim(ofield_cfg%output_name) field_name = trim(ofield_cfg%field_name) @@ -203,7 +209,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & MISSVAL_PR_1_IF: IF ( missvalue_present ) THEN !!(section: mask_varian .eq. true + mask present) IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -378,7 +384,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ELSE NDCMP_RKR_1_IF IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -494,7 +500,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ELSE NDCMP_RKR_2_IF IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '') THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -643,7 +649,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ELSE NDCMP_RKR_3_IF IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -755,7 +761,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ELSE NDCMP_RKR_4_IF IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF (fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -797,31 +803,33 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !> @brief This code will be used by the preprecessor to generate an implementation - !! to the module procudure for the fieldbuff_copy_fieldvals interface. The + !! to the module procedure for the fieldbuff_copy_fieldvals interface. The !! generated function is a wrapper calling 4D field/5D buffer version of the same. FUNCTION FMS_DIAG_FBCF_3D_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & & bbounds, count_0d, mask, missvalue, & & l_start, l_end, err_msg, err_msg_local) result( succeded ) - TYPE(fms_diag_outfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !!where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !! where "cfg" is short for configuration FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! Normally the member of the buffer of same name, + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !< Normally the member of the buffer of same name, LOGICAL, CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask - FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !> buffer may be set to this value where mask is false. + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output - CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg - CHARACTER(len=256), INTENT(inout) :: err_msg_local + CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !!Possibly passed in by the caller,and sent to handler + CHARACTER(len=256), INTENT(inout) :: err_msg_local !!Possibly set by bounds checker, and sent to handler !! For pointer bounds remapping - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null() !< - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null() !< - LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null() !< + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null() !< Pointer to the field + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null() !< Pointer to the outfield buffer. + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null() !< !< Pointer to the mask. - LOGICAL :: succeded !> True iff no errors encountered. + LOGICAL :: succeded !< True iff no errors encountered. field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field(:,:,:) ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:1, 1:size(ofb,4)) => ofb @@ -836,29 +844,31 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END FUNCTION FMS_DIAG_FBCF_3D_PNAME_ !> @brief This code will be used by the preprecessor to generate an implementation -!! to the module procudure for the fieldbuff_copy_fieldvals interface. +!! to the module procedure for the fieldbuff_copy_fieldvals interface. !! The function may set or add to the output field buffer (argument ofb) with the input !! field data array (argument field) FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & & bbounds, count_0d, mask, missvalue, & & l_start, l_end, err_msg, err_msg_local) result( succeded ) - TYPE(fms_diag_outfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !! where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !!where "cfg" is short for configuration FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< The Output Field Buffer TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds - FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !> Normally the member of the buffer of same name, + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !< Normally the member of the buffer of same name, LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask - FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !> buffer may be set to this value where mask is false. + FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output - CHARACTER(len=*), INTENT(inout), OPTIONAL :: err_msg - CHARACTER(len=256), INTENT(inout) :: err_msg_local - LOGICAL :: succeded !> Return true iff errors are not encounterd. + CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !!Possibly passed in by the caller, and sent to handler + CHARACTER(len=256), INTENT(inout) :: err_msg_local !!Possibly set by bounds checker, and sent to handler + LOGICAL :: succeded !< Return true iff errors are not encounterd. !! !! - !> The indecies copied directly from the ofield_index_cfg + !< The indices copied directly from the ofield_index_cfg INTEGER :: is, js, ks, ie, je, ke, hi, hj, f1, f2, f3, f4 CHARACTER(:), ALLOCATABLE :: output_name !< A copy of same variable in ofield_cfg @@ -868,8 +878,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, LOGICAL :: mask_present !< A copy of same variable in ofield_cfg LOGICAL :: missvalue_present !< A copy of same variable in ofield_cfg - INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations - !> Looping indecies, derived from ofield_index_cfg: + INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations + !< Looping indices, derived from ofield_index_cfg: INTEGER :: i, j, k, i1, j1, k1 @@ -878,18 +888,18 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, ksr= l_start(3) ker= l_end(3) - is = ofield_index_cfg%is - js = ofield_index_cfg%js - ks = ofield_index_cfg%ks - ie = ofield_index_cfg%ie - je = ofield_index_cfg%je - ke = ofield_index_cfg%ke - hi = ofield_index_cfg%hi - hj = ofield_index_cfg%hj - f1 = ofield_index_cfg%f1 - f2 = ofield_index_cfg%f2 - f3 = ofield_index_cfg%f3 - f4 = ofield_index_cfg%f4 + is = ofield_index_cfg%get_is() + js = ofield_index_cfg%get_js() + ks = ofield_index_cfg%get_ks() + ie = ofield_index_cfg%get_ie() + je = ofield_index_cfg%get_je() + ke = ofield_index_cfg%get_ke() + hi = ofield_index_cfg%get_hi() + hj = ofield_index_cfg%get_hj() + f1 = ofield_index_cfg%get_f1() + f2 = ofield_index_cfg%get_f2() + f3 = ofield_index_cfg%get_f3() + f4 = ofield_index_cfg%get_f4() time_max = ofield_cfg%time_reduction%is_time_max() time_min = ofield_cfg%time_reduction%is_time_min() @@ -932,7 +942,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -970,7 +980,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1013,7 +1023,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1050,7 +1060,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1093,7 +1103,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1128,7 +1138,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1162,7 +1172,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, ELSE IF ( debug_diag_manager ) THEN CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) - CALL check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) + CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN succeded = .FALSE. @@ -1224,24 +1234,26 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, !> @brief This code will be used by the preprecessor to generate an implementation - !! to the module procudure for the fieldbuff_copy_misvals interface. The + !! to the module procedure for the fieldbuff_copy_misvals interface. The !! generated function is a wrapper calling 4D field/5D buffer version of the same. SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ (ofield_cfg, ofield_index_cfg, ofb, sample, & & l_start, l_end, rmask, rmask_thresh, missvalue) - TYPE(fms_diag_outfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS,DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! null() !< - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: rmask_ptr => null() !< + !! These below are used in pointer bounds remapping + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null() !< Pointer to the output field + !! buffer - used in remapping + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: rmask_ptr => null() !< Pointer to the rmask - used + !! in remapping ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:1, 1:size(ofb,4)) => ofb rmask_ptr(1:size(rmask,1),1:size(rmask,2),1:size(rmask,3),1:1) => rmask @@ -1252,15 +1264,17 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, !> @brief This code will be used by the preprecessor to generate an implementation - !! to the module procudure for the fieldbuff_copy_misvals interface. + !! to the module procedure for the fieldbuff_copy_misvals interface. !! The function updates where appropriate and depending on the rmask argument, !! elements of the running field output buffer (argument buffer) with value missvalue. !! NOTE: It appears these OFB updates were introcuded by EMC MM into the tail end of the !! legacy send_data_3d. SUBROUTINE FMS_DIAG_FBCM_PNAME_ (ofield_cfg, ofield_index_cfg, buffer, sample, & & l_start, l_end, rmask, rmask_thresh, missvalue) - TYPE(fms_diag_outfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object - TYPE(fms_diag_outfield_index_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object + TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The fmsDiagOutfield_type object, + !! where "cfg" is short for configuration + TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The fmsDiagOutfieldIndex_type object, + !!where "cfg" is short for configuration FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout), DIMENSION(:,:,:,:,:) :: buffer !< the buffer to update INTEGER, INTENT(in) :: sample !< index along the diurnal time axis INTEGER, INTENT(in), DIMENSION(3):: l_start !< local start indices on 3 axes for regional output @@ -1269,21 +1283,23 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: rmask_thresh !< Updates where rmask < rmask_thresh FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< Value used to update the buffer. + !< Looping indices copied from corresponding one in ofield_index_cfg info: INTEGER :: is, js, ks, ie, je, ke, hi, hj + !< Floags copied from corresponding one in ofield_cfg info: LOGICAL :: need_compute LOGICAL :: reduced_k_range - INTEGER :: ksr, ker !> Loop indeccies used in reduced_k_range calculations - !> Looping indecies, derived from ofield_index_cfg info: + INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations + !< Looping indices, derived from ofield_index_cfg info: INTEGER :: i, j, k, i1, j1, k1 - is = ofield_index_cfg%is - js = ofield_index_cfg%js - ks = ofield_index_cfg%ks - ie = ofield_index_cfg%ie - je = ofield_index_cfg%je - ke = ofield_index_cfg%ke - hi = ofield_index_cfg%hi - hj = ofield_index_cfg%hj + is = ofield_index_cfg%get_is() + js = ofield_index_cfg%get_js() + ks = ofield_index_cfg%get_ks() + ie = ofield_index_cfg%get_ie() + je = ofield_index_cfg%get_je() + ke = ofield_index_cfg%get_ke() + hi = ofield_index_cfg%get_hi() + hj = ofield_index_cfg%get_hj() reduced_k_range = ofield_cfg%reduced_k_range need_compute = ofield_cfg%need_compute diff --git a/diag_manager/include/fms_diag_fieldbuff_update.inc b/diag_manager/include/fms_diag_fieldbuff_update.inc index 7bc3432ad0..b45071d307 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.inc +++ b/diag_manager/include/fms_diag_fieldbuff_update.inc @@ -9,9 +9,9 @@ #undef FMS_DIAG_FBCF_3D_PNAME_ #define FMS_DIAG_FBCF_3D_PNAME_ fieldbuff_copy_fieldvals_3d_r4 #undef FMS_DIAG_FBCM_PNAME_ -#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_r4 +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_missvals_r4 #undef FMS_DIAG_FBCM_3D_PNAME_ -#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_misvals_3d_r4 +#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_missvals_3d_r4 #include #undef FMS_DIAG_FBU_DATA_TYPE_ @@ -25,7 +25,7 @@ #undef FMS_DIAG_FBCF_3D_PNAME_ #define FMS_DIAG_FBCF_3D_PNAME_ fieldbuff_copy_fieldvals_3d_r8 #undef FMS_DIAG_FBCM_PNAME_ -#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_misvals_r8 +#define FMS_DIAG_FBCM_PNAME_ fieldbuff_copy_missvals_r8 #undef FMS_DIAG_FBCM_3D_PNAME_ -#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_misvals_3d_r8 +#define FMS_DIAG_FBCM_3D_PNAME_ fieldbuff_copy_missvals_3d_r8 #include diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index f91e3c929a..a87099c6dc 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -25,10 +25,10 @@ program test_diag_update_buffer use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated use fms_mod, ONLY: fms_init, fms_end, error_mesg, FATAL,NOTE use diag_data_mod, ONLY: fms_diag_ibounds_type, VERY_LARGE_AXIS_LENGTH - USE fms_diag_outfield_mod, ONLY: fms_diag_outfield_type, fms_diag_outfield_index_type - USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_misvals, & + USE fms_diag_outfield_mod, ONLY: fmsDiagOutfield_type, fmsDiagOutfieldIndex_type + USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & & fieldbuff_copy_fieldvals - USE fms_diag_time_reduction_mod, ONLY: time_reduction_type, time_average, time_rms + USE fms_diag_time_reduction_mod, ONLY: fmsDiagTimeReduction_type, time_average, time_rms implicit none @@ -41,10 +41,10 @@ program test_diag_update_buffer INTEGER, ALLOCATABLE, dimension(:) :: num_elements END TYPE diag_test_buffer_type - integer,parameter :: SZ=10 ! to be allocated of rype data (e.g. r4. i8) + integer,parameter :: SZ=10 !< Field data this size in all spatiall dims. + integer,parameter :: SL=2 !< Field data this size in 4th dim + integer,parameter :: NDI=1 !< Number of diurnal elemes + CLASS(*), ALLOCATABLE :: r4_datapoint, i8_datapoint !< to be allocated of rype data (e.g. r4. i8) !! to be used thought. TYPE(fms_diag_ibounds_type) :: buff_bounds @@ -92,7 +92,7 @@ program test_diag_update_buffer LOGICAL :: mask_variant INTEGER :: num_elems LOGICAL :: reduced_k_range - TYPE(time_reduction_type), allocatable :: time_reduction !!Replaces LOGICAL::time_rms,time_max,time_min... + TYPE(fmsDiagTimeReduction_type), allocatable :: time_reduction !!Replaces LOGICAL::time_rms,time_max,time_min... INTEGER:: diag_field_id INTEGER:: sample !!diurnal_index @@ -107,8 +107,8 @@ program test_diag_update_buffer LOGICAL :: missvalue_present = .false. - TYPE(fms_diag_outfield_type), ALLOCATABLE :: ofield_cfg - TYPE(fms_diag_outfield_index_type), ALLOCATABLE :: ofield_index_cfg + TYPE(fmsDiagOutfield_type), ALLOCATABLE :: ofield_cfg + TYPE(fmsDiagOutfieldIndex_type), ALLOCATABLE :: ofield_index_cfg call fms_init @@ -262,7 +262,7 @@ program test_diag_update_buffer subroutine init_ofield_cfg( of_cfg, module_name, field_name, output_name, & & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & & time_reduction_type,output_freq) - type(fms_diag_outfield_type) :: of_cfg + type(fmsDiagOutfield_type) :: of_cfg CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fms_diag_outfield_type CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fms_diag_outfield_type CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fms_diag_outfield_type @@ -289,7 +289,7 @@ end subroutine init_ofield_cfg !> @brief Initialized an fms_diag_outfield_index_type by calling member funtion of !! fms_diag_outfield_index_type input object. SUBROUTINE init_ofield_index_cfg(idx_cfg, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) - type(fms_diag_outfield_index_type), INTENT(inout) :: idx_cfg !< The object to initialize. + type(fmsDiagOutfieldIndex_type), INTENT(inout) :: idx_cfg !< The object to initialize. INTEGER, INTENT(in) :: is, js, ks !< Var with same name in fms_diag_outfield_index_type INTEGER, INTENT(in) :: ie, je, ke !< Var with same name in fms_diag_outfield_index_type INTEGER, INTENT(in) :: hi, hj !< Var with same name in fms_diag_outfield_index_type @@ -325,11 +325,11 @@ END SUBROUTINE init_field_values !> @brief Init to zero the buffer, counter , an SUBROUTINE init_buff_values_1 (buffer, counter, count_0d, num_elems) - CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: buffer - CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: counter - CLASS(*), DIMENSION(:), INTENT(INOUT) :: count_0d - INTEGER, DIMENSION(:), INTENT(INOUT) :: num_elems - INTEGER, PARAMETER :: sample = 1 + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: buffer !< The actual buffer array of the buffer class. + CLASS(*), DIMENSION(:,:,:,:,:), INTENT(INOUT) :: counter !< The actual buffer array of the buffer class. + CLASS(*), DIMENSION(:), INTENT(INOUT) :: count_0d !< A counter used in time averaging. + INTEGER, DIMENSION(:), INTENT(INOUT) :: num_elems !< A counter used in time averaging. + INTEGER, PARAMETER :: sample = 1 !< The diurnal sample. SELECT TYPE ( buffer) TYPE IS (real(kind=r4_kind)) @@ -462,8 +462,8 @@ end subroutine check_results_2 !> @brief Calculate the unique index into a 4D array given the first four indecies !! i,j,k,l and the with in the fist three dimensions. pure integer function get_array_index_from_4D(i,j,k, l, NX,NY,NZ) - INTEGER, INTENT(IN) :: i, j, k, l !> The three spatial dimentsions plus another - INTEGER, INTENT(IN) :: NX, NY, NZ !> The size of the spatial dimentions. + INTEGER, INTENT(IN) :: i, j, k, l !< The three spatial dimentsions plus another + INTEGER, INTENT(IN) :: NX, NY, NZ !< The size of the spatial dimentions. get_array_index_from_4D = (l-1)* (NX * NY * NZ) + (k-1) * NX * NY + (j-1) * NX + i end function get_array_index_from_4D @@ -493,10 +493,10 @@ END subroutine allocate_input_data_and_ptrs subroutine allocate_buffer_obj( data_point, bo, NX,NY,NZ, NL, NDI) TYPE(diag_test_buffer_type), INTENT(inout), allocatable :: bo - CLASS(*), INTENT(in) :: data_point !> Sample point allocated to the type being tested. - INTEGER, INTENT(IN) :: NX, NY, NZ !> The three spatial dimensions. - INTEGER, INTENT(IN) :: NL !> Size of the 4th dimentions - INTEGER, INTENT(IN) :: NDI !> Diurnal axis length, + CLASS(*), INTENT(in) :: data_point !< Sample point allocated to the type being tested. + INTEGER, INTENT(IN) :: NX, NY, NZ !< The three spatial dimensions. + INTEGER, INTENT(IN) :: NL !< Size of the 4th dimentions + INTEGER, INTENT(IN) :: NDI !< Diurnal axis length, allocate (bo) select type (data_point) type is (integer(kind=i8_kind)) From beebd469f7bf1fa17ef07910e4416428fa32b9f2 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Thu, 9 Feb 2023 11:44:57 -0500 Subject: [PATCH 24/37] Addresses more items from the review. --- diag_manager/fms_diag_fieldbuff_update.F90 | 1 + diag_manager/fms_diag_outfield.F90 | 595 ++++++++++-------- diag_manager/fms_diag_time_reduction.F90 | 51 +- .../include/fms_diag_fieldbuff_update.fh | 55 +- 4 files changed, 407 insertions(+), 295 deletions(-) diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index 4442e021a7..37389a743a 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -40,6 +40,7 @@ MODULE fms_diag_fieldbuff_update_mod USE diag_data_mod, ONLY: debug_diag_manager, fms_diag_ibounds_type USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type USE diag_util_mod, ONLY: fms_diag_check_out_of_bounds, update_bounds + USE fms_diag_time_reduction_mod, ONLY: fmsDiagTimeReduction_type USE fms_diag_elem_weight_procs_mod, ONLY: addwf implicit none diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index 463b0827f1..33562c0c58 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -34,274 +34,379 @@ !> @addtogroup fms_diag_outfield_mod !> @{ MODULE fms_diag_outfield_mod - USE platform_mod - USE mpp_mod, only :FATAL, WARNING - USE fms_mod, only :lowercase, uppercase, error_mesg, fms_error_handler - - - !! TODO: these might need removal or replacement - USE diag_data_mod, only:Time_zero - USE diag_data_mod, only: GLO_REG_VAL, GLO_REG_VAL_ALT, region_out_use_alt_value, VERY_LARGE_AXIS_LENGTH, coord_type - USE diag_data_mod, only: fms_diag_ibounds_type, input_field_type, output_field_type - USE fms_diag_time_reduction_mod, only: fmsDiagTimeReduction_type, time_none , time_average, time_rms - USE fms_diag_time_reduction_mod, only: time_max, time_min, time_sum, time_power - - - - implicit none - - !> @brief Class fms_diag_outfield_type (along with class ms_diag_outfield_index_type ) - !! contain information used in updating the output buffers by the diag_manager - !! send_data routines. In some sense they can be seen as encapsulating related - !! information in a convenient way (e.g. to pass to functions and for do loop - !! controls. - !! - !! Class fms_diag_outfield_type also contains a significant subset of the fields - !! and routines of of the legacy class output_field_type - !! TODO: (MDM) This class will need further development for the modern_diag effort. - !! For its development, consider the legacy diag_util::init_output_field already - !! in place. Fields added so are used the the field buffer math/dmUpdate functions. - !> @ingroup fms_diag_outfield_mod - TYPE fmsDiagOutfield_type - CHARACTER(len=:), ALLOCATABLE :: module_name !< Module name. - CHARACTER(len=:), ALLOCATABLE :: field_name !< Output field name. - CHARACTER(len=:), ALLOCATABLE :: output_name !< Output name written to file. - CHARACTER(len=:), ALLOCATABLE :: output_file !< File where field should be written. - - !!Major outer loop controls in send_data functions. - INTEGER :: pow_value !< Power value for rms or pow(x) calculations - LOGICAL :: phys_window !< TODO: Rename? OMP subsetted data, See output_fields - LOGICAL :: need_compute !< True iff is local_output and current PE take part in send_data. - LOGICAL :: reduced_k_range !< If true, the local start and end indecies are used in k (i.e. 3rd) dim. - LOGICAL :: missvalue_present !< - LOGICAL :: mask_variant - LOGICAL :: mask_present !< True iff mars arguemnt is present in user-facing send function call. - !< Note this field exist since the actual mask argument in the send - !< function call may be downstream replaced by a null pointer which - !< is considered present. - - TYPE(fmsDiagTimeReduction_type) :: time_reduction !< Instance of the fmsDiagTimeTeduction_type. - - !!TODO (Future effort? ) : a pointer for time_min and time_max comparison function - !! If possible, this can reove the innermost if/then/else construct in the buffer update loops. - !! min_max_f_ptr => (should point to < or > operators) - - !! gcc error: Interface ‘addwf’ at (1) must be explicit - ! procedure (addwf), pointer, nopass :: f_ptr => null () !!A pointer to the field weighing procedure - - CONTAINS - procedure, public :: initialize => initialize_outfield_imp - END TYPE fmsDiagOutfield_type - - - !> @brief Class fms_diag_outfield_index_type which (along with class fms_diag_outfield_type) - !! encapsulate related information used in updating the output buffers by the diag_manager - !! send_data routines. This class in particular focuses on do loop index controls or settings. - !! Note that the index names in this class should be indentical to the names used in the - !! diag_manager send_data functions and in the "math" buffer update functions. The purpose - !! of this class is also to allow for a smaller call function signature for the math/buffer - !! update functions. - !> @ingroup fms_diag_outfield_mod - TYPE, public :: fmsDiagOutfieldIndex_type - PRIVATE - INTEGER :: f1,f2 !< Indecies used specify 1st dim bounds of field, mask and rmask. - INTEGER :: f3,f4 !< Indecies used specify 2st dim bounds of field, mask and rmask. - INTEGER :: is, js, ks !< Start indecies in each spatial dim of the field_data; and - !! may be user provided in send_data - Integer :: ie, je, ke !< End indecies in each spatial dim of the field_data; and - !! may be user provided in send_data - INTEGER :: hi !< halo size in x direction. Same name as in send_data - INTEGER :: hj !< halo size in y direction. Same + USE platform_mod + USE mpp_mod, only :FATAL, WARNING + USE fms_mod, only :lowercase, uppercase, error_mesg, fms_error_handler + + + !! TODO: these might need removal or replacement + USE diag_data_mod, only:Time_zero + USE diag_data_mod, only: GLO_REG_VAL, GLO_REG_VAL_ALT, region_out_use_alt_value, VERY_LARGE_AXIS_LENGTH, coord_type + USE diag_data_mod, only: fms_diag_ibounds_type, input_field_type, output_field_type + USE fms_diag_time_reduction_mod, only: fmsDiagTimeReduction_type, time_none , time_average, time_rms + USE fms_diag_time_reduction_mod, only: time_max, time_min, time_sum, time_power + + + + implicit none + + !> @brief Class fms_diag_outfield_type (along with class ms_diag_outfield_index_type ) + !! contain information used in updating the output buffers by the diag_manager + !! send_data routines. In some sense they can be seen as encapsulating related + !! information in a convenient way (e.g. to pass to functions and for do loop + !! controls. + !! + !! Class fms_diag_outfield_type also contains a significant subset of the fields + !! and routines of of the legacy class output_field_type + !! TODO: (MDM) This class will need further development for the modern_diag effort. + !! For its development, consider the legacy diag_util::init_output_field already + !! in place. Fields added so are used the the field buffer math/dmUpdate functions. + !> @ingroup fms_diag_outfield_mod + TYPE, public :: fmsDiagOutfield_type + PRIVATE + CHARACTER(len=:), ALLOCATABLE :: module_name !< Module name. + CHARACTER(len=:), ALLOCATABLE :: field_name !< Output field name. + CHARACTER(len=:), ALLOCATABLE :: output_name !< Output name written to file. + CHARACTER(len=:), ALLOCATABLE :: output_file !< File where field should be written. + + !!Major outer loop controls in send_data functions. + INTEGER :: pow_value !< Power value for rms or pow(x) calculations + LOGICAL :: phys_window !< TODO: Rename? OMP subsetted data, See output_fields + LOGICAL :: need_compute !< True iff is local_output and current PE take part in send_data. + LOGICAL :: reduced_k_range !< If true, the local start and end indecies are used in k (i.e. 3rd) dim. + LOGICAL :: missvalue_present !< + LOGICAL :: mask_variant + LOGICAL :: mask_present !< True iff mars arguemnt is present in user-facing send function call. + !< Note this field exist since the actual mask argument in the send + !< function call may be downstream replaced by a null pointer which + !< is considered present. + + TYPE(fmsDiagTimeReduction_type) :: time_reduction !< Instance of the fmsDiagTimeTeduction_type. + + !!TODO (Future effort? ) : a pointer for time_min and time_max comparison function + !! If possible, this can reove the innermost if/then/else construct in the buffer update loops. + !! min_max_f_ptr => (should point to < or > operators) + + !! gcc error: Interface ‘addwf’ at (1) must be explicit + ! procedure (addwf), pointer, nopass :: f_ptr => null () !!A pointer to the field weighing procedure + + CONTAINS + procedure :: get_module_name + procedure :: get_field_name + procedure :: get_output_name + procedure :: get_output_file + procedure :: get_pow_value + procedure :: get_phys_window + procedure :: get_need_compute + procedure :: get_reduced_k_range + procedure :: get_missvalue_present + procedure :: get_mask_variant + procedure :: get_mask_present + procedure :: get_time_reduction + procedure, public :: initialize => initialize_outfield_imp + + END TYPE fmsDiagOutfield_type + + !> @brief Class fms_diag_outfield_index_type which (along with class fms_diag_outfield_type) + !! encapsulate related information used in updating the output buffers by the diag_manager + !! send_data routines. This class in particular focuses on do loop index controls or settings. + !! Note that the index names in this class should be indentical to the names used in the + !! diag_manager send_data functions and in the "math" buffer update functions. The purpose + !! of this class is also to allow for a smaller call function signature for the math/buffer + !! update functions. + !> @ingroup fms_diag_outfield_mod + TYPE, public :: fmsDiagOutfieldIndex_type + PRIVATE + INTEGER :: f1,f2 !< Indecies used specify 1st dim bounds of field, mask and rmask. + INTEGER :: f3,f4 !< Indecies used specify 2st dim bounds of field, mask and rmask. + INTEGER :: is, js, ks !< Start indecies in each spatial dim of the field_data; and + !! may be user provided in send_data + Integer :: ie, je, ke !< End indecies in each spatial dim of the field_data; and + !! may be user provided in send_data + INTEGER :: hi !< halo size in x direction. Same name as in send_data + INTEGER :: hj !< halo size in y direction. Same CONTAINS - procedure :: initialize => initialize_outfield_index_type - procedure :: get_f1 - procedure :: get_f2 - procedure :: get_f3 - procedure :: get_f4 - procedure :: get_is - procedure :: get_js - procedure :: get_ks - procedure :: get_ie - procedure :: get_je - procedure :: get_ke - procedure :: get_hi - procedure :: get_hj - - END TYPE fmsDiagOutfieldIndex_type + procedure :: initialize => initialize_outfield_index_type + procedure :: get_f1 + procedure :: get_f2 + procedure :: get_f3 + procedure :: get_f4 + procedure :: get_is + procedure :: get_js + procedure :: get_ks + procedure :: get_ie + procedure :: get_je + procedure :: get_ke + procedure :: get_hi + procedure :: get_hj + + END TYPE fmsDiagOutfieldIndex_type CONTAINS + !> @brief Gets module_name + !! @return copy of the module_name character array + pure function get_module_name (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%module_name + end function get_module_name + + !> @brief Gets field_name + !! @return copy of the field_name character array + pure function get_field_name (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%field_name + end function get_field_name + + !> @brief Gets output_name + !! @return copy of the output_name character array + pure function get_output_name (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%output_name + end function get_output_name + + !> @brief Gets output_file + !! @return copy of the output_file character array + pure function get_output_file (this) & + result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + character(len=:), allocatable :: rslt + rslt = this%output_file + end function get_output_file + + !> @brief Gets pow_value + !! @return copy of integer member pow_value + pure integer function get_pow_value (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%pow_value + end function get_pow_value + + !> @brief Gets phys_window + !! @return copy of integer member phys_window + pure logical function get_phys_window (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%phys_window + end function get_phys_window + + !> @brief Gets need_compute + !! @return copy of integer member need_compute + pure logical function get_need_compute (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%need_compute + end function get_need_compute + + !> @brief Gets reduced_k_range + !! @return copy of integer member reduced_k_range + pure logical function get_reduced_k_range (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%reduced_k_range + end function get_reduced_k_range + + !> @brief Gets missvalue_present + !! @return copy of integer member missvalue_present + pure logical function get_missvalue_present (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%missvalue_present + end function get_missvalue_present + + !> @brief Gets mask_variant + !! @return copy of integer member mask_variant + pure logical function get_mask_variant (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%mask_variant + end function get_mask_variant + + !> @brief Gets mask_present + !! @return copy of integer member mask_present + pure logical function get_mask_present (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< The fmsDiagOutfield_type object + rslt = this%mask_present + end function get_mask_present + + !> @brief Gets the time_reduction object + !! @return copy of the memeber object time_reduction + function get_time_reduction (this) result(rslt) + class (fmsDiagOutfield_type), intent(in) :: this !< diag object + TYPE(fmsDiagTimeReduction_type), allocatable :: rslt + allocate( rslt ) + call rslt%copy(this%time_reduction) + end function get_time_reduction + !> @brief Gets f1 - !! @return copy of integer memeber f1 - pure integer function get_f1 (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%f1 - end function get_f1 - - !> @brief Gets f2 - !! @return copy of integer memeber f2 - pure integer function get_f2 (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%f2 - end function get_f2 - - !> @brief Gets f3 - !! @return copy of integer memeber f3 - pure integer function get_f3 (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%f3 - end function get_f3 + !! @return copy of integer member f1 + pure integer function get_f1 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f1 + end function get_f1 + + !> @brief Gets f2 + !! @return copy of integer member f2 + pure integer function get_f2 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f2 + end function get_f2 + + !> @brief Gets f3 + !! @return copy of integer member f3 + pure integer function get_f3 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f3 + end function get_f3 !> @brief Gets f4 - !! @return copy of integer memeber f4 - pure integer function get_f4 (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%f4 - end function get_f4 - - !> @brief Gets is - !! @return copy of integer memeber is - pure integer function get_is (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%is - end function get_is - - !> @brief Gets js - !! @return copy of integer memeber js - pure integer function get_js (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%js - end function get_js - - !> @brief Gets ks - !! @return copy of integer memeber ks - pure integer function get_ks (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%ks - end function get_ks - + !! @return copy of integer member f4 + pure integer function get_f4 (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%f4 + end function get_f4 + + !> @brief Gets is + !! @return copy of integer member is + pure integer function get_is (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%is + end function get_is + + !> @brief Gets js + !! @return copy of integer member js + pure integer function get_js (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%js + end function get_js + + !> @brief Gets ks + !! @return copy of integer member ks + pure integer function get_ks (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%ks + end function get_ks !> @brief Gets ie - !! @return copy of integer memeber ie - pure integer function get_ie (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%ie - end function get_ie + !! @return copy of integer member ie + pure integer function get_ie (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%ie + end function get_ie !> @brief Gets je - !! @return copy of integer memeber je - pure integer function get_je (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%je - end function get_je + !! @return copy of integer member je + pure integer function get_je (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%je + end function get_je !> @brief Gets ke - !! @return copy of integer memeber ke - pure integer function get_ke (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%ke - end function get_ke - - !> @brief Gets hi - !! @return copy of integer memeber hi - pure integer function get_hi (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%hi - end function get_hi - - !> @brief Gets hj - !! @return copy of integer memeber hj - pure integer function get_hj (this) result(rslt) - class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The index object - rslt = this%hj - end function get_hj - - - -!> #brief initialize all the memebers of the class. - SUBROUTINE initialize_outfield_index_type(this, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) - CLASS(fmsDiagOutfieldIndex_type), INTENT(inout) :: this - INTEGER, INTENT(in) :: is, js, ks !< Variable used to update class member of same names. - INTEGER, INTENT(in) :: ie, je, ke !< Variable used to update class member of same names. - INTEGER, INTENT(in) :: hi, hj !< Variable used to update class member of same names. - INTEGER, INTENT(in) :: f1, f2, f3, f4 !< Variable used to update class member of same names. - - this%is = is - this%js = js - this%ks = ks - this%ie = ie - this%je = je - this%ke = ke - - this%hi = hi - this%hj = hj - - this%f1 = f1 - this%f2 = f2 - this%f3 = f3 - this%f4 = f4 - END SUBROUTINE initialize_outfield_index_type - - - !> @brief Update the fmsDiagOutfield_type instance with those fields used in the legacy diag manager. + !! @return copy of integer member ke + pure integer function get_ke (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%ke + end function get_ke + + !> @brief Gets hi + !! @return copy of integer member hi + pure integer function get_hi (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%hi + end function get_hi + + !> @brief Gets hj + !! @return copy of integer member hj + pure integer function get_hj (this) result(rslt) + class (fmsDiagOutfieldIndex_type), intent(in) :: this !< The fmsDiagOutfieldIndex_type object + rslt = this%hj + end function get_hj + + + !> #brief initialize all the members of the class. + SUBROUTINE initialize_outfield_index_type(this, is, js , ks, ie, je, ke, hi, hj, f1, f2, f3, f4) + CLASS(fmsDiagOutfieldIndex_type), INTENT(inout) :: this + INTEGER, INTENT(in) :: is, js, ks !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: ie, je, ke !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: hi, hj !< Variable used to update class member of same names. + INTEGER, INTENT(in) :: f1, f2, f3, f4 !< Variable used to update class member of same names. + + this%is = is + this%js = js + this%ks = ks + this%ie = ie + this%je = je + this%ke = ke + + this%hi = hi + this%hj = hj + + this%f1 = f1 + this%f2 = f2 + this%f3 = f3 + this%f4 = f4 + END SUBROUTINE initialize_outfield_index_type + + + !> @brief Update the fmsDiagOutfield_type instance with those fields used in the legacy diag manager. !! Note that this is initializing from the legacy structures. - !! Note that output_frequency came from file_type; - SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_present, freq) - CLASS(fmsDiagOutfield_type), INTENT(inout) :: this !< An instance of the fmsDiagOutfield_type - TYPE(input_field_type), INTENT(in) :: input_field !< An instance of the input_field_type - TYPE(output_field_type), INTENT(in) :: output_field !< An instance of the output_field_type - LOGICAL, INTENT(in) :: mask_present !< Was the mask present in the call to send_data? - INTEGER, INTENT(in) :: freq !< The output frequency. - INTEGER :: time_redux !< The time reduction type integer. - - this%module_name = input_field%module_name - this%field_name = input_field%field_name - this%output_name = output_field%output_name - - this%pow_value = output_field%pow_value - this%phys_window = output_field%phys_window - this%need_compute = output_field%need_compute - this%reduced_k_range = output_field%reduced_k_range - this%mask_variant = input_field%mask_variant - !!Note: in legacy diag manager, presence of missing value vs presence of mask - !! is determined in different ways (diag table vs send function call) - this%missvalue_present = input_field%missing_value_present - this%mask_present = mask_present - - time_redux = get_output_field_time_reduction (output_field) - call this%time_reduction%initialize( time_redux , freq) - - !!TODO: the time_min and time_max buffer update code is almost the exact same src code, except - !! for the compariosn function. Simplify code and set comparison function: - !!TODO: If possible add to the power function. See issue with pointers and elemental functions - - END SUBROUTINE initialize_outfield_imp - - - !> \brief Get the time reduction from a legacy output field. - !\note Note we do not place this in the time_reduction class to avoid circular dependencies. - function get_output_field_time_reduction(ofield) result (rslt) + !! Note that output_frequency came from file_type; + SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_present, freq) + CLASS(fmsDiagOutfield_type), INTENT(inout) :: this !< An instance of the fmsDiagOutfield_type + TYPE(input_field_type), INTENT(in) :: input_field !< An instance of the input_field_type + TYPE(output_field_type), INTENT(in) :: output_field !< An instance of the output_field_type + LOGICAL, INTENT(in) :: mask_present !< Was the mask present in the call to send_data? + INTEGER, INTENT(in) :: freq !< The output frequency. + INTEGER :: time_redux !< The time reduction type integer. + + this%module_name = input_field%module_name + this%field_name = input_field%field_name + this%output_name = output_field%output_name + + this%pow_value = output_field%pow_value + this%phys_window = output_field%phys_window + this%need_compute = output_field%need_compute + this%reduced_k_range = output_field%reduced_k_range + this%mask_variant = input_field%mask_variant + !!Note: in legacy diag manager, presence of missing value vs presence of mask + !! is determined in different ways (diag table vs send function call) + this%missvalue_present = input_field%missing_value_present + this%mask_present = mask_present + + time_redux = get_output_field_time_reduction (output_field) + call this%time_reduction%initialize( time_redux , freq) + + !!TODO: the time_min and time_max buffer update code is almost the exact same src code, except + !! for the compariosn function. Simplify code and set comparison function: + !!TODO: If possible add to the power function. See issue with pointers and elemental functions + + END SUBROUTINE initialize_outfield_imp + + + !> \brief Get the time reduction from a legacy output field. + !\note Note we do not place this in the time_reduction class to avoid circular dependencies. + function get_output_field_time_reduction(ofield) result (rslt) TYPE(output_field_type), INTENT(in) :: ofield !< An instance of the output_field_type INTEGER :: rslt !< The result integer which is the time reduction. if(ofield%time_max) then - rslt = time_max + rslt = time_max elseif(ofield%time_min)then - rslt = time_min + rslt = time_min else if (ofield%time_sum) then - rslt = time_sum + rslt = time_sum else if (ofield%time_rms) then - rslt = time_rms + rslt = time_rms else if (ofield%time_average) then - rslt = time_average + rslt = time_average else - rslt = time_none - !if(.NOT. ofield%static) then - !!TODO: Set error to FATAL. When legacy diag_manager is removed? - ! CALL error_mesg('fms_diag_outfield:get_output_field_time_reduction', & - ! & 'result is time_none but out_field%static is not true', WARNING) - !end if + rslt = time_none + !if(.NOT. ofield%static) then + !!TODO: Set error to FATAL. When legacy diag_manager is removed? + ! CALL error_mesg('fms_diag_outfield:get_output_field_time_reduction', & + ! & 'result is time_none but out_field%static is not true', WARNING) + !end if endif - end function get_output_field_time_reduction + end function get_output_field_time_reduction END MODULE fms_diag_outfield_mod !> @} diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 index 7a80ffdfc5..e48bb44e0f 100644 --- a/diag_manager/fms_diag_time_reduction.F90 +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -74,6 +74,7 @@ MODULE fms_diag_time_reduction_mod procedure, public :: is_time_diurnal => is_time_diurnal_imp procedure, public :: is_time_power => is_time_power_imp procedure, public :: initialize + procedure, public :: copy END TYPE fmsDiagTimeReduction_type !> @brief This interface is for the class constructor. @@ -88,22 +89,22 @@ MODULE fms_diag_time_reduction_mod function fmsDiagTimeReduction_type_constructor(dt, out_frequency) result(time_redux) integer, intent(in) :: dt !< The redution type (time_rms, time_power, etc) integer, intent(in) :: out_frequency !< The output frequency. - class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type class - !! allocated and returned by this constructor. + class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type + !!class allocated and returned by this constructor. allocate(time_redux) call time_redux%initialize(dt, out_frequency) end function fmsDiagTimeReduction_type_constructor -!> @brief Initialize the object. - subroutine initialize(this, dt, out_frequency) - class (fmsDiagTimeReduction_type), intent(inout) :: this !< The fmsDiagTimeReduction_type object - integer, intent(in) :: dt !< The redution type (time_rms, time_porer, etc) - integer, intent(in) :: out_frequency !< The output frequency. + !> @brief Initialize the object. + subroutine initialize(this, dt, out_frequency) + class (fmsDiagTimeReduction_type), intent(inout) :: this !< The fmsDiagTimeReduction_type object + integer, intent(in) :: dt !< The redution type (time_rms, time_porer, etc) + integer, intent(in) :: out_frequency !< The output frequency. - this%the_time_reduction = dt + this%the_time_reduction = dt - !! Set the time_averaging flag - !! See legacy init_ouput_fields function, lines 1470ff + !! Set the time_averaging flag + !! See legacy init_ouput_fields function, lines 1470ff IF(( dt .EQ. time_average) .OR. (dt .EQ. time_rms) .OR. (dt .EQ. time_power) .OR. & & (dt .EQ. time_diurnal)) THEN this%time_averaging = .true. @@ -125,18 +126,24 @@ subroutine initialize(this, dt, out_frequency) ELSE this%time_ops = .false. END IF - end subroutine initialize - - - - -!> \brief Returns true if any of time_min, time_max, time_rms or time_average is true. -!! @return true if any of time_min, time_max, time_rms or time_average is true. - pure function has_time_ops_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! @brief Copy the source time reduction object into the this object. + subroutine copy(this, source) + class (fmsDiagTimeReduction_type),intent(inout):: this !< The fmsDiagTimeReduction_type object + class (fmsDiagTimeReduction_type),intent(in):: source !< The fmsDiagTimeReduction_type object + this%the_time_reduction = source%the_time_reduction + this%time_averaging = source%time_averaging + this%time_ops = source%time_ops + end subroutine copy + + !> \brief Returns true if any of time_min, time_max, time_rms or time_average is true. + !! @return true if any of time_min, time_max, time_rms or time_average is true. + pure function has_time_ops_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff time_averaging is true. !! @return true iff time_averaging is true. diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 51c0201a93..f723726699 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -138,8 +138,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & INTEGER:: ls, le !< start and end indices for the 4th dimension. INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations - !< Looping indices, derived from ofield_index_cfg: - INTEGER :: i, j, k, l, i1, j1, k1 + INTEGER :: i, j, k, l, i1, j1, k1 !< Looping indices, derived from ofield_index_cfg: INTEGER :: numthreads INTEGER :: active_omp_level @@ -171,16 +170,16 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & f3 = ofield_index_cfg%get_f3() f4 = ofield_index_cfg%get_f4() - output_name = trim(ofield_cfg%output_name) - field_name = trim(ofield_cfg%field_name) - module_name = trim(ofield_cfg%module_name) - pow_value = ofield_cfg%pow_value - phys_window = ofield_cfg%phys_window - reduced_k_range = ofield_cfg%reduced_k_range - need_compute = ofield_cfg%need_compute - mask_variant = ofield_cfg%mask_variant - mask_present = ofield_cfg%mask_present - missvalue_present = ofield_cfg%missvalue_present + output_name = trim(ofield_cfg%get_output_name()) + field_name = trim(ofield_cfg%get_field_name()) + module_name = trim(ofield_cfg%get_module_name()) + pow_value = ofield_cfg%get_pow_value() + phys_window = ofield_cfg%get_phys_window() + reduced_k_range = ofield_cfg%get_reduced_k_range() + need_compute = ofield_cfg%get_need_compute() + mask_variant = ofield_cfg%get_mask_variant() + mask_present = ofield_cfg%get_mask_present() + missvalue_present = ofield_cfg%get_missvalue_present() !$OMP CRITICAL field_num_threads = 1 @@ -877,13 +876,11 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg LOGICAL :: mask_present !< A copy of same variable in ofield_cfg LOGICAL :: missvalue_present !< A copy of same variable in ofield_cfg + class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations - !< Looping indices, derived from ofield_index_cfg: - INTEGER :: i, j, k, i1, j1, k1 - - - LOGICAL :: time_max, time_min, time_sum + INTEGER :: i, j, k, i1, j1, k1 !< Looping indices, derived from ofield_index_cfg: + LOGICAL :: time_max, time_min, time_sum !< A copies of same variables in ofield_cfg%time_reduction ksr= l_start(3) ker= l_end(3) @@ -901,16 +898,18 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, f3 = ofield_index_cfg%get_f3() f4 = ofield_index_cfg%get_f4() - time_max = ofield_cfg%time_reduction%is_time_max() - time_min = ofield_cfg%time_reduction%is_time_min() - time_sum = ofield_cfg%time_reduction%is_time_sum() + allocate(time_redux) + call time_redux%copy(ofield_cfg%get_time_reduction()) + time_max = time_redux%is_time_max() + time_min = time_redux%is_time_min() + time_sum = time_redux%is_time_sum() - output_name = trim(ofield_cfg%output_name) - module_name = trim(ofield_cfg%module_name) - reduced_k_range = ofield_cfg%reduced_k_range - need_compute = ofield_cfg%need_compute - mask_present = ofield_cfg%mask_present - missvalue_present = ofield_cfg%missvalue_present + output_name = trim(ofield_cfg%get_output_name()) + module_name = trim(ofield_cfg%get_module_name()) + reduced_k_range = ofield_cfg%get_reduced_k_range() + need_compute = ofield_cfg%get_need_compute() + mask_present = ofield_cfg%get_mask_present() + missvalue_present = ofield_cfg%get_missvalue_present() ! Add processing for Max and Min TIME_IF: IF ( time_max ) THEN @@ -1301,8 +1300,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, hi = ofield_index_cfg%get_hi() hj = ofield_index_cfg%get_hj() - reduced_k_range = ofield_cfg%reduced_k_range - need_compute = ofield_cfg%need_compute + reduced_k_range = ofield_cfg%get_reduced_k_range() + need_compute = ofield_cfg%get_need_compute() associate(ofb => buffer) From 7aba81be5015f9eafc4ea456a40ad383700aa435 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Thu, 9 Feb 2023 12:50:04 -0500 Subject: [PATCH 25/37] Adding function initialize_for_ut to fmsDiagOutfield_type so unit test has the appropriate set access to private fields. --- diag_manager/fms_diag_outfield.F90 | 38 ++++++++++++++++++- .../diag_manager/test_diag_update_buffer.F90 | 31 +-------------- 2 files changed, 38 insertions(+), 31 deletions(-) diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index 33562c0c58..e361488956 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -104,6 +104,7 @@ MODULE fms_diag_outfield_mod procedure :: get_mask_present procedure :: get_time_reduction procedure, public :: initialize => initialize_outfield_imp + procedure :: initialize_for_ut END TYPE fmsDiagOutfield_type @@ -139,7 +140,6 @@ MODULE fms_diag_outfield_mod procedure :: get_ke procedure :: get_hi procedure :: get_hj - END TYPE fmsDiagOutfieldIndex_type CONTAINS @@ -382,6 +382,42 @@ SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_presen END SUBROUTINE initialize_outfield_imp + !> @brief Initialized an fms_diag_outfield_type as needed for unit tests. + subroutine initialize_for_ut(this, module_name, field_name, output_name, & + & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & + & time_reduction_type,output_freq) + CLASS(fmsDiagOutfield_type), intent(inout) :: this + CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fms_diag_outfield_type + CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fms_diag_outfield_type + CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fms_diag_outfield_type + INTEGER, INTENT(in) :: power_val !< Var with same name in fms_diag_outfield_type + LOGICAL, INTENT(in) :: phys_window !< Var with same name in fms_diag_outfield_type + LOGICAL, INTENT(in) :: need_compute !< Var with same name in fms_diag_outfield_type + LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fms_diag_outfield_type + LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fms_diag_outfield_type + INTEGER, INTENT(in) :: num_elems !< Var with same name in fms_diag_outfield_type + INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fms_diag_outfield_type + INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type + + this%module_name = module_name + this%field_name = field_name + this%output_name = output_name + this%pow_value = power_val + this%phys_window = phys_window + this%need_compute = need_compute + this%reduced_k_range = reduced_k_range + this%mask_variant = mask_variant + call this%time_reduction%initialize(time_reduction_type, output_freq) + end subroutine initialize_for_ut + + !> @brief Reset the time reduction member field. Intended for use in unit tests only. + SUBROUTINE reset_time_reduction_ut(this, source ) + CLASS(fmsDiagOutfield_type), INTENT(inout) :: this !< An instance of the fmsDiagOutfield_type + TYPE(fmsDiagTimeReduction_type) :: source !< The fmsDiagTimeReduction_type to copy from + call this%time_reduction%copy(source) + END SUBROUTINE reset_time_reduction_ut + + !> \brief Get the time reduction from a legacy output field. !\note Note we do not place this in the time_reduction class to avoid circular dependencies. diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index a87099c6dc..234914017d 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -209,7 +209,7 @@ program test_diag_update_buffer ALLOCATE( ofield_cfg ) - call init_ofield_cfg(ofield_cfg, module_name1, field_name1, output_name1, pow_value, & + call ofield_cfg%initialize_for_ut(module_name1, field_name1, output_name1, pow_value, & & phys_window, need_compute, mask_variant, reduced_k_range , & & num_elems, time_reduction_type1, output_freq1 ) ALLOCATE( ofield_index_cfg ) @@ -256,35 +256,6 @@ program test_diag_update_buffer call fms_end CONTAINS - !> @brief Initialized an fms_diag_outfield_type as needed in the test. - !! TODO in future PR: There may in the future ne a member function of fms_diag_outfield_type - !! to call. - subroutine init_ofield_cfg( of_cfg, module_name, field_name, output_name, & - & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & - & time_reduction_type,output_freq) - type(fmsDiagOutfield_type) :: of_cfg - CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fms_diag_outfield_type - CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fms_diag_outfield_type - CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fms_diag_outfield_type - INTEGER, INTENT(in) :: power_val !< Var with same name in fms_diag_outfield_type - LOGICAL, INTENT(in) :: phys_window !< Var with same name in fms_diag_outfield_type - LOGICAL, INTENT(in) :: need_compute !< Var with same name in fms_diag_outfield_type - LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fms_diag_outfield_type - LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fms_diag_outfield_type - INTEGER, INTENT(in) :: num_elems !< Var with same name in fms_diag_outfield_type - INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fms_diag_outfield_type - INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type - - of_cfg%module_name = module_name - of_cfg%field_name = field_name - of_cfg%output_name = output_name - of_cfg%pow_value = pow_value - of_cfg%phys_window = phys_window - of_cfg%need_compute = need_compute - of_cfg%reduced_k_range = reduced_k_range - of_cfg%mask_variant = mask_variant - call of_cfg%time_reduction%initialize(time_reduction_type, output_freq) - end subroutine init_ofield_cfg !> @brief Initialized an fms_diag_outfield_index_type by calling member funtion of !! fms_diag_outfield_index_type input object. From 2b688dc113bbdb441fc618b374334fd2d734aaaa Mon Sep 17 00:00:00 2001 From: ngs333 Date: Fri, 10 Feb 2023 13:44:47 -0500 Subject: [PATCH 26/37] Changes originating from PR review comments. --- diag_manager/diag_data.F90 | 8 ++-- diag_manager/diag_manager.F90 | 3 +- diag_manager/diag_util.F90 | 40 +++++++++---------- diag_manager/fms_diag_fieldbuff_update.F90 | 2 +- diag_manager/fms_diag_outfield.F90 | 38 +++++++++--------- diag_manager/fms_diag_time_reduction.F90 | 4 +- .../include/fms_diag_fieldbuff_update.fh | 32 +++++++-------- .../diag_manager/test_diag_update_buffer.F90 | 14 +++---- 8 files changed, 70 insertions(+), 71 deletions(-) diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 1829b0d597..7cd701ba69 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -130,7 +130,7 @@ MODULE diag_data_mod !> @brief Data structure holding intervals (or interval bounds or limits). !! Used for checking the bounds of the field output buffer arrays. -TYPE, public :: fms_diag_ibounds_type +TYPE, public :: fmsDiagIbounds_type INTEGER :: imin !< Lower i bound. INTEGER :: imax !< Upper i bound. INTEGER :: jmin !< Lower j bound. @@ -139,7 +139,7 @@ MODULE diag_data_mod INTEGER :: kmax !< Upper k bound. contains procedure :: reset => ibounds_reset -END TYPE fms_diag_ibounds_type +END TYPE fmsDiagIbounds_type @@ -258,7 +258,7 @@ MODULE diag_data_mod TYPE(diag_grid) :: output_grid LOGICAL :: local_output, need_compute, phys_window, written_once LOGICAL :: reduced_k_range - TYPE(fms_diag_ibounds_type) :: buff_bounds + TYPE(fmsDiagIbounds_type) :: buff_bounds TYPE(time_type) :: Time_of_prev_field_data TYPE(diag_atttype), allocatable, dimension(:) :: attributes INTEGER :: num_attributes @@ -408,7 +408,7 @@ END SUBROUTINE diag_data_init !> @brief Sets the lower and upper bounds to lower_val and upper_val, respectively. SUBROUTINE ibounds_reset (this, lower_val, upper_val) - class (fms_diag_ibounds_type), target, intent(inout) :: this !< ibounds instance + class (fmsDiagIbounds_type), target, intent(inout) :: this !< ibounds instance integer, intent(in) :: lower_val !< value for the lower bounds in each dimension integer, intent(in) :: upper_val !< value for the upper bounds in each dimension this%imin = lower_val diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index ed5374b16b..7dc5100206 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1497,7 +1497,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & TYPE(fmsDiagOutfield_type), ALLOCATABLE:: ofield_cfg ! @brief Determine the bounds of the first three dimentions + !> @brief Determine the bounds of the first three dimensions !! of the "array" argument and store it the bounding box argument "bounds" SUBROUTINE fms_bounds_from_array_4D(bounds, array) REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. bounds%imin = LBOUND(array,1) bounds%imax = UBOUND(array,1) bounds%jmin = LBOUND(array,2) @@ -771,11 +771,11 @@ SUBROUTINE fms_bounds_from_array_4D(bounds, array) bounds%kmax = UBOUND(array,3) END SUBROUTINE fms_bounds_from_array_4D - !> @brief Determine the bounds of the first three dimentions + !> @brief Determine the bounds of the first three dimensions !! of the "array" argument and store it the bounding box argument "bounds" SUBROUTINE fms_bounds_from_array_5D(bounds, array) - CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 4D input array. - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. + CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 5D input array. + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. bounds%imin = LBOUND(array,1) bounds%imax = UBOUND(array,1) bounds%jmin = LBOUND(array,2) @@ -802,7 +802,7 @@ END SUBROUTINE fms_update_bounds_legacy !! max boundaries (array indices) of the input bounding box "bounds" with !! the six specified bounds values. SUBROUTINE fms_update_bounds_modern(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) - TYPE (fms_diag_ibounds_type), intent(inout) :: bounds ! output_fields(out_num)%buff_bounds) CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) @@ -932,7 +932,7 @@ END SUBROUTINE check_out_of_bounds !! If there is an error then error message will be filled. SUBROUTINE fms_diag_check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, err_msg) REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The bounding box to check against + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty @@ -940,7 +940,7 @@ SUBROUTINE fms_diag_check_out_of_bounds_modern_r4(ofb, bounds, output_name, modu CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: out_of_bounds = .true. - TYPE (fms_diag_ibounds_type) :: array_bounds + TYPE (fmsDiagIbounds_type) :: array_bounds CALL bounds_from_array(array_bounds, ofb) @@ -964,7 +964,7 @@ END SUBROUTINE fms_diag_check_out_of_bounds_modern_r4 SUBROUTINE fms_diag_check_out_of_bounds_modern_r8(ofb, bounds, output_name, module_name, err_msg) REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check - TYPE (fms_diag_ibounds_type), INTENT(inout) :: bounds !< The bounding box to check against + TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty @@ -972,7 +972,7 @@ SUBROUTINE fms_diag_check_out_of_bounds_modern_r8(ofb, bounds, output_name, modu CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: out_of_bounds = .true. - TYPE (fms_diag_ibounds_type) :: array_bounds ! @brief Class fms_diag_outfield_type (along with class ms_diag_outfield_index_type ) + !> @brief Class fmsDiagOutfiled_type (along with class ms_diag_outfield_index_type ) !! contain information used in updating the output buffers by the diag_manager !! send_data routines. In some sense they can be seen as encapsulating related !! information in a convenient way (e.g. to pass to functions and for do loop !! controls. !! - !! Class fms_diag_outfield_type also contains a significant subset of the fields + !! Class fmsDiagOutfiled_type also contains a significant subset of the fields !! and routines of of the legacy class output_field_type !! TODO: (MDM) This class will need further development for the modern_diag effort. !! For its development, consider the legacy diag_util::init_output_field already @@ -76,15 +74,15 @@ MODULE fms_diag_outfield_mod LOGICAL :: reduced_k_range !< If true, the local start and end indecies are used in k (i.e. 3rd) dim. LOGICAL :: missvalue_present !< LOGICAL :: mask_variant - LOGICAL :: mask_present !< True iff mars arguemnt is present in user-facing send function call. - !< Note this field exist since the actual mask argument in the send + LOGICAL :: mask_present !< True iff mask argument is present in user-facing send function call. + !< Note this field exists since the actual mask argument in the send !< function call may be downstream replaced by a null pointer which !< is considered present. TYPE(fmsDiagTimeReduction_type) :: time_reduction !< Instance of the fmsDiagTimeTeduction_type. !!TODO (Future effort? ) : a pointer for time_min and time_max comparison function - !! If possible, this can reove the innermost if/then/else construct in the buffer update loops. + !! If possible, this can remove the innermost if/then/else construct in the buffer update loops. !! min_max_f_ptr => (should point to < or > operators) !! gcc error: Interface ‘addwf’ at (1) must be explicit @@ -108,7 +106,7 @@ MODULE fms_diag_outfield_mod END TYPE fmsDiagOutfield_type - !> @brief Class fms_diag_outfield_index_type which (along with class fms_diag_outfield_type) + !> @brief Class fms_diag_outfield_index_type which (along with class fmsDiagOutfiled_type) !! encapsulate related information used in updating the output buffers by the diag_manager !! send_data routines. This class in particular focuses on do loop index controls or settings. !! Note that the index names in this class should be indentical to the names used in the @@ -382,21 +380,21 @@ SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_presen END SUBROUTINE initialize_outfield_imp - !> @brief Initialized an fms_diag_outfield_type as needed for unit tests. + !> @brief Initialized an fmsDiagOutfiled_type as needed for unit tests. subroutine initialize_for_ut(this, module_name, field_name, output_name, & & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & & time_reduction_type,output_freq) CLASS(fmsDiagOutfield_type), intent(inout) :: this - CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fms_diag_outfield_type - CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fms_diag_outfield_type - CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fms_diag_outfield_type - INTEGER, INTENT(in) :: power_val !< Var with same name in fms_diag_outfield_type - LOGICAL, INTENT(in) :: phys_window !< Var with same name in fms_diag_outfield_type - LOGICAL, INTENT(in) :: need_compute !< Var with same name in fms_diag_outfield_type - LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fms_diag_outfield_type - LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fms_diag_outfield_type - INTEGER, INTENT(in) :: num_elems !< Var with same name in fms_diag_outfield_type - INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fms_diag_outfield_type + CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fmsDiagOutfiled_type + CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fmsDiagOutfiled_type + CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fmsDiagOutfiled_type + INTEGER, INTENT(in) :: power_val !< Var with same name in fmsDiagOutfiled_type + LOGICAL, INTENT(in) :: phys_window !< Var with same name in fmsDiagOutfiled_type + LOGICAL, INTENT(in) :: need_compute !< Var with same name in fmsDiagOutfiled_type + LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fmsDiagOutfiled_type + LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fmsDiagOutfiled_type + INTEGER, INTENT(in) :: num_elems !< Var with same name in fmsDiagOutfiled_type + INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fmsDiagOutfiled_type INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type this%module_name = module_name diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 index e48bb44e0f..e4bb9bd051 100644 --- a/diag_manager/fms_diag_time_reduction.F90 +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -50,11 +50,11 @@ MODULE fms_diag_time_reduction_mod !> @brief Class fmsDiagTimeReduction_type has an encapsulation of the "Fortran enum" time !! reduction integer parameters, plus an encapsulation of the groupings of -!! the time reduction types. It is inteded to provide some of the functionality +!! the time reduction types. It is intended to provide some of the functionality !! that was coded in the legacy function diag_data.F90:init_output_fields. !! The functionality in the end is used by send_data in (EFFICIENT) do loops calling !! the weighting or math functions to update buffers. -!! the The integer parameters above are the legal time reduction types, +!! The integer parameters above are the legal time reduction types, !! but they are not necessarily mutually exclusive in some contexts. !! !> @addtogroup fms_diag_time_reduction_mod diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index f723726699..ef10bd37cd 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -17,8 +17,8 @@ !* License along with FMS. If not, see . !*********************************************************************** - !> @brief This code will be used by the preprecessor to generate an implementation - !! to the module procedure for the fieldbuff_update interface. The + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_update interface. The !! generated function is a wrapper calling 4D field/5D buffer version of the same. FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & & ofb, ofc, bbounds, count_0d, num_elements, mask, weight1, missvalue, & @@ -32,7 +32,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(inout), target :: ofb !< Output Field Buffer FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:), INTENT(inout), target :: ofc !< Output Field Counter - TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. INTEGER, INTENT(inout) :: num_elements LOGICAL, CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask !< mask @@ -81,8 +81,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END FUNCTION FMS_DIAG_FBU_3D_PNAME_ -!> @brief This code will be used by the preprecessor to generate an implementation -!! to the module procedure for the fieldbuff_update interface. +!> @brief This code will be used by the preprocessor to generate an implementation +!! of the module procedure for the fieldbuff_update interface. !! Updates elements of the running field output buffer (argument ofb) !! and counter (argument ofc) based on the input field data array (argument field_d). !! In general the formulas are : @@ -104,7 +104,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< Output Field Buffer FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofc !< Output Field Counter - TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. INTEGER, INTENT(inout) :: num_elements @@ -801,8 +801,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END FUNCTION FMS_DIAG_FBU_PNAME_ - !> @brief This code will be used by the preprecessor to generate an implementation - !! to the module procedure for the fieldbuff_copy_fieldvals interface. The + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_copy_fieldvals interface. The !! generated function is a wrapper calling 4D field/5D buffer version of the same. FUNCTION FMS_DIAG_FBCF_3D_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & & bbounds, count_0d, mask, missvalue, & @@ -814,7 +814,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! @brief This code will be used by the preprecessor to generate an implementation -!! to the module procedure for the fieldbuff_copy_fieldvals interface. +!> @brief This code will be used by the preprocessor to generate an implementation +!! of the module procedure for the fieldbuff_copy_fieldvals interface. !! The function may set or add to the output field buffer (argument ofb) with the input !! field data array (argument field) FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & @@ -856,7 +856,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< The Output Field Buffer - TYPE(fms_diag_ibounds_type), INTENT(inout) :: bbounds + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !< Normally the member of the buffer of same name, LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. @@ -1232,8 +1232,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, - !> @brief This code will be used by the preprecessor to generate an implementation - !! to the module procedure for the fieldbuff_copy_misvals interface. The + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_copy_misvals interface. The !! generated function is a wrapper calling 4D field/5D buffer version of the same. SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ (ofield_cfg, ofield_index_cfg, ofb, sample, & & l_start, l_end, rmask, rmask_thresh, missvalue) @@ -1262,8 +1262,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, END SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ - !> @brief This code will be used by the preprecessor to generate an implementation - !! to the module procedure for the fieldbuff_copy_misvals interface. + !> @brief This code will be used by the preprocessor to generate an implementation + !! of the module procedure for the fieldbuff_copy_misvals interface. !! The function updates where appropriate and depending on the rmask argument, !! elements of the running field output buffer (argument buffer) with value missvalue. !! NOTE: It appears these OFB updates were introcuded by EMC MM into the tail end of the diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index 234914017d..aaf2a47e56 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -24,7 +24,7 @@ program test_diag_update_buffer use platform_mod use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated use fms_mod, ONLY: fms_init, fms_end, error_mesg, FATAL,NOTE - use diag_data_mod, ONLY: fms_diag_ibounds_type, VERY_LARGE_AXIS_LENGTH + use diag_data_mod, ONLY: fmsDiagIbounds_type, VERY_LARGE_AXIS_LENGTH USE fms_diag_outfield_mod, ONLY: fmsDiagOutfield_type, fmsDiagOutfieldIndex_type USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & & fieldbuff_copy_fieldvals @@ -34,12 +34,12 @@ program test_diag_update_buffer !! Class diag_buffer_type is here only for temporary use for modern diag_manager !! development until the real buffer class is sufficiently ready and merged. - TYPE diag_test_buffer_type + TYPE diagTestBuffer_type CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: buffer CLASS(*), ALLOCATABLE, DIMENSION(:,:,:,:,:) :: counter CLASS(*), ALLOCATABLE, DIMENSION(:) :: count_0d INTEGER, ALLOCATABLE, dimension(:) :: num_elements - END TYPE diag_test_buffer_type + END TYPE diagTestBuffer_type integer,parameter :: SZ=10 !< Field data this size in all spatiall dims. integer,parameter :: SL=2 !< Field data this size in 4th dim @@ -47,7 +47,7 @@ program test_diag_update_buffer CLASS(*), ALLOCATABLE :: r4_datapoint, i8_datapoint !< to be allocated of rype data (e.g. r4. i8) !! to be used thought. - TYPE(fms_diag_ibounds_type) :: buff_bounds + TYPE(fmsDiagIbounds_type) :: buff_bounds !!Diag_manager::send_data uses CLASS(*) in function signature, SO !! we mimic the resulting operations. The set of ClASS(*) data needs to be allocated of same @@ -57,7 +57,7 @@ program test_diag_update_buffer CLASS(*), ALLOCATABLE, TARGET :: missvalue LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: mask LOGICAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: oor_mask - TYPE(diag_test_buffer_type), ALLOCATABLE, TARGET :: buff_obj + TYPE(diagTestBuffer_type), ALLOCATABLE, TARGET :: buff_obj !! In principle, the field_data can be r4,r8,i4,i8,but we will only rest r4,i8 !!These belwo will be pointers to the data @@ -125,7 +125,7 @@ program test_diag_update_buffer call init_field_values (field_data) - !!TODO:: Can switch to final diang_manager buffer_object type in modern diag effort. + !!TODO: (MDM) Can switch to final diang_manager buffer_object type in modern diag effort. !!In this version, we will meerely set type specific pointers to data. Some will be !! null, but at the end either the r4 pointers are non-null or the i8 pointers are not null @@ -463,7 +463,7 @@ END subroutine allocate_input_data_and_ptrs subroutine allocate_buffer_obj( data_point, bo, NX,NY,NZ, NL, NDI) - TYPE(diag_test_buffer_type), INTENT(inout), allocatable :: bo + TYPE(diagTestBuffer_type), INTENT(inout), allocatable :: bo CLASS(*), INTENT(in) :: data_point !< Sample point allocated to the type being tested. INTEGER, INTENT(IN) :: NX, NY, NZ !< The three spatial dimensions. INTEGER, INTENT(IN) :: NL !< Size of the 4th dimentions From c2615ba4bcf4c6fa35bb1f756c1d225610b4b8e7 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Sat, 11 Feb 2023 23:56:15 -0500 Subject: [PATCH 27/37] Several modificationsand comment updates based on review. --- diag_manager/diag_util.F90 | 107 ++++++++---------- diag_manager/fms_diag_elem_weight_procs.F90 | 3 + diag_manager/fms_diag_fieldbuff_update.F90 | 2 +- diag_manager/fms_diag_time_reduction.F90 | 4 +- .../include/fms_diag_fieldbuff_update.fh | 64 ++++++----- 5 files changed, 85 insertions(+), 95 deletions(-) diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 665a694cde..7e67bb1d1d 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -77,12 +77,13 @@ MODULE diag_util_mod IMPLICIT NONE PRIVATE - PUBLIC get_subfield_size, log_diag_field_info, bounds_from_array, update_bounds, check_out_of_bounds,& - & check_bounds_are_exact_dynamic, check_bounds_are_exact_static, init_file, diag_time_inc,& + PUBLIC get_subfield_size, log_diag_field_info, init_file, diag_time_inc,& & find_input_field, init_input_field, init_output_field, diag_data_out, write_static,& & check_duplicate_output_fields, get_date_dif, get_subfield_vert_size, sync_file_times,& & prepend_attribute, attribute_init, diag_util_init,& - & fms_diag_check_out_of_bounds + & update_bounds, check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,& + & fms_diag_bounds_from_array, fms_diag_check_out_of_bounds, fms_diag_update_bounds, & + & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static !> @brief Prepend a value to a string attribute in the output field or output file. @@ -99,36 +100,18 @@ MODULE diag_util_mod MODULE PROCEDURE attribute_init_file END INTERFACE attribute_init - INTERFACE update_bounds - module procedure fms_update_bounds_legacy - module procedure fms_update_bounds_modern - END INTERFACE update_bounds - INTERFACE fms_diag_check_out_of_bounds - !!module procedure check_out_of_bounds_legacy - module procedure fms_diag_check_out_of_bounds_modern_r4 - module procedure fms_diag_check_out_of_bounds_modern_r8 + module procedure fms_diag_check_out_of_bounds_r4 + module procedure fms_diag_check_out_of_bounds_r8 END INTERFACE fms_diag_check_out_of_bounds - INTERFACE check_bounds_are_exact_dynamic - module procedure check_bounds_are_exact_dynamic_legacy - !!TODO: (MDM) module procedure check_bounds_are_exact_dynamic_modern ? - END INTERFACE check_bounds_are_exact_dynamic - - INTERFACE check_bounds_are_exact_static - module procedure fms_check_bounds_are_exact_static_legacy - !! TODO: (MDM) module procedure check_bounds_are_exact_static_modern - END INTERFACE check_bounds_are_exact_static - - INTERFACE bounds_from_array - module procedure fms_bounds_from_array_4D - module procedure fms_bounds_from_array_5D - END INTERFACE bounds_from_array - + INTERFACE fms_diag_bounds_from_array + module procedure bounds_from_array_4D + module procedure bounds_from_array_5D + END INTERFACE fms_diag_bounds_from_array !> @addtogroup diag_util_mod !> @{ - ! Include variable "version" to be written to log file. #include @@ -760,7 +743,7 @@ END SUBROUTINE log_diag_field_info !> @brief Determine the bounds of the first three dimensions !! of the "array" argument and store it the bounding box argument "bounds" - SUBROUTINE fms_bounds_from_array_4D(bounds, array) + SUBROUTINE bounds_from_array_4D(bounds, array) REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. bounds%imin = LBOUND(array,1) @@ -769,11 +752,11 @@ SUBROUTINE fms_bounds_from_array_4D(bounds, array) bounds%jmax = UBOUND(array,2) bounds%kmin = LBOUND(array,3) bounds%kmax = UBOUND(array,3) - END SUBROUTINE fms_bounds_from_array_4D + END SUBROUTINE bounds_from_array_4D !> @brief Determine the bounds of the first three dimensions !! of the "array" argument and store it the bounding box argument "bounds" - SUBROUTINE fms_bounds_from_array_5D(bounds, array) + SUBROUTINE bounds_from_array_5D(bounds, array) CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 5D input array. TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. bounds%imin = LBOUND(array,1) @@ -782,11 +765,11 @@ SUBROUTINE fms_bounds_from_array_5D(bounds, array) bounds%jmax = UBOUND(array,2) bounds%kmin = LBOUND(array,3) bounds%kmax = UBOUND(array,3) - END SUBROUTINE fms_bounds_from_array_5D + END SUBROUTINE bounds_from_array_5D !> @brief Update the output_fields x, y, and z min and max boundaries (array indices) !! with the six specified bounds values. - SUBROUTINE fms_update_bounds_legacy(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) + SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) INTEGER, INTENT(in) :: out_num !< output field ID INTEGER, INTENT(in) :: lower_i !< Lower i bound. INTEGER, INTENT(in) :: upper_i !< Upper i bound. @@ -794,14 +777,14 @@ SUBROUTINE fms_update_bounds_legacy(out_num, lower_i, upper_i, lower_j, upper_j, INTEGER, INTENT(in) :: upper_j !< Upper j bound. INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. - CALL fms_update_bounds_modern(output_fields(out_num)%buff_bounds, & + CALL fms_diag_update_bounds(output_fields(out_num)%buff_bounds, & & lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) - END SUBROUTINE fms_update_bounds_legacy + END SUBROUTINE update_bounds !> @brief Update the the first three (normally x, y, and z) min and !! max boundaries (array indices) of the input bounding box "bounds" with !! the six specified bounds values. -SUBROUTINE fms_update_bounds_modern(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) +SUBROUTINE fms_diag_update_bounds(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) TYPE (fmsDiagIbounds_type), intent(inout) :: bounds ! @brief Compares the bounding indices of an array specified in "current_bounds" !! to the corresponding lower and upper bounds specified in "bounds" @@ -827,7 +810,7 @@ LOGICAL FUNCTION compare_buffer_bounds_to_size(current_bounds, bounds, error_str TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds ! @brief Interface lowerb_comp should be used for comparison to lower bounds of buffer. @@ -901,7 +884,7 @@ END FUNCTION a_noteq_b SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID number. INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. - CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the CHARACTER(len=128) :: error_string1, error_string2 @@ -909,7 +892,7 @@ SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) TYPE (fmsDiagIbounds_type) :: array_bounds associate (buff_bounds => output_fields(out_num)%buff_bounds) - CALL bounds_from_array(array_bounds, output_fields(out_num)%buffer) + CALL fms_diag_bounds_from_array(array_bounds, output_fields(out_num)%buffer) out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & & error_string2, a_lessthan_b, a_greaterthan_b) @@ -930,7 +913,7 @@ END SUBROUTINE check_out_of_bounds !> @brief Checks if the array indices for output_fields(out_num) are outside the !! output_fields(out_num)%buffer upper and lower bounds. !! If there is an error then error message will be filled. -SUBROUTINE fms_diag_check_out_of_bounds_modern_r4(ofb, bounds, output_name, module_name, err_msg) +SUBROUTINE fms_diag_check_out_of_bounds_r4(ofb, bounds, output_name, module_name, err_msg) REAL(kind=r4_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message @@ -942,7 +925,7 @@ SUBROUTINE fms_diag_check_out_of_bounds_modern_r4(ofb, bounds, output_name, modu LOGICAL :: out_of_bounds = .true. TYPE (fmsDiagIbounds_type) :: array_bounds - CALL bounds_from_array(array_bounds, ofb) + CALL fms_diag_bounds_from_array(array_bounds, ofb) out_of_bounds = compare_buffer_bounds_to_size(array_bounds, bounds, & & error_string2, a_lessthan_b, a_greaterthan_b) @@ -956,25 +939,25 @@ SUBROUTINE fms_diag_check_out_of_bounds_modern_r4(ofb, bounds, output_name, modu ELSE err_msg = '' END IF -END SUBROUTINE fms_diag_check_out_of_bounds_modern_r4 +END SUBROUTINE fms_diag_check_out_of_bounds_r4 !> @brief Checks if the array indices for output_field buffer (ofb) are outside the !! are outside the bounding box (bounds). !! If there is an error then error message will be filled. -SUBROUTINE fms_diag_check_out_of_bounds_modern_r8(ofb, bounds, output_name, module_name, err_msg) +SUBROUTINE fms_diag_check_out_of_bounds_r8(ofb, bounds, output_name, module_name, err_msg) REAL(kind=r8_kind), INTENT (in), DIMENSION(:,:,:,:,:) :: ofb !< The output field buffer to check TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The bounding box to check against CHARACTER(:), ALLOCATABLE, INTENT(in) :: output_name !< output name for placing in error message CHARACTER(:), ALLOCATABLE, INTENT(in) :: module_name !< module name for placing in error message - CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_out_of_bounds. An empty + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_out_of_bounds. An empty !! error string indicates the x, y, and z indices are not outside the CHARACTER(len=128) :: error_string1, error_string2 LOGICAL :: out_of_bounds = .true. TYPE (fmsDiagIbounds_type) :: array_bounds ! @brief Checks that array indices specified in the bounding box "current_bounds" !! are identical to those in the bounding box "bounds" match exactly. The check !! occurs only when the time changed. !! If there is an error then error message will be filled. -SUBROUTINE check_bounds_are_exact_dynamic_modern(current_bounds, bounds, output_name, module_name, & +SUBROUTINE fms_diag_check_bounds_are_exact_dynamic(current_bounds, bounds, output_name, module_name, & & Time, field_prev_Time, err_msg) TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds !output_fields(out_num)%Time_of_prev_field_data is not !! equal to Time or Time_zero. TYPE(time_type), INTENT(inout) :: field_prev_Time !< output_fields(out_num)%Time_of_prev_field_data - CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. !! An empty error string indicates the x, y, and z indices are !! equal to the buffer array boundaries. @@ -1041,18 +1024,18 @@ SUBROUTINE check_bounds_are_exact_dynamic_modern(current_bounds, bounds, output_ END IF call bounds%reset(VERY_LARGE_AXIS_LENGTH, 0) END IF -END SUBROUTINE check_bounds_are_exact_dynamic_modern +END SUBROUTINE fms_diag_check_bounds_are_exact_dynamic !> @brief This is an adaptor to the check_bounds_are_exact_dynamic_modern function to !! maintain an interface servicing the legacy diag_manager. -SUBROUTINE check_bounds_are_exact_dynamic_legacy(out_num, diag_field_id, Time, err_msg) +SUBROUTINE check_bounds_are_exact_dynamic(out_num, diag_field_id, Time, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID number. INTEGER, INTENT(in) :: diag_field_id !< Input field ID number. TYPE(time_type), INTENT(in) :: Time !< Time to use in check. The check is only performed if !! output_fields(out_num)%Time_of_prev_field_data is not !! equal to Time or Time_zero. - CHARACTER(len=*), INTENT(inout) :: err_msg !< Return status of check_bounds_are_exact_dynamic. + CHARACTER(len=*), INTENT(out) :: err_msg !< Return status of check_bounds_are_exact_dynamic. !! An empty error string indicates the x, y, and z indices are !! equal to the buffer array boundaries. CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message @@ -1062,21 +1045,21 @@ SUBROUTINE check_bounds_are_exact_dynamic_legacy(out_num, diag_field_id, Time, e output_name = output_fields(out_num)%output_name module_name = input_fields(diag_field_id)%module_name - CALL bounds_from_array(current_bounds, output_fields(out_num)%buffer) + CALL fms_diag_bounds_from_array(current_bounds, output_fields(out_num)%buffer) - CALL check_bounds_are_exact_dynamic_modern(current_bounds, output_fields(out_num)%buff_bounds, & + CALL fms_diag_check_bounds_are_exact_dynamic(current_bounds, output_fields(out_num)%buff_bounds, & & output_name, module_name, & & Time, output_fields(out_num)%Time_of_prev_field_data, err_msg) -END SUBROUTINE check_bounds_are_exact_dynamic_legacy +END SUBROUTINE check_bounds_are_exact_dynamic !> @brief Check if the array indices for output_fields(out_num) are equal to the !! output_fields(out_num)%buffer upper and lower bounds. - SUBROUTINE fms_check_bounds_are_exact_static_legacy(out_num, diag_field_id, err_msg) + SUBROUTINE check_bounds_are_exact_static(out_num, diag_field_id, err_msg) INTEGER, INTENT(in) :: out_num !< Output field ID INTEGER, INTENT(in) :: diag_field_id !< Input field ID. - CHARACTER(len=*), INTENT(inout) :: err_msg !< The return status, which is set to non-empty message + CHARACTER(len=*), INTENT(out) :: err_msg !< The return status, which is set to non-empty message !! if the check fails. CHARACTER(:), ALLOCATABLE :: output_name !< output name for placing in error message CHARACTER(:), ALLOCATABLE :: module_name !< output name for placing in error message @@ -1085,23 +1068,23 @@ SUBROUTINE fms_check_bounds_are_exact_static_legacy(out_num, diag_field_id, err_ output_name = output_fields(out_num)%output_name module_name = input_fields(diag_field_id)%module_name - CALL bounds_from_array(current_bounds, output_fields(out_num)%buffer) + CALL fms_diag_bounds_from_array(current_bounds, output_fields(out_num)%buffer) - CALL fms_check_bounds_are_exact_static_modern(current_bounds, output_fields(out_num)%buff_bounds, & + CALL fms_diag_check_bounds_are_exact_static(current_bounds, output_fields(out_num)%buff_bounds, & & output_name, module_name, err_msg) - END SUBROUTINE fms_check_bounds_are_exact_static_legacy + END SUBROUTINE check_bounds_are_exact_static !> @brief Check if the array indices specified in the bounding box "current_bounds" are equal to those !! specified in the bounding box "bounds" output_fields are equal to the buffer upper and lower bounds. !! If there is an error then error message will be filled. - SUBROUTINE fms_check_bounds_are_exact_static_modern(current_bounds, bounds, output_name, module_name, err_msg) + SUBROUTINE fms_diag_check_bounds_are_exact_static(current_bounds, bounds, output_name, module_name, err_msg) TYPE (fmsDiagIbounds_type), INTENT(in) :: current_bounds ! @brief Initialize the output file. diff --git a/diag_manager/fms_diag_elem_weight_procs.F90 b/diag_manager/fms_diag_elem_weight_procs.F90 index 14d0d79d4c..0a07d47327 100644 --- a/diag_manager/fms_diag_elem_weight_procs.F90 +++ b/diag_manager/fms_diag_elem_weight_procs.F90 @@ -53,6 +53,9 @@ MODULE fms_diag_elem_weight_procs_mod !! not in the original send_data_3d code and the power function was used. !! So this case may need to be deleted if reproducability is an issue. + !!TODO: (MDM) Discuss whether or not the pow_value should be allowed to + !! also be real though legacy interface has it satic. + !> @brief Calculates and returns the value given by this formula: !! returned_value = buff + (weight * field)**pow_value !! Special cases when pow_value is equal to 1 or 2 do not explicitly use the power function. diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index c4893abb75..b48d140dce 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -39,7 +39,7 @@ MODULE fms_diag_fieldbuff_update_mod USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,fms_error_handler USE diag_data_mod, ONLY: debug_diag_manager, fmsDiagIbounds_type USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type - USE diag_util_mod, ONLY: fms_diag_check_out_of_bounds, update_bounds + USE diag_util_mod, ONLY: fms_diag_check_out_of_bounds, fms_diag_update_bounds USE fms_diag_time_reduction_mod, ONLY: fmsDiagTimeReduction_type USE fms_diag_elem_weight_procs_mod, ONLY: addwf diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 index e4bb9bd051..83cb4d4315 100644 --- a/diag_manager/fms_diag_time_reduction.F90 +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -86,6 +86,8 @@ MODULE fms_diag_time_reduction_mod CONTAINS !> @brief The class contructors. Just allocates the class and calls an initializer + !! @return An allocated instance of fmsDiagTimeReduction_type, which is nitialized using + !! provided values for arguments dt and out_freqeuncy. function fmsDiagTimeReduction_type_constructor(dt, out_frequency) result(time_redux) integer, intent(in) :: dt !< The redution type (time_rms, time_power, etc) integer, intent(in) :: out_frequency !< The output frequency. @@ -117,7 +119,7 @@ subroutine initialize(this, dt, out_frequency) ENDIF END IF - !!TODO: Add other checks? E.g. If time_averaging == .false., then + !!TODO: (MDM) Add other checks? E.g. If time_averaging == .false., then !! out_frequency == EVERY_TIME IF((dt .EQ. time_min) .OR. (dt .EQ. time_max) .OR. & diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index ef10bd37cd..03080bd8c7 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -32,10 +32,11 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(inout), target :: ofb !< Output Field Buffer FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:), INTENT(inout), target :: ofc !< Output Field Counter - TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< The array bounds of the ofb argument. FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. - INTEGER, INTENT(inout) :: num_elements - LOGICAL, CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask !< mask + INTEGER, INTENT(inout) :: num_elements !< Used in counting updated buffer elements; Other functions (e.g. wrting + !!field) may nprmalize output buffer elements with the same. + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask !< The mask of the corresponding field. FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight. FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. @@ -45,8 +46,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL, INTENT(inout) :: issued_mask_ignore_warning INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on 3 axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on 3 axes for regional output - CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !!Possibly passed in by the caller, and sent to error handler - CHARACTER(len=256), INTENT(inout) :: err_msg_local !!Possibly set by bounds checker, and sent to error handler + CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !< Possibly passed in by the caller, and sent to error handler + CHARACTER(len=256), INTENT(inout) :: err_msg_local !< Possibly set by bounds checker, and sent to error handler !!TODO: can the use of a dummy be removed. FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),target :: ofc_dummy @@ -104,12 +105,12 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field_d !< The input field data array. FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< Output Field Buffer FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofc !< Output Field Counter - TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< An instance of the class fms_diag_buff_intervals_t + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< The array bounds of the ofb argument. INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. - INTEGER, INTENT(inout) :: num_elements - - LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask !< mask + INTEGER, INTENT(inout) :: num_elements !< Used in counting updated buffer elements; Other functions (e.g. wrting + !!field) may nprmalize output buffer elements with the same. + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL:: mask !< The mask of the corresponding field. FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. @@ -119,8 +120,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL, INTENT(inout) :: issued_mask_ignore_warning INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on 3 axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on 3 axes for regional output - CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !!Possibly passed by the caller, and sent to error handler - CHARACTER(len=256), INTENT(inout) :: err_msg_local !!Possibly set by bounds checker, and sent to error handler + CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !< Possibly passed by the caller, and sent to error handler + CHARACTER(len=256), INTENT(inout) :: err_msg_local !< Possibly set by bounds checker, and sent to error handler INTEGER :: pow_value !< A copy of same variable in ofield_cfg CHARACTER(:), ALLOCATABLE :: output_name !< A copy of same variable in ofield_cfg @@ -205,9 +206,9 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ! Should reduced_k_range data be supported with the mask_variant option ????? ! If not, error message should be produced and the reduced_k_range loop below eliminated MASK_PR_1_IF: IF (mask_present ) THEN - MISSVAL_PR_1_IF: IF ( missvalue_present ) THEN !!(section: mask_varian .eq. true + mask present) + MISSVAL_PR_1_IF: IF ( missvalue_present ) THEN !!(section: mask_variant .eq. true + mask present) IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -382,7 +383,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END IF ELSE NDCMP_RKR_1_IF IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -498,7 +499,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END IF ELSE NDCMP_RKR_2_IF IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '') THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -647,7 +648,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL ELSE NDCMP_RKR_3_IF IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -759,7 +760,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ELSE NDCMP_RKR_4_IF IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF (fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -814,14 +815,14 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! null() !< Pointer to the field @@ -862,8 +863,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output - CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !!Possibly passed in by the caller, and sent to handler - CHARACTER(len=256), INTENT(inout) :: err_msg_local !!Possibly set by bounds checker, and sent to handler + CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !< Possibly passed in by the caller, and sent to handler + CHARACTER(len=256), INTENT(inout) :: err_msg_local !< Possibly set by bounds checker, and sent to handler LOGICAL :: succeded !< Return true iff errors are not encounterd. !! !! @@ -940,7 +941,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -978,7 +979,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1021,7 +1022,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1058,7 +1059,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1101,7 +1102,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1136,7 +1137,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1170,7 +1171,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1235,13 +1236,14 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, !> @brief This code will be used by the preprocessor to generate an implementation !! of the module procedure for the fieldbuff_copy_misvals interface. The !! generated function is a wrapper calling 4D field/5D buffer version of the same. + !! TODO (MDM) the meaning of an integer rmask has to be studied. SUBROUTINE FMS_DIAG_FBCM_3D_PNAME_ (ofield_cfg, ofield_index_cfg, ofb, sample, & & l_start, l_end, rmask, rmask_thresh, missvalue) TYPE(fmsDiagOutfield_type), INTENT(in) :: ofield_cfg !< The ofield_cfg object TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS,DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! Date: Sun, 12 Feb 2023 00:05:49 -0500 Subject: [PATCH 28/37] Fixing a line length > 120 columns. --- diag_manager/include/fms_diag_fieldbuff_update.fh | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 03080bd8c7..1aa09d0550 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -36,7 +36,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. INTEGER, INTENT(inout) :: num_elements !< Used in counting updated buffer elements; Other functions (e.g. wrting !!field) may nprmalize output buffer elements with the same. - LOGICAL, CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target :: mask !< The mask of the corresponding field. + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:), INTENT(in), OPTIONAL, target:: mask !< The mask of the corresponding field. FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight. FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. @@ -108,7 +108,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< The array bounds of the ofb argument. INTEGER, INTENT(in) :: sample !< The index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_, INTENT(inout):: count_0d !< Normally the member of the buffer object of the same name. - INTEGER, INTENT(inout) :: num_elements !< Used in counting updated buffer elements; Other functions (e.g. wrting + INTEGER, INTENT(inout):: num_elements !< Used in counting updated buffer elements; Other functions (e.g. wrting !!field) may nprmalize output buffer elements with the same. LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL:: mask !< The mask of the corresponding field. FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight @@ -814,7 +814,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !! where "cfg" is short for configuration FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:),INTENT(in),target:: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis - FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! null() !< Pointer to the field - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null() !< Pointer to the outfield buffer. + FMS_DIAG_FBU_DATA_TYPE_ , pointer,DIMENSION(:,:,:,:,:):: ofb_ptr => null() !< Pointer to the outfield buffer. LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null() !< !< Pointer to the mask. LOGICAL :: succeded !< True iff no errors encountered. @@ -1243,7 +1243,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS,DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! Date: Sun, 12 Feb 2023 21:34:47 -0500 Subject: [PATCH 29/37] Fixing typo of remaning rmaks to mask in last lint fix push. --- diag_manager/include/fms_diag_fieldbuff_update.fh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 1aa09d0550..a78ffc43db 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -1243,7 +1243,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, TYPE(fmsDiagOutfieldIndex_type) , INTENT(in) :: ofield_index_cfg !< The ofield_index_cfg object FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS,DIMENSION(:,:,:,:),INTENT(inout),target:: ofb ! Date: Sun, 12 Feb 2023 22:52:31 -0500 Subject: [PATCH 30/37] Fixing more items from PR review. --- diag_manager/fms_diag_outfield.F90 | 30 +++++++++---------- diag_manager/fms_diag_time_reduction.F90 | 3 +- .../include/fms_diag_fieldbuff_update.fh | 20 ++++++------- 3 files changed, 27 insertions(+), 26 deletions(-) diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index 840f37660a..4cb3070f7a 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -48,13 +48,13 @@ MODULE fms_diag_outfield_mod implicit none - !> @brief Class fmsDiagOutfiled_type (along with class ms_diag_outfield_index_type ) + !> @brief Class fmsDiagOutfield_type (along with class ms_diag_outfield_index_type ) !! contain information used in updating the output buffers by the diag_manager !! send_data routines. In some sense they can be seen as encapsulating related !! information in a convenient way (e.g. to pass to functions and for do loop - !! controls. + !! controls.) !! - !! Class fmsDiagOutfiled_type also contains a significant subset of the fields + !! Class fmsDiagOutfield_type also contains a significant subset of the fields !! and routines of of the legacy class output_field_type !! TODO: (MDM) This class will need further development for the modern_diag effort. !! For its development, consider the legacy diag_util::init_output_field already @@ -106,7 +106,7 @@ MODULE fms_diag_outfield_mod END TYPE fmsDiagOutfield_type - !> @brief Class fms_diag_outfield_index_type which (along with class fmsDiagOutfiled_type) + !> @brief Class fms_diag_outfield_index_type which (along with class fmsDiagOutfield_type) !! encapsulate related information used in updating the output buffers by the diag_manager !! send_data routines. This class in particular focuses on do loop index controls or settings. !! Note that the index names in this class should be indentical to the names used in the @@ -380,21 +380,21 @@ SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_presen END SUBROUTINE initialize_outfield_imp - !> @brief Initialized an fmsDiagOutfiled_type as needed for unit tests. + !> @brief Initialized an fmsDiagOutfield_type as needed for unit tests. subroutine initialize_for_ut(this, module_name, field_name, output_name, & & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & & time_reduction_type,output_freq) CLASS(fmsDiagOutfield_type), intent(inout) :: this - CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fmsDiagOutfiled_type - CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fmsDiagOutfiled_type - CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fmsDiagOutfiled_type - INTEGER, INTENT(in) :: power_val !< Var with same name in fmsDiagOutfiled_type - LOGICAL, INTENT(in) :: phys_window !< Var with same name in fmsDiagOutfiled_type - LOGICAL, INTENT(in) :: need_compute !< Var with same name in fmsDiagOutfiled_type - LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fmsDiagOutfiled_type - LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fmsDiagOutfiled_type - INTEGER, INTENT(in) :: num_elems !< Var with same name in fmsDiagOutfiled_type - INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fmsDiagOutfiled_type + CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fmsDiagOutfield_type + CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fmsDiagOutfield_type + CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: power_val !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: phys_window !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: need_compute !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: num_elems !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fmsDiagOutfield_type INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type this%module_name = module_name diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 index 83cb4d4315..307c6fe2ad 100644 --- a/diag_manager/fms_diag_time_reduction.F90 +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -97,7 +97,8 @@ function fmsDiagTimeReduction_type_constructor(dt, out_frequency) result(time_re call time_redux%initialize(dt, out_frequency) end function fmsDiagTimeReduction_type_constructor - !> @brief Initialize the object. + !> @brief Initialize the object. As an alternative to the constructor, one can + !! allocate an fmsDiagTimeReduction_type instance, then call its initialize function. subroutine initialize(this, dt, out_frequency) class (fmsDiagTimeReduction_type), intent(inout) :: this !< The fmsDiagTimeReduction_type object integer, intent(in) :: dt !< The redution type (time_rms, time_porer, etc) diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index a78ffc43db..a70184c4fd 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -46,8 +46,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL, INTENT(inout) :: issued_mask_ignore_warning INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on 3 axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on 3 axes for regional output - CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !< Possibly passed in by the caller, and sent to error handler - CHARACTER(len=256), INTENT(inout) :: err_msg_local !< Possibly set by bounds checker, and sent to error handler + CHARACTER(len=*), INTENT(out),OPTIONAL::err_msg !< Possibly passed in by the caller, and sent to error handler + CHARACTER(len=256), INTENT(out) :: err_msg_local !< Possibly set by bounds checker, and sent to error handler !!TODO: can the use of a dummy be removed. FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),target :: ofc_dummy @@ -120,8 +120,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL, INTENT(inout) :: issued_mask_ignore_warning INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on 3 axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on 3 axes for regional output - CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !< Possibly passed by the caller, and sent to error handler - CHARACTER(len=256), INTENT(inout) :: err_msg_local !< Possibly set by bounds checker, and sent to error handler + CHARACTER(len=*), INTENT(out),OPTIONAL::err_msg !< Possibly passed by the caller, and sent to error handler + CHARACTER(len=256), INTENT(out) :: err_msg_local !< Possibly set by bounds checker, and sent to error handler INTEGER :: pow_value !< A copy of same variable in ofield_cfg CHARACTER(:), ALLOCATABLE :: output_name !< A copy of same variable in ofield_cfg @@ -821,8 +821,8 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output - CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !< Possibly passed in by the caller,and sent to handler - CHARACTER(len=256), INTENT(inout) :: err_msg_local !< Possibly set by bounds checker, and sent to handler + CHARACTER(len=*), INTENT(out),OPTIONAL::err_msg !< Possibly passed in by the caller,and sent to handler + CHARACTER(len=256), INTENT(out) :: err_msg_local !< Possibly set by bounds checker, and sent to handler !! For pointer bounds remapping FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null() !< Pointer to the field @@ -863,8 +863,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output - CHARACTER(len=*), INTENT(inout),OPTIONAL::err_msg !< Possibly passed in by the caller, and sent to handler - CHARACTER(len=256), INTENT(inout) :: err_msg_local !< Possibly set by bounds checker, and sent to handler + CHARACTER(len=*), INTENT(out),OPTIONAL::err_msg !< Possibly passed in by the caller, and sent to handler + CHARACTER(len=256), INTENT(out) :: err_msg_local !< Possibly set by bounds checker, and sent to handler LOGICAL :: succeded !< Return true iff errors are not encounterd. !! !! @@ -1287,8 +1287,8 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, !< Looping indices copied from corresponding one in ofield_index_cfg info: INTEGER :: is, js, ks, ie, je, ke, hi, hj !< Floags copied from corresponding one in ofield_cfg info: - LOGICAL :: need_compute - LOGICAL :: reduced_k_range + LOGICAL :: need_compute !< A copy of same variable in ofield_cfg + LOGICAL :: reduced_k_range !< A copy of same variable in ofield_cfg INTEGER :: ksr, ker !< Loop indices used in reduced_k_range calculations !< Looping indices, derived from ofield_index_cfg info: INTEGER :: i, j, k, i1, j1, k1 From 95e5e2cbec205aaf76b28578736178c8f0d2aa7b Mon Sep 17 00:00:00 2001 From: ngs333 Date: Mon, 13 Feb 2023 00:06:11 -0500 Subject: [PATCH 31/37] Localized used of dummy arrays for pointer_bounds_remapping issue into fms_diag_fieldbuff_update.fh; and added TODO: with explanation. Added to diag manager namelist. Fixed some comments as per PR review. --- diag_manager/diag_data.F90 | 2 -- diag_manager/diag_manager.F90 | 16 +++------- .../include/fms_diag_fieldbuff_update.fh | 32 +++++++++++++++---- 3 files changed, 30 insertions(+), 20 deletions(-) diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 7cd701ba69..1fa64f92f6 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -347,8 +347,6 @@ MODULE diag_data_mod LOGICAL :: use_mpp_io = .false. !< false is fms2_io (default); true is mpp_io LOGICAL :: use_refactored_send = .false. !< Namelist flag to use refactored send_data math funcitons. - !!TODO: leave use_refactored_send as false - ! #ifdef use_netCDF diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 7dc5100206..23b7d62406 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1491,12 +1491,12 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 => null() !< A pointer to r4 type of rmask REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 => null() ! null() !< A pointer to mask + !!LOGICAL , pointer, DIMENSION(:,:,:) :: mask_ptr => null() !< A pointer to mask TYPE(fmsDiagOutfieldIndex_type), ALLOCATABLE:: ofield_index_cfg ! mask - else - mask_ptr(1:size(mask_dummy,1),1:size(mask_dummy,2),1:size(mask_dummy,3)) => mask_dummy - ENDIF - IF ( average ) THEN !!TODO (Future work): the copy that is filed_out should not be necessary mf_result = fieldbuff_update(ofield_cfg, ofield_index_cfg, field_out, sample, & & output_fields(out_num)%buffer, output_fields(out_num)%counter ,output_fields(out_num)%buff_bounds,& & output_fields(out_num)%count_0d(sample), output_fields(out_num)%num_elements(sample), & - & mask_ptr, weight1 ,missvalue, & + & mask, weight1 ,missvalue, & & input_fields(diag_field_id)%numthreads, input_fields(diag_field_id)%active_omp_level,& & input_fields(diag_field_id)%issued_mask_ignore_warning, & & l_start, l_end, err_msg, err_msg_local ) @@ -1926,7 +1920,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & mf_result = fieldbuff_copy_fieldvals(ofield_cfg, ofield_index_cfg, field_out, sample, & & output_fields(out_num)%buffer, output_fields(out_num)%buff_bounds , & & output_fields(out_num)%count_0d(sample), & - & mask_ptr, missvalue, l_start, l_end, err_msg, err_msg_local) + & mask, missvalue, l_start, l_end, err_msg, err_msg_local) IF (mf_result .eqv. .FALSE.) THEN DEALLOCATE(ofield_index_cfg) DEALLOCATE(ofield_cfg) @@ -3765,7 +3759,7 @@ SUBROUTINE diag_manager_init(diag_model_subset, time_init, err_msg) & max_input_fields, max_axes, do_diag_field_log, write_bytes_in_file, debug_diag_manager,& & max_num_axis_sets, max_files, use_cmor, issue_oor_warnings,& & oor_warnings_fatal, max_out_per_in_field, flush_nc_files, region_out_use_alt_value, max_field_attributes,& - & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io + & max_file_attributes, max_axis_attributes, prepend_date, use_mpp_io, use_refactored_send ! If the module was already initialized do nothing IF ( module_is_initialized ) RETURN diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index a70184c4fd..d3df9d6af0 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -49,8 +49,15 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & CHARACTER(len=*), INTENT(out),OPTIONAL::err_msg !< Possibly passed in by the caller, and sent to error handler CHARACTER(len=256), INTENT(out) :: err_msg_local !< Possibly set by bounds checker, and sent to error handler - !!TODO: can the use of a dummy be removed. - FMS_DIAG_FBU_DATA_TYPE_ , ALLOCATABLE, DIMENSION(:,:,:,:),target :: ofc_dummy + LOGICAL :: succeded !< True iff no errors encountered. + + !!TODO: Can the two dummy variables below be removed. The variables were introduced because of pointer + !! bounds remapping to call the next routine. Note that mask is an optional argument, and ofc might not + !! have been allocated. The program hangs if the approach of having pointers to the dummy arrays are not used. + !! Also note that a sepeate logical field (in fmsDiagOutfield_type, but was used in + !! the legacy diag manager also) is used to determine "if the mask was preent"! + FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(1),target :: ofc_dummy + LOGICAL, DIMENSION(1), target :: mask_dummy !! For pointer bounds remapping FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null()!< Pointer to the field @@ -58,7 +65,6 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr => null()!< Pointer to the outfield counter. LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null()!< Pointer to the mask. - LOGICAL :: succeded !< True iff no errors encountered. field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3),1:1, 1:size(ofb,4)) => ofb @@ -67,14 +73,17 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & if(allocated(ofc)) then ofc_ptr(1:size(ofc,1),1:size(ofc,2),1:size(ofc,3), 1:1, 1:size(ofc,4)) => ofc else - allocate(ofc_dummy(1,1,1,1)) - ofc_ptr(1:1,1:1,1:1, 1:1,1:1) => ofc_dummy + ofc_ptr(1:1,1:1,1:1,1:1,1:1) => ofc_dummy endif IF (PRESENT (mask)) THEN mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ELSE + mask_ptr(1:1,1:1,1:1,1:1) => mask_dummy ENDIF + + succeded = FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & & ofb_ptr, ofc_ptr, bbounds, count_0d, num_elements, mask_ptr, weight1, missvalue, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & @@ -824,18 +833,27 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & CHARACTER(len=*), INTENT(out),OPTIONAL::err_msg !< Possibly passed in by the caller,and sent to handler CHARACTER(len=256), INTENT(out) :: err_msg_local !< Possibly set by bounds checker, and sent to handler + LOGICAL :: succeded !< True iff no errors encountered. + + !!TODO: Can the dummy variable array below be removed. The variable was introduced because of pointer + !! bounds remapping to call the next routine. Note that mask is an optional argument. + !! The program hangs if the approach of having a pointer to the dummy array is not used. + !! Also note that a seperate logical field (in fmsDiagOutfield_type, but was used in + !! the legacy diag manager also) is used to determine "if the mask was preent"! + LOGICAL, DIMENSION(1,1,1,1), target :: mask_dummy + !! For pointer bounds remapping FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null() !< Pointer to the field FMS_DIAG_FBU_DATA_TYPE_ , pointer,DIMENSION(:,:,:,:,:):: ofb_ptr => null() !< Pointer to the outfield buffer. LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null() !< !< Pointer to the mask. - LOGICAL :: succeded !< True iff no errors encountered. - field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field(:,:,:) ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:1, 1:size(ofb,4)) => ofb IF (PRESENT (mask)) THEN mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask + ELSE + mask_ptr(1:1,1:1,1:1,1:1) => mask_dummy ENDIF succeded = FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & From 3a0a6749fdda8c73c6fab37838946e55993501d2 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Mon, 13 Feb 2023 22:59:21 -0500 Subject: [PATCH 32/37] Fixing whitespace at end of file lint error; reformatting two files to project standard. --- diag_manager/fms_diag_outfield.F90 | 88 +++---- diag_manager/fms_diag_time_reduction.F90 | 307 ++++++++++++----------- 2 files changed, 198 insertions(+), 197 deletions(-) diff --git a/diag_manager/fms_diag_outfield.F90 b/diag_manager/fms_diag_outfield.F90 index 4cb3070f7a..52762516ac 100644 --- a/diag_manager/fms_diag_outfield.F90 +++ b/diag_manager/fms_diag_outfield.F90 @@ -61,7 +61,7 @@ MODULE fms_diag_outfield_mod !! in place. Fields added so are used the the field buffer math/dmUpdate functions. !> @ingroup fms_diag_outfield_mod TYPE, public :: fmsDiagOutfield_type - PRIVATE + PRIVATE CHARACTER(len=:), ALLOCATABLE :: module_name !< Module name. CHARACTER(len=:), ALLOCATABLE :: field_name !< Output field name. CHARACTER(len=:), ALLOCATABLE :: output_name !< Output name written to file. @@ -88,21 +88,21 @@ MODULE fms_diag_outfield_mod !! gcc error: Interface ‘addwf’ at (1) must be explicit ! procedure (addwf), pointer, nopass :: f_ptr => null () !!A pointer to the field weighing procedure - CONTAINS - procedure :: get_module_name - procedure :: get_field_name - procedure :: get_output_name - procedure :: get_output_file - procedure :: get_pow_value - procedure :: get_phys_window - procedure :: get_need_compute - procedure :: get_reduced_k_range - procedure :: get_missvalue_present - procedure :: get_mask_variant - procedure :: get_mask_present - procedure :: get_time_reduction - procedure, public :: initialize => initialize_outfield_imp - procedure :: initialize_for_ut + CONTAINS + procedure :: get_module_name + procedure :: get_field_name + procedure :: get_output_name + procedure :: get_output_file + procedure :: get_pow_value + procedure :: get_phys_window + procedure :: get_need_compute + procedure :: get_reduced_k_range + procedure :: get_missvalue_present + procedure :: get_mask_variant + procedure :: get_mask_present + procedure :: get_time_reduction + procedure, public :: initialize => initialize_outfield_imp + procedure :: initialize_for_ut END TYPE fmsDiagOutfield_type @@ -119,9 +119,9 @@ MODULE fms_diag_outfield_mod INTEGER :: f1,f2 !< Indecies used specify 1st dim bounds of field, mask and rmask. INTEGER :: f3,f4 !< Indecies used specify 2st dim bounds of field, mask and rmask. INTEGER :: is, js, ks !< Start indecies in each spatial dim of the field_data; and - !! may be user provided in send_data + !! may be user provided in send_data Integer :: ie, je, ke !< End indecies in each spatial dim of the field_data; and - !! may be user provided in send_data + !! may be user provided in send_data INTEGER :: hi !< halo size in x direction. Same name as in send_data INTEGER :: hj !< halo size in y direction. Same CONTAINS @@ -380,32 +380,32 @@ SUBROUTINE initialize_outfield_imp(this, input_field, output_field, mask_presen END SUBROUTINE initialize_outfield_imp - !> @brief Initialized an fmsDiagOutfield_type as needed for unit tests. + !> @brief Initialized an fmsDiagOutfield_type as needed for unit tests. subroutine initialize_for_ut(this, module_name, field_name, output_name, & - & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & - & time_reduction_type,output_freq) - CLASS(fmsDiagOutfield_type), intent(inout) :: this - CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fmsDiagOutfield_type - CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fmsDiagOutfield_type - CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fmsDiagOutfield_type - INTEGER, INTENT(in) :: power_val !< Var with same name in fmsDiagOutfield_type - LOGICAL, INTENT(in) :: phys_window !< Var with same name in fmsDiagOutfield_type - LOGICAL, INTENT(in) :: need_compute !< Var with same name in fmsDiagOutfield_type - LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fmsDiagOutfield_type - LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fmsDiagOutfield_type - INTEGER, INTENT(in) :: num_elems !< Var with same name in fmsDiagOutfield_type - INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fmsDiagOutfield_type - INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type - - this%module_name = module_name - this%field_name = field_name - this%output_name = output_name - this%pow_value = power_val - this%phys_window = phys_window - this%need_compute = need_compute - this%reduced_k_range = reduced_k_range - this%mask_variant = mask_variant - call this%time_reduction%initialize(time_reduction_type, output_freq) + & power_val, phys_window, need_compute, mask_variant, reduced_k_range, num_elems, & + & time_reduction_type,output_freq) + CLASS(fmsDiagOutfield_type), intent(inout) :: this + CHARACTER(len=*), INTENT(in) :: module_name !< Var with same name in fmsDiagOutfield_type + CHARACTER(len=*), INTENT(in) :: field_name !< Var with same name in fmsDiagOutfield_type + CHARACTER(len=*), INTENT(in) :: output_name !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: power_val !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: phys_window !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: need_compute !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: mask_variant !< Var with same name in fmsDiagOutfield_type + LOGICAL, INTENT(in) :: reduced_k_range !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: num_elems !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: time_reduction_type !< Var with same name in fmsDiagOutfield_type + INTEGER, INTENT(in) :: output_freq !< The output_freq need in initaliztion of time_reduction_type + + this%module_name = module_name + this%field_name = field_name + this%output_name = output_name + this%pow_value = power_val + this%phys_window = phys_window + this%need_compute = need_compute + this%reduced_k_range = reduced_k_range + this%mask_variant = mask_variant + call this%time_reduction%initialize(time_reduction_type, output_freq) end subroutine initialize_for_ut !> @brief Reset the time reduction member field. Intended for use in unit tests only. @@ -413,7 +413,7 @@ SUBROUTINE reset_time_reduction_ut(this, source ) CLASS(fmsDiagOutfield_type), INTENT(inout) :: this !< An instance of the fmsDiagOutfield_type TYPE(fmsDiagTimeReduction_type) :: source !< The fmsDiagTimeReduction_type to copy from call this%time_reduction%copy(source) - END SUBROUTINE reset_time_reduction_ut + END SUBROUTINE reset_time_reduction_ut diff --git a/diag_manager/fms_diag_time_reduction.F90 b/diag_manager/fms_diag_time_reduction.F90 index 307c6fe2ad..78de19a25a 100644 --- a/diag_manager/fms_diag_time_reduction.F90 +++ b/diag_manager/fms_diag_time_reduction.F90 @@ -33,71 +33,73 @@ MODULE fms_diag_time_reduction_mod USE diag_data_mod, only: EVERY_TIME USE fms_mod, ONLY: error_mesg, FATAL - implicit none - - !!These parametes are the possible kinds of time reduction operations. - !!TODO: should they be put in diag_data ? - !!TODO: - !!TODO: time_diurnal "not really" same kind as others, so remove? - INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method - INTEGER, PARAMETER :: time_average = 1 !< The reduction method is average - INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms - INTEGER, PARAMETER :: time_max = 3 !< The reduction method is max - INTEGER, PARAMETER :: time_min = 4 !< The reduction method is min - INTEGER, PARAMETER :: time_sum = 5 !< The reudction method is sum - INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal - INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power - -!> @brief Class fmsDiagTimeReduction_type has an encapsulation of the "Fortran enum" time -!! reduction integer parameters, plus an encapsulation of the groupings of -!! the time reduction types. It is intended to provide some of the functionality -!! that was coded in the legacy function diag_data.F90:init_output_fields. -!! The functionality in the end is used by send_data in (EFFICIENT) do loops calling -!! the weighting or math functions to update buffers. -!! The integer parameters above are the legal time reduction types, -!! but they are not necessarily mutually exclusive in some contexts. -!! -!> @addtogroup fms_diag_time_reduction_mod - TYPE fmsDiagTimeReduction_type - integer , private :: the_time_reduction !< The time reduction type, as an integer defined above. - logical , private :: time_averaging !< Set true iff time_average, time_rms, time_power or time_diurnal is true - logical , private :: time_ops !< Set true iff time_min, time_max, time_rms or time_average is true. + implicit none + + !!TODO: (Future effort) Note that time_diurnal processing is a little different + !! and more complex than the other reduction methods, and therefore refactoring its + !! processing may simplify the overall related codebase. The refactoring, + !! if possible, may be done elsewhere in the diag_manager. + + !!These parametes are the possible kinds of time reduction operations. + INTEGER, PARAMETER :: time_none = 0 !< There is no reduction method + INTEGER, PARAMETER :: time_average = 1 !< The reduction method is average + INTEGER, PARAMETER :: time_rms = 2 !< The reduction method is rms + INTEGER, PARAMETER :: time_max = 3 !< The reduction method is max + INTEGER, PARAMETER :: time_min = 4 !< The reduction method is min + INTEGER, PARAMETER :: time_sum = 5 !< The reudction method is sum + INTEGER, PARAMETER :: time_diurnal = 6 !< The reduction method is diurnal + INTEGER, PARAMETER :: time_power = 7 !< The reduction method is power + + !> @brief Class fmsDiagTimeReduction_type has an encapsulation of the "Fortran enum" time + !! reduction integer parameters, plus an encapsulation of the groupings of + !! the time reduction types. It is intended to provide some of the functionality + !! that was coded in the legacy function diag_data.F90:init_output_fields. + !! The functionality in the end is used by send_data in (EFFICIENT) do loops calling + !! the weighting or math functions to update buffers. + !! The integer parameters above are the legal time reduction types, + !! but they are not necessarily mutually exclusive in some contexts. + !! + !> @addtogroup fms_diag_time_reduction_mod + TYPE fmsDiagTimeReduction_type + integer , private :: the_time_reduction !< The time reduction type, as an integer defined above. + logical , private :: time_averaging !< Set true iff time_average, time_rms, time_power or time_diurnal is true + logical , private :: time_ops !< Set true iff time_min, time_max, time_rms or time_average is true. CONTAINS - procedure, public :: do_time_averaging => do_time_averaging_imp - procedure, public :: has_time_ops => has_time_ops_imp - procedure, public :: is_time_none => is_time_none_imp - procedure, public :: is_time_average => is_time_average_imp - procedure, public :: is_time_rms => is_time_rms_imp - procedure, public :: is_time_max => is_time_max_imp - procedure, public :: is_time_min => is_time_min_imp - procedure, public :: is_time_sum => is_time_sum_imp - procedure, public :: is_time_diurnal => is_time_diurnal_imp - procedure, public :: is_time_power => is_time_power_imp - procedure, public :: initialize - procedure, public :: copy - END TYPE fmsDiagTimeReduction_type - -!> @brief This interface is for the class constructor. -!> @addtogroup fms_diag_time_reduction_mod - interface fmsDiagTimeReduction_type - procedure :: fmsDiagTimeReduction_type_constructor - end interface fmsDiagTimeReduction_type + procedure, public :: do_time_averaging => do_time_averaging_imp + procedure, public :: has_time_ops => has_time_ops_imp + procedure, public :: is_time_none => is_time_none_imp + procedure, public :: is_time_average => is_time_average_imp + procedure, public :: is_time_rms => is_time_rms_imp + procedure, public :: is_time_max => is_time_max_imp + procedure, public :: is_time_min => is_time_min_imp + procedure, public :: is_time_sum => is_time_sum_imp + procedure, public :: is_time_diurnal => is_time_diurnal_imp + procedure, public :: is_time_power => is_time_power_imp + procedure, public :: initialize + procedure, public :: copy + END TYPE fmsDiagTimeReduction_type + + !> @brief This interface is for the class constructor. + !> @addtogroup fms_diag_time_reduction_mod + interface fmsDiagTimeReduction_type + procedure :: fmsDiagTimeReduction_type_constructor + end interface fmsDiagTimeReduction_type CONTAINS - !> @brief The class contructors. Just allocates the class and calls an initializer - !! @return An allocated instance of fmsDiagTimeReduction_type, which is nitialized using - !! provided values for arguments dt and out_freqeuncy. - function fmsDiagTimeReduction_type_constructor(dt, out_frequency) result(time_redux) - integer, intent(in) :: dt !< The redution type (time_rms, time_power, etc) - integer, intent(in) :: out_frequency !< The output frequency. - class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type - !!class allocated and returned by this constructor. - allocate(time_redux) - call time_redux%initialize(dt, out_frequency) - end function fmsDiagTimeReduction_type_constructor - - !> @brief Initialize the object. As an alternative to the constructor, one can + !> @brief The class contructors. Just allocates the class and calls an initializer + !! @return An allocated instance of fmsDiagTimeReduction_type, which is nitialized using + !! provided values for arguments dt and out_freqeuncy. + function fmsDiagTimeReduction_type_constructor(dt, out_frequency) result(time_redux) + integer, intent(in) :: dt !< The redution type (time_rms, time_power, etc) + integer, intent(in) :: out_frequency !< The output frequency. + class (fmsDiagTimeReduction_type), allocatable :: time_redux !< The instance of the fmsDiagTimeReduction_type + !!class allocated and returned by this constructor. + allocate(time_redux) + call time_redux%initialize(dt, out_frequency) + end function fmsDiagTimeReduction_type_constructor + + !> @brief Initialize the object. As an alternative to the constructor, one can !! allocate an fmsDiagTimeReduction_type instance, then call its initialize function. subroutine initialize(this, dt, out_frequency) class (fmsDiagTimeReduction_type), intent(inout) :: this !< The fmsDiagTimeReduction_type object @@ -108,27 +110,27 @@ subroutine initialize(this, dt, out_frequency) !! Set the time_averaging flag !! See legacy init_ouput_fields function, lines 1470ff - IF(( dt .EQ. time_average) .OR. (dt .EQ. time_rms) .OR. (dt .EQ. time_power) .OR. & - & (dt .EQ. time_diurnal)) THEN - this%time_averaging = .true. - ELSE - this%time_averaging= .false. - IF((dt .NE. time_max) .AND. (dt .ne. time_min) .AND. (dt .NE. time_sum) & - & .AND. (dt .NE. time_none)) THEN - CALL error_mesg('fmsDiagTimeReduction_type: initialize', & - & 'time_averaging=.false. but reduction type not compatible', FATAL) - ENDIF - END IF - - !!TODO: (MDM) Add other checks? E.g. If time_averaging == .false., then - !! out_frequency == EVERY_TIME - - IF((dt .EQ. time_min) .OR. (dt .EQ. time_max) .OR. & - & ( dt .EQ. time_average) .OR. (dt .EQ. time_sum) ) THEN - this%time_ops = .true. - ELSE - this%time_ops = .false. - END IF + IF(( dt .EQ. time_average) .OR. (dt .EQ. time_rms) .OR. (dt .EQ. time_power) .OR. & + & (dt .EQ. time_diurnal)) THEN + this%time_averaging = .true. + ELSE + this%time_averaging= .false. + IF((dt .NE. time_max) .AND. (dt .ne. time_min) .AND. (dt .NE. time_sum) & + & .AND. (dt .NE. time_none)) THEN + CALL error_mesg('fmsDiagTimeReduction_type: initialize', & + & 'time_averaging=.false. but reduction type not compatible', FATAL) + ENDIF + END IF + + !!TODO: (MDM) Add other checks? E.g. If time_averaging == .false., then + !! out_frequency == EVERY_TIME + + IF((dt .EQ. time_min) .OR. (dt .EQ. time_max) .OR. & + & ( dt .EQ. time_average) .OR. (dt .EQ. time_sum) ) THEN + this%time_ops = .true. + ELSE + this%time_ops = .false. + END IF end subroutine initialize !> @brief Copy the source time reduction object into the this object. @@ -148,78 +150,77 @@ pure function has_time_ops_imp (this) has_time_ops_imp = this%time_ops end function has_time_ops_imp - !> \brief Returns true iff time_averaging is true. - !! @return true iff time_averaging is true. - pure function do_time_averaging_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_average - !! @return true iff the_time_reduction is time_average - pure function is_time_average_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_none - !! @return true iff the_time_reduction is time_none - pure function is_time_none_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_rms - !! @return true iff the_time_reduction is time_rms - pure function is_time_rms_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_max - !! @return true iff the_time_reduction is time_max - pure function is_time_max_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_min - !! @return true iff the_time_reduction is time_min - pure function is_time_min_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_sum - !! @return true iff the_time_reduction is time_sum - pure function is_time_sum_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_diurnal - !! @return true iff the_time_reduction is time_diurnal - pure function is_time_diurnal_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_power - !! @return true iff the_time_reduction is time_power - pure function is_time_power_imp (this) - class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff time_averaging is true. + !! @return true iff time_averaging is true. + pure function do_time_averaging_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_average + !! @return true iff the_time_reduction is time_average + pure function is_time_average_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_none + !! @return true iff the_time_reduction is time_none + pure function is_time_none_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_rms + !! @return true iff the_time_reduction is time_rms + pure function is_time_rms_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_max + !! @return true iff the_time_reduction is time_max + pure function is_time_max_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_min + !! @return true iff the_time_reduction is time_min + pure function is_time_min_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_sum + !! @return true iff the_time_reduction is time_sum + pure function is_time_sum_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_diurnal + !! @return true iff the_time_reduction is time_diurnal + pure function is_time_diurnal_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! \brief Returns true iff the_time_reduction is time_power + !! @return true iff the_time_reduction is time_power + pure function is_time_power_imp (this) + class (fmsDiagTimeReduction_type), intent(in) :: this ! @} From f2b5b6dfd78e6d5df350e9ac28ba331562500cc9 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Wed, 22 Feb 2023 12:37:42 -0500 Subject: [PATCH 33/37] Updates based on latest review comments, mostly making private the data members of fmsDiagIbounds_type. --- diag_manager/diag_data.F90 | 114 +++++++++++++++++- diag_manager/diag_util.F90 | 103 +++++----------- diag_manager/fms_diag_fieldbuff_update.F90 | 3 +- diag_manager/fms_diag_outfield.F90 | 1 + .../include/fms_diag_fieldbuff_update.fh | 53 ++++---- 5 files changed, 166 insertions(+), 108 deletions(-) diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index 1fa64f92f6..b4cc54a3e9 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -131,6 +131,7 @@ MODULE diag_data_mod !> @brief Data structure holding intervals (or interval bounds or limits). !! Used for checking the bounds of the field output buffer arrays. TYPE, public :: fmsDiagIbounds_type +PRIVATE INTEGER :: imin !< Lower i bound. INTEGER :: imax !< Upper i bound. INTEGER :: jmin !< Lower j bound. @@ -138,9 +139,23 @@ MODULE diag_data_mod INTEGER :: kmin !< Lower k bound. INTEGER :: kmax !< Upper k bound. contains - procedure :: reset => ibounds_reset + procedure :: reset => reset_bounds + procedure :: reset_bounds_from_array_4D + procedure :: reset_bounds_from_array_5D + procedure :: update_bounds + procedure :: get_imin + procedure :: get_imax + procedure :: get_jmin + procedure :: get_jmax + procedure :: get_kmin + procedure :: get_kmax END TYPE fmsDiagIbounds_type +!INTERFACE fms_diag_bounds_from_array +!module procedure bounds_from_array_4D +!module procedure bounds_from_array_5D +!END INTERFACE fms_diag_bounds_from_array + @@ -403,9 +418,51 @@ SUBROUTINE diag_data_init() call write_version_number("DIAG_DATA_MOD", version) END SUBROUTINE diag_data_init - - !> @brief Sets the lower and upper bounds to lower_val and upper_val, respectively. - SUBROUTINE ibounds_reset (this, lower_val, upper_val) + !> @brief Gets imin of fmsDiagIbounds_type + !! @return copy of integer member imin + pure integer function get_imin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%imin + end function get_imin + + !> @brief Gets imax of fmsDiagIbounds_type + !! @return copy of integer member imax + pure integer function get_imax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%imax + end function get_imax + + !> @brief Gets jmin of fmsDiagIbounds_type + !! @return copy of integer member jmin + pure integer function get_jmin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%jmin + end function get_jmin + + !> @brief Gets jmax of fmsDiagIbounds_type + !! @return copy of integer member jmax + pure integer function get_jmax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%jmax + end function get_jmax + + + !> @brief Gets kmin of fmsDiagIbounds_type + !! @return copy of integer member kmin + pure integer function get_kmin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%kmin + end function get_kmin + + !> @brief Gets kmax of fmsDiagIbounds_type + !! @return copy of integer member kmax + pure integer function get_kmax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%kmax + end function get_kmax + + !> @brief Reset the instance bounding lower and upper bounds to lower_val and upper_val, respectively. + SUBROUTINE reset_bounds (this, lower_val, upper_val) class (fmsDiagIbounds_type), target, intent(inout) :: this !< ibounds instance integer, intent(in) :: lower_val !< value for the lower bounds in each dimension integer, intent(in) :: upper_val !< value for the upper bounds in each dimension @@ -415,7 +472,54 @@ SUBROUTINE ibounds_reset (this, lower_val, upper_val) this%imax = upper_val this%jmax = upper_val this%kmax = upper_val - END SUBROUTINE ibounds_reset + END SUBROUTINE reset_bounds + + !> @brief Update the the first three (normally x, y, and z) min and + !! max boundaries (array indices) of the instance bounding box + !! the six specified bounds values. + SUBROUTINE update_bounds(this, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) + CLASS (fmsDiagIbounds_type), intent(inout) :: this ! @brief Reset the instance bounding box with the bounds determined from the + !! first three dimensions of the 5D "array" argument + SUBROUTINE reset_bounds_from_array_4D(this, array) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. + REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. + this%imin = LBOUND(array,1) + this%imax = UBOUND(array,1) + this%jmin = LBOUND(array,2) + this%jmax = UBOUND(array,2) + this%kmin = LBOUND(array,3) + this%kmax = UBOUND(array,3) + END SUBROUTINE reset_bounds_from_array_4D + + !> @brief Reset the instance bounding box with the bounds determined from the + !! first three dimensions of the 5D "array" argument + SUBROUTINE reset_bounds_from_array_5D(this, array) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. + CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 5D input array. + this%imin = LBOUND(array,1) + this%imax = UBOUND(array,1) + this%jmin = LBOUND(array,2) + this%jmax = UBOUND(array,2) + this%kmin = LBOUND(array,3) + this%kmax = UBOUND(array,3) + END SUBROUTINE reset_bounds_from_array_5D + + END MODULE diag_data_mod !> @} diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 7e67bb1d1d..01038ca4c0 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -82,7 +82,7 @@ MODULE diag_util_mod & check_duplicate_output_fields, get_date_dif, get_subfield_vert_size, sync_file_times,& & prepend_attribute, attribute_init, diag_util_init,& & update_bounds, check_out_of_bounds, check_bounds_are_exact_dynamic, check_bounds_are_exact_static,& - & fms_diag_bounds_from_array, fms_diag_check_out_of_bounds, fms_diag_update_bounds, & + & fms_diag_check_out_of_bounds, & & fms_diag_check_bounds_are_exact_dynamic, fms_diag_check_bounds_are_exact_static @@ -105,10 +105,6 @@ MODULE diag_util_mod module procedure fms_diag_check_out_of_bounds_r8 END INTERFACE fms_diag_check_out_of_bounds - INTERFACE fms_diag_bounds_from_array - module procedure bounds_from_array_4D - module procedure bounds_from_array_5D - END INTERFACE fms_diag_bounds_from_array !> @addtogroup diag_util_mod !> @{ @@ -741,31 +737,7 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& & TRIM(axes_list) END SUBROUTINE log_diag_field_info - !> @brief Determine the bounds of the first three dimensions - !! of the "array" argument and store it the bounding box argument "bounds" - SUBROUTINE bounds_from_array_4D(bounds, array) - REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. - TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. - bounds%imin = LBOUND(array,1) - bounds%imax = UBOUND(array,1) - bounds%jmin = LBOUND(array,2) - bounds%jmax = UBOUND(array,2) - bounds%kmin = LBOUND(array,3) - bounds%kmax = UBOUND(array,3) - END SUBROUTINE bounds_from_array_4D - - !> @brief Determine the bounds of the first three dimensions - !! of the "array" argument and store it the bounding box argument "bounds" - SUBROUTINE bounds_from_array_5D(bounds, array) - CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 5D input array. - TYPE (fmsDiagIbounds_type), INTENT(inout) :: bounds !< The instance of the bounding box. - bounds%imin = LBOUND(array,1) - bounds%imax = UBOUND(array,1) - bounds%jmin = LBOUND(array,2) - bounds%jmax = UBOUND(array,2) - bounds%kmin = LBOUND(array,3) - bounds%kmax = UBOUND(array,3) - END SUBROUTINE bounds_from_array_5D + !> @brief Update the output_fields x, y, and z min and max boundaries (array indices) !! with the six specified bounds values. @@ -777,28 +749,11 @@ SUBROUTINE update_bounds(out_num, lower_i, upper_i, lower_j, upper_j, lower_k, u INTEGER, INTENT(in) :: upper_j !< Upper j bound. INTEGER, INTENT(in) :: lower_k !< Lower k bound. INTEGER, INTENT(in) :: upper_k !< Upper k bound. - CALL fms_diag_update_bounds(output_fields(out_num)%buff_bounds, & - & lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) + CALL output_fields(out_num)%buff_bounds%update_bounds & + & ( lower_i, upper_i, lower_j, upper_j, lower_k, upper_k ) END SUBROUTINE update_bounds - !> @brief Update the the first three (normally x, y, and z) min and - !! max boundaries (array indices) of the input bounding box "bounds" with - !! the six specified bounds values. -SUBROUTINE fms_diag_update_bounds(bounds, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) - TYPE (fmsDiagIbounds_type), intent(inout) :: bounds ! @brief Compares the bounding indices of an array specified in "current_bounds" !! to the corresponding lower and upper bounds specified in "bounds" @@ -831,26 +786,26 @@ END FUNCTION upperb_comp compare_buffer_bounds_to_size = .FALSE. - IF (lowerb_comp( bounds%imin , current_bounds%imin) .OR. & - upperb_comp( bounds%imax , current_bounds%imax).OR.& - lowerb_comp( bounds%jmin , current_bounds%jmin) .OR.& - upperb_comp( bounds%jmax , current_bounds%jmax) .OR.& - lowerb_comp( bounds%kmin , current_bounds%kmin) .OR.& - upperb_comp( bounds%kmax , current_bounds%kmax)) THEN + IF (lowerb_comp( bounds%get_imin() , current_bounds%get_imin()) .OR. & + upperb_comp( bounds%get_imax() , current_bounds%get_imax()).OR.& + lowerb_comp( bounds%get_jmin() , current_bounds%get_jmin()) .OR.& + upperb_comp( bounds%get_jmax() , current_bounds%get_jmax()) .OR.& + lowerb_comp( bounds%get_kmin() , current_bounds%get_kmin()) .OR.& + upperb_comp( bounds%get_kmax() , current_bounds%get_kmax())) THEN compare_buffer_bounds_to_size = .TRUE. error_str ='Buffer bounds= : , : , : Actual bounds= : , : , : ' - WRITE(error_str(15:17),'(i3)') current_bounds%imin - WRITE(error_str(19:21),'(i3)') current_bounds%imax - WRITE(error_str(23:25),'(i3)') current_bounds%jmin - WRITE(error_str(27:29),'(i3)') current_bounds%jmax - WRITE(error_str(31:33),'(i3)') current_bounds%kmin - WRITE(error_str(35:37),'(i3)') current_bounds%kmax - WRITE(error_str(54:56),'(i3)') bounds%imin - WRITE(error_str(58:60),'(i3)') bounds%imax - WRITE(error_str(62:64),'(i3)') bounds%jmin - WRITE(error_str(66:68),'(i3)') bounds%jmax - WRITE(error_str(70:72),'(i3)') bounds%kmin - WRITE(error_str(74:76),'(i3)') bounds%kmax + WRITE(error_str(15:17),'(i3)') current_bounds%get_imin() + WRITE(error_str(19:21),'(i3)') current_bounds%get_imax() + WRITE(error_str(23:25),'(i3)') current_bounds%get_jmin() + WRITE(error_str(27:29),'(i3)') current_bounds%get_jmax() + WRITE(error_str(31:33),'(i3)') current_bounds%get_kmin() + WRITE(error_str(35:37),'(i3)') current_bounds%get_kmax() + WRITE(error_str(54:56),'(i3)') bounds%get_imin() + WRITE(error_str(58:60),'(i3)') bounds%get_imax() + WRITE(error_str(62:64),'(i3)') bounds%get_jmin() + WRITE(error_str(66:68),'(i3)') bounds%get_jmax() + WRITE(error_str(70:72),'(i3)') bounds%get_kmin() + WRITE(error_str(74:76),'(i3)') bounds%get_kmax() ELSE compare_buffer_bounds_to_size = .FALSE. error_str = '' @@ -892,7 +847,7 @@ SUBROUTINE check_out_of_bounds(out_num, diag_field_id, err_msg) TYPE (fmsDiagIbounds_type) :: array_bounds associate (buff_bounds => output_fields(out_num)%buff_bounds) - CALL fms_diag_bounds_from_array(array_bounds, output_fields(out_num)%buffer) + CALL array_bounds%reset_bounds_from_array_4D(output_fields(out_num)%buffer) out_of_bounds = compare_buffer_bounds_to_size(array_bounds, buff_bounds, & & error_string2, a_lessthan_b, a_greaterthan_b) @@ -925,7 +880,7 @@ SUBROUTINE fms_diag_check_out_of_bounds_r4(ofb, bounds, output_name, module_name LOGICAL :: out_of_bounds = .true. TYPE (fmsDiagIbounds_type) :: array_bounds - CALL fms_diag_bounds_from_array(array_bounds, ofb) + CALL array_bounds%reset_bounds_from_array_5D(ofb) out_of_bounds = compare_buffer_bounds_to_size(array_bounds, bounds, & & error_string2, a_lessthan_b, a_greaterthan_b) @@ -957,7 +912,7 @@ SUBROUTINE fms_diag_check_out_of_bounds_r8(ofb, bounds, output_name, module_name LOGICAL :: out_of_bounds = .true. TYPE (fmsDiagIbounds_type) :: array_bounds ! @ingroup fms_diag_outfield_mod TYPE, public :: fmsDiagOutfield_type PRIVATE diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index d3df9d6af0..2504e24585 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -60,12 +60,12 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL, DIMENSION(1), target :: mask_dummy !! For pointer bounds remapping - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null()!< Pointer to the field - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null()!< Pointer to the outfield buffer. - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr => null()!< Pointer to the outfield counter. - LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null()!< Pointer to the mask. - + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr !< Pointer to the field + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr !< Pointer to the outfield buffer. + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofc_ptr !< Pointer to the outfield counter. + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< Pointer to the mask. + !!Set all the pointers! field_ptr(1:size(field_d,1),1:size(field_d,2),1:size(field_d,3),1:1) => field_d ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3),1:1, 1:size(ofb,4)) => ofb @@ -82,8 +82,6 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & mask_ptr(1:1,1:1,1:1,1:1) => mask_dummy ENDIF - - succeded = FMS_DIAG_FBU_PNAME_ (ofield_cfg, ofield_index_cfg, field_ptr, sample, & & ofb_ptr, ofc_ptr, bbounds, count_0d, num_elements, mask_ptr, weight1, missvalue, & & field_num_threads, field_active_omp_level, issued_mask_ignore_warning, & @@ -217,7 +215,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & MASK_PR_1_IF: IF (mask_present ) THEN MISSVAL_PR_1_IF: IF ( missvalue_present ) THEN !!(section: mask_variant .eq. true + mask present) IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -392,7 +390,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END IF ELSE NDCMP_RKR_1_IF IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -508,7 +506,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & END IF ELSE NDCMP_RKR_2_IF IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '') THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -657,7 +655,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & !$OMP END CRITICAL ELSE NDCMP_RKR_3_IF IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -769,7 +767,7 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & ELSE NDCMP_RKR_4_IF IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF (fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -843,13 +841,13 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & LOGICAL, DIMENSION(1,1,1,1), target :: mask_dummy !! For pointer bounds remapping - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr => null() !< Pointer to the field - FMS_DIAG_FBU_DATA_TYPE_ , pointer,DIMENSION(:,:,:,:,:):: ofb_ptr => null() !< Pointer to the outfield buffer. - LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr => null() !< !< Pointer to the mask. + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr!< Pointer to the field + FMS_DIAG_FBU_DATA_TYPE_ , pointer,DIMENSION(:,:,:,:,:):: ofb_ptr!< Pointer to the outfield buffer. + LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< Pointer to the mask. + !Initialize all the pointers field_ptr(1:size(field,1),1:size(field,2),1:size(field,3),1:1) => field(:,:,:) ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:1, 1:size(ofb,4)) => ofb - IF (PRESENT (mask)) THEN mask_ptr(1:size(mask,1),1:size(mask,2),1:size(mask,3),1:1) => mask ELSE @@ -959,7 +957,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -997,7 +995,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1040,7 +1038,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1077,7 +1075,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1120,7 +1118,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1155,7 +1153,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, & field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1189,7 +1187,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, OFB(is-hi:ie-hi,js-hj:je-hj,:,:,sample) = field(f1:f2,f3:f4,ksr:ker,:) ELSE IF ( debug_diag_manager ) THEN - CALL fms_diag_update_bounds(bbounds, is-hi, ie-hi, js-hj, je-hj, ks, ke) + CALL bbounds%update_bounds(is-hi, ie-hi, js-hj, je-hj, ks, ke) CALL fms_diag_check_out_of_bounds(ofb, bbounds, output_name, module_name, err_msg_local) IF ( err_msg_local /= '' ) THEN IF ( fms_error_handler('diag_manager_mod::send_data_3d', err_msg_local, err_msg) ) THEN @@ -1269,11 +1267,12 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output !! These below are used in pointer bounds remapping - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr => null() !< Pointer to the output field - !! buffer - used in remapping - FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: rmask_ptr => null() !< Pointer to the rmask - used - !! in remapping + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:,:) :: ofb_ptr !< Pointer to the output field + !! buffer - used in remapping + FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: rmask_ptr !< Pointer to the rmask - used + !! in remapping + !!Initialize all the pointers ofb_ptr(1:size(ofb,1),1:size(ofb,2),1:size(ofb,3), 1:1, 1:size(ofb,4)) => ofb rmask_ptr(1:size(rmask,1),1:size(rmask,2),1:size(rmask,3),1:1) => rmask From f31d685b16833f64f3e488520185a7cb5f701ed1 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Wed, 22 Feb 2023 16:25:37 -0500 Subject: [PATCH 34/37] Added module fms_diag_bbox_mod; improved comments in fms_diag_fieldbuff_update.fh --- CMakeLists.txt | 1 + diag_manager/Makefile.am | 7 +- diag_manager/diag_data.F90 | 134 +------------- diag_manager/diag_util.F90 | 3 +- diag_manager/fms_diag_bbox.F90 | 167 ++++++++++++++++++ diag_manager/fms_diag_fieldbuff_update.F90 | 3 +- .../include/fms_diag_fieldbuff_update.fh | 26 +-- .../include/fms_diag_fieldbuff_update.inc | 19 ++ .../diag_manager/test_diag_update_buffer.F90 | 3 +- 9 files changed, 215 insertions(+), 148 deletions(-) create mode 100644 diag_manager/fms_diag_bbox.F90 diff --git a/CMakeLists.txt b/CMakeLists.txt index 4f38492e72..42420fdb9e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -128,6 +128,7 @@ list(APPEND fms_fortran_src_files diag_manager/fms_diag_outfield.F90 diag_manager/fms_diag_elem_weight_procs.F90 diag_manager/fms_diag_fieldbuff_update.F90 + diag_manager/fms_diag_bbox_mod.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 diff --git a/diag_manager/Makefile.am b/diag_manager/Makefile.am index 21a6300335..37759e838f 100644 --- a/diag_manager/Makefile.am +++ b/diag_manager/Makefile.am @@ -42,21 +42,23 @@ libdiag_manager_la_SOURCES = \ fms_diag_outfield.F90 \ fms_diag_elem_weight_procs.F90 \ fms_diag_fieldbuff_update.F90 \ + fms_diag_bbox.F90 \ include/fms_diag_fieldbuff_update.inc \ include/fms_diag_fieldbuff_update.fh # Some mods are dependant on other mods in this dir. +diag_data_mod.$(FC_MODEXT): fms_diag_bbox_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_axis_mod.$(FC_MODEXT) diag_output_mod.$(FC_MODEXT) \ - diag_grid_mod.$(FC_MODEXT) + diag_grid_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) fms_diag_axis_object_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_time_utils_mod.$(FC_MODEXT) fms_diag_time_reduction_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_fieldbuff_update_mod.$(FC_MODEXT): diag_data_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ - fms_diag_elem_weight_procs_mod.$(FC_MODEXT) + fms_diag_elem_weight_procs_mod.$(FC_MODEXT) fms_diag_bbox_mod.$(FC_MODEXT) diag_manager_mod.$(FC_MODEXT): diag_axis_mod.$(FC_MODEXT) diag_data_mod.$(FC_MODEXT) diag_util_mod.$(FC_MODEXT) \ diag_output_mod.$(FC_MODEXT) diag_grid_mod.$(FC_MODEXT) diag_table_mod.$(FC_MODEXT) \ fms_diag_time_reduction_mod.$(FC_MODEXT) fms_diag_outfield_mod.$(FC_MODEXT) \ @@ -73,6 +75,7 @@ MODFILES = \ diag_table_mod.$(FC_MODEXT) \ fms_diag_time_reduction_mod.$(FC_MODEXT) \ fms_diag_outfield_mod.$(FC_MODEXT) \ + fms_diag_bbox_mod.$(FC_MODEXT) \ fms_diag_elem_weight_procs_mod.$(FC_MODEXT) \ fms_diag_fieldbuff_update_mod.$(FC_MODEXT) \ diag_manager_mod.$(FC_MODEXT) \ diff --git a/diag_manager/diag_data.F90 b/diag_manager/diag_data.F90 index b4cc54a3e9..a1f5947098 100644 --- a/diag_manager/diag_data.F90 +++ b/diag_manager/diag_data.F90 @@ -51,6 +51,8 @@ MODULE diag_data_mod USE time_manager_mod, ONLY: time_type USE mpp_domains_mod, ONLY: domain1d, domain2d, domainUG USE fms_mod, ONLY: WARNING, write_version_number + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type + #ifdef use_netCDF ! NF90_FILL_REAL has value of 9.9692099683868690e+36. USE netcdf, ONLY: NF_FILL_REAL => NF90_FILL_REAL @@ -128,37 +130,6 @@ MODULE diag_data_mod REAL :: zend END TYPE coord_type - !> @brief Data structure holding intervals (or interval bounds or limits). - !! Used for checking the bounds of the field output buffer arrays. -TYPE, public :: fmsDiagIbounds_type -PRIVATE - INTEGER :: imin !< Lower i bound. - INTEGER :: imax !< Upper i bound. - INTEGER :: jmin !< Lower j bound. - INTEGER :: jmax !< Upper j bound. - INTEGER :: kmin !< Lower k bound. - INTEGER :: kmax !< Upper k bound. - contains - procedure :: reset => reset_bounds - procedure :: reset_bounds_from_array_4D - procedure :: reset_bounds_from_array_5D - procedure :: update_bounds - procedure :: get_imin - procedure :: get_imax - procedure :: get_jmin - procedure :: get_jmax - procedure :: get_kmin - procedure :: get_kmax -END TYPE fmsDiagIbounds_type - -!INTERFACE fms_diag_bounds_from_array -!module procedure bounds_from_array_4D -!module procedure bounds_from_array_5D -!END INTERFACE fms_diag_bounds_from_array - - - - !> @brief Type to define the diagnostic files that will be written as defined by the diagnostic table. !> @ingroup diag_data_mod TYPE file_type @@ -418,107 +389,6 @@ SUBROUTINE diag_data_init() call write_version_number("DIAG_DATA_MOD", version) END SUBROUTINE diag_data_init - !> @brief Gets imin of fmsDiagIbounds_type - !! @return copy of integer member imin - pure integer function get_imin (this) result(rslt) - class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance - rslt = this%imin - end function get_imin - - !> @brief Gets imax of fmsDiagIbounds_type - !! @return copy of integer member imax - pure integer function get_imax (this) result(rslt) - class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance - rslt = this%imax - end function get_imax - - !> @brief Gets jmin of fmsDiagIbounds_type - !! @return copy of integer member jmin - pure integer function get_jmin (this) result(rslt) - class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance - rslt = this%jmin - end function get_jmin - - !> @brief Gets jmax of fmsDiagIbounds_type - !! @return copy of integer member jmax - pure integer function get_jmax (this) result(rslt) - class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance - rslt = this%jmax - end function get_jmax - - - !> @brief Gets kmin of fmsDiagIbounds_type - !! @return copy of integer member kmin - pure integer function get_kmin (this) result(rslt) - class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance - rslt = this%kmin - end function get_kmin - - !> @brief Gets kmax of fmsDiagIbounds_type - !! @return copy of integer member kmax - pure integer function get_kmax (this) result(rslt) - class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance - rslt = this%kmax - end function get_kmax - - !> @brief Reset the instance bounding lower and upper bounds to lower_val and upper_val, respectively. - SUBROUTINE reset_bounds (this, lower_val, upper_val) - class (fmsDiagIbounds_type), target, intent(inout) :: this !< ibounds instance - integer, intent(in) :: lower_val !< value for the lower bounds in each dimension - integer, intent(in) :: upper_val !< value for the upper bounds in each dimension - this%imin = lower_val - this%jmin = lower_val - this%kmin = lower_val - this%imax = upper_val - this%jmax = upper_val - this%kmax = upper_val - END SUBROUTINE reset_bounds - - !> @brief Update the the first three (normally x, y, and z) min and - !! max boundaries (array indices) of the instance bounding box - !! the six specified bounds values. - SUBROUTINE update_bounds(this, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) - CLASS (fmsDiagIbounds_type), intent(inout) :: this ! @brief Reset the instance bounding box with the bounds determined from the - !! first three dimensions of the 5D "array" argument - SUBROUTINE reset_bounds_from_array_4D(this, array) - CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. - REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. - this%imin = LBOUND(array,1) - this%imax = UBOUND(array,1) - this%jmin = LBOUND(array,2) - this%jmax = UBOUND(array,2) - this%kmin = LBOUND(array,3) - this%kmax = UBOUND(array,3) - END SUBROUTINE reset_bounds_from_array_4D - - !> @brief Reset the instance bounding box with the bounds determined from the - !! first three dimensions of the 5D "array" argument - SUBROUTINE reset_bounds_from_array_5D(this, array) - CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. - CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 5D input array. - this%imin = LBOUND(array,1) - this%imax = UBOUND(array,1) - this%jmin = LBOUND(array,2) - this%jmax = UBOUND(array,2) - this%kmin = LBOUND(array,3) - this%kmax = UBOUND(array,3) - END SUBROUTINE reset_bounds_from_array_5D - END MODULE diag_data_mod diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index 02c54bd688..c5ce2b2332 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -49,7 +49,7 @@ MODULE diag_util_mod & mix_snapshot_average_fields, global_descriptor, CMOR_MISSING_VALUE, use_cmor, pack_size,& & debug_diag_manager, flush_nc_files, output_field_type, max_field_attributes, max_file_attributes,& & file_type, prepend_date, region_out_use_alt_value, GLO_REG_VAL, GLO_REG_VAL_ALT,& - & DIAG_FIELD_NOT_FOUND, diag_init_time, fmsDiagIbounds_type + & DIAG_FIELD_NOT_FOUND, diag_init_time USE diag_data_mod, ONLY: fileobjU, fileobj, fnum_for_domain, fileobjND USE diag_axis_mod, ONLY: get_diag_axis_data, get_axis_global_length, get_diag_axis_cart,& & get_domain1d, get_domain2d, diag_subaxes_init, diag_axis_init, get_diag_axis, get_axis_aux,& @@ -71,6 +71,7 @@ MODULE diag_util_mod USE mpp_mod, ONLY: mpp_npes USE constants_mod, ONLY: SECONDS_PER_DAY, SECONDS_PER_HOUR, SECONDS_PER_MINUTE USE fms2_io_mod + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type #ifdef use_netCDF USE netcdf, ONLY: NF90_CHAR #endif diff --git a/diag_manager/fms_diag_bbox.F90 b/diag_manager/fms_diag_bbox.F90 new file mode 100644 index 0000000000..7fa331258a --- /dev/null +++ b/diag_manager/fms_diag_bbox.F90 @@ -0,0 +1,167 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +!> @defgroup fms_diag_bbox_mod fms_diag_bbox_mod +!> @ingroup diag_manager +!> @brief fms_diag_bbox_mod defines classes encapsulating bounding boxes +!! and interval bounds. +!! +!> @author Miguel Zuniga +!! +!> @file +!> @brief File for @ref fms_diag_bbox_mod +!> @addtogroup fms_diag_bbox_mod +!> @{ +MODULE fms_diag_bbox_mod + + USE fms_mod, ONLY: error_mesg, FATAL + + implicit none + +!> @brief Data structure holding a 3D bounding box. It is commonlyused to +!! represent the interval bounds or limits of a 3D sub-array such as the +!! array index bounds of the spatial component a diag_manager field output +!! buffer array. + TYPE, public :: fmsDiagIbounds_type + PRIVATE + INTEGER :: imin !< Lower i bound. + INTEGER :: imax !< Upper i bound. + INTEGER :: jmin !< Lower j bound. + INTEGER :: jmax !< Upper j bound. + INTEGER :: kmin !< Lower k bound. + INTEGER :: kmax !< Upper k bound. + contains + procedure :: reset => reset_bounds + procedure :: reset_bounds_from_array_4D + procedure :: reset_bounds_from_array_5D + procedure :: update_bounds + procedure :: get_imin + procedure :: get_imax + procedure :: get_jmin + procedure :: get_jmax + procedure :: get_kmin + procedure :: get_kmax + END TYPE fmsDiagIbounds_type + +CONTAINS + + !> @brief Gets imin of fmsDiagIbounds_type + !! @return copy of integer member imin + pure integer function get_imin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%imin + end function get_imin + + !> @brief Gets imax of fmsDiagIbounds_type + !! @return copy of integer member imax + pure integer function get_imax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%imax + end function get_imax + + !> @brief Gets jmin of fmsDiagIbounds_type + !! @return copy of integer member jmin + pure integer function get_jmin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%jmin + end function get_jmin + + !> @brief Gets jmax of fmsDiagIbounds_type + !! @return copy of integer member jmax + pure integer function get_jmax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%jmax + end function get_jmax + + + !> @brief Gets kmin of fmsDiagIbounds_type + !! @return copy of integer member kmin + pure integer function get_kmin (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%kmin + end function get_kmin + + !> @brief Gets kmax of fmsDiagIbounds_type + !! @return copy of integer member kmax + pure integer function get_kmax (this) result(rslt) + class (fmsDiagIbounds_type), intent(in) :: this !< The !< ibounds instance + rslt = this%kmax + end function get_kmax + + !> @brief Reset the instance bounding lower and upper bounds to lower_val and upper_val, respectively. + SUBROUTINE reset_bounds (this, lower_val, upper_val) + class (fmsDiagIbounds_type), target, intent(inout) :: this !< ibounds instance + integer, intent(in) :: lower_val !< value for the lower bounds in each dimension + integer, intent(in) :: upper_val !< value for the upper bounds in each dimension + this%imin = lower_val + this%jmin = lower_val + this%kmin = lower_val + this%imax = upper_val + this%jmax = upper_val + this%kmax = upper_val + END SUBROUTINE reset_bounds + + !> @brief Update the the first three (normally x, y, and z) min and + !! max boundaries (array indices) of the instance bounding box + !! the six specified bounds values. + SUBROUTINE update_bounds(this, lower_i, upper_i, lower_j, upper_j, lower_k, upper_k) + CLASS (fmsDiagIbounds_type), intent(inout) :: this ! @brief Reset the instance bounding box with the bounds determined from the + !! first three dimensions of the 5D "array" argument + SUBROUTINE reset_bounds_from_array_4D(this, array) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. + REAL, INTENT( in), DIMENSION(:,:,:,:) :: array !< The 4D input array. + this%imin = LBOUND(array,1) + this%imax = UBOUND(array,1) + this%jmin = LBOUND(array,2) + this%jmax = UBOUND(array,2) + this%kmin = LBOUND(array,3) + this%kmax = UBOUND(array,3) + END SUBROUTINE reset_bounds_from_array_4D + + !> @brief Reset the instance bounding box with the bounds determined from the + !! first three dimensions of the 5D "array" argument + SUBROUTINE reset_bounds_from_array_5D(this, array) + CLASS (fmsDiagIbounds_type), INTENT(inout) :: this !< The instance of the bounding box. + CLASS(*), INTENT( in), DIMENSION(:,:,:,:,:) :: array !< The 5D input array. + this%imin = LBOUND(array,1) + this%imax = UBOUND(array,1) + this%jmin = LBOUND(array,2) + this%jmax = UBOUND(array,2) + this%kmin = LBOUND(array,3) + this%kmax = UBOUND(array,3) + END SUBROUTINE reset_bounds_from_array_5D + + END MODULE fms_diag_bbox_mod + !> @} + ! close documentation grouping diff --git a/diag_manager/fms_diag_fieldbuff_update.F90 b/diag_manager/fms_diag_fieldbuff_update.F90 index a848884cf7..0e3783dcef 100644 --- a/diag_manager/fms_diag_fieldbuff_update.F90 +++ b/diag_manager/fms_diag_fieldbuff_update.F90 @@ -37,11 +37,12 @@ MODULE fms_diag_fieldbuff_update_mod USE mpp_mod, ONLY: mpp_pe, mpp_root_pe USE time_manager_mod, ONLY: time_type USE fms_mod, ONLY: error_mesg, FATAL, WARNING, NOTE, stdout, stdlog, write_version_number,fms_error_handler - USE diag_data_mod, ONLY: debug_diag_manager, fmsDiagIbounds_type + USE diag_data_mod, ONLY: debug_diag_manager USE fms_diag_outfield_mod, ONLY: fmsDiagOutfieldIndex_type, fmsDiagOutfield_type USE diag_util_mod, ONLY: fms_diag_check_out_of_bounds USE fms_diag_time_reduction_mod, ONLY: fmsDiagTimeReduction_type USE fms_diag_elem_weight_procs_mod, ONLY: addwf + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type implicit none diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index 2504e24585..d4f7a5e70c 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -40,10 +40,12 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight. FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. - INTEGER, INTENT(inout) :: field_num_threads - INTEGER, INTENT(inout) :: field_active_omp_level + INTEGER, INTENT(inout) :: field_num_threads !< Number of OMP threads used processing the input field; + !!expected 1 if no OMP. + INTEGER, INTENT(inout) :: field_active_omp_level ! A target for ofc_ptr, in case ofc is not allocated + LOGICAL, DIMENSION(1), target :: mask_dummy !> A target for mask_ptr, in case mask is not present !! For pointer bounds remapping FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr !< Pointer to the field @@ -121,10 +123,12 @@ FUNCTION FMS_DIAG_FBU_3D_PNAME_(ofield_cfg, ofield_index_cfg, field_d, sample, & FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: weight1 !< Field data is multiplied by weight FMS_DIAG_FBU_DATA_TYPE_, INTENT(in) :: missvalue !< Buffer may be set to missvalue where mask is false. - INTEGER, INTENT(inout) :: field_num_threads - INTEGER, INTENT(inout) :: field_active_omp_level + INTEGER, INTENT(inout) :: field_num_threads !< Number of OMP threads used processing the input field; + !! expected 1 if no OMP. + INTEGER, INTENT(inout)::field_active_omp_level ! A target for mask_ptr, in case mask is not present - !! For pointer bounds remapping + !! For pointer bounds remapping: FMS_DIAG_FBU_DATA_TYPE_ , pointer, DIMENSION(:,:,:,:) :: field_ptr!< Pointer to the field FMS_DIAG_FBU_DATA_TYPE_ , pointer,DIMENSION(:,:,:,:,:):: ofb_ptr!< Pointer to the outfield buffer. LOGICAL , pointer, DIMENSION(:,:,:,:) :: mask_ptr !< Pointer to the mask. @@ -873,7 +877,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, FMS_DIAG_FBU_DATA_TYPE_ , CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in) :: field !< The field value array. INTEGER, INTENT(in) :: sample !< index along the diurnal time axis FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< The Output Field Buffer - TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds + TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< The array bounds of the ofb argument. FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !< Normally the member of the buffer of same name, LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. diff --git a/diag_manager/include/fms_diag_fieldbuff_update.inc b/diag_manager/include/fms_diag_fieldbuff_update.inc index b45071d307..be6f51d0f1 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.inc +++ b/diag_manager/include/fms_diag_fieldbuff_update.inc @@ -1,3 +1,22 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS). +!* +!* FMS is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* FMS is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + #undef FMS_DIAG_FBU_DATA_TYPE_ #define FMS_DIAG_FBU_DATA_TYPE_ REAL(r4_kind) #undef FMS_DIAG_FBU_PNAME_ diff --git a/test_fms/diag_manager/test_diag_update_buffer.F90 b/test_fms/diag_manager/test_diag_update_buffer.F90 index aaf2a47e56..67de3ec665 100644 --- a/test_fms/diag_manager/test_diag_update_buffer.F90 +++ b/test_fms/diag_manager/test_diag_update_buffer.F90 @@ -24,11 +24,12 @@ program test_diag_update_buffer use platform_mod use mpp_mod, only: mpp_init, mpp_set_stack_size, mpp_init_test_requests_allocated use fms_mod, ONLY: fms_init, fms_end, error_mesg, FATAL,NOTE - use diag_data_mod, ONLY: fmsDiagIbounds_type, VERY_LARGE_AXIS_LENGTH + use diag_data_mod, ONLY: VERY_LARGE_AXIS_LENGTH USE fms_diag_outfield_mod, ONLY: fmsDiagOutfield_type, fmsDiagOutfieldIndex_type USE fms_diag_fieldbuff_update_mod, ONLY: fieldbuff_update, fieldbuff_copy_missvals, & & fieldbuff_copy_fieldvals USE fms_diag_time_reduction_mod, ONLY: fmsDiagTimeReduction_type, time_average, time_rms + USE fms_diag_bbox_mod, ONLY: fmsDiagIbounds_type implicit none From 76a224111842a7a9245ab002a809ff1ab2461332 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Wed, 22 Feb 2023 16:41:05 -0500 Subject: [PATCH 35/37] Fixing type in CMakeLists.txt --- CMakeLists.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index 42420fdb9e..930f37c426 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -128,7 +128,7 @@ list(APPEND fms_fortran_src_files diag_manager/fms_diag_outfield.F90 diag_manager/fms_diag_elem_weight_procs.F90 diag_manager/fms_diag_fieldbuff_update.F90 - diag_manager/fms_diag_bbox_mod.F90 + diag_manager/fms_diag_bbox.F90 drifters/cloud_interpolator.F90 drifters/drifters.F90 drifters/drifters_comm.F90 From 1583e907249ddc3d11ce80e5ceeb266c0e44dfdd Mon Sep 17 00:00:00 2001 From: ngs333 Date: Thu, 23 Feb 2023 10:41:38 -0500 Subject: [PATCH 36/37] Modifications from PR review; mostly not setting pointers to null at declaration line, and some missing comments. --- diag_manager/diag_manager.F90 | 7 ++++--- diag_manager/diag_util.F90 | 2 +- diag_manager/include/fms_diag_fieldbuff_update.fh | 2 +- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 2cb734aacb..c127993b49 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1491,9 +1491,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out !< Local copy of field - REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 => null() !< A pointer to r4 type of rmask - REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 => null() ! null() !< A pointer to mask + REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask + REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 ! null() + rmask_ptr_r8 => null() IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index c5ce2b2332..9956c2d9c4 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -1045,7 +1045,7 @@ SUBROUTINE fms_diag_check_bounds_are_exact_static(current_bounds, bounds, output !! if the check fails. CHARACTER(len=128) :: error_string1, error_string2 - LOGICAL :: lims_not_exact = .true. + LOGICAL :: lims_not_exact err_msg = '' lims_not_exact = compare_buffer_bounds_to_size(current_bounds, bounds, & diff --git a/diag_manager/include/fms_diag_fieldbuff_update.fh b/diag_manager/include/fms_diag_fieldbuff_update.fh index d4f7a5e70c..52fa7259d6 100644 --- a/diag_manager/include/fms_diag_fieldbuff_update.fh +++ b/diag_manager/include/fms_diag_fieldbuff_update.fh @@ -879,7 +879,7 @@ FUNCTION FMS_DIAG_FBCF_PNAME_ (ofield_cfg, ofield_index_cfg, field, sample, ofb, FMS_DIAG_FBU_DATA_TYPE_ , DIMENSION(:,:,:,:,:), INTENT(inout) :: ofb !< The Output Field Buffer TYPE(fmsDiagIbounds_type), INTENT(inout) :: bbounds !< The array bounds of the ofb argument. FMS_DIAG_FBU_DATA_TYPE_ , INTENT(inout) :: count_0d !< Normally the member of the buffer of same name, - LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask + LOGICAL, CONTIGUOUS, DIMENSION(:,:,:,:), INTENT(in), OPTIONAL :: mask !< The mask of the corresponding field. FMS_DIAG_FBU_DATA_TYPE_ , INTENT(in) :: missvalue !< buffer may be set to this value where mask is false. INTEGER, DIMENSION(3), INTENT(in) :: l_start !< local start indices on spatial axes for regional output INTEGER, DIMENSION(3), INTENT(in) :: l_end !< local end indices on spatial for regional output From 8faab409998d19867364c1c628aaeab8f3bffc39 Mon Sep 17 00:00:00 2001 From: ngs333 Date: Thu, 23 Feb 2023 11:52:13 -0500 Subject: [PATCH 37/37] Fixing spelling in two comment lines. --- diag_manager/diag_manager.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index c127993b49..e78ee3e6f9 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -1494,8 +1494,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & REAL(kind=r4_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r4 !< A pointer to r4 type of rmask REAL(kind=r8_kind), POINTER, DIMENSION(:,:,:) :: rmask_ptr_r8 !