From d8cb860ed74e91df93b56d6243d89c66ed0f310f Mon Sep 17 00:00:00 2001 From: MinsukJi-NOAA Date: Wed, 12 Jan 2022 18:29:06 +0000 Subject: [PATCH 1/5] Make 'unsupported kind' error messages more descriptive. Change author of constants4.F90 --- constants4/constants4.F90 | 2 +- diag_manager/diag_axis.F90 | 6 +- diag_manager/diag_grid.F90 | 18 ++- diag_manager/diag_manager.F90 | 39 ++++-- diag_manager/diag_util.F90 | 6 +- sat_vapor_pres/sat_vapor_pres.F90 | 27 ++-- sat_vapor_pres/sat_vapor_pres_k.F90 | 204 ++++++++++++++++++---------- time_manager/time_manager.F90 | 6 +- tracer_manager/tracer_manager.F90 | 8 +- 9 files changed, 209 insertions(+), 107 deletions(-) diff --git a/constants4/constants4.F90 b/constants4/constants4.F90 index d433f280f3..18c8140a3d 100644 --- a/constants4/constants4.F90 +++ b/constants4/constants4.F90 @@ -20,7 +20,7 @@ !> @ingroup constants !> @brief Defines useful constants for Earth. Constants are defined as real !! parameters. Constants are accessed through the "use" statement. -!> @author Bruce Wyman +!> @author Bin Li !! !> Constants have been declared as type REAL, PARAMETER. !! diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index 1d75502002..13daf3cf35 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -237,7 +237,8 @@ INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, directi TYPE IS (real(kind=r8_kind)) Axes(diag_axis_init)%data = DATA(1:axlen) CLASS DEFAULT - CALL error_mesg('diag_axis_mod::diag_axis_init', 'unsupported kind', FATAL) + CALL error_mesg('diag_axis_mod::diag_axis_init',& + & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT Axes(diag_axis_init)%units = units Axes(diag_axis_init)%length = axlen @@ -494,7 +495,8 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& TYPE IS (real(kind=r8_kind)) DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length) CLASS DEFAULT - CALL error_mesg('diag_axis_mod::get_diag_axis', 'unsupported kind', FATAL) + CALL error_mesg('diag_axis_mod::get_diag_axis',& + & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT END IF IF ( PRESENT(num_attributes) ) THEN diff --git a/diag_manager/diag_grid.F90 b/diag_manager/diag_grid.F90 index 4d63b78f76..99a474c9a3 100644 --- a/diag_manager/diag_grid.F90 +++ b/diag_manager/diag_grid.F90 @@ -260,7 +260,8 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r8_kind)) diag_global_grid%aglo_lat = TRANSPOSE(aglo_lat) CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init', 'unsupported kind', FATAL) + CALL error_mesg('diag_grid_mod::diag_grid_init',& + & 'The a-grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT SELECT TYPE (aglo_lon) @@ -269,7 +270,8 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r8_kind)) diag_global_grid%aglo_lon = TRANSPOSE(aglo_lon) CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init', 'unsupported kind', FATAL) + CALL error_mesg('diag_grid_mod::diag_grid_init',& + & 'The a-grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT ELSE SELECT TYPE (aglo_lat) @@ -278,7 +280,8 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r8_kind)) diag_global_grid%aglo_lat = aglo_lat CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init', 'unsupported kind', FATAL) + CALL error_mesg('diag_grid_mod::diag_grid_init',& + & 'The a-grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT SELECT TYPE (aglo_lon) @@ -287,7 +290,8 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r8_kind)) diag_global_grid%aglo_lon = aglo_lon CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init', 'unsupported kind', FATAL) + CALL error_mesg('diag_grid_mod::diag_grid_init',& + & 'The a-grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT END IF @@ -297,7 +301,8 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r8_kind)) diag_global_grid%glo_lat = glo_lat CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init', 'unsupported kind', FATAL) + CALL error_mesg('diag_grid_mod::diag_grid_init',& + & 'The grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT SELECT TYPE (glo_lon) @@ -306,7 +311,8 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r8_kind)) diag_global_grid%glo_lon = glo_lon CLASS DEFAULT - CALL error_mesg('diag_grid_mod::diag_grid_init', 'unsupported kind', FATAL) + CALL error_mesg('diag_grid_mod::diag_grid_init',& + & 'The grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT diag_global_grid%dimI = i_dim diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 39ea807884..4d80482432 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -648,7 +648,8 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, TYPE IS (real(kind=r8_kind)) missing_value_use = missing_value CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::register_static_field', 'unsupported kind', FATAL) + CALL error_mesg ('diag_manager_mod::register_static_field',& + & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT END IF END IF @@ -810,7 +811,8 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, TYPE IS (real(kind=r8_kind)) range_use = range CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::register_static_field', 'unsupported kind', FATAL) + CALL error_mesg ('diag_manager_mod::register_static_field',& + & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT input_fields(field)%range = range_use ! don't use the range if it is not a valid range @@ -1299,7 +1301,8 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) TYPE IS (real(kind=r8_kind)) field_out(1, 1, 1) = field CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_0d', 'unsupported kind', FATAL) + CALL error_mesg ('diag_manager_mod::send_data_0d',& + & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT send_data_0d = send_data_3d(diag_field_id, field_out, time, err_msg=err_msg) @@ -1332,7 +1335,8 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie TYPE IS (real(kind=r8_kind)) field_out(:, 1, 1) = field CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_1d', 'unsupported kind', FATAL) + CALL error_mesg ('diag_manager_mod::send_data_1d',& + & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT ! Default values for mask @@ -1349,7 +1353,8 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie TYPE IS (real(kind=r8_kind)) WHERE (rmask < 0.5) mask_out(:, 1, 1) = .FALSE. CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_1d', 'unsupported kind', FATAL) + CALL error_mesg ('diag_manager_mod::send_data_1d',& + & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT END IF @@ -1399,7 +1404,8 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & TYPE IS (real(kind=r8_kind)) field_out(:, :, 1) = field CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_2d', 'unsupported kind', FATAL) + CALL error_mesg ('diag_manager_mod::send_data_2d',& + & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT ! Default values for mask @@ -1416,7 +1422,8 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & TYPE IS (real(kind=r8_kind)) WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE. CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_2d', 'unsupported kind', FATAL) + CALL error_mesg ('diag_manager_mod::send_data_2d',& + & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT END IF @@ -1661,7 +1668,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & TYPE IS (real(kind=r8_kind)) field_out = field CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d', 'unsupported kind', FATAL) + 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. @@ -1685,7 +1693,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & 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', 'unsupported kind', FATAL) + 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 @@ -1793,7 +1802,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & TYPE IS (real(kind=r8_kind)) weight1 = weight CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d', 'unsupported kind', FATAL) + 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. @@ -3153,7 +3163,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END DO END DO CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d', 'unsupported kind', FATAL) + 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) @@ -3180,7 +3191,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END DO END DO CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d', 'unsupported kind', FATAL) + 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) @@ -3203,7 +3215,8 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & END DO END DO CLASS DEFAULT - CALL error_mesg ('diag_manager_mod::send_data_3d', 'unsupported kind', FATAL) + 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 diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index adfa8a911a..fe3be65786 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -684,7 +684,8 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& TYPE IS (real(kind=r8_kind)) missing_value_use = missing_value CLASS DEFAULT - CALL error_mesg ('diag_util_mod::log_diag_field_info', 'unsupported kind', FATAL) + CALL error_mesg ('diag_util_mod::log_diag_field_info',& + & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT WRITE (lmissval,*) missing_value_use END IF @@ -699,7 +700,8 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& TYPE IS (real(kind=r8_kind)) range_use = range CLASS DEFAULT - CALL error_mesg ('diag_util_mod::log_diag_field_info', 'unsupported kind', FATAL) + CALL error_mesg ('diag_util_mod::log_diag_field_info',& + & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) END SELECT WRITE (lmin,*) range_use(1) WRITE (lmax,*) range_use(2) diff --git a/sat_vapor_pres/sat_vapor_pres.F90 b/sat_vapor_pres/sat_vapor_pres.F90 index 70c821c8a7..054860e530 100644 --- a/sat_vapor_pres/sat_vapor_pres.F90 +++ b/sat_vapor_pres/sat_vapor_pres.F90 @@ -2627,7 +2627,8 @@ function check_1d ( temp ) result ( nbad ) if (ind < 0 .or. ind > nlim) nbad = nbad+1 enddo class default - call error_mesg ('sat_vapor_pres_mod::check_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_mod::check_1d',& + & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select end function check_1d @@ -2651,7 +2652,8 @@ function check_2d ( temp ) result ( nbad ) nbad = nbad + check_1d ( temp(:,j) ) enddo class default - call error_mesg ('sat_vapor_pres_mod::check_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_mod::check_2d',& + & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select end function check_2d @@ -2670,7 +2672,8 @@ subroutine temp_check_1d ( temp ) type is (real(kind=r8_kind)) write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i:i)),i=1,size(temp,1)) class default - call error_mesg ('sat_vapor_pres_mod::temp_check_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_mod::temp_check_1d',& + & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select end subroutine temp_check_1d @@ -2691,7 +2694,8 @@ subroutine temp_check_2d ( temp ) write(unit,*) 'Bad temperatures (dimension 1): ', (check_1d(temp(i,:)),i=1,size(temp,1)) write(unit,*) 'Bad temperatures (dimension 2): ', (check_1d(temp(:,j)),j=1,size(temp,2)) class default - call error_mesg ('sat_vapor_pres_mod::temp_check_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_mod::temp_check_2d',& + & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select end subroutine temp_check_2d @@ -2714,7 +2718,8 @@ subroutine temp_check_3d ( temp ) write(unit,*) 'Bad temperatures (dimension 2): ', (check_2d(temp(:,j,:)),j=1,size(temp,2)) write(unit,*) 'Bad temperatures (dimension 3): ', (check_2d(temp(:,:,k)),k=1,size(temp,3)) class default - call error_mesg ('sat_vapor_pres_mod::temp_check_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_mod::temp_check_3d',& + & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select end subroutine temp_check_3d @@ -2739,7 +2744,8 @@ subroutine show_all_bad_0d ( temp ) write(unit,'(a,e10.3,a,i6)') 'Bad temperature=',temp,' pe=',mpp_pe() endif class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_mod::show_all_bad_0d',& + & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select end subroutine show_all_bad_0d @@ -2768,7 +2774,8 @@ subroutine show_all_bad_1d ( temp ) endif enddo class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_mod::show_all_bad_1d',& + & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select end subroutine show_all_bad_1d @@ -2801,7 +2808,8 @@ subroutine show_all_bad_2d ( temp ) enddo enddo class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_mod::show_all_bad_2d',& + & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select end subroutine show_all_bad_2d @@ -2838,7 +2846,8 @@ subroutine show_all_bad_3d ( temp ) enddo enddo class default - call error_mesg ('sat_vapor_pres_mod::show_all_bad_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_mod::show_all_bad_3d',& + & 'The temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select end subroutine show_all_bad_3d diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index 87790a8e2f..aa7bc813fa 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -513,7 +513,8 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL) end if if (present(q)) then @@ -532,7 +533,8 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL) end if if (present(hc)) then @@ -551,7 +553,8 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL) end if if (present(dqsdT)) then @@ -570,7 +573,8 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL) end if if (present(esat)) then @@ -589,7 +593,8 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if select type (temp) @@ -833,7 +838,8 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL) end if if (present(q)) then @@ -852,7 +858,8 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL) end if if (present(hc)) then @@ -871,7 +878,8 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL) end if if (present(dqsdT)) then @@ -890,7 +898,8 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL) end if if (present(esat)) then @@ -909,7 +918,8 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if select type (temp) @@ -1149,7 +1159,8 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL) end if if (present(q)) then @@ -1168,7 +1179,8 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL) end if if (present(hc)) then @@ -1187,7 +1199,8 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL) end if if (present(dqsdT)) then @@ -1206,7 +1219,8 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL) end if if (present(esat)) then @@ -1225,7 +1239,8 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if select type (temp) @@ -1460,7 +1475,8 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, press and qs types do not match', FATAL) end if if (present(q)) then @@ -1479,7 +1495,8 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and q types do not match', FATAL) end if if (present(hc)) then @@ -1498,7 +1515,8 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and hc types do not match', FATAL) end if if (present(dqsdT)) then @@ -1517,7 +1535,8 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and dqsdT types do not match', FATAL) end if if (present(esat)) then @@ -1536,7 +1555,8 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & end select end if if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::compute_qs_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if if (present(hc)) then @@ -2080,7 +2100,8 @@ subroutine lookup_es_des_k_3d (temp, esat, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_3d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) end if nbad = 0 @@ -2164,7 +2185,8 @@ subroutine lookup_es_des_k_2d (temp, esat, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_2d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) end if nbad = 0 @@ -2244,7 +2266,8 @@ subroutine lookup_es_des_k_1d (temp, esat, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_1d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) end if nbad = 0 @@ -2308,7 +2331,8 @@ subroutine lookup_es_des_k_0d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) tmp = temp-tminl class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select ind = int(dtinvl*(tmp+tepsl)) @@ -2322,7 +2346,8 @@ subroutine lookup_es_des_k_0d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) esat = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& + & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select select type (desat) @@ -2331,7 +2356,8 @@ subroutine lookup_es_des_k_0d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& + & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select endif @@ -2360,7 +2386,8 @@ subroutine lookup_es_k_3d(temp, esat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_k_3d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if nbad = 0 @@ -2429,7 +2456,8 @@ subroutine lookup_des_k_3d(temp, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_3d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) end if nbad = 0 @@ -2497,7 +2525,8 @@ subroutine lookup_des_k_2d(temp, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_2d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) end if nbad = 0 @@ -2560,7 +2589,8 @@ subroutine lookup_es_k_2d(temp, esat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_k_2d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if nbad = 0 @@ -2623,7 +2653,8 @@ subroutine lookup_des_k_1d(temp, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_1d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) end if nbad = 0 @@ -2682,7 +2713,8 @@ subroutine lookup_es_k_1d(temp, esat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_k_1d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if nbad = 0 @@ -2735,7 +2767,8 @@ subroutine lookup_des_k_0d(temp, desat, nbad) type is (real(kind=r8_kind)) tmp = temp-tminl class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select ind = int(dtinvl*(tmp+tepsl)) @@ -2749,7 +2782,8 @@ subroutine lookup_des_k_0d(temp, desat, nbad) type is (real(kind=r8_kind)) desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',& + & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select endif @@ -2770,7 +2804,8 @@ subroutine lookup_es_k_0d(temp, esat, nbad) type is (real(kind=r8_kind)) tmp = temp-tminl class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select ind = int(dtinvl*(tmp+tepsl)) @@ -2784,7 +2819,8 @@ subroutine lookup_es_k_0d(temp, esat, nbad) type is (real(kind=r8_kind)) esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',& + & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select endif @@ -2819,7 +2855,8 @@ subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_3d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) end if nbad = 0 @@ -2903,7 +2940,8 @@ subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_2d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) end if nbad = 0 @@ -2983,7 +3021,8 @@ subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_1d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) end if nbad = 0 @@ -3047,7 +3086,8 @@ subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) tmp = temp-tminl class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select ind = int(dtinvl*(tmp+tepsl)) @@ -3061,7 +3101,8 @@ subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) esat = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& + & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select select type (desat) @@ -3070,7 +3111,8 @@ subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& + & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select endif @@ -3099,7 +3141,8 @@ subroutine lookup_es2_k_3d(temp, esat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_3d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if nbad = 0 @@ -3168,7 +3211,8 @@ subroutine lookup_des2_k_3d(temp, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_3d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) end if nbad = 0 @@ -3236,7 +3280,8 @@ subroutine lookup_des2_k_2d(temp, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_2d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) end if nbad = 0 @@ -3299,7 +3344,8 @@ subroutine lookup_es2_k_2d(temp, esat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_2d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if nbad = 0 @@ -3362,7 +3408,8 @@ subroutine lookup_des2_k_1d(temp, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_1d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) end if nbad = 0 @@ -3421,7 +3468,8 @@ subroutine lookup_es2_k_1d(temp, esat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_1d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if nbad = 0 @@ -3474,7 +3522,8 @@ subroutine lookup_des2_k_0d(temp, desat, nbad) type is (real(kind=r8_kind)) tmp = temp-tminl class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select ind = int(dtinvl*(tmp+tepsl)) @@ -3488,7 +3537,8 @@ subroutine lookup_des2_k_0d(temp, desat, nbad) type is (real(kind=r8_kind)) desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',& + & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select endif @@ -3509,7 +3559,8 @@ subroutine lookup_es2_k_0d(temp, esat, nbad) type is (real(kind=r8_kind)) tmp = temp-tminl class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select ind = int(dtinvl*(tmp+tepsl)) @@ -3523,7 +3574,8 @@ subroutine lookup_es2_k_0d(temp, esat, nbad) type is (real(kind=r8_kind)) esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',& + & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select endif @@ -3560,7 +3612,8 @@ subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_3d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) end if nbad = 0 @@ -3644,7 +3697,8 @@ subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_2d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) end if nbad = 0 @@ -3724,7 +3778,8 @@ subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_1d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp, esat and desat types do not match', FATAL) end if nbad = 0 @@ -3788,7 +3843,8 @@ subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) tmp = temp-tminl class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select ind = int(dtinvl*(tmp+tepsl)) @@ -3802,7 +3858,8 @@ subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) esat = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& + & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select select type (desat) @@ -3811,7 +3868,8 @@ subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& + & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select endif @@ -3840,7 +3898,8 @@ subroutine lookup_es3_k_3d(temp, esat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_3d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if nbad = 0 @@ -3909,7 +3968,8 @@ subroutine lookup_des3_k_3d(temp, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_3d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_3d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) end if nbad = 0 @@ -3977,7 +4037,8 @@ subroutine lookup_des3_k_2d(temp, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_2d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) end if nbad = 0 @@ -4040,7 +4101,8 @@ subroutine lookup_es3_k_2d(temp, esat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_2d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_2d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if nbad = 0 @@ -4103,7 +4165,8 @@ subroutine lookup_des3_k_1d(temp, desat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_1d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and desat types do not match', FATAL) end if nbad = 0 @@ -4162,7 +4225,8 @@ subroutine lookup_es3_k_1d(temp, esat, nbad) end select end select if ( .not. valid_types ) then - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_1d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_1d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8) OR temp and esat types do not match', FATAL) end if nbad = 0 @@ -4215,7 +4279,8 @@ subroutine lookup_des3_k_0d(temp, desat, nbad) type is (real(kind=r8_kind)) tmp = temp-tminl class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select ind = int(dtinvl*(tmp+tepsl)) @@ -4229,7 +4294,8 @@ subroutine lookup_des3_k_0d(temp, desat, nbad) type is (real(kind=r8_kind)) desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',& + & 'desat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select endif @@ -4250,7 +4316,8 @@ subroutine lookup_es3_k_0d(temp, esat, nbad) type is (real(kind=r8_kind)) tmp = temp-tminl class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',& + & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select ind = int(dtinvl*(tmp+tepsl)) @@ -4264,7 +4331,8 @@ subroutine lookup_es3_k_0d(temp, esat, nbad) type is (real(kind=r8_kind)) esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) class default - call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d', 'unsupported kind', FATAL) + call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',& + & 'esat is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select endif diff --git a/time_manager/time_manager.F90 b/time_manager/time_manager.F90 index a8cc7668fd..fd2d1f4e3a 100644 --- a/time_manager/time_manager.F90 +++ b/time_manager/time_manager.F90 @@ -1220,7 +1220,8 @@ function real_to_time_type(x,err_msg) result(t) type is (real(kind=r8_kind)) a = x/spd class default - call error_mesg('time_manager_mod::real_to_time_type', 'unsupported kind', FATAL) + call error_mesg('time_manager_mod::real_to_time_type',& + & 'x is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select days = safe_rtoi(a,do_floor) @@ -1231,7 +1232,8 @@ function real_to_time_type(x,err_msg) result(t) type is (real(kind=r8_kind)) a = x - real(days)*spd class default - call error_mesg('time_manager_mod::real_to_time_type', 'unsupported kind', FATAL) + call error_mesg('time_manager_mod::real_to_time_type',& + & 'x is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) end select seconds = safe_rtoi(a,do_floor) diff --git a/tracer_manager/tracer_manager.F90 b/tracer_manager/tracer_manager.F90 index 9d7aef4edc..348b704a81 100644 --- a/tracer_manager/tracer_manager.F90 +++ b/tracer_manager/tracer_manager.F90 @@ -1071,7 +1071,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg) type is (real(kind=r8_kind)) tracer = surf_value class default - call mpp_error(FATAL, "set_tracer_profile : unsupported kind") + call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)") end select if ( query_method ( 'profile_type',model,n,scheme,control)) then @@ -1087,7 +1087,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg) type is (real(kind=r8_kind)) tracer = surf_value class default - call mpp_error(FATAL, "set_tracer_profile : unsupported kind") + call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)") end select endif @@ -1133,7 +1133,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg) tracer(:,:,k) = tracer(:,:,k-1) * multiplier enddo class default - call mpp_error(FATAL, "set_tracer_profile : unsupported kind") + call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)") end select case (MODEL_OCEAN) multiplier = exp( log (bottom_value/surf_value) /numlevels) @@ -1149,7 +1149,7 @@ subroutine set_tracer_profile(model, n, tracer, err_msg) tracer(:,:,k) = tracer(:,:,k+1) * multiplier enddo class default - call mpp_error(FATAL, "set_tracer_profile : unsupported kind") + call mpp_error(FATAL, "set_tracer_profile : tracer is not one of the supported types of real(kind=4) or real(kind=8)") end select case default end select From 947a17d6313b238eec77968708350a1fdaff3797 Mon Sep 17 00:00:00 2001 From: MinsukJi-NOAA Date: Wed, 12 Jan 2022 18:39:08 +0000 Subject: [PATCH 2/5] Add doxygen comment to valid_types in sat_vapor_pres/sat_vapor_pres_k.F90 --- sat_vapor_pres/sat_vapor_pres_k.F90 | 62 ++++++++++++++--------------- 1 file changed, 31 insertions(+), 31 deletions(-) diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index aa7bc813fa..15e0562a6d 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -492,7 +492,7 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & real(kind=r8_kind), allocatable, dimension(:,:,:) :: esloc_r8, desat_r8, denom_r8 integer :: i, j, k real :: hc_loc - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -817,7 +817,7 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & real(kind=r8_kind), allocatable, dimension(:,:) :: esloc_r8, desat_r8, denom_r8 integer :: i, j real :: hc_loc - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -1138,7 +1138,7 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & real(kind=r8_kind), allocatable, dimension(:) :: esloc_r8, desat_r8, denom_r8 integer :: i real :: hc_loc - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -1454,7 +1454,7 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & real(kind=r4_kind) :: esloc_r4, desat_r4, denom_r4 real(kind=r8_kind) :: esloc_r8, desat_r8, denom_r8 real :: hc_loc - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2079,7 +2079,7 @@ subroutine lookup_es_des_k_3d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2164,7 +2164,7 @@ subroutine lookup_es_des_k_2d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2245,7 +2245,7 @@ subroutine lookup_es_des_k_1d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2371,7 +2371,7 @@ subroutine lookup_es_k_3d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2441,7 +2441,7 @@ subroutine lookup_des_k_3d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2510,7 +2510,7 @@ subroutine lookup_des_k_2d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2574,7 +2574,7 @@ subroutine lookup_es_k_2d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2638,7 +2638,7 @@ subroutine lookup_des_k_1d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2698,7 +2698,7 @@ subroutine lookup_es_k_1d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2834,7 +2834,7 @@ subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -2919,7 +2919,7 @@ subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3000,7 +3000,7 @@ subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3126,7 +3126,7 @@ subroutine lookup_es2_k_3d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3196,7 +3196,7 @@ subroutine lookup_des2_k_3d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3265,7 +3265,7 @@ subroutine lookup_des2_k_2d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3329,7 +3329,7 @@ subroutine lookup_es2_k_2d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3393,7 +3393,7 @@ subroutine lookup_des2_k_1d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3453,7 +3453,7 @@ subroutine lookup_es2_k_1d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3591,7 +3591,7 @@ subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3676,7 +3676,7 @@ subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3757,7 +3757,7 @@ subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad) real :: tmp, del integer :: ind, i - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3883,7 +3883,7 @@ subroutine lookup_es3_k_3d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -3953,7 +3953,7 @@ subroutine lookup_des3_k_3d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j, k - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -4022,7 +4022,7 @@ subroutine lookup_des3_k_2d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -4086,7 +4086,7 @@ subroutine lookup_es3_k_2d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i, j - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -4150,7 +4150,7 @@ subroutine lookup_des3_k_1d(temp, desat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) @@ -4210,7 +4210,7 @@ subroutine lookup_es3_k_1d(temp, esat, nbad) integer, intent(out) :: nbad real :: tmp, del integer :: ind, i - logical :: valid_types = .false. + logical :: valid_types = .false. !< For checking if variable types match select type (temp) type is (real(kind=r4_kind)) From e2e3c311c0a30a48886c312f3cc8ac4de25ef616 Mon Sep 17 00:00:00 2001 From: MinsukJi-NOAA Date: Thu, 13 Jan 2022 21:48:33 +0000 Subject: [PATCH 3/5] Modify codes for r8-r4 conversion to remove compiler warnings --- diag_manager/diag_axis.F90 | 4 +- diag_manager/diag_grid.F90 | 12 +- diag_manager/diag_manager.F90 | 38 ++-- diag_manager/diag_util.F90 | 8 +- sat_vapor_pres/sat_vapor_pres_k.F90 | 304 ++++++++++++++-------------- time_manager/time_manager.F90 | 4 +- 6 files changed, 185 insertions(+), 185 deletions(-) diff --git a/diag_manager/diag_axis.F90 b/diag_manager/diag_axis.F90 index 13daf3cf35..8f19ed865b 100644 --- a/diag_manager/diag_axis.F90 +++ b/diag_manager/diag_axis.F90 @@ -235,7 +235,7 @@ INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, directi TYPE IS (real(kind=r4_kind)) Axes(diag_axis_init)%data = DATA(1:axlen) TYPE IS (real(kind=r8_kind)) - Axes(diag_axis_init)%data = DATA(1:axlen) + Axes(diag_axis_init)%data = real(DATA(1:axlen)) CLASS DEFAULT CALL error_mesg('diag_axis_mod::diag_axis_init',& & 'The axis data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -491,7 +491,7 @@ SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,& ELSE SELECT TYPE (DATA) TYPE IS (real(kind=r4_kind)) - DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length) + DATA(1:Axes(id)%length) = real(Axes(id)%data(1:Axes(id)%length), kind=r4_kind) TYPE IS (real(kind=r8_kind)) DATA(1:Axes(id)%length) = Axes(id)%data(1:Axes(id)%length) CLASS DEFAULT diff --git a/diag_manager/diag_grid.F90 b/diag_manager/diag_grid.F90 index 99a474c9a3..12b9c9115f 100644 --- a/diag_manager/diag_grid.F90 +++ b/diag_manager/diag_grid.F90 @@ -258,7 +258,7 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r4_kind)) diag_global_grid%aglo_lat = TRANSPOSE(aglo_lat) TYPE IS (real(kind=r8_kind)) - diag_global_grid%aglo_lat = TRANSPOSE(aglo_lat) + diag_global_grid%aglo_lat = TRANSPOSE(real(aglo_lat)) CLASS DEFAULT CALL error_mesg('diag_grid_mod::diag_grid_init',& & 'The a-grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -268,7 +268,7 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r4_kind)) diag_global_grid%aglo_lon = TRANSPOSE(aglo_lon) TYPE IS (real(kind=r8_kind)) - diag_global_grid%aglo_lon = TRANSPOSE(aglo_lon) + diag_global_grid%aglo_lon = TRANSPOSE(real(aglo_lon)) CLASS DEFAULT CALL error_mesg('diag_grid_mod::diag_grid_init',& & 'The a-grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -278,7 +278,7 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r4_kind)) diag_global_grid%aglo_lat = aglo_lat TYPE IS (real(kind=r8_kind)) - diag_global_grid%aglo_lat = aglo_lat + diag_global_grid%aglo_lat = real(aglo_lat) CLASS DEFAULT CALL error_mesg('diag_grid_mod::diag_grid_init',& & 'The a-grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -288,7 +288,7 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r4_kind)) diag_global_grid%aglo_lon = aglo_lon TYPE IS (real(kind=r8_kind)) - diag_global_grid%aglo_lon = aglo_lon + diag_global_grid%aglo_lon = real(aglo_lon) CLASS DEFAULT CALL error_mesg('diag_grid_mod::diag_grid_init',& & 'The a-grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -299,7 +299,7 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r4_kind)) diag_global_grid%glo_lat = glo_lat TYPE IS (real(kind=r8_kind)) - diag_global_grid%glo_lat = glo_lat + diag_global_grid%glo_lat = real(glo_lat) CLASS DEFAULT CALL error_mesg('diag_grid_mod::diag_grid_init',& & 'The grid latitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -309,7 +309,7 @@ SUBROUTINE diag_grid_init(domain, glo_lat, glo_lon, aglo_lat, aglo_lon) TYPE IS (real(kind=r4_kind)) diag_global_grid%glo_lon = glo_lon TYPE IS (real(kind=r8_kind)) - diag_global_grid%glo_lon = glo_lon + diag_global_grid%glo_lon = real(glo_lon) CLASS DEFAULT CALL error_mesg('diag_grid_mod::diag_grid_init',& & 'The grid longitude data is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 4d80482432..8c81793331 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -622,8 +622,8 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, INTEGER, OPTIONAL, INTENT(in) :: volume !< Field ID for the volume field associated with this field CHARACTER(len=*), OPTIONAL, INTENT(in) :: realm !< String to set as the value to the modeling_realm attribute - REAL :: missing_value_use - REAL, DIMENSION(2) :: range_use + REAL :: missing_value_use !< Local copy of missing_value + REAL, DIMENSION(2) :: range_use !< Local copy of range INTEGER :: field, num_axes, j, out_num, k INTEGER, DIMENSION(3) :: siz, local_siz, local_start, local_end ! indices of local domain of global axes INTEGER :: tile, file_num @@ -646,7 +646,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, TYPE IS (real(kind=r4_kind)) missing_value_use = missing_value TYPE IS (real(kind=r8_kind)) - missing_value_use = missing_value + missing_value_use = real(missing_value) CLASS DEFAULT CALL error_mesg ('diag_manager_mod::register_static_field',& & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -809,7 +809,7 @@ INTEGER FUNCTION register_static_field(module_name, field_name, axes, long_name, TYPE IS (real(kind=r4_kind)) range_use = range TYPE IS (real(kind=r8_kind)) - range_use = range + range_use = real(range) CLASS DEFAULT CALL error_mesg ('diag_manager_mod::register_static_field',& & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1286,7 +1286,7 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) TYPE(time_type), INTENT(in), OPTIONAL :: time CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - REAL :: field_out(1, 1, 1) + REAL :: field_out(1, 1, 1) !< 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 @@ -1299,7 +1299,7 @@ LOGICAL FUNCTION send_data_0d(diag_field_id, field, time, err_msg) TYPE IS (real(kind=r4_kind)) field_out(1, 1, 1) = field TYPE IS (real(kind=r8_kind)) - field_out(1, 1, 1) = field + field_out(1, 1, 1) = real(field) CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_0d',& & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1319,8 +1319,8 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out - LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out + REAL, DIMENSION(SIZE(field(:)), 1, 1) :: field_out !< Local copy of field + 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 @@ -1333,7 +1333,7 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie TYPE IS (real(kind=r4_kind)) field_out(:, 1, 1) = field TYPE IS (real(kind=r8_kind)) - field_out(:, 1, 1) = field + field_out(:, 1, 1) = real(field) CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_1d',& & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1349,9 +1349,9 @@ LOGICAL FUNCTION send_data_1d(diag_field_id, field, time, is_in, mask, rmask, ie IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) - WHERE (rmask < 0.5) mask_out(:, 1, 1) = .FALSE. + WHERE (rmask < 0.5_r4_kind) mask_out(:, 1, 1) = .FALSE. TYPE IS (real(kind=r8_kind)) - WHERE (rmask < 0.5) mask_out(:, 1, 1) = .FALSE. + WHERE (rmask < 0.5_r8_kind) mask_out(:, 1, 1) = .FALSE. CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_1d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1388,8 +1388,8 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & CLASS(*), INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg - REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out - LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out + 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 ! If diag_field_id is < 0 it means that this field is not registered, simply return IF ( diag_field_id <= 0 ) THEN @@ -1402,7 +1402,7 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & TYPE IS (real(kind=r4_kind)) field_out(:, :, 1) = field TYPE IS (real(kind=r8_kind)) - field_out(:, :, 1) = field + field_out(:, :, 1) = real(field) CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_2d',& & 'The field is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1418,9 +1418,9 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & IF ( PRESENT(rmask) ) THEN SELECT TYPE (rmask) TYPE IS (real(kind=r4_kind)) - WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE. + WHERE ( rmask < 0.5_r4_kind ) mask_out(:, :, 1) = .FALSE. TYPE IS (real(kind=r8_kind)) - WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE. + WHERE ( rmask < 0.5_r8_kind ) mask_out(:, :, 1) = .FALSE. CLASS DEFAULT CALL error_mesg ('diag_manager_mod::send_data_2d',& & 'The rmask is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1631,7 +1631,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & CHARACTER(len=256) :: err_msg_local CHARACTER(len=128) :: error_string, error_string1 - REAL, ALLOCATABLE, DIMENSION(:,:,:) :: field_out + 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 @@ -1666,7 +1666,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & TYPE IS (real(kind=r4_kind)) field_out = field TYPE IS (real(kind=r8_kind)) - field_out = field + 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) @@ -1800,7 +1800,7 @@ LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & TYPE IS (real(kind=r4_kind)) weight1 = weight TYPE IS (real(kind=r8_kind)) - weight1 = weight + 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) diff --git a/diag_manager/diag_util.F90 b/diag_manager/diag_util.F90 index fe3be65786..10598cedf1 100644 --- a/diag_manager/diag_util.F90 +++ b/diag_manager/diag_util.F90 @@ -643,8 +643,8 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& CHARACTER(len=1) :: sep = '|' CHARACTER(len=256) :: axis_name, axes_list INTEGER :: i - REAL :: missing_value_use - REAL, DIMENSION(2) :: range_use + REAL :: missing_value_use !< Local copy of missing_value + REAL, DIMENSION(2) :: range_use !< Local copy of range IF ( .NOT.do_diag_field_log ) RETURN IF ( mpp_pe().NE.mpp_root_pe() ) RETURN @@ -682,7 +682,7 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& TYPE IS (real(kind=r4_kind)) missing_value_use = missing_value TYPE IS (real(kind=r8_kind)) - missing_value_use = missing_value + missing_value_use = real(missing_value) CLASS DEFAULT CALL error_mesg ('diag_util_mod::log_diag_field_info',& & 'The missing_value is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -698,7 +698,7 @@ SUBROUTINE log_diag_field_info(module_name, field_name, axes, long_name, units,& TYPE IS (real(kind=r4_kind)) range_use = range TYPE IS (real(kind=r8_kind)) - range_use = range + range_use = real(range) CLASS DEFAULT CALL error_mesg ('diag_util_mod::log_diag_field_info',& & 'The range is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) diff --git a/sat_vapor_pres/sat_vapor_pres_k.F90 b/sat_vapor_pres/sat_vapor_pres_k.F90 index 15e0562a6d..3a1ba4f43b 100644 --- a/sat_vapor_pres/sat_vapor_pres_k.F90 +++ b/sat_vapor_pres/sat_vapor_pres_k.F90 @@ -488,8 +488,8 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & logical,intent(in), optional :: es_over_liq logical,intent(in), optional :: es_over_liq_and_ice - real(kind=r4_kind), allocatable, dimension(:,:,:) :: esloc_r4, desat_r4, denom_r4 - real(kind=r8_kind), allocatable, dimension(:,:,:) :: esloc_r8, desat_r8, denom_r8 + real(kind=r4_kind), allocatable, dimension(:,:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments + real(kind=r8_kind), allocatable, dimension(:,:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments integer :: i, j, k real :: hc_loc logical :: valid_types = .false. !< For checking if variable types match @@ -613,7 +613,7 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & type is (real(kind=r4_kind)) hc_loc = hc type is (real(kind=r8_kind)) - hc_loc = hc + hc_loc = real(hc) end select else hc_loc = 1.0 @@ -624,7 +624,7 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -642,7 +642,7 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -660,7 +660,7 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -677,7 +677,7 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*hc_loc + esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) esloc_r8 = esloc_r8*hc_loc end select @@ -699,23 +699,23 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & if (present (q) .and. use_exact_qs) then select type (q) type is (real(kind=r4_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r4/press + qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r4/press + dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press end select endif end select else ! (present(q)) - denom_r4 = press - (1.0 - eps)*esloc_r4 + denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 do k=1,size(qs,3) do j=1,size(qs,2) do i=1,size(qs,1) - if (denom_r4(i,j,k) > 0.0) then - qs(i,j,k) = eps*esloc_r4(i,j,k)/denom_r4(i,j,k) + if (denom_r4(i,j,k) > 0.0_r4_kind) then + qs(i,j,k) = real(eps, kind=r4_kind)*esloc_r4(i,j,k)/denom_r4(i,j,k) else - qs(i,j,k) = eps + qs(i,j,k) = real(eps, kind=r4_kind) endif end do end do @@ -723,7 +723,7 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = eps*press*desat_r4/denom_r4**2 + dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 end select endif endif ! (present(q)) @@ -767,14 +767,14 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & else ! (nbad = 0) select type (qs) type is (real(kind=r4_kind)) - qs = -999. + qs = -999.0_r4_kind type is (real(kind=r8_kind)) qs = -999. end select if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = -999. + dqsdT = -999.0_r4_kind type is (real(kind=r8_kind)) dqsdT = -999. end select @@ -782,7 +782,7 @@ subroutine compute_qs_k_3d (temp, press, eps, zvir, qs, nbad, q, hc, & if (present (esat)) then select type (esat) type is (real(kind=r4_kind)) - esat = -999. + esat = -999.0_r4_kind type is (real(kind=r8_kind)) esat = -999. end select @@ -813,8 +813,8 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & logical,intent(in), optional :: es_over_liq logical,intent(in), optional :: es_over_liq_and_ice - real(kind=r4_kind), allocatable, dimension(:,:) :: esloc_r4, desat_r4, denom_r4 - real(kind=r8_kind), allocatable, dimension(:,:) :: esloc_r8, desat_r8, denom_r8 + real(kind=r4_kind), allocatable, dimension(:,:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments + real(kind=r8_kind), allocatable, dimension(:,:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments integer :: i, j real :: hc_loc logical :: valid_types = .false. !< For checking if variable types match @@ -938,7 +938,7 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & type is (real(kind=r4_kind)) hc_loc = hc type is (real(kind=r8_kind)) - hc_loc = hc + hc_loc = real(hc) end select else hc_loc = 1.0 @@ -949,7 +949,7 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -967,7 +967,7 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -985,7 +985,7 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -1002,7 +1002,7 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*hc_loc + esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) esloc_r8 = esloc_r8*hc_loc end select @@ -1024,29 +1024,29 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & if (present (q) .and. use_exact_qs) then select type (q) type is (real(kind=r4_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r4/press + qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r4/press + dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press end select endif end select else ! (present(q)) - denom_r4 = press - (1.0 - eps)*esloc_r4 + denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 do j=1,size(qs,2) do i=1,size(qs,1) - if (denom_r4(i,j) > 0.0) then - qs(i,j) = eps*esloc_r4(i,j)/denom_r4(i,j) + if (denom_r4(i,j) > 0.0_r4_kind) then + qs(i,j) = real(eps, kind=r4_kind)*esloc_r4(i,j)/denom_r4(i,j) else - qs(i,j) = eps + qs(i,j) = real(eps, kind=r4_kind) endif end do end do if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = eps*press*desat_r4/denom_r4**2 + dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 end select endif endif ! (present(q)) @@ -1088,14 +1088,14 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & else ! (nbad = 0) select type (qs) type is (real(kind=r4_kind)) - qs = -999. + qs = -999.0_r4_kind type is (real(kind=r8_kind)) qs = -999. end select if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = -999. + dqsdT = -999.0_r4_kind type is (real(kind=r8_kind)) dqsdT = -999. end select @@ -1103,7 +1103,7 @@ subroutine compute_qs_k_2d (temp, press, eps, zvir, qs, nbad, q, hc, & if (present (esat)) then select type (esat) type is (real(kind=r4_kind)) - esat = -999. + esat = -999.0_r4_kind type is (real(kind=r8_kind)) esat = -999. end select @@ -1134,8 +1134,8 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & logical,intent(in), optional :: es_over_liq logical,intent(in), optional :: es_over_liq_and_ice - real(kind=r4_kind), allocatable, dimension(:) :: esloc_r4, desat_r4, denom_r4 - real(kind=r8_kind), allocatable, dimension(:) :: esloc_r8, desat_r8, denom_r8 + real(kind=r4_kind), allocatable, dimension(:) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments + real(kind=r8_kind), allocatable, dimension(:) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments integer :: i real :: hc_loc logical :: valid_types = .false. !< For checking if variable types match @@ -1259,7 +1259,7 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & type is (real(kind=r4_kind)) hc_loc = hc type is (real(kind=r8_kind)) - hc_loc = hc + hc_loc = real(hc) end select else hc_loc = 1.0 @@ -1270,7 +1270,7 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -1288,7 +1288,7 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -1306,7 +1306,7 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -1323,7 +1323,7 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*hc_loc + esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) esloc_r8 = esloc_r8*hc_loc end select @@ -1345,27 +1345,27 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & if (present (q) .and. use_exact_qs) then select type (q) type is (real(kind=r4_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r4/press + qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r4/press + dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press end select endif end select else ! (present(q)) - denom_r4 = press - (1.0 - eps)*esloc_r4 + denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 do i=1,size(qs,1) - if (denom_r4(i) > 0.0) then - qs(i) = eps*esloc_r4(i)/denom_r4(i) + if (denom_r4(i) > 0.0_r4_kind) then + qs(i) = real(eps, kind=r4_kind)*esloc_r4(i)/denom_r4(i) else - qs(i) = eps + qs(i) = real(eps, kind=r4_kind) endif end do if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = eps*press*desat_r4/denom_r4**2 + dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 end select endif endif ! (present(q)) @@ -1405,14 +1405,14 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & else ! (nbad = 0) select type (qs) type is (real(kind=r4_kind)) - qs = -999. + qs = -999.0_r4_kind type is (real(kind=r8_kind)) qs = -999. end select if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = -999. + dqsdT = -999.0_r4_kind type is (real(kind=r8_kind)) dqsdT = -999. end select @@ -1420,7 +1420,7 @@ subroutine compute_qs_k_1d (temp, press, eps, zvir, qs, nbad, q, hc, & if (present (esat)) then select type (esat) type is (real(kind=r4_kind)) - esat = -999. + esat = -999.0_r4_kind type is (real(kind=r8_kind)) esat = -999. end select @@ -1451,8 +1451,8 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & logical,intent(in), optional :: es_over_liq logical,intent(in), optional :: es_over_liq_and_ice - real(kind=r4_kind) :: esloc_r4, desat_r4, denom_r4 - real(kind=r8_kind) :: esloc_r8, desat_r8, denom_r8 + real(kind=r4_kind) :: esloc_r4, desat_r4, denom_r4 !< Local variables to use when called with r4 arguments + real(kind=r8_kind) :: esloc_r8, desat_r8, denom_r8 !< Local variables to use when called with r8 arguments real :: hc_loc logical :: valid_types = .false. !< For checking if variable types match @@ -1564,7 +1564,7 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & type is (real(kind=r4_kind)) hc_loc = hc type is (real(kind=r8_kind)) - hc_loc = hc + hc_loc = real(hc) end select else hc_loc = 1.0 @@ -1575,7 +1575,7 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es2_des2_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es2_des2_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -1593,7 +1593,7 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es3_des3_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es3_des3_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -1611,7 +1611,7 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) call lookup_es_des_k (temp, esloc_r4, desat_r4, nbad) - desat_r4 = desat_r4*hc_loc + desat_r4 = desat_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) call lookup_es_des_k (temp, esloc_r8, desat_r8, nbad) desat_r8 = desat_r8*hc_loc @@ -1628,7 +1628,7 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & select type (temp) type is (real(kind=r4_kind)) - esloc_r4 = esloc_r4*hc_loc + esloc_r4 = esloc_r4*real(hc_loc, kind=r4_kind) type is (real(kind=r8_kind)) esloc_r8 = esloc_r8*hc_loc end select @@ -1650,25 +1650,25 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & if (present (q) .and. use_exact_qs) then select type (q) type is (real(kind=r4_kind)) - qs = (1.0 + zvir*q)*eps*esloc_r4/press + qs = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*esloc_r4/press if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = (1.0 + zvir*q)*eps*desat_r4/press + dqsdT = (1.0_r4_kind + real(zvir, kind=r4_kind)*q)*real(eps, kind=r4_kind)*desat_r4/press end select endif end select else ! (present(q)) - denom_r4 = press - (1.0 - eps)*esloc_r4 - if (denom_r4 > 0.0) then - qs = eps*esloc_r4/denom_r4 + denom_r4 = press - (1.0_r4_kind - real(eps, kind=r4_kind))*esloc_r4 + if (denom_r4 > 0.0_r4_kind) then + qs = real(eps, kind=r4_kind)*esloc_r4/denom_r4 else - qs = eps + qs = real(eps, kind=r4_kind) endif if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = eps*press*desat_r4/denom_r4**2 + dqsdT = real(eps, kind=r4_kind)*press*desat_r4/denom_r4**2 end select endif endif ! (present(q)) @@ -1706,14 +1706,14 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & else ! (nbad = 0) select type (qs) type is (real(kind=r4_kind)) - qs = -999. + qs = -999.0_r4_kind type is (real(kind=r8_kind)) qs = -999. end select if (present (dqsdT)) then select type (dqsdT) type is (real(kind=r4_kind)) - dqsdT = -999. + dqsdT = -999.0_r4_kind type is (real(kind=r8_kind)) dqsdT = -999. end select @@ -1721,7 +1721,7 @@ subroutine compute_qs_k_0d (temp, press, eps, zvir, qs, nbad, q, hc, & if (present (esat)) then select type (esat) type is (real(kind=r4_kind)) - esat = -999. + esat = -999.0_r4_kind type is (real(kind=r8_kind)) esat = -999. end select @@ -2121,8 +2121,8 @@ subroutine lookup_es_des_k_3d (temp, esat, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + esat(i,j,k) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) + desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) endif enddo enddo @@ -2137,7 +2137,7 @@ subroutine lookup_es_des_k_3d (temp, esat, desat, nbad) do k = 1, size(temp,3) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl + tmp = real(temp(i,j,k))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2205,8 +2205,8 @@ subroutine lookup_es_des_k_2d (temp, esat, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + esat(i,j) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) + desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) endif enddo enddo @@ -2219,7 +2219,7 @@ subroutine lookup_es_des_k_2d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j)-tminl + tmp = real(temp(i,j))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2285,8 +2285,8 @@ subroutine lookup_es_des_k_1d (temp, esat, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) - desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) + desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) endif enddo end select @@ -2297,7 +2297,7 @@ subroutine lookup_es_des_k_1d (temp, esat, desat, nbad) select type (desat) type is (real(kind=r8_kind)) do i = 1, size(temp,1) - tmp = temp(i)-tminl + tmp = real(temp(i))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2329,7 +2329,7 @@ subroutine lookup_es_des_k_0d (temp, esat, desat, nbad) type is (real(kind=r4_kind)) tmp = temp-tminl type is (real(kind=r8_kind)) - tmp = temp-tminl + tmp = real(temp)-tminl class default call error_mesg ('sat_vapor_pres_k_mod::lookup_es_des_k_0d',& & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -2342,7 +2342,7 @@ subroutine lookup_es_des_k_0d (temp, esat, desat, nbad) del = tmp-dtres*real(ind) select type (esat) type is (real(kind=r4_kind)) - esat = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) + esat = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) type is (real(kind=r8_kind)) esat = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) class default @@ -2352,7 +2352,7 @@ subroutine lookup_es_des_k_0d (temp, esat, desat, nbad) select type (desat) type is (real(kind=r4_kind)) - desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) type is (real(kind=r8_kind)) desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) class default @@ -2405,7 +2405,7 @@ subroutine lookup_es_k_3d(temp, esat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) + esat(i,j,k) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) endif enddo enddo @@ -2417,7 +2417,7 @@ subroutine lookup_es_k_3d(temp, esat, nbad) do k = 1, size(temp,3) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl + tmp = real(temp(i,j,k))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2475,7 +2475,7 @@ subroutine lookup_des_k_3d(temp, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + desat(i,j,k) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) endif enddo enddo @@ -2487,7 +2487,7 @@ subroutine lookup_des_k_3d(temp, desat, nbad) do k = 1, size(temp,3) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl + tmp = real(temp(i,j,k))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2543,7 +2543,7 @@ subroutine lookup_des_k_2d(temp, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - desat(i,j) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + desat(i,j) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) endif enddo enddo @@ -2553,7 +2553,7 @@ subroutine lookup_des_k_2d(temp, desat, nbad) type is (real(kind=r8_kind)) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j)-tminl + tmp = real(temp(i,j))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2607,7 +2607,7 @@ subroutine lookup_es_k_2d(temp, esat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j) = TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) + esat(i,j) = real(( TABLE(ind+1)+del*(DTABLE(ind+1)+del*D2TABLE(ind+1)) ), kind=r4_kind) endif enddo enddo @@ -2617,7 +2617,7 @@ subroutine lookup_es_k_2d(temp, esat, nbad) type is (real(kind=r8_kind)) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j)-tminl + tmp = real(temp(i,j))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2670,7 +2670,7 @@ subroutine lookup_des_k_1d(temp, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - desat(i) = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + desat(i) = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) endif enddo end select @@ -2678,7 +2678,7 @@ subroutine lookup_des_k_1d(temp, desat, nbad) select type (desat) type is (real(kind=r8_kind)) do i = 1, size(temp,1) - tmp = temp(i)-tminl + tmp = real(temp(i))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2730,7 +2730,7 @@ subroutine lookup_es_k_1d(temp, esat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i) = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) + esat(i) = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind) endif enddo end select @@ -2738,7 +2738,7 @@ subroutine lookup_es_k_1d(temp, esat, nbad) select type (esat) type is (real(kind=r8_kind)) do i = 1, size(temp,1) - tmp = temp(i)-tminl + tmp = real(temp(i))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2765,7 +2765,7 @@ subroutine lookup_des_k_0d(temp, desat, nbad) type is (real(kind=r4_kind)) tmp = temp-tminl type is (real(kind=r8_kind)) - tmp = temp-tminl + tmp = real(temp)-tminl class default call error_mesg ('sat_vapor_pres_k_mod::lookup_des_k_0d',& & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -2778,7 +2778,7 @@ subroutine lookup_des_k_0d(temp, desat, nbad) del = tmp-dtres*real(ind) select type (desat) type is (real(kind=r4_kind)) - desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) + desat = real(( DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) ), kind=r4_kind) type is (real(kind=r8_kind)) desat = DTABLE(ind+1) + 2.*del*D2TABLE(ind+1) class default @@ -2802,7 +2802,7 @@ subroutine lookup_es_k_0d(temp, esat, nbad) type is (real(kind=r4_kind)) tmp = temp-tminl type is (real(kind=r8_kind)) - tmp = temp-tminl + tmp = real(temp)-tminl class default call error_mesg ('sat_vapor_pres_k_mod::lookup_k_0d',& & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -2815,7 +2815,7 @@ subroutine lookup_es_k_0d(temp, esat, nbad) del = tmp-dtres*real(ind) select type (esat) type is (real(kind=r4_kind)) - esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) + esat = real(( TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) ), kind=r4_kind) type is (real(kind=r8_kind)) esat = TABLE(ind+1) + del*(DTABLE(ind+1) + del*D2TABLE(ind+1)) class default @@ -2876,8 +2876,8 @@ subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + esat(i,j,k) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) + desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) endif enddo enddo @@ -2892,7 +2892,7 @@ subroutine lookup_es2_des2_k_3d (temp, esat, desat, nbad) do k = 1, size(temp,3) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl + tmp = real(temp(i,j,k))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -2960,8 +2960,8 @@ subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + esat(i,j) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) + desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) endif enddo enddo @@ -2974,7 +2974,7 @@ subroutine lookup_es2_des2_k_2d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j)-tminl + tmp = real(temp(i,j))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3040,8 +3040,8 @@ subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) - desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) + desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) endif enddo end select @@ -3052,7 +3052,7 @@ subroutine lookup_es2_des2_k_1d (temp, esat, desat, nbad) select type (desat) type is (real(kind=r8_kind)) do i = 1, size(temp,1) - tmp = temp(i)-tminl + tmp = real(temp(i))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3084,7 +3084,7 @@ subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad) type is (real(kind=r4_kind)) tmp = temp-tminl type is (real(kind=r8_kind)) - tmp = temp-tminl + tmp = real(temp)-tminl class default call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_des2_k_0d',& & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -3097,7 +3097,7 @@ subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad) del = tmp-dtres*real(ind) select type (esat) type is (real(kind=r4_kind)) - esat = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) + esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) type is (real(kind=r8_kind)) esat = TABLE2(ind+1) + del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) class default @@ -3107,7 +3107,7 @@ subroutine lookup_es2_des2_k_0d (temp, esat, desat, nbad) select type (desat) type is (real(kind=r4_kind)) - desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) type is (real(kind=r8_kind)) desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) class default @@ -3160,7 +3160,7 @@ subroutine lookup_es2_k_3d(temp, esat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) + esat(i,j,k) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) endif enddo enddo @@ -3172,7 +3172,7 @@ subroutine lookup_es2_k_3d(temp, esat, nbad) do k = 1, size(temp,3) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl + tmp = real(temp(i,j,k))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3230,7 +3230,7 @@ subroutine lookup_des2_k_3d(temp, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + desat(i,j,k) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) endif enddo enddo @@ -3242,7 +3242,7 @@ subroutine lookup_des2_k_3d(temp, desat, nbad) do k = 1, size(temp,3) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl + tmp = real(temp(i,j,k))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3298,7 +3298,7 @@ subroutine lookup_des2_k_2d(temp, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - desat(i,j) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + desat(i,j) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) endif enddo enddo @@ -3308,7 +3308,7 @@ subroutine lookup_des2_k_2d(temp, desat, nbad) type is (real(kind=r8_kind)) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j)-tminl + tmp = real(temp(i,j))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3362,7 +3362,7 @@ subroutine lookup_es2_k_2d(temp, esat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j) = TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) + esat(i,j) = real(( TABLE2(ind+1)+del*(DTABLE2(ind+1)+del*D2TABLE2(ind+1)) ), kind=r4_kind) endif enddo enddo @@ -3372,7 +3372,7 @@ subroutine lookup_es2_k_2d(temp, esat, nbad) type is (real(kind=r8_kind)) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j)-tminl + tmp = real(temp(i,j))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3425,7 +3425,7 @@ subroutine lookup_des2_k_1d(temp, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - desat(i) = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + desat(i) = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) endif enddo end select @@ -3433,7 +3433,7 @@ subroutine lookup_des2_k_1d(temp, desat, nbad) select type (desat) type is (real(kind=r8_kind)) do i = 1, size(temp,1) - tmp = temp(i)-tminl + tmp = real(temp(i))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3485,7 +3485,7 @@ subroutine lookup_es2_k_1d(temp, esat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i) = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) + esat(i) = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) ), kind=r4_kind) endif enddo end select @@ -3493,7 +3493,7 @@ subroutine lookup_es2_k_1d(temp, esat, nbad) select type (esat) type is (real(kind=r8_kind)) do i = 1, size(temp,1) - tmp = temp(i)-tminl + tmp = real(temp(i))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3520,7 +3520,7 @@ subroutine lookup_des2_k_0d(temp, desat, nbad) type is (real(kind=r4_kind)) tmp = temp-tminl type is (real(kind=r8_kind)) - tmp = temp-tminl + tmp = real(temp)-tminl class default call error_mesg ('sat_vapor_pres_k_mod::lookup_des2_k_0d',& & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -3533,7 +3533,7 @@ subroutine lookup_des2_k_0d(temp, desat, nbad) del = tmp-dtres*real(ind) select type (desat) type is (real(kind=r4_kind)) - desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) + desat = real(( DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) ), kind=r4_kind) type is (real(kind=r8_kind)) desat = DTABLE2(ind+1) + 2.*del*D2TABLE2(ind+1) class default @@ -3557,7 +3557,7 @@ subroutine lookup_es2_k_0d(temp, esat, nbad) type is (real(kind=r4_kind)) tmp = temp-tminl type is (real(kind=r8_kind)) - tmp = temp-tminl + tmp = real(temp)-tminl class default call error_mesg ('sat_vapor_pres_k_mod::lookup_es2_k_0d',& & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -3570,7 +3570,7 @@ subroutine lookup_es2_k_0d(temp, esat, nbad) del = tmp-dtres*real(ind) select type (esat) type is (real(kind=r4_kind)) - esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) + esat = real(( TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1))), kind=r4_kind) type is (real(kind=r8_kind)) esat = TABLE2(ind+1) + del*(DTABLE2(ind+1) + del*D2TABLE2(ind+1)) class default @@ -3633,8 +3633,8 @@ subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + esat(i,j,k) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) + desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) endif enddo enddo @@ -3649,7 +3649,7 @@ subroutine lookup_es3_des3_k_3d (temp, esat, desat, nbad) do k = 1, size(temp,3) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl + tmp = real(temp(i,j,k))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3717,8 +3717,8 @@ subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + esat(i,j) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) + desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) endif enddo enddo @@ -3731,7 +3731,7 @@ subroutine lookup_es3_des3_k_2d (temp, esat, desat, nbad) type is (real(kind=r8_kind)) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j)-tminl + tmp = real(temp(i,j))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3797,8 +3797,8 @@ subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) - desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) + desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) endif enddo end select @@ -3809,7 +3809,7 @@ subroutine lookup_es3_des3_k_1d (temp, esat, desat, nbad) select type (desat) type is (real(kind=r8_kind)) do i = 1, size(temp,1) - tmp = temp(i)-tminl + tmp = real(temp(i))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3841,7 +3841,7 @@ subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad) type is (real(kind=r4_kind)) tmp = temp-tminl type is (real(kind=r8_kind)) - tmp = temp-tminl + tmp = real(temp)-tminl class default call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_des3_k_0d',& & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -3854,7 +3854,7 @@ subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad) del = tmp-dtres*real(ind) select type (esat) type is (real(kind=r4_kind)) - esat = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) + esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) type is (real(kind=r8_kind)) esat = TABLE3(ind+1) + del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) class default @@ -3864,7 +3864,7 @@ subroutine lookup_es3_des3_k_0d (temp, esat, desat, nbad) select type (desat) type is (real(kind=r4_kind)) - desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) type is (real(kind=r8_kind)) desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) class default @@ -3917,7 +3917,7 @@ subroutine lookup_es3_k_3d(temp, esat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j,k) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) + esat(i,j,k) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) endif enddo enddo @@ -3929,7 +3929,7 @@ subroutine lookup_es3_k_3d(temp, esat, nbad) do k = 1, size(temp,3) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl + tmp = real(temp(i,j,k))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -3987,7 +3987,7 @@ subroutine lookup_des3_k_3d(temp, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - desat(i,j,k) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + desat(i,j,k) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) endif enddo enddo @@ -3999,7 +3999,7 @@ subroutine lookup_des3_k_3d(temp, desat, nbad) do k = 1, size(temp,3) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j,k)-tminl + tmp = real(temp(i,j,k))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -4055,7 +4055,7 @@ subroutine lookup_des3_k_2d(temp, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - desat(i,j) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + desat(i,j) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) endif enddo enddo @@ -4065,7 +4065,7 @@ subroutine lookup_des3_k_2d(temp, desat, nbad) type is (real(kind=r8_kind)) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j)-tminl + tmp = real(temp(i,j))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -4119,7 +4119,7 @@ subroutine lookup_es3_k_2d(temp, esat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i,j) = TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) + esat(i,j) = real(( TABLE3(ind+1)+del*(DTABLE3(ind+1)+del*D2TABLE3(ind+1)) ), kind=r4_kind) endif enddo enddo @@ -4129,7 +4129,7 @@ subroutine lookup_es3_k_2d(temp, esat, nbad) type is (real(kind=r8_kind)) do j = 1, size(temp,2) do i = 1, size(temp,1) - tmp = temp(i,j)-tminl + tmp = real(temp(i,j))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -4182,7 +4182,7 @@ subroutine lookup_des3_k_1d(temp, desat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - desat(i) = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + desat(i) = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) endif enddo end select @@ -4190,7 +4190,7 @@ subroutine lookup_des3_k_1d(temp, desat, nbad) select type (desat) type is (real(kind=r8_kind)) do i = 1, size(temp,1) - tmp = temp(i)-tminl + tmp = real(temp(i))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -4242,7 +4242,7 @@ subroutine lookup_es3_k_1d(temp, esat, nbad) nbad = nbad+1 else del = tmp-dtres*real(ind) - esat(i) = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) + esat(i) = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) ), kind=r4_kind) endif enddo end select @@ -4250,7 +4250,7 @@ subroutine lookup_es3_k_1d(temp, esat, nbad) select type (esat) type is (real(kind=r8_kind)) do i = 1, size(temp,1) - tmp = temp(i)-tminl + tmp = real(temp(i))-tminl ind = int(dtinvl*(tmp+tepsl)) if (ind < 0 .or. ind >= table_siz) then nbad = nbad+1 @@ -4277,7 +4277,7 @@ subroutine lookup_des3_k_0d(temp, desat, nbad) type is (real(kind=r4_kind)) tmp = temp-tminl type is (real(kind=r8_kind)) - tmp = temp-tminl + tmp = real(temp)-tminl class default call error_mesg ('sat_vapor_pres_k_mod::lookup_des3_k_0d',& & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -4290,7 +4290,7 @@ subroutine lookup_des3_k_0d(temp, desat, nbad) del = tmp-dtres*real(ind) select type (desat) type is (real(kind=r4_kind)) - desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) + desat = real(( DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) ), kind=r4_kind) type is (real(kind=r8_kind)) desat = DTABLE3(ind+1) + 2.*del*D2TABLE3(ind+1) class default @@ -4314,7 +4314,7 @@ subroutine lookup_es3_k_0d(temp, esat, nbad) type is (real(kind=r4_kind)) tmp = temp-tminl type is (real(kind=r8_kind)) - tmp = temp-tminl + tmp = real(temp)-tminl class default call error_mesg ('sat_vapor_pres_k_mod::lookup_es3_k_0d',& & 'temp is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -4327,7 +4327,7 @@ subroutine lookup_es3_k_0d(temp, esat, nbad) del = tmp-dtres*real(ind) select type (esat) type is (real(kind=r4_kind)) - esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) + esat = real(( TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1))), kind=r4_kind) type is (real(kind=r8_kind)) esat = TABLE3(ind+1) + del*(DTABLE3(ind+1) + del*D2TABLE3(ind+1)) class default diff --git a/time_manager/time_manager.F90 b/time_manager/time_manager.F90 index fd2d1f4e3a..02eee5721c 100644 --- a/time_manager/time_manager.F90 +++ b/time_manager/time_manager.F90 @@ -1218,7 +1218,7 @@ function real_to_time_type(x,err_msg) result(t) type is (real(kind=r4_kind)) a = x/spd type is (real(kind=r8_kind)) - a = x/spd + a = real(x)/spd class default call error_mesg('time_manager_mod::real_to_time_type',& & 'x is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) @@ -1230,7 +1230,7 @@ function real_to_time_type(x,err_msg) result(t) type is (real(kind=r4_kind)) a = x - real(days)*spd type is (real(kind=r8_kind)) - a = x - real(days)*spd + a = real(x) - real(days)*spd class default call error_mesg('time_manager_mod::real_to_time_type',& & 'x is not one of the supported types of real(kind=4) or real(kind=8)', FATAL) From a9c1d72d3fc4b5c6ae58a3957b8273f7c1aaefdc Mon Sep 17 00:00:00 2001 From: MinsukJi-NOAA Date: Fri, 14 Jan 2022 14:27:11 +0000 Subject: [PATCH 4/5] Remove OVERLOAD_R8 directives regarding send_data_*d_r8 subroutines --- diag_manager/diag_manager.F90 | 158 ---------------------------------- 1 file changed, 158 deletions(-) diff --git a/diag_manager/diag_manager.F90 b/diag_manager/diag_manager.F90 index 8c81793331..a38777e4f2 100644 --- a/diag_manager/diag_manager.F90 +++ b/diag_manager/diag_manager.F90 @@ -329,12 +329,6 @@ MODULE diag_manager_mod MODULE PROCEDURE send_data_1d MODULE PROCEDURE send_data_2d MODULE PROCEDURE send_data_3d -!#ifdef OVERLOAD_R8 -! MODULE PROCEDURE send_data_0d_r8 -! MODULE PROCEDURE send_data_1d_r8 -! MODULE PROCEDURE send_data_2d_r8 -! MODULE PROCEDURE send_data_3d_r8 -!#endif END INTERFACE !> @brief Register a diagnostic field for a given module @@ -1436,158 +1430,6 @@ LOGICAL FUNCTION send_data_2d(diag_field_id, field, time, is_in, js_in, & END IF END FUNCTION send_data_2d -!#ifdef OVERLOAD_R8 -! -! !> @return true if send is successful -! LOGICAL FUNCTION send_data_0d_r8(diag_field_id, field, time, err_msg) -! INTEGER, INTENT(in) :: diag_field_id -! REAL(r8_kind), INTENT(in) :: field -! TYPE(time_type), INTENT(in), OPTIONAL :: time -! CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg -! -! REAL(r8_kind) :: field_out(1, 1, 1) -! -! ! If diag_field_id is < 0 it means that this field is not registered, simply return -! IF ( diag_field_id <= 0 ) THEN -! send_data_0d_r8 = .FALSE. -! RETURN -! END IF -! ! First copy the data to a three d array with last element 1 -! field_out(1, 1, 1) = field -! send_data_0d_r8 = send_data_3d_r8(diag_field_id, field_out, time, err_msg=err_msg) -! END FUNCTION send_data_0d_r8 -! -! !> @return true if send is successful -! LOGICAL FUNCTION send_data_1d_r8(diag_field_id, field, time, is_in, mask, rmask, ie_in, weight, err_msg) -! INTEGER, INTENT(in) :: diag_field_id -! REAL(r8_kind), DIMENSION(:), INTENT(in) :: field -! REAL, INTENT(in), OPTIONAL :: weight -! REAL, INTENT(in), DIMENSION(:), OPTIONAL :: rmask -! TYPE (time_type), INTENT(in), OPTIONAL :: time -! INTEGER, INTENT(in), OPTIONAL :: is_in, ie_in -! LOGICAL, INTENT(in), DIMENSION(:), OPTIONAL :: mask -! CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg -! -! REAL(r8_kind), DIMENSION(SIZE(field(:)), 1, 1) :: field_out -! LOGICAL, DIMENSION(SIZE(field(:)), 1, 1) :: mask_out -! -! ! If diag_field_id is < 0 it means that this field is not registered, simply return -! IF ( diag_field_id <= 0 ) THEN -! send_data_1d_r8 = .FALSE. -! RETURN -! END IF -! -! ! First copy the data to a three d array with last element 1 -! field_out(:, 1, 1) = field -! -! ! Default values for mask -! IF ( PRESENT(mask) ) THEN -! mask_out(:, 1, 1) = mask -! ELSE -! mask_out = .TRUE. -! END IF -! -! IF ( PRESENT(rmask) ) WHERE (rmask < 0.5) mask_out(:, 1, 1) = .FALSE. -! IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN -! IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN -! send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& -! & mask=mask_out, ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) -! ELSE -! send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, mask=mask_out,& -! & weight=weight, err_msg=err_msg) -! END IF -! ELSE -! IF ( PRESENT(is_in) .OR. PRESENT(ie_in) ) THEN -! send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, is_in=is_in, js_in=1, ks_in=1,& -! & ie_in=ie_in, je_in=1, ke_in=1, weight=weight, err_msg=err_msg) -! ELSE -! send_data_1d_r8 = send_data_3d_r8(diag_field_id, field_out, time, weight=weight, err_msg=err_msg) -! END IF -! END IF -! END FUNCTION send_data_1d_r8 -! !> @return true if send is successful -! LOGICAL FUNCTION send_data_2d_r8(diag_field_id, field, time, is_in, js_in, & -! & mask, rmask, ie_in, je_in, weight, err_msg) -! INTEGER, INTENT(in) :: diag_field_id -! REAL(r8_kind), INTENT(in), DIMENSION(:,:) :: field -! REAL, INTENT(in), OPTIONAL :: weight -! TYPE (time_type), INTENT(in), OPTIONAL :: time -! INTEGER, INTENT(in), OPTIONAL :: is_in, js_in, ie_in, je_in -! LOGICAL, INTENT(in), DIMENSION(:,:), OPTIONAL :: mask -! REAL, INTENT(in), DIMENSION(:,:),OPTIONAL :: rmask -! CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg -! -! REAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: field_out -! LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),1) :: mask_out -! -! ! If diag_field_id is < 0 it means that this field is not registered, simply return -! IF ( diag_field_id <= 0 ) THEN -! send_data_2d_r8 = .FALSE. -! RETURN -! END IF -! -! ! First copy the data to a three d array with last element 1 -! field_out(:, :, 1) = field -! -! ! Default values for mask -! IF ( PRESENT(mask) ) THEN -! mask_out(:, :, 1) = mask -! ELSE -! mask_out = .TRUE. -! END IF -! -! IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) mask_out(:, :, 1) = .FALSE. -! IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN -! send_data_2d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1, mask=mask_out,& -! & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) -! ELSE -! send_data_2d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=1,& -! & ie_in=ie_in, je_in=je_in, ke_in=1, weight=weight, err_msg=err_msg) -! END IF -! END FUNCTION send_data_2d_r8 -! -! !> @return true if send is successful -! LOGICAL FUNCTION send_data_3d_r8(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 -! REAL(r8_kind), INTENT(in), DIMENSION(:,:,:) :: field -! REAL, 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, INTENT(in), DIMENSION(:,:,:), OPTIONAL :: mask -! REAL, INTENT(in), DIMENSION(:,:,:),OPTIONAL :: rmask -! CHARACTER(len=*), INTENT(out), OPTIONAL :: err_msg -! -! REAL, DIMENSION(SIZE(field,1),SIZE(field,2),size(field,3)) :: field_out -! LOGICAL, DIMENSION(SIZE(field,1),SIZE(field,2),size(field,3)) :: mask_out -! -! ! 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_r8 = .FALSE. -! RETURN -! END IF -! -! ! First copy the data to a three d array with last element 1 -! field_out = field -! -! ! Default values for mask -! IF ( PRESENT(mask) ) THEN -! mask_out = mask -! ELSE -! mask_out = .TRUE. -! END IF -! -! IF ( PRESENT(rmask) ) WHERE ( rmask < 0.5 ) mask_out = .FALSE. -! IF ( PRESENT(mask) .OR. PRESENT(rmask) ) THEN -! send_data_3d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=ks_in, mask=mask_out,& -! & ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) -! ELSE -! send_data_3d_r8 = send_data_3d(diag_field_id, field_out, time, is_in=is_in, js_in=js_in, ks_in=ks_in,& -! & ie_in=ie_in, je_in=je_in, ke_in=ke_in, weight=weight, err_msg=err_msg) -! END IF -! END FUNCTION send_data_3d_r8 -!#endif - !> @return true if send is successful LOGICAL FUNCTION send_data_3d(diag_field_id, field, time, is_in, js_in, ks_in, & & mask, rmask, ie_in, je_in, ke_in, weight, err_msg) From 49a5326f00a186d77c3e42fdeac6c621472b5307 Mon Sep 17 00:00:00 2001 From: MinsukJi-NOAA Date: Fri, 14 Jan 2022 14:45:07 +0000 Subject: [PATCH 5/5] Add Doxygen comments to constants4.F90 --- constants4/constants4.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/constants4/constants4.F90 b/constants4/constants4.F90 index 18c8140a3d..c244b6a428 100644 --- a/constants4/constants4.F90 +++ b/constants4/constants4.F90 @@ -68,14 +68,14 @@ module constantsR4_mod !! simulations (<13km) that will tax hardware resources. #ifdef SMALL_EARTH #if defined(DCMIP) || (defined(HIWPP) && defined(SUPER_K)) - real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 120._r8_kind ! only needed for supercell test + real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 120._r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90 #elif defined(HIWPP) - real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 166.7_r8_kind + real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 166.7_r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90 #else - real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 10._r8_kind + real(r4_kind), public, parameter :: small_fac = 1._r8_kind / 10._r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90 #endif #else - real(r4_kind), public, parameter :: small_fac = 1._r8_kind + real(r4_kind), public, parameter :: small_fac = 1._r8_kind !< Real(kind=4) variant of small_fac defined in constants/constants.F90 #endif #ifdef GFS_PHYS