feat(NetCDF_variable): generalize time derivatives

demo/app/train-cloud-microphysics.F90

@@ -22,13 +22,13 @@ program train_cloud_microphysics
   use NetCDF_variable_m, only: NetCDF_variable_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 train-cloud-microphysics -- \'                                              // new_line('a') // &
-    '  --base <string> --epochs <integer> \'                                                            // new_line('a') // &
+  character(len=*), parameter :: usage =                                                        new_line('a') // new_line('a') // &
+    'Usage: ' //                                                                                new_line('a') // new_line('a') // &
+    './build/run-fpm.sh run train-cloud-microphysics -- \'                                                    // new_line('a') // &
+    '  --base <string> --epochs <integer> \'                                                                  // new_line('a') // &
     '  [--start <integer>] [--end <integer>] [--stride <integer>] [--bins <integer>] [--report <integer>] [--tolerance <real>]'// &
-                                                                                          new_line('a') // new_line('a') // &
-    'where angular brackets denote user-provided values and square brackets denote optional arguments.' // new_line('a') // &
+                                                                                                new_line('a') // new_line('a') // &
+    'where angular brackets denote user-provided values and square brackets denote optional arguments.'       // new_line('a') // &
     'The presence of a file named "stop" halts execution gracefully.'
 
   type command_line_arguments_t 
@@ -249,20 +249,26 @@ subroutine read_train_write(training_configuration, args, plot_file)
 
         end associate
       end associate
-    end associate
 
-    block
-      type(NetCDF_variable_t) derivative(size(output_variable))
-    end block
+      block
+        type(NetCDF_variable_t) derivative(size(output_variable))
+
+        print *,"Calculating time derivatives"
+
+        associate(dt => NetCDF_variable_t(output_time - input_time, "dt"))
+          do v = 1, size(derivative)
+            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)
+            end associate
+          end do
+        end associate
+      end block
+
+    end associate
 
     !t_end = size(time_in)
 
-    !allocate(dpt_dt, mold = potential_temperature_out)
-    !allocate(dqv_dt, mold = qv_out)
-    !allocate(dqc_dt, mold = qc_out)
-    !allocate(dqr_dt, mold = qr_out)
-    !allocate(dqs_dt, mold = qs_out)
-
     !associate(dt => real(time_out - time_in))
     !  do concurrent(t = 1:t_end)
     !    dpt_dt(:,:,:,t) = (potential_temperature_out(:,:,:,t) - potential_temperature_in(:,:,:,t))/dt(t)

demo/src/NetCDF_variable_m.f90

@@ -23,8 +23,44 @@ module NetCDF_variable_m
     procedure, private, non_overridable :: default_real_rank, double_precision_rank
     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
   end type
 
+  interface NetCDF_variable_t
+
+    elemental module function default_real_copy(source, rename) result(NetCDF_variable)
+      implicit none
+      type(NetCDF_variable_t), intent(in) :: source
+      type(string_t), intent(in), optional :: rename
+      type(NetCDF_variable_t) NetCDF_variable
+    end function
+
+    elemental module function default_real_copy_character_name(source, rename) result(NetCDF_variable)
+      implicit none
+      type(NetCDF_variable_t), intent(in) :: source
+      character(len=*), intent(in), optional :: rename
+      type(NetCDF_variable_t) NetCDF_variable
+    end function
+
+    elemental module function double_precision_copy(source, rename) result(NetCDF_variable)
+      implicit none
+      type(NetCDF_variable_t(double_precision)), intent(in) :: source
+      type(string_t), intent(in), optional :: rename
+      type(NetCDF_variable_t(double_precision)) NetCDF_variable
+    end function
+
+    elemental module function double_precision_copy_character_name(source, rename) result(NetCDF_variable)
+      implicit none
+      type(NetCDF_variable_t(double_precision)), intent(in) :: source
+      character(len=*), intent(in), optional :: rename
+      type(NetCDF_variable_t(double_precision)) NetCDF_variable
+    end function
+
+  end interface
+
   interface
 
     impure elemental module subroutine default_real_input(self, variable_name, file, rank)
@@ -92,9 +128,33 @@ elemental module function default_real_subtract(lhs, rhs) result(difference)
     elemental module function double_precision_subtract(lhs, rhs) result(difference)
       implicit none
       class(NetCDF_variable_t(double_precision)), intent(in) :: lhs, rhs
-      type(NetCDF_variable_t) 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
+
   end interface
 
 end module 

demo/src/NetCDF_variable_s.f90

@@ -22,6 +22,60 @@
 
 contains
 
+  module procedure default_real_copy
+
+    if (present(rename)) then
+      NetCDF_variable%name_ = rename
+    else
+      NetCDF_variable%name_ = source%name_
+    end if
+
+    select case(source%rank())
+    case (1)
+      NetCDF_variable%values_1D_ = source%values_1D_
+    case (2)
+      NetCDF_variable%values_2D_ = source%values_2D_
+    case (3)
+      NetCDF_variable%values_3D_ = source%values_3D_
+    case (4)
+      NetCDF_variable%values_4D_ = source%values_4D_
+    case default
+      error stop 'NetCDF_variable_s(default_real_copy): unsupported rank'
+    end select 
+
+  end procedure
+
+  module procedure default_real_copy_character_name
+    NetCDF_variable = default_real_copy(source, string_t(rename))
+  end procedure
+
+  module procedure double_precision_copy
+
+    if (present(rename)) then
+      NetCDF_variable%name_ = rename
+    else
+      NetCDF_variable%name_ = source%name_
+    end if
+
+    select case(source%rank())
+    case (1)
+      NetCDF_variable%values_1D_ = source%values_1D_
+    case (2)
+      NetCDF_variable%values_2D_ = source%values_2D_
+    case (3)
+      NetCDF_variable%values_3D_ = source%values_3D_
+    case (4)
+      NetCDF_variable%values_4D_ = source%values_4D_
+    case default
+      error stop 'NetCDF_variable_s(double_precision_copy): unsupported rank'
+    end select 
+
+  end procedure
+
+  module procedure double_precision_copy_character_name
+    NetCDF_variable = double_precision_copy(source, string_t(rename))
+  end procedure
+
   module procedure default_real_input
     self%name_ = variable_name
     select case (rank)
@@ -206,4 +260,88 @@ 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, "NetCDF_variable_s(default_real_divide): rhs%rank()==1")
+
+    associate(t_end => size(rhs%values_1D_))
+
+      select case(lhs%rank())
+      case(4)
+
+        call assert(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, "NetCDF_variable_s(double_precision_divide): rhs%rank()==1")
+
+    associate(t_end => size(rhs%values_1D_))
+
+      select case(lhs%rank())
+      case(4)
+
+        call assert(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(), "NetCDF_variable_s(default_real_assign): ranks match)")
+  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(), "NetCDF_variable_s(double_precision_assign): ranks match)")
+  end procedure
+
 end submodule NetCDF_variable_s