factec.F90

Go to the documentation of this file.

! Oct-2012 P. Marguinaud 64b LFI
! Jan-2011 P. Marguinaud Thread-safe FA
SUBROUTINE factec_fort                                      &
&                     (fa, krep, pa, knbit, kdec, ke, knutil)
USE fa_mod, ONLY : fa_com
USE parkind1, ONLY : jprb
USE yomhook , ONLY : lhook, dr_hook
USE lfi_precision
IMPLICIT NONE
!****
!      Sous-programme de calcul du FACTeur d'EChelle binaire associe
!     a un champ d'amplitude donnee, code sur KNBIT bits.
!**
!    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
!                PA     (Entree) ==> Amplitude du champ a compacter;
!                KNBIT  (Entree) ==> Nb de bits servant au compactage;
!                KDEC   (Entree) ==> Facteur d'echelle decimal;
!                KE     (Sortie) ==> Facteur d'echelle binaire;
!                KNUTIL (Sortie) ==> Nombre d'entiers utilises pour
!                                    representer le champ.
!
!     Modifications:
!
TYPE(fa_com) :: FA
REAL (KIND=JPDBLR) PA
INTEGER (KIND=JPLIKB) KREP, KNBIT, KDEC, KE, KNUTIL
!
REAL (KIND=JPDBLR) ZTWO, ZHALF, ZTEN

!
!**
!     1.  -  CONTROLES ET INITIALISATIONS.
!-----------------------------------------------------------------------
!
REAL(KIND=JPRB) :: ZHOOK_HANDLE
IF (lhook) CALL dr_hook('FACTEC_MT',0,zhook_handle)
ztwo   = 2._jpdblr
zhalf  = 0.5_jpdblr
zten   = 10._jpdblr
krep   = 0
ke     = 0
knutil = 0
IF (knbit.LE.0 .OR. knbit.GT.64) THEN
  krep=-1
  WRITE (unit=fa%NULOUT,fmt=*)'****'
  WRITE (unit=fa%NULOUT,fmt=*)                               &
&         '**** FACTEC: ERROR, bits number out of range 1-64'
  WRITE (unit=fa%NULOUT,fmt=*)'****         KNBIT = ',knbit
  WRITE (unit=fa%NULOUT,fmt=*)                                 &
&         '****         Binary scale factor is not computed !!'
  WRITE (unit=fa%NULOUT,fmt=*)'****'
  GOTO 1001
ENDIF
IF ( abs(pa).LT.tiny(pa) ) THEN
  WRITE (unit=fa%NULOUT,fmt=*)'----'
  WRITE (unit=fa%NULOUT,fmt=*)                              &
&         '---- FACTEC: Warning, the range of the field is', &
&         ' considered as zero'
  WRITE (unit=fa%NULOUT,fmt=*)'----'
  ke = 0
  knutil = 1
  GOTO 1001
ENDIF
IF ( abs(log10(abs(pa))+real(kdec, jpdblr))  &
&     .GE. REAL (RANGE(PA), JPDBLR) ) then
  krep=-1
  WRITE (unit=fa%NULOUT,fmt=*)'****'
  WRITE (unit=fa%NULOUT,fmt=*)                                  &
&                '**** FACTEC: ERROR, PA*10**KDEC exceeds real', &
&                'representation of KIND=',jpdblr
  WRITE (unit=fa%NULOUT,fmt=*)                              &
&         '****         LOG10(ABS(PA)), KDEC, RANGE(PA) = ', &
&         log10(abs(pa)), kdec, range(pa)
  WRITE (unit=fa%NULOUT,fmt=*)                                 &
&         '****         Binary scale factor is not computed !!'
  WRITE (unit=fa%NULOUT,fmt=*)'****'
  GOTO 1001
ENDIF
!
!**
!     2.  -  CALCUL DU FACTEUR D'ECHELLE BINAIRE
!-----------------------------------------------------------------------
!
ke = floor( log( (pa*10._8**kdec) /                 &
&                 (2._8**knbit-0.5_8) )/log(2._8),  &
&                 kind=jplikb ) + 1
knutil = floor( 0.5_8 + pa*(10._8**kdec)*(2._8**(-ke)), &
&                kind=jplikb )

1001 CONTINUE

IF (lhook) CALL dr_hook('FACTEC_MT',1,zhook_handle)
END SUBROUTINE


!INTF KREP            OUT 
!INTF PA            IN    
!INTF KNBIT         IN    
!INTF KDEC          IN    
!INTF KE              OUT 
!INTF KNUTIL          OUT