mode_char2real.F90 Source File

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL version 2.1
!SFX_LIC version 1. See LICENSE, Licence_CeCILL_V2.1-en.txt and Licence_CeCILL_V2.1-fr.txt  
!SFX_LIC for details. version 1.
MODULE MODE_CHAR2REAL
!
USE MODI_ABOR1_SFX
!
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE PARKIND1  ,ONLY : JPRB
!
INTERFACE ASSIGNMENT (=)
  MODULE PROCEDURE CHAR_TO_REAL
END INTERFACE
!
CONTAINS 
!
SUBROUTINE CHAR_TO_REAL(KOUT,HSTR) 
USE MODD_ARCH, ONLY : LITTLE_ENDIAN_ARCH
IMPLICIT NONE
 CHARACTER(LEN=*),DIMENSION(:),INTENT(IN)  :: HSTR
REAL,DIMENSION(SIZE(HSTR)),   INTENT(OUT) :: KOUT
INTEGER :: ISIZE, JI
 CHARACTER(LEN=8),DIMENSION(:),ALLOCATABLE :: YTEMP
 CHARACTER(LEN=4),DIMENSION(:),ALLOCATABLE :: YTEMP2
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('MODE_CHAR2REAL:CHAR_TO_REAL',0,ZHOOK_HANDLE)
SELECT CASE(LEN(HSTR(1)))
CASE (8)
  ISIZE = SIZE(HSTR)
  IF (LITTLE_ENDIAN_ARCH) THEN! must swap 8 bytes
    ALLOCATE(YTEMP(ISIZE))
    DO JI=1,ISIZE
      YTEMP(JI)(1:1) = HSTR(JI)(8:8)
      YTEMP(JI)(2:2) = HSTR(JI)(7:7)
      YTEMP(JI)(3:3) = HSTR(JI)(6:6)
      YTEMP(JI)(4:4) = HSTR(JI)(5:5)
      YTEMP(JI)(5:5) = HSTR(JI)(4:4)
      YTEMP(JI)(6:6) = HSTR(JI)(3:3)
      YTEMP(JI)(7:7) = HSTR(JI)(2:2)
      YTEMP(JI)(8:8) = HSTR(JI)(1:1)
    END DO
    KOUT = TRANSFER(YTEMP,1.0_8,ISIZE)
    DEALLOCATE(YTEMP)
  ELSE
    KOUT = TRANSFER(HSTR,1.0_8,ISIZE)
  END IF
CASE (4) 
  ! EMULATE a 32 bits REAL
  ISIZE = SIZE(HSTR)
  IF (LITTLE_ENDIAN_ARCH) THEN
    ALLOCATE(YTEMP2(ISIZE))
    DO JI=1,ISIZE
      YTEMP2(JI)(1:1) = HSTR(JI)(4:4)
      YTEMP2(JI)(2:2) = HSTR(JI)(3:3)
      YTEMP2(JI)(3:3) = HSTR(JI)(2:2)
      YTEMP2(JI)(4:4) = HSTR(JI)(1:1)
    END DO
    KOUT = TRANSFER(YTEMP2,1.0_4,ISIZE)
    DEALLOCATE(YTEMP2)
  ELSE
    KOUT = TRANSFER(HSTR,1.0_4,ISIZE)
  END IF 
CASE (2)
  ! EMULATE a 16 bits signed INTEGER
  IF (LITTLE_ENDIAN_ARCH) THEN! must swap 2 bytes
    KOUT = ICHAR(HSTR(:)(2:2))+256*ICHAR(HSTR(:)(1:1))
  ELSE
    KOUT = ICHAR(HSTR(:)(1:1))+256*ICHAR(HSTR(:)(2:2))
 END IF
   WHERE (KOUT > 32767) 
      KOUT = KOUT - 65536.
   END WHERE
  
CASE(1)
  ! EMULATE an 8 bits signed INTEGER
  KOUT(:) = ICHAR(HSTR(:))
  WHERE (KOUT > 127) 
    KOUT = KOUT - 256.
  END WHERE

CASE default
  CALL ABOR1_SFX('MODE_CHAR2REAL: CONVERSION ERROR IN READ_DIRECT SUBROUTINE')
END SELECT
IF (LHOOK) CALL DR_HOOK('MODE_CHAR2REAL:CHAR_TO_REAL',1,ZHOOK_HANDLE)
END SUBROUTINE CHAR_TO_REAL
END MODULE MODE_CHAR2REAL