SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/FA/mt/factec

Go to the documentation of this file.
00001 C Jan-2011 P. Marguinaud Thread-safe FA
00002       SUBROUTINE FACTEC_MT (FA, KREP, PA, KNBIT, KDEC, KE, KNUTIL)
00003       USE FA_MOD, ONLY : FA_COM
00004       USE PARKIND1, ONLY : JPRB
00005       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00006 !****
00007 !      Sous-programme de calcul du FACTeur d'EChelle binaire associe
00008 !     a un champ d'amplitude donnee, code sur KNBIT bits.
00009 !**
00010 !    Arguments : KREP   (Sortie) ==> Code-reponse du sous-programme;
00011 !                PA     (Entree) ==> Amplitude du champ a compacter;
00012 !                KNBIT  (Entree) ==> Nb de bits servant au compactage;
00013 !                KDEC   (Entree) ==> Facteur d'echelle decimal;
00014 !                KE     (Sortie) ==> Facteur d'echelle binaire;
00015 !                KNUTIL (Sortie) ==> Nombre d'entiers utilises pour
00016 !                                    representer le champ.
00017 !
00018 !     Modifications:
00019 !
00020       IMPLICIT NONE
00021 #include "precision.h"
00022       TYPE(FA_COM) :: FA
00023       REAL (KIND=JPDBLR) PA
00024       INTEGER KREP, KNBIT, KDEC, KE, KNUTIL
00025 !
00026       REAL (KIND=JPDBLR) ZTWO, ZHALF, ZTEN
00027 #include "facom_mt.h"
00028 !
00029 !**
00030 !     1.  -  CONTROLES ET INITIALISATIONS.
00031 !-----------------------------------------------------------------------
00032 !
00033       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00034       IF (LHOOK) CALL DR_HOOK('FACTEC_MT',0,ZHOOK_HANDLE)
00035       ZTWO   = 2.
00036       ZHALF  = 0.5
00037       ZTEN   = 10.
00038       KREP   = 0
00039       KE     = 0
00040       KNUTIL = 0
00041       IF (KNBIT.LE.0 .OR. KNBIT.GT.64) THEN
00042         KREP=-1
00043         WRITE (UNIT=FA%NULOUT,FMT=*)'****'
00044         WRITE (UNIT=FA%NULOUT,FMT=*)
00045      S         '**** FACTEC: ERROR, bits number out of range 1-64'
00046         WRITE (UNIT=FA%NULOUT,FMT=*)'****         KNBIT = ',KNBIT
00047         WRITE (UNIT=FA%NULOUT,FMT=*)
00048      S         '****         Binary scale factor is not computed !!'
00049         WRITE (UNIT=FA%NULOUT,FMT=*)'****'
00050         IF (LHOOK) CALL DR_HOOK('FACTEC_MT',1,ZHOOK_HANDLE)
00051         RETURN
00052       ENDIF
00053       IF ( ABS(PA).LT.TINY(PA) ) THEN
00054         WRITE (UNIT=FA%NULOUT,FMT=*)'----'
00055         WRITE (UNIT=FA%NULOUT,FMT=*)
00056      S         '---- FACTEC: Warning, the range of the field is',
00057      S         ' considered as zero'
00058         WRITE (UNIT=FA%NULOUT,FMT=*)'----'
00059         KE = 0
00060         KNUTIL = 1
00061         IF (LHOOK) CALL DR_HOOK('FACTEC_MT',1,ZHOOK_HANDLE)
00062         RETURN
00063       ENDIF
00064       IF ( ABS(LOG10(ABS(PA))+KDEC) .GE. RANGE(PA) ) THEN
00065         KREP=-1
00066         WRITE (UNIT=FA%NULOUT,FMT=*)'****'
00067         WRITE (UNIT=FA%NULOUT,FMT=*)
00068      S                '**** FACTEC: ERROR, PA*10**KDEC exceeds real',
00069      S                'representation of KIND=',JPDBLR
00070         WRITE (UNIT=FA%NULOUT,FMT=*)
00071      S         '****         LOG10(ABS(PA)), KDEC, RANGE(PA) = ',
00072      S         LOG10(ABS(PA)), KDEC, RANGE(PA)
00073         WRITE (UNIT=FA%NULOUT,FMT=*)
00074      S         '****         Binary scale factor is not computed !!'
00075         WRITE (UNIT=FA%NULOUT,FMT=*)'****'
00076         IF (LHOOK) CALL DR_HOOK('FACTEC_MT',1,ZHOOK_HANDLE)
00077         RETURN
00078       ENDIF
00079 !
00080 !**
00081 !     2.  -  CALCUL DU FACTEUR D'ECHELLE BINAIRE
00082 !-----------------------------------------------------------------------
00083 !
00084 ! KE = FLOOR( LOG( (PA*10.**KDEC) / (2.**KNBIT-0.5) )/LOG(2.) ) + 1
00085       KE = FLOOR( LOG( (PA*10._8**KDEC) /
00086      S                 (2._8**KNBIT-0.5_8) )/LOG(2._8) ) + 1
00087 ! KE = FLOOR( LOG( (PA*ZTEN**KDEC) / (ZTWO**KNBIT-ZHALF) )/LOG(ZTWO) ) + 1
00088 !
00089 ! KNUTIL = FLOOR( 0.5 + PA*(10.**KDEC)*(2.**(-KE)) )
00090       KNUTIL = FLOOR( 0.5_8 + PA*(10._8**KDEC)*(2._8**(-KE)) )
00091 ! KNUTIL = FLOOR( ZHALF + PA*(ZTEN**KDEC)*(ZTWO**(-KE)) )
00092 !
00093       IF (LHOOK) CALL DR_HOOK('FACTEC_MT',1,ZHOOK_HANDLE)
00094       END
00095