From faa700f7736cc982df0d6c9d5329b708b75ac1d4 Mon Sep 17 00:00:00 2001 From: Pierre Siddall <43399998+Pierre-siddall@users.noreply.github.com> Date: Mon, 16 Mar 2026 08:46:39 +0000 Subject: [PATCH 1/2] fix labelling issues --- src/correlated_k/corr_k.f90 | 18 ++-- src/correlated_k/corr_k_single.f90 | 124 +++++++++++++-------------- src/correlated_k/read_pt_line_90.f90 | 18 ++-- src/correlated_k/read_ref_pt_90.f90 | 2 +- src/general/make_block_19.f90 | 4 +- src/general/make_block_5.f90 | 8 +- src/general/make_block_9.f90 | 2 +- src/scatter/db_scatter_integral.f90 | 34 ++++---- src/scatter/get_db_wavelengths.f90 | 8 +- src/scatter/icedb2bin.f90 | 20 ++--- src/scatter/scatter_average_90.f90 | 16 ++-- 11 files changed, 127 insertions(+), 127 deletions(-) diff --git a/src/correlated_k/corr_k.f90 b/src/correlated_k/corr_k.f90 index f14fb49..6b00dd0 100644 --- a/src/correlated_k/corr_k.f90 +++ b/src/correlated_k/corr_k.f90 @@ -24,9 +24,9 @@ PROGRAM corr_k ! ! ! Local scalars: - INTEGER :: start_time(8) + INTEGER :: start_time(8) ! Start/finish of program - INTEGER :: end_time(8) + INTEGER :: end_time(8) ! End of program INTEGER :: iu_lbl ! Unit number for input of the LbL database in HITRAN format @@ -369,7 +369,7 @@ END SUBROUTINE corr_k_single CALL open_file_in(ierr, iu_lbl, & "Give the name of the bespoke HITRAN .bpar database.") IF (ierr /= i_normal) THEN - WRITE(iu_err, '(A, i5)') 'Error in open_file_in: ', ierr + WRITE(iu_err, '(A, i5)') 'Error in open_file_in: ', ierr STOP END IF CALL read_parsum_dat @@ -401,7 +401,7 @@ END SUBROUTINE corr_k_single CALL open_file_in(ierr, iu_lbl, & "Give the name of the .uvxsc database.") IF (ierr /= i_normal) THEN - WRITE(iu_err, '(A, i5)') 'Error in open_file_in: ', ierr + WRITE(iu_err, '(A, i5)') 'Error in open_file_in: ', ierr STOP END IF EXIT @@ -480,12 +480,12 @@ END SUBROUTINE corr_k_single include_instrument_response=.TRUE. CALL read_instrument_response_90(filter, ierr) IF (ierr /= i_normal) STOP - EXIT + EXIT Inst ! ELSE IF ( (char_if == 'N') .OR. (char_if == 'n') ) THEN ! include_instrument_response=.FALSE. - EXIT + EXIT Inst ! ELSE ! @@ -529,7 +529,7 @@ END SUBROUTINE corr_k_single i_line_prof_corr, l_self_broadening, n_gas_frac, gas_frac, npd_gas_frac, & ierr) ! -! Allocate arrays for the k-fit, now that the size of the scaling +! Allocate arrays for the k-fit, now that the size of the scaling ! vector is known. ALLOCATE(w_k(npd_k_term, Spectrum%Dim%nd_band)) ALLOCATE(k_opt(npd_k_term, Spectrum%Dim%nd_band)) @@ -545,7 +545,7 @@ END SUBROUTINE corr_k_single l_fit_self_continuum .OR. l_fit_frn_continuum) THEN ! Select the weighting to be applied. CALL select_weight_ck_90(i_weight, SolarSpec, l_interactive, ierr) -! +! ! Set the output file. CALL get_free_unit(ierr, iu_k_out) IF (ierr /= i_normal) STOP @@ -554,7 +554,7 @@ END SUBROUTINE corr_k_single file_k, ierr) IF (ierr /= i_normal) STOP END IF - + ! Define the output file of detailed monitoring information. CALL get_free_unit(ierr, iu_monitor) IF (ierr /= i_normal) STOP diff --git a/src/correlated_k/corr_k_single.f90 b/src/correlated_k/corr_k_single.f90 index 62dbc02..dbe0e76 100644 --- a/src/correlated_k/corr_k_single.f90 +++ b/src/correlated_k/corr_k_single.f90 @@ -49,7 +49,7 @@ SUBROUTINE corr_k_single & USE errormessagelength_mod, ONLY: errormessagelength USE ereport_mod, ONLY: ereport - IMPLICIT NONE + IMPLICIT NONE TYPE StrLineParam @@ -170,7 +170,7 @@ SUBROUTINE corr_k_single & ! Solar Spectrum ! LOGICAL, Intent(IN) :: include_h2o_foreign_continuum -! Flag to include the foreign-broadened H2O continuum (with a +! Flag to include the foreign-broadened H2O continuum (with a ! partial pressure of 0) with the line data LOGICAL, Intent(IN) :: l_use_h2o_frn_param ! Flag to use foreign broadened H2O continuum parametrisation @@ -354,7 +354,7 @@ SUBROUTINE corr_k_single & ! including all k-terms REAL (RealK), Pointer :: trans_pt_k(:, :, :) ! Actual transmissions for a single k-term only (used when fitting -! a scaling function) at the supplied range of pressures and +! a scaling function) at the supplied range of pressures and ! temperatures REAL (RealK), Pointer :: trans_calc(:) ! Calculated transmissions @@ -375,7 +375,7 @@ SUBROUTINE corr_k_single & REAL (RealK), Dimension(:), Allocatable :: u_c ! Pathlengths for continuum absorption REAL (RealK), Pointer, Dimension(:, :) :: u_fit_c -! Products of the mass of absorber and the partial pressure in +! Products of the mass of absorber and the partial pressure in ! continua REAL (RealK), Dimension(:), Allocatable :: trans_c ! Continuum transmissions @@ -402,7 +402,7 @@ SUBROUTINE corr_k_single & ! In order to apply a line transmission weighting to continuum absorption ! transmissions the column mass of the weighting gas is needed. This is ! calculated as u_gas = max_path_wgt*sqrt(u_cont/max_path) for self- -! broadened continua (l_wgt_scale_sqrt == .TRUE.) and +! broadened continua (l_wgt_scale_sqrt == .TRUE.) and ! as u_gas = max_path_wgt*u_cont/max_path if a foreign-broadened continuum ! (l_wgt_scale_sqrt == .FALSE.). u_wgt_scale is used to store the quantity ! max_path_wgt/sqrt(max_path) or max_path_wgt/max_path. @@ -410,7 +410,7 @@ SUBROUTINE corr_k_single & INTEGER :: i_index_c ! Variable indicating the type of the continuum REAL (RealK) :: k_ave_tmp(nd_k_term) -! Mean k-value across the band: temporary value at conditions +! Mean k-value across the band: temporary value at conditions ! other than the reference REAL (RealK) :: k_opt_tmp(nd_k_term) ! Optimal k-value across the band: temporary value at conditions @@ -445,7 +445,7 @@ SUBROUTINE corr_k_single & REAL :: start_band, finish_band, timer1, timer2 ! Timers - + LOGICAL :: l_debug = .FALSE. ! LOGICAL :: l_debug = .TRUE. LOGICAL :: l_output_reference_weight = .FALSE. @@ -459,7 +459,7 @@ SUBROUTINE corr_k_single & INTERFACE ! SUBROUTINE rad_weight_90(i_weight, nu, SolarSpec, T, weight) -! Function to calculate the array of radiant weightings +! Function to calculate the array of radiant weightings ! USE def_solarspec ! @@ -991,7 +991,7 @@ END SUBROUTINE write_fit_90 "Wavenumbers of min and max lines are: ", & hitran_data(1) % frequency, & hitran_data(num_lines_in_band) % frequency -! +! ! Set aside space for the adjusted line parameters: ! this will be reused each time T and p change. ALLOCATE(adj_line_parm(num_lines_in_band)) @@ -1078,7 +1078,7 @@ END SUBROUTINE write_fit_90 DEALLOCATE(xsc(i)%data) END DO DEALLOCATE(xsc) - + END IF IF (l_fit_cont_data .AND. l_cont_line_abs_weight) THEN @@ -1218,7 +1218,7 @@ END SUBROUTINE write_fit_90 kabs = max_p_calc/(max_path*kabs_rank2) END WHERE END IF - + ! Read mapping, g-points and reference k-term weights CALL input_map_band_cdf @@ -1447,14 +1447,14 @@ END SUBROUTINE write_fit_90 ELSE wgt=wgt_sv END IF - + IF (l_fit_cont_data .AND. l_cont_line_abs_weight) & kabs_lines=kabs_all_lines(1:n_nu,ipt) - + IF (ipt == ipt_ref) THEN wgt_ref(1:n_nu) = nu_inc * wgt(1:n_nu) END IF - + ! Perform the appropriate fits. IF (l_fit_self_continuum) THEN kabs=kabs_all(1:n_nu,ipt) @@ -1496,12 +1496,12 @@ END SUBROUTINE write_fit_90 END IF END IF ENDDO - + IF (l_fit_frn_continuum) k_cont => k_opt_frn(ib) IF (l_fit_self_continuum) k_cont => k_opt_self(ib) - + IF (l_scale_pT) THEN -! +! IF (l_fit_line_data) THEN SELECT CASE(i_scale_function) CASE (IP_scale_power_law, IP_scale_power_quad, & @@ -1528,7 +1528,7 @@ END SUBROUTINE write_fit_90 END IF END IF END IF - + IF (l_fit_line_data .AND. l_scale_pT) DEALLOCATE(trans_pt_k) END IF @@ -1647,7 +1647,7 @@ END SUBROUTINE write_fit_90 i_scale_function, scale_cont(:, :, ib)) DEALLOCATE(trans_app_c) ENDIF - + IF (l_fit_cont_data .AND. l_cont_line_abs_weight) & kabs_all=kabs_all_lines IF (.NOT.l_lbl_exist) CALL output_lbl_band_cdf @@ -1669,7 +1669,7 @@ END SUBROUTINE write_fit_90 DEALLOCATE(hitran_data, STAT = alloc_status) IF (alloc_status /= 0) THEN WRITE(*,"(a)") "Error deallocating array for HITRAN line data" - EXIT + EXIT bands ENDIF ENDIF @@ -1691,7 +1691,7 @@ END SUBROUTINE write_fit_90 IF (l_lbl_exist) DEALLOCATE(nu_wgt_all) DEALLOCATE(band_min) DEALLOCATE(band_max) - + CALL close_lbl_files CALL close_map_files @@ -1894,7 +1894,7 @@ END SUBROUTINE access_cia_int SUBROUTINE fit_transparent_int ! ! - IMPLICIT NONE + IMPLICIT NONE ! n_k(ib)=1 w_k(1, ib)=1.0_RealK @@ -1944,13 +1944,13 @@ END SUBROUTINE fit_transparent_int ! SUBROUTINE set_wgt_int - IMPLICIT NONE + IMPLICIT NONE ! Set up the array of wavenumbers at the weighting points within the ! band. The band should contain a whole number of intervals (band limits ! have been adjusted in the calling routine if required). Care is taken ! to ensure excluded bands are properly dealt with. - + ! Calculate band width band_width = band_max(ib) - band_min(ib) DO jx = 1, n_band_exclude(ib) @@ -2013,7 +2013,7 @@ SUBROUTINE apply_response_int USE spline_evaluate_mod, ONLY: spline_evaluate ! ! - IMPLICIT NONE + IMPLICIT NONE ! IF (include_instrument_response) THEN DO i=1, n_nu @@ -2021,7 +2021,7 @@ SUBROUTINE apply_response_int filter%wavenumber, filter%response, filter%d2_response, & nu_wgt(i), response_0) IF (ierr == i_err_range) THEN -! The filter function is taken to be 0 outside +! The filter function is taken to be 0 outside ! the explicit range. We therefore zero the response and ! recover from the error. response_0 = 0.0 @@ -2291,7 +2291,7 @@ SUBROUTINE calc_cia_abs_int DO j = 1, n_nu ! Lookup wavenumer in cm-1 waveno = nu_wgt(j) * 0.01_RealK - + ! Reset interpolation quantities t_cia = 0.0_RealK n_t_cia = 0 @@ -2376,7 +2376,7 @@ END SUBROUTINE calc_k_opt_ref SUBROUTINE ck_trans_fit - IMPLICIT NONE + IMPLICIT NONE ! Integrate the sorted weightings across the band. integ_wgt=nu_inc * SUM(wgt(1:n_nu)) @@ -2391,7 +2391,7 @@ SUBROUTINE ck_trans_fit umin=umin_kopt IF (k_opt(n_k(ib),ib) > 0.0_RealK) umin = & MAX(umin_kopt, -LOG(1.0_RealK-tol)/k_opt(n_k(ib),ib)) -! Optimization over paths is likely to be simpler with +! Optimization over paths is likely to be simpler with ! fewer k-terms. n_path=2*n_k(ib)+1 DO i=1, n_path @@ -2480,7 +2480,7 @@ END SUBROUTINE ck_fit_k SUBROUTINE calc_self_trans_int ! ! - IMPLICIT NONE + IMPLICIT NONE ! ! Local variables INTEGER :: i_pp @@ -2521,9 +2521,9 @@ END SUBROUTINE exponent_fit_90 ! FUNCTION trans_k_dist(n_nu, k, nu_inc, wgt, integ_wgt, n_path, u) & RESULT (trans) -! +! USE realtype_rd -! +! INTEGER, Intent(IN) :: n_nu INTEGER, Intent(IN) :: n_path REAL (RealK), Intent(IN), Dimension(n_nu) :: k @@ -2531,10 +2531,10 @@ FUNCTION trans_k_dist(n_nu, k, nu_inc, wgt, integ_wgt, n_path, u) & REAL (RealK), Intent(IN), Dimension(n_nu) :: wgt REAL (RealK), Intent(IN) :: integ_wgt REAL (RealK), Intent(IN), Dimension(n_path) :: u -! +! REAL (RealK), Dimension(n_path) :: trans - -! + +! END FUNCTION trans_k_dist ! ! @@ -2547,7 +2547,7 @@ END FUNCTION trans_k_dist trans_line = & trans_k_dist(n_nu, kabs, nu_inc, wgt, integ_wgt, n_path_c, u_c) ! -! The continuum is calculated at a range of partial pressures up to +! The continuum is calculated at a range of partial pressures up to ! the saturation value. e_sat = sat_vap_press(t_calc(ipt), p_calc(ipt)) ALLOCATE(k_self(n_nu)) @@ -2558,7 +2558,7 @@ END FUNCTION trans_k_dist !$OMP NUM_THREADS(n_omp_threads) DO i_pp = 1, n_pp ! - pp = e_sat * REAL(i_pp, RealK) / REAL(n_pp, RealK) + pp = e_sat * REAL(i_pp, RealK) / REAL(n_pp, RealK) ! ! Calculate the self-broadened continuum coefficients at this ! partial pressure. @@ -2578,7 +2578,7 @@ END FUNCTION trans_k_dist il = 1 + (i_pp - 1) * n_path_c ih = i_pp * n_path_c trans_fit_c(il:ih, ipt) = trans_c / (trans_line + TINY(trans_line) ) -! Eventually, the continuum coefficient will be in units of +! Eventually, the continuum coefficient will be in units of ! m5/(mol.kg). u_fit_c(il:ih, ipt) = u_c * & ( pp / (molar_gas_constant * t_calc(ipt)) ) @@ -2619,7 +2619,7 @@ END SUBROUTINE calc_self_trans_int SUBROUTINE calc_frn_trans_int ! ! - IMPLICIT NONE + IMPLICIT NONE ! ! Local variables INTEGER :: i_pp @@ -2660,9 +2660,9 @@ END SUBROUTINE exponent_fit_90 ! FUNCTION trans_k_dist(n_nu, k, nu_inc, wgt, integ_wgt, n_path, u) & RESULT (trans) -! +! USE realtype_rd -! +! INTEGER, Intent(IN) :: n_nu INTEGER, Intent(IN) :: n_path REAL (RealK), Intent(IN), Dimension(n_nu) :: k @@ -2670,10 +2670,10 @@ FUNCTION trans_k_dist(n_nu, k, nu_inc, wgt, integ_wgt, n_path, u) & REAL (RealK), Intent(IN), Dimension(n_nu) :: wgt REAL (RealK), Intent(IN) :: integ_wgt REAL (RealK), Intent(IN), Dimension(n_path) :: u -! +! REAL (RealK), Dimension(n_path) :: trans - -! + +! END FUNCTION trans_k_dist ! ! @@ -2686,7 +2686,7 @@ END FUNCTION trans_k_dist trans_line = & trans_k_dist(n_nu, kabs, nu_inc, wgt, integ_wgt, n_path_c, u_c) ! -! The continuum is calculated at a range of partial pressures up to +! The continuum is calculated at a range of partial pressures up to ! the saturation value. e_sat = sat_vap_press(t_calc(ipt), p_calc(ipt)) ALLOCATE(k_frn(n_nu)) @@ -2697,7 +2697,7 @@ END FUNCTION trans_k_dist !$OMP NUM_THREADS(n_omp_threads) DO i_pp = 1, n_pp ! - pp = e_sat * REAL(i_pp, RealK) / REAL(n_pp, RealK) + pp = e_sat * REAL(i_pp, RealK) / REAL(n_pp, RealK) ! ! Calculate the foreign-broadened continuum coefficients at this ! partial pressure. @@ -2717,7 +2717,7 @@ END FUNCTION trans_k_dist il = 1 + (i_pp - 1) * n_path_c ih = i_pp * n_path_c trans_fit_c(il:ih, ipt) = trans_c / (trans_line + TINY(trans_line) ) -! Eventually, the continuum coefficient will be in units of +! Eventually, the continuum coefficient will be in units of ! m5/(mol.kg). u_fit_c(il:ih, ipt) = u_c * & ( (p_calc(ipt) - pp) / (molar_gas_constant * t_calc(ipt)) ) @@ -2758,7 +2758,7 @@ END SUBROUTINE calc_frn_trans_int SUBROUTINE fit_scale_line_int ! ! - IMPLICIT NONE + IMPLICIT NONE ! DO ik=1, n_k(ib) ! @@ -2844,11 +2844,11 @@ SUBROUTINE fit_scale_line_int2 IF (l_debug) & print*,'Fitting 2 scaling functions split at pressure: ', & p_calc(index_k_ref) - + err_norm_old=err_norm - + ! Fit 2 scaling functions, one either side of the maximum k. - + ! Ininitialize the parameters of the first scaling function. SELECT CASE(i_scale_function2) CASE (IP_scale_power_law) @@ -2861,7 +2861,7 @@ SUBROUTINE fit_scale_line_int2 scale_vector(1:4, ik, ib) = & (/ 1.0_RealK, -2.0_RealK, 0.0_RealK, 0.0_RealK /) END SELECT - + ! Now if the absorption coefficient for the term is 0, there is ! no optimal scaling function, so no scaling function can be ! determined. We relate this to the machine's precision. @@ -2885,7 +2885,7 @@ SUBROUTINE fit_scale_line_int2 ENDIF err_norm=rms_residual*(index_k_ref-1) ENDIF - + ! Ininitialize the parameters of the second scaling function. SELECT CASE(i_scale_function2) CASE (IP_scale_power_law) @@ -2919,7 +2919,7 @@ SUBROUTINE fit_scale_line_int2 ENDIF err_norm=err_norm + rms_residual*(n_pt_pair-index_k_ref) ENDIF - + IF (err_norm < err_norm_old) THEN ! Set reference P, T, and absorption for each k-term: scale_vector(n_scale_variable(i_scale_function2)*2+1,ik,ib) = & @@ -2940,7 +2940,7 @@ END SUBROUTINE fit_scale_line_int2 SUBROUTINE fit_scale_cont_int ! ! - IMPLICIT NONE + IMPLICIT NONE ! WRITE(iu_monitor, '(/a, /a)') & "===================", & @@ -3006,7 +3006,7 @@ SUBROUTINE input_lbl_band_cdf_init ! Allocate array with all wavenumbers ALLOCATE(nu_wgt_all(dim_len)) -! Read and get step in wavenumber array +! Read and get step in wavenumber array CALL nf(nf90_inq_varid(ncidin_lbl,'nu',varid)) CALL nf(nf90_get_att(ncidin_lbl,varid,'step',nu_inc)) CALL nf(nf90_get_var(ncidin_lbl,varid,nu_wgt_all)) @@ -3033,7 +3033,7 @@ SUBROUTINE input_lbl_band_cdf_init END DO ! Read pressures and temperatures - CALL nf(nf90_inq_varid(ncidin_lbl,'p_calc',varid)) + CALL nf(nf90_inq_varid(ncidin_lbl,'p_calc',varid)) CALL nf(nf90_get_var(ncidin_lbl,varid,p_calc_in)) CALL nf(nf90_inq_varid(ncidin_lbl,'t_calc',varid)) CALL nf(nf90_get_var(ncidin_lbl,varid,t_calc_in)) @@ -3052,7 +3052,7 @@ SUBROUTINE input_lbl_band_cdf_init IF (l_self_broadening) THEN ! Read gas fractions - CALL nf(nf90_inq_varid(ncidin_lbl,'gas_frac',varid)) + CALL nf(nf90_inq_varid(ncidin_lbl,'gas_frac',varid)) CALL nf(nf90_get_var(ncidin_lbl,varid,gas_frac_in)) ! Check gas fractions in lbl file @@ -3339,7 +3339,7 @@ SUBROUTINE output_map_band_cdf_init INTEGER :: dimid1, dimid2, dimid3, dimid4 ! dimension ID INTEGER :: varid ! variable ID INTEGER :: n_nu_band(n_selected_band) ! number of frequency points - LOGICAL :: l_map_exist ! flag for mapping file existing + LOGICAL :: l_map_exist ! flag for mapping file existing ! Calculate total number of frequency points DO ibb=1, n_selected_band @@ -3585,17 +3585,17 @@ SUBROUTINE close_lbl_files END SUBROUTINE close_lbl_files SUBROUTINE close_map_files - + use netcdf IMPLICIT NONE - + ! Close files IF (l_load_map) THEN CALL nf(nf90_close(ncidin_map)) ELSE IF (l_save_map) THEN CALL nf(nf90_close(ncidout_map)) ENDIF - + END SUBROUTINE close_map_files Subroutine nf(status) diff --git a/src/correlated_k/read_pt_line_90.f90 b/src/correlated_k/read_pt_line_90.f90 index bf82842..8626d3a 100644 --- a/src/correlated_k/read_pt_line_90.f90 +++ b/src/correlated_k/read_pt_line_90.f90 @@ -102,16 +102,16 @@ SUBROUTINE read_pt_line_90 & 'Specify pressure and corresponding temperatures (*END to finish)' ENDIF ! - l_next= .TRUE. + l_next= .TRUE. ! The next line will be read until l_next is false. Input: DO - IF (.NOT.l_next) EXIT + IF (.NOT.l_next) EXIT Input READ(iu_pt, '(a)', IOSTAT=ios) line IF (ios /= 0) THEN WRITE(iu_err, "(a)") "Erroneous input" IF ( l_interactive .AND. (.NOT.l_file) ) THEN WRITE(iu_stdout, '(a)') "Please re-enter this line." - CYCLE + CYCLE Input ELSE ierr=i_err_fatal RETURN @@ -156,19 +156,19 @@ SUBROUTINE read_pt_line_90 & j=2 Process: DO ! - IF (j >= length) EXIT + IF (j >= length) EXIT Process ! IF ( (list(j-1:j-1) == ' ') .AND. (list(j:j) /= ' ') ) THEN ! Beginning of word found. begin=j n_word=n_word+1 -! Check for termination of input: a line begins with 'F' +! Check for termination of input: a line begins with 'F' ! or 'f' or the directive "*END" IF (n_word == 1) THEN IF ( (list(j:j) == 'f') .OR. & (list(j:j) == 'f') .OR. & - (list(j:j+3) == '*END') ) THEN - l_finish= .TRUE. + (list(j:j+3) == '*END') ) THEN + l_finish= .TRUE. RETURN ENDIF ENDIF @@ -188,7 +188,7 @@ SUBROUTINE read_pt_line_90 & ELSE WRITE(iu_stdout, '(a)') 'Please re-enter the list.' l_reread=.TRUE. - EXIT + EXIT Process ENDIF ENDIF word(1:n_char_word) = ' ' @@ -204,7 +204,7 @@ SUBROUTINE read_pt_line_90 & ELSE WRITE(iu_stdout, '(/a/)') 'Please re-enter' l_reread=.TRUE. - EXIT + EXIT Process ENDIF ENDIF ENDIF diff --git a/src/correlated_k/read_ref_pt_90.f90 b/src/correlated_k/read_ref_pt_90.f90 index c64ce1b..86d0bc1 100644 --- a/src/correlated_k/read_ref_pt_90.f90 +++ b/src/correlated_k/read_ref_pt_90.f90 @@ -93,7 +93,7 @@ SUBROUTINE read_ref_pt_90 & Input: DO READ(iu_file_in, '(a)', IOSTAT=ios) line ! - IF (ios /= 0) EXIT + IF (ios /= 0) EXIT Input ! ! Lines of valid data begin with the directive *REF. IF (line(1:4) == '*REF') THEN diff --git a/src/general/make_block_19.f90 b/src/general/make_block_19.f90 index 6804198..5c7fedc 100644 --- a/src/general/make_block_19.f90 +++ b/src/general/make_block_19.f90 @@ -140,7 +140,7 @@ SUBROUTINE make_block_19(Spectrum, ierr) END IF END DO inner READ(iu_esft, '(15x, i5, //)', IOSTAT=ios) i_input_type - IF (ios < 0) EXIT + IF (ios < 0) EXIT outer IF (i_input_type /= it_file_cont_gen_fit) THEN WRITE(*, '(/a)') & '***error: the esft data have an invalid file type.' @@ -267,7 +267,7 @@ SUBROUTINE make_block_19(Spectrum, ierr) arr_tmp_real_4d DEALLOCATE(arr_tmp_real_4d) END IF - + READ(iu_esft, '(6(1PE13.6))', IOSTAT=ios) & (Spectrum%ContGen%t_lookup_cont(it), & it=1, Spectrum%ContGen%n_t_lookup_cont) diff --git a/src/general/make_block_5.f90 b/src/general/make_block_5.f90 index bfc97d4..e714589 100644 --- a/src/general/make_block_5.f90 +++ b/src/general/make_block_5.f90 @@ -76,7 +76,7 @@ SUBROUTINE make_block_5(Spectrum, ierr) REAL (RealK), ALLOCATABLE :: arr_tmp_real_6d(:, :, :, :, :, :) ! Temporary arrays used when resizing existing arrays REAL (RealK) :: t_lookup_pressure -! Single pressure used for temperature lookup tables +! Single pressure used for temperature lookup tables ! Alias pointers to dimensions to the actual structure. nd_band => Spectrum%Dim%nd_band @@ -200,7 +200,7 @@ SUBROUTINE make_block_5(Spectrum, ierr) END IF END DO inner READ(iu_esft, '(15x, i5, //)', IOSTAT=ios) i_input_type - IF (ios < 0) EXIT + IF (ios < 0) EXIT outer IF (i_input_type == it_file_line_fit .OR. & i_input_type == it_file_line_fit_self) THEN READ(iu_esft, '(14x, i5, 21x, i5)') i_band, i_index @@ -281,7 +281,7 @@ SUBROUTINE make_block_5(Spectrum, ierr) Spectrum%Gas%i_scat(nd_k_term_alloc+1:,:,:) = 0 DEALLOCATE(arr_tmp_int_3d) - ALLOCATE(arr_tmp_real_3d(nd_k_term_alloc, nd_band, nd_species)) + ALLOCATE(arr_tmp_real_3d(nd_k_term_alloc, nd_band, nd_species)) arr_tmp_real_3d = Spectrum%Gas%k DEALLOCATE(Spectrum%Gas%k) ALLOCATE(Spectrum%Gas%k(nd_k_term, nd_band, nd_species)) @@ -508,7 +508,7 @@ SUBROUTINE make_block_5(Spectrum, ierr) DEALLOCATE(arr_tmp_real_4d) ELSE ALLOCATE(Spectrum%Gas%k_t_lookup_gas(Spectrum%Dim%nd_t_lookup_gas, & - nd_k_term, nd_species, nd_band)) + nd_k_term, nd_species, nd_band)) END IF END IF diff --git a/src/general/make_block_9.f90 b/src/general/make_block_9.f90 index d12b099..c434e5a 100644 --- a/src/general/make_block_9.f90 +++ b/src/general/make_block_9.f90 @@ -121,7 +121,7 @@ SUBROUTINE make_block_9(Spectrum, ierr) END IF END DO inner READ(iu_esft, '(15x, i5, //)', IOSTAT=ios) i_input_type - IF (ios < 0) EXIT + IF (ios < 0) EXIT outer IF (i_input_type /= it_file_cont_fit) THEN WRITE(*, '(/a)') & '*** error: the input file is of an invalid type.' diff --git a/src/scatter/db_scatter_integral.f90 b/src/scatter/db_scatter_integral.f90 index a602f18..cdaa939 100644 --- a/src/scatter/db_scatter_integral.f90 +++ b/src/scatter/db_scatter_integral.f90 @@ -9,7 +9,7 @@ SUBROUTINE db_scatter_integral & (nd_wavelength, nd_size_scat, & SizeDist,wavelength_index,n_wavelength,wavelength,DBGeom, & ice_db_mono_info, & - n_angle,mu_angle, & + n_angle,mu_angle, & panel_ratio, & extinction, scattering, asymmetry, l_stokes, i_stokes, & nd_scatt_angle, & @@ -19,27 +19,27 @@ SUBROUTINE db_scatter_integral & ) ! ! Method: -! The extinction, the scattering and the asymmetry are +! The extinction, the scattering and the asymmetry are ! initialized to 0. Initial estimates of these quantities are ! made and the range of integration is extended until further ! extension does not sensibly alter these estimates. This is ! done by dividing the range of integration into panels and -! adding new panels as required. the resolution within a panel +! adding new panels as required. the resolution within a panel ! is then increased until the integrals converge. ! ! ! ! Modules used USE realtype_rd - USE def_size_dist - USE def_std_io_icf - USE prec_integral_tcf - USE scatter_algorithm_pcf - USE shape_particle_pcf - USE error_pcf - USE rad_ccf, ONLY: pi - USE def_db_crystal_geometry - USE def_db_ss_mono + USE def_size_dist + USE def_std_io_icf + USE prec_integral_tcf + USE scatter_algorithm_pcf + USE shape_particle_pcf + USE error_pcf + USE rad_ccf, ONLY: pi + USE def_db_crystal_geometry + USE def_db_ss_mono ! ! IMPLICIT NONE @@ -48,7 +48,7 @@ SUBROUTINE db_scatter_integral & ! ! Dummy arguments ! - INTEGER, Intent(IN) :: n_wavelength + INTEGER, Intent(IN) :: n_wavelength ! Number of wavelengths ! ! Sizes of dummy arrays: @@ -252,7 +252,7 @@ END FUNCTION volume_particle ! until the inclusion of further panels makes little change in the ! estimate of the integral. ! - Set_range: DO ; IF ( .NOT.(l_add_upper .OR. l_add_lower) ) EXIT + Set_range: DO ; IF ( .NOT.(l_add_upper .OR. l_add_lower) ) EXIT Set_range ! IF (l_add_upper) THEN dimen_panel_low = dimen_high @@ -280,7 +280,7 @@ END FUNCTION volume_particle ! IF (number_point > 0.0_RealK) THEN ! The scattering code is not called if there are -! no particles at this size. +! no particles at this size. CALL db_interp_ss_mono(nd_wavelength, & nd_scatt_angle, nd_size_scat, & dimen(i), & @@ -378,7 +378,7 @@ END FUNCTION volume_particle IF (number_point > 0.0_RealK) THEN ! The scattering code is not called if there are -! no particles at this size. +! no particles at this size. CALL db_interp_ss_mono(nd_wavelength, & nd_scatt_angle, nd_size_scat, & dimen(i), & @@ -407,7 +407,7 @@ END FUNCTION volume_particle y(i, 4:3+n_angle) = number_point * s(1:n_angle) ! ! - y(i, 1) = number_point * extinction_point + y(i, 1) = number_point * extinction_point y(i, 2) = number_point * scattering_point y(i, 3) = asymmetry_point * y(i, 2) ! diff --git a/src/scatter/get_db_wavelengths.f90 b/src/scatter/get_db_wavelengths.f90 index a8ef01e..0013e5e 100644 --- a/src/scatter/get_db_wavelengths.f90 +++ b/src/scatter/get_db_wavelengths.f90 @@ -31,7 +31,7 @@ SUBROUTINE get_db_wavelengths & INTEGER, Intent(In) :: nd_wavelength ! Size allocated for array of wavelengths INTEGER, Intent(In) :: nd_size_scat -! Size allocated for the number of scattering +! Size allocated for the number of scattering ! entries at each wavelength ! INTEGER, Intent(IN) :: iu_db_input @@ -61,7 +61,7 @@ SUBROUTINE get_db_wavelengths & INTEGER :: n_block ! Number of blocks of scattering data INTEGER :: i_block -! Loop variable +! Loop variable LOGICAL :: new_wavelength ! Flag that states if a new wavelength ! has been read from the database @@ -119,7 +119,7 @@ SUBROUTINE get_db_wavelengths & db_record(j_pt_wl, n_rec_block(j_pt_wl)) = i_block+1 ! ! -! Check if number of scattering angles is consistent +! Check if number of scattering angles is consistent ! throughout the records IF (i_block == 1) n_angle = ice_sct%n_angle IF ( ice_sct%n_angle /= n_angle .AND. i_block > 1 ) THEN @@ -133,7 +133,7 @@ SUBROUTINE get_db_wavelengths & ! Advance to the next block i_block = i_block+1 ! Stop at the last block. - IF (i_block > n_block) EXIT + IF (i_block > n_block) EXIT process_block ! ENDDO process_block ! diff --git a/src/scatter/icedb2bin.f90 b/src/scatter/icedb2bin.f90 index 5071037..e2a7a3e 100644 --- a/src/scatter/icedb2bin.f90 +++ b/src/scatter/icedb2bin.f90 @@ -9,19 +9,19 @@ PROGRAM icedb2bin ! ! Description: -! This program receives the ASCII database of scattering +! This program receives the ASCII database of scattering ! properties and convertis it to a direct access unformatted ! file for use in calculating single scattering properties ! averaged over distributions. ! ! Method: ! The file is opened and read to determine how many blocks -! of data for a specific size and wavelength are contained +! of data for a specific size and wavelength are contained ! within it. An unformatted direct access file is then -! opened and the data are written to it. +! opened and the data are written to it. ! ! Note: -! The initial data are expected to be supplied in the +! The initial data are expected to be supplied in the ! following units: ! Wavelength: Micron ! Mean maximum dimension: Micron @@ -117,10 +117,10 @@ PROGRAM icedb2bin ! Read through the input to find the number of blocks of data. ! In the current format the first element of an entry is the wavelength. n_block=0 - count_block: DO + count_block: DO READ(iunit_in, '(A)', IOSTAT=ios) line ! Conventionally negative errors denote an end of the file. - IF (ios < 0) EXIT + IF (ios < 0) EXIT count_block IF (line(17:28) == "; Wavelength") n_block=n_block+1 ENDDO count_block REWIND(iunit_in) @@ -168,13 +168,13 @@ PROGRAM icedb2bin n_angle=0 READ(iunit_in, '()') read_phase: DO -! If the line contains the string "; Wavelength" it signals -! the start of the next block, or the block may be at the end +! If the line contains the string "; Wavelength" it signals +! the start of the next block, or the block may be at the end ! of the file. READ(iunit_in, '(A)', IOSTAT=ios) line IF ( (ios < 0).OR.(line(17:28) == '; Wavelength') ) THEN BACKSPACE(iunit_in) - EXIT + EXIT read_phase ENDIF n_angle=n_angle+1 IF (n_angle > npd_sct_db_angle) THEN @@ -256,7 +256,7 @@ PROGRAM icedb2bin ! Advance the count of the number of blocks. i_block=i_block+1 ! Stop at the last block. - IF (i_block > n_block) EXIT + IF (i_block > n_block) EXIT process_block ! ENDDO process_block ! diff --git a/src/scatter/scatter_average_90.f90 b/src/scatter/scatter_average_90.f90 index 1003777..e4e731c 100644 --- a/src/scatter/scatter_average_90.f90 +++ b/src/scatter/scatter_average_90.f90 @@ -14,9 +14,9 @@ PROGRAM scatter_average_90 ! file. Optionally, the data may be fitted. ! ! Method: -! A file containing blocks of monochromatic single +! A file containing blocks of monochromatic single ! scattering properties is read in. These monochromatic -! values are averaged across the bands given in a +! values are averaged across the bands given in a ! spectral file. The averaged values may be written to ! a file or fitted using a recognized parametrization. ! @@ -322,7 +322,7 @@ END SUBROUTINE cloud_fit_90 ! IF ( (char_yn == 'y') .OR. (char_yn == 'Y') ) THEN ! -! The data are checked to ensure that they are all for +! The data are checked to ensure that they are all for ! the same type of scatterer. DO i=2, n_block IF (i_scatter_type(i) /= i_scatter_type(1)) THEN @@ -359,7 +359,7 @@ END SUBROUTINE cloud_fit_90 ! ELSE IF ( (char_yn == 'n') .OR. (char_yn == 'N') ) THEN STOP - ELSE + ELSE ! WRITE(iu_err, '(a)') '+++ Illegal response.' IF (l_interactive) THEN @@ -397,12 +397,12 @@ SUBROUTINE get_inst_response_int include_instrument_response=.TRUE. CALL read_instrument_response_90(filter, ierr) IF (ierr /= i_normal) STOP - EXIT + EXIT Inst ! ELSE IF ( (char_if == 'N') .OR. (char_if == 'n') ) THEN ! include_instrument_response=.FALSE. - EXIT + EXIT Inst ! ELSE ! @@ -415,7 +415,7 @@ SUBROUTINE get_inst_response_int ! ENDIF ! - ENDDO Inst + ENDDO Inst ! ! ! @@ -480,7 +480,7 @@ SUBROUTINE calculate_means_int ! Effective albedo of single scattering ! ! -! +! ! Calculate the mean scattering. mean_scattering = 0.0_RealK DO k = 0, n_int_weight From 3a8f80e6d45e86b853ca8dae891202ad043859fa Mon Sep 17 00:00:00 2001 From: Pierre Siddall <43399998+Pierre-siddall@users.noreply.github.com> Date: Mon, 16 Mar 2026 08:56:10 +0000 Subject: [PATCH 2/2] Sign contributers file --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index 797addf..9061b5b 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -5,3 +5,4 @@ | james-bruten-mo | James Bruten | Met Office | 2025-12-09 | | mo-jmanners | James Manners | Met Office | 2025-12-18 | | t00sa | Sam Clarke-Green | Met Office | 20226-03-02 | +| Pierre-siddall | Pierre Siddall | Met Office | 20226-03-16 |