wrdlen.F

Go to the documentation of this file.

C> @file
C> @brief Determine important information about the local machine.

C> This subroutine figures out some important information about the
C> local machine on which the BUFRLIB software is being run, including
C> the native endianness, the number of bytes in an integer, and
C> whether the machine uses the ASCII or EBCDIC character set.
C>
C> <p>This subroutine isn't normally called directly by any
C> application program, because it's automatically called internally
C> from within subroutine openbf() during the first time that subroutine
C> is called by any application program.  It's also called as needed
C> from within several other subroutines, but it always keeps track of
C> its results as well as whether it has already been called during
C> the life of an application program, and that way if it does end
C> up being called more than once, it will just quietly return without
C> having to recompute all of its results from the first call.
C>
C> @authors J. Woollen
C> @authors J. Ator
C> @date 1994-01-06
C>
C> <b>Program history log:</b>
C> - 1994-01-06  J. Woollen -- Original author
C> - 1998-07-08  J. Woollen -- Replaced call to Cray library routine ABORT
C>                             with call to new internal routine bort()
C> - 2003-11-04  J. Ator    -- Added documentation
C> - 2003-11-04  S. Bender  -- Added remarks and routine interdependencies
C> - 2003-11-04  D. Keyser  -- Unified/portable for WRF; added history
C>                             documentation; outputs more complete
C>                             diagnostic info when routine terminates
C>                             abnormally, unusual things happen or for
C>                             informational purposes; initialized NBYTW
C>                             to zero during the first call
C> - 2004-08-18  J. Ator    -- Added SAVE For IFIRST flag and immediate
C>                           return if IFIRST=1
C> - 2007-01-19  J. Ator    -- Big-endian vs. little-endian is now
C>                           determined at compile time and configured
C>                           within BUFRLIB via conditional compilation
C>                           directives
C> - 2009-03-23  J. Ator    -- Call bvers() to get version number
C>
      SUBROUTINE wrdlen

      COMMON /hrdwrd/ nbytw,nbitw,iord(8)
      COMMON /charac/ iascii,iatoe(0:255),ietoa(0:255)
      COMMON /quiet / iprt

      CHARACTER*128 bort_str,errstr
      CHARACTER*8   cint,dint,cvstr
      CHARACTER*6   cndian,clang
      equivalence(cint,int)
      equivalence(dint,jnt)
      LOGICAL       print

      DATA ifirst/0/

      SAVE ifirst

C-----------------------------------------------------------------------
C-----------------------------------------------------------------------

C     HAS THIS SUBROUTINE ALREADY BEEN CALLED?

      IF(ifirst.EQ.0) THEN

C        NO, SO CHECK WHETHER DIAGNOSTIC INFORMATION SHOULD BE PRINTED
C        AND THEN PROCEED THROUGH THE REST OF THE SUBROUTINE.

         print = iprt.GE.1
         ifirst = 1
      ELSE

C        YES, SO THERE IS NO NEED TO PROCEED ANY FURTHER.

         RETURN
      ENDIF

C  COUNT THE BITS IN A WORD - MAX 64 ALLOWED
C  -----------------------------------------

      int = 1
      DO i=1,65
      int = ishft(int,1)
      IF(int.EQ.0) goto 10
      ENDDO
   10 IF(i.GE.65)       goto 900
      IF(mod(i,8).NE.0) goto 901

C  NBITW is no. of bits in a word, NBYTW is no. of bytes in a word
C  ---------------------------------------------------------------

      nbitw = i
      nbytw = i/8

C  INDEX THE BYTE STORAGE ORDER -  HIGH BYTE TO LOW BYTE
C  -----------------------------------------------------

      jnt = 0

      DO i = 1,8
         iord(i) = 9999
      ENDDO

      DO i=1,nbytw
         int = ishft(1,(nbytw-i)*8)
         DO j=1,nbytw
            IF(cint(j:j).NE.dint(j:j)) goto 20
         ENDDO
c  .... DK: Can the below ever happen since upper loop bounds is NBYTW?
   20    IF(j.GT.nbytw) goto 902
         iord(i) = j
      ENDDO

C  SETUP AN ASCII/EBCDIC TRANSLATOR AND DETERMINE WHICH IS NATIVE
C  --------------------------------------------------------------

      ia = iupm('A',8)
      IF(ia.EQ. 65) THEN
         iascii = 1
         clang  = 'ASCII '
      ELSEIF(ia.EQ.193) THEN
         iascii = 0
         clang  = 'EBCDIC'
      ELSE
         goto 903
      ENDIF

      DO i=0,255
      ietoa(i) = 0
      iatoe(i) = 0
      ENDDO

      ietoa(  1) =   1
      iatoe(  1) =   1
      ietoa(  2) =   2
      iatoe(  2) =   2
      ietoa(  3) =   3
      iatoe(  3) =   3
      ietoa(  5) =   9
      iatoe(  9) =   5
      ietoa(  7) = 127
      iatoe(127) =   7
      ietoa( 11) =  11
      iatoe( 11) =  11
      ietoa( 12) =  12
      iatoe( 12) =  12
      ietoa( 13) =  13
      iatoe( 13) =  13
      ietoa( 14) =  14
      iatoe( 14) =  14
      ietoa( 15) =  15
      iatoe( 15) =  15
      ietoa( 16) =  16
      iatoe( 16) =  16
      ietoa( 17) =  17
      iatoe( 17) =  17
      ietoa( 18) =  18
      iatoe( 18) =  18
      ietoa( 19) =  19
      iatoe( 19) =  19
      ietoa( 22) =   8
      iatoe(  8) =  22
      ietoa( 24) =  24
      iatoe( 24) =  24
      ietoa( 25) =  25
      iatoe( 25) =  25
      ietoa( 29) =  29
      iatoe( 29) =  29
      ietoa( 31) =  31
      iatoe( 31) =  31
      ietoa( 34) =  28
      iatoe( 28) =  34
      ietoa( 37) =  10
      iatoe( 10) =  37
      ietoa( 38) =  23
      iatoe( 23) =  38
      ietoa( 39) =  27
      iatoe( 27) =  39
      ietoa( 45) =   5
      iatoe(  5) =  45
      ietoa( 46) =   6
      iatoe(  6) =  46
      ietoa( 47) =   7
      iatoe(  7) =  47
      ietoa( 50) =  22
      iatoe( 22) =  50
      ietoa( 53) =  30
      iatoe( 30) =  53
      ietoa( 55) =   4
      iatoe(  4) =  55
      ietoa( 60) =  20
      iatoe( 20) =  60
      ietoa( 61) =  21
      iatoe( 21) =  61
      ietoa( 63) =  26
      iatoe( 26) =  63
      ietoa( 64) =  32
      iatoe( 32) =  64
      ietoa( 74) =  91
      iatoe( 91) =  74
      ietoa( 75) =  46
      iatoe( 46) =  75
      ietoa( 76) =  60
      iatoe( 60) =  76
      ietoa( 77) =  40
      iatoe( 40) =  77
      ietoa( 78) =  43
      iatoe( 43) =  78
      ietoa( 79) =  33
      iatoe( 33) =  79
      ietoa( 80) =  38
      iatoe( 38) =  80
      ietoa( 90) =  93
      iatoe( 93) =  90
      ietoa( 91) =  36
      iatoe( 36) =  91
      ietoa( 92) =  42
      iatoe( 42) =  92
      ietoa( 93) =  41
      iatoe( 41) =  93
      ietoa( 94) =  59
      iatoe( 59) =  94
      ietoa( 95) =  94
      iatoe( 94) =  95
      ietoa( 96) =  45
      iatoe( 45) =  96
      ietoa( 97) =  47
      iatoe( 47) =  97
      ietoa(106) = 124
      iatoe(124) = 106
      ietoa(107) =  44
      iatoe( 44) = 107
      ietoa(108) =  37
      iatoe( 37) = 108
      ietoa(109) =  95
      iatoe( 95) = 109
      ietoa(110) =  62
      iatoe( 62) = 110
      ietoa(111) =  63
      iatoe( 63) = 111
      ietoa(121) =  96
      iatoe( 96) = 121
      ietoa(122) =  58
      iatoe( 58) = 122
      ietoa(123) =  35
      iatoe( 35) = 123
      ietoa(124) =  64
      iatoe( 64) = 124
      ietoa(125) =  39
      iatoe( 39) = 125
      ietoa(126) =  61
      iatoe( 61) = 126
      ietoa(127) =  34
      iatoe( 34) = 127
      ietoa(129) =  97
      iatoe( 97) = 129
      ietoa(130) =  98
      iatoe( 98) = 130
      ietoa(131) =  99
      iatoe( 99) = 131
      ietoa(132) = 100
      iatoe(100) = 132
      ietoa(133) = 101
      iatoe(101) = 133
      ietoa(134) = 102
      iatoe(102) = 134
      ietoa(135) = 103
      iatoe(103) = 135
      ietoa(136) = 104
      iatoe(104) = 136
      ietoa(137) = 105
      iatoe(105) = 137
      ietoa(145) = 106
      iatoe(106) = 145
      ietoa(146) = 107
      iatoe(107) = 146
      ietoa(147) = 108
      iatoe(108) = 147
      ietoa(148) = 109
      iatoe(109) = 148
      ietoa(149) = 110
      iatoe(110) = 149
      ietoa(150) = 111
      iatoe(111) = 150
      ietoa(151) = 112
      iatoe(112) = 151
      ietoa(152) = 113
      iatoe(113) = 152
      ietoa(153) = 114
      iatoe(114) = 153
      ietoa(161) = 126
      iatoe(126) = 161
      ietoa(162) = 115
      iatoe(115) = 162
      ietoa(163) = 116
      iatoe(116) = 163
      ietoa(164) = 117
      iatoe(117) = 164
      ietoa(165) = 118
      iatoe(118) = 165
      ietoa(166) = 119
      iatoe(119) = 166
      ietoa(167) = 120
      iatoe(120) = 167
      ietoa(168) = 121
      iatoe(121) = 168
      ietoa(169) = 122
      iatoe(122) = 169
      ietoa(173) =  91
      iatoe( 91) = 173
      ietoa(176) =  48
      iatoe( 48) = 176
      ietoa(177) =  49
      iatoe( 49) = 177
      ietoa(178) =  50
      iatoe( 50) = 178
      ietoa(179) =  51
      iatoe( 51) = 179
      ietoa(180) =  52
      iatoe( 52) = 180
      ietoa(181) =  53
      iatoe( 53) = 181
      ietoa(182) =  54
      iatoe( 54) = 182
      ietoa(183) =  55
      iatoe( 55) = 183
      ietoa(184) =  56
      iatoe( 56) = 184
      ietoa(185) =  57
      iatoe( 57) = 185
      ietoa(189) =  93
      iatoe( 93) = 189
      ietoa(192) = 123
      iatoe(123) = 192
      ietoa(193) =  65
      iatoe( 65) = 193
      ietoa(194) =  66
      iatoe( 66) = 194
      ietoa(195) =  67
      iatoe( 67) = 195
      ietoa(196) =  68
      iatoe( 68) = 196
      ietoa(197) =  69
      iatoe( 69) = 197
      ietoa(198) =  70
      iatoe( 70) = 198
      ietoa(199) =  71
      iatoe( 71) = 199
      ietoa(200) =  72
      iatoe( 72) = 200
      ietoa(201) =  73
      iatoe( 73) = 201
      ietoa(208) = 125
      iatoe(125) = 208
      ietoa(209) =  74
      iatoe( 74) = 209
      ietoa(210) =  75
      iatoe( 75) = 210
      ietoa(211) =  76
      iatoe( 76) = 211
      ietoa(212) =  77
      iatoe( 77) = 212
      ietoa(213) =  78
      iatoe( 78) = 213
      ietoa(214) =  79
      iatoe( 79) = 214
      ietoa(215) =  80
      iatoe( 80) = 215
      ietoa(216) =  81
      iatoe( 81) = 216
      ietoa(217) =  82
      iatoe( 82) = 217
      ietoa(224) =  92
      iatoe( 92) = 224
      ietoa(226) =  83
      iatoe( 83) = 226
      ietoa(227) =  84
      iatoe( 84) = 227
      ietoa(228) =  85
      iatoe( 85) = 228
      ietoa(229) =  86
      iatoe( 86) = 229
      ietoa(230) =  87
      iatoe( 87) = 230
      ietoa(231) =  88
      iatoe( 88) = 231
      ietoa(232) =  89
      iatoe( 89) = 232
      ietoa(233) =  90
      iatoe( 90) = 233
      ietoa(240) =  48
      iatoe( 48) = 240
      ietoa(241) =  49
      iatoe( 49) = 241
      ietoa(242) =  50
      iatoe( 50) = 242
      ietoa(243) =  51
      iatoe( 51) = 243
      ietoa(244) =  52
      iatoe( 52) = 244
      ietoa(245) =  53
      iatoe( 53) = 245
      ietoa(246) =  54
      iatoe( 54) = 246
      ietoa(247) =  55
      iatoe( 55) = 247
      ietoa(248) =  56
      iatoe( 56) = 248
      ietoa(249) =  57
      iatoe( 57) = 249

C  SHOW SOME RESULTS
C  -----------------

      IF(print) THEN
         CALL bvers(cvstr)
#ifdef BIG_ENDIAN
         cndian = '  BIG '
#else
         cndian = 'LITTLE'
#endif
      errstr = '=============== ' //
     . 'WELCOME TO THE BUFR ARCHIVE LIBRARY' // ' =============='
      CALL errwrt(errstr)
      WRITE (  unit=errstr, fmt='(A,I2)' )
     . ' MACHINE CHARACTERISTICS: NUMBER OF BYTES PER WORD =', nbytw
      CALL errwrt(errstr)
      WRITE (  unit=errstr, fmt='(A,I3)' )
     . '                          NUMBER OF BITS PER WORD =', nbitw
      CALL errwrt(errstr)
      errstr = '                          BYTE ORDER IS ' // cndian //
     .  ' ENDIAN'
      CALL errwrt(errstr)
      errstr = '                          ' // clang //
     .  ' IS THE NATIVE LANGUAGE'
      CALL errwrt(errstr)
      errstr = '====================== VERSION: ' // cvstr //
     .  '=========================='
      CALL errwrt(errstr)
      CALL errwrt(' ')
      ENDIF

C  EXITS
C  -----

      RETURN
  900 WRITE(bort_str,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH IS '//
     . 'LIMITED TO 64 BITS (THIS MACHINE APPARENTLY HAS",I4," BIT '//
     . 'WORDS!)")') i
      CALL bort(bort_str)
  901 WRITE(bort_str,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH (",I4,"'//
     . ') IS NOT A MULTIPLE OF 8 (THIS MACHINE HAS WORDS NOT ON WHOLE'//
     . ' BYTE BOUNDARIES!)")') i
      CALL bort(bort_str)
  902 WRITE(bort_str,'("BUFRLIB: WRDLEN - BYTE ORDER CHECKING MISTAKE'//
     . .GT.', LOOP INDEX J (HERE =",I3,") IS  NO. OF BYTES PER WORD '//
     . 'ON THIS MACHINE (",I3,")")') j,nbytw
      CALL bort(bort_str)
  903 WRITE(bort_str,'("BUFRLIB: WRDLEN - CAN''T DETERMINE MACHINE '//
     . 'NATIVE LANGUAGE (CHAR. A UNPACKS TO INT.",I4," NEITHER ASCII '//
     . ' (65) NOR EBCDIC (193)")') ia
      CALL bort(bort_str)
      END