Changeset 4444 for LMDZ6/branches

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/easy_netcdf.F90

-                      r3908
+                      r4444
   ! a NetCDF file
   type netcdf_file
     integer :: ncid             ! NetCDF file ID
+    integer :: ncid = -1! NetCDF file ID
     integer :: iverbose ! Verbosity: 0 = report only fatal errors,
                         !            1 = ...and warnings,
 …
     procedure :: create => create_netcdf_file
     procedure :: close => close_netcdf_file
+    procedure :: is_open
     procedure :: get_real_scalar
+    procedure :: get_int_scalar
     procedure :: get_real_vector
     procedure :: get_integer_vector
+    procedure :: get_int_vector
     procedure :: get_real_matrix
     procedure :: get_real_array3
 …
     procedure :: get_real_array3_indexed
     procedure :: get_real_array4
+    generic   :: get => get_real_scalar, get_real_vector, &
+    procedure :: get_char_vector
+    procedure :: get_char_matrix
+    generic   :: get => get_real_scalar, get_int_scalar, &
+         &              get_real_vector, get_int_vector, &
          &              get_real_matrix, get_real_array3, &
          &              get_real_array4, get_integer_vector, &
+         &              get_real_array4, &
          &              get_real_scalar_indexed, get_real_vector_indexed, &
+         &              get_real_matrix_indexed, get_real_array3_indexed
+         &              get_real_matrix_indexed, get_real_array3_indexed, &
+         &              get_char_vector, get_char_matrix
     procedure :: get_real_scalar_attribute
     procedure :: get_string_attribute
 …
     procedure :: put_real_scalar
     procedure :: put_real_vector
+    procedure :: put_int_vector
     procedure :: put_real_matrix
     procedure :: put_real_array3
 …
          &              put_real_matrix, put_real_array3, &
          &              put_real_scalar_indexed, put_real_vector_indexed, &
          &              put_real_matrix_indexed
+         &              put_real_matrix_indexed, put_int_vector
     procedure :: set_verbose
     procedure :: transpose_matrices
 …
     procedure :: attribute_exists
     procedure :: global_attribute_exists
+#ifdef NC_NETCDF4
+    procedure :: copy_dimensions
+#endif
+    procedure :: copy_variable_definition
+    procedure :: copy_variable
     procedure, private :: get_array_dimensions
     procedure, private :: get_variable_id
 …
     end if
+    this%ncid = -1
   end subroutine close_netcdf_file
 …
     integer                        :: j, istatus
     integer                        :: dimids(NF90_MAX_VAR_DIMS)
+    integer                        :: idimids(NF90_MAX_VAR_DIMS)
     istatus = nf90_inquire_variable(this%ncid, ivarid, &
          &                          ndims=ndims, dimids=dimids)
+         &                          ndims=ndims, dimids=idimids)
     if (istatus /= NF90_NOERR) then
       write(nulerr,'(a,i0,a,a)') '*** Error inquiring about NetCDF variable with id ', &
 …
     ndimlens(:) = 0
     do j = 1,ndims
       istatus = nf90_inquire_dimension(this%ncid, dimids(j), len=ndimlens(j))
+      istatus = nf90_inquire_dimension(this%ncid, idimids(j), len=ndimlens(j))
       if (istatus /= NF90_NOERR) then
         write(nulerr,'(a,i0,a,i0,a,a)') '*** Error reading length of dimension ', &
 …
   !---------------------------------------------------------------------
+  ! Return true if file is open, false otherwise
+  function is_open(this)
+    class(netcdf_file) :: this
+    logical            :: is_open
+    is_open = (this%ncid >= 0)
+  end function is_open
+  !---------------------------------------------------------------------
   ! Return the number of dimensions of variable with name var_name, or
   ! -1 if the variable is not found
 …
   !---------------------------------------------------------------------
+  ! Read an integer scalar
+  subroutine get_int_scalar(this, var_name, scalar)
+    class(netcdf_file)           :: this
+    character(len=*), intent(in) :: var_name
+    integer,          intent(out):: scalar
+    integer                      :: istatus
+    integer                      :: ivarid, ndims
+    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
+    integer                      :: j, ntotal
+    ! Inquire the ID, shape & size of the variable
+    call this%get_variable_id(var_name, ivarid)
+    call this%get_array_dimensions(ivarid, ndims, ndimlens)
+    ! Compute number of elements of the variable in the file
+    ntotal = 1
+    do j = 1, ndims
+      ntotal = ntotal * ndimlens(j)
+    end do
+    if (this%iverbose >= 3) then
+      write(nulout,'(a,a)',advance='no') '  Reading ', var_name
+      call this%print_variable_attributes(ivarid,nulout)
+    end if
+    ! Abort if the number of elements is anything other than 1
+    if (ntotal /= 1) then
+      write(nulerr,'(a,a,a,i0,a)') '*** Error reading NetCDF variable ', &
+           &    var_name, ' with total length ', ntotal, ' as a scalar'
+      call my_abort('Error reading NetCDF file')
+    end if
+    ! Read variable
+    istatus = nf90_get_var(this%ncid, ivarid, scalar)
+    if (istatus /= NF90_NOERR) then
+      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
+           &  var_name, ' as a scalar: ', trim(nf90_strerror(istatus))
+      call my_abort('Error reading NetCDF file')
+    end if
+  end subroutine get_int_scalar
+  !---------------------------------------------------------------------
   ! Read a scalar from a larger array, where "index" indexes the most
   ! slowly varying dimension
   subroutine get_real_scalar_indexed(this, var_name, index, scalar)
+  subroutine get_real_scalar_indexed(this, var_name, scalar, index)
     class(netcdf_file)           :: this
     character(len=*), intent(in) :: var_name
 …
   !---------------------------------------------------------------------
   ! Read a 1D array into "vector", which must be allocatable and will
   ! be reallocated if necessary
+  ! Read a 1D real array into "vector", which must be allocatable and
+  ! will be reallocated if necessary
   subroutine get_real_vector(this, var_name, vector)
     class(netcdf_file)           :: this
 …
   !---------------------------------------------------------------------
   ! Read a 1D integer array into "vector", which must be allocatable
+  ! Read a 1D character array into "vector", which must be allocatable
   ! and will be reallocated if necessary
   subroutine get_integer_vector(this, var_name, vector)
+  subroutine get_char_vector(this, var_name, vector)
     class(netcdf_file)           :: this
     character(len=*), intent(in) :: var_name
     integer, allocatable, intent(out) :: vector(:)
+    character(len=1), allocatable, intent(out) :: vector(:)
     integer                      :: n  ! Length of vector
 …
     if (istatus /= NF90_NOERR) then
       write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
+           &  var_name, ' as a vector of chars: ', trim(nf90_strerror(istatus))
+      call my_abort('Error reading NetCDF file')
+    end if
+  end subroutine get_char_vector
+  !---------------------------------------------------------------------
+  ! Read a 1D integer array into "vector", which must be allocatable
+  ! and will be reallocated if necessary
+  subroutine get_int_vector(this, var_name, vector)
+    class(netcdf_file)           :: this
+    character(len=*), intent(in) :: var_name
+    integer, allocatable, intent(out) :: vector(:)
+    integer                      :: n  ! Length of vector
+    integer                      :: istatus
+    integer                      :: ivarid, ndims
+    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
+    integer                      :: j
+    call this%get_variable_id(var_name, ivarid)
+    call this%get_array_dimensions(ivarid, ndims, ndimlens)
+    ! Ensure variable has only one dimension in the file
+    n = 1
+    do j = 1, ndims
+      n = n * ndimlens(j)
+      if (j > 1 .and. ndimlens(j) > 1) then
+        write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', &
+             & var_name, &
+             & ' as a vector: all dimensions above the first must be singletons'
+        call my_abort('Error reading NetCDF file')
+      end if
+    end do
+    ! Reallocate if necessary
+    if (allocated(vector)) then
+      if (size(vector) /= n) then
+        if (this%iverbose >= 1) then
+          write(nulout,'(a,a)') '  Warning: resizing vector to read ', var_name
+        end if
+        deallocate(vector)
+        allocate(vector(n))
+      end if
+    else
+      allocate(vector(n))
+    end if
+    if (this%iverbose >= 3) then
+      write(nulout,'(a,a,a,i0,a)',advance='no') '  Reading ', var_name, '(', n, ')'
+      call this%print_variable_attributes(ivarid,nulout)
+    end if
+    ! Read variable
+    istatus = nf90_get_var(this%ncid, ivarid, vector)
+    if (istatus /= NF90_NOERR) then
+      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
            &  var_name, ' as an integer vector: ', trim(nf90_strerror(istatus))
       call my_abort('Error reading NetCDF file')
     end if
+  end subroutine get_integer_vector
+  end subroutine get_int_vector
   !---------------------------------------------------------------------
   ! Read a vector of data from a larger array; the vector must be
   ! allocatable and will be reallocated if necessary
   subroutine get_real_vector_indexed(this, var_name, index, vector)
+  subroutine get_real_vector_indexed(this, var_name, vector, index)
     class(netcdf_file)           :: this
     character(len=*), intent(in) :: var_name
 …
   !---------------------------------------------------------------------
+  ! Read 2D array of characters into "matrix", which must be
+  ! allocatable and will be reallocated if necessary.  Whether to
+  ! transpose is specifed by the final optional argument, but can also
+  ! be specified by the do_transpose_2d class data member.
+  subroutine get_char_matrix(this, var_name, matrix, do_transp)
+    class(netcdf_file)           :: this
+    character(len=*), intent(in) :: var_name
+    character(len=1), allocatable, intent(inout) :: matrix(:,:)
+    logical, optional, intent(in):: do_transp ! Transpose data?
+    character(len=1), allocatable:: tmp_matrix(:,:)
+    integer                      :: ndimlen1, ndimlen2
+    integer                      :: istatus
+    integer                      :: ivarid, ndims
+    integer                      :: ndimlens(NF90_MAX_VAR_DIMS)
+    integer                      :: vstart(NF90_MAX_VAR_DIMS)
+    integer                      :: vcount(NF90_MAX_VAR_DIMS)
+    integer                      :: j, ntotal
+    logical                      :: do_transpose
+    ! Decide whether to transpose the array
+    if (present(do_transp)) then
+      do_transpose = do_transp
+    else
+      do_transpose = this%do_transpose_2d
+    end if
+    call this%get_variable_id(var_name, ivarid)
+    call this%get_array_dimensions(ivarid, ndims, ndimlens)
+    ! Ensure the variable has no more than two non-singleton
+    ! dimensions
+    ntotal = 1
+    do j = 1, ndims
+      ntotal = ntotal * ndimlens(j)
+      if (j > 2 .and. ndimlens(j) > 1) then
+        write(nulerr,'(a,a,a)') '*** Error reading NetCDF variable ', &
+           & var_name, &
+           & ' as a matrix: all dimensions above the second must be singletons'
+        call my_abort('Error reading NetCDF file')
+      end if
+    end do
+    ! Work out dimension lengths
+    if (ndims >= 2) then
+      ndimlen1 = ndimlens(1)
+      ndimlen2 = ntotal/ndimlen1
+    else
+      ndimlen1 = ntotal
+      ndimlen2 = 1
+    end if
+    if (do_transpose) then
+      ! Read and transpose
+      allocate(tmp_matrix(ndimlen1, ndimlen2))
+      ! Reallocate if necessary
+      if (allocated(matrix)) then
+        if (size(matrix,1) /= ndimlen2 .or. size(matrix,2) /= ndimlen1) then
+          if (this%iverbose >= 1) then
+            write(nulout,'(a,a)') '  Warning: resizing matrix to read ', var_name
+          end if
+          deallocate(matrix)
+          allocate(matrix(ndimlen2, ndimlen1))
+        end if
+      else
+        allocate(matrix(ndimlen2, ndimlen1))
+      end if
+      if (this%iverbose >= 3) then
+        write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') '  Reading ', var_name, '(', &
+             &                            ndimlen2, ',', ndimlen1, ')'
+        call this%print_variable_attributes(ivarid,nulout)
+      end if
+      istatus = nf90_get_var(this%ncid, ivarid, tmp_matrix)
+      matrix = transpose(tmp_matrix)
+      deallocate(tmp_matrix)
+    else
+      ! Read data without transposition
+      ! Reallocate if necessary
+      if (allocated(matrix)) then
+        if (size(matrix,1) /= ndimlen1 .or. size(matrix,2) /= ndimlen2) then
+          if (this%iverbose >= 1) then
+            write(nulout,'(a,a)') '  Warning: resizing matrix to read ', var_name
+          end if
+          allocate(matrix(ndimlen1, ndimlen2))
+        end if
+      else
+        allocate(matrix(ndimlen1, ndimlen2))
+      end if
+      if (this%iverbose >= 3) then
+        write(nulout,'(a,a,a,i0,a,i0,a)',advance='no') '  Reading ', var_name, '(', &
+             &                            ndimlen1, ',', ndimlen2, ')'
+        call this%print_variable_attributes(ivarid,nulout)
+      end if
+      vstart = 1
+      vcount(1:2) = [ndimlen1,1]
+      do j = 1,ndimlen2
+        vstart(2) = j
+        istatus = nf90_get_var(this%ncid, ivarid, matrix(:,j), start=vstart, count=vcount)
+      end do
+    end if
+    if (istatus /= NF90_NOERR) then
+      write(nulerr,'(a,a,a,a)') '*** Error reading NetCDF variable ', &
+           &    var_name, ' as a matrix of characters: ', trim(nf90_strerror(istatus))
+      call my_abort('Error reading NetCDF file')
+    end if
+  end subroutine get_char_matrix
+  !---------------------------------------------------------------------
   ! Read matrix of data from a larger array, which must be allocatable
   ! and will be reallocated if necessary.  Whether to transpose is
   ! specifed by the final optional argument, but can also be specified
   ! by the do_transpose_2d class data member.
   subroutine get_real_matrix_indexed(this, var_name, index, matrix, do_transp)
+  subroutine get_real_matrix_indexed(this, var_name, matrix, index, do_transp)
     class(netcdf_file)           :: this
     character(len=*), intent(in) :: var_name
 …
       if (this%iverbose >= 3) then
         write(nulout,'(a,a,a,i0,i0,i0,a)',advance='no') '  Reading ', var_name, &
              & ' (permuted dimensions ', i_permute_3d, ')'
+             & ' (permuting dimensions ', i_permute_3d, ')'
         call this%print_variable_attributes(ivarid,nulout)
       end if
 …
   ! be allocatable and will be reallocated if necessary.  Whether to
   ! pemute is specifed by the final optional argument
   subroutine get_real_array3_indexed(this, var_name, index, var, ipermute)
+  subroutine get_real_array3_indexed(this, var_name, var, index, ipermute)
     class(netcdf_file)                   :: this
     character(len=*), intent(in)         :: var_name
 …
         write(nulout,'(a,i0,a,a,a,i0,i0,i0,a)') '  Reading slice ', index, &
              &  ' of ', var_name, &
              & ' (permuted dimensions ', i_permute_3d, ')'
+             & ' (permuting dimensions ', i_permute_3d, ')'
       end if
 …
       if (this%iverbose >= 3) then
         write(nulout,'(a,a,a,i0,i0,i0,a)',advance='no') '  Reading ', var_name, &
              & ' (permuted dimensions ', i_permute_4d, ')'
+             & ' (permuting dimensions ', i_permute_4d, ')'
         call this%print_variable_attributes(ivarid,nulout)
       end if
 …
     !    allocate(character(len=i_attr_len) :: attr_str)
     if (len(attr_str) < i_attr_len) then
       write(nulerr,'(a,a)') '*** Error: not enough space to read attribute ', attr_name
+      write(nulerr,'(a,a)') '*** Not enough space to read attribute ', attr_name
       call my_abort('Error reading NetCDF file')
     end if
 …
     real(jprb),       intent(out) :: attr
     integer :: i_attr_len, ivarid
+    integer :: ivarid
     integer :: istatus
-    integer :: j
     istatus = nf90_inq_varid(this%ncid, var_name, ivarid)
 …
     !    allocate(character(len=i_attr_len) :: attr_str)
     if (len(attr_str) < i_attr_len) then
       write(nulerr,'(a,a)') '*** Error: not enough space to read global attribute ', attr_name
+      write(nulerr,'(a,a)') '*** Not enough space to read global attribute ', attr_name
       call my_abort('Error reading NetCDF file')
     end if
 …
     character(len=4000) :: attr_str
-    integer :: i_attr_len
     integer :: istatus
-    integer :: j
     if (this%iverbose >= 4) then
       istatus = nf90_get_att(this%ncid, ivarid, 'long_name', attr_str)
       if (istatus == NF90_NOERR) then
+        write(iunit, '(a)') ':'
+        write(iunit, '(a,a)', advance='no') '    ', trim(attr_str)
+        write(iunit, '(a,a,a)', advance='no') ': "', trim(attr_str), '"'
         istatus = nf90_get_att(this%ncid, ivarid, 'units', attr_str)
         if (istatus == NF90_NOERR) then
 …
   ! names.
   subroutine define_variable(this, var_name, dim1_name, dim2_name, dim3_name, &
+       &                     long_name, units_str, comment_str, standard_name, is_double, &
+       &                     data_type_name, fill_value, deflate_level, shuffle, chunksizes)
+       &                     dim4_name, long_name, units_str, comment_str, &
+       &                     standard_name, is_double, data_type_name, fill_value, &
+       &                     deflate_level, shuffle, chunksizes, ndims)
     class(netcdf_file)                     :: this
     character(len=*), intent(in)           :: var_name
     character(len=*), intent(in), optional :: long_name, units_str, comment_str, standard_name
     character(len=*), intent(in), optional :: dim1_name, dim2_name, dim3_name
+    character(len=*), intent(in), optional :: dim1_name, dim2_name, dim3_name, dim4_name
     logical,          intent(in), optional :: is_double
     character(len=*), intent(in), optional :: data_type_name
 …
     logical,          intent(in), optional :: shuffle ! Shuffle bytes before compression
     integer, dimension(:), intent(in), optional :: chunksizes
+    integer :: istatus, ndims, ivarid
+    integer,          intent(in), optional :: ndims
+    integer :: istatus, ndims_local, ndims_input, ivarid
     integer, dimension(NF90_MAX_VAR_DIMS) :: idimids
     integer :: data_type
+    if (present(dim1_name)) then
+    ! Sometimes a program may not know at compile time the exact
+    ! dimensions of a variable - if ndims is present then only up to
+    ! that many dimensions will be defined
+    ndims_input = 4
+    if (present(ndims)) then
+      ndims_input = ndims
+    end if
+    if (present(dim1_name) .and. ndims_input >= 1) then
       ! Variable is at least one dimensional
       ndims = 1
+      ndims_local = 1
       istatus = nf90_inq_dimid(this%ncid, dim1_name, idimids(1))
       if (istatus /= NF90_NOERR) then
 …
         call my_abort('Error writing NetCDF file')
       end if
       if (present(dim2_name)) then
+      if (present(dim2_name) .and. ndims_input >= 2) then
         ! Variable is at least two dimensional
         ndims = 2
+        ndims_local = 2
         istatus = nf90_inq_dimid(this%ncid, dim2_name, idimids(2))
         if (istatus /= NF90_NOERR) then
 …
           call my_abort('Error writing NetCDF file')
         end if
         if (present(dim3_name)) then
+        if (present(dim3_name) .and. ndims_input >= 3) then
           ! Variable is at least three dimensional
           ndims = 3
+          ndims_local = 3
           istatus = nf90_inq_dimid(this%ncid, dim3_name, idimids(3))
           if (istatus /= NF90_NOERR) then
 …
             call my_abort('Error writing NetCDF file')
           end if
+          if (present(dim4_name) .and. ndims_input >= 4) then
+            ! Variable is at least three dimensional
+            ndims_local = 4
+            istatus = nf90_inq_dimid(this%ncid, dim4_name, idimids(4))
+            if (istatus /= NF90_NOERR) then
+              write(nulerr,'(a,a,a,a)') '*** Error inquiring ID of dimension ', &
+                   &             dim4_name, ': ', trim(nf90_strerror(istatus))
+              call my_abort('Error writing NetCDF file')
+            end if
+          end if
         end if
       end if
     else
       ! Variable is a scalar
       ndims = 0
+      ndims_local = 0
     end if
     ! Read output precision from optional argument "is_double" if
     ! present, otherwise from default output precision for this file
-    data_type = NF90_FLOAT ! Default
     if (present(data_type_name)) then
       if (data_type_name == 'double') then
 …
         data_type = NF90_FLOAT
       else
         write(nulerr,'(a,a,a)') '*** Error: netCDF data type "', data_type_name, '" not supported'
+        write(nulerr,'(a,a,a)') '*** NetCDF data type "', data_type_name, '" not supported'
         call my_abort('Error writing NetCDF file')
       end if
     else if (present(is_double)) then
+      if (is_double) then
+        data_type = NF90_DOUBLE
+      else
+        data_type = NF90_FLOAT
+      end if
+    else if (this%is_double_precision) then
       data_type = NF90_DOUBLE
+    else
+      data_type = NF90_FLOAT
     end if
     ! Define variable
 #ifdef NC_NETCDF4
     istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims), &
+    istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims_local), &
          & ivarid, deflate_level=deflate_level, shuffle=shuffle, chunksizes=chunksizes)
 #else
     istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims), ivarid)
+    istatus = nf90_def_var(this%ncid, var_name, data_type, idimids(1:ndims_local), ivarid)
 #endif
     if (istatus /= NF90_NOERR) then
 …
       istatus = nf90_put_att(this%ncid, ivarid, "long_name", long_name)
       if (this%iverbose >= 4) then
+        write(nulout,'(a,a,a,a)') '  Defining ',trim(var_name),': ',long_name
+        write(nulout,'(a,a,a,a,a)', advance='no') '  Defining ',trim(var_name), &
+             &  ': "', long_name, '"'
       end if
     else
       if (this%iverbose >= 4) then
+        write(nulout,'(a,a)') '  Defining ',trim(var_name)
+      end if
+    end if
+        write(nulout,'(a,a)', advance='no') '  Defining ',trim(var_name)
+      end if
+    end if
     if (present(units_str)) then
       istatus = nf90_put_att(this%ncid, ivarid, "units", units_str)
+    end if
+      if (this%iverbose >= 4) then
+        if (trim(units_str) == '1') then
+          write(nulout, '(a)') ' (dimensionless)'
+        else
+          write(nulout, '(a,a,a)') ' (', trim(units_str), ')'
+        end if
+      end if
+    else
+      if (this%iverbose >= 4) then
+        write(nulout, '(1x)')
+      end if
+    end if
     if (present(standard_name)) then
       istatus = nf90_put_att(this%ncid, ivarid, "standard_name", standard_name)
 …
   subroutine put_global_attributes(this, title_str, inst_str, source_str, &
        &  comment_str, references_str, creator_name, creator_email_str, &
        &  contributor_name, project_str, conventions_str)
+       &  contributor_name, project_str, conventions_str, prior_history_str)
     class(netcdf_file)                     :: this
 …
     character(len=*), intent(in), optional :: contributor_name, project_str
     character(len=*), intent(in), optional :: comment_str, conventions_str
     character(len=*), intent(in), optional :: references_str
+    character(len=*), intent(in), optional :: references_str, prior_history_str
     character(len=32)   :: date_time_str
 …
          &   time_vals(1), time_vals(2), time_vals(3), time_vals(5), time_vals(6), time_vals(7)
+    history_str = trim(date_time_str) // ': ' // trim(command_line_str)
+    if (present(prior_history_str)) then
+      history_str = trim(prior_history_str) // new_line('a') &
+           &  // trim(date_time_str) // ': ' // trim(command_line_str)
+    else
+      history_str = trim(date_time_str) // ': ' // trim(command_line_str)
+    end if
     if (present(title_str))   i=nf90_put_att(this%ncid, NF90_GLOBAL, "title", title_str)
 …
   !---------------------------------------------------------------------
+  ! Save an integer vector with name var_name in the file
+  subroutine put_int_vector(this, var_name, var)
+    class(netcdf_file)             :: this
+    character(len=*), intent(in)   :: var_name
+    integer,          intent(in)   :: var(:)
+    integer :: ivarid, ndims, istatus
+    integer(kind=jpib) :: ntotal
+    integer :: ndimlens(NF90_MAX_VAR_DIMS)
+    call this%end_define_mode()
+    ! Check the vector is of the right length
+    call this%get_variable_id(var_name, ivarid)
+    call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal)
+    if (ntotal /= size(var,kind=jpib)) then
+      write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector of length ', &
+           & size(var), ' to ', var_name, ' which has total length ', ntotal
+      call my_abort('Error writing NetCDF file')
+    end if
+    ! Save the vector
+    istatus = nf90_put_var(this%ncid, ivarid, var)
+    if (istatus /= NF90_NOERR) then
+      write(nulerr,'(a,a,a,a)') '*** Error writing vector ', var_name, ': ', &
+           &                    trim(nf90_strerror(istatus))
+      call my_abort('Error writing NetCDF file')
+    end if
+  end subroutine put_int_vector
+  !---------------------------------------------------------------------
   ! Save a vector slice with name var_name in the file
   subroutine put_real_vector_indexed(this, var_name, index, var)
+  subroutine put_real_vector_indexed(this, var_name, var, index2, index3)
     class(netcdf_file)             :: this
     character(len=*), intent(in)   :: var_name
     real(jprb), intent(in)         :: var(:)
+    integer, intent(in)            :: index
+    integer, intent(in)            :: index2
+    integer, intent(in), optional  :: index3
     integer :: ivarid, ndims, istatus
 …
     integer :: vcount(NF90_MAX_VAR_DIMS)
+    character(len=512) :: var_slice_name
+    integer :: index_last
     call this%end_define_mode()
 …
     call this%get_array_dimensions(ivarid, ndims, ndimlens, ntotal)
     ntotal = ntotal / ndimlens(ndims)
+    if (present(index3)) then
+      ntotal = ntotal / ndimlens(ndims-1)
+      index_last = index3
+      write(var_slice_name,'(a,a,i0,a,i0,a)') var_name, '(:,', index2, ',', index3, ')'
+    else
+      index_last = index2
+      write(var_slice_name,'(a,a,i0,a)') var_name, '(:,', index2, ')'
+    end if
     if (ntotal /= size(var,kind=jpib)) then
       write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector of length ', &
            & size(var), ' to slice of ', var_name, ' which has length ', ntotal
+      write(nulerr,'(a,i0,a,a,i0)') '*** Error: attempt to write vector of length ', &
+           & size(var), ' to ', trim(var_slice_name), ' which has length ', ntotal
       call my_abort('Error writing NetCDF file')
     end if
     if (index < 1 .or. index > ndimlens(ndims)) then
       write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write vector to slice ', &
            &  index, ' of ', var_name, ' which has outer dimension  ', ndimlens(ndims)
+    if (index_last < 1 .or. index_last > ndimlens(ndims)) then
+      write(nulerr,'(a,a,a,i0)') '*** Error: attempt to write vector to ', &
+           &  trim(var_slice_name), ' which has outer dimension  ', ndimlens(ndims)
       call my_abort('Error writing NetCDF file')
     end if
 …
     ! Save the vector
     vstart(1:ndims-1) = 1
-    vstart(ndims)     = index
     vcount(1:ndims-1) = ndimlens(1:ndims-1)
     vcount(ndims)     = 1
+    if (present(index3)) then
+      vstart(ndims)   = index3
+      vstart(ndims-1) = index2
+      vcount(ndims-1) = 1
+    else
+      vstart(ndims)   = index2
+    end if
     istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart, count=vcount)
     if (istatus /= NF90_NOERR) then
       write(nulerr,'(a,a,a,a)') '*** Error writing vector to ', var_name, ': ', &
            &                    trim(nf90_strerror(istatus))
+      write(nulerr,'(a,a,a,a)') '*** Error writing vector to ', trim(var_slice_name), &
+           &  ': ', trim(nf90_strerror(istatus))
       call my_abort('Error writing NetCDF file')
     end if
 …
   ! dimensions if either optional argument transp is .true., or the
   ! transpose_matrices method has already been called.
   subroutine put_real_matrix_indexed(this, var_name, index, var, do_transp)
+  subroutine put_real_matrix_indexed(this, var_name, var, index3, index4, do_transp)
     class(netcdf_file)             :: this
     character(len=*), intent(in)   :: var_name
     real(jprb), intent(in)         :: var(:,:)
+    integer, intent(in)            :: index
+    integer, intent(in)            :: index3
+    integer, intent(in), optional  :: index4
     real(jprb), allocatable        :: var_transpose(:,:)
     logical, optional, intent(in):: do_transp
+    logical, optional, intent(in)  :: do_transp
     integer :: ivarid, ndims, nvarlen, istatus
 …
     integer :: vcount(NF90_MAX_VAR_DIMS)
+    character(len=512) :: var_slice_name
     logical :: do_transpose
 …
     ! ntotal is zero then there must be an unlimited dimension)
     ntotal = ntotal / ndimlens(ndims)
+    if (present(index4)) then
+      ntotal = ntotal / ndimlens(ndims-1)
+      write(var_slice_name,'(a,a,i0,a,i0,a)') var_name, '(:,:,', index3, ',', index4, ')'
+    else
+      write(var_slice_name,'(a,a,i0,a)') var_name, '(:,:,', index3, ')'
+    end if
     if (ntotal /= size(var,kind=jpib) .and. ntotal /= 0) then
       write(nulerr,'(a,i0,a,a,a,i0)') '*** Error: attempt to write matrix of total size ', &
            & nvarlen, ' to ', var_name, ' which has total size ', ntotal
+           & nvarlen, ' to ', trim(var_slice_name), ' which has total size ', ntotal
       call my_abort('Error writing NetCDF file')
     end if
     vstart(1:ndims-1) = 1
-    vstart(ndims)     = index
     vcount(1:ndims-1) = ndimlens(1:ndims-1)
     vcount(ndims)     = 1
+    if (present(index4)) then
+      vstart(ndims)   = index4
+      vstart(ndims-1) = index3
+      vcount(ndims-1) = 1
+    else
+      vstart(ndims)   = index3
+    end if
     if (do_transpose) then
       ! Save the matrix with transposition
       if (this%iverbose >= 3) then
         write(nulout,'(a,i0,a,a,a)') '  Writing slice ', index, ' of ', var_name, &
+        write(nulout,'(a,a,a)') '  Writing ', trim(var_slice_name), &
              & ' (transposing dimensions)'
       end if
 …
       ! Save the matrix without transposition
       if (this%iverbose >= 3) then
         write(nulout,'(a,i0,a,a)') '  Writing slice ', index, ' of ', var_name
+        write(nulout,'(a,a)') '  Writing ', trim(var_slice_name)
       end if
       istatus = nf90_put_var(this%ncid, ivarid, var, start=vstart, count=vcount)
 …
     if (istatus /= NF90_NOERR) then
       write(nulerr,'(a,a,a,a)') '*** Error writing matrix ', var_name, &
+      write(nulerr,'(a,a,a)') '*** Error writing ', trim(var_slice_name), &
            &                    ': ', trim(nf90_strerror(istatus))
       call my_abort('Error writing NetCDF file')
 …
       if (this%iverbose >= 3) then
         write(nulout,'(a,a,a,i0,i0,i0,a)') '  Writing ', var_name, &
              & ' (permuted dimensions: ', i_permute_3d, ')'
+             & ' (permuting dimensions: ', i_permute_3d, ')'
       end if
       n_dimlens_permuted = (/ size(var,i_permute_3d(1)), &
            &                  size(var,i_permute_3d(2)), &
            &                  size(var,i_permute_3d(3))  /)
+      if (this%iverbose >= 4) then
+        write(nulout,'(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a)') '    (', &
+             &  n_dimlens_permuted(1), ',', n_dimlens_permuted(2), &
+             &  ',', n_dimlens_permuted(3), ') -> (', ndimlens(1), &
+             &  ',', ndimlens(2), ',', ndimlens(3), ')'
+      end if
+      !! FIX: This makes it look like the dimensions have stayed the same
+      ! if (this%iverbose >= 4) then
+      !   write(nulout,'(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a)') '    (', &
+      !        &  n_dimlens_permuted(1), ',', n_dimlens_permuted(2), &
+      !        &  ',', n_dimlens_permuted(3), ') -> (', ndimlens(1), &
+      !        &  ',', ndimlens(2), ',', ndimlens(3), ')'
+      ! end if
       allocate(var_permute(n_dimlens_permuted(1), &
            &   n_dimlens_permuted(2), n_dimlens_permuted(3)))
 …
   end subroutine put_real_array3
+#ifdef NC_NETCDF4
+  !---------------------------------------------------------------------
+  ! Copy dimensions from "infile" to "this"
+  subroutine copy_dimensions(this, infile)
+    class(netcdf_file)            :: this
+    type(netcdf_file), intent(in) :: infile
+    integer :: jdim
+    integer :: ndims
+    integer :: idimids(1024)
+    integer :: dimlen
+    character(len=512) :: dimname
+    integer :: istatus
+    integer :: include_parents
+    include_parents = 0
+    istatus = nf90_inq_dimids(infile%ncid, ndims, idimids, include_parents)
+    if (istatus /= NF90_NOERR) then
+      write(nulerr,'(a,a)') '*** Error reading dimensions of NetCDF file: ', &
+           trim(nf90_strerror(istatus))
+      call my_abort('Error reading NetCDF file')
+    end if
+    do jdim = 1,ndims
+      istatus = nf90_inquire_dimension(infile%ncid, idimids(jdim), &
+           &  name=dimname, len=dimlen)
+      if (istatus /= NF90_NOERR) then
+        write(nulerr,'(a,a)') '*** Error reading NetCDF dimension properties: ', &
+             trim(nf90_strerror(istatus))
+        call my_abort('Error reading NetCDF file')
+      end if
+      call this%define_dimension(trim(dimname), dimlen)
+    end do
+  end subroutine copy_dimensions
+#endif
+  !---------------------------------------------------------------------
+  ! Copy variable definition and attributes from "infile" to "this"
+  subroutine copy_variable_definition(this, infile, var_name)
+    class(netcdf_file)            :: this
+    type(netcdf_file), intent(in) :: infile
+    character(len=*),  intent(in) :: var_name
+#ifdef NC_NETCDF4
+    integer :: deflate_level  ! Compression: 0 (none) to 9 (most)
+    logical :: shuffle        ! Shuffle bytes before compression
+    integer :: chunksizes(NF90_MAX_VAR_DIMS)
+#endif
+    integer :: data_type
+    integer :: ndims
+    integer :: idimids_in(NF90_MAX_VAR_DIMS)
+    integer :: idimids_out(NF90_MAX_VAR_DIMS)
+    integer :: nattr
+    character(len=512) :: attr_name
+    character(len=512) :: dim_name
+    integer :: istatus
+    integer :: ivarid_in, ivarid_out
+    integer :: jattr, jdim
+    if (this%iverbose >= 4) then
+      write(nulout,'(a,a)') '  Copying definition of ', trim(var_name)
+    end if
+    ! Get variable ID from name
+    istatus = nf90_inq_varid(infile%ncid, var_name, ivarid_in)
+    if (istatus /= NF90_NOERR) then
+      write(nulerr,'(a,i0,a)') '*** Error inquiring about NetCDF variable "', &
+           & var_name, '": ', trim(nf90_strerror(istatus))
+      call my_abort('Error reading NetCDF file')
+    end if
+    ! Get variable properties
+#ifdef NC_NETCDF4
+    istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type, ndims=ndims, &
+         &  dimids=idimids_in, chunksizes=chunksizes, deflate_level=deflate_level, &
+         &  shuffle=shuffle, natts=nattr)
+#else
+    istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type, ndims=ndims, &
+         &  dimids=idimids_in, natts=nattr)
+#endif
+    if (istatus /= NF90_NOERR) then
+      write(nulerr,'(a,a)') '*** Error reading NetCDF variable properties: ', &
+           trim(nf90_strerror(istatus))
+      call my_abort('Error reading NetCDF file')
+    end if
+    ! Map dimension IDs
+    do jdim = 1,ndims
+      istatus = nf90_inquire_dimension(infile%ncid, idimids_in(jdim), name=dim_name)
+      if (istatus /= NF90_NOERR) then
+        write(nulerr,'(a,a)') '*** Error reading NetCDF dimension name: ', &
+             trim(nf90_strerror(istatus))
+        call my_abort('Error reading NetCDF file')
+      end if
+      istatus = nf90_inq_dimid(this%ncid, trim(dim_name), idimids_out(jdim))
+      if (istatus /= NF90_NOERR) then
+        write(nulerr,'(a,a)') '*** Error reading NetCDF dimension ID: ', &
+             trim(nf90_strerror(istatus))
+        call my_abort('Error reading NetCDF file')
+      end if
+    end do
+    ! Create variable
+#ifdef NC_NETCDF4
+    istatus = nf90_def_var(this%ncid, var_name, data_type, idimids_out(1:ndims), &
+         & ivarid_out, deflate_level=deflate_level, shuffle=shuffle, chunksizes=chunksizes(1:ndims))
+#else
+    istatus = nf90_def_var(this%ncid, var_name, data_type, idimids_out(1:ndims), ivarid_out)
+#endif
+    if (istatus /= NF90_NOERR) then
+      write(nulerr,'(a,a,a,a)') '*** Error defining variable "', var_name, &
+           &                    '": ', trim(nf90_strerror(istatus))
+      call my_abort('Error writing NetCDF file')
+    end if
+    ! Copy attributes
+    do jattr = 1,nattr
+      istatus = nf90_inq_attname(infile%ncid, ivarid_in, jattr, attr_name)
+      if (istatus /= NF90_NOERR) then
+        write(nulerr,'(a,a)') '*** Error reading attribute: ', &
+             &  trim(nf90_strerror(istatus))
+        call my_abort('Error reading NetCDF file')
+      end if
+      istatus = nf90_copy_att(infile%ncid, ivarid_in, trim(attr_name), &
+           &                    this%ncid, ivarid_out)
+    end do
+  end subroutine copy_variable_definition
+  !---------------------------------------------------------------------
+  ! Copy variable from "infile" to "this"
+  subroutine copy_variable(this, infile, var_name)
+    class(netcdf_file)             :: this
+    class(netcdf_file), intent(in) :: infile
+    character(len=*),   intent(in) :: var_name
+    integer :: ivarid_in, ivarid_out
+    integer :: ndims
+    integer :: ndimlens(NF90_MAX_VAR_DIMS)
+    integer(kind=jpib) :: ntotal
+    integer :: data_type
+    integer :: istatus
+    ! We use the Fortran-77 functions because they don't check that
+    ! the rank of the arguments is correct
+    integer, external :: nf_get_var_double, nf_put_var_double
+    integer, external :: nf_get_var_int, nf_put_var_int
+    real(kind=jprd), allocatable :: data_real(:)
+    integer,         allocatable :: data_int(:)
+    ! If we are in define mode, exit define mode
+    call this%end_define_mode()
+    if (this%iverbose >= 4) then
+      write(nulout,'(a,a)') '  Copying ', trim(var_name)
+    end if
+    call infile%get_variable_id(var_name, ivarid_in)
+    call infile%get_array_dimensions(ivarid_in, ndims, ndimlens, ntotal)
+    istatus = nf90_inquire_variable(infile%ncid, ivarid_in, xtype=data_type)
+    if (istatus /= NF90_NOERR) then
+      write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', &
+           &  trim(nf90_strerror(istatus))
+      call my_abort('Error reading NetCDF file')
+    end if
+    call infile%get_variable_id(var_name, ivarid_out)
+    if (data_type == NF90_DOUBLE .or. data_type == NF90_FLOAT) then
+      allocate(data_real(ntotal))
+      !istatus = nf90_get_var(infile%ncid, ivarid_in, data_real(1))
+      istatus = nf_get_var_double(infile%ncid, ivarid_in, data_real)
+      if (istatus /= NF90_NOERR) then
+        deallocate(data_real)
+        write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', &
+             &  trim(nf90_strerror(istatus))
+        call my_abort('Error reading NetCDF file')
+      end if
+      !istatus = nf90_put_var(this%ncid, ivarid_out, data_real)
+      istatus = nf_put_var_double(this%ncid, ivarid_out, data_real)
+      deallocate(data_real)
+      if (istatus /= NF90_NOERR) then
+        write(nulerr,'(a,a,a,a)') '*** Error writing variable "', var_name, '": ', &
+             &  trim(nf90_strerror(istatus))
+        call my_abort('Error writing NetCDF file')
+      end if
+    else
+      allocate(data_int(ntotal))
+      !istatus = nf90_get_var(infile%ncid, ivarid_in, data_int)
+      istatus = nf_get_var_int(infile%ncid, ivarid_in, data_int)
+      if (istatus /= NF90_NOERR) then
+        deallocate(data_int)
+        write(nulerr,'(a,a,a,a)') '*** Error reading variable "', var_name, '": ', &
+             &  trim(nf90_strerror(istatus))
+        call my_abort('Error reading NetCDF file')
+      end if
+      !istatus = nf90_put_var(this%ncid, ivarid_out, data_int)
+      istatus = nf_put_var_int(this%ncid, ivarid_out, data_int)
+      deallocate(data_int)
+      if (istatus /= NF90_NOERR) then
+        write(nulerr,'(a,a,a,a)') '*** Error writing variable "', var_name, '": ', &
+             &  trim(nf90_strerror(istatus))
+        call my_abort('Error writing NetCDF file')
+      end if
+    end if
+  end subroutine copy_variable
 end module easy_netcdf

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_adding_ica_lw.F90

-                      r3908
+                      r4444
     ! Loop index for model level
     integer :: jlev
+    integer :: jlev, jcol
     real(jprb) :: hook_handle
 …
     ! Work down through the atmosphere computing the downward fluxes
     ! at each half-level
+! Added for DWD (2020)
+!NEC$ outerloop_unroll(8)
     do jlev = 1,nlev
+      flux_dn(:,jlev+1) = transmittance(:,jlev)*flux_dn(:,jlev) + source_dn(:,jlev)
+      do jcol = 1,ncol
+        flux_dn(jcol,jlev+1) = transmittance(jcol,jlev)*flux_dn(jcol,jlev) + source_dn(jcol,jlev)
+      end do
     end do
 …
     ! Work back up through the atmosphere computing the upward fluxes
     ! at each half-level
+! Added for DWD (2020)
+!NEC$ outerloop_unroll(8)
     do jlev = nlev,1,-1
+      flux_up(:,jlev) = transmittance(:,jlev)*flux_up(:,jlev+1) + source_up(:,jlev)
+      do jcol = 1,ncol
+        flux_up(jcol,jlev) = transmittance(jcol,jlev)*flux_up(jcol,jlev+1) + source_up(jcol,jlev)
+      end do
     end do

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_adding_ica_sw.F90

-                      r3908
+                      r4444
     ! also the "source", which is the upwelling flux due to direct
     ! radiation that is scattered below that level
+! Added for DWD (2020)
+!NEC$ outerloop_unroll(8)
     do jlev = nlev,1,-1
       ! Next loop over columns. We could do this by indexing the
 …
     ! Work back down through the atmosphere computing the fluxes at
     ! each half-level
+! Added for DWD (2020)
+!NEC$ outerloop_unroll(8)
     do jlev = 1,nlev
       do jcol = 1,ncol

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_aerosol.F90

-                      r3908
+                      r4444
       allocate(this%g_lw  (config%n_bands_lw,istartlev:iendlev,ncol))
       ! If longwave scattering by aerosol is not to be represented,
       ! then the user may wish to just provide absorption optical deth
       ! in od_lw, in which case we must set the following two
+      ! then the user may wish to just provide absorption optical
+      ! depth in od_lw, in which case we must set the following two
       ! variables to zero
       this%ssa_lw = 0.0_jprb
 …
   !---------------------------------------------------------------------
   ! Deallocate array
+  ! Deallocate arrays
   subroutine deallocate_aerosol_arrays(this)
 …
     use yomhook,          only : lhook, dr_hook
     use radiation_config, only : out_of_bounds_3d
+    use radiation_check,  only : out_of_bounds_3d
     class(aerosol_type),   intent(inout) :: this

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_aerosol_optics.F90

-                      r4188
+                      r4444
+!
 ! Modifications
+!   2018-04-15  R Hogan  Add "direct" option
+!   2018-04-15  R. Hogan  Add "direct" option
+!   2020-11-14  R. Hogan  Add setup_general_aerosol_optics for ecCKD compatibility
+!   2022-03-27  R. Hogan  Add setup_general_aerosol_optics_legacy to use RRTM aerosol files with ecCKD
 module radiation_aerosol_optics
 …
     use radiation_aerosol_optics_data, only : aerosol_optics_type
     use radiation_io,                  only : nulerr, radiation_abort
     use setup_aerosol_optics_lmdz_m, only: setup_aerosol_optics_lmdz
+    use setup_aerosol_optics_lmdz_m,   only: setup_aerosol_optics_lmdz
     type(config_type), intent(inout) :: config
 …
       ! Load data from file and prepare to map config%n_aerosol_types
       ! aerosol types
+       call setup_aerosol_optics_lmdz(config%aerosol_optics, &
+            trim(config%aerosol_optics_file_name))
+      if (config%use_general_aerosol_optics) then
+        ! Read file containing high spectral resolution optical
+        ! properties and average to the spectral intervals of the
+        ! current gas-optics scheme
+!        call setup_general_aerosol_optics(config)
+        call setup_general_aerosol_optics_lmdz(config,trim(config%aerosol_optics_file_name))
+      else
+        ! Read file containing optical properties already in the bands
+        ! of the gas-optics scheme
+!        call config%aerosol_optics%setup(trim(config%aerosol_optics_file_name), &
+!             &                           iverbose=config%iverbosesetup)
+        call setup_aerosol_optics_lmdz(config%aerosol_optics, &
+                                       trim(config%aerosol_optics_file_name))
+      end if
+      call config%aerosol_optics%initialize_types(config%n_aerosol_types)
       ! Check agreement in number of bands
       if (config%n_bands_lw /= config%aerosol_optics%n_bands_lw) then
+        write(nulerr,'(a)') '*** Error: number of longwave bands does not match aerosol optics look-up table'
+        write(nulerr,'(a,i0,a,i0,a)') '*** Error: number of longwave bands (', &
+             &  config%n_bands_lw, ') does not match aerosol optics look-up table (', &
+             &  config%aerosol_optics%n_bands_lw, ')'
         call radiation_abort()
       end if
 …
     end if
+    call config%aerosol_optics%print_description(config%i_aerosol_type_map(1:config%n_aerosol_types))
+    if (config%iverbosesetup >= 1) then
+      call config%aerosol_optics%print_description(config%i_aerosol_type_map(1:config%n_aerosol_types))
+    end if
     if (lhook) call dr_hook('radiation_aerosol_optics:setup_aerosol_optics',1,hook_handle)
   end subroutine setup_aerosol_optics
+  !---------------------------------------------------------------------
+  ! Read file containing high spectral resolution optical properties
+  ! and average to the spectral intervals of the current gas-optics
+  ! scheme
+  subroutine setup_general_aerosol_optics(config)
+    use parkind1,                      only : jprb
+    use yomhook,                       only : lhook, dr_hook
+    use easy_netcdf,                   only : netcdf_file
+    use radiation_config,              only : config_type
+    use radiation_aerosol_optics_data, only : aerosol_optics_type
+    use radiation_spectral_definition, only : SolarReferenceTemperature, &
+         &                                    TerrestrialReferenceTemperature
+    use radiation_io,                  only : nulout
+    type(config_type), intent(inout), target :: config
+    ! The NetCDF file containing the aerosol optics data
+    type(netcdf_file)  :: file
+    ! Wavenumber points in NetCDF file
+    real(jprb), allocatable :: wavenumber(:) ! cm-1
+    ! Hydrophilic aerosol properties
+    real(jprb), allocatable :: mass_ext_philic(:,:,:)    ! Mass-ext coefficient (m2 kg-1)
+    real(jprb), allocatable :: ssa_philic(:,:,:)         ! Single-scattering albedo
+    real(jprb), allocatable :: g_philic(:,:,:)           ! Asymmetry factor
+    real(jprb), allocatable :: lidar_ratio_philic(:,:,:) ! Lidar ratio (sr)
+    ! Hydrophobic aerosol properties
+    real(jprb), allocatable :: mass_ext_phobic(:,:)      ! Mass-ext coefficient (m2 kg-1)
+    real(jprb), allocatable :: ssa_phobic(:,:)           ! Single-scattering albedo
+    real(jprb), allocatable :: g_phobic(:,:)             ! Asymmetry factor
+    real(jprb), allocatable :: lidar_ratio_phobic(:,:)   ! Lidar ratio (sr)
+    ! Mapping matrix between optical properties at the wavenumbers in
+    ! the file, and spectral intervals used by the gas-optics scheme
+    real(jprb), allocatable :: mapping(:,:)
+    ! Pointer to the aerosol optics coefficients for brevity of access
+    type(aerosol_optics_type), pointer :: ao
+    ! Target monochromatic wavenumber for interpolation (cm-1)
+    real(jprb) :: wavenumber_target
+    ! Number of spectral points describing aerosol properties in the
+    ! shortwave and longwave
+    integer    :: nspecsw, nspeclw
+    ! Number of monochromatic wavelengths required
+    integer    :: nmono
+    integer    :: n_type_philic, n_type_phobic, nrh, nwn
+    integer    :: jtype, jwl, iwn
+    ! Weight of first point in interpolation
+    real(jprb) :: weight1
+    real(jprb) :: hook_handle
+    if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',0,hook_handle)
+    ao => config%aerosol_optics
+    call file%open(trim(config%aerosol_optics_file_name), iverbose=config%iverbosesetup)
+    if (.not. file%exists('wavenumber')) then
+      ! Assume we have an old-style aerosol optics file with optical
+      ! properties provided per pre-defined band
+      call file%close()
+      if (config%iverbosesetup >= 2) then
+        write(nulout,'(a)') 'Legacy aerosol optics file: mapping between bands'
+      end if
+      call setup_general_aerosol_optics_legacy(config, trim(config%aerosol_optics_file_name))
+      return
+    end if
+    if (file%exists('mass_ext_hydrophilic')) then
+      ao%use_hydrophilic = .true.
+    else
+      ao%use_hydrophilic = .false.
+    end if
+    call file%get('wavenumber', wavenumber)
+    nwn = size(wavenumber)
+    ! Read the raw scattering data
+    call file%get('mass_ext_hydrophobic',    mass_ext_phobic)
+    call file%get('ssa_hydrophobic',         ssa_phobic)
+    call file%get('asymmetry_hydrophobic',   g_phobic)
+    call file%get('lidar_ratio_hydrophobic', lidar_ratio_phobic)
+    call file%get_global_attribute('description_hydrophobic', &
+         &                         ao%description_phobic_str)
+    if (ao%use_hydrophilic) then
+      call file%get('mass_ext_hydrophilic',    mass_ext_philic)
+      call file%get('ssa_hydrophilic',         ssa_philic)
+      call file%get('asymmetry_hydrophilic',   g_philic)
+      call file%get('lidar_ratio_hydrophilic', lidar_ratio_philic)
+      call file%get('relative_humidity1',      ao%rh_lower)
+      call file%get_global_attribute('description_hydrophilic', &
+           &                         ao%description_philic_str)
+    end if
+    ! Close aerosol scattering file
+    call file%close()
+    n_type_phobic = size(mass_ext_phobic, 2)
+    if (ao%use_hydrophilic) then
+      n_type_philic = size(mass_ext_philic, 3)
+      nrh = size(ao%rh_lower)
+    else
+      n_type_philic = 0
+      nrh = 0
+    end if
+    if (config%do_cloud_aerosol_per_sw_g_point) then
+      nspecsw = config%gas_optics_sw%spectral_def%ng
+    else
+      nspecsw = config%gas_optics_sw%spectral_def%nband
+    end if
+    if (config%do_cloud_aerosol_per_lw_g_point) then
+      nspeclw = config%gas_optics_lw%spectral_def%ng
+    else
+      nspeclw = config%gas_optics_lw%spectral_def%nband
+    end if
+    if (allocated(ao%wavelength_mono)) then
+      ! Monochromatic wavelengths also required
+      nmono = size(ao%wavelength_mono)
+    else
+      nmono = 0
+    end if
+    call ao%allocate(n_type_phobic, n_type_philic, nrh, nspeclw, nspecsw, nmono)
+    if (config%do_sw) then
+      call config%gas_optics_sw%spectral_def%calc_mapping(SolarReferenceTemperature, &
+           &  wavenumber, mapping, use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point))
+      ao%mass_ext_sw_phobic = matmul(mapping, mass_ext_phobic)
+      ao%ssa_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) &
+           &           / ao%mass_ext_sw_phobic
+      ao%g_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) &
+           &         / (ao%mass_ext_sw_phobic*ao%ssa_sw_phobic)
+      if (ao%use_hydrophilic) then
+        do jtype = 1,n_type_philic
+          ao%mass_ext_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype))
+          ao%ssa_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) &
+               &                                        *ssa_philic(:,:,jtype)) &
+               &           / ao%mass_ext_sw_philic(:,:,jtype)
+          ao%g_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) &
+               &                       *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) &
+               &         / (ao%mass_ext_sw_philic(:,:,jtype)*ao%ssa_sw_philic(:,:,jtype))
+        end do
+      end if
+    end if
+    if (config%do_lw) then
+      call config%gas_optics_lw%spectral_def%calc_mapping(TerrestrialReferenceTemperature, &
+           &  wavenumber, mapping, use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point))
+      ao%mass_ext_lw_phobic = matmul(mapping, mass_ext_phobic)
+      ao%ssa_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) &
+           &           / ao%mass_ext_lw_phobic
+      ao%g_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) &
+           &         / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic)
+      if (ao%use_hydrophilic) then
+        do jtype = 1,n_type_philic
+          ao%mass_ext_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype))
+          ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) &
+               &                                        *ssa_philic(:,:,jtype)) &
+               &           / ao%mass_ext_lw_philic(:,:,jtype)
+          ao%g_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) &
+               &                       *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) &
+               &         / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype))
+        end do
+      end if
+    end if
+    if (allocated(ao%wavelength_mono)) then
+      ! Monochromatic wavelengths also required
+      do jwl = 1,nmono
+        ! Wavelength (m) to wavenumber (cm-1)
+        wavenumber_target = 0.01_jprb / ao%wavelength_mono(jwl)
+        ! Find index to first interpolation point, and its weight
+        if (wavenumber_target <= wavenumber(1)) then
+          weight1 = 1.0_jprb
+          iwn = 1
+        else if (wavenumber_target >= wavenumber(nwn)) then
+          iwn = nwn-1
+          weight1 = 0.0_jprb
+        else
+          iwn = 1
+          do while (wavenumber(iwn+1) < wavenumber_target .and. iwn < nwn-1)
+            iwn = iwn + 1
+          end do
+          weight1 = (wavenumber(iwn+1)-wavenumber_target) &
+               &  / (wavenumber(iwn+1)-wavenumber(iwn))
+        end if
+        ! Linear interpolation
+        ao%mass_ext_mono_phobic(jwl,:) = weight1 * mass_ext_phobic(iwn,:) &
+             &             + (1.0_jprb - weight1)* mass_ext_phobic(iwn+1,:)
+        ao%ssa_mono_phobic(jwl,:)      = weight1 * ssa_phobic(iwn,:) &
+             &             + (1.0_jprb - weight1)* ssa_phobic(iwn+1,:)
+        ao%g_mono_phobic(jwl,:)        = weight1 * g_phobic(iwn,:) &
+             &             + (1.0_jprb - weight1)* g_phobic(iwn+1,:)
+        ao%lidar_ratio_mono_phobic(jwl,:) = weight1 * lidar_ratio_phobic(iwn,:) &
+             &                + (1.0_jprb - weight1)* lidar_ratio_phobic(iwn+1,:)
+        if (ao%use_hydrophilic) then
+          ao%mass_ext_mono_philic(jwl,:,:) = weight1 * mass_ext_philic(iwn,:,:) &
+               &               + (1.0_jprb - weight1)* mass_ext_philic(iwn+1,:,:)
+          ao%ssa_mono_philic(jwl,:,:)      = weight1 * ssa_philic(iwn,:,:) &
+               &               + (1.0_jprb - weight1)* ssa_philic(iwn+1,:,:)
+          ao%g_mono_philic(jwl,:,:)        = weight1 * g_philic(iwn,:,:) &
+               &               + (1.0_jprb - weight1)* g_philic(iwn+1,:,:)
+          ao%lidar_ratio_mono_philic(jwl,:,:) = weight1 * lidar_ratio_philic(iwn,:,:) &
+               &                  + (1.0_jprb - weight1)* lidar_ratio_philic(iwn+1,:,:)
+        end if
+      end do
+    end if
+    ! Deallocate memory local to this routine
+    deallocate(mass_ext_phobic)
+    deallocate(ssa_phobic)
+    deallocate(g_phobic)
+    deallocate(lidar_ratio_phobic)
+    if (ao%use_hydrophilic) then
+      deallocate(mass_ext_philic)
+      deallocate(ssa_philic)
+      deallocate(g_philic)
+      deallocate(lidar_ratio_philic)
+    end if
+    if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',1,hook_handle)
+  end subroutine setup_general_aerosol_optics
+    !---------------------------------------------------------------------
+  ! Read LMDZ file containing high spectral resolution optical properties
+  ! and average to the spectral intervals of the current gas-optics
+  ! scheme
+  subroutine setup_general_aerosol_optics_lmdz(config,file_name)
+    use parkind1,                      only : jprb
+    use yomhook,                       only : lhook, dr_hook
+!    use easy_netcdf,                   only : netcdf_file
+    use radiation_config,              only : config_type
+    use radiation_aerosol_optics_data, only : aerosol_optics_type
+    use radiation_spectral_definition, only : SolarReferenceTemperature, &
+         &                                    TerrestrialReferenceTemperature
+    use radiation_io,                  only : nulout
+    use netcdf95, only: nf95_open, nf95_inq_grp_full_ncid, nf95_close, &
+         nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, &
+         nf95_get_var, nf95_gw_var
+    use netcdf, only: nf90_nowrite
+    type(config_type), intent(inout), target :: config
+!    ! The NetCDF file containing the aerosol optics data
+!    type(netcdf_file)  :: file
+    character(len=*), intent(in):: file_name
+    ! NetCDF file containing the aerosol optics data
+    ! Wavenumber points in NetCDF file
+    real(jprb), allocatable :: wavenumber(:) ! cm-1
+    ! Hydrophilic aerosol properties
+    real(jprb), allocatable :: mass_ext_philic(:,:,:)    ! Mass-ext coefficient (m2 kg-1)
+    real(jprb), allocatable :: ssa_philic(:,:,:)         ! Single-scattering albedo
+    real(jprb), allocatable :: g_philic(:,:,:)           ! Asymmetry factor
+    real(jprb), allocatable :: lidar_ratio_philic(:,:,:) ! Lidar ratio (sr)
+    ! Hydrophobic aerosol properties
+    real(jprb), allocatable :: mass_ext_phobic(:,:)      ! Mass-ext coefficient (m2 kg-1)
+    real(jprb), allocatable :: ssa_phobic(:,:)           ! Single-scattering albedo
+    real(jprb), allocatable :: g_phobic(:,:)             ! Asymmetry factor
+    real(jprb), allocatable :: lidar_ratio_phobic(:,:)   ! Lidar ratio (sr)
+    ! Mapping matrix between optical properties at the wavenumbers in
+    ! the file, and spectral intervals used by the gas-optics scheme
+    real(jprb), allocatable :: mapping(:,:)
+    ! Pointer to the aerosol optics coefficients for brevity of access
+    type(aerosol_optics_type), pointer :: ao
+    ! Target monochromatic wavenumber for interpolation (cm-1)
+    real(jprb) :: wavenumber_target
+    ! Number of spectral points describing aerosol properties in the
+    ! shortwave and longwave
+    integer    :: nspecsw, nspeclw
+    ! Number of monochromatic wavelengths required
+    integer    :: nmono
+    integer    :: n_type_philic, n_type_phobic, nrh, nwn
+    integer    :: jtype, jwl, iwn
+    ! Weight of first point in interpolation
+    real(jprb) :: weight1
+    real(jprb) :: hook_handle
+    ! Local:
+    integer ncid, grpid, dimid, varid
+    if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',0,hook_handle)
+    ao => config%aerosol_optics
+    ao%use_hydrophilic = .true.
+    ao%use_monochromatic = .true.
+    print*,'file_name= ',file_name
+    call nf95_open(file_name, nf90_nowrite, ncid)
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic", grpid)
+    call nf95_inq_dimid(grpid, "hur", dimid)
+    call nf95_inquire_dimension(grpid, dimid, nclen = ao%nrh)
+!    allocate(ao%rh_lower(ao%nrh))
+    call nf95_inq_varid(grpid, "hur_bounds", varid)
+    call nf95_get_var(grpid, varid, ao%rh_lower, count_nc = [1, ao%nrh])
+    ! Hydrophilic/LW_bands:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/LW_bands", grpid)
+    call nf95_inq_varid(grpid, "asymmetry", varid)
+    call nf95_gw_var(grpid, varid, ao%g_lw_philic)
+    call nf95_inq_varid(grpid, "single_scat_alb", varid)
+    call nf95_gw_var(grpid, varid, ao%ssa_lw_philic)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_lw_philic)
+    ! Hydrophilic/SW_bands:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/SW_bands", grpid)
+    call nf95_inq_varid(grpid, "asymmetry", varid)
+    call nf95_gw_var(grpid, varid, ao%g_sw_philic)
+    ao%g_sw_philic = cshift(ao%g_sw_philic, 1)
+    call nf95_inq_varid(grpid, "single_scat_alb", varid)
+    call nf95_gw_var(grpid, varid, ao%ssa_sw_philic)
+    ao%g_sw_philic = cshift(ao%ssa_sw_philic, 1)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_sw_philic)
+    ao%g_sw_philic = cshift(ao%mass_ext_sw_philic, 1)
+    ! Hydrophilic/Monochromatic:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophilic/Monochromatic", grpid)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_mono_philic)
+    ! Hydrophobic/LW_bands:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/LW_bands", grpid)
+    call nf95_inq_varid(grpid, "asymmetry", varid)
+    call nf95_gw_var(grpid, varid, ao%g_lw_phobic)
+    call nf95_inq_varid(grpid, "single_scat_alb", varid)
+    call nf95_gw_var(grpid, varid, ao%ssa_lw_phobic)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_lw_phobic)
+    ! Hydrophobic/SW_bands:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/SW_bands", grpid)
+    call nf95_inq_varid(grpid, "asymmetry", varid)
+    call nf95_gw_var(grpid, varid, ao%g_sw_phobic)
+    ao%g_sw_phobic = cshift(ao%g_sw_phobic, 1)
+    call nf95_inq_varid(grpid, "single_scat_alb", varid)
+    call nf95_gw_var(grpid, varid, ao%ssa_sw_phobic)
+    ao%g_sw_phobic = cshift(ao%ssa_sw_phobic, 1)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_sw_phobic)
+    ao%g_sw_phobic = cshift(ao%mass_ext_sw_phobic, 1)
+! AI ATTENTION
+    call nf95_inq_varid(grpid, "wavenumber", varid)
+    call nf95_gw_var(grpid, varid, wavenumber)
+    ! Hydrophobic/Monochromatic:
+    call nf95_inq_grp_full_ncid(ncid, "Hydrophobic/Monochromatic", grpid)
+    call nf95_inq_varid(grpid, "mass_ext", varid)
+    call nf95_gw_var(grpid, varid, ao%mass_ext_mono_phobic)
+!    call file%get('wavenumber', wavenumber)
+!    nwn = size(wavenumber)
+!    call file%get_global_attribute('description_hydrophobic', &
+!         &                         ao%description_phobic_str)
+!      call file%get('relative_humidity1',      ao%rh_lower)
+!      call file%get_global_attribute('description_hydrophilic', &
+!           &                         ao%description_philic_str)
+    ! Close aerosol scattering file
+!    call file%close()
+    call nf95_close(ncid)
+    ! Get array sizes
+!    ao%n_bands_lw = size(ao%mass_ext_lw_phobic, 1)
+!    ao%n_bands_sw = size(ao%mass_ext_sw_phobic, 1)
+!    ao%n_mono_wl = size(ao%mass_ext_mono_phobic, 1)
+!    ao%n_type_phobic = size(ao%mass_ext_lw_phobic, 2)
+!    ao%n_type_philic = size(ao%mass_ext_lw_philic, 3)
+    ! Allocate memory for mapping arrays
+!    ao%ntype = ao%n_type_phobic + ao%n_type_philic
+!    allocate(ao%iclass(ao%ntype))
+!    allocate(ao%itype(ao%ntype))
+!    ao%iclass = IAerosolClassUndefined
+!    ao%itype  = 0
+    n_type_phobic = size(mass_ext_phobic, 2)
+    if (ao%use_hydrophilic) then
+      n_type_philic = size(mass_ext_philic, 3)
+      nrh = size(ao%rh_lower)
+    else
+      n_type_philic = 0
+      nrh = 0
+    end if
+    if (config%do_cloud_aerosol_per_sw_g_point) then
+      nspecsw = config%gas_optics_sw%spectral_def%ng
+    else
+      nspecsw = config%gas_optics_sw%spectral_def%nband
+    end if
+    if (config%do_cloud_aerosol_per_lw_g_point) then
+      nspeclw = config%gas_optics_lw%spectral_def%ng
+    else
+      nspeclw = config%gas_optics_lw%spectral_def%nband
+    end if
+    if (allocated(ao%wavelength_mono)) then
+      ! Monochromatic wavelengths also required
+      nmono = size(ao%wavelength_mono)
+    else
+      nmono = 0
+    end if
+    call ao%allocate(n_type_phobic, n_type_philic, nrh, nspeclw, nspecsw, nmono)
+    if (config%do_sw) then
+      call config%gas_optics_sw%spectral_def%calc_mapping(SolarReferenceTemperature, &
+           &  wavenumber, mapping, use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point))
+      ao%mass_ext_sw_phobic = matmul(mapping, mass_ext_phobic)
+      ao%ssa_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) &
+           &           / ao%mass_ext_sw_phobic
+      ao%g_sw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) &
+           &         / (ao%mass_ext_sw_phobic*ao%ssa_sw_phobic)
+      if (ao%use_hydrophilic) then
+        do jtype = 1,n_type_philic
+          ao%mass_ext_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype))
+          ao%ssa_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) &
+               &                                        *ssa_philic(:,:,jtype)) &
+               &           / ao%mass_ext_sw_philic(:,:,jtype)
+          ao%g_sw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) &
+               &                       *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) &
+               &         / (ao%mass_ext_sw_philic(:,:,jtype)*ao%ssa_sw_philic(:,:,jtype))
+        end do
+      end if
+    end if
+    if (config%do_lw) then
+      call config%gas_optics_lw%spectral_def%calc_mapping(TerrestrialReferenceTemperature, &
+           &  wavenumber, mapping, use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point))
+      ao%mass_ext_lw_phobic = matmul(mapping, mass_ext_phobic)
+      ao%ssa_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic) &
+           &           / ao%mass_ext_lw_phobic
+      ao%g_lw_phobic = matmul(mapping, mass_ext_phobic*ssa_phobic*g_phobic) &
+           &         / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic)
+      if (ao%use_hydrophilic) then
+        do jtype = 1,n_type_philic
+          ao%mass_ext_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype))
+          ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) &
+               &                                        *ssa_philic(:,:,jtype)) &
+               &           / ao%mass_ext_lw_philic(:,:,jtype)
+          ao%g_lw_philic(:,:,jtype) = matmul(mapping, mass_ext_philic(:,:,jtype) &
+               &                       *ssa_philic(:,:,jtype)*g_philic(:,:,jtype)) &
+               &         / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype))
+        end do
+      end if
+    end if
+    if (allocated(ao%wavelength_mono)) then
+      ! Monochromatic wavelengths also required
+      do jwl = 1,nmono
+        ! Wavelength (m) to wavenumber (cm-1)
+        wavenumber_target = 0.01_jprb / ao%wavelength_mono(jwl)
+        ! Find index to first interpolation point, and its weight
+        if (wavenumber_target <= wavenumber(1)) then
+          weight1 = 1.0_jprb
+          iwn = 1
+        else if (wavenumber_target >= wavenumber(nwn)) then
+          iwn = nwn-1
+          weight1 = 0.0_jprb
+        else
+          iwn = 1
+          do while (wavenumber(iwn+1) < wavenumber_target .and. iwn < nwn-1)
+            iwn = iwn + 1
+          end do
+          weight1 = (wavenumber(iwn+1)-wavenumber_target) &
+               &  / (wavenumber(iwn+1)-wavenumber(iwn))
+        end if
+        ! Linear interpolation
+        ao%mass_ext_mono_phobic(jwl,:) = weight1 * mass_ext_phobic(iwn,:) &
+             &             + (1.0_jprb - weight1)* mass_ext_phobic(iwn+1,:)
+        ao%ssa_mono_phobic(jwl,:)      = weight1 * ssa_phobic(iwn,:) &
+             &             + (1.0_jprb - weight1)* ssa_phobic(iwn+1,:)
+        ao%g_mono_phobic(jwl,:)        = weight1 * g_phobic(iwn,:) &
+             &             + (1.0_jprb - weight1)* g_phobic(iwn+1,:)
+        ao%lidar_ratio_mono_phobic(jwl,:) = weight1 * lidar_ratio_phobic(iwn,:) &
+             &                + (1.0_jprb - weight1)* lidar_ratio_phobic(iwn+1,:)
+        if (ao%use_hydrophilic) then
+          ao%mass_ext_mono_philic(jwl,:,:) = weight1 * mass_ext_philic(iwn,:,:) &
+               &               + (1.0_jprb - weight1)* mass_ext_philic(iwn+1,:,:)
+          ao%ssa_mono_philic(jwl,:,:)      = weight1 * ssa_philic(iwn,:,:) &
+               &               + (1.0_jprb - weight1)* ssa_philic(iwn+1,:,:)
+          ao%g_mono_philic(jwl,:,:)        = weight1 * g_philic(iwn,:,:) &
+               &               + (1.0_jprb - weight1)* g_philic(iwn+1,:,:)
+          ao%lidar_ratio_mono_philic(jwl,:,:) = weight1 * lidar_ratio_philic(iwn,:,:) &
+               &                  + (1.0_jprb - weight1)* lidar_ratio_philic(iwn+1,:,:)
+        end if
+      end do
+    end if
+    ! Deallocate memory local to this routine
+    deallocate(mass_ext_phobic)
+    deallocate(ssa_phobic)
+    deallocate(g_phobic)
+    deallocate(lidar_ratio_phobic)
+    if (ao%use_hydrophilic) then
+      deallocate(mass_ext_philic)
+      deallocate(ssa_philic)
+      deallocate(g_philic)
+      deallocate(lidar_ratio_philic)
+    end if
+    if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics',1,hook_handle)
+  end subroutine setup_general_aerosol_optics_lmdz
+  !---------------------------------------------------------------------
+  ! Read file containing legacy-style band-wise aerosol optical
+  ! properties and average to the spectral intervals of the current
+  ! gas-optics scheme
+  subroutine setup_general_aerosol_optics_legacy(config, file_name)
+    use parkind1,                      only : jprb
+    use yomhook,                       only : lhook, dr_hook
+    use easy_netcdf,                   only : netcdf_file
+    use radiation_config,              only : config_type
+    use radiation_aerosol_optics_data, only : aerosol_optics_type
+    use radiation_spectral_definition, only : SolarReferenceTemperature, &
+         &                                    TerrestrialReferenceTemperature
+    type(config_type), intent(inout), target :: config
+    ! The NetCDF file containing the aerosol optics data
+    character(len=*), intent(in) :: file_name
+    ! Mapping matrix between optical properties at the wavenumbers in
+    ! the file, and spectral intervals used by the gas-optics scheme
+    real(jprb), allocatable :: mapping(:,:), mapping_transp(:,:)
+    ! Pointer to the aerosol optics coefficients for brevity of access
+    type(aerosol_optics_type), pointer :: ao
+    ! Local copy of aerosol optical properties in the spectral
+    ! intervals of the file, which is deallocated when it goes out of
+    ! scope
+    type(aerosol_optics_type) :: ao_legacy
+    integer :: jtype
+    real(jprb) :: hook_handle
+    if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics_legacy',0,hook_handle)
+    ao => config%aerosol_optics
+    ! Load file into a local structure
+    call ao_legacy%setup(file_name, iverbose=config%iverbosesetup)
+    ! Copy over scalars and coordinate variables
+    call ao%allocate(ao_legacy%n_type_phobic, ao_legacy%n_type_philic, ao_legacy%nrh, &
+         &           config%n_bands_lw, config%n_bands_sw, ao_legacy%n_mono_wl)
+    ao%description_phobic_str = ao_legacy%description_phobic_str
+    ao%description_philic_str = ao_legacy%description_philic_str
+    ao%rh_lower = ao_legacy%rh_lower
+    ! use_hydrophilic = ao_legacy%use_hydrophilic
+    ! ao%iclass = ao_legacy%iclass
+    ! ao%itype = ao_legacy%itype
+    ! ao%ntype = ao_legacy%ntype
+    ! ao%n_type_phobic = ao_legacy%n_type_phobic
+    ! ao%n_type_philic = ao_legacy%n_type_philic
+    ! ao%n_mono_wl = ao_legacy%n_mono_wl
+    ! ao%use_monochromatic = ao_legacy%use_monochromatic
+    if (config%do_sw) then
+      call config%gas_optics_sw%spectral_def%calc_mapping_from_wavenumber_bands(SolarReferenceTemperature, &
+           &  ao_legacy%wavenumber1_sw, ao_legacy%wavenumber2_sw, mapping_transp, &
+           &  use_bands=(.not. config%do_cloud_aerosol_per_sw_g_point))
+      if (allocated(mapping)) then
+        deallocate(mapping)
+      end if
+      allocate(mapping(config%n_bands_sw,ao_legacy%n_bands_sw))
+      mapping = transpose(mapping_transp)
+      ao%mass_ext_sw_phobic = matmul(mapping, ao_legacy%mass_ext_sw_phobic)
+      ao%ssa_sw_phobic = matmul(mapping, ao_legacy%mass_ext_sw_phobic*ao_legacy%ssa_sw_phobic) &
+           &           / ao%mass_ext_sw_phobic
+      ao%g_sw_phobic = matmul(mapping, ao_legacy%mass_ext_sw_phobic*ao_legacy%ssa_sw_phobic &
+           &                           *ao_legacy%g_sw_phobic) &
+           &         / (ao%mass_ext_sw_phobic*ao%ssa_sw_phobic)
+      if (ao%use_hydrophilic) then
+        do jtype = 1,ao%n_type_philic
+          ao%mass_ext_sw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_sw_philic(:,:,jtype))
+          ao%ssa_sw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_sw_philic(:,:,jtype) &
+               &                                        *ao_legacy%ssa_sw_philic(:,:,jtype)) &
+               &           / ao%mass_ext_sw_philic(:,:,jtype)
+          ao%g_sw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_sw_philic(:,:,jtype) &
+               &               *ao_legacy%ssa_sw_philic(:,:,jtype)*ao_legacy%g_sw_philic(:,:,jtype)) &
+               &         / (ao%mass_ext_sw_philic(:,:,jtype)*ao%ssa_sw_philic(:,:,jtype))
+        end do
+      end if
+    end if
+    if (config%do_lw) then
+      if (allocated(mapping_transp)) then
+        deallocate(mapping_transp)
+      end if
+      call config%gas_optics_lw%spectral_def%calc_mapping_from_wavenumber_bands(TerrestrialReferenceTemperature, &
+           &  ao_legacy%wavenumber1_lw, ao_legacy%wavenumber2_lw, mapping_transp, &
+           &  use_bands=(.not. config%do_cloud_aerosol_per_lw_g_point))
+      if (allocated(mapping)) then
+        deallocate(mapping)
+      end if
+      allocate(mapping(config%n_bands_lw,ao_legacy%n_bands_lw))
+      mapping = transpose(mapping_transp)
+      ao%mass_ext_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic)
+      ao%ssa_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic) &
+           &           / ao%mass_ext_lw_phobic
+      ao%g_lw_phobic = matmul(mapping, ao_legacy%mass_ext_lw_phobic*ao_legacy%ssa_lw_phobic &
+           &                           *ao_legacy%g_lw_phobic) &
+           &         / (ao%mass_ext_lw_phobic*ao%ssa_lw_phobic)
+      if (ao%use_hydrophilic) then
+        do jtype = 1,ao%n_type_philic
+          ao%mass_ext_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype))
+          ao%ssa_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) &
+               &                                        *ao_legacy%ssa_lw_philic(:,:,jtype)) &
+               &           / ao%mass_ext_lw_philic(:,:,jtype)
+          ao%g_lw_philic(:,:,jtype) = matmul(mapping, ao_legacy%mass_ext_lw_philic(:,:,jtype) &
+               &               *ao_legacy%ssa_lw_philic(:,:,jtype)*ao_legacy%g_lw_philic(:,:,jtype)) &
+               &         / (ao%mass_ext_lw_philic(:,:,jtype)*ao%ssa_lw_philic(:,:,jtype))
+        end do
+      end if
+    end if
+    if (allocated(ao_legacy%wavelength_mono)) then
+      ao%wavelength_mono = ao_legacy%wavelength_mono
+      ao%mass_ext_mono_phobic = ao_legacy%mass_ext_mono_phobic
+      ao%ssa_mono_phobic = ao_legacy%ssa_mono_phobic
+      ao%g_mono_phobic = ao_legacy%g_mono_phobic
+      ao%lidar_ratio_mono_phobic = ao_legacy%lidar_ratio_mono_phobic
+      if (ao%use_hydrophilic) then
+        ao%mass_ext_mono_philic = ao_legacy%mass_ext_mono_philic
+        ao%ssa_mono_philic = ao_legacy%ssa_mono_philic
+        ao%g_mono_philic = ao_legacy%g_mono_philic
+        ao%lidar_ratio_mono_philic = ao_legacy%lidar_ratio_mono_philic
+      end if
+    end if
+    if (lhook) call dr_hook('radiation_aerosol_optics:setup_general_aerosol_optics_legacy',1,hook_handle)
+  end subroutine setup_general_aerosol_optics_legacy
 …
          &  IAerosolClassUndefined,   IAerosolClassIgnored, &
          &  IAerosolClassHydrophobic, IAerosolClassHydrophilic
-    USE phys_local_var_mod, ONLY: rhcl
     integer, intent(in) :: nlev               ! number of model levels
 …
     ! Loop indices for column, level, g point, band and aerosol type
     integer :: jcol, jlev, jg, jtype
+    integer :: jcol, jlev, jg, jtype, jband
     ! Range of levels over which aerosols are present
 …
     ! Indices to spectral band and relative humidity look-up table
     integer :: iband, irh
+    ! Short cut for ao%itype(jtype)
+    integer :: itype
     ! Pointer to the aerosol optics coefficients for brevity of access
 …
       ! Set variables to zero that may not have been previously
       g_sw = 0.0_jprb
+      g_sw(:,:,istartcol:iendcol) = 0.0_jprb
       if (config%do_lw_aerosol_scattering) then
+        ssa_lw = 0.0_jprb
+        g_lw   = 0.0_jprb
+      end if
+!AI juin 2022
+      !call gas%get(IH2O, IMassMixingRatio, h2o_mmr, istartcol=istartcol)
+        ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb
+        g_lw(:,:,istartcol:iendcol)   = 0.0_jprb
+      end if
+      call gas%get(IH2O, IMassMixingRatio, h2o_mmr, istartcol=istartcol)
       ! Loop over position
 …
           ! saturation and the index to the relative-humidity index of
           ! hydrophilic-aerosol data
+! AI juin 2022
+!          rh  = h2o_mmr(jcol,jlev) / thermodynamics%h2o_sat_liq(jcol,jlev)
+!          irh = ao%calc_rh_index(rh)
+          irh = ao%calc_rh_index(rhcl(jcol,jlev))
+!          print*,'irh=',irh
+          rh  = h2o_mmr(jcol,jlev) / thermodynamics%h2o_sat_liq(jcol,jlev)
+          irh = ao%calc_rh_index(rh)
           factor = ( thermodynamics%pressure_hl(jcol,jlev+1) &
 …
           do jtype = 1,config%n_aerosol_types
+            itype = ao%itype(jtype)
             ! Add the optical depth, scattering optical depth and
             ! scattering optical depth-weighted asymmetry factor for
 …
             ! dimension being spectral band.
             if (ao%iclass(jtype) == IAerosolClassHydrophobic) then
+              local_od_sw = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
+                   &  * ao%mass_ext_sw_phobic(:,ao%itype(jtype))
+              od_sw_aerosol = od_sw_aerosol + local_od_sw
+              scat_sw_aerosol = scat_sw_aerosol &
+                   &  + local_od_sw * ao%ssa_sw_phobic(:,ao%itype(jtype))
+              scat_g_sw_aerosol = scat_g_sw_aerosol &
+                   &  + local_od_sw * ao%ssa_sw_phobic(:,ao%itype(jtype)) &
+                   &  * ao%g_sw_phobic(:,ao%itype(jtype))
+              do jband = 1,config%n_bands_sw
+                local_od_sw(jband) = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
+                     &  * ao%mass_ext_sw_phobic(jband,itype)
+                od_sw_aerosol(jband) = od_sw_aerosol(jband) + local_od_sw(jband)
+                scat_sw_aerosol(jband) = scat_sw_aerosol(jband) &
+                     &  + local_od_sw(jband) * ao%ssa_sw_phobic(jband,itype)
+                scat_g_sw_aerosol(jband) = scat_g_sw_aerosol(jband) &
+                     &  + local_od_sw(jband) * ao%ssa_sw_phobic(jband,itype) &
+                     &  * ao%g_sw_phobic(jband,itype)
+              end do
               if (config%do_lw_aerosol_scattering) then
                 local_od_lw = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
                      &  * ao%mass_ext_lw_phobic(:,ao%itype(jtype))
+                     &  * ao%mass_ext_lw_phobic(:,itype)
                 od_lw_aerosol = od_lw_aerosol + local_od_lw
                 scat_lw_aerosol = scat_lw_aerosol &
                      &  + local_od_lw * ao%ssa_lw_phobic(:,ao%itype(jtype))
+                     &  + local_od_lw * ao%ssa_lw_phobic(:,itype)
                 scat_g_lw_aerosol = scat_g_lw_aerosol &
                      &  + local_od_lw * ao%ssa_lw_phobic(:,ao%itype(jtype)) &
                      &  * ao%g_lw_phobic(:,ao%itype(jtype))
+                     &  + local_od_lw * ao%ssa_lw_phobic(:,itype) &
+                     &  * ao%g_lw_phobic(:,itype)
               else
                 ! If aerosol longwave scattering is not included then we
 …
                 od_lw_aerosol = od_lw_aerosol &
                      &  + factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
                      &  * ao%mass_ext_lw_phobic(:,ao%itype(jtype)) &
                      &  * (1.0_jprb - ao%ssa_lw_phobic(:,ao%itype(jtype)))
+                     &  * ao%mass_ext_lw_phobic(:,itype) &
+                     &  * (1.0_jprb - ao%ssa_lw_phobic(:,itype))
               end if
             else if (ao%iclass(jtype) == IAerosolClassHydrophilic) then
               ! Hydrophilic aerosols require the look-up tables to
               ! be indexed with irh
+              local_od_sw = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
+                   &  * ao%mass_ext_sw_philic(:,irh,ao%itype(jtype))
+              od_sw_aerosol = od_sw_aerosol + local_od_sw
+              scat_sw_aerosol = scat_sw_aerosol &
+                   &  + local_od_sw * ao%ssa_sw_philic(:,irh,ao%itype(jtype))
+              scat_g_sw_aerosol = scat_g_sw_aerosol &
+                   &  + local_od_sw * ao%ssa_sw_philic(:,irh,ao%itype(jtype)) &
+                   &  * ao%g_sw_philic(:,irh,ao%itype(jtype))
+              do jband = 1,config%n_bands_sw
+                local_od_sw(jband) = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
+                     &  * ao%mass_ext_sw_philic(jband,irh,itype)
+                od_sw_aerosol(jband) = od_sw_aerosol(jband) + local_od_sw(jband)
+                scat_sw_aerosol(jband) = scat_sw_aerosol(jband) &
+                     &  + local_od_sw(jband) * ao%ssa_sw_philic(jband,irh,itype)
+                scat_g_sw_aerosol(jband) = scat_g_sw_aerosol(jband) &
+                     &  + local_od_sw(jband) * ao%ssa_sw_philic(jband,irh,itype) &
+                     &  * ao%g_sw_philic(jband,irh,itype)
+              end do
               if (config%do_lw_aerosol_scattering) then
                 local_od_lw = factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
                      &  * ao%mass_ext_lw_philic(:,irh,ao%itype(jtype))
+                     &  * ao%mass_ext_lw_philic(:,irh,itype)
                 od_lw_aerosol = od_lw_aerosol + local_od_lw
                 scat_lw_aerosol = scat_lw_aerosol &
                      &  + local_od_lw * ao%ssa_lw_philic(:,irh,ao%itype(jtype))
+                     &  + local_od_lw * ao%ssa_lw_philic(:,irh,itype)
                 scat_g_lw_aerosol = scat_g_lw_aerosol &
                      &  + local_od_lw * ao%ssa_lw_philic(:,irh,ao%itype(jtype)) &
                      &  * ao%g_lw_philic(:,irh,ao%itype(jtype))
+                     &  + local_od_lw * ao%ssa_lw_philic(:,irh,itype) &
+                     &  * ao%g_lw_philic(:,irh,itype)
               else
                 ! If aerosol longwave scattering is not included then we
 …
                 od_lw_aerosol = od_lw_aerosol &
                      &  + factor * aerosol%mixing_ratio(jcol,jlev,jtype) &
                      &  * ao%mass_ext_lw_philic(:,irh,ao%itype(jtype)) &
                      &  * (1.0_jprb - ao%ssa_lw_philic(:,irh,ao%itype(jtype)))
+                     &  * ao%mass_ext_lw_philic(:,irh,itype) &
+                     &  * (1.0_jprb - ao%ssa_lw_philic(:,irh,itype))
               end if
             end if
 …
           ! properties (noting that any gas scattering will have an
           ! asymmetry factor of zero)
           if (od_sw_aerosol(1) > 0.0_jprb) then
             do jg = 1,config%n_g_sw
               iband = config%i_band_from_reordered_g_sw(jg)
               local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband)
+          do jg = 1,config%n_g_sw
+            iband = config%i_band_from_reordered_g_sw(jg)
+            local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband)
+            if (local_od > 0.0_jprb .and. od_sw_aerosol(iband) > 0.0_jprb) then
               local_scat = ssa_sw(jg,jlev,jcol) * od_sw(jg,jlev,jcol) &
                    &  + scat_sw_aerosol(iband)
 …
               ! simply weights the aerosol asymmetry by the scattering
               ! optical depth
+              g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband) / local_scat
+              if (local_scat > 0.0_jprb) then
+                g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband) / local_scat
+              end if
               ssa_sw(jg,jlev,jcol) = local_scat / local_od
               od_sw (jg,jlev,jcol) = local_od
             end do
           end if
+            end if
+          end do
           ! Combine aerosol longwave scattering properties with gas
 …
             do jg = 1,config%n_g_lw
               iband = config%i_band_from_reordered_g_lw(jg)
+              if (od_lw_aerosol(iband) > 0.0_jprb) then
+              local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband)
+              if (local_od > 0.0_jprb .and. od_lw_aerosol(iband) > 0.0_jprb) then
                 ! All scattering is due to aerosols, therefore the
                 ! asymmetry factor is equal to the value for aerosols
 …
                   g_lw(jg,jlev,jcol) = scat_g_lw_aerosol(iband) &
                        &  / scat_lw_aerosol(iband)
-                else
-                  g_lw(jg,jlev,jcol) = 0.0_jprb
                 end if
-                local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband)
                 ssa_lw(jg,jlev,jcol) = scat_lw_aerosol(iband) / local_od
                 od_lw (jg,jlev,jcol) = local_od
 …
     ! a point in space for each spectral band of the shortwave and
     ! longwave spectrum
     real(jprb), dimension(config%n_bands_sw) &
+    real(jprb), dimension(config%n_bands_sw,nlev) &
          & :: od_sw_aerosol, scat_sw_aerosol, scat_g_sw_aerosol
     real(jprb), dimension(config%n_bands_lw) :: od_lw_aerosol
     real(jprb), dimension(config%n_bands_lw_if_scattering) &
+    real(jprb), dimension(config%n_bands_lw,nlev) :: od_lw_aerosol
+    real(jprb), dimension(config%n_bands_lw_if_scattering,nlev) &
          & :: scat_lw_aerosol, scat_g_lw_aerosol
     ! Loop indices for column, level, g point and band
     integer :: jcol, jlev, jg
+    integer :: jcol, jlev, jg, jb
     ! Range of levels over which aerosols are present
 …
       ! Set variables to zero that may not have been previously
       g_sw = 0.0_jprb
+      g_sw(:,:,istartcol:iendcol) = 0.0_jprb
       ! Loop over position
       do jcol = istartcol,iendcol
+! Added for DWD (2020)
+!NEC$ forced_collapse
         do jlev = istartlev,iendlev
+          od_sw_aerosol = aerosol%od_sw(:,jlev,jcol)
+          scat_sw_aerosol = aerosol%ssa_sw(:,jlev,jcol) * od_sw_aerosol
+          scat_g_sw_aerosol = aerosol%g_sw(:,jlev,jcol) * scat_sw_aerosol
+          if (.not. config%do_sw_delta_scaling_with_gases) then
+            ! Delta-Eddington scaling on aerosol only.  Note that if
+            ! do_sw_delta_scaling_with_gases==.true. then the delta
+            ! scaling is done to the cloud-aerosol-gas mixture inside
+            ! the solver
+            call delta_eddington_extensive(od_sw_aerosol, scat_sw_aerosol, &
+                 &                         scat_g_sw_aerosol)
+          end if
+          ! Combine aerosol shortwave scattering properties with gas
+          ! properties (noting that any gas scattering will have an
+          ! asymmetry factor of zero)
+          if (od_sw_aerosol(1) > 0.0_jprb) then
+          do jb = 1,config%n_bands_sw
+            od_sw_aerosol(jb,jlev) = aerosol%od_sw(jb,jlev,jcol)
+            scat_sw_aerosol(jb,jlev) = aerosol%ssa_sw(jb,jlev,jcol) * od_sw_aerosol(jb,jlev)
+            scat_g_sw_aerosol(jb,jlev) = aerosol%g_sw(jb,jlev,jcol) * scat_sw_aerosol(jb,jlev)
+            if (.not. config%do_sw_delta_scaling_with_gases) then
+              ! Delta-Eddington scaling on aerosol only.  Note that if
+              ! do_sw_delta_scaling_with_gases==.true. then the delta
+              ! scaling is done to the cloud-aerosol-gas mixture
+              ! inside the solver
+              call delta_eddington_extensive(od_sw_aerosol(jb,jlev), scat_sw_aerosol(jb,jlev), &
+                   &                         scat_g_sw_aerosol(jb,jlev))
+            end if
+          end do
+        end do
+        ! Combine aerosol shortwave scattering properties with gas
+        ! properties (noting that any gas scattering will have an
+        ! asymmetry factor of zero)
+        do jlev = istartlev,iendlev
+          if (od_sw_aerosol(1,jlev) > 0.0_jprb) then
             do jg = 1,config%n_g_sw
               iband = config%i_band_from_reordered_g_sw(jg)
               local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband)
+              local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband,jlev)
               local_scat = ssa_sw(jg,jlev,jcol) * od_sw(jg,jlev,jcol) &
                    &  + scat_sw_aerosol(iband)
+                   &  + scat_sw_aerosol(iband,jlev)
               ! Note that asymmetry_sw of gases is zero so the following
               ! simply weights the aerosol asymmetry by the scattering
               ! optical depth
+              g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband) / local_scat
+              g_sw(jg,jlev,jcol) = scat_g_sw_aerosol(iband,jlev) / local_scat
+              local_od = od_sw(jg,jlev,jcol) + od_sw_aerosol(iband,jlev)
               ssa_sw(jg,jlev,jcol) = local_scat / local_od
               od_sw (jg,jlev,jcol) = local_od
 …
       if (config%do_lw_aerosol_scattering) then
         ssa_lw = 0.0_jprb
         g_lw   = 0.0_jprb
+        ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb
+        g_lw(:,:,istartcol:iendcol)   = 0.0_jprb
         ! Loop over position
         do jcol = istartcol,iendcol
+! Added for DWD (2020)
+!NEC$ forced_collapse
           do jlev = istartlev,iendlev
+            od_lw_aerosol = aerosol%od_lw(:,jlev,jcol)
+            scat_lw_aerosol = aerosol%ssa_lw(:,jlev,jcol) * od_lw_aerosol
+            scat_g_lw_aerosol = aerosol%g_lw(:,jlev,jcol) * scat_lw_aerosol
+            do jb = 1,config%n_bands_lw
+              od_lw_aerosol(jb,jlev) = aerosol%od_lw(jb,jlev,jcol)
+              scat_lw_aerosol(jb,jlev) = aerosol%ssa_lw(jb,jlev,jcol) * od_lw_aerosol(jb,jlev)
+              scat_g_lw_aerosol(jb,jlev) = aerosol%g_lw(jb,jlev,jcol) * scat_lw_aerosol(jb,jlev)
+            call delta_eddington_extensive(od_lw_aerosol, scat_lw_aerosol, &
+                 &                         scat_g_lw_aerosol)
+              call delta_eddington_extensive(od_lw_aerosol(jb,jlev), scat_lw_aerosol(jb,jlev), &
+                   &                         scat_g_lw_aerosol(jb,jlev))
+            end do
+          end do
+          do jlev = istartlev,iendlev
             do jg = 1,config%n_g_lw
               iband = config%i_band_from_reordered_g_lw(jg)
               if (od_lw_aerosol(iband) > 0.0_jprb) then
+              if (od_lw_aerosol(iband,jlev) > 0.0_jprb) then
                 ! All scattering is due to aerosols, therefore the
                 ! asymmetry factor is equal to the value for aerosols
+                if (scat_lw_aerosol(iband) > 0.0_jprb) then
+                  g_lw(jg,jlev,jcol) = scat_g_lw_aerosol(iband) &
+                       &  / scat_lw_aerosol(iband)
+                else
+                  g_lw(jg,jlev,jcol) = 0.0_jprb
+                if (scat_lw_aerosol(iband,jlev) > 0.0_jprb) then
+                  g_lw(jg,jlev,jcol) = scat_g_lw_aerosol(iband,jlev) &
+                       &  / scat_lw_aerosol(iband,jlev)
                 end if
                 local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband)
                 ssa_lw(jg,jlev,jcol) = scat_lw_aerosol(iband) / local_od
+                local_od = od_lw(jg,jlev,jcol) + od_lw_aerosol(iband,jlev)
+                ssa_lw(jg,jlev,jcol) = scat_lw_aerosol(iband,jlev) / local_od
                 od_lw (jg,jlev,jcol) = local_od
               end if
 …
         ! Loop over position
         do jcol = istartcol,iendcol
+! Added for DWD (2020)
+!NEC$ forced_collapse
           do jlev = istartlev,iendlev
             ! If aerosol longwave scattering is not included then we
             ! weight the optical depth by the single scattering
             ! co-albedo
+            od_lw_aerosol = aerosol%od_lw(:,jlev,jcol) &
+                 &  * (1.0_jprb - aerosol%ssa_lw(:,jlev,jcol))
+            do jb = 1, config%n_bands_lw
+              od_lw_aerosol(jb,jlev) = aerosol%od_lw(jb,jlev,jcol) &
+                 &  * (1.0_jprb - aerosol%ssa_lw(jb,jlev,jcol))
+            end do
+          end do
+          do jlev = istartlev,iendlev
             do jg = 1,config%n_g_lw
               od_lw(jg,jlev,jcol) = od_lw(jg,jlev,jcol) &
                    &  + od_lw_aerosol(config%i_band_from_reordered_g_lw(jg))
+                   &  + od_lw_aerosol(config%i_band_from_reordered_g_lw(jg),jlev)
             end do
           end do
 …
   ! Sometimes it is useful to specify aerosol in terms of its optical
   ! depth at a particular wavelength.  This function returns the dry
   ! shortwave mass-extinction coefficient, i.e. the extinction cross
   ! section per unit mass, for aerosol of type "itype" at shortwave
   ! band "iband". For hydrophilic types, the value at the first
   ! relative humidity bin is taken.
   function dry_aerosol_sw_mass_extinction(config, itype, iband)
+  ! mass-extinction coefficient, i.e. the extinction cross section per
+  ! unit mass, for aerosol of type "itype" at the specified wavelength
+  ! (m). For hydrophilic types, the value at the first relative
+  ! humidity bin is taken.
+  function dry_aerosol_mass_extinction(config, itype, wavelength)
     use parkind1,                      only : jprb
+    use radiation_io,                  only : nulerr, radiation_abort
     use radiation_config,              only : config_type
     use radiation_aerosol_optics_data, only : aerosol_optics_type, &
 …
     type(config_type), intent(in), target :: config
+    ! Aerosol type and shortwave band as indices to the array
+    integer, intent(in) :: itype, iband
+    ! Aerosol type
+    integer, intent(in) :: itype
+    ! Wavelength (m)
+    real(jprb), intent(in) :: wavelength
+    real(jprb) dry_aerosol_sw_mass_extinction
+    real(jprb) :: dry_aerosol_mass_extinction
+    ! Index to the monochromatic wavelength requested
+    integer :: imono
     ! Pointer to the aerosol optics coefficients for brevity of access
 …
     ao => config%aerosol_optics
+    imono = minloc(abs(wavelength - ao%wavelength_mono), 1)
+    if (abs(wavelength - ao%wavelength_mono(imono))/wavelength > 0.01_jprb) then
+      write(nulerr,'(a,e8.4,a)') '*** Error: requested wavelength ', &
+           &  wavelength, ' not within 1% of stored wavelengths'
+      call radiation_abort()
+     end if
     if (ao%iclass(itype) == IAerosolClassHydrophobic) then
       dry_aerosol_sw_mass_extinction = ao%mass_ext_sw_phobic(iband,ao%itype(itype))
+      dry_aerosol_mass_extinction = ao%mass_ext_mono_phobic(imono,ao%itype(itype))
     else if (ao%iclass(itype) == IAerosolClassHydrophilic) then
       ! Take the value at the first relative-humidity bin for the
       ! "dry" aerosol value
       dry_aerosol_sw_mass_extinction = ao%mass_ext_sw_philic(iband,1,ao%itype(itype))
+      dry_aerosol_mass_extinction = ao%mass_ext_mono_philic(imono,1,ao%itype(itype))
     else
       dry_aerosol_sw_mass_extinction = 0.0_jprb
     end if
   end function dry_aerosol_sw_mass_extinction
+      dry_aerosol_mass_extinction = 0.0_jprb
+    end if
+  end function dry_aerosol_mass_extinction
   !---------------------------------------------------------------------
+  ! Compute aerosol extinction coefficient at a particular shortwave
+  ! band and a single height - this is useful for visibility
+  ! diagnostics
+  subroutine aerosol_sw_extinction(ncol,istartcol,iendcol, &
+       &  config, iband, mixing_ratio, relative_humidity, extinction)
+  ! Compute aerosol extinction coefficient at a particular wavelength
+  ! and a single height - this is useful for visibility diagnostics
+  subroutine aerosol_extinction(ncol,istartcol,iendcol, &
+       &  config, wavelength, mixing_ratio, relative_humidity, extinction)
     use parkind1,                      only : jprb
 …
     integer, intent(in) :: istartcol, iendcol ! range of columns to process
     type(config_type), intent(in), target :: config
     integer, intent(in)     :: iband ! Index of required spectral band
+    real(jprb), intent(in)  :: wavelength ! Requested wavelength (m)
     real(jprb), intent(in)  :: mixing_ratio(ncol,config%n_aerosol_types)
     real(jprb), intent(in)  :: relative_humidity(ncol)
 …
     ! Local aerosol extinction
     real(jprb) :: ext
+    ! Index to the monochromatic wavelength requested
+    integer :: imono
     ! Pointer to the aerosol optics coefficients for brevity of access
 …
     real(jprb) :: hook_handle
     if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_sw_extinction',0,hook_handle)
+    if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_extinction',0,hook_handle)
     do jtype = 1,config%n_aerosol_types
 …
     ao => config%aerosol_optics
+    imono = minloc(abs(wavelength - ao%wavelength_mono), 1)
+    if (abs(wavelength - ao%wavelength_mono(imono))/wavelength > 0.01_jprb) then
+      write(nulerr,'(a,e8.4,a)') '*** Error: requested wavelength ', &
+           &  wavelength, ' not within 1% of stored wavelengths'
+      call radiation_abort()
+     end if
     ! Loop over position
 …
         if (ao%iclass(jtype) == IAerosolClassHydrophobic) then
           ext = ext + mixing_ratio(jcol,jtype) &
                &    * ao%mass_ext_sw_phobic(iband,ao%itype(jtype))
+               &    * ao%mass_ext_mono_phobic(imono,ao%itype(jtype))
         else if (ao%iclass(jtype) == IAerosolClassHydrophilic) then
           ext = ext + mixing_ratio(jcol,jtype) &
                &    * ao%mass_ext_sw_philic(iband,irh,ao%itype(jtype))
+               &    * ao%mass_ext_mono_philic(imono,irh,ao%itype(jtype))
         end if
       end do
 …
     end do
     if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_sw_extinction',1,hook_handle)
   end subroutine aerosol_sw_extinction
+    if (lhook) call dr_hook('radiation_aerosol_optics:aerosol_extinction',1,hook_handle)
+  end subroutine aerosol_extinction
 end module radiation_aerosol_optics

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_aerosol_optics_data.F90

-                      r3908
+                      r4444
      integer, allocatable, dimension(:) :: itype
+     ! Wavenumber (cm-1) upper and lower bounds of each spectral
+     ! interval, which if used in the RRTMG gas optics scheme should
+     ! match its band bounds
+     real(jprb), allocatable, dimension(:) :: wavenumber1_sw, wavenumber2_sw
+     real(jprb), allocatable, dimension(:) :: wavenumber1_lw, wavenumber2_lw
      ! Scattering properties are provided separately in the shortwave
      ! and longwave for hydrophobic and hydrophilic aerosols.
 …
           &  ssa_sw_phobic,      & ! Single scattering albedo
           &  g_sw_phobic,        & ! Asymmetry factor
+!          &  ssa_g_sw_phobic,    & ! ssa*g
           &  mass_ext_lw_phobic, & ! Mass-extinction coefficient (m2 kg-1)
+!          &  mass_abs_lw_phobic, & ! Mass-absorption coefficient (m2 kg-1)
           &  ssa_lw_phobic,      & ! Single scattering albedo
           &  g_lw_phobic           ! Asymmetry factor
      ! Hydrophilic aerosols are dimensioned (nband, nrh, n_type_philic):
+     ! Hydrophilic aerosols are dimensioned (nband,nrh,n_type_philic):
      real(jprb), allocatable, dimension(:,:,:) :: &
           &  mass_ext_sw_philic, & ! Mass-extinction coefficient (m2 kg-1)
           &  ssa_sw_philic,      & ! Single scattering albedo
           &  g_sw_philic,        & ! Asymmetry factor
+ !         &  ssa_g_sw_philic,    & ! ssa*g
           &  mass_ext_lw_philic, & ! Mass-extinction coefficient (m2 kg-1)
+ !         &  mass_abs_lw_philic, & ! Mass-absorption coefficient (m2 kg-1)
           &  ssa_lw_philic,      & ! Single scattering albedo
           &  g_lw_philic           ! Asymmetry factor
+     ! Scattering properties at selected wavelengths
+     ! (n_mono_wl,n_type_phobic/philic)
+     ! Wavelengths at which monochromatic properties are stored,
+     ! dimensioned (n_mono_wl), units metres
+     real(jprb), allocatable :: wavelength_mono(:)
+     ! Scattering properties at selected monochromatic wavelengths
+     ! (n_mono_wl,n_type_phobic)
      real(jprb), allocatable, dimension(:,:) :: &
           &  mass_ext_mono_phobic, & ! Mass-extinction coefficient (m2 kg-1)
 …
           &  g_mono_phobic,        & ! Asymmetry factor
           &  lidar_ratio_mono_phobic ! Lidar Ratio
+     ! ...hydrophilic aerosols dimensioned (n_mono_wl,nrh,n_type_philic):
      real(jprb), allocatable, dimension(:,:,:) :: &
           &  mass_ext_mono_philic, & ! Mass-extinction coefficient (m2 kg-1)
 …
      ! The number of hydrophobic and hydrophilic types read from the
      ! aerosol optics file
+     integer :: n_type_phobic, n_type_philic
+     integer :: n_type_phobic = 0
+     integer :: n_type_philic = 0
      ! Number of relative humidity bins
      integer :: nrh
+     integer :: nrh = 0
      ! Number of longwave and shortwave bands of the data in the file,
 …
    contains
      procedure :: setup => setup_aerosol_optics
+     procedure :: save  => save_aerosol_optics
+     procedure :: allocate
+     procedure :: initialize_types
      procedure :: set_hydrophobic_type
      procedure :: set_hydrophilic_type
 …
   !---------------------------------------------------------------------
   ! Setup aerosol optics coefficients by reading them from a file
   subroutine setup_aerosol_optics(this, file_name, ntype, iverbose)
+  subroutine setup_aerosol_optics(this, file_name, iverbose)
     use yomhook,              only : lhook, dr_hook
 …
     class(aerosol_optics_type), intent(inout) :: this
     character(len=*), intent(in)              :: file_name
-    integer, intent(in)                       :: ntype
     integer, intent(in), optional             :: iverbose
     ! The NetCDF file containing the aerosol optics data
     type(netcdf_file)  :: file
+    real(jprb), allocatable :: wavelength_tmp(:)
     integer            :: iverb
     real(jprb)         :: hook_handle
 …
       this%use_hydrophilic = .false.
     end if
+    ! Read the wavenumber bounds
+    call file%get('wavenumber1_sw', this%wavenumber1_sw)
+    call file%get('wavenumber2_sw', this%wavenumber2_sw)
+    call file%get('wavenumber1_lw', this%wavenumber1_lw)
+    call file%get('wavenumber2_lw', this%wavenumber2_lw)
     ! Read the raw scattering data
 …
          &                         this%description_phobic_str)
+    ! Precompute ssa*g for the shortwave and mass-absorption for the
+    ! longwave - TBD FIX
+    !allocate(this%ssa_g_sw_phobic(...
     if (this%use_hydrophilic) then
       call file%get('mass_ext_sw_hydrophilic', this%mass_ext_sw_philic)
 …
     end if
     ! Read the raw scattering data at selected wavelengths if
     ! available in the input file
+    ! Read the monochromatic scattering data at selected wavelengths
+    ! if available in the input file
     if (file%exists('mass_ext_mono_hydrophobic')) then
       this%use_monochromatic = .true.
+      if (allocated(this%wavelength_mono)) then
+        ! User has provided required monochromatic wavelengths, which
+        ! must match those in the file (in the more recent "general"
+        ! aerosol optics, interpolation provides optical properties at
+        ! the requested wavelengths)
+        call file%get('wavelength_mono', wavelength_tmp)
+        if (size(wavelength_tmp) /= size(this%wavelength_mono)) then
+          write(nulerr,'(a,i0,a,i0,a)') '*** Error: ', size(this%wavelength_mono), &
+               &  ' monochromatic wavelengths requested but ', &
+               &  size(wavelength_tmp), ' in file'
+          call radiation_abort('Radiation configuration error')
+        end if
+        if (any(abs(this%wavelength_mono-wavelength_tmp) &
+               &  / this%wavelength_mono > 0.01_jprb)) then
+          write(nulerr,'(a,a)') '*** Error: requested monochromatic wavelengths', &
+               &  'must all be within 1% of values in file'
+          call radiation_abort('Radiation configuration error')
+        end if
+      else
+        ! User has not provided required wavelengths, so we save the
+        ! monochromatic wavelengths in the file
+        call file%get('wavelength_mono', this%wavelength_mono)
+      end if
       call file%get('mass_ext_mono_hydrophobic', this%mass_ext_mono_phobic)
       call file%get('ssa_mono_hydrophobic',      this%ssa_mono_phobic)
 …
         write(nulerr,'(a,a)') '*** Error: mass extinction for hydrophilic and hydrophobic ', &
              &                'aerosol have different numbers of longwave bands'
         call radiation_abort()
+        call radiation_abort('Radiation configuration error')
       end if
       if (size(this%mass_ext_sw_philic,1) /= this%n_bands_sw) then
         write(nulerr,'(a,a)') '*** Error: mass extinction for hydrophilic and hydrophobic ', &
              &                'aerosol have different numbers of shortwave bands'
         call radiation_abort()
+        call radiation_abort('Radiation configuration error')
       end if
       if (size(this%rh_lower) /= this%nrh) then
         write(nulerr,'(a)') '*** Error: size(relative_humidity1) /= size(mass_ext_sw_hydrophilic,2)'
         call radiation_abort()
+        call radiation_abort('Radiation configuration error')
       end if
 …
     end if
+    if (lhook) call dr_hook('radiation_aerosol_optics_data:setup',1,hook_handle)
+  end subroutine setup_aerosol_optics
+  !---------------------------------------------------------------------
+  ! Initialize the arrays describing the user's aerosol types
+  subroutine initialize_types(this, ntype)
+    class(aerosol_optics_type), intent(inout) :: this
+    integer,                    intent(in)    :: ntype
     ! Allocate memory for mapping arrays
     this%ntype = ntype
 …
     this%itype  = 0
+    if (lhook) call dr_hook('radiation_aerosol_optics_data:setup',1,hook_handle)
+  end subroutine setup_aerosol_optics
+  end subroutine initialize_types
+  !---------------------------------------------------------------------
+  ! Allocate arrays for aerosol optics data type
+  subroutine allocate(this, n_type_phobic, n_type_philic, nrh, &
+       &              n_bands_lw, n_bands_sw, n_mono_wl)
+    use yomhook,     only : lhook, dr_hook
+    class(aerosol_optics_type), intent(inout) :: this
+    integer, intent(in) :: n_type_phobic, n_type_philic, nrh
+    integer, intent(in) :: n_bands_lw, n_bands_sw, n_mono_wl
+    real(jprb) :: hook_handle
+    if (lhook) call dr_hook('radiation_aerosol_optics_data:allocate',0,hook_handle)
+    this%n_type_phobic = n_type_phobic
+    this%n_type_philic = n_type_philic
+    this%nrh           = nrh
+    this%n_bands_lw    = n_bands_lw
+    this%n_bands_sw    = n_bands_sw
+    this%n_mono_wl     = n_mono_wl
+    if (n_type_philic > 0) then
+      this%use_hydrophilic = .true.
+    else
+      this%use_hydrophilic = .false.
+    end if
+    if (n_bands_sw > 0) then
+      allocate(this%mass_ext_sw_phobic(n_bands_sw, n_type_phobic))
+      allocate(this%ssa_sw_phobic(n_bands_sw, n_type_phobic))
+      allocate(this%g_sw_phobic(n_bands_sw, n_type_phobic))
+    end if
+    if (n_bands_lw > 0) then
+      allocate(this%mass_ext_lw_phobic(n_bands_lw, n_type_phobic))
+      allocate(this%ssa_lw_phobic(n_bands_lw, n_type_phobic))
+      allocate(this%g_lw_phobic(n_bands_lw, n_type_phobic))
+    end if
+    if (n_mono_wl > 0) then
+      allocate(this%mass_ext_mono_phobic(n_mono_wl, n_type_phobic))
+      allocate(this%ssa_mono_phobic(n_mono_wl, n_type_phobic))
+      allocate(this%g_mono_phobic(n_mono_wl, n_type_phobic))
+      allocate(this%lidar_ratio_mono_phobic(n_mono_wl, n_type_phobic))
+    end if
+    if (n_type_philic > 0 .and. nrh > 0) then
+      if (n_bands_sw > 0) then
+        allocate(this%mass_ext_sw_philic(n_bands_sw, nrh, n_type_philic))
+        allocate(this%ssa_sw_philic(n_bands_sw, nrh, n_type_philic))
+        allocate(this%g_sw_philic(n_bands_sw, nrh, n_type_philic))
+      end if
+      if (n_bands_lw > 0) then
+        allocate(this%mass_ext_lw_philic(n_bands_lw, nrh, n_type_philic))
+        allocate(this%ssa_lw_philic(n_bands_lw, nrh, n_type_philic))
+        allocate(this%g_lw_philic(n_bands_lw, nrh, n_type_philic))
+      end if
+      if (n_mono_wl > 0) then
+        allocate(this%mass_ext_mono_philic(n_mono_wl, nrh, n_type_philic))
+        allocate(this%ssa_mono_philic(n_mono_wl, nrh, n_type_philic))
+        allocate(this%g_mono_philic(n_mono_wl, nrh, n_type_philic))
+        allocate(this%lidar_ratio_mono_philic(n_mono_wl, nrh, n_type_philic))
+      end if
+    end if
+    if (lhook) call dr_hook('radiation_aerosol_optics_data:allocate',1,hook_handle)
+  end subroutine allocate
+  !---------------------------------------------------------------------
+  subroutine save_aerosol_optics(this, file_name, iverbose)
+    use yomhook,     only : lhook, dr_hook
+    use easy_netcdf, only : netcdf_file
+    class(aerosol_optics_type), intent(inout) :: this
+    character(len=*),           intent(in)    :: file_name
+    integer,          optional, intent(in)    :: iverbose
+    ! Object for output NetCDF file
+    type(netcdf_file) :: out_file
+    real(jprb) :: hook_handle
+    if (lhook) call dr_hook('radiation_aerosol_optics_data:save',0,hook_handle)
+    ! Create the file
+    call out_file%create(trim(file_name), iverbose=iverbose)
+    ! Define dimensions
+    call out_file%define_dimension("band_lw", this%n_bands_lw)
+    call out_file%define_dimension("band_sw", this%n_bands_sw)
+    call out_file%define_dimension("hydrophilic", this%n_type_philic)
+    call out_file%define_dimension("hydrophobic", this%n_type_phobic)
+    call out_file%define_dimension("relative_humidity", this%nrh)
+    !if (this%use_monochromatic) then
+    !  call out_file%define_dimension("wavelength_mono", this%n_mono_wl)
+    !end if
+    ! Put global attributes
+    call out_file%put_global_attributes( &
+         &   title_str="Aerosol optical properties in the spectral intervals of the gas-optics scheme for ecRad", &
+         &   source_str="ecRad offline radiation model")
+    call out_file%put_global_attribute( &
+         &  "description_hydrophobic", this%description_phobic_str)
+    call out_file%put_global_attribute( &
+         &  "description_hydrophilic", this%description_philic_str)
+    ! Define variables
+    call out_file%define_variable("mass_ext_sw_hydrophobic", units_str="m2 kg-1", &
+         &  long_name="Shortwave mass-extinction coefficient of hydrophobic aerosols", &
+         &  dim2_name="hydrophobic", dim1_name="band_sw")
+    call out_file%define_variable("ssa_sw_hydrophobic", units_str="1", &
+         &  long_name="Shortwave single scattering albedo of hydrophobic aerosols", &
+         &  dim2_name="hydrophobic", dim1_name="band_sw")
+    call out_file%define_variable("asymmetry_sw_hydrophobic", units_str="1", &
+         &  long_name="Shortwave asymmetry factor of hydrophobic aerosols", &
+         &  dim2_name="hydrophobic", dim1_name="band_sw")
+    call out_file%define_variable("mass_ext_lw_hydrophobic", units_str="m2 kg-1", &
+         &  long_name="Longwave mass-extinction coefficient of hydrophobic aerosols", &
+         &  dim2_name="hydrophobic", dim1_name="band_lw")
+    call out_file%define_variable("ssa_lw_hydrophobic", units_str="1", &
+         &  long_name="Longwave single scattering albedo of hydrophobic aerosols", &
+         &  dim2_name="hydrophobic", dim1_name="band_lw")
+    call out_file%define_variable("asymmetry_lw_hydrophobic", units_str="1", &
+         &  long_name="Longwave asymmetry factor of hydrophobic aerosols", &
+         &  dim2_name="hydrophobic", dim1_name="band_lw")
+    call out_file%define_variable("mass_ext_sw_hydrophilic", units_str="m2 kg-1", &
+         &  long_name="Shortwave mass-extinction coefficient of hydrophilic aerosols", &
+         &  dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_sw")
+    call out_file%define_variable("ssa_sw_hydrophilic", units_str="1", &
+         &  long_name="Shortwave single scattering albedo of hydrophilic aerosols", &
+         &  dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_sw")
+    call out_file%define_variable("asymmetry_sw_hydrophilic", units_str="1", &
+         &  long_name="Shortwave asymmetry factor of hydrophilic aerosols", &
+         &  dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_sw")
+    call out_file%define_variable("mass_ext_lw_hydrophilic", units_str="m2 kg-1", &
+         &  long_name="Longwave mass-extinction coefficient of hydrophilic aerosols", &
+         &  dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_lw")
+    call out_file%define_variable("ssa_lw_hydrophilic", units_str="1", &
+         &  long_name="Longwave single scattering albedo of hydrophilic aerosols", &
+         &  dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_lw")
+    call out_file%define_variable("asymmetry_lw_hydrophilic", units_str="1", &
+         &  long_name="Longwave asymmetry factor of hydrophilic aerosols", &
+         &  dim3_name="hydrophilic", dim2_name="relative_humidity", dim1_name="band_lw")
+    ! Write variables
+    call out_file%put("mass_ext_sw_hydrophobic", this%mass_ext_sw_phobic)
+    call out_file%put("ssa_sw_hydrophobic", this%ssa_sw_phobic)
+    call out_file%put("asymmetry_sw_hydrophobic", this%g_sw_phobic)
+    call out_file%put("mass_ext_lw_hydrophobic", this%mass_ext_lw_phobic)
+    call out_file%put("ssa_lw_hydrophobic", this%ssa_lw_phobic)
+    call out_file%put("asymmetry_lw_hydrophobic", this%g_lw_phobic)
+    call out_file%put("mass_ext_sw_hydrophilic", this%mass_ext_sw_philic)
+    call out_file%put("ssa_sw_hydrophilic", this%ssa_sw_philic)
+    call out_file%put("asymmetry_sw_hydrophilic", this%g_sw_philic)
+    call out_file%put("mass_ext_lw_hydrophilic", this%mass_ext_lw_philic)
+    call out_file%put("ssa_lw_hydrophilic", this%ssa_lw_philic)
+    call out_file%put("asymmetry_lw_hydrophilic", this%g_lw_philic)
+    call out_file%close()
+    if (lhook) call dr_hook('radiation_aerosol_optics_data:save',1,hook_handle)
+  end subroutine save_aerosol_optics

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_cloud.F90

-                      r3908
+                      r4444
 !   2019-01-14  R. Hogan  Added inv_inhom_effective_size variable
 !   2019-01-14  R. Hogan  Added out_of_physical_bounds routine
+!   2019-06-14  R. Hogan  Added capability to store any number of cloud/precip types
 module radiation_cloud
 …
   type cloud_type
     ! For maximum flexibility, an arbitrary number "ntype" of
+    ! cloud types could be stored, as follows:
+    !     integer :: ntype     ! number of cloud types
+    !     integer :: nfraction ! number of cloud fractions
+    !     real(jprb), allocatable, dimension(:,:,:) :: &
+    !          mixing_ratio, & ! (ncol,nwetlev,ntype) mass mixing ratio (kg/kg)
+    !          particle_size,& ! (ncol,nwetlev,ntype) effective radius/size (m)
+    !          fraction        ! (ncol,nwetlev,nfraction) areal (i.e. cloud) fraction
+    ! However, for practical purposes at the moment we consider two
+    ! cloud types, liquid cloud droplets and ice cloud
+    ! particles.  The following variables are dimensioned (ncol,nlev)
+    real(jprb), allocatable, dimension(:,:) :: &
+    ! hydrometeor types can be stored, dimensioned (ncol,nlev,ntype)
+    integer                                   :: ntype = 0
+    real(jprb), allocatable, dimension(:,:,:) :: &
+         &  mixing_ratio, &  ! mass mixing ratio (kg/kg)
+         &  effective_radius ! (m)
+    ! For backwards compatibility, we also allow for the two
+    ! traditional cloud types, liquid cloud droplets and ice cloud
+    ! particles, dimensioned (ncol,nlev)
+    real(jprb), pointer, dimension(:,:) :: &
          &  q_liq,  q_ice,  & ! mass mixing ratio (kg/kg)
+         &  re_liq, re_ice, & ! effective radius (m)
+         &  fraction          ! (0-1) Assume liq & ice completely mixed
+         &  re_liq, re_ice    ! effective radius (m)
+    ! For the moment, the different types of hydrometeor are assumed
+    ! to be mixed with each other, so there is just one cloud fraction
+    ! variable varying from 0 to 1
+    real(jprb), allocatable, dimension(:,:) :: fraction
     ! The fractional standard deviation of cloud optical depth in the
 …
   ! in the offline code these are allocated when they are read from
   ! the NetCDF file
   subroutine allocate_cloud_arrays(this, ncol, nlev, use_inhom_effective_size)
+  subroutine allocate_cloud_arrays(this, ncol, nlev, ntype, use_inhom_effective_size)
     use yomhook,     only : lhook, dr_hook
+    class(cloud_type), intent(inout) :: this
+    integer, intent(in)              :: ncol  ! Number of columns
+    integer, intent(in)              :: nlev  ! Number of levels
+    class(cloud_type), intent(inout), target :: this
+    integer, intent(in)              :: ncol   ! Number of columns
+    integer, intent(in)              :: nlev   ! Number of levels
+    ! Number of cloud/precip particle types.  If not present then the
+    ! older cloud behaviour is assumed: two types are present, (1)
+    ! liquid and (2) ice, and they can be accessed via q_liq, q_ice,
+    ! re_liq and re_ice.
+    integer, intent(in), optional    :: ntype
     logical, intent(in), optional    :: use_inhom_effective_size
 …
     if (lhook) call dr_hook('radiation_cloud:allocate',0,hook_handle)
+    allocate(this%q_liq(ncol,nlev))
+    allocate(this%re_liq(ncol,nlev))
+    allocate(this%q_ice(ncol,nlev))
+    allocate(this%re_ice(ncol,nlev))
+    if (present(ntype)) then
+      this%ntype = ntype
+    else
+      this%ntype = 2
+    end if
+    allocate(this%mixing_ratio(ncol,nlev,this%ntype))
+    allocate(this%effective_radius(ncol,nlev,this%ntype))
+    nullify(this%q_liq)
+    nullify(this%q_ice)
+    nullify(this%re_liq)
+    nullify(this%re_ice)
+    if (.not. present(ntype)) then
+      ! Older interface in which only liquid and ice are supported
+      this%q_liq  => this%mixing_ratio(:,:,1)
+      this%q_ice  => this%mixing_ratio(:,:,2)
+      this%re_liq => this%effective_radius(:,:,1)
+      this%re_ice => this%effective_radius(:,:,2)
+    end if
     allocate(this%fraction(ncol,nlev))
     allocate(this%overlap_param(ncol,nlev-1))
 …
     if (lhook) call dr_hook('radiation_cloud:deallocate',0,hook_handle)
+    if (allocated(this%q_liq))    deallocate(this%q_liq)
+    if (allocated(this%re_liq))   deallocate(this%re_liq)
+    if (allocated(this%q_ice))    deallocate(this%q_ice)
+    if (allocated(this%re_ice))   deallocate(this%re_ice)
+    if (allocated(this%fraction)) deallocate(this%fraction)
+    if (allocated(this%overlap_param))  deallocate(this%overlap_param)
+    if (allocated(this%fractional_std)) deallocate(this%fractional_std)
+    nullify(this%q_liq)
+    nullify(this%q_ice)
+    nullify(this%re_liq)
+    nullify(this%re_ice)
+    if (allocated(this%mixing_ratio))     deallocate(this%mixing_ratio)
+    if (allocated(this%effective_radius)) deallocate(this%effective_radius)
+    if (allocated(this%fraction))         deallocate(this%fraction)
+    if (allocated(this%overlap_param))    deallocate(this%overlap_param)
+    if (allocated(this%fractional_std))   deallocate(this%fractional_std)
     if (allocated(this%inv_cloud_effective_size)) &
          &  deallocate(this%inv_cloud_effective_size)
 …
     integer :: ncol, nlev
     integer :: jlev
+    integer :: jcol, jlev
     real(jprb)        :: hook_handle
 …
       ! top-of-atmosphere to surface). In case pressure_hl(:,1)=0, we
       ! don't take the logarithm of the first pressure in each column.
+      this%overlap_param(i1:i2,1) = exp(-(R_over_g/decorrelation_length) &
+           &                            * thermodynamics%temperature_hl(i1:i2,2) &
+           &                            *log(thermodynamics%pressure_hl(i1:i2,3) &
+           &                                /thermodynamics%pressure_hl(i1:i2,2)))
+      do jcol = i1,i2
+        this%overlap_param(jcol,1) = exp(-(R_over_g/decorrelation_length) &
+             &                            * thermodynamics%temperature_hl(jcol,2) &
+             &                            *log(thermodynamics%pressure_hl(jcol,3) &
+             &                                /thermodynamics%pressure_hl(jcol,2)))
+      end do
       do jlev = 2,nlev-1
+        this%overlap_param(i1:i2,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) &
+             &                            * thermodynamics%temperature_hl(i1:i2,jlev+1) &
+             &                            *log(thermodynamics%pressure_hl(i1:i2,jlev+2) &
+             &                                /thermodynamics%pressure_hl(i1:i2,jlev)))
+        do jcol = i1,i2
+          this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) &
+              &                            * thermodynamics%temperature_hl(jcol,jlev+1) &
+              &                            *log(thermodynamics%pressure_hl(jcol,jlev+2) &
+              &                                /thermodynamics%pressure_hl(jcol,jlev)))
+        end do
       end do
 …
        ! don't take the logarithm of the last pressure in each column.
       do jlev = 1,nlev-2
+        this%overlap_param(i1:i2,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) &
+             &                            * thermodynamics%temperature_hl(i1:i2,jlev+1) &
+             &                            *log(thermodynamics%pressure_hl(i1:i2,jlev) &
+             &                                /thermodynamics%pressure_hl(i1:i2,jlev+2)))
+        do jcol = i1,i2
+          this%overlap_param(jcol,jlev) = exp(-(0.5_jprb*R_over_g/decorrelation_length) &
+              &                            * thermodynamics%temperature_hl(jcol,jlev+1) &
+              &                            *log(thermodynamics%pressure_hl(jcol,jlev) &
+              &                                /thermodynamics%pressure_hl(jcol,jlev+2)))
+        end do
       end do
+      this%overlap_param(i1:i2,nlev-1) = exp(-(R_over_g/decorrelation_length) &
+           &                            * thermodynamics%temperature_hl(i1:i2,nlev) &
+           &                            *log(thermodynamics%pressure_hl(i1:i2,nlev-1) &
+           &                                /thermodynamics%pressure_hl(i1:i2,nlev)))
+      do jcol = i1,i2
+        this%overlap_param(jcol,nlev-1) = exp(-(R_over_g/decorrelation_length) &
+            &                            * thermodynamics%temperature_hl(jcol,nlev) &
+            &                            *log(thermodynamics%pressure_hl(jcol,nlev-1) &
+            &                                /thermodynamics%pressure_hl(jcol,nlev)))
+      end do
     end if
 …
     integer,           intent(in)    :: istartcol, iendcol
     integer :: nlev
     integer :: jcol, jlev
+    integer :: nlev, ntype
+    integer :: jcol, jlev, jh
     real(jprb) :: cloud_fraction_threshold, cloud_mixing_ratio_threshold
+    real(jprb) :: sum_mixing_ratio(istartcol:iendcol)
     real(jprb) :: hook_handle
 …
     if (lhook) call dr_hook('radiation_cloud:crop_cloud_fraction',0,hook_handle)
+    nlev = size(this%fraction,2)
+    nlev  = size(this%fraction,2)
+    ntype = size(this%mixing_ratio,3)
     do jlev = 1,nlev
       do jcol = istartcol,iendcol
+        if (this%fraction(jcol,jlev) < cloud_fraction_threshold &
+             &  .or. this%q_liq(jcol,jlev)+this%q_ice(jcol,jlev) &
+             &        < cloud_mixing_ratio_threshold) then
+        sum_mixing_ratio(jcol) = 0.0_jprb
+      end do
+      do jh = 1, ntype
+        do jcol = istartcol,iendcol
+          sum_mixing_ratio(jcol) = sum_mixing_ratio(jcol) + this%mixing_ratio(jcol,jlev,jh)
+        end do
+      end do
+      do jcol = istartcol,iendcol
+        if (this%fraction(jcol,jlev)        < cloud_fraction_threshold &
+             &  .or. sum_mixing_ratio(jcol) < cloud_mixing_ratio_threshold) then
           this%fraction(jcol,jlev) = 0.0_jprb
         end if
 …
     use yomhook,          only : lhook, dr_hook
     use radiation_config, only : out_of_bounds_2d
+    use radiation_check, only : out_of_bounds_2d, out_of_bounds_3d
     class(cloud_type), intent(inout) :: this
 …
     end if
     is_bad =    out_of_bounds_2d(this%q_liq, 'q_liq', 0.0_jprb, 1.0_jprb, &
+    is_bad =    out_of_bounds_3d(this%mixing_ratio, 'cloud%mixing_ratio', 0.0_jprb, 1.0_jprb, &
          &                       do_fix_local, i1=istartcol, i2=iendcol) &
+         & .or. out_of_bounds_2d(this%q_ice, 'q_ice', 0.0_jprb, 1.0_jprb, &
+         &                       do_fix_local, i1=istartcol, i2=iendcol) &
+         & .or. out_of_bounds_2d(this%re_liq, 're_liq', 0.0_jprb, 0.01_jprb, &
+         &                       do_fix_local, i1=istartcol, i2=iendcol) &
+         & .or. out_of_bounds_2d(this%re_ice, 're_ice', 0.0_jprb, 0.1_jprb, &
+         & .or. out_of_bounds_3d(this%effective_radius, 'cloud%effective_radius', 0.0_jprb, 0.1_jprb, &
          &                       do_fix_local, i1=istartcol, i2=iendcol) &
          & .or. out_of_bounds_2d(this%fraction, 'cloud%fraction', 0.0_jprb, 1.0_jprb, &

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_cloud_cover.F90

-                      r3908
+                      r4444
            &  + (1.0_jprb - overlap_alpha) &
            &  * (frac(jlev)+frac(jlev+1)-frac(jlev)*frac(jlev+1))
+! Added for DWD (2020)
+#ifdef __SX__
+    end do
+    do jlev = 1,nlev-1
+#endif
       if (frac(jlev) >= MaxCloudFrac) then
         ! Cloud cover has reached one

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_cloud_generator.F90

-                      r3908
+                      r4444
 ! Modifications
 !   2018-02-22  R. Hogan  Call masked version of PDF sampler for speed
+!   2020-03-31  R. Hogan  More vectorizable version of Exp-Ran
 module radiation_cloud_generator
 …
        &  fractional_std, pdf_sampler, &
        &  od_scaling, total_cloud_cover, &
        &  is_beta_overlap)
+       &  use_beta_overlap, use_vectorizable_generator)
     use parkind1, only           : jprb
 …
     ! overlap parameter of Shonk et al. (2010), and needs to be
     ! converted to alpha.
+    logical, intent(in), optional :: is_beta_overlap
+    logical, intent(in), optional :: use_beta_overlap
+    ! Do we use the more vectorizable cloud generator, at the expense
+    ! of more random numbers being needed?
+    logical, intent(in), optional :: use_vectorizable_generator
     ! Outputs
 …
     real(jprb), dimension(nlev-1) :: pair_cloud_cover, overhang
+    logical :: use_vec_gen
     real(jprb) :: hook_handle
 …
     if (i_overlap_scheme == IOverlapExponentialRandom) then
       call cum_cloud_cover_exp_ran(nlev, frac, overlap_param, &
            &   cum_cloud_cover, pair_cloud_cover, is_beta_overlap)
+           &   cum_cloud_cover, pair_cloud_cover, use_beta_overlap)
     else if (i_overlap_scheme == IOverlapMaximumRandom) then
       call cum_cloud_cover_max_ran(nlev, frac, &
 …
     else if (i_overlap_scheme == IOverlapExponential) then
       call cum_cloud_cover_exp_exp(nlev, frac, overlap_param, &
            &   cum_cloud_cover, pair_cloud_cover, is_beta_overlap)
+           &   cum_cloud_cover, pair_cloud_cover, use_beta_overlap)
     else
       write(nulerr,'(a)') '*** Error: cloud overlap scheme not recognised'
 …
       od_scaling = 0.0_jprb
+      ! Expensive operation: initialize random number generator for
+      ! this column
+      call initialize_random_numbers(iseed, random_stream)
+      ! Compute ng random numbers to use to locate cloud top
+      call uniform_distribution(rand_top, random_stream)
+      ! Loop over ng columns
+      do jg = 1,ng
+        ! Find the cloud top height corresponding to the current
+        ! random number, and store in itrigger
+        trigger = rand_top(jg) * total_cloud_cover
+        jlev = ibegin
+        do while (trigger > cum_cloud_cover(jlev) .and. jlev < iend)
+          jlev = jlev + 1
+      if (present(use_vectorizable_generator)) then
+        use_vec_gen = use_vectorizable_generator
+      else
+        use_vec_gen = .false.
+      end if
+      if (.not. use_vec_gen) then
+        ! Original generator that minimizes the number of random
+        ! numbers used, but is not vectorizable
+        ! Expensive operation: initialize random number generator for
+        ! this column
+        call initialize_random_numbers(iseed, random_stream)
+        ! Compute ng random numbers to use to locate cloud top
+        call uniform_distribution(rand_top, random_stream)
+        ! Loop over ng columns
+        do jg = 1,ng
+          ! Find the cloud top height corresponding to the current
+          ! random number, and store in itrigger
+          trigger = rand_top(jg) * total_cloud_cover
+          jlev = ibegin
+          do while (trigger > cum_cloud_cover(jlev) .and. jlev < iend)
+            jlev = jlev + 1
+          end do
+          itrigger = jlev
+          if (i_overlap_scheme /= IOverlapExponential) then
+            call generate_column_exp_ran(ng, nlev, jg, random_stream, pdf_sampler, &
+                 &  frac, pair_cloud_cover, &
+                 &  cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, &
+                 &  itrigger, iend, od_scaling)
+          else
+            call generate_column_exp_exp(ng, nlev, jg, random_stream, pdf_sampler, &
+                 &  frac, pair_cloud_cover, &
+                 &  cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, &
+                 &  itrigger, iend, od_scaling)
+          end if
         end do
+        itrigger = jlev
+        if (i_overlap_scheme /= IOverlapExponential) then
+          call generate_column_exp_ran(ng, nlev, jg, random_stream, pdf_sampler, &
+               &  frac, pair_cloud_cover, &
+               &  cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, &
+               &  itrigger, iend, od_scaling)
+        else
+          call generate_column_exp_exp(ng, nlev, jg, random_stream, pdf_sampler, &
+               &  frac, pair_cloud_cover, &
+               &  cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, &
+               &  itrigger, iend, od_scaling)
+      else
+        ! Alternative generator (only for Exp-Ran overlap so far) that
+        ! should be vectorizable but generates more random numbers,
+        ! some of which are not used
+        if (i_overlap_scheme == IOverlapExponential) then
+          write(nulerr,'(a)') '*** Error: vectorizable cloud generator is not available with Exp-Exp overlap'
+          call radiation_abort()
         end if
+      end do
+        call generate_columns_exp_ran(ng, nlev, iseed, pdf_sampler, &
+             &  total_cloud_cover, frac_threshold, frac, pair_cloud_cover, &
+             &  cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, &
+             &  ibegin, iend, od_scaling)
+      end if
     end if
     if (lhook) call dr_hook('radiation_cloud_generator:cloud_generator',1,hook_handle)
 …
     ! Sample from a lognormal or gamma distribution to obtain the
+    ! optical depth scalings, calling the faster masked version and
+    ! assuming values outside the range itrigger:iend are already zero
+    ! optical depth scalings
+    ! Masked version assuming values outside the range itrigger:iend
+    ! are already zero:
     call pdf_sampler%masked_sample(n_layers_to_scale, &
          &  fractional_std(itrigger:iend), &
 …
          &  is_cloudy(itrigger:iend))
+    ! ! IFS version:
+    ! !$omp simd
+    ! do jlev=itrigger,iend
+    !    if (.not. is_cloudy(jlev)) then
+    !       od_scaling(ig,jlev) = 0.0_jprb
+    !    else
+    !       call sample_from_pdf_simd(&
+    !            pdf_sampler,fractional_std(jlev),&
+    !            rand_inhom1(jlev-itrigger+1), &
+    !            od_scaling(ig,jlev))
+    !    end if
+    ! end do
   end subroutine generate_column_exp_exp
+  !---------------------------------------------------------------------
+  ! Extract the value of a lognormal distribution with fractional
+  ! standard deviation "fsd" corresponding to the cumulative
+  ! distribution function value "cdf", and return it in x. Since this
+  ! is an elemental subroutine, fsd, cdf and x may be arrays. SIMD version.
+  subroutine sample_from_pdf_simd(this, fsd, cdf, x)
+    use parkind1,              only : jprb
+    use radiation_pdf_sampler, only : pdf_sampler_type
+    implicit none
+#if defined(__GFORTRAN__) || defined(__PGI) || defined(__NEC__)
+#else
+    !$omp declare simd(sample_from_pdf_simd) uniform(this) &
+    !$omp linear(ref(fsd)) linear(ref(cdf))
+#endif
+    type(pdf_sampler_type), intent(in)  :: this
+    ! Fractional standard deviation (0 to 4) and cumulative
+    ! distribution function (0 to 1)
+    real(jprb),              intent(in)  :: fsd, cdf
+    ! Sample from distribution
+    real(jprb),              intent(out) :: x
+    ! Index to look-up table
+    integer    :: ifsd, icdf
+    ! Weights in bilinear interpolation
+    real(jprb) :: wfsd, wcdf
+    ! Bilinear interpolation with bounds
+    wcdf = cdf * (this%ncdf-1) + 1.0_jprb
+    icdf = max(1, min(int(wcdf), this%ncdf-1))
+    wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb))
+    wfsd = (fsd-this%fsd1) * this%inv_fsd_interval + 1.0_jprb
+    ifsd = max(1, min(int(wfsd), this%nfsd-1))
+    wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb))
+    x =      (1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf  ,ifsd)   &
+         & + (1.0_jprb-wcdf)*          wfsd  * this%val(icdf  ,ifsd+1) &
+         & +           wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd)   &
+         & +           wcdf *          wfsd  * this%val(icdf+1,ifsd+1)
+  end subroutine sample_from_pdf_simd
+  !---------------------------------------------------------------------
+  ! Generate columns of optical depth scalings using
+  ! exponential-random overlap (which includes maximum-random overlap
+  ! as a limiting case).  This version is intended to work better on
+  ! hardware with long vector lengths.  As with all calculations in
+  ! this file, we zoom into the fraction of the column with cloud at
+  ! any height, so that all spectral intervals see a cloud somewhere.
+  ! In the McICA solver, this is combined appropriately with the
+  ! clear-sky calculation.
+  subroutine generate_columns_exp_ran(ng, nlev, iseed, pdf_sampler, &
+       &  total_cloud_cover, frac_threshold, frac, pair_cloud_cover, &
+       &  cum_cloud_cover, overhang, fractional_std, overlap_param_inhom, &
+       &  ibegin, iend, od_scaling)
+    use parkind1,              only : jprb
+    use radiation_pdf_sampler, only : pdf_sampler_type
+    use radiation_random_numbers, only : rng_type, IRngMinstdVector, IRngNative
+    implicit none
+    ! Number of g points / columns
+    integer, intent(in) :: ng
+    ! Number of levels
+    integer, intent(in) :: nlev
+    integer, intent(in) :: iseed ! seed for random number generator
+    ! Stream for producing random numbers
+    !type(randomnumberstream) :: random_stream
+    type(rng_type) :: random_number_generator
+    ! Object for sampling from a lognormal or gamma distribution
+    type(pdf_sampler_type), intent(in) :: pdf_sampler
+    ! Total cloud cover using cloud fraction and overlap parameter
+    real(jprb), intent(in) :: total_cloud_cover
+    real(jprb), intent(in) :: frac_threshold
+    ! Cloud fraction, cumulative cloud cover and fractional standard
+    ! deviation in each layer
+    real(jprb), intent(in), dimension(nlev) :: frac, cum_cloud_cover, fractional_std
+    ! Cloud cover of a pair of layers, and amount by which cloud at
+    ! next level increases total cloud cover as seen from above
+    real(jprb), intent(in), dimension(nlev-1) :: pair_cloud_cover, overhang
+    ! Overlap parameter of inhomogeneities
+    real(jprb), intent(in), dimension(nlev-1) :: overlap_param_inhom
+    ! Top of highest cloudy layer and base of lowest
+    integer, intent(inout) :: ibegin, iend
+    ! Optical depth scaling to output
+    real(jprb), intent(inout), dimension(ng,nlev) :: od_scaling
+    ! Loop indices
+    integer :: jlev, jg
+    real(jprb) :: rand_cloud(ng,ibegin:iend)
+    real(jprb) :: rand_inhom(ng,ibegin-1:iend), rand_inhom2(ng,ibegin:iend)
+    ! Is the cloud fraction above the minimum threshold at each level
+    logical :: is_any_cloud(ibegin:iend)
+    ! Scaled random number for finding cloud
+    real(jprb) :: trigger(ng)
+    logical :: is_cloud(ng)    ! Is there cloud at this level and spectral interval?
+    logical :: prev_cloud(ng)  ! Was there cloud at level above?
+    logical :: first_cloud(ng) ! At level of first cloud counting down from top?
+    logical :: found_cloud(ng) ! Cloud found in this column counting down from top?
+    is_any_cloud = (frac(ibegin:iend) >= frac_threshold)
+    ! Initialize random number generator for this column, and state
+    ! that random numbers will be requested in blocks of length the
+    ! number of spectral intervals ng.
+    call random_number_generator%initialize(IRngMinstdVector, iseed=iseed, &
+         &                                  nmaxstreams=ng)
+    ! Random numbers to use to locate cloud top
+    call random_number_generator%uniform_distribution(trigger)
+    ! Random numbers to work out whether to transition vertically from
+    ! clear to cloudy, cloudy to clear, clear to clear or cloudy to
+    ! cloudy
+    call random_number_generator%uniform_distribution(rand_cloud, is_any_cloud)
+    ! Random numbers to generate sub-grid cloud structure
+    call random_number_generator%uniform_distribution(rand_inhom)
+    call random_number_generator%uniform_distribution(rand_inhom2, is_any_cloud)
+    trigger = trigger * total_cloud_cover
+    ! Initialize logicals for clear-sky above first cloudy layer
+    found_cloud = .false.
+    is_cloud    = .false.
+    first_cloud = .false.
+    ! Loop down through layers starting at the first cloudy layer
+    do jlev = ibegin,iend
+      if (is_any_cloud(jlev)) then
+! Added for DWD (2020)
+!NEC$ shortloop
+        do jg = 1,ng
+          ! The intention is that all these operations are vectorizable,
+          ! since all are vector operations on vectors of length ng...
+          ! Copy the cloud mask between levels
+          prev_cloud(jg) = is_cloud(jg)
+          ! For each spectral interval, has the first cloud appeared at this level?
+          first_cloud(jg) = (trigger(jg) <= cum_cloud_cover(jlev) .and. .not. found_cloud(jg))
+          ! ...if so, add to found_cloud
+          found_cloud(jg) = found_cloud(jg) .or. first_cloud(jg)
+          ! There is cloud at this level either if a first cloud has
+          ! appeared, or using separate probability calculations
+          ! depending on whether there is a cloud above (given by
+          ! prev_cloud)
+          is_cloud(jg) = first_cloud(jg) &
+               &  .or. found_cloud(jg) .and. merge(rand_cloud(jg,jlev)*frac(jlev-1) &
+               &               < frac(jlev)+frac(jlev-1)-pair_cloud_cover(jlev-1), &
+               &             rand_cloud(jg,jlev)*(cum_cloud_cover(jlev-1) - frac(jlev-1)) &
+               &               < pair_cloud_cover(jlev-1) - overhang(jlev-1) - frac(jlev-1), &
+               &             prev_cloud(jg))
+          ! The random number determining cloud structure decorrelates
+          ! with the one above it according to the overlap parameter,
+          ! but always decorrelates if there is clear-sky above.  If
+          ! there is clear-sky in the present level, the random number
+          ! is set to zero to ensure that the optical depth scaling is
+          ! also zero.
+          rand_inhom(jg,jlev) = merge(merge(rand_inhom(jg,jlev-1), rand_inhom(jg,jlev), &
+               &                           rand_inhom2(jg,jlev) < overlap_param_inhom(jlev-1) &
+               &                           .and. prev_cloud(jg)), &
+               &                     0.0_jprb, is_cloud(jg))
+        end do
+      else
+        ! No cloud at this level
+        is_cloud = .false.
+      end if
+    end do
+    ! Sample from a lognormal or gamma distribution to obtain the
+    ! optical depth scalings, calling the faster masked version and
+    ! assuming values outside the range ibegin:iend are already zero
+    call pdf_sampler%masked_block_sample(iend-ibegin+1, ng, &
+         &  fractional_std(ibegin:iend), &
+         &  rand_inhom(:,ibegin:iend), od_scaling(:,ibegin:iend), &
+         &  is_any_cloud)
+  end subroutine generate_columns_exp_ran
 end module radiation_cloud_generator

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_cloud_optics.F90

-                      r3908
+                      r4444
   implicit none
   public
 …
     type(cloud_optics_type), pointer :: ho
     integer    :: jcol, jlev
+    integer    :: jcol, jlev, jb
     real(jprb) :: hook_handle
 …
             end if
+            ! Delta-Eddington scaling in the shortwave only
             if (.not. config%do_sw_delta_scaling_with_gases) then
-              ! Delta-Eddington scaling in the shortwave only
               call delta_eddington_scat_od(od_sw_liq, scat_od_sw_liq, g_sw_liq)
             end if
+            !call delta_eddington_scat_od(od_lw_liq, scat_od_lw_liq, g_lw_liq)
           else
             ! Liquid not present: set properties to zero
 …
             end if
+            ! Delta-Eddington scaling in both longwave and shortwave
+            ! (assume that particles are larger than wavelength even
+            ! in longwave)
             if (.not. config%do_sw_delta_scaling_with_gases) then
-              ! Delta-Eddington scaling in both longwave and shortwave
-              ! (assume that particles are larger than wavelength even
-              ! in longwave)
               call delta_eddington_scat_od(od_sw_ice, scat_od_sw_ice, g_sw_ice)
             end if
             call delta_eddington_scat_od(od_lw_ice, scat_od_lw_ice, g_lw_ice)
           else
             ! Ice not present: set properties to zero
 …
           ! Combine liquid and ice
           if (config%do_lw_cloud_scattering) then
+            od_lw_cloud(:,jlev,jcol) = od_lw_liq + od_lw_ice
+            where (scat_od_lw_liq+scat_od_lw_ice > 0.0_jprb)
+              g_lw_cloud(:,jlev,jcol) = (g_lw_liq * scat_od_lw_liq &
+                   &  + g_lw_ice * scat_od_lw_ice) &
+                   &  / (scat_od_lw_liq+scat_od_lw_ice)
+            elsewhere
+              g_lw_cloud(:,jlev,jcol) = 0.0_jprb
+            end where
+            ssa_lw_cloud(:,jlev,jcol) = (scat_od_lw_liq + scat_od_lw_ice) &
+                 &                    / (od_lw_liq + od_lw_ice)
+! Added for DWD (2020)
+!NEC$ shortloop
+            do jb = 1, config%n_bands_lw
+              od_lw_cloud(jb,jlev,jcol) = od_lw_liq(jb) + od_lw_ice(jb)
+              if (scat_od_lw_liq(jb)+scat_od_lw_ice(jb) > 0.0_jprb) then
+                g_lw_cloud(jb,jlev,jcol) = (g_lw_liq(jb) * scat_od_lw_liq(jb) &
+                   &  + g_lw_ice(jb) * scat_od_lw_ice(jb)) &
+                   &  / (scat_od_lw_liq(jb)+scat_od_lw_ice(jb))
+              else
+                g_lw_cloud(jb,jlev,jcol) = 0.0_jprb
+              end if
+              ssa_lw_cloud(jb,jlev,jcol) = (scat_od_lw_liq(jb) + scat_od_lw_ice(jb)) &
+                 &                    / (od_lw_liq(jb) + od_lw_ice(jb))
+            end do
           else
             ! If longwave scattering is to be neglected then the
             ! best approximation is to set the optical depth equal
             ! to the absorption optical depth
+            od_lw_cloud(:,jlev,jcol) = od_lw_liq - scat_od_lw_liq &
+                 &                   + od_lw_ice - scat_od_lw_ice
+! Added for DWD (2020)
+!NEC$ shortloop
+            do jb = 1, config%n_bands_lw
+              od_lw_cloud(jb,jlev,jcol) = od_lw_liq(jb) - scat_od_lw_liq(jb) &
+                    &                   + od_lw_ice(jb) - scat_od_lw_ice(jb)
+            end do
           end if
+          od_sw_cloud(:,jlev,jcol) = od_sw_liq + od_sw_ice
+          g_sw_cloud(:,jlev,jcol) = (g_sw_liq * scat_od_sw_liq &
+               &  + g_sw_ice * scat_od_sw_ice) &
+               &  / (scat_od_sw_liq + scat_od_sw_ice)
+          ssa_sw_cloud(:,jlev,jcol) &
+               &  = (scat_od_sw_liq + scat_od_sw_ice) / (od_sw_liq + od_sw_ice)
+! Added for DWD (2020)
+!NEC$ shortloop
+          do jb = 1, config%n_bands_sw
+            od_sw_cloud(jb,jlev,jcol) = od_sw_liq(jb) + od_sw_ice(jb)
+            g_sw_cloud(jb,jlev,jcol) = (g_sw_liq(jb) * scat_od_sw_liq(jb) &
+               &  + g_sw_ice(jb) * scat_od_sw_ice(jb)) &
+               &  / (scat_od_sw_liq(jb) + scat_od_sw_ice(jb))
+            ssa_sw_cloud(jb,jlev,jcol) &
+               &  = (scat_od_sw_liq(jb) + scat_od_sw_ice(jb)) / (od_sw_liq(jb) + od_sw_ice(jb))
+          end do
         end if ! Cloud present
       end do ! Loop over column

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_config.F90

-                      r4115
+                      r4444
 !   2019-02-03  R. Hogan  Added ability to fix out-of-physical-bounds inputs
 !   2019-02-10  R. Hogan  Renamed "encroachment" to "entrapment"
+!   2020-05-18  R. Hogan  Moved out_of_bounds_* to radiation_check.F90
+!   2021-07-04  R. Hogan  Numerous changes for ecCKD and general cloud/aerosol optics
+!
 ! Note: The aim is for ecRad in the IFS to be as similar as possible
 …
   use radiation_cloud_optics_data,   only : cloud_optics_type
+  use radiation_general_cloud_optics_data,   only : general_cloud_optics_type
   use radiation_aerosol_optics_data, only : aerosol_optics_type
   use radiation_pdf_sampler,         only : pdf_sampler_type
   use radiation_cloud_cover,         only : OverlapName, &
        & IOverlapMaximumRandom, IOverlapExponentialRandom, IOverlapExponential
+  use radiation_ecckd,               only : ckd_model_type
   implicit none
 …
        & IEntrapmentExplicitNonFractal, & ! As above but ignore fractal nature of clouds
        & IEntrapmentMaximum ! Complete horizontal homogenization within regions (old SPARTACUS assumption)
   end enum
 …
   ! Gas models
   enum, bind(c)
      enumerator IGasModelMonochromatic, IGasModelIFSRRTMG
+     enumerator IGasModelMonochromatic, IGasModelIFSRRTMG, IGasModelECCKD
   end enum
+  character(len=*), parameter :: GasModelName(0:1) = (/ 'Monochromatic', &
+       &                                                'RRTMG-IFS    ' /)
+  character(len=*), parameter :: GasModelName(0:2) = (/ 'Monochromatic', &
+       &                                                'RRTMG-IFS    ', &
+       &                                                'ECCKD        '/)
   ! Hydrometeor scattering models
 …
   integer, parameter :: NMaxAerosolTypes = 256
+  ! Maximum number of different cloud types that can be provided
+  integer, parameter :: NMaxCloudTypes = 12
   ! Maximum number of shortwave albedo and longwave emissivity
   ! intervals
 …
     character(len=511) :: directory_name = '.'
+    ! If this is true then support arbitrary hydrometeor types (not
+    ! just ice and liquid) and arbitrary spectral discretization (not
+    ! just RRTMG). It is required that this is true if the ecCKD gas
+    ! optics model is selected. General cloud optics has only been
+    ! available from ecRad version 1.5.
+    logical :: use_general_cloud_optics = .true.
+    ! If this is true then support aerosol properties at an arbitrary
+    ! spectral discretization (not just RRTMG). It is required that
+    ! this is true if the ecCKD gas optics model is selected.
+    logical :: use_general_aerosol_optics = .true.
     ! Cloud is deemed to be present in a layer if cloud fraction
     ! exceeds this value
 …
     ! (2000)?
     logical :: use_beta_overlap = .false.
+    ! Use a more vectorizable McICA cloud generator, at the expense of
+    ! more random numbers being generated?  This is the default on NEC
+    ! SX.
+#ifdef __SX__
+    logical :: use_vectorizable_generator = .true.
+#else
+    logical :: use_vectorizable_generator = .false.
+#endif
     ! Shape of sub-grid cloud water PDF
 …
     logical :: do_sw_delta_scaling_with_gases = .false.
+    ! Codes describing the gas and cloud scattering models to use, the
+    ! latter of which is currently not used
+    ! Codes describing the gas model
     integer :: i_gas_model = IGasModelIFSRRTMG
-    !     integer :: i_cloud_model
     ! Optics if i_gas_model==IGasModelMonochromatic.
 …
     ! according to the spectral overlap of each interval with each
     ! band
     logical :: do_nearest_spectral_sw_albedo = .true.
     logical :: do_nearest_spectral_lw_emiss  = .true.
+    logical :: do_nearest_spectral_sw_albedo = .false.
+    logical :: do_nearest_spectral_lw_emiss  = .false.
     ! User-defined monotonically increasing wavelength bounds (m)
     ! between input surface albedo/emissivity intervals. Implicitly
+    ! the first interval starts at zero and the last ends at infinity.
+    ! the first interval starts at zero and the last ends at
+    ! infinity. These must be set with define_sw_albedo_intervals and
+    ! define_lw_emiss_intervals.
     real(jprb) :: sw_albedo_wavelength_bound(NMaxAlbedoIntervals-1) = -1.0_jprb
     real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1)  = -1.0_jprb
+    real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1) = -1.0_jprb
     ! The index to the surface albedo/emissivity intervals for each of
 …
     logical :: do_3d_effects = .true.
+    character(len=511) :: cloud_type_name(NMaxCloudTypes) = ["","","","","","","","","","","",""]
+! &
+!         &   = ["mie_droplet                   ", &
+!         &      "baum-general-habit-mixture_ice"]
+    ! Spectral averaging method to use with generalized cloud optics;
+    ! see Edwards & Slingo (1996) for definition.  Experimentation
+    ! with ecRad suggests that "thick" averaging is more accurate for
+    ! both liquid and ice clouds.
+    logical :: use_thick_cloud_spectral_averaging(NMaxCloudTypes) &
+         &  = [.true.,.true.,.true.,.true.,.true.,.true., &
+         &     .true.,.true.,.true.,.true.,.true.,.true.]
     ! To what extent do we include "entrapment" effects in the
     ! SPARTACUS solver? This essentially means that in a situation
 …
     ! doesn't start with a '/' character then it will be prepended by
     ! the contents of directory_name.
     character(len=511) :: ice_optics_override_file_name = ''
     character(len=511) :: liq_optics_override_file_name = ''
+    character(len=511) :: ice_optics_override_file_name     = ''
+    character(len=511) :: liq_optics_override_file_name     = ''
     character(len=511) :: aerosol_optics_override_file_name = ''
+    character(len=511) :: gas_optics_sw_override_file_name  = ''
+    character(len=511) :: gas_optics_lw_override_file_name  = ''
     ! Optionally override the look-up table file for the cloud-water
 …
     character(len=511) :: cloud_pdf_override_file_name = ''
+    ! Do we compute cloud, aerosol and surface optical properties per
+    ! g point?  Not available with RRTMG gas optics model.
+    logical :: do_cloud_aerosol_per_sw_g_point = .true.
+    logical :: do_cloud_aerosol_per_lw_g_point = .true.
+    ! Do we weight the mapping from surface emissivity/albedo to
+    ! g-point/band weighting by a reference Planck function (more
+    ! accurate) or weighting each wavenumber equally (less accurate
+    ! but consistent with IFS Cycle 48r1 and earlier)?
+    logical :: do_weighted_surface_mapping = .true.
+    ! COMPUTED PARAMETERS
+    ! Users of this library should not edit these parameters directly;
+    ! they are set by the "consolidate" routine
     ! Has "consolidate" been called?
     logical :: is_consolidated = .false.
+    ! COMPUTED PARAMETERS
+    ! Users of this library should not edit these parameters directly;
+    ! they are set by the "consolidate" routine
+    ! Wavenumber range for each band, in cm-1, which will be allocated
+    ! to be of length n_bands_sw or n_bands_lw
+    real(jprb), allocatable, dimension(:) :: wavenumber1_sw
+    real(jprb), allocatable, dimension(:) :: wavenumber2_sw
+    real(jprb), allocatable, dimension(:) :: wavenumber1_lw
+    real(jprb), allocatable, dimension(:) :: wavenumber2_lw
+    ! Fraction of each g point in each wavenumber interval,
+    ! dimensioned (n_wav_frac_[l|s]w, n_g_[l|s]w)
+    real(jprb), allocatable, dimension(:,:) :: g_frac_sw, g_frac_lw
     ! If the nearest surface albedo/emissivity interval is to be used
 …
     integer :: n_canopy_bands_lw = 1
+    ! Data structures containing gas optics description in the case of
+    ! ecCKD
+    type(ckd_model_type)         :: gas_optics_sw, gas_optics_lw
     ! Data structure containing cloud scattering data
     type(cloud_optics_type)      :: cloud_optics
+    ! Number of general cloud types, default liquid and ice
+    integer :: n_cloud_types = 2
+    ! List of data structures (one per cloud type) containing cloud
+    ! scattering data
+    type(general_cloud_optics_type), allocatable :: cloud_optics_sw(:)
+    type(general_cloud_optics_type), allocatable :: cloud_optics_lw(:)
     ! Data structure containing aerosol scattering data
 …
     character(len=511) :: ice_optics_file_name, &
          &                liq_optics_file_name, &
+         &                aerosol_optics_file_name
+         &                aerosol_optics_file_name, &
+         &                gas_optics_sw_file_name, &
+         &                gas_optics_lw_file_name
     ! McICA PDF look-up table file name
 …
     ! g points or the number of bands
     integer :: n_spec_sw = 0, n_spec_lw = 0
+    ! Number of wavenumber intervals used to describe the mapping from
+    ! g-points to wavenumber space
+    integer :: n_wav_frac_sw = 0, n_wav_frac_lw = 0
     ! Dimensions to store variables that are only needed if longwave
 …
      procedure :: define_sw_albedo_intervals
      procedure :: define_lw_emiss_intervals
+     procedure :: consolidate_intervals
+     procedure :: set_aerosol_wavelength_mono
+     procedure :: consolidate_sw_albedo_intervals
+     procedure :: consolidate_lw_emiss_intervals
   end type config_type
 …
     logical :: do_sw, do_lw, do_clear, do_sw_direct
     logical :: do_3d_effects, use_expm_everywhere, use_aerosols
+    logical :: use_general_cloud_optics, use_general_aerosol_optics
     logical :: do_lw_side_emissivity
     logical :: do_3d_lw_multilayer_effects, do_fu_lw_ice_optics_bug
 …
     logical :: do_save_radiative_properties, do_save_spectral_flux
     logical :: do_save_gpoint_flux, do_surface_sw_spectral_flux
     logical :: use_beta_overlap, do_lw_derivatives
+    logical :: use_beta_overlap, do_lw_derivatives, use_vectorizable_generator
     logical :: do_sw_delta_scaling_with_gases
     logical :: do_canopy_fluxes_sw, do_canopy_fluxes_lw
     logical :: use_canopy_full_spectrum_sw, use_canopy_full_spectrum_lw
     logical :: do_canopy_gases_sw, do_canopy_gases_lw
+    logical :: do_cloud_aerosol_per_sw_g_point, do_cloud_aerosol_per_lw_g_point
+    logical :: do_weighted_surface_mapping
     integer :: n_regions, iverbose, iverbosesetup, n_aerosol_types
     real(jprb):: mono_lw_wavelength, mono_lw_total_od, mono_sw_total_od
 …
     character(511) :: liq_optics_override_file_name, ice_optics_override_file_name
     character(511) :: cloud_pdf_override_file_name
+    character(511) :: gas_optics_sw_override_file_name, gas_optics_lw_override_file_name
     character(63)  :: liquid_model_name, ice_model_name, gas_model_name
     character(63)  :: sw_solver_name, lw_solver_name, overlap_scheme_name
     character(63)  :: sw_entrapment_name, sw_encroachment_name, cloud_pdf_shape_name
+    character(len=511) :: cloud_type_name(NMaxCloudTypes) = ["","","","","","","","","","","",""]
+    logical :: use_thick_cloud_spectral_averaging(NMaxCloudTypes) &
+         &  = [.false.,.false.,.false.,.false.,.false.,.false., &
+         &     .false.,.false.,.false.,.false.,.false.,.false.]
     integer :: i_aerosol_type_map(NMaxAerosolTypes) ! More than 256 is an error
     logical :: do_nearest_spectral_sw_albedo = .true.
     logical :: do_nearest_spectral_lw_emiss  = .true.
+    logical :: do_nearest_spectral_sw_albedo
+    logical :: do_nearest_spectral_lw_emiss
     real(jprb) :: sw_albedo_wavelength_bound(NMaxAlbedoIntervals-1)
     real(jprb) :: lw_emiss_wavelength_bound( NMaxAlbedoIntervals-1)
 …
     integer :: iunit ! Unit number of namelist file
-    logical :: lldeb_conf = .false.
     namelist /radiation/ do_sw, do_lw, do_sw_direct, &
 …
          &  ice_optics_override_file_name, liq_optics_override_file_name, &
          &  aerosol_optics_override_file_name, cloud_pdf_override_file_name, &
+         &  gas_optics_sw_override_file_name, gas_optics_lw_override_file_name, &
          &  liquid_model_name, ice_model_name, max_3d_transfer_rate, &
          &  min_cloud_effective_size, overhang_factor, encroachment_scaling, &
 …
          &  do_canopy_fluxes_sw, do_canopy_fluxes_lw, &
          &  do_canopy_gases_sw, do_canopy_gases_lw, &
+         &  use_general_cloud_optics, use_general_aerosol_optics, &
          &  do_sw_delta_scaling_with_gases, overlap_scheme_name, &
          &  sw_solver_name, lw_solver_name, use_beta_overlap, &
+         &  sw_solver_name, lw_solver_name, use_beta_overlap, use_vectorizable_generator, &
          &  use_expm_everywhere, iverbose, iverbosesetup, &
          &  cloud_inhom_decorr_scaling, cloud_fraction_threshold, &
 …
          &  mono_lw_single_scattering_albedo, mono_sw_single_scattering_albedo, &
          &  mono_lw_asymmetry_factor, mono_sw_asymmetry_factor, &
          &  cloud_pdf_shape_name, &
+         &  cloud_pdf_shape_name, cloud_type_name, use_thick_cloud_spectral_averaging, &
          &  do_nearest_spectral_sw_albedo, do_nearest_spectral_lw_emiss, &
          &  sw_albedo_wavelength_bound, lw_emiss_wavelength_bound, &
+         &  i_sw_albedo_index, i_lw_emiss_index
+         &  i_sw_albedo_index, i_lw_emiss_index, &
+         &  do_cloud_aerosol_per_lw_g_point, &
+         &  do_cloud_aerosol_per_sw_g_point, do_weighted_surface_mapping
     real(jprb) :: hook_handle
 …
     ice_optics_override_file_name = this%ice_optics_override_file_name
     aerosol_optics_override_file_name = this%aerosol_optics_override_file_name
+    gas_optics_sw_override_file_name = this%gas_optics_sw_override_file_name
+    gas_optics_lw_override_file_name = this%gas_optics_lw_override_file_name
     use_expm_everywhere = this%use_expm_everywhere
     use_aerosols = this%use_aerosols
 …
     iverbose = this%iverbose
     iverbosesetup = this%iverbosesetup
+    use_general_cloud_optics = this%use_general_cloud_optics
+    use_general_aerosol_optics = this%use_general_aerosol_optics
     cloud_fraction_threshold = this%cloud_fraction_threshold
     cloud_mixing_ratio_threshold = this%cloud_mixing_ratio_threshold
     use_beta_overlap = this%use_beta_overlap
+    use_vectorizable_generator = this%use_vectorizable_generator
     cloud_inhom_decorr_scaling = this%cloud_inhom_decorr_scaling
     clear_to_thick_fraction = this%clear_to_thick_fraction
 …
     max_3d_transfer_rate = this%max_3d_transfer_rate
     min_cloud_effective_size = this%min_cloud_effective_size
+    cloud_type_name = this%cloud_type_name
+    use_thick_cloud_spectral_averaging = this%use_thick_cloud_spectral_averaging
     overhang_factor = this%overhang_factor
     encroachment_scaling = -1.0_jprb
 …
     i_sw_albedo_index             = this%i_sw_albedo_index
     i_lw_emiss_index              = this%i_lw_emiss_index
+    do_cloud_aerosol_per_lw_g_point = this%do_cloud_aerosol_per_lw_g_point
+    do_cloud_aerosol_per_sw_g_point = this%do_cloud_aerosol_per_sw_g_point
+    do_weighted_surface_mapping   = this%do_weighted_surface_mapping
     if (present(file_name) .and. present(unit)) then
 …
       end if
     else
+      ! This version exits correctly, but provides less information
+      ! about how the namelist was incorrect
       read(unit=iunit, iostat=iosread, nml=radiation)
+      ! Depending on compiler this version provides more information
+      ! about the error in the namelist
+      !read(unit=iunit, nml=radiation)
       if (iosread /= 0) then
         ! An error occurred reading the file
 …
     this%mono_sw_asymmetry_factor = mono_sw_asymmetry_factor
     this%use_beta_overlap = use_beta_overlap
+    this%use_vectorizable_generator = use_vectorizable_generator
     this%cloud_inhom_decorr_scaling = cloud_inhom_decorr_scaling
     this%clear_to_thick_fraction = clear_to_thick_fraction
 …
     this%max_3d_transfer_rate = max_3d_transfer_rate
     this%min_cloud_effective_size = max(1.0e-6_jprb, min_cloud_effective_size)
+    this%cloud_type_name = cloud_type_name
+    this%use_thick_cloud_spectral_averaging = use_thick_cloud_spectral_averaging
     if (encroachment_scaling >= 0.0_jprb) then
       this%overhang_factor = encroachment_scaling
 …
     this%ice_optics_override_file_name = ice_optics_override_file_name
     this%aerosol_optics_override_file_name = aerosol_optics_override_file_name
+    this%gas_optics_sw_override_file_name = gas_optics_sw_override_file_name
+    this%gas_optics_lw_override_file_name = gas_optics_lw_override_file_name
+    this%use_general_cloud_optics      = use_general_cloud_optics
+    this%use_general_aerosol_optics    = use_general_aerosol_optics
     this%cloud_fraction_threshold = cloud_fraction_threshold
     this%cloud_mixing_ratio_threshold = cloud_mixing_ratio_threshold
 …
     this%i_sw_albedo_index             = i_sw_albedo_index
     this%i_lw_emiss_index              = i_lw_emiss_index
+! AI mars 2022
+if (lldeb_conf) then
+print*,'**************PARAMETRES DE CONFIGURATION OFFLINE*******************'
+print*,'config%iverbosesetup   = ', iverbosesetup
+print*,'config%do_lw   = ', do_lw
+print*,'config%do_sw   = ', do_sw
+print*,'config%do_clear   = ', do_clear
+print*,'config%do_sw_direct   = ', do_sw_direct
+print*,'config%do_3d_effects   = ', do_3d_effects
+print*,'config%do_3d_lw_multilayer_effects   = ', do_3d_lw_multilayer_effects
+print*,'config%do_lw_side_emissivity   = ', do_lw_side_emissivity
+print*,'config%use_expm_everywhere   = ', use_expm_everywhere
+print*,'config%use_aerosols   = ', use_aerosols
+print*,'config%do_lw_cloud_scattering   = ', do_lw_cloud_scattering
+print*,'config%do_lw_aerosol_scattering   = ', do_lw_aerosol_scattering
+print*,'config%nregions   = ', n_regions
+print*,'config%do_surface_sw_spectral_flux   = ', do_surface_sw_spectral_flux
+print*,'config%do_sw_delta_scaling_with_gases   = ', &
+do_sw_delta_scaling_with_gases
+print*,'config%do_fu_lw_ice_optics_bug   = ', do_fu_lw_ice_optics_bug
+print*,'config%do_canopy_fluxes_sw   = ', do_canopy_fluxes_sw
+print*,'config%do_canopy_fluxes_lw   = ', do_canopy_fluxes_lw
+print*,'config%use_canopy_full_spectrum_sw   = ', use_canopy_full_spectrum_sw
+print*,'config%use_canopy_full_spectrum_lw   = ', use_canopy_full_spectrum_lw
+print*,'config%do_canopy_gases_sw   = ', do_canopy_gases_sw
+print*,'config%do_canopy_gases_lw   = ', do_canopy_gases_lw
+print*,'config%mono_lw_wavelength   = ', mono_lw_wavelength
+print*,'config%mono_lw_total_od   = ', mono_lw_total_od
+print*,'config%mono_sw_total_od   = ', mono_sw_total_od
+print*,'config%mono_lw_single_scattering_albedo   = ', &
+mono_lw_single_scattering_albedo
+print*,'config%mono_sw_single_scattering_albedo   = ', &
+mono_sw_single_scattering_albedo
+print*,'config%mono_lw_asymmetry_factor   = ', mono_lw_asymmetry_factor
+print*,'config%mono_sw_asymmetry_factor   = ', mono_sw_asymmetry_factor
+print*,'config%use_beta_overlap   = ', use_beta_overlap
+print*,'config%cloud_inhom_decorr_scaling   = ', cloud_inhom_decorr_scaling
+print*,'config%clear_to_thick_fraction   = ', clear_to_thick_fraction
+print*,'config%overhead_sun_factor   = ', overhead_sun_factor
+print*,'config%max_gas_od_3d   = ', max_gas_od_3d
+print*,'config%max_cloud_od   = ', max_cloud_od
+print*,'config%max_3d_transfer_rate   = ', max_3d_transfer_rate
+print*,'config%min_cloud_effective_size   = ', &
+max(1.0e-6_jprb,min_cloud_effective_size)
+print*,'config%overhang_factor   = ', encroachment_scaling
+print*,'config%directory_name  = ',directory_name
+print*,'config%cloud_pdf_override_file_name  = ',cloud_pdf_override_file_name
+print*,'config%liq_optics_override_file_name  = ',liq_optics_override_file_name
+print*,'config%ice_optics_override_file_name  = ',ice_optics_override_file_name
+print*,'config%aerosol_optics_override_file_name  = ', &
+aerosol_optics_override_file_name
+print*,'config%cloud_fraction_threshold  = ',cloud_fraction_threshold
+print*,'config%cloud_mixing_ratio_threshold  = ',cloud_mixing_ratio_threshold
+print*,'config%n_aerosol_types  = ',n_aerosol_types
+print*,'config%do_save_radiative_properties  = ',do_save_radiative_properties
+print*,'config%do_lw_derivatives  = ',do_lw_derivatives
+print*,'config%do_save_spectral_flux  = ',do_save_spectral_flux
+print*,'config%do_save_gpoint_flux  = ',do_save_gpoint_flux
+print*,'config%do_nearest_spectral_sw_albedo  = ',do_nearest_spectral_sw_albedo
+print*,'config%do_nearest_spectral_lw_emiss   = ',do_nearest_spectral_lw_emiss
+print*,'config%sw_albedo_wavelength_bound     = ',sw_albedo_wavelength_bound
+print*,'config%lw_emiss_wavelength_bound      = ',lw_emiss_wavelength_bound
+print*,'config%i_sw_albedo_index              = ',i_sw_albedo_index
+print*,'config%i_lw_emiss_index               = ',i_lw_emiss_index
+print*,'************************************************************************'
+endif
+    this%do_cloud_aerosol_per_lw_g_point = do_cloud_aerosol_per_lw_g_point
+    this%do_cloud_aerosol_per_sw_g_point = do_cloud_aerosol_per_sw_g_point
+    this%do_weighted_surface_mapping   = do_weighted_surface_mapping
     if (do_save_gpoint_flux) then
       ! Saving the fluxes every g-point overrides saving as averaged
 …
       ! save anything
       this%do_save_spectral_flux = .true.
-      print*,'config%do_save_spectral_flux = .true.'
     end if
 …
     call get_enum_code(liquid_model_name, LiquidModelName, &
          &            'liquid_model_name', this%i_liq_model)
-    print*,'config%i_liq_model =', this%i_liq_model
     ! Determine ice optics model
     call get_enum_code(ice_model_name, IceModelName, &
          &            'ice_model_name', this%i_ice_model)
+    print*,'config%i_ice_model =', this%i_ice_model
     ! Determine gas optics model
     call get_enum_code(gas_model_name, GasModelName, &
          &            'gas_model_name', this%i_gas_model)
-    print*,'config%%i_gas_model = ', this%i_gas_model
     ! Determine solvers
     call get_enum_code(sw_solver_name, SolverName, &
          &            'sw_solver_name', this%i_solver_sw)
-    print*,'config%i_solver_sw = ', this%i_solver_sw
     call get_enum_code(lw_solver_name, SolverName, &
          &            'lw_solver_name', this%i_solver_lw)
+    print*,'config%i_solver_lw = ', this%i_solver_lw
     if (len_trim(sw_encroachment_name) > 1) then
       call get_enum_code(sw_encroachment_name, EncroachmentName, &
 …
       call get_enum_code(sw_entrapment_name, EntrapmentName, &
            &             'sw_entrapment_name', this%i_3d_sw_entrapment)
-      print*,'config%i_3d_sw_entrapment = ', this%i_3d_sw_entrapment
     end if
 …
     call get_enum_code(overlap_scheme_name, OverlapName, &
          &             'overlap_scheme_name', this%i_overlap_scheme)
     print*,'config%i_overlap_scheme = ', this%i_overlap_scheme
     ! Determine cloud PDF shape
     call get_enum_code(cloud_pdf_shape_name, PdfShapeName, &
          &             'cloud_pdf_shape_name', this%i_cloud_pdf_shape)
+    print*,'config%i_cloud_pdf_shape = ', this%i_cloud_pdf_shape
     this%i_aerosol_type_map = 0
     if (this%use_aerosols) then
       this%i_aerosol_type_map(1:n_aerosol_types) &
            &  = i_aerosol_type_map(1:n_aerosol_types)
-      print*,'config%i_aerosol_type_map = ', this%i_aerosol_type_map
     end if
 …
       this%do_clouds = .false.
     end if
+    print*,'config%do_clouds = ', this%do_clouds
+    if (this%i_gas_model == IGasModelIFSRRTMG &
+         & .and. (this%use_general_cloud_optics &
+         &        .or. this%use_general_aerosol_optics)) then
+      if (this%do_sw .and. this%do_cloud_aerosol_per_sw_g_point) then
+        write(nulout,'(a)') 'Warning: RRTMG SW only supports cloud/aerosol/surface optical properties per band, not per g-point'
+        this%do_cloud_aerosol_per_sw_g_point = .false.
+      end if
+      if (this%do_lw .and. this%do_cloud_aerosol_per_lw_g_point) then
+        write(nulout,'(a)') 'Warning: RRTMG LW only supports cloud/aerosol/surface optical properties per band, not per g-point'
+        this%do_cloud_aerosol_per_lw_g_point = .false.
+      end if
+    end if
     ! Normal subroutine exit
 …
   subroutine consolidate_config(this)
+    use parkind1,     only : jprd
     use yomhook,      only : lhook, dr_hook
     use radiation_io, only : nulout, nulerr, radiation_abort
 …
       write(nulerr,'(a)') '*** Error: SPARTACUS/Tripleclouds solvers can only do Exponential-Random overlap'
       call radiation_abort('Radiation configuration error')
+    end if
+    if (jprb < jprd .and. this%iverbosesetup >= 1 &
+         &  .and. (this%i_solver_sw == ISolverSPARTACUS &
+         &    .or. this%i_solver_lw == ISolverSPARTACUS)) then
+      write(nulout,'(a)') 'Warning: the SPARTACUS solver may be unstable in single precision'
+    end if
+    ! If ecCKD gas optics model is being used set relevant file names
+    if (this%i_gas_model == IGasModelECCKD) then
+      ! This gas optics model requires the general cloud and
+      ! aerosol optics settings
+      if (.not. this%use_general_cloud_optics) then
+        write(nulerr,'(a)') '*** Error: ecCKD gas optics model requires general cloud optics'
+        call radiation_abort('Radiation configuration error')
+      end if
+      if (.not. this%use_general_aerosol_optics) then
+        write(nulerr,'(a)') '*** Error: ecCKD gas optics model requires general aerosol optics'
+        call radiation_abort('Radiation configuration error')
+      end if
+      if (len_trim(this%gas_optics_sw_override_file_name) > 0) then
+        if (this%gas_optics_sw_override_file_name(1:1) == '/') then
+          this%gas_optics_sw_file_name = trim(this%gas_optics_sw_override_file_name)
+        else
+          this%gas_optics_sw_file_name = trim(this%directory_name) &
+               &  // '/' // trim(this%gas_optics_sw_override_file_name)
+        end if
+      else
+        ! In the IFS, the gas optics files should be specified in
+        ! ifs/module/radiation_setup.F90, not here
+        this%gas_optics_sw_file_name = trim(this%directory_name) &
+             &  // "/ecckd-1.0_sw_climate_rgb-32b_ckd-definition.nc"
+      end if
+      if (len_trim(this%gas_optics_lw_override_file_name) > 0) then
+        if (this%gas_optics_lw_override_file_name(1:1) == '/') then
+          this%gas_optics_lw_file_name = trim(this%gas_optics_lw_override_file_name)
+        else
+          this%gas_optics_lw_file_name = trim(this%directory_name) &
+               &  // '/' // trim(this%gas_optics_lw_override_file_name)
+        end if
+      else
+        ! In the IFS, the gas optics files should be specified in
+        ! ifs/module/radiation_setup.F90, not here
+        this%gas_optics_lw_file_name = trim(this%directory_name) &
+             &  // "/ecckd-1.0_lw_climate_fsck-32b_ckd-definition.nc"
+      end if
     end if
 …
       ! In the IFS, the aerosol optics file should be specified in
       ! ifs/module/radiation_setup.F90, not here
+      this%aerosol_optics_file_name &
+           &   = trim(this%directory_name) // "/aerosol_ifs_rrtm_45R2.nc"
+      if (this%use_general_aerosol_optics) then
+         this%aerosol_optics_file_name &
+             &   = trim(this%directory_name) // "/aerosol_ifs_48R1.nc"
+      else
+        this%aerosol_optics_file_name &
+             &   = trim(this%directory_name) // "/aerosol_ifs_rrtm_46R1_with_NI_AM.nc"
+      end if
     end if
 …
            &          this%i_gas_model)
       call print_logical('  Aerosols are', 'use_aerosols', this%use_aerosols)
+      call print_logical('  Clouds are', 'do_clouds', this%do_clouds)
+      if (this%use_aerosols) then
+        call print_logical('  General aerosol optics', &
+             &             'use_general_aerosol_optics', this%use_general_aerosol_optics)
+      end if
+      if (this%do_clouds) then
+        write(nulout,'(a)') '  Clouds are ON'
+      else
+        write(nulout,'(a)') '  Clouds are OFF'
+      end if
+      if (this%do_sw) then
+        call print_logical('  Do cloud/aerosol/surface SW properties per g-point', &
+             &  'do_cloud_aerosol_per_sw_g_point', this%do_cloud_aerosol_per_sw_g_point)
+      end if
+      if (this%do_lw) then
+        call print_logical('  Do cloud/aerosol/surface LW properties per g-point', &
+             &  'do_cloud_aerosol_per_lw_g_point', this%do_cloud_aerosol_per_lw_g_point)
+      end if
       !---------------------------------------------------------------------
 …
              &   'do_nearest_spectral_lw_emiss', this%do_nearest_spectral_lw_emiss)
       end if
+      call print_logical('  Planck-weighted surface albedo/emiss mapping', &
+           &   'do_weighted_surface_mapping', this%do_weighted_surface_mapping)
       !---------------------------------------------------------------------
       if (this%do_clouds) then
 …
         call print_real('  Cloud mixing-ratio threshold', &
              &   'cloud_mixing_ratio_threshold', this%cloud_mixing_ratio_threshold)
+        call print_enum('  Liquid optics scheme is', LiquidModelName, &
+             &          'i_liq_model',this%i_liq_model)
+        call print_enum('  Ice optics scheme is', IceModelName, &
+             &          'i_ice_model',this%i_ice_model)
+        if (this%i_ice_model == IIceModelFu) then
+          call print_logical('  Longwave ice optics bug in Fu scheme is', &
+               &   'do_fu_lw_ice_optics_bug',this%do_fu_lw_ice_optics_bug)
+        call print_logical('  General cloud optics', &
+             &             'use_general_cloud_optics', this%use_general_cloud_optics)
+        if (.not. this%use_general_cloud_optics) then
+          call print_enum('  Liquid optics scheme is', LiquidModelName, &
+               &          'i_liq_model',this%i_liq_model)
+          call print_enum('  Ice optics scheme is', IceModelName, &
+               &          'i_ice_model',this%i_ice_model)
+          if (this%i_ice_model == IIceModelFu) then
+            call print_logical('  Longwave ice optics bug in Fu scheme is', &
+                 &   'do_fu_lw_ice_optics_bug',this%do_fu_lw_ice_optics_bug)
+          end if
         end if
         call print_enum('  Cloud overlap scheme is', OverlapName, &
 …
                &   'overhang_factor', this%overhang_factor)
         end if
+      else if (this%i_solver_sw == ISolverMcICA &
+           &  .or. this%i_solver_lw == ISolverMcICA) then
+        call print_logical('  Use vectorizable McICA cloud generator', &
+             &   'use_vectorizable_generator', this%use_vectorizable_generator)
       end if
 …
     use parkind1, only : jprb
     use radiation_io, only : nulout, nulerr, radiation_abort
+    use radiation_spectral_definition, only : SolarReferenceTemperature
     class(config_type), intent(in) :: this
 …
     character(len=*), optional, intent(in) :: weighting_name
+    real(jprb), allocatable   :: mapping(:,:)
     ! Internally we deal with wavenumber
     real(jprb) :: wavenumber1, wavenumber2 ! cm-1
+    real(jprb) :: wavenumber1_band, wavenumber2_band ! cm-1
     integer :: jband ! Loop index for spectral band
     if (this%n_bands_sw <= 0) then
       write(nulerr,'(a)') '*** Error: get_sw_weights called before number of shortwave bands set'
       call radiation_abort()
+      call radiation_abort('Radiation configuration error')
     end if
 …
     wavenumber2 = 0.01_jprb / wavelength1
+    call this%gas_optics_sw%spectral_def%calc_mapping_from_bands(SolarReferenceTemperature, &
+         &  [wavelength1, wavelength2], [1, 2, 3], mapping, &
+         &  use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point), use_fluxes=.true.)
+    ! "mapping" now contains a 3*nband matrix, where mapping(2,:)
+    ! contains the weights of interest.  We now find the non-zero weights
     nweights = 0
+    do jband = 1,this%n_bands_sw
+      if (wavenumber1 < this%wavenumber2_sw(jband) &
+           &  .and. wavenumber2 > this%wavenumber1_sw(jband)) then
+    do jband = 1,size(mapping,2)
+      if (mapping(2,jband) > 0.0_jprb) then
         nweights = nweights+1
+        iband(nweights) = jband
+        weight(nweights) = (min(wavenumber2,this%wavenumber2_sw(jband)) &
+             &         - max(wavenumber1,this%wavenumber1_sw(jband))) &
+             & / (this%wavenumber2_sw(jband) - this%wavenumber1_sw(jband))
+        iband(nweights) = jband;
+        weight(nweights) = mapping(2,jband)
       end if
     end do
 …
       write(nulerr,'(a,e8.4,a,e8.4,a)') '*** Error: wavelength range ', &
            &  wavelength1, ' to ', wavelength2, ' m is outside shortwave band'
       call radiation_abort()
+      call radiation_abort('Radiation configuration error')
     else if (this%iverbosesetup >= 2 .and. present(weighting_name)) then
       write(nulout,'(a,a,a,f6.0,a,f6.0,a)') 'Spectral weights for ', &
            &  weighting_name, ' (', wavenumber1, ' to ', &
            &  wavenumber2, ' cm-1):'
+      do jband = 1, nweights
+        write(nulout, '(a,i0,a,f6.0,a,f6.0,a,f8.4)') '  Shortwave band ', &
+             &  iband(jband), ' (', this%wavenumber1_sw(iband(jband)), ' to ', &
+             &  this%wavenumber2_sw(iband(jband)), ' cm-1): ', weight(jband)
+      end do
+      if (this%do_cloud_aerosol_per_sw_g_point) then
+        do jband = 1, nweights
+          write(nulout, '(a,i0,a,f8.4)') '  Shortwave g point ', iband(jband), ': ', weight(jband)
+        end do
+      else
+        do jband = 1, nweights
+          wavenumber1_band = this%gas_optics_sw%spectral_def%wavenumber1_band(iband(jband))
+          wavenumber2_band = this%gas_optics_sw%spectral_def%wavenumber2_band(iband(jband))
+          write(nulout, '(a,i0,a,f6.0,a,f6.0,a,f8.4)') '  Shortwave band ', &
+               &  iband(jband), ' (', wavenumber1_band, ' to ', &
+               &  wavenumber2_band, ' cm-1): ', weight(jband)
+        end do
+      end if
     end if
 …
     use radiation_io, only : nulerr, radiation_abort
+    use radiation_spectral_definition, only : SolarReferenceTemperature
     class(config_type),   intent(inout) :: this
 …
       write(nulerr,'(a,i0,a,i0)') '*** Error: ', ninterval, &
            &  ' albedo intervals exceeds maximum of ', NMaxAlbedoIntervals
       call radiation_abort();
+      call radiation_abort('Radiation configuration error')
     end if
 …
     this%i_sw_albedo_index(ninterval+1:)           = 0
+    ! If this routine is called before setup_radiation then the
+    ! spectral intervals are not yet known
+    ! consolidate_sw_albedo_intervals is called later.  Otherwise it
+    ! is called immediately and overwrites any existing mapping.
     if (this%is_consolidated) then
+      call this%consolidate_intervals(.true., &
+           &  this%do_nearest_spectral_sw_albedo, &
+           &  this%sw_albedo_wavelength_bound, this%i_sw_albedo_index, &
+           &  this%wavenumber1_sw, this%wavenumber2_sw, &
+           &  this%i_albedo_from_band_sw, this%sw_albedo_weights)
+      call this%consolidate_sw_albedo_intervals
     end if
 …
     use radiation_io, only : nulerr, radiation_abort
+    use radiation_spectral_definition, only : TerrestrialReferenceTemperature
     class(config_type),   intent(inout) :: this
 …
       write(nulerr,'(a,i0,a,i0)') '*** Error: ', ninterval, &
            &  ' emissivity intervals exceeds maximum of ', NMaxAlbedoIntervals
       call radiation_abort();
+      call radiation_abort('Radiation configuration error')
     end if
 …
     if (this%is_consolidated) then
+      call this%consolidate_intervals(.false., &
+           &  this%do_nearest_spectral_lw_emiss, &
+           &  this%lw_emiss_wavelength_bound, this%i_lw_emiss_index, &
+           &  this%wavenumber1_lw, this%wavenumber2_lw, &
+           &  this%i_emiss_from_band_lw, this%lw_emiss_weights)
+      call this%consolidate_lw_emiss_intervals
     end if
 …
   !---------------------------------------------------------------------
+  ! This routine consolidates either the input shortwave albedo
+  ! intervals with the shortwave bands, or the input longwave
+  ! emissivity intervals with the longwave bands, depending on the
+  ! arguments provided.
+  subroutine consolidate_intervals(this, is_sw, do_nearest, &
+       &  wavelength_bound, i_intervals, wavenumber1, wavenumber2, &
+       &  i_mapping, weights)
+    use radiation_io, only : nulout, nulerr, radiation_abort
+  ! Set the wavelengths (m) at which monochromatic aerosol properties
+  ! are required. This routine must be called before consolidation of
+  ! settings.
+  subroutine set_aerosol_wavelength_mono(this, wavelength_mono)
+    use radiation_io, only : nulerr, radiation_abort
+    class(config_type), intent(inout) :: this
+    real(jprb),         intent(in)    :: wavelength_mono(:)
+    if (this%is_consolidated) then
+      write(nulerr,'(a)') '*** Errror: set_aerosol_wavelength_mono must be called before setup_radiation'
+      call radiation_abort('Radiation configuration error')
+    end if
+    if (allocated(this%aerosol_optics%wavelength_mono)) then
+      deallocate(this%aerosol_optics%wavelength_mono)
+    end if
+    allocate(this%aerosol_optics%wavelength_mono(size(wavelength_mono)))
+    this%aerosol_optics%wavelength_mono = wavelength_mono
+  end subroutine set_aerosol_wavelength_mono
+  !---------------------------------------------------------------------
+  ! Consolidate the surface shortwave albedo intervals with the
+  ! band/g-point intervals
+  subroutine consolidate_sw_albedo_intervals(this)
+    use radiation_io, only : nulout
+    use radiation_spectral_definition, only : SolarReferenceTemperature
     class(config_type),   intent(inout) :: this
+    ! Is this the shortwave?  Otherwise longwave
+    logical,    intent(in)    :: is_sw
+    ! Do we find the nearest albedo interval to the centre of each
+    ! band, or properly weight the contributions? This can be modified
+    ! if there is only one albedo intervals.
+    logical, intent(inout)    :: do_nearest
+    ! Monotonically increasing wavelength bounds between intervals,
+    ! not including the outer bounds (which are assumed to be zero and
+    ! infinity)
+    real(jprb), intent(in)    :: wavelength_bound(NMaxAlbedoIntervals-1)
+    ! The albedo band indices corresponding to each interval
+    integer,    intent(in)    :: i_intervals(NMaxAlbedoIntervals)
+    ! Start and end wavenumber bounds for the ecRad bands (cm-1)
+    real(jprb), intent(in)    :: wavenumber1(:), wavenumber2(:)
+    ! if do_nearest is TRUE then the result is expressed in i_mapping,
+    ! which will be allocated to have the same length as wavenumber1,
+    ! and contain the index of the albedo interval corresponding to
+    ! that band
+    integer,    allocatable, intent(inout) :: i_mapping(:)
+    ! ...otherwise the result is expressed in "weights", of
+    ! size(n_intervals, n_bands) containing how much of each interval
+    ! contributes to each band.
+    real(jprb), allocatable, intent(inout) :: weights(:,:)
+    ! Number and loop index of ecRad bands
+    integer    :: nband, jband
+    ! Number and index of albedo/emissivity intervals
+    integer    :: ninterval, iinterval
+    ! Sometimes an albedo or emissivity value will be used in more
+    ! than one interval, so nvalue indicates how many values will
+    ! actually be provided
+    integer    :: nvalue
+    ! Wavenumber bounds of the albedo/emissivity interval
+    real(jprb) :: wavenumber1_albedo, wavenumber2_albedo
+    ! Reciprocal of the wavenumber range of the ecRad band
+    real(jprb) :: recip_dwavenumber ! cm
+    ! Midpoint/bound of wavenumber band
+    real(jprb) :: wavenumber_mid, wavenumber_bound ! cm-1
+    nband = size(wavenumber1)
+    integer :: ninterval, jint, jband
     ! Count the number of albedo/emissivity intervals
     ninterval = 0
     do iinterval = 1,NMaxAlbedoIntervals
       if (i_intervals(iinterval) > 0) then
         ninterval = iinterval
+    do jint = 1,NMaxAlbedoIntervals
+      if (this%i_sw_albedo_index(jint) > 0) then
+        ninterval = jint
       else
         exit
 …
     end do
+    if (ninterval < 2) then
+      ! Zero or one albedo/emissivity intervals found, so we index all
+      ! bands to one interval
+      if (allocated(i_mapping)) then
+        deallocate(i_mapping)
+      end if
+      allocate(i_mapping(nband))
+      i_mapping(:) = 1
+      do_nearest = .true.
+    if (ninterval < 1) then
+      ! The user has not specified shortwave albedo bands - assume
+      ! only one
       ninterval = 1
+      nvalue = 1
+    else
+      ! Check wavelength is monotonically increasing
+      do jband = 2,ninterval-1
+        if (wavelength_bound(jband) <= wavelength_bound(jband-1)) then
+          if (is_sw) then
+            write(nulerr, '(a,a)') '*** Error: wavelength bounds for shortwave albedo intervals ', &
+                 &  'must be monotonically increasing'
+          else
+            write(nulerr, '(a,a)') '*** Error: wavelength bounds for longwave emissivity intervals ', &
+                 &  'must be monotonically increasing'
+          end if
+          call radiation_abort()
+        end if
+      end do
+      ! What is the maximum index, indicating the number of
+      ! albedo/emissivity values to expect?
+      nvalue = maxval(i_intervals(1:ninterval))
+      if (do_nearest) then
+        ! Simpler nearest-neighbour mapping from band to
+        ! albedo/emissivity interval
+        if (allocated(i_mapping)) then
+          deallocate(i_mapping)
+        end if
+        allocate(i_mapping(nband))
+        ! Loop over bands
+        do jband = 1,nband
+          ! Compute mid-point of band in wavenumber space (cm-1)
+          wavenumber_mid = 0.5_jprb * (wavenumber1(jband) &
+               &                     + wavenumber2(jband))
+          iinterval = 1
+          ! Convert wavelength (m) into wavenumber (cm-1) at the lower
+          ! bound of the albedo interval
+          wavenumber_bound = 0.01_jprb / wavelength_bound(iinterval)
+          ! Find the albedo interval that has the largest overlap with
+          ! the band; this approach assumes that the albedo intervals
+          ! are larger than the spectral bands
+          do while (wavenumber_bound >= wavenumber_mid &
+               &    .and. iinterval < ninterval)
+            iinterval = iinterval + 1
+            if (iinterval < ninterval) then
+              wavenumber_bound = 0.01_jprb / wavelength_bound(iinterval)
+            else
+              ! For the last interval there is no lower bound
+              wavenumber_bound = 0.0_jprb
+            end if
+          end do
+          ! Save the index of the band corresponding to the albedo
+          ! interval and move onto the next band
+          i_mapping(jband) = i_intervals(iinterval)
+        end do
+      else
+        ! More accurate weighting
+        if (allocated(weights)) then
+          deallocate(weights)
+        end if
+        allocate(weights(nvalue,nband))
+        weights(:,:) = 0.0_jprb
+        ! Loop over bands
+        do jband = 1,nband
+          recip_dwavenumber = 1.0_jprb / (wavenumber2(jband) &
+               &                        - wavenumber1(jband))
+          ! Find the first overlapping albedo band
+          iinterval = 1
+          ! Convert wavelength (m) into wavenumber (cm-1) at the lower
+          ! bound (in wavenumber space) of the albedo/emissivty interval
+          wavenumber1_albedo = 0.01_jprb / wavelength_bound(iinterval)
+          do while (wavenumber1_albedo >= wavenumber2(jband) &
+               &    .and. iinterval < ninterval)
+            iinterval = iinterval + 1
+            wavenumber1_albedo = 0.01_jprb / wavelength_bound(iinterval)
+          end do
+          wavenumber2_albedo = wavenumber2(jband)
+          ! Add all overlapping bands
+          do while (wavenumber2_albedo > wavenumber1(jband) &
+               &  .and. iinterval <= ninterval)
+            weights(i_intervals(iinterval),jband) &
+                 &  = weights(i_intervals(iinterval),jband) &
+                 &  + recip_dwavenumber &
+                 &  * (min(wavenumber2_albedo,wavenumber2(jband)) &
+                 &   - max(wavenumber1_albedo,wavenumber1(jband)))
+            wavenumber2_albedo = wavenumber1_albedo
+            iinterval = iinterval + 1
+            if (iinterval < ninterval) then
+              wavenumber1_albedo = 0.01_jprb / wavelength_bound(iinterval)
+            else
+              wavenumber1_albedo = 0.0_jprb
+            end if
+          end do
+        end do
+      end if
+    end if
+    ! Define how many bands to use for reporting surface downwelling
+    ! fluxes for canopy radiation scheme
+    if (is_sw) then
+      this%i_sw_albedo_index(1) = 1
+      this%i_sw_albedo_index(2:) = 0
       if (this%use_canopy_full_spectrum_sw) then
         this%n_canopy_bands_sw = this%n_g_sw
       else
+        this%n_canopy_bands_sw = nvalue
+        this%n_canopy_bands_sw = 1
+      end if
+    else
+      if (this%use_canopy_full_spectrum_sw) then
+        this%n_canopy_bands_sw = this%n_g_sw
+      else
+        this%n_canopy_bands_sw = maxval(this%i_sw_albedo_index(1:ninterval))
+      end if
+    end if
+    if (this%do_weighted_surface_mapping) then
+      call this%gas_optics_sw%spectral_def%calc_mapping_from_bands(SolarReferenceTemperature, &
+           &  this%sw_albedo_wavelength_bound(1:ninterval-1), this%i_sw_albedo_index(1:ninterval), &
+           &  this%sw_albedo_weights, use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point))
+    else
+      ! Weight each wavenumber equally as in IFS Cycles 48 and earlier
+      call this%gas_optics_sw%spectral_def%calc_mapping_from_bands(-1.0_jprb, &
+           &  this%sw_albedo_wavelength_bound(1:ninterval-1), this%i_sw_albedo_index(1:ninterval), &
+           &  this%sw_albedo_weights, use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point))
+    end if
+    ! Legacy method uses input band with largest weight
+    if (this%do_nearest_spectral_sw_albedo) then
+      allocate(this%i_albedo_from_band_sw(this%n_bands_sw))
+      this%i_albedo_from_band_sw = maxloc(this%sw_albedo_weights, dim=1)
+    end if
+    if (this%iverbosesetup >= 2) then
+      write(nulout, '(a)') 'Surface shortwave albedo'
+      if (.not. this%do_nearest_spectral_sw_albedo) then
+        call this%gas_optics_sw%spectral_def%print_mapping_from_bands(this%sw_albedo_weights, &
+             &       use_bands=(.not. this%do_cloud_aerosol_per_sw_g_point))
+      else if (ninterval <= 1) then
+        write(nulout, '(a)') 'All shortwave bands will use the same albedo'
+      else
+        write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', size(this%i_albedo_from_band_sw), &
+             &  ' shortwave intervals to albedo intervals:'
+        do jband = 1,size(this%i_albedo_from_band_sw)
+          write(nulout,'(a,i0)',advance='no') ' ', this%i_albedo_from_band_sw(jband)
+        end do
+        write(nulout, '()')
+      end if
+    end if
+  end subroutine consolidate_sw_albedo_intervals
+  !---------------------------------------------------------------------
+  ! Consolidate the surface longwave emissivity intervals with the
+  ! band/g-point intervals
+  subroutine consolidate_lw_emiss_intervals(this)
+    use radiation_io, only : nulout
+    use radiation_spectral_definition, only : TerrestrialReferenceTemperature
+    class(config_type),   intent(inout) :: this
+    integer :: ninterval, jint, jband
+    ! Count the number of albedo/emissivity intervals
+    ninterval = 0
+    do jint = 1,NMaxAlbedoIntervals
+      if (this%i_lw_emiss_index(jint) > 0) then
+        ninterval = jint
+      else
+        exit
+      end if
+    end do
+    if (ninterval < 1) then
+      ! The user has not specified longwave emissivity bands - assume
+      ! only one
+      ninterval = 1
+      this%i_lw_emiss_index(1) = 1
+      this%i_lw_emiss_index(2:) = 0
+      if (this%use_canopy_full_spectrum_sw) then
+        this%n_canopy_bands_lw = this%n_g_lw
+      else
+        this%n_canopy_bands_lw = 1
       end if
     else
 …
         this%n_canopy_bands_lw = this%n_g_lw
       else
+        this%n_canopy_bands_lw = nvalue
+      end if
+        this%n_canopy_bands_lw = maxval(this%i_lw_emiss_index(1:ninterval))
+      end if
+    end if
+    if (this%do_weighted_surface_mapping) then
+      call this%gas_optics_lw%spectral_def%calc_mapping_from_bands(TerrestrialReferenceTemperature, &
+           &  this%lw_emiss_wavelength_bound(1:ninterval-1), this%i_lw_emiss_index(1:ninterval), &
+           &  this%lw_emiss_weights, use_bands=(.not. this%do_cloud_aerosol_per_lw_g_point))
+    else
+      ! Weight each wavenumber equally as in IFS Cycles 48 and earlier
+      call this%gas_optics_lw%spectral_def%calc_mapping_from_bands(-1.0_jprb, &
+           &  this%lw_emiss_wavelength_bound(1:ninterval-1), this%i_lw_emiss_index(1:ninterval), &
+           &  this%lw_emiss_weights, use_bands=(.not. this%do_cloud_aerosol_per_lw_g_point))
+    end if
+    ! Legacy method uses input band with largest weight
+    if (this%do_nearest_spectral_lw_emiss) then
+      allocate(this%i_emiss_from_band_lw(this%n_bands_lw))
+      this%i_emiss_from_band_lw = maxloc(this%lw_emiss_weights, dim=1)
     end if
     if (this%iverbosesetup >= 2) then
+      if (.not. do_nearest) then
+        if (is_sw) then
+          write(nulout, '(a,i0,a,i0,a)') 'Weighting of ', nvalue, ' albedo values in ', &
+             &  nband, ' shortwave bands (wavenumber ranges in cm-1):'
+        else
+          write(nulout, '(a,i0,a,i0,a)') 'Weighting of ', nvalue, ' emissivity values in ', &
+             &  nband, ' longwave bands (wavenumber ranges in cm-1):'
+        end if
+        do jband = 1,nband
+          write(nulout,'(i6,a,i6,a)',advance='no') nint(wavenumber1(jband)), ' to', &
+               &                        nint(wavenumber2(jband)), ':'
+          do iinterval = 1,nvalue
+            write(nulout,'(f5.2)',advance='no') weights(iinterval,jband)
+          end do
+          write(nulout, '()')
+        end do
+      write(nulout, '(a)') 'Surface longwave emissivity'
+      if (.not. this%do_nearest_spectral_lw_emiss) then
+        call this%gas_optics_lw%spectral_def%print_mapping_from_bands(this%lw_emiss_weights, &
+             &                          use_bands=(.not. this%do_cloud_aerosol_per_lw_g_point))
       else if (ninterval <= 1) then
+        if (is_sw) then
+          write(nulout, '(a)') 'All shortwave bands will use the same albedo'
+        else
+          write(nulout, '(a)') 'All longwave bands will use the same emissivty'
+        end if
+        write(nulout, '(a)') 'All longwave bands will use the same emissivty'
       else
+        if (is_sw) then
+          write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', nband, &
+               &  ' shortwave bands to albedo intervals:'
+        else
+          write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', nband, &
+               &  ' longwave bands to emissivity intervals:'
+        end if
+        do jband = 1,nband
+          write(nulout,'(a,i0)',advance='no') ' ', i_mapping(jband)
+        write(nulout, '(a,i0,a)',advance='no') 'Mapping from ', size(this%i_emiss_from_band_lw), &
+             &  ' longwave intervals to emissivity intervals:'
+        do jband = 1,size(this%i_emiss_from_band_lw)
+          write(nulout,'(a,i0)',advance='no') ' ', this%i_emiss_from_band_lw(jband)
         end do
         write(nulout, '()')
 …
     end if
   end subroutine consolidate_intervals
+  end subroutine consolidate_lw_emiss_intervals
 …
   end subroutine print_enum
-  !---------------------------------------------------------------------
-  ! Return .true. if 1D allocatable array "var" is out of physical
-  ! range specified by boundmin and boundmax, and issue a warning.
-  ! "do_fix" determines whether erroneous values are fixed to lie
-  ! within the physical range. To check only a subset of the array,
-  ! specify i1 and i2 for the range.
-  function out_of_bounds_1d(var, var_name, boundmin, boundmax, do_fix, i1, i2) result (is_bad)
-    use radiation_io,     only : nulout
-    real(jprb), allocatable, intent(inout) :: var(:)
-    character(len=*),        intent(in) :: var_name
-    real(jprb),              intent(in) :: boundmin, boundmax
-    logical,                 intent(in) :: do_fix
-    integer,       optional, intent(in) :: i1, i2
-    logical                       :: is_bad
-    real(jprb) :: varmin, varmax
-    is_bad = .false.
-    if (allocated(var)) then
-      if (present(i1) .and. present(i2)) then
-        varmin = minval(var(i1:i2))
-        varmax = maxval(var(i1:i2))
-      else
-        varmin = minval(var)
-        varmax = maxval(var)
-      end if
-      if (varmin < boundmin .or. varmax > boundmax) then
-        write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') &
-             &  '*** Warning: ', var_name, ' range', varmin, ' to', varmax, &
-             &  ' is out of physical range', boundmin, 'to', boundmax
-        is_bad = .true.
-        if (do_fix) then
-          if (present(i1) .and. present(i2)) then
-            var(i1:i2) = max(boundmin, min(boundmax, var(i1:i2)))
-          else
-            var = max(boundmin, min(boundmax, var))
-          end if
-          write(nulout,'(a)') ': corrected'
-        else
-          write(nulout,'(1x)')
-        end if
-      end if
-    end if
-  end function out_of_bounds_1d
-  !---------------------------------------------------------------------
-  ! Return .true. if 2D allocatable array "var" is out of physical
-  ! range specified by boundmin and boundmax, and issue a warning.  To
-  ! check only a subset of the array, specify i1 and i2 for the range
-  ! of the first dimension and j1 and j2 for the range of the second.
-  function out_of_bounds_2d(var, var_name, boundmin, boundmax, do_fix, &
-       &                    i1, i2, j1, j2) result (is_bad)
-    use radiation_io,     only : nulout
-    real(jprb), allocatable, intent(inout) :: var(:,:)
-    character(len=*),        intent(in) :: var_name
-    real(jprb),              intent(in) :: boundmin, boundmax
-    logical,                 intent(in) :: do_fix
-    integer,       optional, intent(in) :: i1, i2, j1, j2
-    ! Local copies of indices
-    integer :: ii1, ii2, jj1, jj2
-    logical                       :: is_bad
-    real(jprb) :: varmin, varmax
-    is_bad = .false.
-    if (allocated(var)) then
-      if (present(i1) .and. present(i2)) then
-        ii1 = i1
-        ii2 = i2
-      else
-        ii1 = lbound(var,1)
-        ii2 = ubound(var,1)
-      end if
-      if (present(j1) .and. present(j2)) then
-        jj1 = j1
-        jj2 = j2
-      else
-        jj1 = lbound(var,2)
-        jj2 = ubound(var,2)
-      end if
-      varmin = minval(var(ii1:ii2,jj1:jj2))
-      varmax = maxval(var(ii1:ii2,jj1:jj2))
-      if (varmin < boundmin .or. varmax > boundmax) then
-        write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') &
-             &  '*** Warning: ', var_name, ' range', varmin, ' to', varmax,&
-             &  ' is out of physical range', boundmin, 'to', boundmax
-        is_bad = .true.
-        if (do_fix) then
-          var(ii1:ii2,jj1:jj2) = max(boundmin, min(boundmax, var(ii1:ii2,jj1:jj2)))
-          write(nulout,'(a)') ': corrected'
-        else
-          write(nulout,'(1x)')
-        end if
-      end if
-    end if
-  end function out_of_bounds_2d
-  !---------------------------------------------------------------------
-  ! Return .true. if 3D allocatable array "var" is out of physical
-  ! range specified by boundmin and boundmax, and issue a warning.  To
-  ! check only a subset of the array, specify i1 and i2 for the range
-  ! of the first dimension, j1 and j2 for the second and k1 and k2 for
-  ! the third.
-  function out_of_bounds_3d(var, var_name, boundmin, boundmax, do_fix, &
-       &                    i1, i2, j1, j2, k1, k2) result (is_bad)
-    use radiation_io,     only : nulout
-    real(jprb), allocatable, intent(inout) :: var(:,:,:)
-    character(len=*),        intent(in) :: var_name
-    real(jprb),              intent(in) :: boundmin, boundmax
-    logical,                 intent(in) :: do_fix
-    integer,       optional, intent(in) :: i1, i2, j1, j2, k1, k2
-    ! Local copies of indices
-    integer :: ii1, ii2, jj1, jj2, kk1, kk2
-    logical                       :: is_bad
-    real(jprb) :: varmin, varmax
-    is_bad = .false.
-    if (allocated(var)) then
-      if (present(i1) .and. present(i2)) then
-        ii1 = i1
-        ii2 = i2
-      else
-        ii1 = lbound(var,1)
-        ii2 = ubound(var,1)
-      end if
-      if (present(j1) .and. present(j2)) then
-        jj1 = j1
-        jj2 = j2
-      else
-        jj1 = lbound(var,2)
-        jj2 = ubound(var,2)
-      end if
-      if (present(k1) .and. present(k2)) then
-        kk1 = k1
-        kk2 = k2
-      else
-        kk1 = lbound(var,3)
-        kk2 = ubound(var,3)
-      end if
-      varmin = minval(var(ii1:ii2,jj1:jj2,kk1:kk2))
-      varmax = maxval(var(ii1:ii2,jj1:jj2,kk1:kk2))
-      if (varmin < boundmin .or. varmax > boundmax) then
-        write(nulout,'(a,a,a,g12.4,a,g12.4,a,g12.4,a,g12.4)',advance='no') &
-             &  '*** Warning: ', var_name, ' range', varmin, ' to', varmax,&
-             &  ' is out of physical range', boundmin, 'to', boundmax
-        is_bad = .true.
-        if (do_fix) then
-          var(ii1:ii2,jj1:jj2,kk1:kk2) = max(boundmin, min(boundmax, &
-               &                             var(ii1:ii2,jj1:jj2,kk1:kk2)))
-          write(nulout,'(a)') ': corrected'
-        else
-          write(nulout,'(1x)')
-        end if
-      end if
-    end if
-  end function out_of_bounds_3d
 end module radiation_config

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_delta_eddington.h

-                      r3908
+                      r4444
 ! radiation_delta_eddington.h - Delta-Eddington scaling
+! radiation_delta_eddington.h - Delta-Eddington scaling -*- f90 -*-
+!
 ! (C) Copyright 2015- ECMWF.
 …
 end subroutine delta_eddington_scat_od
+!---------------------------------------------------------------------
+! Revert delta-Eddington-scaled quantities in-place, back to their
+! original state
+elemental subroutine revert_delta_eddington(od, ssa, g)
+  use parkind1, only : jprb
+  ! Total optical depth, single scattering albedo and asymmetry
+  ! factor
+  real(jprb), intent(inout) :: od, ssa, g
+  ! Fraction of the phase function deemed to be in the forward lobe
+  ! and therefore treated as if it is not scattered at all
+  real(jprb) :: f
+  g   = g / (1.0_jprb - g)
+  f   = g*g
+  ssa = ssa / (1.0_jprb - f + f*ssa);
+  od  = od / (1.0_jprb - ssa*f)
+end subroutine revert_delta_eddington

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_flux.F90

-                      r3908
+                      r4444
   end type flux_type
+! Added for DWD (2020)
+#ifdef __SX__
+      logical, parameter :: use_indexed_sum_vec = .true.
+#else
+      logical, parameter :: use_indexed_sum_vec = .false.
+#endif
 contains
 …
         if (config%n_spec_lw == 0) then
           write(nulerr,'(a)') '*** Error: number of LW spectral points to save not yet defined ' &
                & // 'so cannot allocated spectral flux arrays'
+               & // 'so cannot allocate spectral flux arrays'
           call radiation_abort()
         end if
 …
     end if
+    if (allocated(this%lw_dn_surf_g))               deallocate(this%lw_dn_surf_g)
+    if (allocated(this%lw_dn_surf_clear_g))         deallocate(this%lw_dn_surf_clear_g)
+    if (allocated(this%sw_dn_diffuse_surf_g))       deallocate(this%sw_dn_diffuse_surf_g)
+    if (allocated(this%sw_dn_direct_surf_g))        deallocate(this%sw_dn_direct_surf_g)
+    if (allocated(this%sw_dn_diffuse_surf_clear_g)) deallocate(this%sw_dn_diffuse_surf_clear_g)
+    if (allocated(this%sw_dn_direct_surf_clear_g))  deallocate(this%sw_dn_direct_surf_clear_g)
     if (lhook) call dr_hook('radiation_flux:deallocate',1,hook_handle)
 …
     if (config%do_sw .and. config%do_surface_sw_spectral_flux) then
+      do jcol = istartcol,iendcol
+        call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), &
+             &           config%i_band_from_reordered_g_sw, &
+             &           this%sw_dn_direct_surf_band(:,jcol))
+        call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), &
+             &           config%i_band_from_reordered_g_sw, &
+             &           this%sw_dn_surf_band(:,jcol))
+        this%sw_dn_surf_band(:,jcol) &
+             &  = this%sw_dn_surf_band(:,jcol) &
+             &  + this%sw_dn_direct_surf_band(:,jcol)
+      end do
+      if (use_indexed_sum_vec) then
+        call indexed_sum_vec(this%sw_dn_direct_surf_g, &
+             &               config%i_band_from_reordered_g_sw, &
+             &               this%sw_dn_direct_surf_band, istartcol, iendcol)
+        call indexed_sum_vec(this%sw_dn_diffuse_surf_g, &
+             &               config%i_band_from_reordered_g_sw, &
+             &               this%sw_dn_surf_band, istartcol, iendcol)
+        do jcol = istartcol,iendcol
+          this%sw_dn_surf_band(:,jcol) &
+               &  = this%sw_dn_surf_band(:,jcol) &
+               &  + this%sw_dn_direct_surf_band(:,jcol)
+        end do
+      else
+        do jcol = istartcol,iendcol
+          call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), &
+               &           config%i_band_from_reordered_g_sw, &
+               &           this%sw_dn_direct_surf_band(:,jcol))
+          call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), &
+               &           config%i_band_from_reordered_g_sw, &
+               &           this%sw_dn_surf_band(:,jcol))
+          this%sw_dn_surf_band(:,jcol) &
+               &  = this%sw_dn_surf_band(:,jcol) &
+               &  + this%sw_dn_direct_surf_band(:,jcol)
+        end do
+      end if
       if (config%do_clear) then
+        do jcol = istartcol,iendcol
+          call indexed_sum(this%sw_dn_direct_surf_clear_g(:,jcol), &
+               &           config%i_band_from_reordered_g_sw, &
+               &           this%sw_dn_direct_surf_clear_band(:,jcol))
+          call indexed_sum(this%sw_dn_diffuse_surf_clear_g(:,jcol), &
+               &           config%i_band_from_reordered_g_sw, &
+               &           this%sw_dn_surf_clear_band(:,jcol))
+          this%sw_dn_surf_clear_band(:,jcol) &
+               &  = this%sw_dn_surf_clear_band(:,jcol) &
+               &  + this%sw_dn_direct_surf_clear_band(:,jcol)
+        end do
+        if (use_indexed_sum_vec) then
+          call indexed_sum_vec(this%sw_dn_direct_surf_clear_g, &
+               &               config%i_band_from_reordered_g_sw, &
+               &               this%sw_dn_direct_surf_clear_band, istartcol, iendcol)
+          call indexed_sum_vec(this%sw_dn_diffuse_surf_clear_g, &
+               &               config%i_band_from_reordered_g_sw, &
+               &               this%sw_dn_surf_clear_band, istartcol, iendcol)
+          do jcol = istartcol,iendcol
+            this%sw_dn_surf_clear_band(:,jcol) &
+                 &  = this%sw_dn_surf_clear_band(:,jcol) &
+                 &  + this%sw_dn_direct_surf_clear_band(:,jcol)
+          end do
+        else
+          do jcol = istartcol,iendcol
+            call indexed_sum(this%sw_dn_direct_surf_clear_g(:,jcol), &
+                 &           config%i_band_from_reordered_g_sw, &
+                 &           this%sw_dn_direct_surf_clear_band(:,jcol))
+            call indexed_sum(this%sw_dn_diffuse_surf_clear_g(:,jcol), &
+                 &           config%i_band_from_reordered_g_sw, &
+                 &           this%sw_dn_surf_clear_band(:,jcol))
+            this%sw_dn_surf_clear_band(:,jcol) &
+                 &  = this%sw_dn_surf_clear_band(:,jcol) &
+                 &  + this%sw_dn_direct_surf_clear_band(:,jcol)
+          end do
+        end if
       end if
 …
         this%sw_dn_direct_surf_canopy (:,istartcol:iendcol) = this%sw_dn_direct_surf_g (:,istartcol:iendcol)
       else if (config%do_nearest_spectral_sw_albedo) then
+        do jcol = istartcol,iendcol
+          call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), &
+               &           config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), &
+               &           this%sw_dn_direct_surf_canopy(:,jcol))
+          call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), &
+               &           config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), &
+               &           this%sw_dn_diffuse_surf_canopy(:,jcol))
+        end do
+        if (use_indexed_sum_vec) then
+          call indexed_sum_vec(this%sw_dn_direct_surf_g, &
+               &               config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), &
+               &               this%sw_dn_direct_surf_canopy, istartcol, iendcol)
+          call indexed_sum_vec(this%sw_dn_diffuse_surf_g, &
+               &               config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), &
+               &               this%sw_dn_diffuse_surf_canopy, istartcol, iendcol)
+        else
+          do jcol = istartcol,iendcol
+            call indexed_sum(this%sw_dn_direct_surf_g(:,jcol), &
+                 &           config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), &
+                 &           this%sw_dn_direct_surf_canopy(:,jcol))
+            call indexed_sum(this%sw_dn_diffuse_surf_g(:,jcol), &
+                 &           config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw), &
+                 &           this%sw_dn_diffuse_surf_canopy(:,jcol))
+          end do
+        end if
       else
         ! More accurate calculations using weights, but requires
 …
         this%lw_dn_surf_canopy(:,istartcol:iendcol) = this%lw_dn_surf_g(:,istartcol:iendcol)
       else if (config%do_nearest_spectral_lw_emiss) then
+        do jcol = istartcol,iendcol
+          call indexed_sum(this%lw_dn_surf_g(:,jcol), &
+               &           config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw), &
+               &           this%lw_dn_surf_canopy(:,jcol))
+        end do
+        if (use_indexed_sum_vec) then
+          call indexed_sum_vec(this%lw_dn_surf_g, &
+               &               config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw), &
+               &               this%lw_dn_surf_canopy, istartcol, iendcol)
+        else
+          do jcol = istartcol,iendcol
+            call indexed_sum(this%lw_dn_surf_g(:,jcol), &
+                 &           config%i_emiss_from_band_lw(config%i_band_from_reordered_g_lw), &
+                 &           this%lw_dn_surf_canopy(:,jcol))
+          end do
+        end if
       else
         ! Compute fluxes in each longwave emissivity interval using
         ! weights; first sum over g points to get the values in bands
+        do jcol = istartcol,iendcol
+          call indexed_sum(this%lw_dn_surf_g(:,jcol), &
+               &           config%i_band_from_reordered_g_lw, &
+               &           lw_dn_surf_band(:,jcol))
+        end do
+        if (use_indexed_sum_vec) then
+          call indexed_sum_vec(this%lw_dn_surf_g, &
+               &               config%i_band_from_reordered_g_lw, &
+               &               lw_dn_surf_band, istartcol, iendcol)
+        else
+          do jcol = istartcol,iendcol
+            call indexed_sum(this%lw_dn_surf_g(:,jcol), &
+                 &           config%i_band_from_reordered_g_lw, &
+                 &           lw_dn_surf_band(:,jcol))
+          end do
+        end if
         nalbedoband = size(config%lw_emiss_weights,1)
         this%lw_dn_surf_canopy(:,istartcol:iendcol) = 0.0_jprb
 …
     use yomhook,          only : lhook, dr_hook
     use radiation_config, only : out_of_bounds_2d
+    use radiation_check,  only : out_of_bounds_2d
     class(flux_type), intent(inout) :: this
 …
   function heating_rate_out_of_physical_bounds(this, nlev, istartcol, iendcol, pressure_hl) result(is_bad)
     use radiation_config, only : out_of_bounds_2d
+    use radiation_check, only : out_of_bounds_2d
     use radiation_constants, only : AccelDueToGravity
 …
   end subroutine indexed_sum
+  !---------------------------------------------------------------------
+  ! Vectorized version of "add_indexed_sum"
+  subroutine indexed_sum_vec(source, ind, dest, ist, iend)
+    real(jprb), intent(in)  :: source(:,:)
+    integer,    intent(in)  :: ind(:)
+    real(jprb), intent(out) :: dest(:,:)
+    integer,    intent(in)  :: ist, iend
+    integer :: ig, jg, jc
+    dest = 0.0
+    do jg = lbound(source,1), ubound(source,1)
+      ig = ind(jg)
+      do jc = ist, iend
+        dest(ig,jc) = dest(ig,jc) + source(jg,jc)
+      end do
+    end do
+  end subroutine indexed_sum_vec
   !---------------------------------------------------------------------

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_gas.F90

-                      r3908
+                      r4444
   use parkind1, only : jprb
+  use radiation_gas_constants
   implicit none
   public
-  ! Gas codes; these indices match those of RRTM-LW up to 7
-  integer, parameter :: IGasNotPresent = 0
-  integer, parameter :: IH2O   = 1
-  integer, parameter :: ICO2   = 2
-  integer, parameter :: IO3    = 3
-  integer, parameter :: IN2O   = 4
-  integer, parameter :: ICO    = 5
-  integer, parameter :: ICH4   = 6
-  integer, parameter :: IO2    = 7
-  integer, parameter :: ICFC11 = 8
-  integer, parameter :: ICFC12 = 9
-  integer, parameter :: IHCFC22= 10
-  integer, parameter :: ICCl4  = 11
-  integer, parameter :: INO2   = 12
-  integer, parameter :: NMaxGases = 12
-  ! Molar masses (g mol-1) of dry air and the various gases above
-  real(jprb), parameter :: IAirMolarMass = 28.970
-  real(jprb), parameter, dimension(0:NMaxGases) :: IGasMolarMass = (/ &
-       & 0.0_jprb,        & ! Gas not present
-       & 18.0152833_jprb, & ! H2O
-       & 44.011_jprb,     & ! CO2
-       & 47.9982_jprb,    & ! O3
-       & 44.013_jprb,     & ! N2O
-       & 28.0101_jprb,    & ! CO
-       & 16.043_jprb,     & ! CH4
-       & 31.9988_jprb,    & ! O2
-       & 137.3686_jprb,   & ! CFC11
-       & 120.914_jprb,    & ! CFC12
-       & 86.469_jprb,     & ! HCFC22
-       & 153.823_jprb,    & ! CCl4
-       & 46.0055_jprb /)    ! NO2
-  ! The corresponding names of the gases in upper and lower case, used
-  ! for reading variables from the input file
-  character*6, dimension(NMaxGases), parameter :: GasName &
-       &  = (/'H2O   ','CO2   ','O3    ','N2O   ','CO    ','CH4   ', &
-       &      'O2    ','CFC11 ','CFC12 ','HCFC22','CCl4  ','NO2   '/)
-  character*6, dimension(NMaxGases), parameter :: GasLowerCaseName &
-       &  = (/'h2o   ','co2   ','o3    ','n2o   ','co    ','ch4   ', &
-       &      'o2    ','cfc11 ','cfc12 ','hcfc22','ccl4  ','no2   '/)
   ! Available units
 …
   !---------------------------------------------------------------------
+  ! Allocate a derived type for holding gas mixing ratios given the
+  ! number of columns and levels
   subroutine allocate_gas(this, ncol, nlev)
 …
     integer,    optional, intent(in)    :: istartcol
+    integer :: i1, i2
+    integer :: i1, i2, jc, jk
     real(jprb)                          :: hook_handle
 …
     this%iunits(igas) = iunits
     this%is_well_mixed(igas) = .false.
+    this%mixing_ratio(i1:i2,:,igas) = mixing_ratio
+    do jk = 1,this%nlev
+      do jc = i1,i2
+        this%mixing_ratio(jc,jk,igas) = mixing_ratio(jc-i1+1,jk)
+      end do
+    end do
     if (present(scale_factor)) then
       this%scale_factor(igas) = scale_factor
 …
     real(jprb)                          :: hook_handle
     integer :: i1, i2
+    integer :: i1, i2, jc, jk
     if (lhook) call dr_hook('radiation_gas:put_well_mixed',0,hook_handle)
 …
     this%iunits(igas)                  = iunits
     this%is_well_mixed(igas)           = .true.
+    this%mixing_ratio(i1:i2,:,igas)    = mixing_ratio
+    do jk = 1,this%nlev
+      do jc = i1,i2
+        this%mixing_ratio(jc,jk,igas) = mixing_ratio
+      end do
+    end do
     if (present(scale_factor)) then
       this%scale_factor(igas) = scale_factor
 …
   ! immediately, but changes the scale factor for the specified gas,
   ! ready to be used in set_units_gas.
   subroutine scale_gas(this, igas, scale_factor, lverbose)
 …
         if (iunits == IMassMixingRatio &
              &   .and. this%iunits(igas) == IVolumeMixingRatio) then
           sf = sf * IGasMolarMass(igas) / IAirMolarMass
+          sf = sf * GasMolarMass(igas) / AirMolarMass
         else if (iunits == IVolumeMixingRatio &
              &   .and. this%iunits(igas) == IMassMixingRatio) then
           sf = sf * IAirMolarMass / IGasMolarMass(igas)
+          sf = sf * AirMolarMass / GasMolarMass(igas)
         end if
         sf = sf * this%scale_factor(igas)
 …
       if (iunits == IMassMixingRatio &
            &   .and. this%iunits(igas) == IVolumeMixingRatio) then
         sf = sf * IGasMolarMass(igas) / IAirMolarMass
+        sf = sf * GasMolarMass(igas) / AirMolarMass
       else if (iunits == IVolumeMixingRatio &
            &   .and. this%iunits(igas) == IMassMixingRatio) then
         sf = sf * IAirMolarMass / IGasMolarMass(igas)
+        sf = sf * AirMolarMass / GasMolarMass(igas)
       end if
       sf = sf * this%scale_factor(igas)
 …
     use yomhook,          only : lhook, dr_hook
     use radiation_config, only : out_of_bounds_3d
+    use radiation_check,  only : out_of_bounds_3d
     class(gas_type),   intent(inout) :: this

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_ice_optics_fu.F90

-                      r3908
+                      r4444
     real (jprb) :: iwp_gm_2
+    integer :: jb
     !real(jprb)  :: hook_handle
 …
     iwp_gm_2  = ice_wp * 1000.0_jprb
+    od = iwp_gm_2 * (coeff(1:nb,1) + coeff(1:nb,2) * inv_de_um)
+    scat_od = od * (1.0_jprb - (coeff(1:nb,3) + de_um*(coeff(1:nb,4) &
+         &  + de_um*(coeff(1:nb,5) + de_um*coeff(1:nb,6)))))
+    g = min(coeff(1:nb,7) + de_um*(coeff(1:nb,8) &
+         &  + de_um*(coeff(1:nb,9) + de_um*coeff(1:nb,10))), &
+! Added for DWD (2020)
+!NEC$ shortloop
+    do jb = 1, nb
+      od(jb) = iwp_gm_2 * (coeff(jb,1) + coeff(jb,2) * inv_de_um)
+      scat_od(jb) = od(jb) * (1.0_jprb - (coeff(jb,3) + de_um*(coeff(jb,4) &
+         &  + de_um*(coeff(jb,5) + de_um*coeff(jb,6)))))
+      g(jb) = min(coeff(jb,7) + de_um*(coeff(jb,8) &
+         &  + de_um*(coeff(jb,9) + de_um*coeff(jb,10))), &
          &  MaxAsymmetryFactor)
+    end do
     !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_fu_sw',1,hook_handle)
 …
     real (jprb) :: iwp_gm_2
+    integer :: jb
     !real(jprb)  :: hook_handle
 …
     iwp_gm_2  = ice_wp * 1000.0_jprb
+    od = iwp_gm_2 * (coeff(1:nb,1) + inv_de_um*(coeff(1:nb,2) &
+         &  + inv_de_um*coeff(1:nb,3)))
+    scat_od = od - iwp_gm_2*inv_de_um*(coeff(1:nb,4) + de_um*(coeff(1:nb,5) &
+         &  + de_um*(coeff(1:nb,6) + de_um*coeff(1:nb,7))))
+    g = min(coeff(1:nb,8) + de_um*(coeff(1:nb,9) &
+         &  + de_um*(coeff(1:nb,10) + de_um*coeff(1:nb,11))), &
+! Added for DWD (2020)
+!NEC$ shortloop
+    do jb = 1, nb
+      od(jb) = iwp_gm_2 * (coeff(jb,1) + inv_de_um*(coeff(jb,2) &
+         &  + inv_de_um*coeff(jb,3)))
+      scat_od(jb) = od(jb) - iwp_gm_2*inv_de_um*(coeff(jb,4) + de_um*(coeff(jb,5) &
+         &  + de_um*(coeff(jb,6) + de_um*coeff(jb,7))))
+      g(jb) = min(coeff(jb,8) + de_um*(coeff(jb,9) &
+         &  + de_um*(coeff(jb,10) + de_um*coeff(jb,11))), &
          &  MaxAsymmetryFactor)
+    end do
     !if (lhook) call dr_hook('radiation_ice_optics:calc_ice_optics_fu_lw',1,hook_handle)

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_ifs_rrtm.F90

-                      r4115
+                      r4444
     real(jprb) :: hook_handle
 #include "surdi.intfb.h"
+!#include "surdi.intfb.h"
 #include "surrtab.intfb.h"
 #include "surrtpk.intfb.h"
 …
     ! up now.
     if (config%do_setup_ifsrrtm) then
       call SURDI
+      !call SURDI
       call SURRTAB
       call SURRTPK
 …
     end if
+    ! Cloud and aerosol properties can only be defined per band
+    config%do_cloud_aerosol_per_sw_g_point = .false.
+    config%do_cloud_aerosol_per_lw_g_point = .false.
     config%n_g_sw = jpgsw
     config%n_g_lw = jpglw
 …
     ! can compute UV and photosynthetically active radiation for a
     ! particular wavelength range
+    allocate(config%wavenumber1_sw(config%n_bands_sw))
+    allocate(config%wavenumber2_sw(config%n_bands_sw))
+    allocate(config%wavenumber1_lw(config%n_bands_lw))
+    allocate(config%wavenumber2_lw(config%n_bands_lw))
+    config%wavenumber1_lw = (/ 10, 350, 500, 630, 700, 820, 980, 1080, 1180, 1390, 1480, &
+         &  1800, 2080, 2250, 2380, 2600 /)
+    config%wavenumber2_lw = (/ 350, 500, 630, 700, 820, 980, 1080, 1180, 1390, 1480, 1800, &
+         &  2080, 2250, 2380, 2600, 3250 /)
+    config%wavenumber1_sw = (/ 2600, 3250, 4000, 4650, 5150, 6150, 7700, 8050, 12850, &
+         &  16000 , 22650, 29000, 38000, 820 /)
+    config%wavenumber2_sw = (/ 3250, 4000, 4650, 5150, 6150, 7700, 8050, 12850, 16000, &
+         &  22650, 29000, 38000, 50000, 2600 /)
+    print*,'allocate dans ifs_rrtm'
+    call config%gas_optics_sw%spectral_def%allocate_bands_only( &
+         &  [2600.0_jprb, 3250.0_jprb, 4000.0_jprb, 4650.0_jprb, 5150.0_jprb, 6150.0_jprb, 7700.0_jprb, &
+         &   8050.0_jprb, 12850.0_jprb, 16000.0_jprb, 22650.0_jprb, 29000.0_jprb, 38000.0_jprb, 820.0_jprb], &
+         &  [3250.0_jprb, 4000.0_jprb, 4650.0_jprb, 5150.0_jprb, 6150.0_jprb, 7700.0_jprb, 8050.0_jprb, &
+         &   12850.0_jprb, 16000.0_jprb, 22650.0_jprb, 29000.0_jprb, 38000.0_jprb, 50000.0_jprb, 2600.0_jprb])
+    call config%gas_optics_lw%spectral_def%allocate_bands_only( &
+         &  [10.0_jprb, 350.0_jprb, 500.0_jprb, 630.0_jprb, 700.0_jprb, 820.0_jprb, 980.0_jprb, 1080.0_jprb, &
+         &   1180.0_jprb, 1390.0_jprb, 1480.0_jprb, 1800.0_jprb, 2080.0_jprb, 2250.0_jprb, 2380.0_jprb, 2600.0_jprb], &
+         &  [350.0_jprb, 500.0_jprb, 630.0_jprb, 700.0_jprb, 820.0_jprb, 980.0_jprb, 1080.0_jprb, 1180.0_jprb, &
+         &   1390.0_jprb, 1480.0_jprb, 1800.0_jprb, 2080.0_jprb, 2250.0_jprb, 2380.0_jprb, 2600.0_jprb, 3250.0_jprb])
     allocate(config%i_band_from_g_sw          (config%n_g_sw))
     allocate(config%i_band_from_g_lw          (config%n_g_lw))
 …
 !    end if
+    pressure_fl(istartcol:iendcol,:) &
+         &  = 0.5_jprb * (thermodynamics%pressure_hl(istartcol:iendcol,istartlev:iendlev) &
+         &               +thermodynamics%pressure_hl(istartcol:iendcol,istartlev+1:iendlev+1))
+    temperature_fl(istartcol:iendcol,:) &
+         &  = 0.5_jprb * (thermodynamics%temperature_hl(istartcol:iendcol,istartlev:iendlev) &
+         &               +thermodynamics%temperature_hl(istartcol:iendcol,istartlev+1:iendlev+1))
+    do jlev=1,nlev
+      do jcol= istartcol,iendcol
+        pressure_fl(jcol,jlev) &
+            &  = 0.5_jprb * (thermodynamics%pressure_hl(jcol,jlev+istartlev-1) &
+            &               +thermodynamics%pressure_hl(jcol,jlev+istartlev))
+        temperature_fl(jcol,jlev) &
+            &  = 0.5_jprb * (thermodynamics%temperature_hl(jcol,jlev+istartlev-1) &
+            &               +thermodynamics%temperature_hl(jcol,jlev+istartlev))
+      end do
+    end do
     ! Check we have gas mixing ratios in the right units
 …
          &  ZRAT_N2OCO2, ZRAT_N2OCO2_1, ZRAT_O3CO2, ZRAT_O3CO2_1)
     ZTAUAERL = 0.0_jprb
+    ZTAUAERL(istartcol:iendcol,:,:) = 0.0_jprb
     CALL RRTM_GAS_OPTICAL_DEPTH &
 …
         lw_emission = lw_emission * (1.0_jprb - lw_albedo)
       else
       ! Longwave emission has already been computed
+        ! Longwave emission has already been computed
         if (config%use_canopy_full_spectrum_lw) then
           lw_emission = transpose(single_level%lw_emission(istartcol:iendcol,:))
 …
     ! Scale the incoming solar per band, if requested
     if (config%use_spectral_solar_scaling) then
+      ZINCSOL(istartcol:iendcol,:) = ZINCSOL(istartcol:iendcol,:) &
+         & * spread(single_level%spectral_solar_scaling(config%i_band_from_reordered_g_sw), &
+         &                                              1,iendcol-istartcol+1)
+      do jg = 1,JPGPT_SW
+        do jcol = istartcol,iendcol
+          ZINCSOL(jcol,jg) = ZINCSOL(jcol,jg) * &
+            &   single_level%spectral_solar_scaling(config%i_band_from_reordered_g_sw(jg))
+        end do
+      end do
     end if
 …
     ! ZINCSOL will be zero.
     if (present(incoming_sw)) then
-      incoming_sw_scale = 1.0_jprb
       do jcol = istartcol,iendcol
         if (single_level%cos_sza(jcol) > 0.0_jprb) then
+! Added for DWD (2020)
+!NEC$ nounroll
           incoming_sw_scale(jcol) = single_level%solar_irradiance / sum(ZINCSOL(jcol,:))
+        else
+          incoming_sw_scale(jcol) = 1.0_jprb
         end if
       end do
 …
     else
       ! G points have not been reordered
       do jg = 1,config%n_g_sw
+      do jcol = istartcol,iendcol
         do jlev = 1,nlev
           do jcol = istartcol,iendcol
+          do jg = 1,config%n_g_sw
             ! Check for negative optical depth
             od_sw (jg,nlev+1-jlev,jcol) = max(config%min_gas_od_sw, ZOD_SW(jcol,jlev,jg))
 …
         end do
         if (present(incoming_sw)) then
+          incoming_sw(jg,:) &
+               &  = incoming_sw_scale(:) * ZINCSOL(:,jg)
+          do jg = 1,config%n_g_sw
+            incoming_sw(jg,jcol) = incoming_sw_scale(jcol) * ZINCSOL(jcol,jg)
+          end do
         end if
       end do
 …
     real(jprb) :: temperature
     real(jprb) :: factor
+    real(jprb) :: factor, planck_tmp(istartcol:iendcol,config%n_g_lw)
     real(jprb) :: ZFLUXFAC
 …
           do jg = 1,config%n_g_lw
             iband = config%i_band_from_g_lw(jg)
+            planck_hl(jg,jlev,:) = planck_store(:,iband) * PFRAC(:,jg,nlev+2-jlev)
+            planck_tmp(:,jg) = planck_store(:,iband) * PFRAC(:,jg,nlev+2-jlev)
+          end do
+          do jcol = istartcol,iendcol
+            planck_hl(:,jlev,jcol) = planck_tmp(jcol,:)
           end do
         end if

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_interface.F90

-                      r3908
+                      r4444
     use yomhook,          only : lhook, dr_hook
     use radiation_config, only : config_type, ISolverMcICA, &
+         &   IGasModelMonochromatic, IGasModelIFSRRTMG
+         &   IGasModelMonochromatic, IGasModelIFSRRTMG, IGasModelECCKD
+    use radiation_spectral_definition, only &
+         &  : SolarReferenceTemperature, TerrestrialReferenceTemperature
     ! Currently there are two gas absorption models: RRTMG (default)
 …
          &   setup_cloud_optics_mono   => setup_cloud_optics, &
          &   setup_aerosol_optics_mono => setup_aerosol_optics
+    use radiation_ifs_rrtm,       only :  setup_gas_optics
+    use radiation_ifs_rrtm,       only :  setup_gas_optics_rrtmg => setup_gas_optics
+    use radiation_ecckd_interface,only :  setup_gas_optics_ecckd => setup_gas_optics
     use radiation_cloud_optics,   only :  setup_cloud_optics
+    use radiation_general_cloud_optics, only :  setup_general_cloud_optics
     use radiation_aerosol_optics, only :  setup_aerosol_optics
 …
       call setup_gas_optics_mono(config, trim(config%directory_name))
     else if (config%i_gas_model == IGasModelIFSRRTMG) then
+      call setup_gas_optics(config, trim(config%directory_name))
+      call setup_gas_optics_rrtmg(config, trim(config%directory_name))
+    else if (config%i_gas_model == IGasModelECCKD) then
+      call setup_gas_optics_ecckd(config)
     end if
 …
     ! Consolidate the albedo/emissivity intervals with the shortwave
     ! and longwave spectral bands
+    call config%consolidate_intervals(.true., &
+           &  config%do_nearest_spectral_sw_albedo, &
+           &  config%sw_albedo_wavelength_bound, config%i_sw_albedo_index, &
+           &  config%wavenumber1_sw, config%wavenumber2_sw, &
+           &  config%i_albedo_from_band_sw, config%sw_albedo_weights)
+    call config%consolidate_intervals(.false., &
+           &  config%do_nearest_spectral_lw_emiss, &
+           &  config%lw_emiss_wavelength_bound, config%i_lw_emiss_index, &
+           &  config%wavenumber1_lw, config%wavenumber2_lw, &
+           &  config%i_emiss_from_band_lw, config%lw_emiss_weights)
+    if (config%do_sw) then
+      call config%consolidate_sw_albedo_intervals
+    end if
+    if (config%do_lw) then
+      call config%consolidate_lw_emiss_intervals
+    end if
     if (config%do_clouds) then
       if (config%i_gas_model == IGasModelMonochromatic) then
         !      call setup_cloud_optics_mono(config)
+      elseif (config%use_general_cloud_optics) then
+        call setup_general_cloud_optics(config)
       else
         call setup_cloud_optics(config)
 …
     use radiation_config
+    use radiation_gas,           only : gas_type
+    use radiation_monochromatic, only : set_gas_units_mono  => set_gas_units
+    use radiation_ifs_rrtm,      only : set_gas_units_ifs   => set_gas_units
+    use radiation_gas,             only : gas_type
+    use radiation_monochromatic,   only : set_gas_units_mono  => set_gas_units
+    use radiation_ifs_rrtm,        only : set_gas_units_ifs   => set_gas_units
+    use radiation_ecckd_interface, only : set_gas_units_ecckd => set_gas_units
     type(config_type), intent(in)    :: config
 …
     if (config%i_gas_model == IGasModelMonochromatic) then
       call set_gas_units_mono(gas)
+    elseif (config%i_gas_model == IGasModelECCKD) then
+      call set_gas_units_ecckd(gas)
     else
       call set_gas_units_ifs(gas)
 …
          &   cloud_optics_mono       => cloud_optics, &
          &   add_aerosol_optics_mono => add_aerosol_optics
+    use radiation_ifs_rrtm,       only : gas_optics
+    use radiation_ifs_rrtm,       only : gas_optics_rrtmg => gas_optics
+    use radiation_ecckd_interface,only : gas_optics_ecckd => gas_optics
     use radiation_cloud_optics,   only : cloud_optics
+    use radiation_general_cloud_optics, only : general_cloud_optics
     use radiation_aerosol_optics, only : add_aerosol_optics
 …
              &  od_lw, od_sw, ssa_sw, &
              &  planck_hl, lw_emission, incoming_sw)
+      else if (config%i_gas_model == IGasModelIFSRRTMG) then
+        call gas_optics_rrtmg(ncol,nlev,istartcol,iendcol, config, &
+             &  single_level, thermodynamics, gas, &
+             &  od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, &
+             &  planck_hl=planck_hl, lw_emission=lw_emission, &
+             &  incoming_sw=incoming_sw)
       else
         call gas_optics(ncol,nlev,istartcol,iendcol, config, &
+        call gas_optics_ecckd(ncol,nlev,istartcol,iendcol, config, &
              &  single_level, thermodynamics, gas, &
              &  od_lw, od_sw, ssa_sw, lw_albedo=lw_albedo, &
 …
           call cloud_optics_mono(nlev, istartcol, iendcol, &
                &  config, thermodynamics, cloud, &
+               &  od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
+               &  od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
+        elseif (config%use_general_cloud_optics) then
+          call general_cloud_optics(nlev, istartcol, iendcol, &
+               &  config, thermodynamics, cloud, &
                &  od_lw_cloud, ssa_lw_cloud, g_lw_cloud, &
                &  od_sw_cloud, ssa_sw_cloud, g_sw_cloud)
 …
         end if
       else
         g_sw = 0.0_jprb
+        g_sw(:,:,istartcol:iendcol) = 0.0_jprb
         if (config%do_lw_aerosol_scattering) then
           ssa_lw = 0.0_jprb
           g_lw   = 0.0_jprb
+          ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb
+          g_lw(:,:,istartcol:iendcol)   = 0.0_jprb
         end if
       end if

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_liquid_optics_socrates.F90

-                      r3908
+                      r4444
     real(jprb), intent(out) :: od(nb), scat_od(nb), g(nb)
+    integer    :: jb
     ! Local effective radius (m), after applying bounds
     real(jprb) :: re
 …
     re = max(MinEffectiveRadius, min(re_in, MaxEffectiveRadius))
+    od = lwp * (coeff(1:nb,1) + re*(coeff(1:nb,2) + re*coeff(1:nb,3))) &
+         &  / (1.0_jprb + re*(coeff(1:nb,4) + re*(coeff(1:nb,5) &
+         &  + re*coeff(1:nb,6))))
+    scat_od = od * (1.0_jprb &
+         &  - (coeff(1:nb,7) + re*(coeff(1:nb,8) + re*coeff(1:nb,9))) &
+         &  / (1.0_jprb + re*(coeff(1:nb,10) + re*coeff(1:nb,11))))
+    g = (coeff(1:nb,12) + re*(coeff(1:nb,13) + re*coeff(1:nb,14))) &
+         &  / (1.0_jprb + re*(coeff(1:nb,15) + re*coeff(1:nb,16)))
+! Added for DWD (2020)
+!NEC$ shortloop
+    do jb = 1, nb
+      od(jb) = lwp * (coeff(jb,1) + re*(coeff(jb,2) + re*coeff(jb,3))) &
+         &  / (1.0_jprb + re*(coeff(jb,4) + re*(coeff(jb,5) &
+         &  + re*coeff(jb,6))))
+      scat_od(jb) = od(jb) * (1.0_jprb &
+         &  - (coeff(jb,7) + re*(coeff(jb,8) + re*coeff(jb,9))) &
+         &  / (1.0_jprb + re*(coeff(jb,10) + re*coeff(jb,11))))
+      g(jb) = (coeff(jb,12) + re*(coeff(jb,13) + re*coeff(jb,14))) &
+         &  / (1.0_jprb + re*(coeff(jb,15) + re*coeff(jb,16)))
+    end do
     !if (lhook) call dr_hook('radiation_liquid_optics_socrates:calc_liq_optics_socrates',1,hook_handle)

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_matrix.F90

r3908	r4444
550	550	real(jprb), dimension(iend) :: y2, y3
551	551
552		~~integer :: j~~
553
554	552	! associate (U11 => A(:,1,1), U12 => A(:,1,2), U13 => A(1,3))
555	553	! LU decomposition of the transpose of A:

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_mcica_lw.F90

-                      r3908
+                      r4444
         ! transmittance etc at each model level
         do jlev = 1,nlev
+          ssa_total = ssa(:,jlev,jcol)
+          g_total   = g(:,jlev,jcol)
+          call calc_two_stream_gammas_lw(ng, ssa_total, g_total, &
+          call calc_two_stream_gammas_lw(ng, ssa(:,jlev,jcol), g(:,jlev,jcol), &
                &  gamma1, gamma2)
           call calc_reflectance_transmittance_lw(ng, &
 …
            &  config%cloud_inhom_decorr_scaling, cloud%fractional_std(jcol,:), &
            &  config%pdf_sampler, od_scaling, total_cloud_cover, &
+           &  is_beta_overlap=config%use_beta_overlap)
+           &  use_beta_overlap=config%use_beta_overlap, &
+           &  use_vectorizable_generator=config%use_vectorizable_generator)
       ! Store total cloud cover
 …
             end if
+            od_cloud_new = od_scaling(:,jlev) &
+                 &  * od_cloud(config%i_band_from_reordered_g_lw,jlev,jcol)
+            od_total = od(:,jlev,jcol) + od_cloud_new
+            ssa_total = 0.0_jprb
+            g_total   = 0.0_jprb
+            do jg = 1,ng
+              od_cloud_new(jg) = od_scaling(jg,jlev) &
+                 &  * od_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol)
+              od_total(jg)  = od(jg,jlev,jcol) + od_cloud_new(jg)
+              ssa_total(jg) = 0.0_jprb
+              g_total(jg)   = 0.0_jprb
+            end do
             if (config%do_lw_cloud_scattering) then
 …
                 ! case that od_total > 0.0 and ssa_total > 0.0 but
                 ! od_total*ssa_total == 0 due to underflow
+                scat_od_total = ssa(:,jlev,jcol)*od(:,jlev,jcol) &
+                     &     + ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) &
+                     &     *  od_cloud_new
+                where (scat_od_total > 0.0_jprb)
+                  g_total = (g(:,jlev,jcol)*ssa(:,jlev,jcol)*od(:,jlev,jcol) &
+                       &     +   g_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) &
+                       &     * ssa_cloud(config%i_band_from_reordered_g_lw,jlev,jcol) &
+                       &     *  od_cloud_new) &
+                       &     / scat_od_total
+                end where
+                where (od_total > 0.0_jprb)
+                  ssa_total = scat_od_total / od_total
+                end where
+                do jg = 1,ng
+                  if (od_total(jg) > 0.0_jprb) then
+                    scat_od_total(jg) = ssa(jg,jlev,jcol)*od(jg,jlev,jcol) &
+                     &     + ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) &
+                     &     *  od_cloud_new(jg)
+                    ssa_total(jg) = scat_od_total(jg) / od_total(jg)
+                    if (scat_od_total(jg) > 0.0_jprb) then
+                      g_total(jg) = (g(jg,jlev,jcol)*ssa(jg,jlev,jcol)*od(jg,jlev,jcol) &
+                         &     +   g_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) &
+                         &     * ssa_cloud(config%i_band_from_reordered_g_lw(jg),jlev,jcol) &
+                         &     *  od_cloud_new(jg)) &
+                         &     / scat_od_total(jg)
+                    end if
+                  end if
+                end do
               else
                 do jg = 1,ng
                   if (od_total(jg) > 0.0_jprb) then
 …
                   end if
                 end do
               end if
 …
           ! Use adding method to compute fluxes but optimize for the
           ! presence of clear-sky layers
-!          call adding_ica_lw(ng, nlev, reflectance, transmittance, source_up, source_dn, &
-!               &  emission(:,jcol), albedo(:,jcol), &
-!               &  flux_up, flux_dn)
           call fast_adding_ica_lw(ng, nlev, reflectance, transmittance, source_up, source_dn, &
                &  emission(:,jcol), albedo(:,jcol), &

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_mcica_sw.F90

-                      r3908
+                      r4444
              &  config%cloud_inhom_decorr_scaling, cloud%fractional_std(jcol,:), &
              &  config%pdf_sampler, od_scaling, total_cloud_cover, &
+             &  is_beta_overlap=config%use_beta_overlap)
+             &  use_beta_overlap=config%use_beta_overlap, &
+             &  use_vectorizable_generator=config%use_vectorizable_generator)
         ! Store total cloud cover
 …
             ! Compute combined gas+aerosol+cloud optical properties
             if (cloud%fraction(jcol,jlev) >= config%cloud_fraction_threshold) then
-              od_cloud_new = od_scaling(:,jlev) &
-                   &  * od_cloud(config%i_band_from_reordered_g_sw,jlev,jcol)
-              od_total  = od(:,jlev,jcol) + od_cloud_new
-              ssa_total = 0.0_jprb
-              g_total   = 0.0_jprb
-              ! In single precision we need to protect against the
-              ! case that od_total > 0.0 and ssa_total > 0.0 but
-              ! od_total*ssa_total == 0 due to underflow
               do jg = 1,ng
+                od_cloud_new(jg) = od_scaling(jg,jlev) &
+                   &  * od_cloud(config%i_band_from_reordered_g_sw(jg),jlev,jcol)
+                od_total(jg)  = od(jg,jlev,jcol) + od_cloud_new(jg)
+                ssa_total(jg) = 0.0_jprb
+                g_total(jg)   = 0.0_jprb
+                ! In single precision we need to protect against the
+                ! case that od_total > 0.0 and ssa_total > 0.0 but
+                ! od_total*ssa_total == 0 due to underflow
                 if (od_total(jg) > 0.0_jprb) then
                   scat_od = ssa(jg,jlev,jcol)*od(jg,jlev,jcol) &

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_monochromatic.F90

-                      r3908
+                      r4444
     real(jprb), dimension(config%n_g_sw,nlev,istartcol:iendcol), intent(out) :: g_sw
     g_sw = 0.0_jprb
+    g_sw(:,:,istartcol:iendcol) = 0.0_jprb
     if (config%do_lw_aerosol_scattering) then
       ssa_lw = 0.0_jprb
       g_lw   = 0.0_jprb
+      ssa_lw(:,:,istartcol:iendcol) = 0.0_jprb
+      g_lw(:,:,istartcol:iendcol)   = 0.0_jprb
     end if

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_pdf_sampler.F90

-                      r3908
+                      r4444
 ! radiation_pdf_sampler.F90 - Get samples from a lognormal distribution for McICA
+! radiation_pdf_sampler.F90 - Get samples from a PDF for McICA
+!
 ! (C) Copyright 2015- ECMWF.
 …
   !---------------------------------------------------------------------
+  ! Derived type for sampling from a lognormal distribution, used to
+  ! generate water content or optical depth scalings for use in the
+  ! Monte Carlo Independent Column Approximation (McICA)
+  ! Derived type for sampling from a lognormal or gamma distribution,
+  ! or other PDF, used to generate water content or optical depth
+  ! scalings for use in the Monte Carlo Independent Column
+  ! Approximation (McICA)
   type pdf_sampler_type
     ! Number of points in look-up table for cumulative distribution
 …
     procedure :: sample => sample_from_pdf
     procedure :: masked_sample => sample_from_pdf_masked
+    procedure :: block_sample => sample_from_pdf_block
+    procedure :: masked_block_sample => sample_from_pdf_masked_block
     procedure :: deallocate => deallocate_pdf_sampler
 …
   !---------------------------------------------------------------------
   ! Extract the value of a lognormal distribution with fractional
   ! standard deviation "fsd" corresponding to the cumulative
   ! distribution function value "cdf", and return it in val. Since this
   ! is an elemental subroutine, fsd, cdf and val may be arrays.
+  ! Extract the value from a PDF with fractional standard deviation
+  ! "fsd" corresponding to the cumulative distribution function value
+  ! "cdf", and return it in val. Since this is an elemental
+  ! subroutine, fsd, cdf and val may be arrays.
   elemental subroutine sample_from_pdf(this, fsd, cdf, val)
 …
   !---------------------------------------------------------------------
+  ! For true elements of mask, extract the values of a lognormal
+  ! distribution with fractional standard deviation "fsd"
+  ! corresponding to the cumulative distribution function values
+  ! "cdf", and return in val. For false elements of mask, return zero
+  ! in val.
+  ! For true elements of mask, extract the values of a PDF with
+  ! fractional standard deviation "fsd" corresponding to the
+  ! cumulative distribution function values "cdf", and return in
+  ! val. For false elements of mask, return zero in val.
   subroutine sample_from_pdf_masked(this, nsamp, fsd, cdf, val, mask)
 …
   end subroutine sample_from_pdf_masked
+  !---------------------------------------------------------------------
+  ! Extract the values of a PDF with fractional standard deviation
+  ! "fsd" corresponding to the cumulative distribution function values
+  ! "cdf", and return in val. This version works on 2D blocks of data.
+  subroutine sample_from_pdf_block(this, nz, ng, fsd, cdf, val)
+    class(pdf_sampler_type), intent(in)  :: this
+    ! Number of samples
+    integer,    intent(in) :: nz, ng
+    ! Fractional standard deviation (0 to 4) and cumulative
+    ! distribution function (0 to 1)
+    real(jprb), intent(in)  :: fsd(nz), cdf(ng, nz)
+    ! Sample from distribution
+    real(jprb), intent(out) :: val(:,:)
+    ! Loop index
+    integer    :: jz, jg
+    ! Index to look-up table
+    integer    :: ifsd, icdf
+    ! Weights in bilinear interpolation
+    real(jprb) :: wfsd, wcdf
+    do jz = 1,nz
+      do jg = 1,ng
+        if (cdf(jg, jz) > 0.0_jprb) then
+          ! Bilinear interpolation with bounds
+          wcdf = cdf(jg,jz) * (this%ncdf-1) + 1.0_jprb
+          icdf = max(1, min(int(wcdf), this%ncdf-1))
+          wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb))
+          wfsd = (fsd(jz)-this%fsd1) * this%inv_fsd_interval + 1.0_jprb
+          ifsd = max(1, min(int(wfsd), this%nfsd-1))
+          wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb))
+          val(jg,jz)=(1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf  ,ifsd)   &
+               &    +(1.0_jprb-wcdf)*          wfsd  * this%val(icdf  ,ifsd+1) &
+               &    +          wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd)   &
+               &    +          wcdf *          wfsd  * this%val(icdf+1,ifsd+1)
+        else
+          val(jg,jz) = 0.0_jprb
+        end if
+      end do
+    end do
+  end subroutine sample_from_pdf_block
+  !---------------------------------------------------------------------
+  ! Extract the values of a PDF with fractional standard deviation
+  ! "fsd" corresponding to the cumulative distribution function values
+  ! "cdf", and return in val. This version works on 2D blocks of data.
+  subroutine sample_from_pdf_masked_block(this, nz, ng, fsd, cdf, val, mask)
+    class(pdf_sampler_type), intent(in)  :: this
+    ! Number of samples
+    integer,    intent(in) :: nz, ng
+    ! Fractional standard deviation (0 to 4) and cumulative
+    ! distribution function (0 to 1)
+    real(jprb), intent(in)  :: fsd(nz), cdf(ng, nz)
+    ! Sample from distribution
+    real(jprb), intent(out) :: val(:,:)
+    ! Mask
+    logical,    intent(in), optional :: mask(nz)
+    ! Loop index
+    integer    :: jz, jg
+    ! Index to look-up table
+    integer    :: ifsd, icdf
+    ! Weights in bilinear interpolation
+    real(jprb) :: wfsd, wcdf
+    do jz = 1,nz
+      if (mask(jz)) then
+        do jg = 1,ng
+          if (cdf(jg, jz) > 0.0_jprb) then
+            ! Bilinear interpolation with bounds
+            wcdf = cdf(jg,jz) * (this%ncdf-1) + 1.0_jprb
+            icdf = max(1, min(int(wcdf), this%ncdf-1))
+            wcdf = max(0.0_jprb, min(wcdf - icdf, 1.0_jprb))
+            wfsd = (fsd(jz)-this%fsd1) * this%inv_fsd_interval + 1.0_jprb
+            ifsd = max(1, min(int(wfsd), this%nfsd-1))
+            wfsd = max(0.0_jprb, min(wfsd - ifsd, 1.0_jprb))
+            val(jg,jz)=(1.0_jprb-wcdf)*(1.0_jprb-wfsd) * this%val(icdf  ,ifsd)   &
+                 &    +(1.0_jprb-wcdf)*          wfsd  * this%val(icdf  ,ifsd+1) &
+                 &    +          wcdf *(1.0_jprb-wfsd) * this%val(icdf+1,ifsd)   &
+                 &    +          wcdf *          wfsd  * this%val(icdf+1,ifsd+1)
+          else
+            val(jg,jz) = 0.0_jprb
+          end if
+        end do
+      end if
+    end do
+  end subroutine sample_from_pdf_masked_block
 end module radiation_pdf_sampler

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_save.F90

-                      r3908
+                      r4444
   ! thermodynamics object
   subroutine save_fluxes(file_name, config, thermodynamics, flux, &
+       &                 iverbose, is_hdf5_file, experiment_name)
+       &                 iverbose, is_hdf5_file, experiment_name, &
+       &                 is_double_precision)
     use yomhook,                  only : lhook, dr_hook
 …
     integer,          optional, intent(in) :: iverbose
     logical,          optional, intent(in) :: is_hdf5_file
+    logical,          optional, intent(in) :: is_double_precision
     character(len=*), optional, intent(in) :: experiment_name
 …
     ! output file column varies most slowly so need to transpose
     call out_file%transpose_matrices(.true.)
+    ! Set default precision for file, if specified
+    if (present(is_double_precision)) then
+      call out_file%double_precision(is_double_precision)
+    end if
     ! Spectral fluxes in memory are dimensioned (nband,ncol,nlev), but
 …
            &   dim2_name="column", dim1_name="level", &
            &   units_str="m", long_name="Ice effective radius")
       if (allocated(cloud%re_ice)) then
+      if (associated(cloud%re_ice)) then
         call out_file%define_variable("re_ice", &
              &   dim2_name="column", dim1_name="level", &
 …
       call out_file%put("q_ice", cloud%q_ice)
       call out_file%put("re_liquid", cloud%re_liq)
       if (allocated(cloud%re_ice)) then
+      if (associated(cloud%re_ice)) then
         call out_file%put("re_ice", cloud%re_ice)
       end if

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_scheme.F90

-                      r4388
+                      r4444
 ! Compute UV fluxes as weighted sum of appropriate shortwave bands
+!AI ATTENTION
+if (0.eq.1) then
 PFLUX_UV       (KIDIA:KFDIA) = 0.0_JPRB
 DO JBAND = 1,NWEIGHT_UV
 …
        &  * flux%sw_dn_surf_clear_band(IBAND_PAR(JBAND),KIDIA:KFDIA)
 ENDDO
+endif
 ! Compute effective broadband emissivity
 ZBLACK_BODY_NET_LW = flux%lw_dn(KIDIA:KFDIA,KLEV+1) &
 …
 !AI ATTENTION
 !IF (YRERAD%LAPPROXSWUPDATE) THEN
+if (0.eq.1) then
 IF (rad_config%do_surface_sw_spectral_flux) THEN
   PSWDIFFUSEBAND(KIDIA:KFDIA,:) = 0.0_JPRB
 …
   ENDDO
 ENDIF
+endif
 CALL single_level%deallocate
 CALL thermodynamics%deallocate

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_setup.F90

r4388	r4444
88	88
89	89	USE radiation_interface, ONLY : setup_radiation
90		USE radiation_aerosol_optics, ONLY : dry_aerosol_sw_mass_extinction
	90	! USE radiation_aerosol_optics, ONLY : dry_aerosol_sw_mass_extinction
91	91
92	92	! AI (propre a IFS)

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_single_level.F90

-                      r3908
+                      r4444
   !---------------------------------------------------------------------
+  ! Allocate the arrays of a single-level type
   subroutine allocate_single_level(this, ncol, nalbedobands, nemisbands, &
        &                           use_sw_albedo_direct, is_simple_surface)
 …
   !---------------------------------------------------------------------
+  ! Deallocate the arrays of a single-level type
   subroutine deallocate_single_level(this)
 …
     ! Temporary storage of albedo in ecRad bands
     real(jprb) :: sw_albedo_band(istartcol:iendcol, config%n_bands_sw)
     real(jprb) :: lw_albedo_band (istartcol:iendcol, config%n_bands_lw)
+    real(jprb) :: lw_albedo_band(istartcol:iendcol, config%n_bands_lw)
     ! Number of albedo bands
 …
     ! Loop indices for ecRad bands and albedo bands
     integer :: jband, jalbedoband
+    integer :: jband, jalbedoband, jcol
     real(jprb) :: hook_handle
 …
     if (lhook) call dr_hook('radiation_single_level:get_albedos',0,hook_handle)
+    ! Albedos/emissivities are stored in single_level in their own
+    ! spectral intervals and with column as the first dimension
+    if (config%use_canopy_full_spectrum_sw) then
+      ! Albedos provided in each g point
+      sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol,:))
+      if (allocated(this%sw_albedo_direct)) then
+        sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol,:))
+      end if
+    elseif (.not. config%do_nearest_spectral_sw_albedo) then
+      ! Albedos averaged accurately to ecRad spectral bands
+      nalbedoband = size(config%sw_albedo_weights,1)
+      sw_albedo_band = 0.0_jprb
+      do jband = 1,config%n_bands_sw
+        do jalbedoband = 1,nalbedoband
+          if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then
+            sw_albedo_band(istartcol:iendcol,jband) &
+                 &  = sw_albedo_band(istartcol:iendcol,jband) &
+                 &  + config%sw_albedo_weights(jalbedoband,jband) &
+                 &    * this%sw_albedo(istartcol:iendcol, jalbedoband)
+          end if
+        end do
+      end do
+      sw_albedo_diffuse = transpose(sw_albedo_band(istartcol:iendcol, &
+           &                              config%i_band_from_reordered_g_sw))
+      if (allocated(this%sw_albedo_direct)) then
+    if (config%do_sw) then
+      ! Albedos/emissivities are stored in single_level in their own
+      ! spectral intervals and with column as the first dimension
+      if (config%use_canopy_full_spectrum_sw) then
+        ! Albedos provided in each g point
+        if (size(this%sw_albedo,2) /= config%n_g_sw) then
+          write(nulerr,'(a,i0,a)') '*** Error: single_level%sw_albedo does not have the expected ', &
+               &  config%n_g_sw, ' spectral intervals'
+          call radiation_abort()
+        end if
+        sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol,:))
+        if (allocated(this%sw_albedo_direct)) then
+          sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol,:))
+        end if
+      else if (.not. config%do_nearest_spectral_sw_albedo) then
+        ! Albedos averaged accurately to ecRad spectral bands
+        nalbedoband = size(config%sw_albedo_weights,1)
+        if (size(this%sw_albedo,2) /= nalbedoband) then
+          write(nulerr,'(a,i0,a)') '*** Error: single_level%sw_albedo does not have the expected ', &
+               &  nalbedoband, ' bands'
+          call radiation_abort()
+        end if
         sw_albedo_band = 0.0_jprb
         do jband = 1,config%n_bands_sw
           do jalbedoband = 1,nalbedoband
             if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then
+              sw_albedo_band(istartcol:iendcol,jband) &
+                   &  = sw_albedo_band(istartcol:iendcol,jband) &
+                   &  + config%sw_albedo_weights(jalbedoband,jband) &
+                   &    * this%sw_albedo_direct(istartcol:iendcol, jalbedoband)
+              do jcol = istartcol,iendcol
+                sw_albedo_band(jcol,jband) &
+                    &  = sw_albedo_band(jcol,jband) &
+                    &  + config%sw_albedo_weights(jalbedoband,jband) &
+                    &    * this%sw_albedo(jcol, jalbedoband)
+              end do
             end if
           end do
         end do
+        sw_albedo_direct = transpose(sw_albedo_band(istartcol:iendcol, &
+             &                             config%i_band_from_reordered_g_sw))
+        sw_albedo_diffuse = transpose(sw_albedo_band(istartcol:iendcol, &
+             &                              config%i_band_from_reordered_g_sw))
+        if (allocated(this%sw_albedo_direct)) then
+          sw_albedo_band = 0.0_jprb
+          do jband = 1,config%n_bands_sw
+            do jalbedoband = 1,nalbedoband
+              if (config%sw_albedo_weights(jalbedoband,jband) /= 0.0_jprb) then
+                sw_albedo_band(istartcol:iendcol,jband) &
+                     &  = sw_albedo_band(istartcol:iendcol,jband) &
+                     &  + config%sw_albedo_weights(jalbedoband,jband) &
+                     &    * this%sw_albedo_direct(istartcol:iendcol, jalbedoband)
+              end if
+            end do
+          end do
+          sw_albedo_direct = transpose(sw_albedo_band(istartcol:iendcol, &
+               &                             config%i_band_from_reordered_g_sw))
+        else
+          sw_albedo_direct = sw_albedo_diffuse
+        end if
       else
+        sw_albedo_direct = sw_albedo_diffuse
+        ! Albedos mapped less accurately to ecRad spectral bands
+        sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol, &
+             &  config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw)))
+        if (allocated(this%sw_albedo_direct)) then
+          sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol, &
+               &  config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw)))
+        else
+          sw_albedo_direct = sw_albedo_diffuse
+        end if
       end if
+    else
+      ! Albedos mapped less accurately to ecRad spectral bands
+      sw_albedo_diffuse = transpose(this%sw_albedo(istartcol:iendcol, &
+           &  config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw)))
+      if (allocated(this%sw_albedo_direct)) then
+        sw_albedo_direct = transpose(this%sw_albedo_direct(istartcol:iendcol, &
+             &  config%i_albedo_from_band_sw(config%i_band_from_reordered_g_sw)))
+      else
+        sw_albedo_direct = sw_albedo_diffuse
+      end if
+    end if
+    if (present(lw_albedo)) then
+    end if
+    if (config%do_lw .and. present(lw_albedo)) then
       if (config%use_canopy_full_spectrum_lw) then
         if (config%n_g_lw /= size(this%lw_emissivity,2)) then
+          write(nulerr,'(a)') '*** Error: single_level%lw_emissivity has the wrong number of spectral intervals'
+          call radiation_abort()
+          write(nulerr,'(a,i0,a)') '*** Error: single_level%lw_emissivity does not have the expected ', &
+               &  config%n_g_lw, ' spectral intervals'
+          call radiation_abort()
         end if
         lw_albedo = 1.0_jprb - transpose(this%lw_emissivity(istartcol:iendcol,:))
 …
         ! Albedos averaged accurately to ecRad spectral bands
         nalbedoband = size(config%lw_emiss_weights,1)
+        if (nalbedoband /= size(this%lw_emissivity,2)) then
+          write(nulerr,'(a,i0,a)') '*** Error: single_level%lw_emissivity does not have the expected ', &
+               &  nalbedoband, ' bands'
+          call radiation_abort()
+        end if
         lw_albedo_band = 0.0_jprb
         do jband = 1,config%n_bands_lw
           do jalbedoband = 1,nalbedoband
             if (config%lw_emiss_weights(jalbedoband,jband) /= 0.0_jprb) then
+              lw_albedo_band(istartcol:iendcol,jband) &
+                   &  = lw_albedo_band(istartcol:iendcol,jband) &
+                   &  + config%lw_emiss_weights(jalbedoband,jband) &
+                   &    * (1.0_jprb-this%lw_emissivity(istartcol:iendcol, jalbedoband))
+              do jcol = istartcol,iendcol
+                lw_albedo_band(jcol,jband) &
+                    &  = lw_albedo_band(jcol,jband) &
+                    &  + config%lw_emiss_weights(jalbedoband,jband) &
+                    &    * (1.0_jprb-this%lw_emissivity(jcol, jalbedoband))
+              end do
             end if
           end do
 …
     use yomhook,          only : lhook, dr_hook
     use radiation_config, only : out_of_bounds_1d, out_of_bounds_2d
+    use radiation_check,  only : out_of_bounds_1d, out_of_bounds_2d
     class(single_level_type), intent(inout) :: this

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_spartacus_lw.F90

-                      r3908
+                      r4444
     use radiation_matrix
     use radiation_two_stream,     only : calc_two_stream_gammas_lw, &
          calc_reflectance_transmittance_lw, LwDiffusivity
+         calc_reflectance_transmittance_lw, LwDiffusivityWP
     use radiation_lw_derivatives, only : calc_lw_derivatives_matrix
     use radiation_constants,      only : Pi, GasConstantDryAir, &
 …
             planck_top(1:ng3D,nreg+jreg) = od_region(1:ng3D,jreg) &
                  &  *(1.0_jprb-ssa_region(1:ng3D,jreg))*region_fracs(jreg,jlev,jcol) &
                  &  *planck_hl(1:ng3D,jlev,jcol)*LwDiffusivity
+                 &  *planck_hl(1:ng3D,jlev,jcol)*LwDiffusivityWP
             planck_top(1:ng3D,jreg) = -planck_top(1:ng3D,nreg+jreg)
             planck_diff(1:ng3D,nreg+jreg) = od_region(1:ng3D,jreg) &
                  &  * (1.0_jprb-ssa_region(1:ng3D,jreg))*region_fracs(jreg,jlev,jcol) &
                  &  * (planck_hl(1:ng3D,jlev+1,jcol) &
                  &  -planck_hl(1:ng3D,jlev,jcol))*LwDiffusivity
+                 &  -planck_hl(1:ng3D,jlev,jcol))*LwDiffusivityWP
             planck_diff(1:ng3D,jreg) = -planck_diff(1:ng3D,nreg+jreg)
           end do

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_spartacus_sw.F90

r3908	r4444
1303	1303	transfer_scaling = 1.0_jprb - (1.0_jprb - config%overhang_factor) &
1304	1304	& * cloud%overlap_param(jcol,jlev-1) &
1305		& * min(region_fracs(jreg,jlev,jcol), region_fracs(jreg,jlev-1,jcol))
	1305	& * min(region_fracs(jreg,jlev,jcol), region_fracs(jreg,jlev-1,jcol)) &
1306	1306	& / max(config%cloud_fraction_threshold, region_fracs(jreg,jlev,jcol))
1307	1307	do jreg4 = 1,nreg

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_thermodynamics.F90

r3908	r4444
297	297
298	298	use yomhook, only : lhook, dr_hook
299		use radiation_c~~onfig,~~ only : out_of_bounds_2d
	299	use radiation_check, only : out_of_bounds_2d
300	300
301	301	class(thermodynamics_type), intent(inout) :: this

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_tripleclouds_lw.F90

-                      r3908
+                      r4444
 !   2017-10-23  R. Hogan  Renamed single-character variables
 !   2018-10-08  R. Hogan  Call calc_region_properties
+!   2020-09-18  R. Hogan  Replaced some array expressions with loops
+!   2020-09-19  R. Hogan  Implement the cloud-only-scattering optimization
 module radiation_tripleclouds_lw
 …
 #include "radiation_optical_depth_scaling.h"
+  !---------------------------------------------------------------------
   ! This module contains just one subroutine, the longwave
   ! "Tripleclouds" solver in which cloud inhomogeneity is treated by
 …
   ! cloudy (with differing optical depth). This approach was described
   ! by Shonk and Hogan (2008).
   subroutine solver_tripleclouds_lw(nlev,istartcol,iendcol, &
        &  config, cloud, &
 …
     use radiation_regions, only        : calc_region_properties
     use radiation_overlap, only        : calc_overlap_matrices
+    use radiation_flux, only           : flux_type, &
+         &                               indexed_sum, add_indexed_sum
+    use radiation_flux, only           : flux_type, indexed_sum
     use radiation_matrix, only         : singlemat_x_vec
     use radiation_two_stream, only     : calc_two_stream_gammas_lw, &
          &                               calc_reflectance_transmittance_lw, &
          &                               calc_no_scattering_transmittance_lw
+    use radiation_adding_ica_lw, only  : adding_ica_lw, calc_fluxes_no_scattering_lw
     use radiation_lw_derivatives, only : calc_lw_derivatives_region
 …
     ! streams
     real(jprb), dimension(config%n_g_lw, nregions, nlev) &
+         &  :: Sup, Sdn
+         &  :: source_up, source_dn
+    ! Clear-sky reflectance and transmittance
+    real(jprb), dimension(config%n_g_lw, nlev) &
+         &  :: ref_clear, trans_clear
     ! ...clear-sky equivalent
     real(jprb), dimension(config%n_g_lw, nlev) &
          &  :: Sup_clear, Sdn_clear
+         &  :: source_up_clear, source_dn_clear
     ! Total albedo of the atmosphere/surface just above a layer
 …
     real(jprb), dimension(config%n_g_lw, nregions, nlev+1) :: total_source
-    ! ...equivalent values for clear-skies
-    real(jprb), dimension(config%n_g_lw, nlev+1) :: total_albedo_clear, total_source_clear
     ! Total albedo and source of the atmosphere just below a layer interface
     real(jprb), dimension(config%n_g_lw, nregions) &
 …
     ! ...clear-sky equivalent (no distinction between "above/below")
     real(jprb), dimension(config%n_g_lw) &
+    real(jprb), dimension(config%n_g_lw, nlev+1) &
          &  :: flux_dn_clear, flux_up_clear
 …
     ! and below the ground, both treated as single-region clear skies
     logical :: is_clear_sky_layer(0:nlev+1)
+    ! Index of the highest cloudy layer
+    integer :: i_cloud_top
     integer :: jcol, jlev, jg, jreg, jreg2, ng
 …
       ! cloud%crop_cloud_fraction has already been called
       is_clear_sky_layer = .true.
+      i_cloud_top = nlev+1
       do jlev = 1,nlev
         if (cloud%fraction(jcol,jlev) > 0.0_jprb) then
           is_clear_sky_layer(jlev) = .false.
+          ! Get index to the first cloudy layer from the top
+          if (i_cloud_top > jlev) then
+            i_cloud_top = jlev
+          end if
         end if
       end do
+      ! --------------------------------------------------------
+      ! Section 3: Loop over layers to compute reflectance and transmittance
+      if (config%do_lw_aerosol_scattering) then
+        ! This is actually the first layer in which we need to
+        ! consider scattering
+        i_cloud_top = 1
+      end if
+      ! --------------------------------------------------------
+      ! Section 3: Clear-sky calculation
+      ! --------------------------------------------------------
+      if (.not. config%do_lw_aerosol_scattering) then
+        ! No scattering in clear-sky flux calculation
+        do jlev = 1,nlev
+          ! Array-wise assignments
+          gamma1 = 0.0_jprb
+          gamma2 = 0.0_jprb
+          call calc_no_scattering_transmittance_lw(ng, od(:,jlev,jcol), &
+               &  planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), &
+               &  trans_clear(:,jlev), source_up_clear(:,jlev), source_dn_clear(:,jlev))
+          ref_clear(:,jlev) = 0.0_jprb
+        end do
+        ! Simple down-then-up method to compute fluxes
+        call calc_fluxes_no_scattering_lw(ng, nlev, &
+             &  trans_clear, source_up_clear, source_dn_clear, &
+             &  emission(:,jcol), albedo(:,jcol), &
+             &  flux_up_clear, flux_dn_clear)
+      else
+        ! Scattering in clear-sky flux calculation
+        do jlev = 1,nlev
+          ! Array-wise assignments
+          gamma1 = 0.0_jprb
+          gamma2 = 0.0_jprb
+          call calc_two_stream_gammas_lw(ng, &
+               &  ssa(:,jlev,jcol), g(:,jlev,jcol), gamma1, gamma2)
+          call calc_reflectance_transmittance_lw(ng, &
+               &  od(:,jlev,jcol), gamma1, gamma2, &
+               &  planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), &
+               &  ref_clear(:,jlev), trans_clear(:,jlev), &
+               &  source_up_clear(:,jlev), source_dn_clear(:,jlev))
+        end do
+        ! Use adding method to compute fluxes
+        call adding_ica_lw(ng, nlev, &
+             &  ref_clear, trans_clear, source_up_clear, source_dn_clear, &
+             &  emission(:,jcol), albedo(:,jcol), &
+             &  flux_up_clear, flux_dn_clear)
+      end if
+      if (config%do_clear) then
+        ! Sum over g-points to compute broadband fluxes
+        flux%lw_up_clear(jcol,:) = sum(flux_up_clear,1)
+        flux%lw_dn_clear(jcol,:) = sum(flux_dn_clear,1)
+        ! Store surface spectral downwelling fluxes
+        flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear(:,nlev+1)
+        ! Save the spectral fluxes if required
+        if (config%do_save_spectral_flux) then
+          do jlev = 1,nlev+1
+            call indexed_sum(flux_up_clear(:,jlev), &
+                 &           config%i_spec_from_reordered_g_lw, &
+                 &           flux%lw_up_clear_band(:,jcol,jlev))
+            call indexed_sum(flux_dn_clear(:,jlev), &
+                 &           config%i_spec_from_reordered_g_lw, &
+                 &           flux%lw_dn_clear_band(:,jcol,jlev))
+          end do
+        end if
+      end if
+      ! --------------------------------------------------------
+      ! Section 4: Loop over cloudy layers to compute reflectance and transmittance
       ! --------------------------------------------------------
       ! In this section the reflectance, transmittance and sources
       ! are computed for each layer
+      do jlev = 1,nlev ! Start at top-of-atmosphere
+      ! Firstly, ensure clear-sky transmittance is valid for whole
+      ! depth of the atmosphere, because even above cloud it is used
+      ! by the LW derivatives
+      transmittance(:,1,:) = trans_clear(:,:)
+      ! Dummy values in cloudy regions above cloud top
+      if (i_cloud_top > 0) then
+        transmittance(:,2:,1:min(i_cloud_top,nlev)) = 1.0_jprb
+      end if
+      do jlev = i_cloud_top,nlev ! Start at cloud top and work down
         ! Array-wise assignments
 …
         gamma2 = 0.0_jprb
+        ! Copy over clear-sky properties
+        reflectance(:,1,jlev)    = ref_clear(:,jlev)
+        source_up(:,1,jlev)      = source_up_clear(:,jlev) ! Scaled later by region size
+        source_dn(:,1,jlev)      = source_dn_clear(:,jlev) ! Scaled later by region size
         nreg = nregions
         if (is_clear_sky_layer(jlev)) then
           nreg = 1
           reflectance(:,2:,jlev)   = 0.0_jprb
+          transmittance(:,2:,jlev)   = 0.0_jprb
+          Sup(:,2:,jlev) = 0.0_jprb
+          Sdn(:,2:,jlev) = 0.0_jprb
+        end if
+        do jreg = 1,nreg
+          if (jreg == 1) then
+            ! Clear-sky calculation
+            if (.not. config%do_lw_aerosol_scattering) then
+              call calc_no_scattering_transmittance_lw(ng, od(:,jlev,jcol), &
+                   &  planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), &
+                   &  transmittance(:,1,jlev), Sup(:,1,jlev), Sdn(:,1,jlev))
+              reflectance(:,1,jlev) = 0.0_jprb
+            else
+              call calc_two_stream_gammas_lw(ng, &
+                   &  ssa(:,jlev,jcol), g(:,jlev,jcol), gamma1, gamma2)
+              call calc_reflectance_transmittance_lw(ng, &
+                   &  od(:,jlev,jcol), gamma1, gamma2, &
+                   &  planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), &
+                   &  reflectance(:,1,jlev), transmittance(:,1,jlev), &
+                   &  Sup(:,1,jlev), Sdn(:,1,jlev))
+            end if
+          else
+          transmittance(:,2:,jlev) = 1.0_jprb
+          source_up(:,2:,jlev)     = 0.0_jprb
+          source_dn(:,2:,jlev)     = 0.0_jprb
+        else
+          do jreg = 2,nreg
             ! Cloudy sky
             ! Add scaled cloud optical depth to clear-sky value
 …
                    &  planck_hl(:,jlev,jcol), planck_hl(:,jlev+1,jcol), &
                    &  reflectance(:,jreg,jlev), transmittance(:,jreg,jlev), &
                    &  Sup(:,jreg,jlev), Sdn(:,jreg,jlev))
+                   &  source_up(:,jreg,jlev), source_dn(:,jreg,jlev))
             else
               ! No-scattering case: use simpler functions for
 …
               call calc_no_scattering_transmittance_lw(ng, od_total, &
                    &  planck_hl(:,jlev,jcol), planck_hl(:,jlev+1, jcol), &
                    &  transmittance(:,jreg,jlev), Sup(:,jreg,jlev), Sdn(:,jreg,jlev))
+                   &  transmittance(:,jreg,jlev), source_up(:,jreg,jlev), source_dn(:,jreg,jlev))
               reflectance(:,jreg,jlev) = 0.0_jprb
             end if
+          end if
+        end do
+        ! Copy over the clear-sky emission
+        Sup_clear(:,jlev) = Sup(:,1,jlev)
+        Sdn_clear(:,jlev) = Sdn(:,1,jlev)
+        if (.not. is_clear_sky_layer(jlev)) then
+          end do
           ! Emission is scaled by the size of each region
           do jreg = 1,nregions
             Sup(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * Sup(:,jreg,jlev)
             Sdn(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * Sdn(:,jreg,jlev)
+            source_up(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * source_up(:,jreg,jlev)
+            source_dn(:,jreg,jlev) = region_fracs(jreg,jlev,jcol) * source_dn(:,jreg,jlev)
           end do
         end if
 …
       ! --------------------------------------------------------
       ! Section 4: Compute total sources albedos
+      ! Section 5: Compute total sources and albedos at each half level
       ! --------------------------------------------------------
 …
         end do
       end do
-      ! Equivalent surface values for computing clear-sky fluxes
-      if (config%do_clear) then
-        do jg = 1,ng
-          total_source_clear(jg,nlev+1) = emission(jg,jcol)
-        end do
-        ! In the case of surface albedo there is no dependence on
-        ! cloud fraction so we can copy the all-sky value
-        total_albedo_clear(1:ng,nlev+1) = total_albedo(1:ng,1,nlev+1)
-      end if
       ! Work up from the surface computing the total albedo of the
       ! atmosphere and the total upwelling due to emission below each
       ! level below using the adding method
       do jlev = nlev,1,-1
+      do jlev = nlev,i_cloud_top,-1
         total_albedo_below        = 0.0_jprb
-        if (config%do_clear) then
-          ! For clear-skies there is no need to consider "above" and
-          ! "below" quantities since with no cloud overlap to worry
-          ! about, these are the same
-          inv_denom(:,1) = 1.0_jprb &
-               &  / (1.0_jprb - total_albedo_clear(:,jlev+1)*reflectance(:,1,jlev))
-          total_albedo_clear(:,jlev) = reflectance(:,1,jlev) &
-               &  + transmittance(:,1,jlev)*transmittance(:,1,jlev)*total_albedo_clear(:,jlev+1) &
-               &  * inv_denom(:,1)
-          total_source_clear(:,jlev) = Sup_clear(:,jlev) &
-               &  + transmittance(:,1,jlev)*(total_source_clear(:,jlev+1) &
-               &  + total_albedo_clear(:,jlev+1)*Sdn_clear(:,jlev)) &
-               &  * inv_denom(:,1)
-        end if
         if (is_clear_sky_layer(jlev)) then
-          inv_denom(:,1) = 1.0_jprb &
-               &  / (1.0_jprb - total_albedo(:,1,jlev+1)*reflectance(:,1,jlev))
           total_albedo_below = 0.0_jprb
-          total_albedo_below(:,1) = reflectance(:,1,jlev) &
-               &  + transmittance(:,1,jlev)*transmittance(:,1,jlev)*total_albedo(:,1,jlev+1) &
-               &  * inv_denom(:,1)
           total_source_below = 0.0_jprb
+          total_source_below(:,1) = Sup(:,1,jlev) &
+               &  + transmittance(:,1,jlev)*(total_source(:,1,jlev+1) &
+               &  + total_albedo(:,1,jlev+1)*Sdn(:,1,jlev)) &
+               &  * inv_denom(:,1)
+          do jg = 1,ng
+            inv_denom(jg,1) = 1.0_jprb &
+                 &  / (1.0_jprb - total_albedo(jg,1,jlev+1)*reflectance(jg,1,jlev))
+            total_albedo_below(jg,1) = reflectance(jg,1,jlev) &
+                 &  + transmittance(jg,1,jlev)*transmittance(jg,1,jlev)*total_albedo(jg,1,jlev+1) &
+                 &  * inv_denom(jg,1)
+            total_source_below(jg,1) = source_up(jg,1,jlev) &
+                 &  + transmittance(jg,1,jlev)*(total_source(jg,1,jlev+1) &
+                 &  + total_albedo(jg,1,jlev+1)*source_dn(jg,1,jlev)) &
+                 &  * inv_denom(jg,1)
+          end do
         else
           inv_denom = 1.0_jprb / (1.0_jprb - total_albedo(:,:,jlev+1)*reflectance(:,:,jlev))
 …
                &  + transmittance(:,:,jlev)*transmittance(:,:,jlev)*total_albedo(:,:,jlev+1) &
                &  * inv_denom
           total_source_below = Sup(:,:,jlev) &
+          total_source_below = source_up(:,:,jlev) &
                &  + transmittance(:,:,jlev)*(total_source(:,:,jlev+1) &
                &  + total_albedo(:,:,jlev+1)*Sdn(:,:,jlev)) &
+               &  + total_albedo(:,:,jlev+1)*source_dn(:,:,jlev)) &
                &  * inv_denom
         end if
 …
       ! --------------------------------------------------------
+      ! Section 5: Compute fluxes
+      ! --------------------------------------------------------
+      ! Top-of-atmosphere fluxes into the regions of the top-most
+      ! layer, zero since we assume no diffuse downwelling
+      flux_dn = 0.0_jprb
+      if (config%do_clear) then
+        flux_dn_clear = 0.0_jprb
+      ! Section 6: Copy over downwelling fluxes above cloud top
+      ! --------------------------------------------------------
+      do jlev = 1,i_cloud_top
+        if (config%do_clear) then
+          ! Clear-sky fluxes have already been averaged: use these
+          flux%lw_dn(jcol,jlev) = flux%lw_dn_clear(jcol,jlev)
+          if (config%do_save_spectral_flux) then
+            flux%lw_dn_band(:,jcol,jlev) = flux%lw_dn_clear_band(:,jcol,jlev)
+          end if
+        else
+          flux%lw_dn(jcol,:) = sum(flux_dn_clear(:,jlev))
+          if (config%do_save_spectral_flux) then
+            call indexed_sum(flux_dn_clear(:,jlev), &
+                 &           config%i_spec_from_reordered_g_lw, &
+                 &           flux%lw_dn_band(:,jcol,jlev))
+          end if
+        end if
+      end do
+      ! --------------------------------------------------------
+      ! Section 7: Compute fluxes up to top-of-atmosphere
+      ! --------------------------------------------------------
+      ! Compute the fluxes just above the highest cloud
+      flux_up(:,1) = total_source(:,1,i_cloud_top) &
+           &  + total_albedo(:,1,i_cloud_top)*flux_dn_clear(:,i_cloud_top)
+      flux_up(:,2:) = 0.0_jprb
+      flux%lw_up(jcol,i_cloud_top) = sum(flux_up(:,1))
+      if (config%do_save_spectral_flux) then
+        call indexed_sum(flux_up(:,1), &
+             &           config%i_spec_from_reordered_g_lw, &
+             &           flux%lw_up_band(:,jcol,i_cloud_top))
       end if
+      ! Store the TOA broadband fluxes
+      flux%lw_up(jcol,1) = sum(total_source(:,:,1))
+      flux%lw_dn(jcol,1) = 0.0_jprb
+      if (config%do_clear) then
+        flux%lw_up_clear(jcol,1) = sum(total_source_clear(:,1))
+        flux%lw_dn_clear(jcol,1) = 0.0_jprb
+      end if
+      ! Save the spectral fluxes if required
+      if (config%do_save_spectral_flux) then
+        call indexed_sum(sum(total_source(:,:,1),2), &
+             &           config%i_spec_from_reordered_g_lw, &
+             &           flux%lw_up_band(:,jcol,1))
+        flux%lw_dn_band(:,jcol,1) = 0.0_jprb
+        if (config%do_clear) then
+          call indexed_sum(total_source_clear(:,1), &
+      do jlev = i_cloud_top-1,1,-1
+        flux_up(:,1) = trans_clear(:,jlev)*flux_up(:,1) + source_up_clear(:,jlev)
+        flux%lw_up(jcol,jlev) = sum(flux_up(:,1))
+        if (config%do_save_spectral_flux) then
+          call indexed_sum(flux_up(:,1), &
                &           config%i_spec_from_reordered_g_lw, &
+               &           flux%lw_up_clear_band(:,jcol,1))
+          flux%lw_dn_clear_band(:,jcol,1) = 0.0_jprb
+        end if
+      end if
+               &           flux%lw_up_band(:,jcol,jlev))
+        end if
+      end do
+      ! --------------------------------------------------------
+      ! Section 8: Compute fluxes down to surface
+      ! --------------------------------------------------------
+      ! Copy over downwelling spectral fluxes at top of first
+      ! scattering layer, using overlap matrix to translate to the
+      ! regions of the first layer of cloud
+      do jreg = 1,nregions
+        flux_dn(:,jreg)  = v_matrix(jreg,1,i_cloud_top,jcol)*flux_dn_clear(:,i_cloud_top)
+      end do
       ! Final loop back down through the atmosphere to compute fluxes
+      do jlev = 1,nlev
+        if (config%do_clear) then
+          flux_dn_clear = (transmittance(:,1,jlev)*flux_dn_clear &
+               &  + reflectance(:,1,jlev)*total_source_clear(:,jlev+1) + Sdn_clear(:,jlev) ) &
+               &  / (1.0_jprb - reflectance(:,1,jlev)*total_albedo_clear(:,jlev+1))
+          flux_up_clear = total_source_clear(:,jlev+1) &
+               &        + flux_dn_clear*total_albedo_clear(:,jlev+1)
+        end if
+      do jlev = i_cloud_top,nlev
         if (is_clear_sky_layer(jlev)) then
+          flux_dn(:,1) = (transmittance(:,1,jlev)*flux_dn(:,1) &
+               &       + reflectance(:,1,jlev)*total_source(:,1,jlev+1) + Sdn(:,1,jlev) ) &
+               &  / (1.0_jprb - reflectance(:,1,jlev)*total_albedo(:,1,jlev+1))
+          do jg = 1,ng
+            flux_dn(jg,1) = (transmittance(jg,1,jlev)*flux_dn(jg,1) &
+                 &  + reflectance(jg,1,jlev)*total_source(jg,1,jlev+1) + source_dn(jg,1,jlev) ) &
+                 &  / (1.0_jprb - reflectance(jg,1,jlev)*total_albedo(jg,1,jlev+1))
+            flux_up(jg,1) = total_source(jg,1,jlev+1) + flux_dn(jg,1)*total_albedo(jg,1,jlev+1)
+          end do
           flux_dn(:,2:)  = 0.0_jprb
-          flux_up(:,1) = total_source(:,1,jlev+1) + flux_dn(:,1)*total_albedo(:,1,jlev+1)
           flux_up(:,2:)  = 0.0_jprb
         else
           flux_dn = (transmittance(:,:,jlev)*flux_dn &
                &     + reflectance(:,:,jlev)*total_source(:,:,jlev+1) + Sdn(:,:,jlev) ) &
+               &     + reflectance(:,:,jlev)*total_source(:,:,jlev+1) + source_dn(:,:,jlev) ) &
                &  / (1.0_jprb - reflectance(:,:,jlev)*total_albedo(:,:,jlev+1))
           flux_up = total_source(:,:,jlev+1) + flux_dn*total_albedo(:,:,jlev+1)
 …
         flux%lw_up(jcol,jlev+1) = sum(sum(flux_up,1))
         flux%lw_dn(jcol,jlev+1) = sum(sum(flux_dn,1))
-        if (config%do_clear) then
-          flux%lw_up_clear(jcol,jlev+1) = sum(flux_up_clear)
-          flux%lw_dn_clear(jcol,jlev+1) = sum(flux_dn_clear)
-        end if
         ! Save the spectral fluxes if required
 …
                &           config%i_spec_from_reordered_g_lw, &
                &           flux%lw_dn_band(:,jcol,jlev+1))
+          if (config%do_clear) then
+            call indexed_sum(flux_up_clear, &
+                 &           config%i_spec_from_reordered_g_lw, &
+                 &           flux%lw_up_clear_band(:,jcol,jlev+1))
+            call indexed_sum(flux_dn_clear, &
+                 &           config%i_spec_from_reordered_g_lw, &
+                 &           flux%lw_dn_clear_band(:,jcol,jlev+1))
+          end if
+        end if
+         end if
       end do ! Final loop over levels
 …
       ! are at the surface
       flux%lw_dn_surf_g(:,jcol) = sum(flux_dn,2)
-      if (config%do_clear) then
-        flux%lw_dn_surf_clear_g(:,jcol) = flux_dn_clear
-      end if
       ! Compute the longwave derivatives needed by Hogan and Bozzo

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_tripleclouds_sw.F90

-                      r3908
+                      r4444
 !   2018-10-08  R. Hogan  Call calc_region_properties
 !   2019-01-02  R. Hogan  Fixed problem of do_save_spectral_flux .and. .not. do_sw_direct
+!   2020-09-18  R. Hogan  Replaced some array expressions with loops for speed
 module radiation_tripleclouds_sw
 …
 #include "radiation_optical_depth_scaling.h"
+  !---------------------------------------------------------------------
   ! This module contains just one subroutine, the shortwave
   ! "Tripleclouds" solver in which cloud inhomogeneity is treated by
 …
   ! cloudy (with differing optical depth). This approach was described
   ! by Shonk and Hogan (2008).
   subroutine solver_tripleclouds_sw(nlev,istartcol,iendcol, &
        &  config, single_level, cloud, &
 …
           ! "below" quantities since with no cloud overlap to worry
           ! about, these are the same
+          inv_denom(:,1) = 1.0_jprb &
+               &  / (1.0_jprb - total_albedo_clear(:,jlev+1)*reflectance(:,1,jlev))
+          total_albedo_clear(:,jlev) = reflectance(:,1,jlev) &
+               &  + transmittance(:,1,jlev) * transmittance(:,1,jlev) &
+               &  * total_albedo_clear(:,jlev+1) * inv_denom(:,1)
+          total_albedo_clear_direct(:,jlev) = ref_dir(:,1,jlev) &
+               &  + (trans_dir_dir(:,1,jlev)*total_albedo_clear_direct(:,jlev+1) &
+               &     +trans_dir_diff(:,1,jlev)*total_albedo_clear(:,jlev+1)) &
+               &  * transmittance(:,1,jlev) * inv_denom(:,1)
+          do jg = 1,ng
+            inv_denom(jg,1) = 1.0_jprb &
+                 &  / (1.0_jprb - total_albedo_clear(jg,jlev+1)*reflectance(jg,1,jlev))
+            total_albedo_clear(jg,jlev) = reflectance(jg,1,jlev) &
+                 &  + transmittance(jg,1,jlev) * transmittance(jg,1,jlev) &
+                 &  * total_albedo_clear(jg,jlev+1) * inv_denom(jg,1)
+            total_albedo_clear_direct(jg,jlev) = ref_dir(jg,1,jlev) &
+                 &  + (trans_dir_dir(jg,1,jlev)*total_albedo_clear_direct(jg,jlev+1) &
+                 &     +trans_dir_diff(jg,1,jlev)*total_albedo_clear(jg,jlev+1)) &
+                 &  * transmittance(jg,1,jlev) * inv_denom(jg,1)
+          end do
         end if
         if (is_clear_sky_layer(jlev)) then
+          inv_denom(:,1) = 1.0_jprb &
+               &  / (1.0_jprb - total_albedo(:,1,jlev+1)*reflectance(:,1,jlev))
+          total_albedo_below(:,1) = reflectance(:,1,jlev) &
+               &  + transmittance(:,1,jlev)  * transmittance(:,1,jlev) &
+               &  * total_albedo(:,1,jlev+1) * inv_denom(:,1)
+          total_albedo_below_direct(:,1) = ref_dir(:,1,jlev) &
+               &  + (trans_dir_dir(:,1,jlev)*total_albedo_direct(:,1,jlev+1) &
+               &     +trans_dir_diff(:,1,jlev)*total_albedo(:,1,jlev+1)) &
+               &  * transmittance(:,1,jlev) * inv_denom(:,1)
+          do jg = 1,ng
+            inv_denom(jg,1) = 1.0_jprb &
+                 &  / (1.0_jprb - total_albedo(jg,1,jlev+1)*reflectance(jg,1,jlev))
+            total_albedo_below(jg,1) = reflectance(jg,1,jlev) &
+                 &  + transmittance(jg,1,jlev)  * transmittance(jg,1,jlev) &
+                 &  * total_albedo(jg,1,jlev+1) * inv_denom(jg,1)
+            total_albedo_below_direct(jg,1) = ref_dir(jg,1,jlev) &
+                 &  + (trans_dir_dir(jg,1,jlev)*total_albedo_direct(jg,1,jlev+1) &
+                 &     +trans_dir_diff(jg,1,jlev)*total_albedo(jg,1,jlev+1)) &
+                 &  * transmittance(jg,1,jlev) * inv_denom(jg,1)
+          end do
         else
           inv_denom = 1.0_jprb / (1.0_jprb - total_albedo(:,:,jlev+1)*reflectance(:,:,jlev))
 …
       do jlev = 1,nlev
         if (config%do_clear) then
+          flux_dn_clear = (transmittance(:,1,jlev)*flux_dn_clear + direct_dn_clear &
+               &  * (trans_dir_dir(:,1,jlev)*total_albedo_clear_direct(:,jlev+1)*reflectance(:,1,jlev) &
+               &     + trans_dir_diff(:,1,jlev) )) &
+               &  / (1.0_jprb - reflectance(:,1,jlev)*total_albedo_clear(:,jlev+1))
+          direct_dn_clear = trans_dir_dir(:,1,jlev)*direct_dn_clear
+          flux_up_clear = direct_dn_clear*total_albedo_clear_direct(:,jlev+1) &
+               &        +   flux_dn_clear*total_albedo_clear(:,jlev+1)
+          do jg = 1,ng
+            flux_dn_clear(jg) = (transmittance(jg,1,jlev)*flux_dn_clear(jg) + direct_dn_clear(jg) &
+               &  * (trans_dir_dir(jg,1,jlev)*total_albedo_clear_direct(jg,jlev+1)*reflectance(jg,1,jlev) &
+               &     + trans_dir_diff(jg,1,jlev) )) &
+               &  / (1.0_jprb - reflectance(jg,1,jlev)*total_albedo_clear(jg,jlev+1))
+            direct_dn_clear(jg) = trans_dir_dir(jg,1,jlev)*direct_dn_clear(jg)
+            flux_up_clear(jg) = direct_dn_clear(jg)*total_albedo_clear_direct(jg,jlev+1) &
+               &        +   flux_dn_clear(jg)*total_albedo_clear(jg,jlev+1)
+          end do
         end if
         if (is_clear_sky_layer(jlev)) then
+          flux_dn(:,1) = (transmittance(:,1,jlev)*flux_dn(:,1) + direct_dn(:,1) &
+               &  * (trans_dir_dir(:,1,jlev)*total_albedo_direct(:,1,jlev+1)*reflectance(:,1,jlev) &
+               &     + trans_dir_diff(:,1,jlev) )) &
+               &  / (1.0_jprb - reflectance(:,1,jlev)*total_albedo(:,1,jlev+1))
+          direct_dn(:,1) = trans_dir_dir(:,1,jlev)*direct_dn(:,1)
+          flux_up(:,1) = direct_dn(:,1)*total_albedo_direct(:,1,jlev+1) &
+               &  +        flux_dn(:,1)*total_albedo(:,1,jlev+1)
+          do jg = 1,ng
+            flux_dn(jg,1) = (transmittance(jg,1,jlev)*flux_dn(jg,1) + direct_dn(jg,1) &
+                 &  * (trans_dir_dir(jg,1,jlev)*total_albedo_direct(jg,1,jlev+1)*reflectance(jg,1,jlev) &
+                 &     + trans_dir_diff(jg,1,jlev) )) &
+                 &  / (1.0_jprb - reflectance(jg,1,jlev)*total_albedo(jg,1,jlev+1))
+            direct_dn(jg,1) = trans_dir_dir(jg,1,jlev)*direct_dn(jg,1)
+            flux_up(jg,1) = direct_dn(jg,1)*total_albedo_direct(jg,1,jlev+1) &
+                 &  +        flux_dn(jg,1)*total_albedo(jg,1,jlev+1)
+          end do
           flux_dn(:,2:)  = 0.0_jprb
           flux_up(:,2:)  = 0.0_jprb

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_two_stream.F90

-                      r3908
+                      r4444
 !   2017-07-26  R Hogan  Added calc_frac_scattered_diffuse_sw routine
 !   2017-10-23  R Hogan  Renamed single-character variables
+!   2021-02-19  R Hogan  Security for shortwave singularity
 module radiation_two_stream
 …
   ! think of acos(1/lw_diffusivity) to be the effective zenith angle
   ! of longwave radiation.
+  real(jprd), parameter :: LwDiffusivity = 1.66_jprd
+  real(jprd), parameter :: LwDiffusivity   = 1.66_jprd
+  real(jprb), parameter :: LwDiffusivityWP = 1.66_jprb ! Working precision version
   ! Shortwave diffusivity factor assumes hemispheric isotropy, assumed
 …
     if (lhook) call dr_hook('radiation_two_stream:calc_two_stream_gammas_lw',0,hook_handle)
 #endif
+! Added for DWD (2020)
+!NEC$ shortloop
     do jg = 1, ng
       ! Fu et al. (1997), Eq 2.9 and 2.10:
 …
     ! Zdunkowski "PIFM" (Zdunkowski et al., 1980; Contributions to
     ! Atmospheric Physics 53, 147-66)
+! Added for DWD (2020)
+!NEC$ shortloop
     do jg = 1, ng
       !      gamma1(jg) = 2.0_jprb  - ssa(jg) * (1.25_jprb + 0.75_jprb*g(jg))
 …
 #endif
+! Added for DWD (2020)
+!NEC$ shortloop
     do jg = 1, ng
       if (od(jg) > 1.0e-3_jprd) then
 …
 #endif
+! Added for DWD (2020)
+!NEC$ shortloop
     do jg = 1, ng
       k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), &
 …
 #endif
+! Added for DWD (2020)
+!NEC$ shortloop
     do jg = 1, ng
       ! Compute upward and downward emission assuming the Planck
 …
     integer    :: jg
+    ! Local value of cosine of solar zenith angle, in case it needs to be
+    ! tweaked to avoid near division by zero. This is intentionally in working
+    ! precision (jprb) rather than fixing at double precision (jprd).
+    real(jprb) :: mu0_local
 #ifdef DO_DR_HOOK_TWO_STREAM
     real(jprb) :: hook_handle
 …
 #endif
+! Added for DWD (2020)
+!NEC$ shortloop
     do jg = 1, ng
+      od_over_mu0 = max(od(jg) / mu0, 0.0_jprd)
+      ! In the IFS this appears to be faster without testing the value
+      ! of od_over_mu0:
+      if (.true.) then
+!      if (od_over_mu0 > 1.0e-6_jprd) then
         gamma4 = 1.0_jprd - gamma3(jg)
         alpha1 = gamma1(jg)*gamma4     + gamma2(jg)*gamma3(jg) ! Eq. 16
         alpha2 = gamma1(jg)*gamma3(jg) + gamma2(jg)*gamma4    ! Eq. 17
+        k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), &
+             &       1.0e-12_jprd)) ! Eq 18
+        ! We had a rare crash where k*mu0 was within around 1e-13 of 1,
+        ! leading to ref_dir and trans_dir_diff being well outside the range
+        ! 0-1. The following approach is appropriate when k_exponent is double
+        ! precision and mu0_local is single precision, although work is needed
+        ! to make this entire routine secure in single precision.
+        mu0_local = mu0
+        if (abs(1.0_jprd - k_exponent*mu0) < 1000.0_jprd * epsilon(1.0_jprd)) then
+          mu0_local = mu0 * (1.0_jprb - 10.0_jprb*epsilon(1.0_jprb))
+        end if
+        od_over_mu0 = max(od(jg) / mu0_local, 0.0_jprd)
         ! Note that if the minimum value is reduced (e.g. to 1.0e-24)
         ! then noise starts to appear as a function of solar zenith
         ! angle
+        k_exponent = sqrt(max((gamma1(jg) - gamma2(jg)) * (gamma1(jg) + gamma2(jg)), &
+             &       1.0e-12_jprd)) ! Eq 18
+        k_mu0 = k_exponent*mu0
+        k_mu0 = k_exponent*mu0_local
         k_gamma3 = k_exponent*gamma3(jg)
         k_gamma4 = k_exponent*gamma4
 …
         k_2_exponential = 2.0_jprd * k_exponent * exponential
-        if (k_mu0 == 1.0_jprd) then
-          k_mu0 = 1.0_jprd - 10.0_jprd*epsilon(1.0_jprd)
-        end if
         reftrans_factor = 1.0_jprd / (k_exponent + gamma1(jg) + (k_exponent - gamma1(jg))*exponential2)
 …
         ! to be the flux into a plane perpendicular to the direction of
         ! the sun, not into a horizontal plane
         reftrans_factor = mu0 * ssa(jg) * reftrans_factor / (1.0_jprd - k_mu0*k_mu0)
+        reftrans_factor = mu0_local * ssa(jg) * reftrans_factor / (1.0_jprd - k_mu0*k_mu0)
         ! Meador & Weaver (1980) Eq. 14, multiplying top & bottom by
 …
              &  * ( (1.0_jprd - k_mu0) * (alpha2 + k_gamma3) &
              &     -(1.0_jprd + k_mu0) * (alpha2 - k_gamma3)*exponential2 &
              &     -k_2_exponential*(gamma3(jg) - alpha2*mu0)*exponential0)
+             &     -k_2_exponential*(gamma3(jg) - alpha2*mu0_local)*exponential0)
         ! Meador & Weaver (1980) Eq. 15, multiplying top & bottom by
         ! exp(-k_exponent*od), minus the 1*exp(-od/mu0) term representing direct
         ! unscattered transmittance.
         trans_dir_diff(jg) = reftrans_factor * ( k_2_exponential*(gamma4 + alpha1*mu0) &
+        trans_dir_diff(jg) = reftrans_factor * ( k_2_exponential*(gamma4 + alpha1*mu0_local) &
             & - exponential0 &
             & * ( (1.0_jprd + k_mu0) * (alpha1 + k_gamma4) &
             &    -(1.0_jprd - k_mu0) * (alpha1 - k_gamma4) * exponential2) )
+      else
+        ! Low optical-depth limit; see equations 19, 20 and 27 from
+        ! Meador & Weaver (1980)
+        trans_diff(jg)     = 1.0_jprb - gamma1(jg) * od(jg)
+        ref_diff(jg)       = gamma2(jg) * od(jg)
+        trans_dir_diff(jg) = (1.0_jprb - gamma3(jg)) * ssa(jg) * od(jg)
+        ref_dir(jg)        = gamma3(jg) * ssa(jg) * od(jg)
+        trans_dir_dir(jg)  = 1.0_jprd - od_over_mu0
+      end if
+        ! Final check that ref_dir + trans_dir_diff <= 1
+        ref_dir(jg) = max(0.0_jprb, min(ref_dir(jg), 1.0_jprb))
+        trans_dir_diff(jg) = max(0.0_jprb, min(trans_dir_diff(jg), 1.0_jprb-ref_dir(jg)))
     end do
 …
 #endif
+! Added for DWD (2020)
+!NEC$ shortloop
     do jg = 1, ng
       od_over_mu0 = max(gamma0(jg) * depth, 0.0_jprd)
 …
 #endif
+! Added for DWD (2020)
+!NEC$ shortloop
     do jg = 1, ng
       ! Note that if the minimum value is reduced (e.g. to 1.0e-24)

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/random_numbers_mix.F90

-                      r4355
+                      r4444
   ! Generate uniformly distributed random numbers in the range 0.0<= px < 1.0
   !--------------------------------------------------------------------------------
+!  INTEGER(KIND=JPIM), PARAMETER :: IVAR=Z"3FFFFFFF"
+  INTEGER(KIND=JPIM) :: IVAR
+  DATA IVAR /Z"3FFFFFFF"/
+  INTEGER(KIND=JPIM), PARAMETER :: IVAR = INT(Z"3FFFFFFF",JPIM)
   TYPE(RANDOMNUMBERSTREAM), INTENT(INOUT) :: YD_STREAM
   REAL(KIND=JPRB), DIMENSION(:),     INTENT(  OUT) :: PX
   INTEGER(KIND=JPIM)                :: JJ, JK, IN, IFILLED
 …
   IF(YD_STREAM%INITTEST /= INITVALUE) &
     & CALL ABOR1 ('uniform_distribution called before initialize_random_numbers')
   !--------------------------------------------------------------------------------
   ! Copy numbers that were generated during the last call, but not used.

Context Navigation

Legend:

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/easy_netcdf.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_adding_ica_lw.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_adding_ica_sw.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_aerosol.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_aerosol_optics.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_aerosol_optics_data.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_cloud.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_cloud_cover.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_cloud_generator.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_cloud_optics.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_config.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_delta_eddington.h

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_flux.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_gas.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_ice_optics_fu.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_ifs_rrtm.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_interface.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_liquid_optics_socrates.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_matrix.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_mcica_lw.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_mcica_sw.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_monochromatic.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_pdf_sampler.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_save.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_scheme.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_setup.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_single_level.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_spartacus_lw.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_spartacus_sw.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_thermodynamics.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_tripleclouds_lw.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_tripleclouds_sw.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/radiation_two_stream.F90

LMDZ6/branches/LMDZ_ECRad/libf/phylmd/ecrad/random_numbers_mix.F90

Download in other formats: