SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/SURFEX/mode

Go to the documentation of this file.
00001 MODULE MODE_CHAR2REAL
00002 !
00003 USE MODI_ABOR1_SFX
00004 !
00005 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00006 USE PARKIND1  ,ONLY : JPRB
00007 !
00008 INTERFACE ASSIGNMENT (=)
00009   MODULE PROCEDURE CHAR_TO_REAL
00010 END INTERFACE
00011 !
00012 CONTAINS 
00013 !
00014 SUBROUTINE CHAR_TO_REAL(KOUT,HSTR) 
00015 USE MODD_ARCH, ONLY : LITTLE_ENDIAN_ARCH
00016 IMPLICIT NONE
00017  CHARACTER(LEN=*),DIMENSION(:),INTENT(IN)  :: HSTR
00018 REAL,DIMENSION(SIZE(HSTR)),   INTENT(OUT) :: KOUT
00019 INTEGER :: ISIZE, JI
00020  CHARACTER(LEN=8),DIMENSION(:),ALLOCATABLE :: YTEMP
00021  CHARACTER(LEN=4),DIMENSION(:),ALLOCATABLE :: YTEMP2
00022 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00023 
00024 IF (LHOOK) CALL DR_HOOK('MODE_CHAR2REAL:CHAR_TO_REAL',0,ZHOOK_HANDLE)
00025 SELECT CASE(LEN(HSTR(1)))
00026 CASE (8)
00027   ISIZE = SIZE(HSTR)
00028   IF (LITTLE_ENDIAN_ARCH) THEN! must swap 8 bytes
00029     ALLOCATE(YTEMP(ISIZE))
00030     DO JI=1,ISIZE
00031       YTEMP(JI)(1:1) = HSTR(JI)(8:8)
00032       YTEMP(JI)(2:2) = HSTR(JI)(7:7)
00033       YTEMP(JI)(3:3) = HSTR(JI)(6:6)
00034       YTEMP(JI)(4:4) = HSTR(JI)(5:5)
00035       YTEMP(JI)(5:5) = HSTR(JI)(4:4)
00036       YTEMP(JI)(6:6) = HSTR(JI)(3:3)
00037       YTEMP(JI)(7:7) = HSTR(JI)(2:2)
00038       YTEMP(JI)(8:8) = HSTR(JI)(1:1)
00039     END DO
00040     KOUT = TRANSFER(YTEMP,1.0_8,ISIZE)
00041     DEALLOCATE(YTEMP)
00042   ELSE
00043     KOUT = TRANSFER(HSTR,1.0_8,ISIZE)
00044   END IF
00045 CASE (4) 
00046   ! EMULATE a 32 bits REAL
00047   ISIZE = SIZE(HSTR)
00048   IF (LITTLE_ENDIAN_ARCH) THEN
00049     ALLOCATE(YTEMP2(ISIZE))
00050     DO JI=1,ISIZE
00051       YTEMP2(JI)(1:1) = HSTR(JI)(4:4)
00052       YTEMP2(JI)(2:2) = HSTR(JI)(3:3)
00053       YTEMP2(JI)(3:3) = HSTR(JI)(2:2)
00054       YTEMP2(JI)(4:4) = HSTR(JI)(1:1)
00055     END DO
00056     KOUT = TRANSFER(YTEMP2,1.0_4,ISIZE)
00057     DEALLOCATE(YTEMP2)
00058   ELSE
00059     KOUT = TRANSFER(HSTR,1.0_4,ISIZE)
00060   END IF 
00061 CASE (2)
00062   ! EMULATE a 16 bits signed INTEGER
00063   IF (LITTLE_ENDIAN_ARCH) THEN! must swap 2 bytes
00064     KOUT = ICHAR(HSTR(:)(2:2))+256*ICHAR(HSTR(:)(1:1))
00065   ELSE
00066     KOUT = ICHAR(HSTR(:)(1:1))+256*ICHAR(HSTR(:)(2:2))
00067  END IF
00068    WHERE (KOUT > 32767) 
00069       KOUT = KOUT - 65536.
00070    END WHERE
00071   
00072 CASE(1)
00073   ! EMULATE an 8 bits signed INTEGER
00074   KOUT(:) = ICHAR(HSTR(:))
00075   WHERE (KOUT > 127) 
00076     KOUT = KOUT - 256.
00077   END WHERE
00078 
00079 CASE default
00080   CALL ABOR1_SFX('MODE_CHAR2REAL: CONVERSION ERROR IN READ_DIRECT SUBROUTINE')
00081 END SELECT
00082 IF (LHOOK) CALL DR_HOOK('MODE_CHAR2REAL:CHAR_TO_REAL',1,ZHOOK_HANDLE)
00083 END SUBROUTINE CHAR_TO_REAL
00084 END MODULE MODE_CHAR2REAL