TNO Intern

Commit 6fe37fff authored by Arjo Segers's avatar Arjo Segers
Browse files

Support integer(1) and character data types.

parent 3d621111
Loading
Loading
Loading
Loading
+441 −3
Original line number Diff line number Diff line
@@ -13,6 +13,12 @@
!     https://computing.llnl.gov/tutorials/mpi/
!
!
! HISTORY
!
!   2023-01, Arjo Segers
!     Support integer(1) and character variables.
!
!
!### macro's ###########################################################
!
#define TRACEBACK write (csol,'("in ",a," (",a,", line",i5,")")') rname, __FILE__, __LINE__; call csoErr
@@ -124,6 +130,7 @@ module CSO_Comm
                                    CSO_Comm_AllReduce_InPlace_r4_5d
    !
    procedure ::                    CSO_Comm_BCast_i
    procedure ::                    CSO_Comm_BCast_i1_1d
    procedure ::                    CSO_Comm_BCast_i_1d
    procedure ::                    CSO_Comm_BCast_r4
    procedure ::                    CSO_Comm_BCast_r4_1d
@@ -137,6 +144,7 @@ module CSO_Comm
    procedure ::                    CSO_Comm_BCast_r8_4d
    procedure ::                    CSO_Comm_BCast_c
    generic   ::  BCast         =>  CSO_Comm_BCast_i, &
                                    CSO_Comm_BCast_i1_1d, &
                                    CSO_Comm_BCast_i_1d, &
                                    CSO_Comm_BCast_r4, &
                                    CSO_Comm_BCast_r4_1d, &
@@ -164,18 +172,22 @@ module CSO_Comm
                                    CSO_Comm_AllGather_i1, &
                                    CSO_Comm_AllGather_r1
    !
    procedure                       CSO_Comm_GatherV_i1_1d
    procedure                       CSO_Comm_GatherV_i_1d
    procedure                       CSO_Comm_GatherV_i_2d
    procedure                       CSO_Comm_GatherV_r4_1d
    procedure                       CSO_Comm_GatherV_r8_1d
    procedure                       CSO_Comm_GatherV_c1_2d
    procedure                       CSO_Comm_GatherV_r4_2d
    procedure                       CSO_Comm_GatherV_r8_2d
    procedure                       CSO_Comm_GatherV_r4_3d
    procedure                       CSO_Comm_GatherV_r8_3d
    generic   ::  GatherV       =>  CSO_Comm_GatherV_i_1d, &
    generic   ::  GatherV       =>  CSO_Comm_GatherV_i1_1d, &
                                    CSO_Comm_GatherV_i_1d, &
                                    CSO_Comm_GatherV_i_2d, &
                                    CSO_Comm_GatherV_r4_1d, &
                                    CSO_Comm_GatherV_r8_1d, &
                                    CSO_Comm_GatherV_c1_2d, &
                                    CSO_Comm_GatherV_r4_2d, &
                                    CSO_Comm_GatherV_r8_2d, &
                                    CSO_Comm_GatherV_r4_3d, &
@@ -186,13 +198,17 @@ module CSO_Comm
    generic   ::  Gather2D      =>  CSO_Comm_Gather2D_r4, &
                                    CSO_Comm_Gather2D_r8
    !
    procedure                       CSO_Comm_ScatterV_i1_1d
    procedure                       CSO_Comm_ScatterV_r4_1d
    procedure                       CSO_Comm_ScatterV_c1_2d
    procedure                       CSO_Comm_ScatterV_r4_2d
    procedure                       CSO_Comm_ScatterV_r4_3d
    procedure                       CSO_Comm_ScatterV_r8_1d
    procedure                       CSO_Comm_ScatterV_r8_2d
    procedure                       CSO_Comm_ScatterV_r8_3d
    generic   ::  ScatterV      =>  CSO_Comm_ScatterV_r4_1d, &
    generic   ::  ScatterV      =>  CSO_Comm_ScatterV_i1_1d, &
                                    CSO_Comm_ScatterV_r4_1d, &
                                    CSO_Comm_ScatterV_c1_2d, &
                                    CSO_Comm_ScatterV_r4_2d, &
                                    CSO_Comm_ScatterV_r4_3d, &
                                    CSO_Comm_ScatterV_r8_1d, &
@@ -578,7 +594,7 @@ contains

    use MPI_F08, only : MPI_DataType
    use MPI_F08, only : MPI_LOGICAL
    use MPI_F08, only : MPI_INTEGER
    use MPI_F08, only : MPI_BYTE, MPI_SHORT, MPI_INTEGER
    use MPI_F08, only : MPI_REAL, MPI_DOUBLE_PRECISION
    use MPI_F08, only : MPI_CHAR

@@ -610,6 +626,10 @@ contains
      case ( 'integer' )
        ! switch:
        select case ( knd )
          case ( 1 )
            dtype = MPI_BYTE
          case ( 2 )
            dtype = MPI_SHORT
          case ( 4 )
            dtype = MPI_INTEGER
          case default
@@ -1696,6 +1716,50 @@ contains
  ! ***


  subroutine CSO_Comm_BCast_i1_1d( self, rootid, values, status )

#ifdef _MPI
    use MPI_F08, only : MPI_DataType
    use MPI_F08, only : MPI_BCast
#endif

    ! --- in/out ---------------------------------

    class(T_CSO_Comm), intent(in)       ::  self
    integer, intent(in)                 ::  rootid
    integer(1), intent(inout)           ::  values(:)
    integer, intent(out)                ::  status

    ! --- const ----------------------------------

    character(len=*), parameter   ::  rname = mname//'/CSO_Comm_BCast_i1_1d'

    ! --- local ----------------------------------

#ifdef _MPI
    type(MPI_DataType)    ::  dtype
#endif

    ! --- begin ----------------------------------

#ifdef _MPI
    ! data type:
    call self%GetDataType( 'integer', kind(values), dtype, status )
    IF_NOT_OK_RETURN(status=1)
    ! send values from root to all other pe's:
    call MPI_BCast( values, size(values), dtype, rootid, self%comm, ierror=status )
    IF_MPI_NOT_OK_RETURN(status=1)
#endif

    ! ok
    status = 0

  end subroutine CSO_Comm_BCast_i1_1d


  ! ***


  subroutine CSO_Comm_BCast_i_1d( self, rootid, values, status )

#ifdef _MPI
@@ -2561,6 +2625,96 @@ contains
  ! If send is supposed to be empty, use optional nloc=0 to specify this.
  !

  subroutine CSO_Comm_GatherV_i1_1d( self, send, recv, status, &
                                      nloc )

#ifdef _MPI
    use MPI_F08, only : MPI_DataType
    use MPI_F08, only : MPI_GatherV
#endif

    ! --- in/out ---------------------------------

    class(T_CSO_Comm), intent(in)       ::  self
    integer(1), intent(in)              ::  send(:)   ! (max(1,nloc))
    integer(1), intent(out)             ::  recv(:)   ! (sum nloc)
    integer, intent(out)                ::  status
    
    integer, intent(in), optional       ::  nloc

    ! --- const ----------------------------------

    character(len=*), parameter   ::  rname = mname//'/CSO_Comm_GatherV_i1_1d'

    ! --- local ----------------------------------
    
    integer                 ::  n
    integer                 ::  ntot
#ifdef _MPI
    type(MPI_DataType)      ::  dtype
    integer, allocatable    ::  recvcounts(:)  ! (npes)
    integer, allocatable    ::  displs(:)  ! (npes)
#endif

    ! --- begin ----------------------------------
    
    ! local size, take from optional argument if present (value is probably zero ..)
    if ( present(nloc) ) then
      n = nloc
    else
      n = size(send)
    end if
    
#ifdef _MPI

    ! data type:
    call self%GetDataType( 'integer', kind(send), dtype, status )
    IF_NOT_OK_RETURN(status=1)

    ! storage:
    allocate( recvcounts(0:self%npes-1), stat=status )
    IF_NOT_OK_RETURN(status=1)
    allocate( displs(0:self%npes-1), stat=status )
    IF_NOT_OK_RETURN(status=1)
    
    ! collect numbers:
    call self%ParInfo( n, status, ntot=ntot, recvcounts=recvcounts, displs=displs )
    IF_NOT_OK_RETURN(status=1)
    
    ! check ...
    if ( self%root ) then
      if ( size(recv) /= ntot ) then
        write (csol,'("receive buffer has size ",i0," while ntot is ",i0)') size(recv), ntot; call csoErr
        TRACEBACK; status=1; return
      end if
    end if
    
    ! collect values from all pe's on root:
    call MPI_GatherV( send, n, dtype, &
                      recv, recvcounts, displs, dtype, &
                      self%root_id, self%comm, ierror=status )
    IF_MPI_NOT_OK_RETURN(status=1)

    ! clear:
    deallocate( recvcounts, stat=status )
    IF_NOT_OK_RETURN(status=1)
    deallocate( displs, stat=status )
    IF_NOT_OK_RETURN(status=1)

#else

    ! just copy ...
    if ( n > 0 ) recv = send(1:n)

#endif
    
    ! ok
    status = 0

  end subroutine CSO_Comm_GatherV_i1_1d
  
  ! *

  subroutine CSO_Comm_GatherV_i_1d( self, send, recv, status, &
                                      nloc )

@@ -2931,6 +3085,102 @@ contains
  
  ! *

  subroutine CSO_Comm_GatherV_c1_2d( self, send, recv, status, &
                                      nloc )

#ifdef _MPI
    use MPI_F08, only : MPI_DataType
    use MPI_F08, only : MPI_GatherV
#endif

    ! --- in/out ---------------------------------
    
    class(T_CSO_Comm), intent(in)       ::  self
    character(len=1), intent(in)        ::  send(:,:)   ! (m,max(1,nloc))
    character(len=1), intent(out)       ::  recv(:,:)   ! (m,sum nloc)
    integer, intent(out)                ::  status
    
    integer, intent(in), optional       ::  nloc

    ! --- const ----------------------------------

    character(len=*), parameter   ::  rname = mname//'/CSO_Comm_GatherV_c1_2d'

    ! --- local ----------------------------------
    
    integer                 ::  m
    integer                 ::  n
#ifdef _MPI
    integer                 ::  ntot
    type(MPI_DataType)      ::  dtype
    integer, allocatable    ::  recvcounts(:)  ! (npes)
    integer, allocatable    ::  displs(:)  ! (npes)
#endif

    ! --- begin ----------------------------------
    
    ! local size, take from optional argument if present (value is probably zero ..)
    if ( present(nloc) ) then
      n = nloc
    else
      n = size(send,2)
    end if
    
    ! first dim:
    m = size(send,1)
    
#ifdef _MPI

    ! data type:
    call self%GetDataType( 'char', 1, dtype, status )
    IF_NOT_OK_RETURN(status=1)

    ! storage:
    allocate( recvcounts(0:self%npes-1), stat=status )
    IF_NOT_OK_RETURN(status=1)
    allocate( displs(0:self%npes-1), stat=status )
    IF_NOT_OK_RETURN(status=1)
    
    ! collect numbers:
    call self%ParInfo( n, status, ntot=ntot, recvcounts=recvcounts, displs=displs )
    IF_NOT_OK_RETURN(status=1)
    
    ! check receive buffer ...
    if ( self%root ) then
      ! check ...
      if ( any( shape(recv) /= (/m,ntot/) ) ) then
        write (csol,'("receive buffer has shape (",i0,",",i0,") while (m,ntot) is (",i0,",",i0,")")') &
                        shape(recv), m,ntot; call csoErr
        TRACEBACK; status=1; return
      end if
    end if
    
    ! collect values from all pe's on root:
    call MPI_GatherV( send, m*n, dtype, &
                      recv, m*recvcounts, m*displs, dtype, &
                      self%root_id, self%comm, ierror=status )
    IF_MPI_NOT_OK_RETURN(status=1)

    ! clear:
    deallocate( recvcounts, stat=status )
    IF_NOT_OK_RETURN(status=1)
    deallocate( displs, stat=status )
    IF_NOT_OK_RETURN(status=1)

#else

    ! just copy ...
    if ( n > 0 ) recv = send(:,1:n)

#endif
    
    ! ok
    status = 0

  end subroutine CSO_Comm_GatherV_c1_2d
  
  ! *

  subroutine CSO_Comm_GatherV_r4_2d( self, send, recv, status, &
                                      nloc )

@@ -3600,6 +3850,98 @@ contains
  ! ***
  ! ********************************************************************
  
  subroutine CSO_Comm_ScatterV_i1_1d( self, send, recv, status, &
                                      nloc )

#ifdef _MPI
    use MPI_F08, only : MPI_DataType
    use MPI_F08, only : MPI_ScatterV
#endif

    ! --- in/out ---------------------------------
    
    integer, parameter                  ::  wp = 1

    class(T_CSO_Comm), intent(in)       ::  self
    integer(wp), intent(in)             ::  send(:)   ! (sum nloc)
    integer(wp), intent(out)            ::  recv(:)   ! (max(1,nloc))
    integer, intent(out)                ::  status
    
    integer, intent(in), optional       ::  nloc

    ! --- const ----------------------------------

    character(len=*), parameter   ::  rname = mname//'/CSO_Comm_ScatterV_i1_1d'

    ! --- local ----------------------------------
    
    integer                 ::  n
#ifdef _MPI
    type(MPI_DataType)      ::  dtype
    integer                 ::  ntot
    integer, allocatable    ::  sendcounts(:)  ! (npes)
    integer, allocatable    ::  displs(:)  ! (npes)
#endif

    ! --- begin ----------------------------------
    
    ! local size, take from optional argument if present (value is probably zero ..)
    if ( present(nloc) ) then
      n = nloc
    else
      n = size(recv)
    end if
    
#ifdef _MPI

    ! data type:
    call self%GetDataType( 'integer', wp, dtype, status )
    IF_NOT_OK_RETURN(status=1)

    ! storage:
    allocate( sendcounts(0:self%npes-1), stat=status )
    IF_NOT_OK_RETURN(status=1)
    allocate( displs(0:self%npes-1), stat=status )
    IF_NOT_OK_RETURN(status=1)
    
    ! collect numbers:
    call self%ParInfo( n, status, ntot=ntot, sendcounts=sendcounts, displs=displs )
    IF_NOT_OK_RETURN(status=1)
    
    ! check ...
    if ( self%root ) then
      if ( size(send) /= ntot ) then
        write (csol,'("send buffer has size ",i0," while ntot is ",i0)') size(send), ntot; call csoErr
        TRACEBACK; status=1; return
      end if
    end if
    
    ! collect values from all pe's on root:
    call MPI_ScatterV( send, sendcounts, displs, dtype, &
                       recv, n                 , dtype, &
                       self%root_id, self%comm, ierror=status )
    IF_MPI_NOT_OK_RETURN(status=1)

    ! clear:
    deallocate( sendcounts, stat=status )
    IF_NOT_OK_RETURN(status=1)
    deallocate( displs, stat=status )
    IF_NOT_OK_RETURN(status=1)

#else

    ! just copy ...
    if ( n > 0 ) recv(1:n) = send(1:n)

#endif
    
    ! ok
    status = 0

  end subroutine CSO_Comm_ScatterV_i1_1d
  
  ! *
  
  subroutine CSO_Comm_ScatterV_r4_1d( self, send, recv, status, &
                                      nloc )

@@ -3692,6 +4034,102 @@ contains
  
  ! *
  
  subroutine CSO_Comm_ScatterV_c1_2d( self, send, recv, status, &
                                      nloc )

#ifdef _MPI
    use MPI_F08, only : MPI_DataType
    use MPI_F08, only : MPI_ScatterV
#endif

    ! --- in/out ---------------------------------
    
    class(T_CSO_Comm), intent(in)       ::  self
    character(len=1), intent(in)        ::  send(:,:)   ! (m,sum nloc)
    character(len=1), intent(out)       ::  recv(:,:)   ! (m,max(1,nloc))
    integer, intent(out)                ::  status
    
    integer, intent(in), optional       ::  nloc

    ! --- const ----------------------------------

    character(len=*), parameter   ::  rname = mname//'/CSO_Comm_ScatterV_c1_2d'

    ! --- local ----------------------------------
    
    integer                 ::  m1
    integer                 ::  n
#ifdef _MPI
    type(MPI_DataType)      ::  dtype
    integer                 ::  ntot
    integer, allocatable    ::  sendcounts(:)  ! (npes)
    integer, allocatable    ::  displs(:)  ! (npes)
#endif

    ! --- begin ----------------------------------
    
    ! local size, take from optional argument if present (value is probably zero ..)
    if ( present(nloc) ) then
      n = nloc
    else
      n = size(recv,2)
    end if
    
    ! first dim:
    m1 = size(recv,1)
    
#ifdef _MPI

    ! data type:
    call self%GetDataType( 'char', 1, dtype, status )
    IF_NOT_OK_RETURN(status=1)

    ! storage:
    allocate( sendcounts(0:self%npes-1), stat=status )
    IF_NOT_OK_RETURN(status=1)
    allocate( displs(0:self%npes-1), stat=status )
    IF_NOT_OK_RETURN(status=1)
    
    ! collect numbers:
    call self%ParInfo( n, status, ntot=ntot, sendcounts=sendcounts, displs=displs )
    IF_NOT_OK_RETURN(status=1)
    
    ! check send buffer ...
    if ( self%root ) then
      ! check ...
      if ( any( shape(send) /= (/m1,ntot/) ) ) then
        write (csol,'("send buffer has shape (",i0,",",i0,") while (m,ntot) is (",i0,",",i0,")")') &
                        shape(send), m1,ntot; call csoErr
        TRACEBACK; status=1; return
      end if
    end if
    
    ! collect values from all pe's on root:
    call MPI_ScatterV( send, m1*sendcounts, m1*displs, dtype, &
                       recv, m1*n                    , dtype, &
                       self%root_id, self%comm, ierror=status )
    IF_MPI_NOT_OK_RETURN(status=1)

    ! clear:
    deallocate( sendcounts, stat=status )
    IF_NOT_OK_RETURN(status=1)
    deallocate( displs, stat=status )
    IF_NOT_OK_RETURN(status=1)

#else

    ! just copy ...
    if ( n > 0 ) recv(:,1:n) = send(:,1:n)

#endif
    
    ! ok
    status = 0

  end subroutine CSO_Comm_ScatterV_c1_2d
  
  ! *
  
  subroutine CSO_Comm_ScatterV_r4_2d( self, send, recv, status, &
                                      nloc )

+258 −7

File changed.

Preview size limit exceeded, changes collapsed.

+212 −4
Original line number Diff line number Diff line
@@ -11,6 +11,14 @@
! 2022-10, Arjo Segers
!   Do not copy packing attributes from input files.
!
! 2023-01, Arjo Segers
!   When packing variables with single value, 
!   use add_offset=value and scale_factor=1
!   to avoid division by zero for all-zero variables.
!
! 2023-01, Arjo Segers
!   Support integer(1) and character variables.
!
! 2023-08, Arjo Segers
!   Replaced `where` constructs by loops after memory errors on some systems.
!
@@ -261,12 +269,16 @@ module CSO_NcFile
    procedure ::  Inq_VarUnits     =>  NcFile_Inq_VarUnits
    !
    procedure   ::                     NcFile_Get_Var_i_1d
    procedure   ::                     NcFile_Get_Var_i1_1d
    procedure   ::                     NcFile_Get_Var_c_2d
    procedure   ::                     NcFile_Get_Var_i_2d
    procedure   ::                     NcFile_Get_Var_i_3d
    procedure   ::                     NcFile_Get_Var_r_1d
    procedure   ::                     NcFile_Get_Var_r_2d
    procedure   ::                     NcFile_Get_Var_r_3d
    generic     ::  Get_Var        =>  NcFile_Get_Var_i_1d, &
                                       NcFile_Get_Var_i1_1d, &
                                       NcFile_Get_Var_c_2d, &
                                       NcFile_Get_Var_i_2d, &
                                       NcFile_Get_Var_i_3d, &
                                       NcFile_Get_Var_r_1d, &
@@ -284,9 +296,11 @@ module CSO_NcFile
    procedure ::  EndDef           =>  NcFile_EndDef
    procedure ::  GetPacking       =>  NcFile_GetPacking
    procedure ::                       NcFile_Put_Var_1d_r
    procedure ::                       NcFile_Put_Var_2d_c
    procedure ::                       NcFile_Put_Var_2d_r
    procedure ::                       NcFile_Put_Var_3d_r
    generic   ::  Put_Var          =>  NcFile_Put_Var_1d_r, &
                                       NcFile_Put_Var_2d_c, &
                                       NcFile_Put_Var_2d_r, &
                                       NcFile_Put_Var_3d_r
    procedure ::  Put_Var1D        =>  NcFile_Put_Var1D_r
@@ -3027,6 +3041,69 @@ contains
  !  ***


  subroutine NcFile_Get_Var_i1_1d( self, description, values, units, status, &
                                   start, count, missing_value )

    use NetCDF, only : NF90_Get_Var
    use NetCDF, only : NF90_Get_Att
    use NetCDF, only : NF90_ENOTATT
  
    ! --- in/out ---------------------------------
    
    class(T_NcFile), intent(in)       ::  self
    character(len=*), intent(in)      ::  description
    integer(1), intent(out)           ::  values(:)
    character(len=*), intent(out)     ::  units
    integer, intent(out)              ::  status
    integer, intent(in), optional     ::  start(:), count(:)
    real, intent(out), optional       ::  missing_value

    ! --- const --------------------------------------

    character(len=*), parameter  ::  rname = mname//'/NcFile_Get_Var_i1_1d'
    
    ! --- local ----------------------------------
    
    integer             ::  varid
    real                ::  add_offset, scale_factor
    
    ! --- begin ----------------------------------
    
    ! get variable id:
    call NcFile_Inq_VarID( self, description, varid, status )
    IF_NOT_OK_RETURN(status=1)

    ! read:
    status = NF90_Get_Var( self%ncid, varid, values, start=start, count=count )
    IF_NF90_NOT_OK_RETURN(status=1)
    
    ! packed?
    call self%Inq_VarPacking( varid, add_offset, scale_factor, status )
    IF_ERROR_RETURN(status=1)
    if ( status == 0 ) then
      ! unpack:
      values = nint( add_offset + scale_factor * values )
    end if
    
    ! Missing value?
    if ( present( missing_value ) ) then
      call self%Inq_VarMissing( varid, missing_value, status )
      IF_ERROR_RETURN(status=1)
    end if
    
    ! get units:
    call self%Inq_VarUnits( varid, description, units, status )
    IF_ERROR_RETURN(status=1)
    
    ! ok
    status = 0
    
  end subroutine NcFile_Get_Var_i1_1d
 

  !  ***


  subroutine NcFile_Get_Var_i_1d( self, description, values, units, status, &
                                   start, count, missing_value )

@@ -3088,6 +3165,75 @@ contains
  
  ! *
  
  subroutine NcFile_Get_Var_c_2d( self, description, values, units, status, &
                                   start, count )

    use NetCDF, only : NF90_Get_Var
    use NetCDF, only : NF90_Get_Att
    use NetCDF, only : NF90_ENOTATT
  
    ! --- in/out ---------------------------------
    
    class(T_NcFile), intent(in)       ::  self
    character(len=*), intent(in)      ::  description
    character(len=1), intent(out)     ::  values(:,:)
    character(len=*), intent(out)     ::  units
    integer, intent(out)              ::  status
    integer, intent(in), optional     ::  start(:), count(:)

    ! --- const --------------------------------------

    character(len=*), parameter  ::  rname = mname//'/NcFile_Get_Var_c_2d'
    
    ! --- local ----------------------------------
    
    integer                         ::  varid
    character(len=:), allocatable   ::  cvalues(:)
    integer                         ::  i, j
    
    ! --- begin ----------------------------------
    
    ! get variable id:
    call NcFile_Inq_VarID( self, description, varid, status )
    IF_NOT_OK_RETURN(status=1)

    ! reading 2D char array does not work,
    ! use instead 1D array of strings:
    allocate( character(len=size(values,1)) :: cvalues(size(values,2)), stat=status )
    IF_NOT_OK_RETURN(status=1)
    
    ! safety ..
    if ( present(start) .or. present(count) ) then
      write (csol,'("optional arguments `start` or `count` not supported yet for char arrays")'); call csoErr
      TRACEBACK; status=1; return
    end if

    ! read:
    status = NF90_Get_Var( self%ncid, varid, cvalues )
    IF_NF90_NOT_OK_RETURN(status=1)
    
    ! copy:
    do j = 1, size(values,2)
      do i = 1, size(values,1)
        values(i,j) = cvalues(j)(i:i)
      end do ! i
    end do ! j
    
    ! clear:
    deallocate( cvalues, stat=status )
    IF_NOT_OK_RETURN(status=1)
                
    ! get units:
    call self%Inq_VarUnits( varid, description, units, status )
    IF_ERROR_RETURN(status=1)
    
    ! ok
    status = 0
    
  end subroutine NcFile_Get_Var_c_2d
  
  ! *
  
  subroutine NcFile_Get_Var_i_2d( self, description, values, units, status, &
                                   start, count, missing_value )

@@ -3837,6 +3983,10 @@ contains
  ! where ``[vmin,vmax]`` is the range of input values,
  ! and ``[fmin,fmax]`` the range of possible values of the packed data type.
  !
  ! If only a single value is present (vmin==vmax) then is used:
  !   scale_factor = 1.0
  !   add_offset   = vmax
  !
  ! Original values might have no-data elements equal to 'fill_value'.
  ! If this is defined, then also 'fill_value__packed' should have been defined;
  ! its value should be outside [fmin,vmin], and is here checked to be fmin-1.
@@ -3877,10 +4027,10 @@ contains
      add_offset   = vmin - scale_factor * fmin
    else
      ! single value only;
      ! set scale factor to that value with zero offset,
      ! packed values will all be 1:
      scale_factor = vmax
      add_offset   = 0.0
      ! set offset to that (single) value and scale factor to 1.0,
      ! packed values will all be 0.0:
      scale_factor = 1.0
      add_offset   = vmax
    end if  ! range or single value

    ! need to check on no-data values?
@@ -4052,6 +4202,64 @@ contains
  ! *
  
  
  !
  ! (Adhoc routine, does not use the internal variable list yet ...)
  !
  ! Write 2D char data to variable with netcdf id 'varid'.
  !

  subroutine NcFile_Put_Var_2d_c( self, varid, values, status )
  
    use NetCDF, only : NF90_Put_Var
    use NetCDF, only : NF90_Put_Att

    ! --- in/out ---------------------------------
    
    class(T_NcFile), intent(inout)        ::  self
    integer, intent(in)                   ::  varid
    character(len=*), intent(in)          ::  values(:,:)
    integer, intent(out)                  ::  status
    
    ! --- const ----------------------------------
    
    character(len=*), parameter   :: rname = mname//'/NcFile_Put_Var_2d_c'
    
    ! --- local ----------------------------------

    character(len=:), allocatable   ::  cvalues(:)
    integer                         ::  i, j
    
    ! --- begin ----------------------------------

    ! writing 2D char array does not work,
    ! use instead 1D array of strings:
    allocate( character(len=size(values,1)) :: cvalues(size(values,2)), stat=status )
    IF_NOT_OK_RETURN(status=1)
    
    ! copy:
    do j = 1, size(values,2)
      do i = 1, size(values,1)
        cvalues(j)(i:i) = values(i,j)
      end do ! i
    end do ! j
    
    ! write:
    status = NF90_Put_Var( self%ncid, varid, cvalues )
    IF_NF90_NOT_OK_RETURN(status=1)
    
    ! clear:
    deallocate( cvalues, stat=status )
    IF_NOT_OK_RETURN(status=1)

    ! ok
    status = 0
    
  end subroutine NcFile_Put_Var_2d_c
  
  
  ! *
  
  
  !
  ! (Adhoc routine, does not use the internal variable list yet ...)
  !
+591 −109

File changed.

Preview size limit exceeded, changes collapsed.

+211 −99

File changed.

Preview size limit exceeded, changes collapsed.