Support integer(1) and character data types. (6fe37fff) · Commits · CAMS / CSO

oper/src/cso_comm.F90

+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, mrecvcounts, mdispls, 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, m1sendcounts, m1displs, 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 )

oper/src/cso_domains.F90

+258 −7

File changed.

Preview size limit exceeded, changes collapsed.

oper/src/cso_ncfile.F90

+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 ...)
		!

oper/src/cso_pixels.F90

+591 −109

File changed.

Preview size limit exceeded, changes collapsed.

oper/src/cso_sat.F90

+211 −99

File changed.

Preview size limit exceeded, changes collapsed.