mode_char2real.F90

Go to the documentation of this 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-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-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