diff --git a/demo/app/convert-time-data-to-json.f90 b/demo/app/convert-time-data-to-json.f90 new file mode 100644 index 000000000..c8bcfcf04 --- /dev/null +++ b/demo/app/convert-time-data-to-json.f90 @@ -0,0 +1,36 @@ +! Copyright (c) 2022-2024, The Regents of the University of California and Sourcery Institute +! Terms of use are as specified in LICENSE.txt +program convert_time_data_to_json + !! Convert icar time-step output file to JSON format + use julienne_m, only : string_t, file_t, command_line_t + use time_data_m, only : time_data_t, icar_output_file_t + implicit none + + character(len=*), parameter :: usage_info = & + new_line('') // new_line('') // & + 'Usage: ./build/run-fpm.sh run convert-time-data-to-json -- --input-file --output-file ' // new_line('') // & + 'where angular brackets (<>) denote user-provided input.' // & + new_line('') + + associate(time_data => time_data_t(icar_output_file_t(file_t(file_path("--input-file"))))) + associate(json_file => time_data%to_json()) + call json_file%write_lines(file_path("--output-file")) + end associate + end associate + + print *,new_line('') // "______ convert-time-data-to-json done _______" + +contains + + function file_path(flag) result(string) + character(len=*), intent(in) :: flag + type(string_t) string + character(len=:), allocatable :: flag_value + type(command_line_t) command_line + + flag_value = command_line%flag_value(flag) + if (len(flag_value)==0) error stop usage_info + string = string_t(flag_value) + end function + +end program diff --git a/demo/app/plot-normalized-histograms.gnu b/demo/app/plot-normalized-histograms.gnu index a8545fa63..47e6107ea 100644 --- a/demo/app/plot-normalized-histograms.gnu +++ b/demo/app/plot-normalized-histograms.gnu @@ -2,10 +2,10 @@ set logscale y 10 set key font ",20" set title "Input-Tensor Histograms Mapped to the Interval [0,1]" font "Arial,20" -plot for [col=2:8] 'training_inputs_stats.plt' using 1:col with linespoints title columnheader +plot for [col=2:8] 'inputs_stats.plt' using 1:col with linespoints title columnheader pause mouse any "Plot 1 of 2. Press any key to continue.\n" set title "Output-Tensor Histograms Mapped to the Interval [0,1]" font "Arial,20" -plot for [col=2:6] 'training_outputs_stats.plt' using 1:col with linespoints title columnheader +plot for [col=2:6] 'outputs_stats.plt' using 1:col with linespoints title columnheader pause mouse any "Plot 2 of 2. Press any key to exit.\n" diff --git a/demo/app/plot-raw-histograms.gnu b/demo/app/plot-raw-histograms.gnu index f009b79dc..fe081ff59 100644 --- a/demo/app/plot-raw-histograms.gnu +++ b/demo/app/plot-raw-histograms.gnu @@ -3,7 +3,7 @@ set term png size 2600, 1200 set output "input-tensor-histograms.png" set multiplot layout 3,3 -do for [name in "potential-temperature pressure qc qr qs qv temperature"] { +do for [name in "potential_temperature pressure qc qr qs qv temperature"] { filename = name . ".plt" set title sprintf("Histogram for %s",name) plot filename using 1:2 with linespoints title columnheader @@ -14,7 +14,7 @@ unset multiplot set output "output-tensor-histograms.png" set multiplot layout 3,2 -do for [name in "dptdt dqcdt dqrdt dqsdt dqvdt"] { +do for [name in "dpotential_temperature_dt dqc_dt dqr_dt dqs_dt dqv_dt"] { filename = name . ".plt" set title sprintf("Histogram for %s",name) plot filename using 1:2 with linespoints title columnheader diff --git a/demo/app/tensor-statistics.F90 b/demo/app/tensor-statistics.F90 index c00f74c1a..a68da19e3 100644 --- a/demo/app/tensor-statistics.F90 +++ b/demo/app/tensor-statistics.F90 @@ -3,27 +3,6 @@ #include "assert_macros.h" -module ubounds_m - !! This module serves only to support array bounds checking in the main program below - implicit none - - type ubounds_t - integer, allocatable :: ubounds_(:) - contains - procedure equals - generic :: operator(==) => equals - end type - -contains - - elemental function equals(lhs, rhs) result(lhs_equals_rhs) - class(ubounds_t), intent(in) :: lhs, rhs - logical lhs_equals_rhs - lhs_equals_rhs = all(lhs%ubounds_ == rhs%ubounds_) - end function - -end module - program tensor_statistics !! This program !! 1. Computes the ranges and histograms of input and output tensors saved by @@ -33,52 +12,65 @@ program tensor_statistics ! External dependencies: use julienne_m, only : command_line_t, file_t, string_t use assert_m - use ubounds_m, only : ubounds_t use ieee_arithmetic, only : ieee_is_nan use iso_fortran_env, only : int64, real64 ! Internal dependencies: use NetCDF_file_m, only: NetCDF_file_t + use NetCDF_variable_m, only: NetCDF_variable_t, time_derivative_t use histogram_m, only: histogram_t, to_file + use time_data_m, only: time_data_t, icar_output_file_t + use fiats_m, only : training_configuration_t, training_data_files_t implicit none - character(len=*), parameter :: usage = new_line('a') // new_line('a') // & - 'Usage: ' // new_line('a') // new_line('a') // & - './build/run-fpm.sh run tensor-statistics -- \' // new_line('a') // & - ' --base --bins \' // new_line('a') // & - ' [--raw] [--start ] [--end ] [--stride ]' // & - new_line('a') // new_line('a') // & - 'where angular brackets denote user-provided values and square brackets denote optional arguments.' & - // new_line('a') + character(len=*), parameter :: usage = new_line('') // new_line('') // & + 'Usage: ' // new_line('') // new_line('') // & + './build/run-fpm.sh run tensor-statistics -- --bins \' // new_line('') // & + ' [--raw] [--start ] [--end ] [--stride ]' // & + new_line('') // new_line('') // & + 'where angular brackets denote user-provided values and square brackets denote optional arguments.' // new_line('') integer(int64) t_start, t_finish, clock_rate integer num_bins, start_step, stride integer, allocatable :: end_step - character(len=:), allocatable :: base_name logical raw + type(string_t), allocatable :: input_file_names(:), output_file_names(:) call system_clock(t_start, clock_rate) - call get_command_line_arguments(base_name, num_bins, start_step, end_step, stride, raw) - call compute_histograms(base_name, raw) + call get_command_line_arguments(num_bins, start_step, end_step, stride, raw) + + associate( & + training_configuration => training_configuration_t(file_t("training_configuration.json")) & + ,training_data_files => training_data_files_t(file_t("training_data_files.json")) & + ) + + call compute_histograms( & + input_tensor_file_names = training_data_files%input_file_names() & + ,output_tensor_file_names = training_data_files%output_file_names() & + ,input_component_names = training_configuration%input_variable_names() & + ,output_component_names = training_configuration%output_variable_names() & + ,time_data_file_name = training_configuration%time_data_file_name() & + ,raw = raw & + ) + end associate call system_clock(t_finish) - print *,"System clock time: ", real(t_finish - t_start, real64)/real(clock_rate, real64) + print '(a,g0)',"System clock time: ", real(t_finish - t_start, real64)/real(clock_rate, real64) print * - print *,"______________________________________________________" - print *,"The *.plt files contain tensor ranges and histograms." - print *,"If you have gnuplot installed, please execute the" - print *,"following command to produce histogram visualizations:" + print '(a)',"______________________________________________________" + print '(a)',"The *.plt files contain tensor ranges and histograms." + print '(a)',"If you have gnuplot installed, please execute the" + print '(a)',"following command to produce histogram visualizations:" print * associate(file_name => trim(merge("plot-raw-histograms ", "plot-normalized-histograms", raw)) // ".gnu") print*," gnuplot app/" // file_name end associate print * - print *,"_______________ tensor_statistics done________________" + print '(a)',"_______________ tensor_statistics done________________" contains - subroutine get_command_line_arguments(base_name, num_bins, start_step, end_step, stride, raw) - character(len=:), allocatable, intent(out) :: base_name + subroutine get_command_line_arguments(num_bins, start_step, end_step, stride, raw) integer, intent(out) :: num_bins, start_step, stride integer, intent(out), allocatable :: end_step logical, intent(out) :: raw @@ -87,14 +79,13 @@ subroutine get_command_line_arguments(base_name, num_bins, start_step, end_step, type(command_line_t) command_line character(len=:), allocatable :: stride_string, bins_string, start_string, end_string - base_name = command_line%flag_value("--base") bins_string = command_line%flag_value("--bins") start_string = command_line%flag_value("--start") end_string = command_line%flag_value("--end") stride_string = command_line%flag_value("--stride") raw = command_line%argument_present(["--raw"]) - associate(required_arguments => len(base_name)/=0 .and. len(bins_string)/=0) + associate(required_arguments => len(bins_string)/=0) if (.not. required_arguments) error stop usage end associate @@ -119,133 +110,115 @@ subroutine get_command_line_arguments(base_name, num_bins, start_step, end_step, end subroutine get_command_line_arguments - subroutine compute_histograms(base_name, raw) - character(len=*), intent(in) :: base_name + subroutine compute_histograms( & + input_tensor_file_names, output_tensor_file_names, input_component_names, output_component_names, time_data_file_name, raw & + ) + type(string_t), intent(in) :: input_tensor_file_names(:), output_tensor_file_names(:) + type(string_t), intent(in) :: input_component_names(:), output_component_names(:), time_data_file_name logical, intent(in) :: raw - integer(int64) t_histo_start, t_histo_finish - real, allocatable, dimension(:,:,:,:) :: & - pressure_in , potential_temperature_in , temperature_in , & - pressure_out, potential_temperature_out, temperature_out, & - qv_out, qc_out, qr_out, qs_out, & - qv_in , qc_in , qr_in , qs_in , & - dpt_dt, dqv_dt, dqc_dt, dqr_dt, dqs_dt - double precision, allocatable, dimension(:) :: time_in, time_out + type(time_derivative_t), allocatable :: derivative(:) + type(NetCDF_variable_t), allocatable :: input_variable(:), output_variable(:) + type(NetCDF_variable_t) input_time, output_time + double precision, allocatable, dimension(:) :: dt double precision, parameter :: tolerance = 1.E-07 - type(histogram_t), allocatable :: histograms(:) - type(ubounds_t), allocatable :: ubounds(:) - integer, allocatable :: lbounds(:) - integer t, t_end - - associate( network_input_file_name => base_name // "_input.nc") - - print *,"Reading network inputs from " // network_input_file_name - - associate(network_input_file => netCDF_file_t(network_input_file_name)) - ! Skipping the following unnecessary inputs: precipitation, snowfall - call network_input_file%input("pressure", pressure_in) - call network_input_file%input("potential_temperature", potential_temperature_in) - call network_input_file%input("temperature", temperature_in) - call network_input_file%input("qv", qv_in) - call network_input_file%input("qc", qc_in) - call network_input_file%input("qr", qr_in) - call network_input_file%input("qs", qs_in) - call network_input_file%input("time", time_in) - - t_end = size(time_in) - lbounds = [lbound(pressure_in), lbound(temperature_in), lbound(qv_in), lbound(qc_in), lbound(qr_in), lbound(qs_in)] - ubounds = & - [ubounds_t(ubound(qv_in)), ubounds_t(ubound(qc_in)), ubounds_t(ubound(qr_in)), ubounds_t(ubound(qs_in)), & - ubounds_t(ubound(pressure_in)), ubounds_t(ubound(temperature_in)) & - ] - - print *,"Calculating input tensor histograms." - call system_clock(t_histo_start) - histograms = [ & - histogram_t(pressure_in, "pressure", num_bins, raw) & - ,histogram_t(potential_temperature_in, 'potential-temperature', num_bins, raw) & - ,histogram_t(temperature_in, "temperature", num_bins, raw) & - ,histogram_t(qv_in, "qv", num_bins, raw) & - ,histogram_t(qc_in, "qc", num_bins, raw) & - ,histogram_t(qr_in, "qr", num_bins, raw) & - ,histogram_t(qs_in, "qs", num_bins, raw) & - ] - call system_clock(t_histo_finish) - print *,"Seven input histograms done in ", real(t_histo_finish - t_histo_start, real64)/real(clock_rate, real64), " sec." - - print *,"Writing input tensor histograms file" - block - type(file_t) histograms_file - integer h - - if (raw) then - do h = 1, size(histograms) - histograms_file = to_file(histograms(h)) - call histograms_file%write_lines(string_t(histograms(h)%variable_name() // ".plt")) - end do - else - histograms_file = to_file(histograms) - call histograms_file%write_lines(string_t(base_name // "_inputs_stats.plt")) - end if - end block - end associate + integer(int64) t_histo_start, t_histo_finish + integer t, t_end, v + + allocate(input_variable(size(input_component_names))) + + print '(a)',"Reading physics-based model inputs from " // input_tensor_file_names(1)%string() + + input_file: & + associate(NetCDF_file => netCDF_file_t(input_tensor_file_names(1))) + + do v=1, size(input_variable) + print '(a)',"- reading " // input_component_names(v)%string() + call input_variable(v)%input(input_component_names(v), NetCDF_file, rank=4) + end do + + do v = 2, size(input_variable) + call_assert(input_variable(v)%conformable_with(input_variable(1))) + end do + + print '(a)',"- reading time from NetCDF file" + call input_time%input("time", NetCDF_file, rank=1) + + end associate input_file + + print '(a)',"Calculating input tensor histograms." + call system_clock(t_histo_start) + associate(histograms => [(input_variable(v)%histogram(num_bins, raw), v = 1, size(input_variable))]) + call system_clock(t_histo_finish) + print '(i0,a,g0,a)',size(histograms), " input histograms done in ", real(t_histo_finish - t_histo_start, real64)/real(clock_rate, real64), " sec." + + print '(a)',"Writing input tensor histograms file" + block + type(file_t) histograms_file + integer h + + if (raw) then + do h = 1, size(histograms) + histograms_file = to_file(histograms(h)) + associate(gnuplot_file_name => histograms(h)%variable_name() // ".plt") + print '(a)',"- writing " // gnuplot_file_name + call histograms_file%write_lines(string_t(gnuplot_file_name)) + end associate + end do + else + histograms_file = to_file(histograms) + associate(gnuplot_file_name => "inputs_stats.plt") + print '(a)',"- writing " // gnuplot_file_name + call histograms_file%write_lines(string_t(gnuplot_file_name)) + end associate + end if + end block + end associate + + allocate(output_variable(size(output_component_names))) + + print '(a)',"Reading physics-based model outputs from " // output_tensor_file_names(1)%string() + + output_file: & + associate(NetCDF_file => netCDF_file_t(output_tensor_file_names(1))) + + do v=1, size(output_variable) + print '(a)', "- reading " // output_component_names(v)%string() + call output_variable(v)%input(output_component_names(v), NetCDF_file, rank=4) + end do + + do v = 2, size(output_variable) + call_assert(output_variable(v)%conformable_with(output_variable(1))) + end do + + print '(a)',"- reading time" + call output_time%input("time", NetCDF_file, rank=1) + + end associate output_file + + print '(a)',"Calculating the desired neural-network model outputs: time derivatives of a subset of the inputs" + + allocate(derivative(size(output_variable))) + + print '(a)',"- reading time from JSON file" + associate(time_data => time_data_t(file_t(time_data_file_name))) + do v = 1, size(derivative) + derivative_name: & + associate(derivative_name => "d" // output_component_names(v)%string() // "_dt") + print '(a)',"- " // derivative_name + derivative(v) = time_derivative_t(old = input_variable(v), new = output_variable(v), dt=time_data%dt()) + call_assert(.not. derivative(v)%any_nan()) + end associate derivative_name + end do end associate - associate(network_output_file_name => base_name // "_output.nc") - - print *, "Reading network outputs from " // network_output_file_name - - associate(network_output_file => netCDF_file_t(network_output_file_name)) - ! Skipping the following unnecessary outputs: pressure, temperature, precipitation, snowfall - call network_output_file%input("potential_temperature", potential_temperature_out) - call network_output_file%input("qv", qv_out) - call network_output_file%input("qc", qc_out) - call network_output_file%input("qr", qr_out) - call network_output_file%input("qs", qs_out) - call network_output_file%input("time", time_out) - lbounds = [lbounds, lbound(qv_out), lbound(qc_out), lbound(qr_out), lbound(qs_out)] - ubounds = [ubounds, ubounds_t(ubound(qv_out)), ubounds_t(ubound(qc_out)), & - ubounds_t(ubound(qr_out)), ubounds_t(ubound(qs_out))] - call_assert_diagnose(all(lbounds == 1), "main: default input/output lower bounds", intrinsic_array_t(lbounds)) - call_assert_describe(all(ubounds == ubounds(1)), "main: matching input/output upper bounds") - call_assert_describe(all(abs(time_in(2:t_end) - time_out(1:t_end-1)) real(time_out - time_in)) - do concurrent(t = 1:t_end) - dpt_dt(:,:,:,t) = (potential_temperature_out(:,:,:,t) - potential_temperature_in(:,:,:,t))/dt(t) - dqv_dt(:,:,:,t) = (qv_out(:,:,:,t)- qv_in(:,:,:,t))/dt(t) - dqc_dt(:,:,:,t) = (qc_out(:,:,:,t)- qc_in(:,:,:,t))/dt(t) - dqr_dt(:,:,:,t) = (qr_out(:,:,:,t)- qr_in(:,:,:,t))/dt(t) - dqs_dt(:,:,:,t) = (qs_out(:,:,:,t)- qs_in(:,:,:,t))/dt(t) - end do - end associate - - call_assert(.not. any(ieee_is_nan(dpt_dt))) - call_assert(.not. any(ieee_is_nan(dqv_dt))) - call_assert(.not. any(ieee_is_nan(dqc_dt))) - call_assert(.not. any(ieee_is_nan(dqr_dt))) - call_assert(.not. any(ieee_is_nan(dqs_dt))) - - print *,"Calculating output tensor histograms." - call system_clock(t_histo_start, clock_rate) - histograms = [ & - histogram_t(dpt_dt, "dptdt", num_bins, raw) & - ,histogram_t(dqv_dt, "dqvdt", num_bins, raw) & - ,histogram_t(dqc_dt, "dqcdt", num_bins, raw) & - ,histogram_t(dqr_dt, "dqrdt", num_bins, raw) & - ,histogram_t(dqs_dt, "dqsdt", num_bins, raw) & - ] + print '(a)',"Calculating histograms for the desired neural-network outputs." + call system_clock(t_histo_start) + associate(histograms => [(derivative(v)%histogram(num_bins, raw), v = 1, size(derivative))]) call system_clock(t_histo_finish) - print *,"Five output histograms done in ", real(t_histo_finish - t_histo_start, real64)/real(clock_rate, real64), " sec." + print '(i0,a,g0,a)',size(histograms), " output histograms done in ", real(t_histo_finish - t_histo_start, real64)/real(clock_rate, real64), " sec." + + print '(a)',"Writing desired-output tensor histograms file" block type(file_t) histograms_file integer h @@ -253,14 +226,21 @@ subroutine compute_histograms(base_name, raw) if (raw) then do h = 1, size(histograms) histograms_file = to_file(histograms(h)) - call histograms_file%write_lines(string_t(histograms(h)%variable_name() // ".plt")) + associate(gnuplot_file_name => histograms(h)%variable_name() // ".plt") + print '(a)',"- writing " // gnuplot_file_name + call histograms_file%write_lines(string_t(gnuplot_file_name)) + end associate end do else - histograms_file = to_file(histograms) - call histograms_file%write_lines(string_t(base_name // "_outputs_stats.plt")) + histograms_file = to_file(histograms) + associate(gnuplot_file_name => "outputs_stats.plt") + print '(a)',"- writing " // gnuplot_file_name + call histograms_file%write_lines(string_t(gnuplot_file_name)) + end associate end if end block end associate + end subroutine end program tensor_statistics diff --git a/demo/app/train-cloud-microphysics.F90 b/demo/app/train-cloud-microphysics.F90 index 5efe5c40c..2996239b4 100644 --- a/demo/app/train-cloud-microphysics.F90 +++ b/demo/app/train-cloud-microphysics.F90 @@ -20,9 +20,10 @@ program train_cloud_microphysics !! Internal dependencies: use phase_space_bin_m, only : phase_space_bin_t use NetCDF_file_m, only: NetCDF_file_t - use NetCDF_variable_m, only: NetCDF_variable_t, tensors + use NetCDF_variable_m, only: NetCDF_variable_t, tensors, time_derivative_t use occupancy_m, only : occupancy_t use default_m, only: default_or_internal_read + use time_data_m, only: time_data_t implicit none @@ -154,7 +155,8 @@ subroutine read_train_write(training_configuration, args, plot_file) type(training_configuration_t), intent(in) :: training_configuration type(command_line_arguments_t), intent(in) :: args type(plot_file_t), intent(in), optional :: plot_file - type(NetCDF_variable_t), allocatable :: input_variable(:), output_variable(:), derivative(:) + type(NetCDF_variable_t), allocatable :: input_variable(:), output_variable(:) + type(time_derivative_t), allocatable :: derivative(:) type(NetCDF_variable_t) input_time, output_time ! local variables: @@ -169,7 +171,7 @@ subroutine read_train_write(training_configuration, args, plot_file) logical stop_requested input_names: & - associate(input_names => training_configuration%input_names()) + associate(input_names => training_configuration%input_variable_names()) allocate(input_variable(size(input_names))) @@ -198,7 +200,7 @@ subroutine read_train_write(training_configuration, args, plot_file) end associate input_names output_names: & - associate(output_names => training_configuration%output_names()) + associate(output_names => training_configuration%output_variable_names()) allocate(output_variable(size(output_names))) @@ -229,19 +231,19 @@ subroutine read_train_write(training_configuration, args, plot_file) print *,"Calculating desired neural-network model outputs" - allocate(derivative, mold=output_variable) + allocate(derivative(size(output_variable))) - dt: & - associate(dt => NetCDF_variable_t(output_time - input_time, "dt")) + print '(a)',"- reading time from JSON file" + associate(time_data => time_data_t(file_t(training_configuration%time_data_file_name()))) do v = 1, size(derivative) derivative_name: & associate(derivative_name => "d" // output_names(v)%string() // "/dt") print *,"- " // derivative_name - derivative(v) = NetCDF_variable_t( (input_variable(v) - output_variable(v)) / dt, derivative_name) + derivative(v) = time_derivative_t(old = input_variable(v), new = output_variable(v), dt=time_data%dt()) call_assert(.not. derivative(v)%any_nan()) end associate derivative_name end do - end associate dt + end associate end associate output_names if (allocated(args%end_step)) then diff --git a/demo/fpm.toml b/demo/fpm.toml index bde6b9b7b..503877403 100644 --- a/demo/fpm.toml +++ b/demo/fpm.toml @@ -4,7 +4,7 @@ author = "(Please see fiats/fpm.toml.)" maintainer = "(Please see fiats/fpm.toml.)" [dependencies] -assert = {git = "https://github.com/sourceryinstitute/assert", tag = "2.0.0"} -julienne = {git = "https://github.com/berkeleylab/julienne", tag = "1.8.0"} +assert = {git = "https://github.com/sourceryinstitute/assert", tag = "2.1.0"} +julienne = {git = "https://github.com/berkeleylab/julienne", tag = "1.8.4"} fiats = {path = "../"} netcdf-interfaces = {git = "https://github.com/LKedward/netcdf-interfaces.git", rev = "d2bbb71ac52b4e346b62572b1ca1620134481096"} diff --git a/demo/src/NetCDF_file_m.f90 b/demo/src/NetCDF_file_m.f90 index 91d1dac92..89bb3c20c 100644 --- a/demo/src/NetCDF_file_m.f90 +++ b/demo/src/NetCDF_file_m.f90 @@ -1,6 +1,7 @@ ! Copyright (c), The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module NetCDF_file_m + use julienne_m, only : string_t implicit none private @@ -16,12 +17,18 @@ module NetCDF_file_m interface NetCDF_file_t - pure module function construct(file_name) result(NetCDF_file) + pure module function construct_from_character_name(file_name) result(NetCDF_file) implicit none character(len=*), intent(in) :: file_name type(NetCDF_file_t) NetCDF_file end function + pure module function construct_from_string_name(file_name) result(NetCDF_file) + implicit none + type(string_t), intent(in) :: file_name + type(NetCDF_file_t) NetCDF_file + end function + end interface interface diff --git a/demo/src/NetCDF_file_s.F90 b/demo/src/NetCDF_file_s.F90 index 7a4bea691..b289c2130 100644 --- a/demo/src/NetCDF_file_s.F90 +++ b/demo/src/NetCDF_file_s.F90 @@ -13,7 +13,11 @@ contains - module procedure construct + module procedure construct_from_string_name + netCDF_file%file_name_ = file_name + end procedure + + module procedure construct_from_character_name netCDF_file%file_name_ = file_name end procedure diff --git a/demo/src/NetCDF_variable_m.f90 b/demo/src/NetCDF_variable_m.f90 index 113145236..ce455a42d 100644 --- a/demo/src/NetCDF_variable_m.f90 +++ b/demo/src/NetCDF_variable_m.f90 @@ -3,6 +3,7 @@ module NetCDF_variable_m use NetCDF_file_m, only : NetCDF_file_t use kind_parameters_m, only : default_real, double_precision + use histogram_m, only : histogram_t use julienne_m, only : string_t use fiats_m, only : tensor_t implicit none @@ -10,6 +11,7 @@ module NetCDF_variable_m private public :: NetCDF_variable_t public :: tensors + public :: time_derivative_t type NetCDF_variable_t(k) integer, kind :: k = default_real @@ -33,12 +35,27 @@ module NetCDF_variable_m procedure, private, non_overridable :: default_real_maximum , double_precision_maximum generic :: operator(-) => default_real_subtract , double_precision_subtract procedure, private, non_overridable :: default_real_subtract , double_precision_subtract - generic :: operator(/) => default_real_divide , double_precision_divide - procedure, private, non_overridable :: default_real_divide , double_precision_divide - generic :: assignment(=) => default_real_assign , double_precision_assign - procedure, private, non_overridable :: default_real_assign , double_precision_assign + generic :: histogram => default_real_histogram , double_precision_histogram + procedure, private, non_overridable :: default_real_histogram , double_precision_histogram + generic :: compare => default_real_compare , double_precision_compare + procedure, private, non_overridable :: default_real_compare , double_precision_compare end type + type, extends(NetCDF_variable_t) :: time_derivative_t(k) + integer, kind :: k = default_real + end type + + interface time_derivative_t + + module function default_real_time_derivative(old, new, dt) result(time_derivative) + implicit none + type(NetCDF_variable_t), intent(in) :: old, new + real, intent(in) :: dt(:) + type(time_derivative_t) time_derivative + end function + + end interface + interface NetCDF_variable_t elemental module function default_real_copy(source, rename) result(NetCDF_variable) @@ -153,30 +170,6 @@ elemental module function double_precision_subtract(lhs, rhs) result(difference) type(NetCDF_variable_t(double_precision)) difference end function - elemental module function default_real_divide(lhs, rhs) result(ratio) - implicit none - class(NetCDF_variable_t), intent(in) :: lhs, rhs - type(NetCDF_variable_t) ratio - end function - - elemental module function double_precision_divide(lhs, rhs) result(ratio) - implicit none - class(NetCDF_variable_t(double_precision)), intent(in) :: lhs, rhs - type(NetCDF_variable_t(double_precision)) ratio - end function - - elemental module subroutine default_real_assign(lhs, rhs) - implicit none - class(NetCDF_variable_t), intent(inout) :: lhs - type(NetCDF_variable_t), intent(in) :: rhs - end subroutine - - elemental module subroutine double_precision_assign(lhs, rhs) - implicit none - class(NetCDF_variable_t(double_precision)), intent(inout) :: lhs - type(NetCDF_variable_t(double_precision)), intent(in) :: rhs - end subroutine - elemental module function default_real_any_nan(self) result(any_nan) implicit none class(NetCDF_variable_t), intent(in) :: self @@ -215,7 +208,7 @@ elemental module function double_precision_maximum(self) result(maximum) module function tensors(NetCDF_variables, step_start, step_end, step_stride) implicit none - type(NetCDF_variable_t), intent(in) :: NetCDF_variables(:) + class(NetCDF_variable_t), intent(in) :: NetCDF_variables(:) type(tensor_t), allocatable :: tensors(:) integer, optional :: step_start, step_end, step_stride end function @@ -232,6 +225,34 @@ elemental module function double_precision_end_time(self) result(end_time) integer end_time end function + elemental module function default_real_histogram(self, num_bins, raw) result(histogram) + implicit none + class(NetCDF_variable_t), intent(inout) :: self + integer, intent(in) :: num_bins + logical, intent(in) :: raw + type(histogram_t) histogram + end function + + elemental module function double_precision_histogram(self, num_bins, raw) result(histogram) + implicit none + class(NetCDF_variable_t(double_precision)), intent(inout) :: self + integer, intent(in) :: num_bins + logical, intent(in) :: raw + type(histogram_t) histogram + end function + + module subroutine default_real_compare(self, values) + implicit none + class(NetCDF_variable_t), intent(in) :: self + type(string_t), intent(in) :: values(:) + end subroutine + + module subroutine double_precision_compare(self, values) + implicit none + class(NetCDF_variable_t(double_precision)), intent(in) :: self + type(string_t), intent(in) :: values(:) + end subroutine + end interface end module \ No newline at end of file diff --git a/demo/src/NetCDF_variable_s.F90 b/demo/src/NetCDF_variable_s.F90 index c2a3d5c68..b00331e25 100644 --- a/demo/src/NetCDF_variable_s.F90 +++ b/demo/src/NetCDF_variable_s.F90 @@ -27,6 +27,57 @@ contains + module procedure default_real_time_derivative + + call_assert(new%conformable_with(old)) + call_assert(old%name_==new%name_) + + time_derivative%name_ = "d" // old%name_ // "_dt" + + block + integer t + + select case(old%rank()) + case(1) + allocate(time_derivative%values_1D_, mold = old%values_1D_) + do concurrent(t = 1:size(old%values_1D_)) + time_derivative%values_1D_(t) = (new%values_1D_(t) - old%values_1D_(t))/ dt(t) + end do + case(2) + allocate(time_derivative%values_2D_, mold = old%values_2D_) + do concurrent(t = 1:size(old%values_2D_,2)) + time_derivative%values_2D_(:,t) = (new%values_2D_(:,t) - old%values_2D_(:,t))/ dt(t) + end do + case(3) + allocate(time_derivative%values_3D_, mold = old%values_3D_) + do concurrent(t = 1:size(old%values_3D_,3)) + time_derivative%values_3D_(:,:,t) = (new%values_3D_(:,:,t) - old%values_3D_(:,:,t))/ dt(t) + end do + case(4) + allocate(time_derivative%values_4D_, mold = old%values_4D_) + do concurrent(t = 1:size(old%values_4D_,4)) + time_derivative%values_4D_(:,:,:,t) = (new%values_4D_(:,:,:,t) - old%values_4D_(:,:,:,t))/ dt(t) + end do + case default + error stop "NetCDF_variable_s(default_real_time_derivative): unsupported rank)" + end select + end block + + end procedure + + module procedure default_real_histogram + select case(self%rank()) + case (4) + histogram = histogram_t(self%values_4D_ , self%name_, num_bins, raw) + case default + error stop 'NetCDF_variable_s(default_real_histogram): unsupported rank' + end select + end procedure + + module procedure double_precision_histogram + error stop 'NetCDF_variable_s(double_precision_histogram): unsupported rank' + end procedure + module procedure default_real_copy if (present(rename)) then @@ -305,90 +356,6 @@ pure function double_precision_upper_bounds(NetCDF_variable) result(ubounds) end select end procedure - module procedure default_real_divide - - integer t - - call_assert(rhs%rank()==1) - - associate(t_end => size(rhs%values_1D_)) - - select case(lhs%rank()) - case(4) - - call_assert_describe(size(rhs%values_1D_) == size(lhs%values_4D_,4), "NetCDF_variable_s(default_real_divide): conformable numerator/denominator") - allocate(ratio%values_4D_, mold = lhs%values_4D_) - - do concurrent(t = 1:t_end) - ratio%values_4D_(:,:,:,t) = lhs%values_4D_(:,:,:,t) / rhs%values_1D_(t) - end do - - case default - error stop "NetCDF_variable_s(default_real_divide): unsupported lhs rank)" - end select - - end associate - - end procedure - - module procedure double_precision_divide - - integer t - - call_assert(rhs%rank()==1) - - associate(t_end => size(rhs%values_1D_)) - - select case(lhs%rank()) - case(4) - - call_assert_describe(size(rhs%values_1D_) == size(lhs%values_4D_,4), "NetCDF_variable_s(double_precision_divide): conformable numerator/denominator") - allocate(ratio%values_4D_, mold = lhs%values_4D_) - - do concurrent(t = 1:t_end) - ratio%values_4D_(:,:,:,t) = lhs%values_4D_(:,:,:,t) / rhs%values_1D_(t) - end do - - case default - error stop "NetCDF_variable_s(double_precision_divide): unsupported lhs rank)" - end select - - end associate - - end procedure - - module procedure default_real_assign - select case(rhs%rank()) - case(1) - lhs%values_1D_ = rhs%values_1D_ - case(2) - lhs%values_2D_ = rhs%values_2D_ - case(3) - lhs%values_3D_ = rhs%values_3D_ - case(4) - lhs%values_4D_ = rhs%values_4D_ - case default - error stop "NetCDF_variable_s(default_real_assign): unsupported rank)" - end select - call_assert(lhs%rank()==rhs%rank()) - end procedure - - module procedure double_precision_assign - select case(rhs%rank()) - case(1) - lhs%values_1D_ = rhs%values_1D_ - case(2) - lhs%values_2D_ = rhs%values_2D_ - case(3) - lhs%values_3D_ = rhs%values_3D_ - case(4) - lhs%values_4D_ = rhs%values_4D_ - case default - error stop "NetCDF_variable_s(double_precision_assign): unsupported rank)" - end select - call_assert(lhs%rank()==rhs%rank()) - end procedure - module procedure default_real_any_nan select case(self%rank()) @@ -540,4 +507,20 @@ pure function double_precision_upper_bounds(NetCDF_variable) result(ubounds) end select end procedure + module procedure default_real_compare + integer i + print *, "Sizes = ", size(self%values_1D_), size(values) + do i=1, min(size(self%values_1D_), size(values)) + print *, self%values_1D_(i), values(i)%string() + end do + end procedure + + module procedure double_precision_compare + integer i + print *, "Sizes = ", size(self%values_1D_), size(values) + do i=1, min(size(self%values_1D_), size(values)) + print *, self%values_1D_(i), ", ", values(i)%string() + end do + end procedure + end submodule NetCDF_variable_s \ No newline at end of file diff --git a/demo/src/histogram_s.F90 b/demo/src/histogram_s.F90 index 59d18af17..4d5ef8c89 100644 --- a/demo/src/histogram_s.F90 +++ b/demo/src/histogram_s.F90 @@ -145,15 +145,17 @@ pure function normalize(x, x_min, x_max) result(x_normalized) end do end do end do - histogram%bin_frequency_ = real(bin_count) / real(cardinality) end if + histogram%bin_frequency_ = real(bin_count) / real(cardinality) end associate end associate end associate end associate +#ifdef ASSERTIONS associate(binned => sum(bin_count)) call_assert_diagnose(cardinality == binned, "histogram_s(construct): lossless binning", intrinsic_array_t([cardinality, binned])) end associate +#endif end associate end procedure diff --git a/demo/src/time_data_m.F90 b/demo/src/time_data_m.F90 index bc5acd068..53cc378c8 100644 --- a/demo/src/time_data_m.F90 +++ b/demo/src/time_data_m.F90 @@ -20,6 +20,8 @@ module time_data_m procedure, private :: default_real_to_json generic :: dt => default_real_dt procedure, private :: default_real_dt + generic :: times => default_real_times + procedure, private :: default_real_times end type type, extends(file_t) :: icar_output_file_t @@ -57,7 +59,13 @@ pure module function from_icar_output(icar_output_file) result(time_data) interface icar_output_file_t - pure module function from_string_array(lines) result(icar_output_file) + pure module function from_file_object(file) result(icar_output_file) + implicit none + type(file_t), intent(in) :: file + type(icar_output_file_t) icar_output_file + end function + + pure module function from_lines(lines) result(icar_output_file) implicit none type(string_t), intent(in) :: lines(:) type(icar_output_file_t) icar_output_file @@ -79,6 +87,12 @@ pure module function default_real_dt(self) result(dt_values) real, allocatable :: dt_values(:) end function + pure module function default_real_times(self) result(times) + implicit none + class(time_data_t), intent(in) :: self + type(string_t), allocatable :: times(:) + end function + end interface end module time_data_m diff --git a/demo/src/time_data_s.F90 b/demo/src/time_data_s.F90 index 127041664..bbb9546ef 100644 --- a/demo/src/time_data_s.F90 +++ b/demo/src/time_data_s.F90 @@ -9,8 +9,12 @@ implicit none contains - module procedure from_string_array - icar_output_file%file_t = file_t(lines) + module procedure from_file_object + icar_output_file%file_t = file + end procedure + + module procedure from_lines + icar_output_file%file_t = file_t(lines) end procedure module procedure default_real_from_json @@ -20,19 +24,14 @@ associate(lines => file%lines()) i = 1 call_assert_diagnose(adjustl(lines(i)%string())=='{'," default_real_json(time_data_s): object start", lines(i)%string()) - call_assert(allocated(file%date_)) - call_assert(allocated(file%time_)) - call_assert(allocated(file%dt_)) - call_assert(all(size(file%date_) == [size(file%time_), size(file%dt_)])) - call_assert(.false.) i = 3 time_data%date_ = lines(i)%get_json_value(key="dates", mold=[string_t::]) i = 4 - time_data%date_ = lines(i)%get_json_value(key="times", mold=[string_t::]) + time_data%time_ = lines(i)%get_json_value(key="times", mold=[string_t::]) i = 5 time_data%dt_= lines(i)%get_json_value(key="dt", mold=[real::]) + call_assert(all(size(time_data%date_) == [size(time_data%time_), size(time_data%dt_)])) end associate - end procedure module procedure default_real_from_strings @@ -63,7 +62,7 @@ allocate(time_data%date_(num_lines)) allocate(time_data%time_(num_lines)) allocate(time_data%dt_(num_lines)) - + do line = 1, num_lines associate(raw_line => lines(line)%string()) call_assert(raw_line(1:len(preface))==preface) @@ -121,4 +120,8 @@ dt_values = self%dt_ end procedure + module procedure default_real_times + times = self%time_ + end procedure + end submodule time_data_s diff --git a/demo/test/time_data_test_m.F90 b/demo/test/time_data_test_m.F90 index 39b78fba9..c29e59c80 100644 --- a/demo/test/time_data_test_m.F90 +++ b/demo/test/time_data_test_m.F90 @@ -42,8 +42,8 @@ function results() result(test_results) #if HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY test_descriptions = [ & - test_description_t("constructing a instance from a file object in the icar output format", construct_from_icar_file) & - test_description_t("writing and reading a JSON file returns the values written", write_then_read_json) & + test_description_t("constructing a instance from a file object in the icar output format", construct_from_icar_file) & + ,test_description_t("writing and reading a JSON file returns the values written", write_then_read_json) & ] #else procedure(diagnosis_function_i), pointer :: construct_from_icar_file_ptr, write_then_read_json_ptr @@ -71,9 +71,9 @@ function construct_from_icar_file() result(test_diagnosis) real, allocatable :: dt(:) associate(time_data => time_data_t( icar_output_file_t( string_t( [ & - "training data dt= 2010/10/01 03:16:00 120.000000 " & - ,"training data dt= 2010/10/01 06:36:00 120.000000 " & - ,"training data dt= 2010/10/01 09:56:00 120.000000 " & + "training data dt= 2010/10/01 03:16:00 120.000000 1" & + ,"training data dt= 2010/10/01 06:36:00 120.000000 2" & + ,"training data dt= 2010/10/01 09:56:00 120.000000 3" & ] ) ) ) ) associate(dt => time_data%dt()) test_diagnosis = test_diagnosis_t( & @@ -92,7 +92,7 @@ function write_then_read_json() result(test_diagnosis) associate(time_data => time_data_t( & date = string_t(["2010/10/01", "2010/10/01", "2010/10/01"]) & ,time = string_t([ "03:16:00", "06:36:00", "09:56:00"]) & - ,dt = [120.000000, 120.000000, 120.000000] & + ,dt = [expected_dt, expected_dt, expected_dt] & ) ) associate(json_file => time_data%to_json()) associate(from_json => time_data_t(json_file)) diff --git a/demo/training_configuration.json b/demo/training_configuration.json index a01576ee5..367daa6fb 100644 --- a/demo/training_configuration.json +++ b/demo/training_configuration.json @@ -3,14 +3,12 @@ "mini-batches" : 10, "learning rate" : 1.50000000, "optimizer" : "adam" - } - , + }, "network configuration": { "skip connections" : false, "nodes per layer" : [7,32,32,32,5], "activation function" : "sigmoid" }, - , "tensor names": { "inputs" : ["potential_temperature","qv", "qc", "qr", "qs", "pressure", "temperature"], "outputs" : ["potential_temperature","qv", "qc", "qr", "qs"] diff --git a/demo/training_data_files.json b/demo/training_data_files.json new file mode 100644 index 000000000..5b85bf348 --- /dev/null +++ b/demo/training_data_files.json @@ -0,0 +1,8 @@ + { + "training data files": { + "path" : "dates-20101001-2011076", + "inputs prefix" : "training_input-image-", + "outputs prefix" : "training_output-image-", + "infixes" : ["000001", "000002", "000003", "000004", "000005", "000006", "000007", "000008", "000009", "000010"] + } + } diff --git a/example/concurrent-inferences.f90 b/example/concurrent-inferences.f90 index 6bb5a436c..d742f0996 100644 --- a/example/concurrent-inferences.f90 +++ b/example/concurrent-inferences.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt program concurrent_inferences !! This program demonstrates how to read a neural network from a JSON file diff --git a/example/print-training-configuration.F90 b/example/print-training-configuration.F90 index 300d2030c..66ab19369 100644 --- a/example/print-training-configuration.F90 +++ b/example/print-training-configuration.F90 @@ -1,11 +1,10 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2024-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt program print_training_configuration !! Demonstrate how to construct and print a training_configuration_t object use fiats_m, only : training_configuration_t, hyperparameters_t, network_configuration_t, tensor_names_t use julienne_m, only : file_t, string_t implicit none -#ifndef _CRAYFTN associate(training_configuration => training_configuration_t( & hyperparameters_t(mini_batches=10, learning_rate=1.5, optimizer = "adam") & ,network_configuration_t(skip_connections=.false., nodes_per_layer=[2,72,2], activation_name="sigmoid") & @@ -15,17 +14,4 @@ program print_training_configuration call json_file%write_lines() end associate end associate -#else - block - type(training_configuration_t) :: training_configuration - type(file_t) :: json_file - training_configuration = training_configuration_t( & - hyperparameters_t(mini_batches=10, learning_rate=1.5, optimizer = "adam") & - ,network_configuration_t(skip_connections=.false., nodes_per_layer=[2,72,2], activation_name="sigmoid") & - ,tensorm_names_t(inputs=[string_t("pressure"), string_t("temperature")], outputs([string_t("saturated mixing ratio")])) & - ) - json_file = file_t(training_configuration%to_json()) - call json_file%write_lines() - end block -#endif end program diff --git a/fpm.toml b/fpm.toml index 0f4888a70..c809d80c1 100644 --- a/fpm.toml +++ b/fpm.toml @@ -5,5 +5,5 @@ author = "Damian Rouson, Tan Nguyen, Jordan Welsman, David Torres, Brad Richards maintainer = "rouson@lbl.gov" [dependencies] -assert = {git = "https://github.com/sourceryinstitute/assert", tag = "2.0.0"} +assert = {git = "https://github.com/sourceryinstitute/assert", tag = "2.1.0"} julienne = {git = "https://github.com/berkeleylab/julienne", tag = "1.5.3"} diff --git a/include/language-support.F90 b/include/language-support.F90 index d64f0096f..6d9d19ec7 100644 --- a/include/language-support.F90 +++ b/include/language-support.F90 @@ -18,3 +18,14 @@ # define MULTI_IMAGE_SUPPORT 1 #endif #endif + +#ifndef HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY + ! Define whether the compiler supports associating a procedure pointer dummy argument with an + ! actual argument that is a valid target for the pointer dummy in a procedure assignment, a + ! feature introduced in Fortran 2008 and described in Fortran 2023 clause 15.5.2.10 paragraph 5. +#if defined(_CRAYFTN) || defined(__INTEL_COMPILER) || defined(NAGFOR) || defined(__flang__) +#define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 1 +#else +#define HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY 0 +#endif +#endif diff --git a/src/fiats/activation_m.f90 b/src/fiats/activation_m.f90 index 8e5948386..b1527b63b 100644 --- a/src/fiats/activation_m.f90 +++ b/src/fiats/activation_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module activation_m diff --git a/src/fiats/activation_s.F90 b/src/fiats/activation_s.F90 index ddff57c46..ca4233412 100644 --- a/src/fiats/activation_s.F90 +++ b/src/fiats/activation_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/double_precision_file_m.f90 b/src/fiats/double_precision_file_m.f90 index f62506a42..2cc2a214e 100644 --- a/src/fiats/double_precision_file_m.f90 +++ b/src/fiats/double_precision_file_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module double_precision_file_m use julienne_m, only : file_t, string_t diff --git a/src/fiats/double_precision_file_s.f90 b/src/fiats/double_precision_file_s.f90 index 620e95291..b34c11f54 100644 --- a/src/fiats/double_precision_file_s.f90 +++ b/src/fiats/double_precision_file_s.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt submodule(double_precision_file_m) double_precision_file_s implicit none diff --git a/src/fiats/double_precision_string_m.f90 b/src/fiats/double_precision_string_m.f90 index 01b2f19d2..2572451c3 100644 --- a/src/fiats/double_precision_string_m.f90 +++ b/src/fiats/double_precision_string_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module double_precision_string_m use julienne_m, only : string_t diff --git a/src/fiats/double_precision_string_s.f90 b/src/fiats/double_precision_string_s.f90 index b0cecd45c..8aa1710bb 100644 --- a/src/fiats/double_precision_string_s.f90 +++ b/src/fiats/double_precision_string_s.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt submodule(double_precision_string_m)double_precision_string_s implicit none diff --git a/src/fiats/hyperparameters_m.f90 b/src/fiats/hyperparameters_m.f90 index d7fc5c464..56134fec5 100644 --- a/src/fiats/hyperparameters_m.f90 +++ b/src/fiats/hyperparameters_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module hyperparameters_m use julienne_string_m, only : string_t diff --git a/src/fiats/hyperparameters_s.F90 b/src/fiats/hyperparameters_s.F90 index 277b06890..0038279f2 100644 --- a/src/fiats/hyperparameters_s.F90 +++ b/src/fiats/hyperparameters_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/input_output_pair_m.f90 b/src/fiats/input_output_pair_m.f90 index 047f2ba5c..6ad6f50e6 100644 --- a/src/fiats/input_output_pair_m.f90 +++ b/src/fiats/input_output_pair_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module input_output_pair_m use tensor_m, only : tensor_t diff --git a/src/fiats/input_output_pair_s.f90 b/src/fiats/input_output_pair_s.f90 index 92a960da8..a263aadff 100644 --- a/src/fiats/input_output_pair_s.f90 +++ b/src/fiats/input_output_pair_s.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt submodule(input_output_pair_m) input_output_pair_s implicit none diff --git a/src/fiats/kind_parameters_m.f90 b/src/fiats/kind_parameters_m.f90 index f312a66b6..05772500c 100644 --- a/src/fiats/kind_parameters_m.f90 +++ b/src/fiats/kind_parameters_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module kind_parameters_m implicit none diff --git a/src/fiats/layer_m.f90 b/src/fiats/layer_m.f90 index e877d397a..c8a0eb224 100644 --- a/src/fiats/layer_m.f90 +++ b/src/fiats/layer_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module layer_m use double_precision_string_m, only : double_precision_string_t diff --git a/src/fiats/layer_s.F90 b/src/fiats/layer_s.F90 index 0a368b605..7a9fbde55 100644 --- a/src/fiats/layer_s.F90 +++ b/src/fiats/layer_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/metadata_m.f90 b/src/fiats/metadata_m.f90 index a5d9df6c3..2247bce9f 100644 --- a/src/fiats/metadata_m.f90 +++ b/src/fiats/metadata_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module metadata_m use julienne_string_m, only : string_t diff --git a/src/fiats/metadata_s.F90 b/src/fiats/metadata_s.F90 index 842974cd9..cca0f9148 100644 --- a/src/fiats/metadata_s.F90 +++ b/src/fiats/metadata_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/mini_batch_m.f90 b/src/fiats/mini_batch_m.f90 index 7bb44d7cb..38c92ebf8 100644 --- a/src/fiats/mini_batch_m.f90 +++ b/src/fiats/mini_batch_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module mini_batch_m use input_output_pair_m, only : input_output_pair_t diff --git a/src/fiats/mini_batch_s.f90 b/src/fiats/mini_batch_s.f90 index e4f126505..e90f3a4c0 100644 --- a/src/fiats/mini_batch_s.f90 +++ b/src/fiats/mini_batch_s.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt submodule(mini_batch_m) mini_batch_s implicit none diff --git a/src/fiats/network_configuration_m.f90 b/src/fiats/network_configuration_m.f90 index 2822173bc..1d7371a42 100644 --- a/src/fiats/network_configuration_m.f90 +++ b/src/fiats/network_configuration_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module network_configuration_m use julienne_string_m, only : string_t diff --git a/src/fiats/network_configuration_s.F90 b/src/fiats/network_configuration_s.F90 index 867f9989d..789ad27df 100644 --- a/src/fiats/network_configuration_s.F90 +++ b/src/fiats/network_configuration_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/neural_network_m.f90 b/src/fiats/neural_network_m.f90 index 0b78067dd..21cef82af 100644 --- a/src/fiats/neural_network_m.f90 +++ b/src/fiats/neural_network_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module neural_network_m !! Define an abstraction that supports inference operations on a neural network diff --git a/src/fiats/neural_network_s.F90 b/src/fiats/neural_network_s.F90 index 9b0ca5c89..34f15cc0d 100644 --- a/src/fiats/neural_network_s.F90 +++ b/src/fiats/neural_network_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/neuron_m.f90 b/src/fiats/neuron_m.f90 index 45852606a..38e4dd2ff 100644 --- a/src/fiats/neuron_m.f90 +++ b/src/fiats/neuron_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module neuron_m use julienne_string_m, only : string_t diff --git a/src/fiats/neuron_s.F90 b/src/fiats/neuron_s.F90 index aba26b8ce..46d34e563 100644 --- a/src/fiats/neuron_s.F90 +++ b/src/fiats/neuron_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/tensor_m.f90 b/src/fiats/tensor_m.f90 index 425a899bb..a7e3a9e9c 100644 --- a/src/fiats/tensor_m.f90 +++ b/src/fiats/tensor_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module tensor_m use kind_parameters_m, only : default_real, double_precision diff --git a/src/fiats/tensor_map_m.f90 b/src/fiats/tensor_map_m.f90 index 1343343fb..5fc36d669 100644 --- a/src/fiats/tensor_map_m.f90 +++ b/src/fiats/tensor_map_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module tensor_map_m use tensor_m, only : tensor_t diff --git a/src/fiats/tensor_map_s.F90 b/src/fiats/tensor_map_s.F90 index 106b28773..d4ac6fbb9 100644 --- a/src/fiats/tensor_map_s.F90 +++ b/src/fiats/tensor_map_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/tensor_names_m.f90 b/src/fiats/tensor_names_m.f90 index b1c1a9723..69f912988 100644 --- a/src/fiats/tensor_names_m.f90 +++ b/src/fiats/tensor_names_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module tensor_names_m use julienne_string_m, only : string_t diff --git a/src/fiats/tensor_names_s.F90 b/src/fiats/tensor_names_s.F90 index c132e2d9d..02be58e68 100644 --- a/src/fiats/tensor_names_s.F90 +++ b/src/fiats/tensor_names_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/tensor_s.f90 b/src/fiats/tensor_s.f90 index c0cf3fbb3..44a9364e5 100644 --- a/src/fiats/tensor_s.f90 +++ b/src/fiats/tensor_s.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt submodule(tensor_m) tensor_s implicit none diff --git a/src/fiats/trainable_network_m.f90 b/src/fiats/trainable_network_m.f90 index 0deec7470..fc19daf29 100644 --- a/src/fiats/trainable_network_m.f90 +++ b/src/fiats/trainable_network_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module trainable_network_m diff --git a/src/fiats/trainable_network_s.F90 b/src/fiats/trainable_network_s.F90 index 58ec6986e..046e2b095 100644 --- a/src/fiats/trainable_network_s.F90 +++ b/src/fiats/trainable_network_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt submodule(trainable_network_m) trainable_network_s diff --git a/src/fiats/training_configuration_m.f90 b/src/fiats/training_configuration_m.f90 index 1dd66dbea..f16ecf9da 100644 --- a/src/fiats/training_configuration_m.f90 +++ b/src/fiats/training_configuration_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module training_configuration_m use activation_m, only : activation_t @@ -20,31 +20,31 @@ module training_configuration_m type(network_configuration_t), private :: network_configuration_ type(tensor_names_t), private :: tensor_names_ contains - generic :: operator(==) => default_real_equals , double_precision_equals - procedure, private :: default_real_equals , double_precision_equals - generic :: to_json => default_real_to_json , double_precision_to_json - procedure, private :: default_real_to_json , double_precision_to_json - generic :: mini_batches => default_real_mini_batches , double_precision_mini_batches - procedure, private :: default_real_mini_batches , double_precision_mini_batches - generic :: optimizer_name => default_real_optimizer_name , double_precision_optimizer_name - procedure, private :: default_real_optimizer_name , double_precision_optimizer_name - generic :: learning_rate => default_real_learning_rate , double_precision_learning_rate - procedure, private :: default_real_learning_rate , double_precision_learning_rate - generic :: activation => default_real_activation , double_precision_activation - procedure, private :: default_real_activation , double_precision_activation - generic :: nodes_per_layer => default_real_nodes_per_layer , double_precision_nodes_per_layer - procedure, private :: default_real_nodes_per_layer , double_precision_nodes_per_layer - generic :: skip_connections => default_real_skip_connections, double_precision_skip_connections - procedure, private :: default_real_skip_connections, double_precision_skip_connections - generic :: input_names => default_real_input_names , double_precision_input_names - procedure, private :: default_real_input_names , double_precision_input_names - generic :: output_names => default_real_output_names , double_precision_output_names - procedure, private :: default_real_output_names , double_precision_output_names + generic :: operator(==) => default_real_equals , double_precision_equals + procedure, private :: default_real_equals , double_precision_equals + generic :: to_json => default_real_to_json , double_precision_to_json + procedure, private :: default_real_to_json , double_precision_to_json + generic :: mini_batches => default_real_mini_batches , double_precision_mini_batches + procedure, private :: default_real_mini_batches , double_precision_mini_batches + generic :: optimizer_name => default_real_optimizer_name , double_precision_optimizer_name + procedure, private :: default_real_optimizer_name , double_precision_optimizer_name + generic :: learning_rate => default_real_learning_rate , double_precision_learning_rate + procedure, private :: default_real_learning_rate , double_precision_learning_rate + generic :: activation => default_real_activation , double_precision_activation + procedure, private :: default_real_activation , double_precision_activation + generic :: nodes_per_layer => default_real_nodes_per_layer , double_precision_nodes_per_layer + procedure, private :: default_real_nodes_per_layer , double_precision_nodes_per_layer + generic :: skip_connections => default_real_skip_connections , double_precision_skip_connections + procedure, private :: default_real_skip_connections , double_precision_skip_connections + generic :: input_variable_names => default_real_input_names , double_precision_input_names + procedure, private :: default_real_input_names , double_precision_input_names + generic :: output_variable_names => default_real_output_names, double_precision_output_names + procedure, private :: default_real_output_names, double_precision_output_names end type - interface training_configuration_t - module function default_real_from_components(hyperparameters, network_configuration, tensor_names) result(training_configuration) + pure module function default_real_from_components(hyperparameters, network_configuration, tensor_names) & + result(training_configuration) implicit none type(hyperparameters_t), intent(in) :: hyperparameters type(network_configuration_t), intent(in) :: network_configuration @@ -52,7 +52,8 @@ module function default_real_from_components(hyperparameters, network_configurat type(tensor_names_t), intent(in) :: tensor_names end function - module function double_precision_from_components(hyperparameters, network_configuration, tensor_names) result(training_configuration) + pure module function double_precision_from_components(hyperparameters, network_configuration, tensor_names) & + result(training_configuration) implicit none type(hyperparameters_t(double_precision)), intent(in) :: hyperparameters type(network_configuration_t), intent(in) :: network_configuration diff --git a/src/fiats/training_configuration_s.F90 b/src/fiats/training_configuration_s.F90 index 9044b93f5..112325401 100644 --- a/src/fiats/training_configuration_s.F90 +++ b/src/fiats/training_configuration_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt submodule(training_configuration_m) training_configuration_s use double_precision_string_m, only : double_precision_string_t @@ -45,48 +45,22 @@ end procedure module procedure default_real_from_file -#if defined _CRAYFTN - type(string_t), allocatable :: lines(:) -#endif - training_configuration%file_t = file_object -#if defined _CRAYFTN - lines = training_configuration%file_t%lines() -#else associate(lines => training_configuration%file_t%lines()) -#endif - training_configuration%hyperparameters_ = hyperparameters_t(lines) training_configuration%network_configuration_= network_configuration_t(lines) training_configuration%tensor_names_ = tensor_names_t(lines) - -#if ! defined _CRAYFTN end associate -#endif - end procedure module procedure double_precision_from_file -#if defined _CRAYFTN - type(double_precision_string_t), allocatable :: lines(:) -#endif - training_configuration%double_precision_file_t = file_object - -#if defined _CRAYFTN - lines = training_configuration%double_precision_file_t%double_precision_lines() -#else associate(lines => training_configuration%double_precision_file_t%double_precision_lines()) -#endif - training_configuration%hyperparameters_ = hyperparameters_t(lines) training_configuration%network_configuration_= network_configuration_t(lines) training_configuration%tensor_names_ = tensor_names_t(lines) - -#if ! defined _CRAYFTN end associate -#endif end procedure module procedure default_real_to_json @@ -152,12 +126,7 @@ end procedure module procedure default_real_activation -#if defined _CRAYFTN - type(string_t) :: activation_name - activation_name = self%network_configuration_%activation_name() -#else associate(activation_name => self%network_configuration_%activation_name()) -#endif select case(activation_name%string()) case ("gelu") activation = activation_t(gelu) @@ -170,18 +139,11 @@ case default error stop 'activation_factory_s(factory): unrecognized activation name "' // activation_name%string() // '"' end select -#if ! (defined _CRAYFTN) end associate -#endif end procedure module procedure double_precision_activation -#if defined _CRAYFTN - type(string_t) :: activation_name - activation_name = self%network_configuration_%activation_name() -#else associate(activation_name => self%network_configuration_%activation_name()) -#endif select case(activation_name%string()) case ("gelu") activation = activation_t(gelu) @@ -194,9 +156,7 @@ case default error stop 'activation_factory_s(factory): unrecognized activation name "' // activation_name%string() // '"' end select -#if ! (defined _CRAYFTN) end associate -#endif end procedure module procedure default_real_input_names diff --git a/src/fiats/training_data_files_m.f90 b/src/fiats/training_data_files_m.f90 new file mode 100644 index 000000000..a9df271d5 --- /dev/null +++ b/src/fiats/training_data_files_m.f90 @@ -0,0 +1,81 @@ +! Copyright (c) 2023-2025, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt +module training_data_files_m + use julienne_string_m, only : string_t + implicit none + + private + public :: training_data_files_t + + type training_data_files_t + private + character(len=:), allocatable :: path_, inputs_prefix_, outputs_prefix_ + type(string_t), allocatable :: infixes_(:) + contains + procedure :: to_json + procedure :: fully_qualified_inputs_files + procedure :: fully_qualified_outputs_files + procedure :: fully_qualified_time_file + procedure :: path + generic :: operator(==) => equals + procedure, private :: equals + end type + + interface training_data_files_t + + pure module function from_json(lines) result(training_data_files) + implicit none + class(string_t), intent(in) :: lines(:) + type(training_data_files_t) training_data_files + end function + + pure module function from_components(path, inputs_prefix, outputs_prefix, infixes) result(training_data_files) + implicit none + character(len=*), intent(in) :: path, inputs_prefix, outputs_prefix + type(string_t), intent(in) :: infixes(:) + type(training_data_files_t) training_data_files + end function + + end interface + + interface + + pure module function path(self) result(training_data_file_path) + implicit none + class(training_data_files_t), intent(in) :: self + character(len=:), allocatable :: training_data_file_path + end function + + elemental module function equals(lhs, rhs) result(lhs_eq_rhs) + implicit none + class(training_data_files_t), intent(in) :: lhs, rhs + logical lhs_eq_rhs + end function + + pure module function to_json(self) result(lines) + implicit none + class(training_data_files_t), intent(in) :: self + type(string_t), allocatable :: lines(:) + end function + + pure module function fully_qualified_inputs_files(self) result(names) + implicit none + class(training_data_files_t), intent(in) :: self + type(string_t), allocatable :: names(:) + end function + + pure module function fully_qualified_outputs_files(self) result(names) + implicit none + class(training_data_files_t), intent(in) :: self + type(string_t), allocatable :: names(:) + end function + + pure module function fully_qualified_time_file(self) result(name) + implicit none + class(training_data_files_t), intent(in) :: self + type(string_t) name + end function + + end interface + +end module diff --git a/src/fiats/training_data_files_s.F90 b/src/fiats/training_data_files_s.F90 new file mode 100644 index 000000000..fd2a83d2c --- /dev/null +++ b/src/fiats/training_data_files_s.F90 @@ -0,0 +1,85 @@ +! Copyright (c) 2023-2025, The Regents of the University of California +! Terms of use are as specified in LICENSE.txt + +#include "assert_macros.h" + +submodule(training_data_files_m) training_data_files_s + use assert_m + use julienne_m, only : operator(.csv.) + implicit none + + character(len=*), parameter :: training_data_files_key = "training data files" + character(len=*), parameter :: path_key = "path" + character(len=*), parameter :: inputs_prefix_key = "inputs prefix" + character(len=*), parameter :: outputs_prefix_key = "outputs prefix" + character(len=*), parameter :: infixes_key = "infixes" + character(len=*), parameter :: suffix = ".nc" + +contains + + module procedure path + training_data_file_path = self%path_ + end procedure + + module procedure fully_qualified_time_file + name = self%path_ // "/dt.json" + end procedure + + module procedure to_json + character(len=*), parameter :: indent = repeat(" ",ncopies=4) + + lines = [ & + string_t(indent // '"' //training_data_files_key // '": {' ) & + ,string_t(indent // indent // '"' // path_key // '" : "' // self%path_ // '",') & + ,string_t(indent // indent // '"' // inputs_prefix_key // '" : "' // self%inputs_prefix_ // '",') & + ,string_t(indent // indent // '"' // outputs_prefix_key // '" : "' // self%outputs_prefix_ // '",') & + , indent // indent // '"infixes" : [' // .csv. self%infixes_%bracket('"') // ']' & + ,string_t(indent // '}' ) & + ] + end procedure + + module procedure from_json + integer l + logical training_data_files_key_found + + training_data_files_key_found = .false. + + do l=1,size(lines) + if (lines(l)%get_json_key() == training_data_files_key) then + training_data_files_key_found = .true. + training_data_files%path_ = lines(l+1)%get_json_value(string_t(path_key), mold=string_t("")) + training_data_files%inputs_prefix_ = lines(l+2)%get_json_value(string_t(inputs_prefix_key), mold=string_t("")) + training_data_files%outputs_prefix_ = lines(l+3)%get_json_value(string_t(outputs_prefix_key), mold=string_t("")) + training_data_files%infixes_ = lines(l+4)%get_json_value(string_t(infixes_key), mold=[string_t("")]) + return + end if + end do + + call_assert(training_data_files_key_found) + end procedure + + module procedure from_components + training_data_files%path_ = path + training_data_files%inputs_prefix_ = inputs_prefix + training_data_files%outputs_prefix_ = outputs_prefix + training_data_files%infixes_ = infixes + end procedure + + module procedure equals + lhs_eq_rhs = lhs%path_ == rhs%path_ & + .and. lhs%inputs_prefix_ == rhs%inputs_prefix_ & + .and. lhs%outputs_prefix_ == rhs%outputs_prefix_ & + .and. all(lhs%infixes_ == rhs%infixes_) + end procedure + + module procedure fully_qualified_inputs_files + integer i + names = [(self%path_ // "/" // self%inputs_prefix_ //self%infixes_(i) // suffix, i=1, size(self%infixes_))] + end procedure + + module procedure fully_qualified_outputs_files + integer i + names = [(self%path_ // "/" // self%outputs_prefix_ //self%infixes_(i) // suffix, i=1, size(self%infixes_))] + end procedure + +end submodule training_data_files_s diff --git a/src/fiats/unmapped_network_s.F90 b/src/fiats/unmapped_network_s.F90 index 82b7ca5e2..f9dde8dad 100644 --- a/src/fiats/unmapped_network_s.F90 +++ b/src/fiats/unmapped_network_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-20225, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats/workspace_s.F90 b/src/fiats/workspace_s.F90 index 290b33957..d17513733 100644 --- a/src/fiats/workspace_s.F90 +++ b/src/fiats/workspace_s.F90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt #include "assert_macros.h" diff --git a/src/fiats_m.f90 b/src/fiats_m.f90 index b8ce8d625..bfc295338 100644 --- a/src/fiats_m.f90 +++ b/src/fiats_m.f90 @@ -1,4 +1,4 @@ -! Copyright (c), The Regents of the University of California +! Copyright (c) 2023-2025, The Regents of the University of California ! Terms of use are as specified in LICENSE.txt module fiats_m !! Specify the user-facing modules, derived types, and type parameters @@ -16,5 +16,6 @@ module fiats_m use tensor_names_m, only : tensor_names_t use trainable_network_m, only : trainable_network_t use training_configuration_m, only : training_configuration_t + use training_data_files_m, only : training_data_files_t implicit none end module fiats_m diff --git a/test/main.F90 b/test/main.F90 index 47e6fd78f..55982480b 100644 --- a/test/main.F90 +++ b/test/main.F90 @@ -14,6 +14,7 @@ program main use tensor_map_test_m, only : tensor_map_test_t use tensor_names_test_m, only : tensor_names_test_t use tensor_test_m, only : tensor_test_t + use training_data_files_test_m, only : training_data_files_test_t use julienne_m, only : command_line_t implicit none @@ -27,6 +28,7 @@ program main type(tensor_map_test_t) tensor_map_test type(tensor_names_test_t) tensor_names_test type(tensor_test_t) tensor_test + type(training_data_files_test_t) training_data_files_test real t_start, t_finish integer :: passes=0, tests=0 @@ -56,6 +58,7 @@ program main call asymmetric_network_test%report(passes, tests) call neural_network_test%report(passes, tests) call trainable_network_test%report(passes, tests) + call training_data_files_test%report(passes, tests) call cpu_time(t_finish) print * diff --git a/test/training_data_files_test_m.F90 b/test/training_data_files_test_m.F90 new file mode 100644 index 000000000..a62abe7dd --- /dev/null +++ b/test/training_data_files_test_m.F90 @@ -0,0 +1,73 @@ +! Copyright (c), The Regents of the University of California +! Terms of use are as specified in LICENSE.txt +module training_data_files_test_m + !! Test training_data_files_t object I/O and construction + + ! External dependencies + use fiats_m, only : training_data_files_t + use julienne_m, only : test_t, test_result_t, test_description_t, test_description_substring, string_t, file_t +#if ! defined(HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY) + use julienne_m, only : test_function_i +#endif + + ! Internal dependencies + use training_data_files_m, only : training_data_files_t + + implicit none + + private + public :: training_data_files_test_t + + type, extends(test_t) :: training_data_files_test_t + contains + procedure, nopass :: subject + procedure, nopass :: results + end type + +contains + + pure function subject() result(specimen) + character(len=:), allocatable :: specimen + specimen = "A training_data_files_t object" + end function + + function results() result(test_results) + type(test_description_t), allocatable :: test_descriptions(:) + type(test_result_t), allocatable :: test_results(:) + +#if defined(HAVE_PROCEDURE_ACTUAL_FOR_POINTER_DUMMY) + test_descriptions = [ & + test_description_t( string_t("round-trip to/from JSON yielding equivalent objects"), check_json_round_trip) & + ] +#else + procedure(test_function_i), pointer :: check_json_round_trip_ptr + check_json_round_trip_ptr => check_json_round_trip + + test_descriptions = [ & + test_description_t(string_t("round-trip to/from JSON yielding equivalent objects"), check_json_round_trip_ptr) & + ] +#endif + associate( & + substring_in_subject => index(subject(), test_description_substring) /= 0, & + substring_in_description => test_descriptions%contains_text(string_t(test_description_substring)) & + ) + test_descriptions = pack(test_descriptions, substring_in_subject .or. substring_in_description) + end associate + test_results = test_descriptions%run() + end function + + function check_json_round_trip() result(test_passes) + logical test_passes + associate(training_data_files => training_data_files_t( & + path = "dates-20101001-2011076" & + ,inputs_prefix = "training_input-image-" & + ,outputs_prefix = "training_output-image-" & + ,infixes = string_t(["000001", "000002", "000003", "000004", "000005", "000006", "000007", "000008", "000009", "000010"]) & + )) + associate(from_json => training_data_files_t(training_data_files%to_json())) + test_passes = training_data_files == from_json + end associate + end associate + end function + +end module training_data_files_test_m