472 lines
19 KiB
Fortran
472 lines
19 KiB
Fortran
!
|
|
! Copyright 2019 Yuta Hirokawa (University of Tsukuba)
|
|
!
|
|
! Licensed under the Apache License, Version 2.0 (the "License");
|
|
! you may not use this file except in compliance with the License.
|
|
! You may obtain a copy of the License at
|
|
!
|
|
! http://www.apache.org/licenses/LICENSE-2.0
|
|
!
|
|
! Unless required by applicable law or agreed to in writing, software
|
|
! distributed under the License is distributed on an "AS IS" BASIS,
|
|
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
! See the License for the specific language governing permissions and
|
|
! limitations under the License.
|
|
!
|
|
module cbslf
|
|
use, intrinsic :: iso_c_binding
|
|
implicit none
|
|
|
|
type cbslf_context
|
|
integer(c_intptr_t) :: ctx
|
|
end type
|
|
public :: cbslf_context
|
|
|
|
public :: cbslf_store_mode
|
|
public :: cbslf_load_mode
|
|
public :: cbslf_unknown_mode
|
|
|
|
public :: cbslf_success
|
|
public :: cbslf_error
|
|
|
|
public :: cbslf_open
|
|
public :: cbslf_close
|
|
public :: cbslf_flush
|
|
|
|
public :: cbslf_write
|
|
public :: cbslf_read
|
|
public :: cbslf_record
|
|
public :: cbslf_record_heap
|
|
|
|
public :: cbslf_get_mode
|
|
public :: cbslf_set_compression_level
|
|
public :: cbslf_get_compression_level
|
|
|
|
#define PASTE(a,b) a##b
|
|
#define CONCAT(a,b) PASTE(a,b)
|
|
|
|
#define SET_ERRCODE(CODE) \
|
|
if (present(errcode)) errcode = CODE
|
|
|
|
#define SET_ERRCODE_COND(COND) \
|
|
if (present(errcode)) then \
|
|
__NL__ if (COND) then \
|
|
__NL__ errcode = cbslf_success \
|
|
__NL__ else \
|
|
__NL__ errcode = cbslf_error \
|
|
__NL__ end if \
|
|
__NL__ end if
|
|
|
|
#define FORTRAN_ARRAY_1 :
|
|
#define FORTRAN_ARRAY_2 :,:
|
|
#define FORTRAN_ARRAY_3 :,:,:
|
|
#define FORTRAN_ARRAY_4 :,:,:,:
|
|
#define FORTRAN_ARRAY_5 :,:,:,:,:
|
|
#define FORTRAN_ARRAY_6 :,:,:,:,:,:
|
|
#define FORTRAN_ARRAY_7 :,:,:,:,:,:,:
|
|
|
|
#define FORTRAN_ARRAY_VALUE_1 1
|
|
#define FORTRAN_ARRAY_VALUE_2 1,1
|
|
#define FORTRAN_ARRAY_VALUE_3 1,1,1
|
|
#define FORTRAN_ARRAY_VALUE_4 1,1,1,1
|
|
#define FORTRAN_ARRAY_VALUE_5 1,1,1,1,1
|
|
#define FORTRAN_ARRAY_VALUE_6 1,1,1,1,1,1
|
|
#define FORTRAN_ARRAY_VALUE_7 1,1,1,1,1,1,1
|
|
|
|
#define FORTRAN_ARRAY_SHAPE_1 lb(1):ub(1)
|
|
#define FORTRAN_ARRAY_SHAPE_2 lb(1):ub(1),lb(2):ub(2)
|
|
#define FORTRAN_ARRAY_SHAPE_3 lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)
|
|
#define FORTRAN_ARRAY_SHAPE_4 lb(1):ub(1),lb(2):ub(2),lb(3):ub(3),lb(4):ub(4)
|
|
#define FORTRAN_ARRAY_SHAPE_5 lb(1):ub(1),lb(2):ub(2),lb(3):ub(3),lb(4):ub(4),lb(5):ub(5)
|
|
#define FORTRAN_ARRAY_SHAPE_6 lb(1):ub(1),lb(2):ub(2),lb(3):ub(3),lb(4):ub(4),lb(5):ub(5),lb(6):ub(6)
|
|
#define FORTRAN_ARRAY_SHAPE_7 lb(1):ub(1),lb(2):ub(2),lb(3):ub(3),lb(4):ub(4),lb(5):ub(5),lb(6):ub(6),lb(7):ub(7)
|
|
|
|
#define DECLARE_SCALAR_INTERFACE(SAVE_LOAD,ROUTINE_NAME) \
|
|
module procedure CONCAT(CONCAT(SAVE_LOAD,_scalar_),ROUTINE_NAME)
|
|
|
|
#define DECLARE_ARRAY_INTERFACE_N(SAVE_LOAD,ROUTINE_NAME,DIMS) \
|
|
module procedure CONCAT(CONCAT(SAVE_LOAD,CONCAT(_array_,DIMS)),CONCAT(_,ROUTINE_NAME))
|
|
|
|
#define DECLARE_ARRAY_INTERFACE(SAVE_LOAD,ROUTINE_NAME) \
|
|
DECLARE_SCALAR_INTERFACE(SAVE_LOAD,ROUTINE_NAME) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_N(SAVE_LOAD,ROUTINE_NAME,1) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_N(SAVE_LOAD,ROUTINE_NAME,2) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_N(SAVE_LOAD,ROUTINE_NAME,3) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_N(SAVE_LOAD,ROUTINE_NAME,4) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_N(SAVE_LOAD,ROUTINE_NAME,5) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_N(SAVE_LOAD,ROUTINE_NAME,6) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_N(SAVE_LOAD,ROUTINE_NAME,7) \
|
|
|
|
#define DECLARE_ARRAY_INTERFACE_ALLOCATABLE_N(SAVE_LOAD,ROUTINE_NAME,DIMS) \
|
|
module procedure CONCAT(CONCAT(SAVE_LOAD,CONCAT(_array_heap_,DIMS)),CONCAT(_,ROUTINE_NAME))
|
|
|
|
#define DECLARE_ARRAY_INTERFACE_ALLOCATABLE(SAVE_LOAD,ROUTINE_NAME) \
|
|
DECLARE_ARRAY_INTERFACE_ALLOCATABLE_N(SAVE_LOAD,ROUTINE_NAME,1) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_ALLOCATABLE_N(SAVE_LOAD,ROUTINE_NAME,2) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_ALLOCATABLE_N(SAVE_LOAD,ROUTINE_NAME,3) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_ALLOCATABLE_N(SAVE_LOAD,ROUTINE_NAME,4) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_ALLOCATABLE_N(SAVE_LOAD,ROUTINE_NAME,5) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_ALLOCATABLE_N(SAVE_LOAD,ROUTINE_NAME,6) \
|
|
__NL__ DECLARE_ARRAY_INTERFACE_ALLOCATABLE_N(SAVE_LOAD,ROUTINE_NAME,7)
|
|
|
|
#define IMPLEMENT_SCALAR_INTERFACE(ROUTINE_NAME,DATA_TYPE) \
|
|
subroutine CONCAT(write_scalar_,ROUTINE_NAME)(ctx, val, errcode) \
|
|
__NL__ use, intrinsic :: iso_c_binding, only: c_sizeof \
|
|
__NL__ implicit none \
|
|
__NL__ type(cbslf_context), intent(in) :: ctx \
|
|
__NL__ DATA_TYPE, target, intent(in) :: val \
|
|
__NL__ integer(4), intent(out), optional :: errcode \
|
|
__NL__ integer(c_int64_t) :: psize \
|
|
__NL__ integer(4) :: ret \
|
|
__NL__ psize = c_sizeof(val) \
|
|
__NL__ ret = cbsl_write(ctx%ctx, loc(val), psize) \
|
|
__NL__ SET_ERRCODE(ret) \
|
|
__NL__ end subroutine \
|
|
__NL__ subroutine CONCAT(read_scalar_,ROUTINE_NAME)(ctx, val, errcode) \
|
|
__NL__ use, intrinsic :: iso_c_binding, only: c_sizeof \
|
|
__NL__ implicit none \
|
|
__NL__ type(cbslf_context), intent(in) :: ctx \
|
|
__NL__ DATA_TYPE, target, intent(out) :: val \
|
|
__NL__ integer(4), intent(out), optional :: errcode \
|
|
__NL__ integer(c_int64_t) :: psize \
|
|
__NL__ integer(4) :: ret \
|
|
__NL__ psize = c_sizeof(val) \
|
|
__NL__ ret = cbsl_read(ctx%ctx, loc(val), psize) \
|
|
__NL__ SET_ERRCODE(ret) \
|
|
__NL__ end subroutine \
|
|
__NL__ subroutine CONCAT(record_scalar_,ROUTINE_NAME)(ctx, val, errcode) \
|
|
__NL__ use, intrinsic :: iso_c_binding, only: c_sizeof \
|
|
__NL__ implicit none \
|
|
__NL__ type(cbslf_context), intent(in) :: ctx \
|
|
__NL__ DATA_TYPE, target, intent(inout) :: val \
|
|
__NL__ integer(4), intent(out), optional :: errcode \
|
|
__NL__ integer(c_int64_t) :: psize \
|
|
__NL__ integer(4) :: ret \
|
|
__NL__ psize = c_sizeof(val) \
|
|
__NL__ ret = cbsl_record(ctx%ctx, loc(val), psize) \
|
|
__NL__ SET_ERRCODE(ret) \
|
|
__NL__ end subroutine
|
|
|
|
#define IMPLEMENT_ARRAY_INTERFACE_N(ROUTINE_NAME,DATA_TYPE,DIMS) \
|
|
__NL__ subroutine CONCAT(CONCAT(write_array_,CONCAT(DIMS,_)),ROUTINE_NAME)(ctx, val, errcode) \
|
|
__NL__ use, intrinsic :: iso_c_binding, only: c_sizeof, c_int64_t \
|
|
__NL__ implicit none \
|
|
__NL__ type(cbslf_context), intent(in) :: ctx \
|
|
__NL__ DATA_TYPE, intent(in) :: val(CONCAT(FORTRAN_ARRAY_,DIMS)) \
|
|
__NL__ integer(4), intent(out), optional :: errcode \
|
|
__NL__ integer(4) :: lb(DIMS),ub(DIMS),nsize,i \
|
|
__NL__ integer(c_int64_t) :: bsize \
|
|
__NL__ integer(4) :: ret \
|
|
__NL__ nsize = size(val, kind=kind(nsize)) \
|
|
__NL__ do i=1,size(lb) \
|
|
__NL__ lb(i) = lbound(val, i, kind(lb(i))) \
|
|
__NL__ ub(i) = ubound(val, i, kind(ub(i))) \
|
|
__NL__ end do \
|
|
__NL__ call cbslf_write(ctx, nsize, ret) \
|
|
__NL__ bsize = size(lb) * c_sizeof(val(CONCAT(FORTRAN_ARRAY_VALUE_,DIMS))) \
|
|
__NL__ ret = iand(cbsl_write(ctx%ctx, loc(lb), bsize), ret) \
|
|
__NL__ ret = iand(cbsl_write(ctx%ctx, loc(ub), bsize), ret) \
|
|
__NL__ bsize = nsize * c_sizeof(val(CONCAT(FORTRAN_ARRAY_VALUE_,DIMS))) \
|
|
__NL__ ret = iand(cbsl_write(ctx%ctx, loc(val), bsize), ret) \
|
|
__NL__ SET_ERRCODE(ret) \
|
|
__NL__ end subroutine \
|
|
__NL__ subroutine CONCAT(CONCAT(read_array_,CONCAT(DIMS,_)),ROUTINE_NAME)(ctx, val, errcode) \
|
|
__NL__ use, intrinsic :: iso_c_binding, only: c_sizeof, c_int64_t \
|
|
__NL__ implicit none \
|
|
__NL__ type(cbslf_context), intent(in) :: ctx \
|
|
__NL__ DATA_TYPE, intent(out) :: val(CONCAT(FORTRAN_ARRAY_,DIMS)) \
|
|
__NL__ integer(4), intent(out), optional :: errcode \
|
|
__NL__ integer(4) :: lb(DIMS),ub(DIMS),nsize \
|
|
__NL__ integer(c_int64_t) :: bsize \
|
|
__NL__ integer(4) :: ret \
|
|
__NL__ ret = cbslf_error \
|
|
__NL__ if (size(val) > 0) then \
|
|
__NL__ call cbslf_read(ctx, nsize, ret) \
|
|
__NL__ if (ret == cbslf_success .and. nsize > 0) then \
|
|
__NL__ bsize = size(lb) * c_sizeof(val(CONCAT(FORTRAN_ARRAY_VALUE_,DIMS))) \
|
|
__NL__ ret = iand(cbsl_read(ctx%ctx, loc(lb), bsize), ret) \
|
|
__NL__ ret = iand(cbsl_read(ctx%ctx, loc(ub), bsize), ret) \
|
|
__NL__ bsize = nsize * c_sizeof(val(CONCAT(FORTRAN_ARRAY_VALUE_,DIMS))) \
|
|
__NL__ ret = iand(cbsl_read(ctx%ctx, loc(val), bsize), ret) \
|
|
__NL__ else \
|
|
__NL__ ret = cbslf_error \
|
|
__NL__ end if \
|
|
__NL__ end if \
|
|
__NL__ SET_ERRCODE(ret) \
|
|
__NL__ end subroutine \
|
|
__NL__ subroutine CONCAT(CONCAT(record_array_,CONCAT(DIMS,_)),ROUTINE_NAME)(ctx, val, errcode) \
|
|
__NL__ use, intrinsic :: iso_c_binding, only: c_sizeof, c_int64_t \
|
|
__NL__ implicit none \
|
|
__NL__ type(cbslf_context), intent(in) :: ctx \
|
|
__NL__ DATA_TYPE, allocatable, intent(inout) :: val(CONCAT(FORTRAN_ARRAY_,DIMS)) \
|
|
__NL__ integer(4), intent(out), optional :: errcode \
|
|
__NL__ integer(4) :: mode,ret \
|
|
__NL__ mode = cbslf_get_mode(ctx) \
|
|
__NL__ select case(mode) \
|
|
__NL__ case(cbslf_store_mode) \
|
|
__NL__ call cbslf_write(ctx, val, ret) \
|
|
__NL__ case(cbslf_load_mode) \
|
|
__NL__ call cbslf_read(ctx, val, ret) \
|
|
__NL__ case default \
|
|
__NL__ ret = cbslf_error \
|
|
__NL__ end select \
|
|
__NL__ SET_ERRCODE(ret) \
|
|
__NL__ end subroutine \
|
|
__NL__ subroutine CONCAT(CONCAT(record_array_heap_,CONCAT(DIMS,_)),ROUTINE_NAME)(ctx, val, errcode) \
|
|
__NL__ use, intrinsic :: iso_c_binding, only: c_sizeof, c_int64_t \
|
|
__NL__ implicit none \
|
|
__NL__ type(cbslf_context), intent(in) :: ctx \
|
|
__NL__ DATA_TYPE, allocatable, intent(inout) :: val(CONCAT(FORTRAN_ARRAY_,DIMS)) \
|
|
__NL__ integer(4), intent(out), optional :: errcode \
|
|
__NL__ integer(4) :: lb(DIMS),ub(DIMS),nsize,mode \
|
|
__NL__ integer(4) :: ret \
|
|
__NL__ integer(c_int64_t) :: bsize \
|
|
__NL__ mode = cbslf_get_mode(ctx) \
|
|
__NL__ select case(mode) \
|
|
__NL__ case(cbslf_store_mode) \
|
|
__NL__ call cbslf_write(ctx, val, ret) \
|
|
__NL__ case(cbslf_load_mode) \
|
|
__NL__ if (allocated(val)) then \
|
|
__NL__ call cbslf_read(ctx, val, ret) \
|
|
__NL__ else \
|
|
__NL__ call cbslf_read(ctx, nsize, ret) \
|
|
__NL__ if (ret == cbslf_success .and. nsize > 0) then \
|
|
__NL__ bsize = size(lb) * c_sizeof(val(CONCAT(FORTRAN_ARRAY_VALUE_,DIMS))) \
|
|
__NL__ ret = iand(cbsl_read(ctx%ctx, loc(lb), bsize), ret) \
|
|
__NL__ ret = iand(cbsl_read(ctx%ctx, loc(ub), bsize), ret) \
|
|
__NL__ allocate(val(CONCAT(FORTRAN_ARRAY_SHAPE_,DIMS))) \
|
|
__NL__ bsize = nsize * c_sizeof(val(CONCAT(FORTRAN_ARRAY_VALUE_,DIMS))) \
|
|
__NL__ ret = iand(cbsl_read(ctx%ctx, loc(val), bsize), ret) \
|
|
__NL__ else \
|
|
__NL__ ret = cbslf_error \
|
|
__NL__ end if \
|
|
__NL__ end if \
|
|
__NL__ case default \
|
|
__NL__ ret = cbslf_error \
|
|
__NL__ end select \
|
|
__NL__ SET_ERRCODE(ret) \
|
|
__NL__ end subroutine
|
|
|
|
#define IMPLEMENT_ARRAY_INTERFACE(ROUTINE_NAME,DATA_TYPE) \
|
|
IMPLEMENT_SCALAR_INTERFACE(ROUTINE_NAME,DATA_TYPE) \
|
|
IMPLEMENT_ARRAY_INTERFACE_N(ROUTINE_NAME,DATA_TYPE,1) \
|
|
IMPLEMENT_ARRAY_INTERFACE_N(ROUTINE_NAME,DATA_TYPE,2) \
|
|
IMPLEMENT_ARRAY_INTERFACE_N(ROUTINE_NAME,DATA_TYPE,3) \
|
|
IMPLEMENT_ARRAY_INTERFACE_N(ROUTINE_NAME,DATA_TYPE,4) \
|
|
IMPLEMENT_ARRAY_INTERFACE_N(ROUTINE_NAME,DATA_TYPE,5) \
|
|
IMPLEMENT_ARRAY_INTERFACE_N(ROUTINE_NAME,DATA_TYPE,6) \
|
|
IMPLEMENT_ARRAY_INTERFACE_N(ROUTINE_NAME,DATA_TYPE,7)
|
|
|
|
!======
|
|
private
|
|
|
|
integer(8), parameter :: CBSL_VERSION = @cbsl_VERSION_MAJOR@@cbsl_VERSION_MINOR@@cbsl_VERSION_PATCH@
|
|
character(*), parameter :: CBSL_VERSTION_STRING = '@cbsl_VERSION@'
|
|
integer(4), parameter :: CBSL_MAJOR_VERSION = @cbsl_VERSION_MAJOR@
|
|
integer(4), parameter :: CBSL_MINOR_VERSION = @cbsl_VERSION_MINOR@
|
|
integer(4), parameter :: CBSL_PATCH_VERSION = @cbsl_VERSION_PATCH@
|
|
|
|
integer(4), parameter :: cbslf_load_mode = 1
|
|
integer(4), parameter :: cbslf_store_mode = 2
|
|
integer(4), parameter :: cbslf_unknown_mode = -1
|
|
|
|
integer(4), parameter :: cbslf_success = 0
|
|
integer(4), parameter :: cbslf_error = -1
|
|
|
|
! C function interfaces
|
|
interface
|
|
function cbsl_open(open_mode, path) result(ctx) &
|
|
bind(C,name='cbsl_open')
|
|
use, intrinsic :: iso_c_binding
|
|
integer(c_int),value, intent(in) :: open_mode
|
|
character(kind=c_char),intent(in) :: path(*)
|
|
integer(c_intptr_t) :: ctx
|
|
end function
|
|
|
|
function cbsl_close(ctx) result(retcode) &
|
|
bind(C,name='cbsl_close')
|
|
use, intrinsic :: iso_c_binding
|
|
integer(c_intptr_t),value,intent(in) :: ctx
|
|
integer(c_int) :: retcode
|
|
end function
|
|
|
|
function cbsl_flush(ctx) result(retcode) &
|
|
bind(C,name='cbsl_flush')
|
|
use, intrinsic :: iso_c_binding
|
|
integer(c_intptr_t),value,intent(in) :: ctx
|
|
integer(c_int) :: retcode
|
|
end function
|
|
|
|
function cbsl_get_mode(ctx) result(retcode) &
|
|
bind(C,name='cbsl_get_mode')
|
|
use, intrinsic :: iso_c_binding
|
|
integer(c_intptr_t),value,intent(in) :: ctx
|
|
integer(c_int) :: retcode
|
|
end function
|
|
|
|
function cbsl_write(ctx, pdata, psize) result(retcode) &
|
|
bind(C,name='cbsl_write')
|
|
use, intrinsic :: iso_c_binding
|
|
integer(c_intptr_t),value,intent(in) :: ctx
|
|
integer(c_intptr_t),value,intent(in) :: pdata
|
|
integer(c_int64_t),value,intent(in) :: psize
|
|
integer(c_int) :: retcode
|
|
end function
|
|
|
|
function cbsl_read(ctx, pdata, psize) result(retcode) &
|
|
bind(C,name='cbsl_read')
|
|
use, intrinsic :: iso_c_binding
|
|
integer(c_intptr_t),value,intent(in) :: ctx
|
|
integer(c_intptr_t),value,intent(in) :: pdata
|
|
integer(c_int64_t),value,intent(in) :: psize
|
|
integer(c_int) :: retcode
|
|
end function
|
|
|
|
function cbsl_record(ctx, pdata, psize) result(retcode) &
|
|
bind(C,name='cbsl_record')
|
|
use, intrinsic :: iso_c_binding
|
|
integer(c_intptr_t),value,intent(in) :: ctx
|
|
integer(c_intptr_t),value,intent(in) :: pdata
|
|
integer(c_int64_t),value,intent(in) :: psize
|
|
integer(c_int) :: retcode
|
|
end function
|
|
|
|
! cbsl_record_heap() not binds because the function uses malloc()
|
|
|
|
function cbsl_set_compression_level(ctx,clevel) result(retcode) &
|
|
bind(C,name='cbsl_set_compression_level')
|
|
use, intrinsic :: iso_c_binding
|
|
integer(c_intptr_t),value,intent(in) :: ctx
|
|
integer(c_int),value,intent(in) :: clevel
|
|
integer(c_int) :: retcode
|
|
end function
|
|
|
|
function cbsl_get_compression_level(ctx) result(clevel) &
|
|
bind(C,name='cbsl_get_compression_level')
|
|
use, intrinsic :: iso_c_binding
|
|
integer(c_intptr_t),value,intent(in) :: ctx
|
|
integer(c_int) :: clevel
|
|
end function
|
|
end interface
|
|
|
|
! Generic routines
|
|
interface cbslf_write
|
|
DECLARE_SCALAR_INTERFACE(write,character)
|
|
DECLARE_SCALAR_INTERFACE(write,logical)
|
|
|
|
DECLARE_ARRAY_INTERFACE(write,integer4)
|
|
DECLARE_ARRAY_INTERFACE(write,integer8)
|
|
DECLARE_ARRAY_INTERFACE(write,sreal)
|
|
DECLARE_ARRAY_INTERFACE(write,dreal)
|
|
DECLARE_ARRAY_INTERFACE(write,ccomplex)
|
|
DECLARE_ARRAY_INTERFACE(write,zcomplex)
|
|
end interface
|
|
|
|
interface cbslf_read
|
|
DECLARE_SCALAR_INTERFACE(read,character)
|
|
DECLARE_SCALAR_INTERFACE(read,logical)
|
|
|
|
DECLARE_ARRAY_INTERFACE(read,integer4)
|
|
DECLARE_ARRAY_INTERFACE(read,integer8)
|
|
DECLARE_ARRAY_INTERFACE(read,sreal)
|
|
DECLARE_ARRAY_INTERFACE(read,dreal)
|
|
DECLARE_ARRAY_INTERFACE(read,ccomplex)
|
|
DECLARE_ARRAY_INTERFACE(read,zcomplex)
|
|
end interface
|
|
|
|
interface cbslf_record
|
|
DECLARE_SCALAR_INTERFACE(record,character)
|
|
DECLARE_SCALAR_INTERFACE(record,logical)
|
|
|
|
DECLARE_ARRAY_INTERFACE(record,integer4)
|
|
DECLARE_ARRAY_INTERFACE(record,integer8)
|
|
DECLARE_ARRAY_INTERFACE(record,sreal)
|
|
DECLARE_ARRAY_INTERFACE(record,dreal)
|
|
DECLARE_ARRAY_INTERFACE(record,ccomplex)
|
|
DECLARE_ARRAY_INTERFACE(record,zcomplex)
|
|
end interface
|
|
|
|
interface cbslf_record_heap
|
|
DECLARE_ARRAY_INTERFACE_ALLOCATABLE(record,integer4)
|
|
DECLARE_ARRAY_INTERFACE_ALLOCATABLE(record,integer8)
|
|
DECLARE_ARRAY_INTERFACE_ALLOCATABLE(record,sreal)
|
|
DECLARE_ARRAY_INTERFACE_ALLOCATABLE(record,dreal)
|
|
DECLARE_ARRAY_INTERFACE_ALLOCATABLE(record,ccomplex)
|
|
DECLARE_ARRAY_INTERFACE_ALLOCATABLE(record,zcomplex)
|
|
end interface
|
|
|
|
contains
|
|
IMPLEMENT_SCALAR_INTERFACE(character,character(*,kind=c_char))
|
|
IMPLEMENT_SCALAR_INTERFACE(logical,logical(c_bool))
|
|
|
|
IMPLEMENT_ARRAY_INTERFACE(integer4,integer(c_int32_t))
|
|
IMPLEMENT_ARRAY_INTERFACE(integer8,integer(c_int64_t))
|
|
IMPLEMENT_ARRAY_INTERFACE(sreal,real(c_float))
|
|
IMPLEMENT_ARRAY_INTERFACE(dreal,real(c_double))
|
|
IMPLEMENT_ARRAY_INTERFACE(ccomplex,complex(c_float_complex))
|
|
IMPLEMENT_ARRAY_INTERFACE(zcomplex,complex(c_double_complex))
|
|
|
|
function cbslf_open(open_mode, path, errcode) result(ctx)
|
|
implicit none
|
|
integer(4), intent(in) :: open_mode
|
|
character(*), intent(in) :: path
|
|
integer(4), intent(out), optional :: errcode
|
|
type(cbslf_context) :: ctx
|
|
character(1,c_char) :: cpath(len_trim(path)+1)
|
|
integer(4) :: n,i
|
|
n = len_trim(path, kind=4)
|
|
do i=1,n
|
|
cpath(i) = path(i:i)
|
|
end do
|
|
cpath(n+1) = c_null_char
|
|
ctx%ctx = cbsl_open(open_mode, cpath)
|
|
SET_ERRCODE_COND(ctx%ctx /= 0) ! is not null pointer
|
|
end function
|
|
|
|
subroutine cbslf_close(ctx, errcode)
|
|
implicit none
|
|
type(cbslf_context), intent(in) :: ctx
|
|
integer(4), intent(out), optional :: errcode
|
|
integer(4) :: ret
|
|
ret = cbsl_close(ctx%ctx)
|
|
SET_ERRCODE(ret)
|
|
end subroutine
|
|
|
|
subroutine cbslf_flush(ctx, errcode)
|
|
implicit none
|
|
type(cbslf_context), intent(in) :: ctx
|
|
integer(4), intent(out), optional :: errcode
|
|
integer(4) :: ret
|
|
ret = cbsl_flush(ctx%ctx)
|
|
SET_ERRCODE(ret)
|
|
end subroutine
|
|
|
|
function cbslf_get_mode(ctx, errcode) result(open_mode)
|
|
implicit none
|
|
type(cbslf_context), intent(in) :: ctx
|
|
integer(4), intent(out), optional :: errcode
|
|
integer(4) :: open_mode
|
|
open_mode = cbsl_get_mode(ctx%ctx)
|
|
SET_ERRCODE_COND(open_mode == cbslf_unknown_mode)
|
|
end function
|
|
|
|
subroutine cbslf_set_compression_level(ctx, clevel, errcode)
|
|
implicit none
|
|
type(cbslf_context), intent(in) :: ctx
|
|
integer(4), intent(in) :: clevel
|
|
integer(4), intent(out), optional :: errcode
|
|
integer(4) :: ret
|
|
ret = cbsl_set_compression_level(ctx%ctx, clevel)
|
|
SET_ERRCODE(ret)
|
|
end subroutine
|
|
|
|
function cbslf_get_compression_level(ctx, errcode) result(clevel)
|
|
implicit none
|
|
type(cbslf_context), intent(in) :: ctx
|
|
integer(4), intent(out), optional :: errcode
|
|
integer(4) :: clevel
|
|
clevel = cbsl_get_compression_level(ctx%ctx)
|
|
SET_ERRCODE_COND(clevel > 0)
|
|
end function
|
|
end module
|