Snippet Library
Module de compression sans perte flottant - Fortran | |
| Type: Sample Code (HOWTO) |
Category: Other |
| License: GNU General Public License |
Language: Other Language |
Description: J'ai implémenté ce module pour un logiciel d'évaluation génomique (genekit. V.Ducrocq). Ce module avait le double avantage de compresser les fichiers de données (format texte à l'origine) comportant plusieurs millions d'enregistrement mais également d'optimiser les communications entre les processus MPI. Il s'est avéré que le module était inutilisable pour les communications entre processus (déjà bien optimiser par les implémentations MPI existantes). J'ai implémenté ce module à partir de l'article : "Fast Lossless Compression of Scientific Floating-Point Data." Ratanaworabhan et al Le module implémente une classe principale CompressFPD64 pour l'interface de compression et de décompression et d'un ensemble de classe pour les prédictions (DataFilePredictorFPD, StridePredictorFPD, TwoStridePredictorFPD, FCMPredictorFPD) | |
Versions Of This Snippet:
| Snippet ID | Download Version | Date Posted | Author | Delete |
|---|---|---|---|---|
| 2 | 1.0 | 2015-05-12 08:51 | Olivier Filangi | 
|
Download a raw-text version of this code by clicking on “Download Version”
Latest Snippet Version: 1.0
! 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
Add a new version
You can submit a new version of this snippet if you have modified it and you feel it is appropriate to share with others.