SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/LIB/XRD38/grib_mf/prtbin

Go to the documentation of this file.
00001       SUBROUTINE PRTBIN_MF (KIN,KNBIT,KOUT,KERR)
00002       USE PARKIND1, ONLY : JPRB
00003       USE YOMHOOK , ONLY : LHOOK, DR_HOOK
00004 C
00005 C**** PRTBIN - Binary to decimal conversion.
00006 C
00007 C     Purpose.
00008 C     --------
00009 C
00010 C           Produces a decimal number with ones and zeroes
00011 C           corresponding to the ones and zeroes of the input
00012 C           binary number.
00013 C           eg input number 1011 binary, output number 1011 decimal.
00014 C
00015 C**   Interface.
00016 C     ----------
00017 C
00018 C           CALL PRTBIN_MF (KIN,KNBIT,KOUT,KERR)
00019 C
00020 C           Integer    K.
00021 C           Real       P.
00022 C           Logical    O.
00023 C           Character  H.
00024 C
00025 C               Input Parameters.
00026 C               -----------------
00027 C
00028 C               KIN   - Integer variable containing binary number.
00029 C
00030 C               KNBIT - Number of bits in binary number.
00031 C
00032 C               Output Parameters.
00033 C               -----------------
00034 C
00035 C               KOUT  - Integer variable containing decimal value
00036 C                       with ones and zeroes corresponding to those of
00037 C                       the input binary number.
00038 C
00039 C               KERR  - 0, If no error.
00040 C                       1, Number of bits in binary number exceeds
00041 C                          maximum allowed.
00042 C
00043 C     Method.
00044 C     -------
00045 C
00046 C           Masking expression used is not ANSI standard.
00047 C
00048 C     Externals.
00049 C     ----------
00050 C
00051 C           None.
00052 C
00053 C     Reference.
00054 C     ----------
00055 C
00056 C           None.
00057 C
00058 C     Comments.
00059 C     ---------
00060 C
00061 C           Routine contains sections 0, 1 and section 9.
00062 C
00063 C     Author.
00064 C     -------
00065 C
00066 C           John Hennessy     ECMWF  October 1985
00067 C
00068 C     Modifications.
00069 C     --------------
00070 C
00071 C           John Hennessy     ECMWF  March 1991
00072 C           Made to conform to current programming standards.
00073 C
00074 C     ---------------------------------------------------------------
00075 C
00076 C
00077       INTEGER KIN, KNBIT, KOUT, KERR
00078 C
00079       INTEGER J101, IK, IMASC, ITEMP
00080 C
00081 C
00082 C
00083 C
00084 C
00085 C
00086 C
00087 C
00088 C*    Section 0. Definition of variables. Check on parameters.
00089 C     -----------------------------------------------------------------
00090 C
00091 C     Check length of binary number.
00092 C
00093       REAL(KIND=JPRB) :: ZHOOK_HANDLE
00094       IF (LHOOK) CALL DR_HOOK('PRTBIN_MF',0,ZHOOK_HANDLE)
00095       IF (KNBIT.LT.0.OR.KNBIT.GT.15)
00096      C   THEN
00097              KERR = 1
00098              WRITE (*,9000) KNBIT
00099              GO TO 900
00100          ELSE
00101              KERR = 0
00102          ENDIF
00103 C
00104 C     -----------------------------------------------------------------
00105 C
00106 C
00107 C
00108 C
00109 C
00110 C
00111 C
00112 C
00113 C
00114 C
00115 C*    Section 1. Generate required number.
00116 C     -----------------------------------------------------------------
00117 C
00118   100 CONTINUE
00119 C
00120       KOUT = 0
00121 C
00122       DO 101 J101=1,KNBIT
00123          IK    = J101 - 1
00124          IMASC = 2**IK
00125          ITEMP = IAND(KIN,IMASC)
00126          IF (ITEMP.NE.0) KOUT = KOUT + 10**IK
00127   101 CONTINUE
00128 C
00129 C     -----------------------------------------------------------------
00130 C
00131 C
00132 C
00133 C
00134 C
00135 C
00136 C
00137 C
00138 C
00139 C
00140 C*    Section 9. Format statements. Return to calling routine.
00141 C     -----------------------------------------------------------------
00142 C
00143   900 CONTINUE
00144 C
00145  9000 FORMAT (1H ,'PRTBIN : Binary number too long - ',I3,' bits.')
00146 C
00147       IF (LHOOK) CALL DR_HOOK('PRTBIN_MF',1,ZHOOK_HANDLE)
00148       END