! Author : Olivier Dot Filangi At Gmail[.]FR ! This module provide a set of datatype to manage a fast lossless compression of floating point dara. ! Reference : Fast Lossless Compression of Scientific Floating-Point Data. Ratanaworabhan et al ! ! Two classes of Predictors : DataFilePredictorFPD,StridePredictorFPD manage a prediction of value to compress data. ! The class CompressFPD64 manage the stream of compressed data ! ! ! ! ! Module COMPRESS_FLOATING_POINT_DATA de compression adapté aux fichiers de performances contenant des flottants ! Proprietes : ! 1) Utilisation d'un predicteur avec un historique ( = nombre de colonne pour un fichier) ! 2) XOR entre cette valeur et la valeur ! 3) sauvegarde du ZCL (zero count leading) + DIFF ! ! ! modification ! 24/06/2014 donnée membre "stream" du type CompressFPD64 pointe vers null à l'initialisation ! module compress_fpd implicit none !#define DEBUG_MOD #undef DEBUG_MOD integer, parameter, private :: sp = selected_real_kind(6, 37) integer, parameter, private :: dp = selected_real_kind(15, 307) integer, parameter, private :: qp = selected_real_kind(33, 4931) ! Codage du Zero Count Leading sur 7 bits en double precision pour atteindre 64 integer , parameter :: NBITS_ZCL_DP = 7 integer , parameter :: NBITS_DP = 64 ! Codage du Zero Count Leading sur 6 bits en double precision pour atteindre 32 integer , parameter :: NBITS_ZCL_SP = 6 integer , parameter :: NBITS_SP = 32 ! Codage du ZCL sur 4 bits le nombre de zero est egale à 4*ZCL integer , parameter :: NBITS_ZLC_4 = 4 ! Codage du ZCL sur 4 bits le nombre de zero est egale à 8*ZCL integer , parameter :: NBITS_ZLC_2 = 2 integer , parameter :: NBITS_ZLC_SELECT = NBITS_ZLC_4 type , public :: CompressFPD64 integer ,private :: BLOCK_SIZE_ALLOC = 100000000 ! taille du buffer integer ,private :: nstream = 0 ! taille du buffer integer(kind=8) ,dimension(:),pointer,public :: stream => null() integer ,public :: idxstream = 0 ! index dans le tableau stream pour la prochaine insertion integer ,private :: idxbitstream = -1 ! index dans l'entier courant pour la prochaine insertion integer ,public :: nflottantTreated = 0 ! Nombre de flottant deja traité contains ! allocation of new stream procedure, public :: setcompress => set_CompressFPD64 ! Prepare to uncompress a stream procedure, public :: setuncompress => set_UncompressFPD64 ! deallocation of stream procedure, public :: release => release_CompressFPD64 ! reinit all index keeping the current stream procedure, public :: rewind ! Get ratio compression (number of integer coded/number of floatted point elt compressed) procedure, public :: ratio ! Get information stream procedure, public :: info => info_CompressFPD64 ! resize the stream buffer procedure, public :: resize_stream ! Add ZCL et DIFF information for simple and double precision in a binary stream procedure, private :: encode_stream64 ! retrieve ZCL et DIFF information for simple and double precision from a binary stream procedure, private :: decode_stream64 procedure ,public :: init => init64 procedure ,public :: addstream => addstream64 procedure ,public :: getstream => getstream64 ! Compress un ensemble de N (taille de l'historique) Valeurs double precision procedure ,public :: compress64 ! Uncompress un ensemble de N (taille de l'historique) Valeurs double precision procedure ,public :: uncompress64 ! Compress un ensemble de N (taille de l'historique) Valeurs simple precision procedure ,public :: compress32 ! Uncompress un ensemble de N (taille de l'historique) Valeurs simple precision procedure ,public :: uncompress32 ! convert the ZCL in the representation domaine 2 bits => 16 values (0,8,16,32) procedure ,public :: getcode procedure ,public :: getZCL end type CompressFPD64 !!=================================================================================== !! !! Predictor type, abstract , public :: PredictorFPD contains procedure(subinit) ,deferred :: init procedure(subrelease) ,deferred :: release procedure(subrelease) ,deferred :: reset procedure(functpred32),deferred :: predict32 procedure(functpred64),deferred :: predict64 procedure(subupdate32),deferred :: update32 procedure(subupdate64),deferred :: update64 end type PredictorFPD abstract interface subroutine subinit(this,nhist) import PredictorFPD class(PredictorFPD) , intent(inout) :: this integer , intent(in) :: nhist end subroutine subinit subroutine subrelease(this) import PredictorFPD class(PredictorFPD) , intent(inout) :: this end subroutine subrelease function functpred32(this,hash,bidon) result(val) import PredictorFPD class(PredictorFPD) ,intent(in) :: this integer ,intent(in) :: hash integer(kind=8) :: val real(kind=4) ,intent(in) :: bidon end function functpred32 function functpred64(this,hash,bidon) result(val) import PredictorFPD class(PredictorFPD) ,intent(in) :: this integer ,intent(in) :: hash integer(kind=8) :: val real(kind=8) ,intent(in) :: bidon end function functpred64 subroutine subupdate32(this,hash,val_flot,val_int) import PredictorFPD class(PredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=4) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int end subroutine subupdate32 subroutine subupdate64(this,hash,val_flot,val_int) import PredictorFPD class(PredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=8) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int end subroutine subupdate64 end interface type , extends(PredictorFPD), public :: DataFilePredictorFPD ! nombre de colonne (correspondant au nombre de colonne du fichier data) integer ,private :: ncol !stockage des anciennes valeurs par colonne integer(kind=8) , dimension(:),allocatable ,private :: lastrecord contains procedure ,public :: init => datafile_init procedure ,public :: release => datafile_release procedure ,public :: reset => datafile_reset procedure ,public :: predict32 => datafile_predict32 procedure ,public :: predict64 => datafile_predict64 procedure ,public :: update32 => datafile_update32 procedure ,public :: update64 => datafile_update64 end type DataFilePredictorFPD type , extends(PredictorFPD) , public :: StridePredictorFPD ! rang du predicteur integer ,private :: nhist !stockage des anciennes valeurs integer(kind=8) , dimension(:),allocatable ,private :: lastrecord !stockage de la difference entre la valeur de lastrecord et la valeur precedente real(kind=dp) , dimension(:),allocatable ,private :: stride contains procedure ,public :: init => stride_init procedure ,public :: release => stride_release procedure ,public :: reset => stride_reset procedure ,public :: predict32 => stride_predict32 procedure ,public :: predict64 => stride_predict64 procedure ,public :: update32 => stride_update32 procedure ,public :: update64 => stride_update64 end type StridePredictorFPD type , extends(PredictorFPD) , public :: TwoStridePredictorFPD ! rang du predicteur integer ,private :: nhist !stockage des anciennes valeurs integer(kind=8) , dimension(:),allocatable ,private :: lastrecord !stockage de la difference entre la valeur de lastrecord et la valeur precedente real(kind=dp) , dimension(:),allocatable ,private :: stride1 real(kind=dp) , dimension(:),allocatable ,private :: stride2 contains procedure ,public :: init => stride2_init procedure ,public :: release => stride2_release procedure ,public :: reset => stride2_reset procedure ,public :: predict32 => stride2_predict32 procedure ,public :: predict64 => stride2_predict64 procedure ,public :: update32 => stride2_update32 procedure ,public :: update64 => stride2_update64 end type TwoStridePredictorFPD type , extends(PredictorFPD) , public :: FCMPredictorFPD ! rang du predicteur integer ,private :: order = 14 ! order of FCM ! integer ,private :: nhist integer ,private :: k = 100 ! history size !stockage des anciennes valeurs integer(kind=8) , dimension(:,:),allocatable ,private :: history ! last record dim = order,nhist integer ,private :: counter_context = 0 integer(kind=8) , dimension(:,:,:),allocatable ,private :: context ! => keep history dim k,order,nhist integer(kind=8) , dimension(:,:) ,allocatable ,private :: valcontext ! => get index dim k,nhist ! real(kind=dp) , dimension(:,:) ,allocatable ,private :: stride contains procedure ,public :: init => fcm_init procedure ,public :: release => fcm_release procedure ,public :: reset => fcm_reset procedure ,public :: predict32 => fcm_predict32 procedure ,public :: predict64 => fcm_predict64 procedure ,public :: update32 => fcm_update32 procedure ,public :: update64 => fcm_update64 end type FCMPredictorFPD !!!! =========================== TEST SUBROUTINE ============================= public :: test_module_FPD contains !! ********************************************************* ! simple prediction : la prediction est la derniere valeur rencontrée de la colonne function fcm_predict64(this,hash,bidon) result(val) class(FCMPredictorFPD) , intent(in) :: this integer , intent(in) :: hash real(kind=dp) , intent(in) :: bidon integer(kind=8) :: val real(kind=dp) :: val_flot integer :: ihist,i,j logical :: equal ihist = 1 ! mod(hash,this%nhist+1) !seek in the context the corresponding history to get a value do i=1,this%k equal=.true. do j=1,this%order if ( this%history(j,ihist) /= this%context(i,j,ihist) ) then equal = .false. exit end if end do if (equal) then ! we find the corresponding history val = this%valcontext(i,ihist) return end if end do !none context was found, return last context recorded... val = this%valcontext(this%counter_context,ihist) return end function fcm_predict64 ! simple prediction : la prediction est la derniere valeur rencontrée de la colonne function fcm_predict32(this,hash,bidon) result(val) class(FCMPredictorFPD) , intent(in) :: this integer , intent(in) :: hash real(kind=sp) , intent(in) :: bidon integer(kind=8) :: val integer :: ihist,i,j logical :: equal ihist = 1 ! mod(hash,this%nhist+1) !seek in the context the corresponding history to get a value do i=1,this%k equal=.true. do j=1,this%order if ( this%history(j,ihist) /= this%context(i,j,ihist) ) then equal = .false. exit end if end do if (equal) then ! we find the corresponding history val = this%valcontext(i,ihist) return end if end do !none context was found, return last context recorded... val = this%valcontext(this%counter_context,ihist) end function fcm_predict32 !! ********************************************************* ! simple prediction : la prediction est la derniere valeur rencontrée de la colonne function datafile_predict64(this,hash,bidon) result(val) class(DataFilePredictorFPD) , intent(in) :: this integer , intent(in) :: hash real(kind=dp) , intent(in) :: bidon integer(kind=8) :: val val = this%lastrecord(mod(hash,this%ncol)+1) return end function datafile_predict64 ! simple prediction : la prediction est la derniere valeur rencontrée de la colonne function datafile_predict32(this,hash,bidon) result(val) class(DataFilePredictorFPD) , intent(in) :: this integer , intent(in) :: hash real(kind=sp) , intent(in) :: bidon integer(kind=8) :: val val = this%lastrecord(mod(hash,this%ncol)+1) return end function datafile_predict32 !! ********************************************************* ! prediction stride : la prediction est la derniere valeur rencontrée de la colonne ! + la difference entre cette valeur et la valeur precedente de la colonne function stride_predict64(this,hash,bidon) result(val) class(StridePredictorFPD) , intent(in) :: this integer , intent(in) :: hash real(kind=dp) , intent(in) :: bidon integer(kind=8) :: val real(kind=dp) :: val_flot val_flot = transfer(this%lastrecord(mod(hash,this%nhist)+1),val_flot) val_flot = val_flot + this%stride(mod(hash,this%nhist)+1) val = transfer(val_flot,val) return end function stride_predict64 function stride_predict32(this,hash,bidon) result(val) class(StridePredictorFPD) , intent(in) :: this integer , intent(in) :: hash real(kind=sp) , intent(in) :: bidon integer(kind=8) :: val real(kind=sp) :: val_flot val_flot = transfer(this%lastrecord(mod(hash,this%nhist)+1),val_flot) val_flot = val_flot + this%stride(mod(hash,this%nhist)+1) val = transfer(val_flot,val) return end function stride_predict32 !! ********************************************************* function stride2_predict64(this,hash,bidon) result(val) class(TwoStridePredictorFPD) , intent(in) :: this integer , intent(in) :: hash real(kind=dp) , intent(in) :: bidon integer(kind=8) :: val real(kind=dp) :: val_flot val_flot = transfer(this%lastrecord(mod(hash,this%nhist)+1),val_flot) val_flot = val_flot + this%stride1(mod(hash,this%nhist)+1) val = transfer(val_flot,val) return end function stride2_predict64 function stride2_predict32(this,hash,bidon) result(val) class(TwoStridePredictorFPD) , intent(in) :: this integer , intent(in) :: hash real(kind=sp) , intent(in) :: bidon integer(kind=8) :: val real(kind=sp) :: val_flot val_flot = transfer(this%lastrecord(mod(hash,this%nhist)+1),val_flot) val_flot = val_flot + this%stride1(mod(hash,this%nhist)+1) val = transfer(val_flot,val) return end function stride2_predict32 !! ********************************************************* subroutine datafile_update64(this,hash,val_flot,val_int) class(DataFilePredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=dp) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int this%lastrecord(mod(hash,this%ncol)+1) = val_int end subroutine datafile_update64 subroutine datafile_update32(this,hash,val_flot,val_int) class(DataFilePredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=sp) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int this%lastrecord(mod(hash,this%ncol)+1) = val_int end subroutine datafile_update32 !! ********************************************************* subroutine stride_update64(this,hash,val_flot,val_int) class(StridePredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=dp) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int real(kind=dp) :: val_buf val_buf = transfer(this%lastrecord(mod(hash,this%nhist)+1),val_buf) this%stride(mod(hash,this%nhist)+1) = val_flot - val_buf this%lastrecord(mod(hash,this%nhist)+1) = val_int end subroutine stride_update64 subroutine stride_update32(this,hash,val_flot,val_int) class(StridePredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=sp) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int real(kind=sp) :: val_buf val_buf = transfer(this%lastrecord(mod(hash,this%nhist)+1),val_buf) this%stride(mod(hash,this%nhist)+1) = val_flot - val_buf this%lastrecord(mod(hash,this%nhist)+1) = val_int end subroutine stride_update32 !! ********************************************************** subroutine stride2_update64(this,hash,val_flot,val_int) class(TwoStridePredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=dp) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int real(kind=dp) :: val_buf val_buf = transfer(this%lastrecord(mod(hash,this%nhist)+1),val_buf) val_buf = val_flot - val_buf ! if (value - old predicted value == s2 )=> stride in s1 if ( val_buf == this%stride2(mod(hash,this%nhist)+1)) then this%stride1(mod(hash,this%nhist)+1) = val_buf end if this%stride2(mod(hash,this%nhist)+1) = val_buf this%lastrecord(mod(hash,this%nhist)+1) = val_int end subroutine stride2_update64 subroutine stride2_update32(this,hash,val_flot,val_int) class(TwoStridePredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=sp) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int real(kind=sp) :: val_buf val_buf = transfer(this%lastrecord(mod(hash,this%nhist)+1),val_buf) val_buf = val_flot - val_buf ! if (value - old predicted value == s2 )=> stride in s1 if ( val_buf == this%stride2(mod(hash,this%nhist)+1)) then this%stride1(mod(hash,this%nhist)+1) = val_buf end if this%stride2(mod(hash,this%nhist)+1) = val_buf this%lastrecord(mod(hash,this%nhist)+1) = val_int end subroutine stride2_update32 !! ********************************************************* subroutine fcm_update64(this,hash,val_flot,val_int) class(FCMPredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=dp) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int integer :: ihist,i,j logical :: equal real(kind=dp) :: val_buf ihist = 1 ! mod(hash,this%nhist+1) !seek in the context the corresponding history to set the value do i=1,this%k equal=.true. do j=1,this%order if ( this%history(j,ihist) /= this%context(i,j,ihist)) then equal = .false. exit end if end do if (equal) then ! we find the corresponding history !try to popup the value if val_int == this%valcontext(i,ihist) this%valcontext(i,ihist) = val_int exit end if end do !none context was found. we add a new context if ( .not. equal ) then this%counter_context = mod(this%counter_context,this%k)+1 do j=1,this%order this%context(this%counter_context,j,ihist) = this%history(j,ihist) end do this%valcontext(this%counter_context,ihist) = val_int end if !update the history this%history(1:this%order-1,ihist)=this%history(2:this%order,ihist) this%history(this%order,ihist) = val_int end subroutine fcm_update64 subroutine fcm_update32(this,hash,val_flot,val_int) class(FCMPredictorFPD) , intent(inout) :: this integer , intent(in) :: hash real(kind=sp) , intent(in) :: val_flot integer(kind=8) , intent(in) :: val_int integer :: ihist,i,j logical :: equal real(kind=sp) :: val_buf ihist = 1 ! mod(hash,this%nhist+1) !seek in the context the corresponding history to set the value do i=1,this%k equal=.true. do j=1,this%order if ( this%history(j,ihist) /= this%context(i,j,ihist)) then equal = .false. exit end if end do if (equal) then ! we find the corresponding history !try to popup the value if val_int == this%valcontext(i,ihist) this%valcontext(i,ihist) = val_int exit end if end do !none context was found. we add a new context if ( .not. equal ) then this%counter_context = mod(this%counter_context,this%k)+1 do j=1,this%order this%context(this%counter_context,j,ihist) = this%history(j,ihist) end do this%valcontext(this%counter_context,ihist) = val_int end if !update the history this%history(1:this%order-1,ihist)=this%history(2:this%order,ihist) this%history(this%order,ihist) = val_int end subroutine fcm_update32 !! ********************************************************* subroutine datafile_init(this,nhist) class(DataFilePredictorFPD) , intent(inout) :: this integer , intent(in) :: nhist integer :: io character(len=256) :: error_mess if ( nhist <= 0 ) then write (0,*) "DataFilePredictorFPD : compress cannot ",& "allocate array with a number of column <= 0 ",nhist stop end if allocate (this%lastrecord(nhist),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "DataFilePredictorFPD compress_fpd:allocation error :",error_mess stop end if this%lastrecord=0. this%ncol = nhist end subroutine datafile_init !! ********************************************************* subroutine stride_init(this,nhist) class(StridePredictorFPD) , intent(inout) :: this integer , intent(in) :: nhist integer :: io character(len=256) :: error_mess if (nhist <= 0) then write (0,*) "StridePredictorFPD compress_fpd:Can not set nhist to 0" stop end if allocate (this%lastrecord(nhist),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "StridePredictorFPD compress_fpd:allocation error :",error_mess stop end if this%lastrecord=0. allocate (this%stride(nhist),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "StridePredictorFPD : compress_fpd:allocation error :",error_mess stop end if this%stride=0. this%nhist=nhist end subroutine stride_init !! ********************************************************* subroutine stride2_init(this,nhist) class(TwoStridePredictorFPD) , intent(inout) :: this integer , intent(in) :: nhist integer :: io character(len=256) :: error_mess if (nhist <= 0) then write (0,*) "TwoStridePredictorFPD compress_fpd:Can not set nhist to 0" stop end if allocate (this%lastrecord(nhist),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "TwoStridePredictorFPD compress_fpd:allocation error :",error_mess stop end if this%lastrecord=0. allocate (this%stride1(nhist),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "TwoStridePredictorFPD : compress_fpd:allocation error :",error_mess stop end if allocate (this%stride2(nhist),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "TwoStridePredictorFPD : compress_fpd:allocation error :",error_mess stop end if this%stride1=0. this%stride2=0. this%nhist=nhist end subroutine stride2_init !! ********************************************************* subroutine fcm_init(this,nhist) class(FCMPredictorFPD) , intent(inout) :: this integer , intent(in) :: nhist integer :: io character(len=256) :: error_mess if (nhist <= 0) then write (0,*) "FCMPredictorFPD compress_fpd:Can not set nhist to 0" stop end if !this%nhist = nhist allocate (this%history(this%order,1),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "TwoStridePredictorFPD : compress_fpd:allocation error :",error_mess stop end if allocate (this%context(this%k,this%order,1),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "TwoStridePredictorFPD : compress_fpd:allocation error :",error_mess stop end if allocate (this%valcontext(this%k,1),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "TwoStridePredictorFPD : compress_fpd:allocation error :",error_mess stop end if ! allocate (this%stride(this%k,this%nhist),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "TwoStridePredictorFPD : compress_fpd:allocation error :",error_mess stop end if this%history = 0 this%context=-1 this%valcontext=0 this%counter_context=1 ! this%stride=0 end subroutine fcm_init !! ********************************************************* subroutine fcm_release(this) class(FCMPredictorFPD) , intent(inout) :: this if ( allocated(this%history) ) then deallocate (this%history) deallocate (this%context) deallocate (this%valcontext) ! deallocate (this%stride) end if end subroutine fcm_release !! ********************************************************* subroutine fcm_reset(this) class(FCMPredictorFPD) , intent(inout) :: this this%history = 0 this%context=0 this%valcontext=0 this%counter_context=1 ! this%stride=0 end subroutine fcm_reset !! ********************************************************* subroutine datafile_release(this) class(DataFilePredictorFPD) , intent(inout) :: this if ( allocated(this%lastrecord) ) then deallocate (this%lastrecord) end if end subroutine datafile_release !! ********************************************************* subroutine stride_release(this) class(StridePredictorFPD) , intent(inout) :: this if ( allocated(this%lastrecord) ) then deallocate (this%lastrecord) end if if ( allocated(this%stride) ) then deallocate (this%stride) end if end subroutine stride_release !! ********************************************************* subroutine stride2_release(this) class(TwoStridePredictorFPD) , intent(inout) :: this if ( allocated(this%lastrecord) ) then deallocate (this%lastrecord) end if if ( allocated(this%stride1) ) then deallocate (this%stride1) end if if ( allocated(this%stride2) ) then deallocate (this%stride2) end if end subroutine stride2_release !! ********************************************************* subroutine datafile_reset(this) class(DataFilePredictorFPD) , intent(inout) :: this this%lastrecord = 0 end subroutine datafile_reset !! ********************************************************* subroutine stride_reset(this) class(StridePredictorFPD) , intent(inout) :: this this%lastrecord = 0 this%stride = 0 end subroutine stride_reset !! ********************************************************* subroutine stride2_reset(this) class(TwoStridePredictorFPD) , intent(inout) :: this this%lastrecord = 0 this%stride1 = 0 this%stride2 = 0 end subroutine stride2_reset !! ********************************************************* function ratio(struct) result(val) class(CompressFPD64) , intent(in) :: struct real :: val if ( struct%idxstream > 0 ) then val = real(struct%nflottantTreated)/real(struct%idxstream) else val = 1. end if end function ratio !! ********************************************************* subroutine info_CompressFPD64(this,unit) class(CompressFPD64) , intent(in) :: this integer , intent(in) :: unit write (unit,*) '===================== INFO STREAM =================== ' write (unit,*) ' memory usage =',this%nstream write (unit,*) ' current index =',this%idxstream write (unit,*) ' binary index =',this%idxbitstream write (unit,*) ' FPD coded =',this%nflottantTreated write (unit,*) ' stream allocated =',associated(this%stream) write (unit,*) ' size stream =',size(this%stream) end subroutine info_CompressFPD64 !! ********************************************************* subroutine resize_stream(this) class(CompressFPD64) , intent(inout) :: this integer(kind=8) ,dimension(:),allocatable :: stream_buf integer :: io character(len=256) :: error_mess allocate (stream_buf(this%nstream),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "CompressFPD64 : compress_fpd:allocation error :",error_mess, 'alloc_size:',this%nstream stop end if stream_buf(:this%nstream) = this%stream(:this%nstream) deallocate (this%stream) allocate (this%stream(this%nstream+this%BLOCK_SIZE_ALLOC),stat=io,errmsg=error_mess) if ( io /= 0 ) then write (0,*) "CompressFPD64 : compress_fpd:allocation error :",error_mess, 'alloc_size:',& this%nstream+this%BLOCK_SIZE_ALLOC stop end if ! print *,this%nstream,size(stream_buf),size(this%stream) this%stream(:this%nstream) = stream_buf this%stream(this%nstream+1:)=0 this%nstream = this%nstream+this%BLOCK_SIZE_ALLOC deallocate (stream_buf) write (*,*) "resize stream =",(real(this%nstream)*4.)/1024.," Ko" end subroutine resize_stream !! ********************************************************* ! Add ZCL et DIFF information in a binary stream subroutine encode_stream64(this,NBITS_ZCL,NBITS,nb,ZCL,DIFF) class(CompressFPD64) , intent(inout) :: this integer , intent(in) :: NBITS_ZCL integer , intent(in) :: NBITS integer , intent(in) :: nb integer(kind=8) , dimension(nb) , intent(in) :: ZCL integer(kind=8) , dimension(nb) , intent(in) :: DIFF integer :: icol,sizerec integer(kind=8) :: code #ifdef DEBUG_MOD print *," ====================================================================" print *," ===*** encode_stream64 ***===" print *," ===*** ZCL =",ZCL print *," ===*** DIFF =",DIFF print *," ====================================================================" #endif !on stoque les valeurs de droite à gauche dans chaque entier (et non de gauche à droite), ! ca evite des calculs supplementaires do icol=1,nb #ifdef DEBUG_MOD print *,"*********** VAL ",icol," ************************" #endif ! NBITS_ZCL_SP bits pour code ZCL code = this%getCode(ZCL(icol),NBITS,NBITS_ZCL) call this%addstream(NBITS_ZCL,code) ! 32 - ZLC bits pour coder DIFF sizerec=NBITS-this%getZCL(code,NBITS,NBITS_ZCL) ! different from first zcl call this%addstream(sizerec,DIFF(icol)) this%nflottantTreated=this%nflottantTreated+1 end do #ifdef DEBUG_MOD print *,"FPD coded=",this%nflottantTreated," nb integer coded=",this%idxstream #endif end subroutine encode_stream64 !! ********************************************************* ! Add ZCL et DIFF information in a binary stream subroutine decode_stream64(this,NBITS_ZCL,NBITS,nb,ZCL,DIFF) class(CompressFPD64) , intent(inout) :: this integer , intent(in) :: NBITS_ZCL integer , intent(in) :: NBITS integer , intent(in) :: nb integer(kind=8) , dimension(nb) , intent(inout) :: ZCL integer(kind=8) , dimension(nb) , intent(inout) :: DIFF integer :: val_buf,icol,sizerec,sizepart,startfrom #ifdef DEBUG_MOD print *," ===*** decode_stream ***===" #endif do icol=1,nb #ifdef DEBUG_MOD print *,"*********** VAL ",icol," ************************" #endif call this%getstream(NBITS_ZCL,ZCL(icol)) sizerec=NBITS-this%getZCL(ZCL(icol),NBITS,NBITS_ZCL) call this%getstream(sizerec,DIFF(icol)) this%nflottantTreated=this%nflottantTreated+1 end do #ifdef DEBUG_MOD print *,"ZCL =",ZCL print *,"DIFF =",DIFF #endif end subroutine decode_stream64 !! ********************************************************* subroutine addstream64(this,sizeval,val) class(CompressFPD64) ,intent(inout) :: this integer ,intent(in) :: sizeval integer(kind=8) ,intent(in) :: val integer(kind=8) :: val_buf integer :: sizepart,v integer ,parameter :: NBITS_INTEGER=bit_size(this%stream) #ifdef DEBUG_MOD print *,"ADD=",val, " SIZE=",sizeval if ( sizeval > NBITS_INTEGER ) then write (0,*) "encode_stream:sizerec [",sizeval,"] > INTEGER_PRECISION =",NBITS_INTEGER stop end if #endif if ( sizeval <= 0 ) return val_buf = this%stream(this%idxstream) ! Le codage rentre dans l'entier courant du stream if ( (this%idxbitstream + sizeval) <= NBITS_INTEGER ) then call mvbits(val,0,sizeval,val_buf,this%idxbitstream) this%idxbitstream = this%idxbitstream + sizeval this%stream(this%idxstream) = val_buf if ( this%idxbitstream >= NBITS_INTEGER ) then this%idxbitstream = 0 this%idxstream = this%idxstream + 1 if ( this%idxstream > this%nstream ) then call this%resize_stream() end if end if else ! Il faut coder l'entrée de cette valeur à cheval entre deux entiers consecutifs de stream sizepart = ( NBITS_INTEGER - this%idxbitstream ) call mvbits(val,0,sizepart,val_buf,this%idxbitstream) !save this%stream(this%idxstream) = val_buf !load new integer this%idxstream = this%idxstream + 1 if ( this%idxstream > this%nstream ) then call this%resize_stream() end if val_buf = this%stream(this%idxstream) ! move remaining data this%idxbitstream = sizeval-sizepart call mvbits(val,sizepart,this%idxbitstream,val_buf,0) this%stream(this%idxstream) = val_buf end if #ifdef DEBUG_MOD print *,'insert VAL=',val_buf, " new index=",this%idxbitstream, & " nflottantcoded=",this%nflottantTreated, " ninteger used=",this%idxstream #endif end subroutine addstream64 !! ********************************************************* subroutine getstream64(this,sizeval,val) class(CompressFPD64) ,intent(inout) :: this integer ,intent(in) :: sizeval integer(kind=8) ,intent(inout) :: val integer(kind=8) :: val_buf integer :: sizepart,startfrom integer ,parameter :: NBITS_INTEGER=bit_size(this%stream) #ifdef DEBUG_MOD print *,"EXTRACT SIZE",sizeval if ( sizeval > NBITS_INTEGER ) then write (0,*) "getstream64 size: [",sizeval,"] > INTEGER_PRECISION =",NBITS_INTEGER stop end if #endif val = 0 if ( sizeval <= 0 ) return if ( this%idxstream > this%nstream ) then call this%info(0) write (0,*) " *** Error fpd_compress:getstream: reach end of stream ! *** " stop end if val_buf = this%stream(this%idxstream) if ( (this%idxbitstream + sizeval) <= NBITS_INTEGER ) then call mvbits(val_buf,this%idxbitstream,sizeval,val,0) this%idxbitstream = this%idxbitstream + sizeval if ( this%idxbitstream >= NBITS_INTEGER ) then this%idxbitstream = 0 this%idxstream = this%idxstream + 1 end if else sizepart = ( NBITS_INTEGER - this%idxbitstream ) call mvbits(val_buf,this%idxbitstream,sizepart,val,0) !load new integer this%idxstream = this%idxstream + 1 if ( this%idxstream > this%nstream ) then call this%info(0) write (0,*) " *** Error fpd_compress:getstream: reach end of stream ! *** " stop end if val_buf = this%stream(this%idxstream) ! move remaining data this%idxbitstream = sizeval-sizepart call mvbits(val_buf,0,this%idxbitstream,val,sizepart) end if #ifdef DEBUG_MOD print *,'extract VAL=',val, " new index=",this%idxbitstream, & " nflottantcoded=",this%nflottantTreated, " ninteger used=",this%idxstream #endif end subroutine getstream64 !! ********************************************************* subroutine init64(this,nstream) class(CompressFPD64) ,intent(inout) :: this integer ,intent(in) :: nstream integer :: io character(len=256) :: error_mess if ( .not. associated(this%stream) ) then allocate (this%stream(nstream),stat=io,errmsg=error_mess) else if ( size(this%stream)< nstream ) then deallocate (this%stream) allocate (this%stream(nstream),stat=io,errmsg=error_mess) else this%stream=0 return end if end if if ( io /= 0 ) then write (0,*) "compress_fpd:init64:allocation error :",error_mess this%nstream=0 else this%stream=0 this%nstream=nstream end if end subroutine init64 !! ********************************************************* ! nbvalues correspond aux nombres de flottants à compresser subroutine set_CompressFPD64(this,predictsize) class(CompressFPD64) , intent(inout) :: this integer ,optional , intent(in) :: predictsize if ( present(predictsize) ) then this%nstream = predictsize else this%nstream = this%BLOCK_SIZE_ALLOC end if this%idxstream = 1 this%idxbitstream = 0 this%nflottantTreated=0 call this%init(this%nstream) end subroutine set_CompressFPD64 subroutine set_UncompressFPD64(this,predictsize) class(CompressFPD64) , intent(inout) :: this integer ,optional , intent(in) :: predictsize if ( present(predictsize) ) then this%nstream = predictsize else this%nstream = this%BLOCK_SIZE_ALLOC end if this%idxstream = 1 this%idxbitstream = 0 this%nflottantTreated=0 call this%init(this%nstream) end subroutine set_UncompressFPD64 !! ********************************************************* subroutine release_CompressFPD64(this) class(CompressFPD64) , intent(inout) :: this this%nstream = 0 this%idxstream = 0 this%idxbitstream = 0 this%nflottantTreated=0 deallocate (this%stream) end subroutine release_CompressFPD64 !! ********************************************************* subroutine rewind(this,predictor) class(CompressFPD64) , intent(inout) :: this class(PredictorFPD) , intent(inout) :: predictor this%idxstream = 1 this%idxbitstream = 0 call predictor%reset() end subroutine rewind !! ********************************************************* subroutine getStream(struct) class(CompressFPD64) , intent(inout) :: struct end subroutine getStream !! ********************************************************* subroutine setStream(struct) class(CompressFPD64) , intent(inout) :: struct end subroutine setStream !! ********************************************************** function getcode(compr,zcl,NBITS_FLOAT,NBITS_ZCL) result(code) class(CompressFPD64) ,intent(in) :: compr integer(kind=8) ,intent(in) :: zcl integer ,intent(in) :: NBITS_FLOAT ! 32 ou 64 integer ,intent(in) :: NBITS_ZCL integer(kind=8) :: code integer :: step,i,cval code = 2**NBITS_ZCL - 1 if ( code >= NBITS_FLOAT ) then code = zcl return end if ! one code for zcl = 32 or 64 if ( NBITS_FLOAT == zcl ) return !step for code step = NBITS_FLOAT / code cval = NBITS_FLOAT - 1 do code=code-1,1,-1 cval=cval - step if ( zcl >= cval) return end do code=0 end function getcode function getZCL(compr,code,NBITS_FLOAT,NBITS_ZCL) result(zcl) class(CompressFPD64) ,intent(in) :: compr integer(kind=8) ,intent(in) :: code integer ,intent(in) :: NBITS_FLOAT ! 32 ou 64 integer ,intent(in) :: NBITS_ZCL integer(kind=8) :: zcl integer :: step,transcode,i,cval transcode = 2**NBITS_ZCL - 1 if ( transcode >= NBITS_FLOAT ) then zcl = code return end if zcl = NBITS_FLOAT if ( transcode == code ) return !step for code step = NBITS_FLOAT / (transcode) zcl = zcl - 1 do transcode = transcode-1,1,-1 zcl = zcl - step if ( transcode == code ) return end do zcl = 0 end function getZCL !! ********************************************************* subroutine compress64(compr,predictor,nb,values) class(CompressFPD64) ,intent(inout) :: compr class(PredictorFPD) ,intent(inout) :: predictor integer ,intent(in) :: nb real(kind=dp) , dimension(nb) , intent(in) :: values integer(kind=8) , dimension(nb) :: ZCL integer(kind=8) , dimension(nb) :: DIFF integer(kind=8) :: compareval,predictvalue integer :: icol,i,ZCL_b integer , parameter :: bitsize= bit_size(DIFF) if ( compr%idxstream == 0 ) then write (0,*) "===============================================" write (0,*) " ** stream is not init ! Call set subroutine **" write (0,*) "===============================================" stop end if ! for each column, we encode the value : ZCL and DIFF do icol = 1,nb compareval = transfer(values(icol),compareval) predictvalue = predictor%predict64(icol,values(1)) DIFF(icol) = IEOR(predictvalue,compareval) ZCL_b=0 do i=bitsize-1,0,-1 if ( btest(DIFF(icol),i) ) exit ZCL_b=ZCL_b+1 end do ZCL(icol)=ZCL_b call predictor%update64(icol,values(icol),compareval) end do call compr%encode_stream64(NBITS_ZLC_SELECT,NBITS_DP,nb,ZCL,DIFF) end subroutine compress64 !! ********************************************************* subroutine compress32(compr,predictor,nb,values) class(CompressFPD64) ,intent(inout) :: compr class(PredictorFPD) ,intent(inout) :: predictor integer ,intent(in) :: nb real(kind=sp) , dimension(nb) , intent(in) :: values integer(kind=8) :: compareval,predictvalue integer(kind=4) :: comp32 integer :: icol,i,ZCL_b integer(kind=8) , dimension(nb) :: ZCL integer(kind=8) , dimension(nb) :: DIFF integer , parameter :: bitsize= bit_size(DIFF) ! real(kind=dp) , dimension(nb) :: values_DP ! values_dp = values ! call compress64(compr,predictor,nb,values_dp) ! values_DP = values if ( compr%idxstream == 0 ) then write (0,*) "===============================================" write (0,*) " ** stream is not init ! Call set subroutine **" write (0,*) "===============================================" stop end if ! for each column, we encode the value : ZCL and DIFF do icol = 1,nb !! correction bug ofi => in 32 transfert(0_32,0) /= 0 with gcc 4.8.* .... !!compareval = transfer(values(icol),compareval) comp32 = transfer(values(icol),comp32) compareval = comp32 !print *,"add val=",values(icol)," => ",compareval predictvalue = predictor%predict32(icol,values(1)) DIFF(icol) = IEOR(predictvalue,compareval) ZCL_b=0 do i=bitsize-1,0,-1 if ( btest(DIFF(icol),i) ) exit ZCL_b=ZCL_b+1 end do if ( ZCL_b < NBITS_SP ) then print *,"STOP ERROR ZCL_b=",ZCL_b," *Simple precision Context*",NBITS_SP stop end if ZCL(icol)=ZCL_b - NBITS_SP ! print *,"===>",ZCL(icol),compr%getcode(ZCL(icol),NBITS_SP,3),compr%getZCL(compr%getcode(ZCL(icol),NBITS_SP,3),NBITS_SP,3) call predictor%update32(icol,values(icol),compareval) end do call compr%encode_stream64(NBITS_ZLC_SELECT,NBITS_SP,nb,ZCL,DIFF) end subroutine compress32 !! ********************************************************* subroutine uncompress64(compr,predictor,nb,values) class(CompressFPD64) , intent(inout) :: compr class(PredictorFPD) , intent(inout) :: predictor real(kind=dp) , dimension(nb) , intent(inout) :: values integer ,intent(in) :: nb integer(kind=8) , dimension(nb) :: ZCL integer(kind=8) , dimension(nb) :: DIFF integer(kind=8) :: compareval,predictvalue integer :: icol,i,ZCL_b if ( compr%idxstream == 0 ) then write (0,*) "stream is not init !" return end if call compr%decode_stream64(NBITS_ZLC_SELECT,NBITS_DP,nb,ZCL,DIFF) ! for each column, we decode the value : ZCL and DIFF do icol = 1, nb predictvalue = predictor%predict64(icol,values(1)) compareval = IEOR(predictvalue,DIFF(icol)) values(icol) = transfer(compareval,values(icol)) call predictor%update64(icol,values(icol),compareval) end do end subroutine uncompress64 !! ********************************************************* subroutine uncompress32(compr,predictor,nb,values) class(CompressFPD64) , intent(inout) :: compr class(PredictorFPD) ,intent(inout) :: predictor real(kind=sp) , dimension(nb) , intent(inout) :: values integer ,intent(in) :: nb integer(kind=8) , dimension(nb) :: ZCL integer(kind=8) , dimension(nb) :: DIFF integer(kind=8) :: compareval,predictvalue integer :: icol,i,ZCL_b if ( compr%idxstream == 0 ) then write (0,*) "stream is not init !" return end if call compr%decode_stream64(NBITS_ZLC_SELECT,NBITS_SP,nb,ZCL,DIFF) ! for each column, we decode the value : ZCL and DIFF do icol = 1, nb ! print *,"<===",ZCL(icol),DIFF(icol) predictvalue = predictor%predict32(icol,values(1)) compareval = IEOR(predictvalue,DIFF(icol)) values(icol) = transfer(compareval,values(icol)) call predictor%update32(icol,values(icol),compareval) end do end subroutine uncompress32 !!! ********************* ========== TEST SUBROUTINE ============= ************************************* subroutine test_module_FPD type(StridePredictorFPD) :: pred1 type(DataFilePredictorFPD) :: pred2 type(TwoStridePredictorFPD) :: pred3 type(FCMPredictorFPD) :: pred_fcm integer , dimension(100) :: suite ! call test_file(pred_fcm) ! stop print *," ******************************** " print *," *** Test ajout ZERO *** " print *," ******************************** " call testzero print *," ******************************** " print *," *** Add 1 elt in Stream < 64 *** " print *," ******************************** " call test_add_get(10) print *," *********************************** " print *," *** Add 1000 elt in Stream *** " print *," *********************************** " call test_add_get_loop(10,1000) !print *," *********************************** " !print *," *** compres32/uncompres32 *** " !print *," *********************************** " !call test_random_simple32 print *," *********************************** " print *," *** compres64/uncompres64 *** " print *," *********************************** " call test_random_simple64 print *," *********************************************************** " print *," *** Test Encodage SUITE SIMPLE - Bench Double precision *** " print *," *********************************************************** " print *," *** ============== StridePredictorFPD ============= *** " call test_suite_simple(pred1,1,1000) print *," *** ============== DataFilePredictorFPD ============= *** " call test_suite_simple(pred2,1,1000) print *," *** ============== TwoStridePredictorFPD ============= *** " call test_suite_simple(pred3,1,1000) print *," *** ============== FCMPredictorFPD ============= *** " call test_suite_simple(pred_fcm,1,1000) !print *," ****************************** " !print *," *** Bench Simple precision *** " !print *," ****************************** " !print *,"=========================================================" !print *," ======== SUITE 1,2,3,4,1,2,3,4,1,2,3,4,1,2,3,4 ======= " !suite(1:16)=(/1,2,3,4,1,2,3,4,1,2,3,4,1,2,3,4/) !print *," *** ============== DataFilePredictorFPD ============= *** " !call test_suite32(pred2,1,16,suite);print *;print * !print *," *** ============== StridePredictorFPD ============= *** " !call test_suite32(pred1,1,16,suite);print *;print * !print *," *** ============== TwoStridePredictorFPD ============= *** " !call test_suite32(pred3,1,16,suite);print *;print * !print *," *** ============== FCMPredictorFPD ============= *** " !call test_suite32(pred_fcm,1,16,suite);print *;print * !print *,"=========================================================" !print *," ======== SUITE 3,4,1,9,3,4,1,9,3,4,1,9,3,4,1,9 ======= " !suite(1:16)=(/3,4,1,9,3,4,1,9,3,4,1,9,3,4,1,9/) !print *," *** ============== DataFilePredictorFPD ============= *** " !call test_suite32(pred2,1,16,suite);print *;print * !print *," *** ============== StridePredictorFPD ============= *** " !call test_suite32(pred1,1,16,suite);print *;print * !print *," *** ============== TwoStridePredictorFPD ============= *** " !call test_suite32(pred3,1,16,suite);print *;print * !print *," *** ============== FCMPredictorFPD ============= *** " !call test_suite32(pred_fcm,1,16,suite);print *;print * !print *," ======== RANDOM ======= " !print *," *** ============== DataFilePredictorFPD/32 ============= *** " !call test_random32(pred2,1,100000) !print *," *** ============== StridePredictorFPD/32 ============= *** " !call test_random32(pred1,1,100000) !print *," *** ============== TwoStridePredictorFPD/32 ============= *** " !call test_random32(pred3,1,100000) !print *," *** ============== FCMPredictorFPD/32 ============= *** " !call test_random32(pred_fcm,1,100000) print *," ****************************** " print *," *** Bench Double precision *** " print *," ****************************** " print *," *** ============== StridePredictorFPD/64 ============= *** " call test_random64(pred1,1,100000) print *," *** ============== DataFilePredictorFPD/64 ============= *** " call test_random64(pred2,1,100000) print *," *** ============== TwoStridePredictorFPD/64 ============= *** " call test_random64(pred3,1,100000) print *," *** ============== FCMPredictorFPD/64 ============= *** " call test_random64(pred_fcm,1,100000) stop end subroutine test_module_FPD subroutine testzero type(CompressFPD64) :: compr integer(kind=8) :: val_curr real(kind=sp), dimension(5) :: r,values = (/ 0.,1.,16.,400.7208,0./) type(DataFilePredictorFPD) :: pred_data call pred_data%init(5) call compr%setcompress(5) call compr%compress32(pred_data,5,values) call compr%rewind(pred_data) call compr%uncompress32(pred_data,5,r) if ( count(r == values) /= 5 ) then call compr%info(6) write (0,*) "false : expected ",values," val=",r stop end if call compr%release() call pred_data%release() call compr%setcompress(100) call compr%addstream(23,111_8) call compr%addstream(23,111_8) call compr%addstream(23,111_8) call compr%addstream(23,111_8) call compr%addstream(23,111_8) call compr%addstream(23,111_8) call compr%addstream(6,32_8) call compr%addstream(0,0_8) compr%idxstream=1 compr%idxbitstream=0 call compr%getstream(23,val_curr) call compr%getstream(23,val_curr) call compr%getstream(23,val_curr) call compr%getstream(23,val_curr) call compr%getstream(23,val_curr) call compr%getstream(23,val_curr) call compr%getstream(6,val_curr) if ( val_curr /= 32 ) then write (0,*) "Error Test ==> 32 expected value val=",val_curr stop end if call compr%getstream(0,val_curr) if ( val_curr /= 0 ) then write (0,*) "Error Test ==> 0 expected value val=",val_curr stop end if write (*,*) "[OK] add 0, size=9" end subroutine testzero subroutine test_add_get(ncol) integer , intent(in) :: ncol type(CompressFPD64) :: compr integer :: i integer(kind=8) :: val_curr !! ========================================= call compr%setcompress(1) call compr%addstream(9,2_8) compr%idxstream=1 compr%idxbitstream=0 call compr%getstream(9,val_curr) if ( val_curr /= 2 ) then write (0,*) "Error Test ==> 2 expected value val=",val_curr stop end if write (*,*) "[OK] add 2, size=9" !! ========================================= call compr%setcompress(1) call compr%addstream(64,2_8) compr%idxstream=1 compr%idxbitstream=0 call compr%getstream(64,val_curr) if ( val_curr /= 2 ) then write (0,*) "Error Test ==> 2 expected value val=",val_curr stop end if end subroutine test_add_get subroutine test_add_get_loop(ncol,nloop) integer , intent(in) :: ncol integer , intent(in) :: nloop type(CompressFPD64) :: compr integer :: i integer(kind=8) :: val_curr call compr%setcompress(nloop) do i=1,nloop call compr%addstream(9,2_8) end do compr%idxstream=1 compr%idxbitstream=0 do i=1,nloop call compr%getstream(9,val_curr) if ( val_curr /= 2 ) then write (0,*) "Error Test ==> 2 expected value val=",val_curr stop end if end do end subroutine test_add_get_loop subroutine test_random_simple32 type(CompressFPD64) :: compr integer :: i real :: valtab(1),r(1) type(DataFilePredictorFPD) :: pred_data call pred_data%init(1) call random_number(valtab) call compr%setcompress(1) call compress32(compr,pred_data,1,valtab) call compr%rewind(pred_data) call uncompress32(compr,pred_data,1,r) if ( r(1) /= valtab(1) ) then call compr%info(6) write (0,*) "false : expected ",valtab(1)," val=",r(1) stop end if call compr%release() call pred_data%release() end subroutine test_random_simple32 subroutine test_random_simple64 type(CompressFPD64) :: compr integer :: i real(kind=dp) :: valtab(1),r(1) type(DataFilePredictorFPD) :: pred_data call pred_data%init(1) call random_number(valtab) call compr%setcompress(1) call compress64(compr,pred_data,1,valtab) call compr%rewind(pred_data) call uncompress64(compr,pred_data,1,r) if ( r(1) /= valtab(1) ) then call compr%info(6) write (0,*) "false : expected ",valtab(1)," val=",r(1) stop end if call compr%release() call pred_data%release() end subroutine test_random_simple64 subroutine test_random32(pred,nhist,nloop) class(PredictorFPD) , intent(inout) :: pred integer , intent(in) :: nhist integer , intent(in) :: nloop type(CompressFPD64) :: compr integer :: i,ii real :: r(1) real , dimension(:), allocatable :: valtab real :: start, finish call cpu_time(start) call pred%init(nhist) allocate (valtab(nloop)) call random_number(valtab) valtab=valtab*1000 call compr%setcompress(nloop) do i=1,nloop call compress32(compr,pred,1,valtab(i)) end do call cpu_time(finish) print '("Time Compress= ",f6.3," seconds."," NFLOT = ",I7)',finish-start print *," ====> RATIO =",compr%ratio() start=finish call compr%rewind(pred) do i=1,nloop call uncompress32(compr,pred,1,r) if ( r(1) /= valtab(i) ) then call compr%info(6) write (0,*) "false : expected ",valtab(i)," val=",r(1), " iloop=",i stop end if end do deallocate (valtab) write (*,*) "[Ok]" call cpu_time(finish) print '("Time Decompr= ",f6.3," seconds."," NFLOT = ",I7)',finish-start,nloop call compr%release() call pred%release() end subroutine test_random32 subroutine test_suite32(pred,nhist,sizes,suite) class(PredictorFPD) , intent(inout) :: pred integer , intent(in) :: nhist integer , intent(in) :: sizes integer ,dimension(:) , intent(in) :: suite type(CompressFPD64) :: compr integer :: i,ii real(kind=dp) , dimension(nhist) :: valtab real :: start, finish call cpu_time(start) call pred%release() call pred%init(nhist) call compr%setcompress(sizes) do i=1,sizes,nhist do ii=1,nhist valtab(ii)=suite(i+ii-1) end do call compress64(compr,pred,nhist,valtab) end do call cpu_time(finish) print '("Time Compress= ",f6.3," seconds."," NFLOT = ",I7)',finish-start print *,"======================================================" print *," ============== RATIO =",compr%ratio()," ============" print *,"======================================================" print *,"-------------------------" call compr%info(6) print *,"-------------------------" start=finish call compr%rewind(pred) do i=1,sizes,nhist call uncompress64(compr,pred,nhist,valtab) do ii=1,nhist if ( suite(i+ii-1) /= valtab(ii) ) then call compr%info(6) write (0,*) "false : val=",valtab(i)," expected ",suite(i+ii-1), " iloop=",i stop end if end do end do write (*,*) "[Ok]" call cpu_time(finish) print '("Time Decompr= ",f6.3," seconds."," NFLOT = ",I7)',finish-start,sizes call compr%release() call pred%release() end subroutine test_suite32 subroutine test_suite_simple(pred,nhist,nloop) class(PredictorFPD) , intent(inout) :: pred integer , intent(in) :: nhist integer , intent(in) :: nloop type(CompressFPD64) :: compr integer :: i,ii real(kind=dp) , dimension(:), allocatable :: valtab real :: start, finish call cpu_time(start) call pred%init(nhist) allocate (valtab(nhist)) call compr%setcompress(nloop) do i=1,nloop,nhist do ii=1,nhist valtab(ii)=i+ii-1 end do call compress64(compr,pred,nhist,valtab) end do call cpu_time(finish) print '("Time Compress= ",f6.3," seconds."," NFLOT = ",I7)',finish-start print *," ========================== " print *," ====RATIO =",compr%ratio() print *," ========================== " ! print *,"-------------------------" ! call compr%info(6) ! print *,"-------------------------" start=finish call compr%rewind(pred) do i=1,nloop,nhist call uncompress64(compr,pred,nhist,valtab) do ii=1,nhist if ( (i + ii -1) /= valtab(ii) ) then call compr%info(6) write (0,*) "false : val=",valtab(i)," expected ",(i + ii -1), " iloop=",i stop end if end do end do deallocate (valtab) write (*,*) "[Ok]" call cpu_time(finish) print '("Time Decompr= ",f6.3," seconds."," NFLOT = ",I7)',finish-start,nloop call compr%release() call pred%release() end subroutine test_suite_simple subroutine test_random64(pred,nhist,nloop) class(PredictorFPD) , intent(inout) :: pred integer , intent(in) :: nhist integer , intent(in) :: nloop type(CompressFPD64) :: compr integer :: i,ii real(kind=dp) :: r(1) real(kind=dp) , dimension(:), allocatable :: valtab real :: start, finish call cpu_time(start) call pred%init(nhist) allocate (valtab(nloop)) call random_number(valtab) valtab=valtab*1000 call compr%setcompress(nloop) do i=1,nloop call compress64(compr,pred,1,valtab(i)) end do call cpu_time(finish) print '("Time Compress= ",f6.3," seconds."," NFLOT = ",I7)',finish-start print *," ====> RATIO =",compr%ratio() start=finish call compr%rewind(pred) do i=1,nloop call uncompress64(compr,pred,1,r) if ( r(1) /= valtab(i) ) then call compr%info(6) write (0,*) "false : expected ",valtab(i)," val=",r(1), " iloop=",i stop end if end do deallocate (valtab) write (*,*) "[Ok]" call cpu_time(finish) print '("Time Decompr= ",f6.3," seconds."," NFLOT = ",I7)',finish-start,nloop call compr%release() call pred%release() end subroutine test_random64 !! ************************************************************************************* subroutine test_file(pred) class(PredictorFPD) , intent(inout) :: pred type(CompressFPD64) :: compr integer :: i,ii real(kind=dp) , dimension(14) :: valtab real :: start, finish real(kind=dp) , dimension(:,:) ,allocatable :: datafile allocate (datafile(100,14)) datafile = transpose(reshape((/& 1.,1.,61.,40.,30.,1.,32.,2.,1.,1.,0.,1.,16.,400.7208068, & 1.,2.,61.,40.,30.,1.,64.,2.,1.,1.,0.,1.,16.,378.6092405, & 1.,3.,61.,40.,30.,1.,102.,2.,1.,1.,20.,1.,16.,422.8063455, & 1.,4.,61.,40.,30.,1.,134.,2.,1.,1.,52.,1.,16.,446.1524943, & 1.,5.,61.,40.,30.,1.,163.,2.,1.,1.,81.,1.,16.,404.3591163, & 1.,6.,61.,40.,30.,1.,191.,2.,1.,1.,109.,1.,16.,482.8101775, & 1.,7.,61.,40.,30.,1.,222.,2.,1.,1.,140.,1.,16.,461.8192922, & 1.,8.,61.,40.,30.,1.,253.,2.,1.,1.,171.,1.,16.,493.2272792, & 1.,9.,61.,40.,30.,1.,282.,2.,1.,1.,200.,1.,16.,452.6028508, & 1.,10.,72.,48.,36.,2.,347.,6.,2.,1.,0.,2.,17.,356.8576225, & 1.,11.,72.,48.,36.,2.,375.,6.,2.,1.,0.,2.,17.,386.8811236, & 1.,12.,72.,48.,36.,2.,412.,6.,2.,1.,8.,2.,17.,375.7816156, & 1.,13.,72.,48.,36.,2.,440.,6.,2.,1.,36.,2.,17.,387.1260413, & 1.,14.,72.,48.,36.,2.,468.,6.,2.,1.,64.,2.,17.,415.1781001, & 1.,15.,72.,48.,36.,2.,497.,6.,2.,1.,93.,2.,17.,435.0262218, & 1.,16.,72.,48.,36.,2.,529.,6.,2.,1.,125.,2.,17.,395.7932483, & 1.,17.,72.,48.,36.,2.,558.,6.,2.,1.,154.,2.,17.,452.8856378, & 1.,18.,72.,48.,36.,2.,588.,6.,2.,1.,184.,2.,17.,457.3265912, & 1.,19.,81.,54.,43.,3.,647.,11.,5.,1.,0.,3.,18.,437.0774596, & 1.,20.,81.,54.,43.,3.,676.,11.,5.,1.,0.,3.,18.,382.5792859, & 1.,21.,81.,54.,43.,3.,713.,11.,5.,1.,0.,3.,18.,382.8253039, & 1.,22.,81.,54.,43.,3.,745.,11.,5.,1.,0.,3.,18.,410.4807373, & 1.,23.,81.,54.,43.,3.,773.,11.,5.,1.,4.,3.,18.,454.1973743, & 1.,24.,81.,54.,43.,3.,803.,11.,5.,1.,34.,3.,18.,421.1965999, & 1.,25.,81.,54.,43.,3.,835.,11.,5.,1.,66.,3.,18.,421.1075783, & 1.,26.,81.,54.,43.,3.,864.,11.,5.,1.,95.,3.,18.,416.0383661, & 1.,27.,81.,54.,43.,3.,892.,11.,5.,1.,124.,3.,18.,412.0377769, & 2.,2.,62.,40.,30.,1.,31.,3.,1.,2.,0.,1.,16.,470.7428877, & 2.,3.,62.,40.,30.,1.,69.,3.,1.,2.,3.,1.,16.,493.6315058, & 2.,4.,62.,40.,30.,1.,101.,3.,1.,2.,35.,1.,16.,530.4416604, & 2.,5.,62.,40.,30.,1.,130.,3.,1.,2.,64.,1.,16.,476.2564778, & 2.,6.,62.,40.,30.,1.,158.,3.,1.,2.,92.,1.,16.,477.3487260, & 2.,7.,62.,40.,30.,1.,189.,3.,1.,2.,123.,1.,16.,499.4842557, & 2.,8.,62.,40.,30.,1.,220.,3.,1.,2.,154.,1.,16.,452.3063110, & 2.,9.,62.,40.,30.,1.,249.,3.,1.,2.,183.,1.,16.,397.8985779, & 2.,10.,73.,48.,37.,2.,330.,7.,3.,2.,0.,2.,17.,296.9186893, & 2.,11.,73.,48.,37.,2.,358.,7.,3.,2.,0.,2.,17.,650.4114446, & 2.,12.,73.,48.,37.,2.,395.,7.,3.,2.,16.,2.,17.,629.0879334, & 2.,13.,73.,48.,37.,2.,423.,7.,3.,2.,44.,2.,17.,652.3509814, & 2.,14.,73.,48.,37.,2.,451.,7.,3.,2.,72.,2.,17.,646.4552580, & 2.,15.,73.,48.,37.,2.,480.,7.,3.,2.,101.,2.,17.,574.9266523, & 2.,16.,73.,48.,37.,2.,512.,7.,3.,2.,133.,2.,17.,566.6593253, & 2.,17.,73.,48.,37.,2.,541.,7.,3.,2.,162.,2.,17.,533.4725265, & 2.,18.,73.,48.,37.,2.,571.,7.,3.,2.,192.,2.,17.,528.8640179, & 2.,19.,81.,54.,43.,3.,655.,11.,5.,2.,0.,3.,18.,353.0435557, & 2.,20.,81.,54.,43.,3.,684.,11.,5.,2.,0.,3.,18.,604.5727712, & 2.,21.,81.,54.,43.,3.,721.,11.,5.,2.,27.,3.,18.,594.6073949, & 2.,22.,81.,54.,43.,3.,753.,11.,5.,2.,59.,3.,18.,643.0839868, & 2.,23.,81.,54.,43.,3.,781.,11.,5.,2.,87.,3.,18.,644.6999980, & 2.,24.,81.,54.,43.,3.,811.,11.,5.,2.,117.,3.,18.,584.1281864, & 2.,25.,81.,54.,43.,3.,843.,11.,5.,2.,149.,3.,18.,607.2354714, & 2.,26.,81.,54.,43.,3.,872.,11.,5.,2.,178.,3.,18.,584.0046535, & 2.,27.,81.,54.,43.,3.,900.,11.,5.,2.,207.,3.,18.,554.1863141, & 3.,98.,60.,39.,30.,10.,28.,1.,1.,21.,0.,1.,16.,163.7248528, & 3.,99.,60.,39.,30.,10.,57.,1.,1.,21.,0.,1.,16.,203.5392723, & 3.,100.,60.,39.,30.,10.,86.,1.,1.,21.,0.,1.,16.,185.5014819, & 3.,101.,60.,39.,30.,10.,128.,1.,1.,21.,18.,1.,16.,182.0294770, & 3.,102.,60.,39.,30.,10.,156.,1.,1.,21.,46.,1.,16.,191.9161088, & 3.,103.,60.,39.,30.,10.,184.,1.,1.,21.,74.,1.,16.,220.1047668, & 3.,104.,60.,39.,30.,10.,217.,1.,1.,21.,107.,1.,16.,233.7994455, & 3.,105.,60.,39.,30.,10.,247.,1.,1.,21.,137.,1.,16.,260.9411912, & 3.,106.,60.,39.,30.,10.,276.,1.,1.,21.,166.,1.,16.,281.6891974, & 3.,107.,60.,39.,30.,10.,310.,1.,1.,21.,200.,1.,16.,308.5365677, & 3.,108.,79.,51.,40.,14.,342.,7.,2.,21.,0.,2.,18.,319.5569894, & 3.,109.,79.,51.,40.,14.,374.,7.,2.,21.,0.,2.,18.,223.0445005, & 3.,110.,79.,51.,40.,14.,411.,7.,2.,21.,0.,2.,18.,221.0397597, & 3.,111.,79.,51.,40.,14.,440.,7.,2.,21.,0.,2.,18.,215.2311555, & 3.,112.,79.,51.,40.,14.,472.,7.,2.,21.,0.,2.,18.,214.8889595, & 3.,113.,79.,51.,40.,14.,502.,7.,2.,21.,0.,2.,18.,217.2286089, & 3.,114.,79.,51.,40.,14.,531.,7.,2.,21.,19.,2.,18.,263.0485508, & 3.,115.,79.,51.,40.,14.,564.,7.,2.,21.,52.,2.,18.,215.7133804, & 3.,116.,79.,51.,40.,14.,622.,7.,2.,21.,115.,2.,18.,227.9440478, & 4.,98.,60.,39.,30.,10.,30.,1.,1.,22.,0.,1.,16.,385.9091690, & 4.,99.,60.,39.,30.,10.,59.,1.,1.,22.,0.,1.,16.,493.4467048, & 4.,100.,60.,39.,30.,10.,88.,1.,1.,22.,0.,1.,16.,457.4634535, & 4.,101.,60.,39.,30.,10.,130.,1.,1.,22.,18.,1.,16.,464.6963764, & 4.,102.,60.,39.,30.,10.,158.,1.,1.,22.,46.,1.,16.,453.0225033, & 4.,103.,60.,39.,30.,10.,186.,1.,1.,22.,74.,1.,16.,492.1058499, & 4.,104.,60.,39.,30.,10.,219.,1.,1.,22.,107.,1.,16.,473.4442605, & 4.,105.,60.,39.,30.,10.,249.,1.,1.,22.,137.,1.,16.,462.7834378, & 4.,106.,60.,39.,30.,10.,278.,1.,1.,22.,166.,1.,16.,472.9760144, & 4.,107.,60.,39.,30.,10.,312.,1.,1.,22.,200.,1.,16.,511.1238621, & 4.,108.,79.,51.,40.,14.,342.,7.,2.,22.,0.,2.,18.,544.9714596, & 4.,109.,79.,51.,40.,14.,374.,7.,2.,22.,0.,2.,18.,541.7719982, & 4.,110.,79.,51.,40.,14.,411.,7.,2.,22.,0.,2.,18.,589.2739131, & 4.,111.,79.,51.,40.,14.,440.,7.,2.,22.,0.,2.,18.,509.4725033, & 4.,112.,79.,51.,40.,14.,472.,7.,2.,22.,30.,2.,18.,533.5697371, & 4.,113.,79.,51.,40.,14.,502.,7.,2.,22.,60.,2.,18.,501.5968797, & 4.,114.,79.,51.,40.,14.,531.,7.,2.,22.,89.,2.,18.,517.1689298, & 4.,115.,79.,51.,40.,14.,564.,7.,2.,22.,122.,2.,18.,511.7383576, & 4.,116.,79.,51.,40.,14.,622.,7.,2.,22.,185.,2.,18.,481.8987888, & 5.,98.,60.,39.,30.,10.,33.,1.,1.,23.,0.,1.,16.,168.9092787, & 5.,99.,60.,39.,30.,10.,62.,1.,1.,23.,0.,1.,16.,234.3615400, & 5.,100.,60.,39.,30.,10.,91.,1.,1.,23.,0.,1.,16.,248.0502428, & 5.,101.,60.,39.,30.,10.,133.,1.,1.,23.,8.,1.,16.,214.7452577, & 5.,102.,60.,39.,30.,10.,161.,1.,1.,23.,36.,1.,16.,210.9344623, & 5.,103.,60.,39.,30.,10.,189.,1.,1.,23.,64.,1.,16.,277.1039614, & 5.,104.,60.,39.,30.,10.,222.,1.,1.,23.,97.,1.,16.,258.0742928, & 5.,105.,60.,39.,30.,10.,252.,1.,1.,23.,127.,1.,16.,245.3979418, & 5.,106.,60.,39.,30.,10.,281.,1.,1.,23.,156.,1.,16.,230.4785225 & /), (/ size(datafile, 2), size(datafile, 1) /) )) call cpu_time(start) call pred%release() call pred%init(14) call compr%setcompress(100*14) do i=1,100 valtab(:)=datafile(i,:) call compress64(compr,pred,14,valtab) end do call cpu_time(finish) print '("Time Compress= ",f6.3," seconds."," NFLOT = ",I7)',finish-start print *," => RATIO =",compr%ratio() start=finish call compr%rewind(pred) do i=1,100 call uncompress64(compr,pred,14,valtab) if ( count(datafile(i,:) == valtab) /= 14 ) then call compr%info(6) write (0,*) "false : val=",valtab," expected ",datafile(i,:), " iloop=",i stop end if end do write (*,*) "[Ok]" call cpu_time(finish) print '("Time Decompr= ",f6.3," seconds."," NFLOT = ",I7)',finish-start call compr%release() call pred%release() deallocate(datafile) end subroutine test_file end module compress_fpd