var/external/bufr/wrdlen.for

   1       SUBROUTINE WRDLEN
   2
   3 C$$$  SUBPROGRAM DOCUMENTATION BLOCK
   4 C
   5 C SUBPROGRAM:    WRDLEN
   6 C   PRGMMR: WOOLLEN          ORG: NP20       DATE: 1994-01-06
   7 C
   8 C ABSTRACT: THIS SUBROUTINE FIGURES OUT SOME IMPORTANT INFORMATION
   9 C   ABOUT THE LOCAL MACHINE ON WHICH THE BUFR ARCHIVE LIBRARY SOFTWARE
  10 C   IS BEING RUN AND STORES THIS INTO COMMON BLOCK /HRDWRD/.  SUCH
  11 C   INFORMATION INCLUDES DETERMINING THE NUMBER OF BITS AND THE NUMBER
  12 C   OF BYTES IN A MACHINE WORD AS WELL AS DETERMINING WHETHER THE
  13 C   MACHINE USES THE ASCII OR EBCDIC CHARACTER SET.
  14 C
  15 C   NOTE: IT IS ONLY NECESSARY FOR THIS SUBROUTINE TO BE CALLED ONCE,
  16 C   AND THIS IS NORMALLY DONE DURING THE FIRST CALL TO BUFR ARCHIVE
  17 C   LIBRARY SUBROUTINE OPENBF.  HOWEVER, THE SUBROUTINE DOES KEEP TRACK
  18 C   OF WHETHER IT HAS ALREADY BEEN CALLED; THUS, IF IT IS CALLED AGAIN
  19 C   LATER BY A DIFFERENT BUFR ARCHIVE LIBRARY SUBROUTINE, IT WILL JUST
  20 C   QUIETLY RETURN WITHOUT (RE)COMPUTING ALL OF THE INFORMATION WITHIN
  21 C   COMMON BLOCK /HRDWRD/.
  22 C
  23 C PROGRAM HISTORY LOG:
  24 C 1994-01-06  J. WOOLLEN -- ORIGINAL AUTHOR
  25 C 1998-07-08  J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
  26 C                           "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
  27 C                           ROUTINE "BORT"
  28 C 2003-11-04  J. ATOR    -- ADDED DOCUMENTATION
  29 C 2003-11-04  S. BENDER  -- ADDED REMARKS/BUFRLIB ROUTINE
  30 C                           INTERDEPENDENCIES
  31 C 2003-11-04  D. KEYSER  -- UNIFIED/PORTABLE FOR WRF; ADDED HISTORY
  32 C                           DOCUMENTATION; OUTPUTS MORE COMPLETE
  33 C                           DIAGNOSTIC INFO WHEN ROUTINE TERMINATES
  34 C                           ABNORMALLY OR FOR INFORMATIONAL PURPOSES;
  35 C                           NBYTW INITIALIZED AS ZERO THE FIRST TIME
  36 C                           THIS ROUTINE IS CALLED (BEFORE WAS
  37 C                           UNDEFINED WHEN FIRST REFERENCED)
  38 C 2004-08-18  J. ATOR    -- ADDED SAVE FOR IFIRST FLAG AND IMMEDIATE
  39 C                           RETURN IF IFIRST=1
  40 C 2007-01-19  J. ATOR    -- BIG-ENDIAN VS. LITTLE-ENDIAN IS NOW
  41 C                           DETERMINED AT COMPILE TIME AND CONFIGURED
  42 C                           WITHIN BUFRLIB VIA CONDITIONAL COMPILATION
  43 C                           DIRECTIVES
  44 C 2009-03-23  J. ATOR    -- CALL BVERS TO GET VERSION NUMBER
  45 C
  46 C USAGE:    CALL WRDLEN
  47 C
  48 C REMARKS:
  49 C    THIS ROUTINE CALLS:        BORT     BVERS    ERRWRT   IUPM
  50 C    THIS ROUTINE IS CALLED BY: COBFL    COPYBF   DATEBF   DATELEN
  51 C                               DUMPBF   IUPBS01  MESGBC   MESGBF
  52 C                               OPENBF   RDMTBB   UPDS3
  53 C                               Normally not called by any application
  54 C                               programs.
  55 C
  56 C ATTRIBUTES:
  57 C   LANGUAGE: FORTRAN 77
  58 C   MACHINE:  PORTABLE TO ALL PLATFORMS
  59 C
  60 C$$$
  61
  62       COMMON /HRDWRD/ NBYTW,NBITW,IORD(8)
  63       COMMON /CHARAC/ IASCII,IATOE(0:255),IETOA(0:255)
  64       COMMON /QUIET / IPRT
  65
  66       CHARACTER*128 BORT_STR,ERRSTR
  67       CHARACTER*8   CINT,DINT,CVSTR
  68       CHARACTER*6   CNDIAN,CLANG
  69       EQUIVALENCE   (CINT,INT)
  70       EQUIVALENCE   (DINT,JNT)
  71       LOGICAL       PRINT
  72
  73       DATA IFIRST/0/
  74
  75       SAVE IFIRST
  76
  77 C-----------------------------------------------------------------------
  78 C-----------------------------------------------------------------------
  79
  80 C     HAS THIS SUBROUTINE ALREADY BEEN CALLED?
  81
  82       IF(IFIRST.EQ.0) THEN
  83
  84 C        NO, SO CHECK WHETHER DIAGNOSTIC INFORMATION SHOULD BE PRINTED
  85 C        AND THEN PROCEED THROUGH THE REST OF THE SUBROUTINE.
  86
  87          PRINT = IPRT.GE.1
  88          IFIRST = 1
  89       ELSE
  90
  91 C        YES, SO THERE IS NO NEED TO PROCEED ANY FURTHER.
  92
  93          RETURN
  94       ENDIF
  95
  96 C  COUNT THE BITS IN A WORD - MAX 64 ALLOWED
  97 C  -----------------------------------------
  98
  99       INT = 1
 100       DO I=1,65
 101       INT = ISHFT(INT,1)
 102       IF(INT.EQ.0) GOTO 10
 103       ENDDO
 104 c  .... DK: Can the below ever happen since upper loop bounds is 65?
 105    10 IF(I.GE.65)       GOTO 900
 106       IF(MOD(I,8).NE.0) GOTO 901
 107
 108 C  NBITW is no. of bits in a word, NBYTW is no. of bytes in a word
 109 C  ---------------------------------------------------------------
 110
 111       NBITW = I
 112       NBYTW = I/8
 113
 114 C  INDEX THE BYTE STORAGE ORDER -  HIGH BYTE TO LOW BYTE
 115 C  -----------------------------------------------------
 116
 117       JNT = 0
 118
 119       DO I = 1,8
 120          IORD(I) = 9999
 121       ENDDO
 122
 123       DO I=1,NBYTW
 124          INT = ISHFT(1,(NBYTW-I)*8)
 125          DO J=1,NBYTW
 126             IF(CINT(J:J).NE.DINT(J:J)) GOTO 20
 127          ENDDO
 128 c  .... DK: Can the below ever happen since upper loop bounds is NBYTW?
 129    20    IF(J.GT.NBYTW) GOTO 902
 130          IORD(I) = J
 131       ENDDO
 132
 133 C  SETUP AN ASCII/EBCDIC TRANSLATOR AND DETERMINE WHICH IS NATIVE
 134 C  --------------------------------------------------------------
 135
 136       IA = IUPM('A',8)
 137       IF(IA.EQ. 65) THEN
 138          IASCII = 1
 139          CLANG  = 'ASCII '
 140       ELSEIF(IA.EQ.193) THEN
 141          IASCII = 0
 142          CLANG  = 'EBCDIC'
 143       ELSE
 144          GOTO 903
 145       ENDIF
 146
 147       DO I=0,255
 148       IETOA(I) = 0
 149       IATOE(I) = 0
 150       ENDDO
 151
 152       IETOA(  1) =   1
 153       IATOE(  1) =   1
 154       IETOA(  2) =   2
 155       IATOE(  2) =   2
 156       IETOA(  3) =   3
 157       IATOE(  3) =   3
 158       IETOA(  5) =   9
 159       IATOE(  9) =   5
 160       IETOA(  7) = 127
 161       IATOE(127) =   7
 162       IETOA( 11) =  11
 163       IATOE( 11) =  11
 164       IETOA( 12) =  12
 165       IATOE( 12) =  12
 166       IETOA( 13) =  13
 167       IATOE( 13) =  13
 168       IETOA( 14) =  14
 169       IATOE( 14) =  14
 170       IETOA( 15) =  15
 171       IATOE( 15) =  15
 172       IETOA( 16) =  16
 173       IATOE( 16) =  16
 174       IETOA( 17) =  17
 175       IATOE( 17) =  17
 176       IETOA( 18) =  18
 177       IATOE( 18) =  18
 178       IETOA( 19) =  19
 179       IATOE( 19) =  19
 180       IETOA( 22) =   8
 181       IATOE(  8) =  22
 182       IETOA( 24) =  24
 183       IATOE( 24) =  24
 184       IETOA( 25) =  25
 185       IATOE( 25) =  25
 186       IETOA( 29) =  29
 187       IATOE( 29) =  29
 188       IETOA( 31) =  31
 189       IATOE( 31) =  31
 190       IETOA( 34) =  28
 191       IATOE( 28) =  34
 192       IETOA( 37) =  10
 193       IATOE( 10) =  37
 194       IETOA( 38) =  23
 195       IATOE( 23) =  38
 196       IETOA( 39) =  27
 197       IATOE( 27) =  39
 198       IETOA( 45) =   5
 199       IATOE(  5) =  45
 200       IETOA( 46) =   6
 201       IATOE(  6) =  46
 202       IETOA( 47) =   7
 203       IATOE(  7) =  47
 204       IETOA( 50) =  22
 205       IATOE( 22) =  50
 206       IETOA( 53) =  30
 207       IATOE( 30) =  53
 208       IETOA( 55) =   4
 209       IATOE(  4) =  55
 210       IETOA( 60) =  20
 211       IATOE( 20) =  60
 212       IETOA( 61) =  21
 213       IATOE( 21) =  61
 214       IETOA( 63) =  26
 215       IATOE( 26) =  63
 216       IETOA( 64) =  32
 217       IATOE( 32) =  64
 218       IETOA( 74) =  91
 219       IATOE( 91) =  74
 220       IETOA( 75) =  46
 221       IATOE( 46) =  75
 222       IETOA( 76) =  60
 223       IATOE( 60) =  76
 224       IETOA( 77) =  40
 225       IATOE( 40) =  77
 226       IETOA( 78) =  43
 227       IATOE( 43) =  78
 228       IETOA( 79) =  33
 229       IATOE( 33) =  79
 230       IETOA( 80) =  38
 231       IATOE( 38) =  80
 232       IETOA( 90) =  93
 233       IATOE( 93) =  90
 234       IETOA( 91) =  36
 235       IATOE( 36) =  91
 236       IETOA( 92) =  42
 237       IATOE( 42) =  92
 238       IETOA( 93) =  41
 239       IATOE( 41) =  93
 240       IETOA( 94) =  59
 241       IATOE( 59) =  94
 242       IETOA( 95) =  94
 243       IATOE( 94) =  95
 244       IETOA( 96) =  45
 245       IATOE( 45) =  96
 246       IETOA( 97) =  47
 247       IATOE( 47) =  97
 248       IETOA(106) = 124
 249       IATOE(124) = 106
 250       IETOA(107) =  44
 251       IATOE( 44) = 107
 252       IETOA(108) =  37
 253       IATOE( 37) = 108
 254       IETOA(109) =  95
 255       IATOE( 95) = 109
 256       IETOA(110) =  62
 257       IATOE( 62) = 110
 258       IETOA(111) =  63
 259       IATOE( 63) = 111
 260       IETOA(121) =  96
 261       IATOE( 96) = 121
 262       IETOA(122) =  58
 263       IATOE( 58) = 122
 264       IETOA(123) =  35
 265       IATOE( 35) = 123
 266       IETOA(124) =  64
 267       IATOE( 64) = 124
 268       IETOA(125) =  39
 269       IATOE( 39) = 125
 270       IETOA(126) =  61
 271       IATOE( 61) = 126
 272       IETOA(127) =  34
 273       IATOE( 34) = 127
 274       IETOA(129) =  97
 275       IATOE( 97) = 129
 276       IETOA(130) =  98
 277       IATOE( 98) = 130
 278       IETOA(131) =  99
 279       IATOE( 99) = 131
 280       IETOA(132) = 100
 281       IATOE(100) = 132
 282       IETOA(133) = 101
 283       IATOE(101) = 133
 284       IETOA(134) = 102
 285       IATOE(102) = 134
 286       IETOA(135) = 103
 287       IATOE(103) = 135
 288       IETOA(136) = 104
 289       IATOE(104) = 136
 290       IETOA(137) = 105
 291       IATOE(105) = 137
 292       IETOA(145) = 106
 293       IATOE(106) = 145
 294       IETOA(146) = 107
 295       IATOE(107) = 146
 296       IETOA(147) = 108
 297       IATOE(108) = 147
 298       IETOA(148) = 109
 299       IATOE(109) = 148
 300       IETOA(149) = 110
 301       IATOE(110) = 149
 302       IETOA(150) = 111
 303       IATOE(111) = 150
 304       IETOA(151) = 112
 305       IATOE(112) = 151
 306       IETOA(152) = 113
 307       IATOE(113) = 152
 308       IETOA(153) = 114
 309       IATOE(114) = 153
 310       IETOA(161) = 126
 311       IATOE(126) = 161
 312       IETOA(162) = 115
 313       IATOE(115) = 162
 314       IETOA(163) = 116
 315       IATOE(116) = 163
 316       IETOA(164) = 117
 317       IATOE(117) = 164
 318       IETOA(165) = 118
 319       IATOE(118) = 165
 320       IETOA(166) = 119
 321       IATOE(119) = 166
 322       IETOA(167) = 120
 323       IATOE(120) = 167
 324       IETOA(168) = 121
 325       IATOE(121) = 168
 326       IETOA(169) = 122
 327       IATOE(122) = 169
 328       IETOA(173) =  91
 329       IATOE( 91) = 173
 330       IETOA(176) =  48
 331       IATOE( 48) = 176
 332       IETOA(177) =  49
 333       IATOE( 49) = 177
 334       IETOA(178) =  50
 335       IATOE( 50) = 178
 336       IETOA(179) =  51
 337       IATOE( 51) = 179
 338       IETOA(180) =  52
 339       IATOE( 52) = 180
 340       IETOA(181) =  53
 341       IATOE( 53) = 181
 342       IETOA(182) =  54
 343       IATOE( 54) = 182
 344       IETOA(183) =  55
 345       IATOE( 55) = 183
 346       IETOA(184) =  56
 347       IATOE( 56) = 184
 348       IETOA(185) =  57
 349       IATOE( 57) = 185
 350       IETOA(189) =  93
 351       IATOE( 93) = 189
 352       IETOA(192) = 123
 353       IATOE(123) = 192
 354       IETOA(193) =  65
 355       IATOE( 65) = 193
 356       IETOA(194) =  66
 357       IATOE( 66) = 194
 358       IETOA(195) =  67
 359       IATOE( 67) = 195
 360       IETOA(196) =  68
 361       IATOE( 68) = 196
 362       IETOA(197) =  69
 363       IATOE( 69) = 197
 364       IETOA(198) =  70
 365       IATOE( 70) = 198
 366       IETOA(199) =  71
 367       IATOE( 71) = 199
 368       IETOA(200) =  72
 369       IATOE( 72) = 200
 370       IETOA(201) =  73
 371       IATOE( 73) = 201
 372       IETOA(208) = 125
 373       IATOE(125) = 208
 374       IETOA(209) =  74
 375       IATOE( 74) = 209
 376       IETOA(210) =  75
 377       IATOE( 75) = 210
 378       IETOA(211) =  76
 379       IATOE( 76) = 211
 380       IETOA(212) =  77
 381       IATOE( 77) = 212
 382       IETOA(213) =  78
 383       IATOE( 78) = 213
 384       IETOA(214) =  79
 385       IATOE( 79) = 214
 386       IETOA(215) =  80
 387       IATOE( 80) = 215
 388       IETOA(216) =  81
 389       IATOE( 81) = 216
 390       IETOA(217) =  82
 391       IATOE( 82) = 217
 392       IETOA(224) =  92
 393       IATOE( 92) = 224
 394       IETOA(226) =  83
 395       IATOE( 83) = 226
 396       IETOA(227) =  84
 397       IATOE( 84) = 227
 398       IETOA(228) =  85
 399       IATOE( 85) = 228
 400       IETOA(229) =  86
 401       IATOE( 86) = 229
 402       IETOA(230) =  87
 403       IATOE( 87) = 230
 404       IETOA(231) =  88
 405       IATOE( 88) = 231
 406       IETOA(232) =  89
 407       IATOE( 89) = 232
 408       IETOA(233) =  90
 409       IATOE( 90) = 233
 410       IETOA(240) =  48
 411       IATOE( 48) = 240
 412       IETOA(241) =  49
 413       IATOE( 49) = 241
 414       IETOA(242) =  50
 415       IATOE( 50) = 242
 416       IETOA(243) =  51
 417       IATOE( 51) = 243
 418       IETOA(244) =  52
 419       IATOE( 52) = 244
 420       IETOA(245) =  53
 421       IATOE( 53) = 245
 422       IETOA(246) =  54
 423       IATOE( 54) = 246
 424       IETOA(247) =  55
 425       IATOE( 55) = 247
 426       IETOA(248) =  56
 427       IATOE( 56) = 248
 428       IETOA(249) =  57
 429       IATOE( 57) = 249
 430
 431 C  SHOW SOME RESULTS
 432 C  -----------------
 433
 434       IF(PRINT) THEN
 435          CALL BVERS(CVSTR)
 436 #ifdef BIG_ENDIAN
 437          CNDIAN = '  BIG '
 438 #else
 439          CNDIAN = 'LITTLE'
 440 #endif
 441       WRITE (  UNIT=ERRSTR, FMT='(2A)' )
 442      & '===============
 443      & WELCOME TO THE BUFR ARCHIVE LIBRARY', ' =============='
 444       CALL ERRWRT(ERRSTR)
 445       WRITE (  UNIT=ERRSTR, FMT='(A,I2)' )
 446      & ' MACHINE CHARACTERISTICS: NUMBER OF BYTES PER WORD =', NBYTW
 447       CALL ERRWRT(ERRSTR)
 448       WRITE (  UNIT=ERRSTR, FMT='(A,I3)' )
 449      & '                          NUMBER OF BITS PER WORD =', NBITW
 450       CALL ERRWRT(ERRSTR)
 451       WRITE (  UNIT=ERRSTR, FMT='(3A)' )
 452      & '                          BYTE ORDER IS ', CNDIAN,
 453      & ' ENDIAN'
 454       CALL ERRWRT(ERRSTR)
 455       WRITE (  UNIT=ERRSTR, FMT='(3A)' )
 456      & '                          ', CLANG,
 457      & ' IS THE NATIVE LANGUAGE'
 458       CALL ERRWRT(ERRSTR)
 459       WRITE (  UNIT=ERRSTR, FMT='(3A)' )
 460      & '====================== VERSION: ', CVSTR,
 461      & '=========================='
 462       CALL ERRWRT(ERRSTR)
 463       CALL ERRWRT(' ')
 464       ENDIF
 465
 466 C  EXITS
 467 C  -----
 468
 469       RETURN
 470   900 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH IS
 471      & LIMITED TO 64 BITS (THIS MACHINE APPARENTLY HAS",I4," BIT
 472      & WORDS!)")') I
 473       CALL BORT(BORT_STR)
 474   901 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - MACHINE WORD LENGTH (",I4,"
 475      & ) IS NOT A MULTIPLE OF 8 (THIS MACHINE HAS WORDS NOT ON WHOLE
 476      &  BYTE BOUNDARIES!)")') I
 477       CALL BORT(BORT_STR)
 478   902 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - BYTE ORDER CHECKING MISTAKE
 479      & , LOOP INDEX J (HERE =",I3,") IS .GT. NO. OF BYTES PER WORD
 480      & ON THIS MACHINE (",I3,")")') J,NBYTW
 481       CALL BORT(BORT_STR)
 482   903 WRITE(BORT_STR,'("BUFRLIB: WRDLEN - CAN''T DETERMINE MACHINE
 483      & NATIVE LANGUAGE (CHAR. A UNPACKS TO INT.",I4," NEITHER ASCII
 484      &  (65) NOR EBCDIC (193)")') IA
 485       CALL BORT(BORT_STR)
 486       END