SUBROUTINE WRDLEN
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM: WRDLEN
C PRGMMR: WOOLLEN ORG: NP20 DATE: 1994-01-06
C
C ABSTRACT: THIS SUBROUTINE FIGURES OUT SOME IMPORTANT INFORMATION
C ABOUT THE LOCAL MACHINE ON WHICH THE BUFR ARCHIVE LIBRARY SOFTWARE
C IS BEING RUN AND STORES THIS INTO COMMON BLOCK /HRDWRD/. SUCH
C INFORMATION INCLUDES DETERMINING THE NUMBER OF BITS AND THE NUMBER
C OF BYTES IN A MACHINE WORD AS WELL AS DETERMINING WHETHER THE
C MACHINE USES THE ASCII OR EBCDIC CHARACTER SET.
C
C NOTE: IT IS ONLY NECESSARY FOR THIS SUBROUTINE TO BE CALLED ONCE,
C AND THIS IS NORMALLY DONE DURING THE FIRST CALL TO BUFR ARCHIVE
C LIBRARY SUBROUTINE OPENBF. HOWEVER, THE SUBROUTINE DOES KEEP TRACK
C OF WHETHER IT HAS ALREADY BEEN CALLED; THUS, IF IT IS CALLED AGAIN
C LATER BY A DIFFERENT BUFR ARCHIVE LIBRARY SUBROUTINE, IT WILL JUST
C QUIETLY RETURN WITHOUT (RE)COMPUTING ALL OF THE INFORMATION WITHIN
C COMMON BLOCK /HRDWRD/.
C
C PROGRAM HISTORY LOG:
C 1994-01-06 J. WOOLLEN -- ORIGINAL AUTHOR
C 1998-07-08 J. WOOLLEN -- REPLACED CALL TO CRAY LIBRARY ROUTINE
C "ABORT" WITH CALL TO NEW INTERNAL BUFRLIB
C ROUTINE "BORT"
C 2003-11-04 J. ATOR -- ADDED DOCUMENTATION
C 2003-11-04 S. BENDER -- ADDED REMARKS/BUFRLIB ROUTINE
C 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 OR FOR INFORMATIONAL PURPOSES;
C NBYTW INITIALIZED AS ZERO THE FIRST TIME
C THIS ROUTINE IS CALLED (BEFORE WAS
C UNDEFINED WHEN FIRST REFERENCED)
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
C USAGE: CALL WRDLEN
C
C REMARKS:
C THIS ROUTINE CALLS: BORT BVERS ERRWRT IUPM
C THIS ROUTINE IS CALLED BY: COBFL COPYBF DATEBF DATELEN
C DUMPBF IUPBS01 MESGBC MESGBF
C OPENBF RDMTBB UPDS3
C Normally not called by any application
C programs.
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 77
C MACHINE: PORTABLE TO ALL PLATFORMS
C
C$$$
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
c .... DK: Can the below ever happen since upper loop bounds is 65?
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
WRITE ( UNIT=ERRSTR, FMT='(2A)' )
& '===============
& 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)
WRITE ( UNIT=ERRSTR, FMT='(3A)' )
& ' BYTE ORDER IS ', CNDIAN,
& ' ENDIAN'
CALL ERRWRT(ERRSTR)
WRITE ( UNIT=ERRSTR, FMT='(3A)' )
& ' ', CLANG,
& ' IS THE NATIVE LANGUAGE'
CALL ERRWRT(ERRSTR)
WRITE ( UNIT=ERRSTR, FMT='(3A)' )
& '====================== 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
& , LOOP INDEX J (HERE =",I3,") IS .GT. 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