double_to_integer.f

Go to the documentation of this file.

!                   ****************************
                    SUBROUTINE double_to_integer
!                   ****************************
!
     &(x,ix,n,qt,nsum)
!
!***********************************************************************
! BIEF   V7P0                                   13/01/2014
!***********************************************************************
!
!brief    Coding a double precision array as an I8 integer.
!
!history  J-M HERVOUET (EDF R&D, LNHE)
!+        13/01/2014
!+        V7P0
!+   First version.
!
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!| IX             |<--| INTEGER ARRAY CODING THE REAL ARRAY
!| N              |-->| NUMBER OF POINTS IN THE ARRAYS X AND IX
!| NSUM           |-->| MAXIMUM NUMBER OF SUMS THAT WILL BE POSSIBLE
!| QT             |<--| THE QUANTUM USED FOR CODING
!| X              |-->| DOUBLE PRECISION ARRAY TO BE CODED
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!
      USE interface_parallel
      USE bief, ex_double_to_integer => double_to_integer
!
      USE declarations_special
      IMPLICIT NONE
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER         , INTENT(IN)    :: N,NSUM
      INTEGER(KIND=K8), INTENT(INOUT) :: IX(n)
      DOUBLE PRECISION, INTENT(IN)    :: X(n)
      DOUBLE PRECISION, INTENT(INOUT) :: QT
!
!+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
!
      INTEGER I
      INTEGER(KIND=K8) IMAX
      DOUBLE PRECISION XMIN,XMAX,SURQT
!
      INTRINSIC nint,max,abs
!
!-----------------------------------------------------------------------
!
      CALL mini(xmin,i,x,n)
      CALL maxi(xmax,i,x,n)
!
      IF(ncsize.GT.1) THEN
        xmin=p_min(xmin)
        xmax=p_max(xmax)
      ENDIF
!
!     WE WANT A RANGE CENTRED ON 0, THAT CONTAINS [XMIN,XMAX]
!
      xmax=max(abs(xmin),abs(xmax))
      imax=huge(imax)/nsum
!
      qt=xmax/dble(imax)
!
      IF(qt.EQ.0.d0) THEN
        surqt=0.d0
      ELSE
        surqt=1.d0/qt
      ENDIF
!
!-----------------------------------------------------------------------
!     CODING
!-----------------------------------------------------------------------
!
      DO i=1,n
        ix(i)=nint(x(i)*surqt)
      ENDDO
!
!-----------------------------------------------------------------------
!
      RETURN
      END