1 SUBROUTINE INXBIT (KGRIB,KLENG,KNSPT,KPARM,KNUM,KBIT, 2 C KBLEN,HFUNC,KRET) 3C 4C**** INXBIT - Insert/extract bits consecutively in/from a given array 5C 6C Purpose. 7C -------- 8C 9C Take rightmost KBLEN bits from KNUM words of KPARM 10C and insert them consecutively in KGRIB, starting at 11C bit after KNSPT or vice versa. 12C 13C** Interface. 14C ---------- 15C 16C CALL INXBIT (KGRIB,KLENG,KNSPT,KPARM,KNUM,KBIT, 17C C KBLEN,KRET) 18C 19C Integer K. 20C Real P. 21C Logical O. 22C Character H. 23C 24C Input Parameters. 25C ----------------- 26C 27C KGRIB - Array containing bitstream. 28C KLENG - Length (words) of this array. 29C KNSPT - Bit number after which insertion or 30C extraction starts. 31C KPARM - Array from which bits are taken for 32C insertion in the bitstream or to which 33C bits are extracted from the bitstream. 34C KBIT - Number of bits in computer word. 35C KNUM - Number of bit fields inserted/extracted. 36C KBLEN - Number of bits per bit field. 37C HFUNC - Requested function. 38C 'C' to insert bits in bitstream, 39C 'D' to extract bits from bitstream. 40C 41C Output Parameters. 42C ------------------ 43C 44C KNSPT - Bit number of last bit inserted/extracted. 45C 46C KRET - Return code. 47C 0 , No error encountered. 48C 1 , Insertion/extraction exceeded 49C array boundary. 50C 51C Method. 52C ------- 53C 54C Word and offset pointer calculated before calling 55C insertion/extraction routines. 56C 57C Externals. 58C ---------- 59C 60C SBYTES 61C GBYTES 62C GSBITE 63C 64C Reference. 65C ---------- 66C 67C ECLIB documentation on SBYTES and GBYTES. 68C 69C Comments. 70C --------- 71C 72C Cray version of routine. 73C This routine should only be used on the Cray as it 74C contains a call to GSBITE, a vectorising version of 75C GBYTE(S) and SBYTE(S). 76C Routine contains Sections 0 to 3 and Section 9. 77C 78C Author. 79C ------- 80C 81C J. Hennessy ECMWF 18.06.91 82C 83C Modifications. 84C -------------- 85C 86C J. Hennessy ECMWF 08.11.91 87C Parameter KMACH removed from list of input parameters. 88C 89C J. Hennessy ECMWF 12.10.92 90C Dimension of IMASK changed from 64 to 65. 91C 92C ---------------------------------------------------------------- 93C 94C 95C 96C 97C 98C 99C 100C 101C 102C 103C* Section 0 . Definition of variables. Data statements. 104C ---------------------------------------------------------------- 105C 106C* Prefix conventions for variable names. 107C 108C Logical L (but not LP), global or common. 109C O, dummy arguments. 110C G, local variable. 111C LP, parameter. 112C Character C, Global or common. 113C H, dummy arguments. 114C Y (but not YP), local variables. 115C YP, parameter. 116C Integer M and N, global or common. 117C K, dummy arguments. 118C I, local variables. 119C J (but not JP), loop control. 120C JP, parameter. 121C Real A to F and Q to X, global or common. 122C P (but not PP), dummy arguments. 123C Z, local variables. 124C PP, parameter. 125C 126 IMPLICIT NONE 127C 128 INTEGER IMASK 129 INTEGER IND 130 INTEGER INUM 131 INTEGER IOFF 132 INTEGER IPR 133 INTEGER IWORD 134C 135 INTEGER KBIT 136 INTEGER KBLEN 137 INTEGER KGRIB 138 INTEGER KLENG 139 INTEGER KNSPT 140 INTEGER KNUM 141 INTEGER KPARM 142 INTEGER KRET 143C 144 INTEGER J901 145C 146 DIMENSION KGRIB(KLENG) 147 DIMENSION KPARM(*) 148 DIMENSION IMASK(65) 149C 150 CHARACTER*1 HFUNC 151C 152C Values in IMASK are set in the first call to routine GSBITE, and 153C are used in subsequent calls. 154C 155 SAVE IMASK 156C 157C Force routine GSBITE to calculate bit-masks first time through. 158C 159 DATA IMASK(2) /0/ 160C 161C Debug print switch. 162C 163 DATA IPR /0/ 164C 165C ---------------------------------------------------------------- 166C 167C 168C 169C 170C 171C 172C 173C 174C 175C 176C* Section 1 . Set initial values. 177C ---------------------------------------------------------------- 178C 179 100 CONTINUE 180C 181 IF (IPR.EQ.1) 182 C THEN 183 WRITE (*,*) 'INXBIT : Section 1.' 184 WRITE (*,*) ' Input values used -' 185 WRITE (*,9009) KLENG 186 WRITE (*,9002) KNSPT 187 WRITE (*,9004) KBIT 188 WRITE (*,9005) HFUNC 189 ENDIF 190C 191 KRET = 0 192C 193C ---------------------------------------------------------------- 194C 195C 196C 197C 198C 199C 200C 201C 202C 203C 204C* Section 2 . Bit insertion/extraction. 205C ---------------------------------------------------------------- 206C 207 200 CONTINUE 208C 209 IF (IPR.EQ.1) WRITE (*,*) 'INXBIT : Section 2.' 210C 211C* Calculate word pointer and offset. 212C 213 IWORD = KNSPT / KBIT 214 IOFF = KNSPT - IWORD * KBIT 215 IWORD = IWORD + 1 216 IF (IPR.EQ.1) WRITE (*,9003) IWORD , IOFF 217C 218C Insert/extract bits. 219C 220 IF (KNUM.GE.8) 221 C THEN 222C 223C Cray vectorising routine GSBITE performs the same 224C functions as SBYTE(S) and GBYTE(S). 225C 226 CALL GSBITE (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM, 227 C KBIT,IMASK,HFUNC) 228 ELSE 229C 230C Cray scalar faster. 231C 232 IF (HFUNC.EQ.'C') 233 C THEN 234 CALL SBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM) 235 ELSE 236 CALL GBYTES (KGRIB(IWORD),KPARM,IOFF,KBLEN,0,KNUM) 237 ENDIF 238 ENDIF 239C 240C Update pointer. 241C 242 KNSPT = KNSPT + KBLEN * KNUM 243C 244C ---------------------------------------------------------------- 245C 246C 247C 248C 249C 250C 251C 252C 253C 254C 255C* Section 3 . Check out of range. 256C ----------------------------------------------------------------- 257C 258 300 CONTINUE 259C 260 IF (IPR.EQ.1) WRITE (*,*) 'INXBIT : Section 3.' 261C 262 IND = KNSPT / KBIT 263 IF (IND.GT.KLENG) 264 C THEN 265 KRET = 1 266 WRITE (*,9001) IND , KLENG 267 ENDIF 268C 269C ---------------------------------------------------------------- 270C 271C 272C 273C 274C 275C 276C 277C 278C 279C 280C* Section 9 . Return to calling routine. Format statements. 281C ---------------------------------------------------------------- 282C 283 900 CONTINUE 284C 285 IF (IPR.EQ.1) 286 C THEN 287 INUM = KNUM 288 IF (INUM.GT.360) 289 C THEN 290 INUM = 360 291 WRITE (*,9007) INUM 292 ENDIF 293 DO 901 J901=1,INUM 294 IF (HFUNC.EQ.'C') 295 C THEN 296 WRITE (*,9006) KPARM(J901) 297 ELSE 298 WRITE (*,9008) KPARM(J901) 299 ENDIF 300 901 CONTINUE 301 WRITE (*,*) 'INXBIT : Section 9.' 302 WRITE (*,*) ' Output values set -' 303 WRITE (*,9002) KNSPT 304 ENDIF 305C 306C 307 9001 FORMAT (1H ,'INXBIT : Word ',I8,' is outside array bounds ',I8) 308C 309 9002 FORMAT (1H ,' KNSPT = ',I8) 310C 311 9003 FORMAT (1H ,'INXBIT : Word is',I8,', bit offset is ',I2) 312C 313 9004 FORMAT (1H ,' KBIT = ',I8) 314C 315 9005 FORMAT (1H ,' HFUNC = ',A) 316C 317 9006 FORMAT (1H ,' Inserted value = ',I20) 318C 319 9007 FORMAT (1H ,' First ',I9,' values.') 320C 321 9008 FORMAT (1H ,' Extracted value = ',I20) 322C 323 9009 FORMAT (1H ,' KLENG = ',I20) 324C 325 RETURN 326C 327 END 328 SUBROUTINE ABORTX (HNAME) 329C 330C**** ABORTX - Terminates execution of program. 331C 332C Purpose. 333C -------- 334C 335C Terminates execution of program. 336C 337C** Interface. 338C ---------- 339C 340C CALL ABORTX (HNAME) 341C 342C Integer K. 343C Real P. 344C Logical O. 345C Character H. 346C 347C Input Parameters. 348C ----------------- 349C 350C HNAME - Name of calling routine. 351C 352C Output Parameters. 353C ------------------ 354C 355C None. 356C 357C Method. 358C ------- 359C 360C Prints message and terminates. 361C 362C Externals. 363C ---------- 364C 365C ABORT 366C 367C Reference. 368C ---------- 369C 370C None. 371C 372C Comments. 373C --------- 374C 375C Cray version of routine. 376C Routine contains Sections 0 to 1 and Section 9. 377C 378C Author. 379C ------- 380C 381C J. Hennessy ECMWF 13.11.91 382C 383C Modifications. 384C -------------- 385C 386C None. 387C 388C ------------------------------------------------------------------ 389C 390C 391C 392C 393C 394C 395C 396C 397C 398C 399C* Section 0 . Definition of variables. 400C ------------------------------------------------------------------ 401C 402C* Prefix conventions for variable names. 403C 404C Logical L (but not LP), global or common. 405C O, dummy arguments. 406C G, local variable. 407C LP, parameter. 408C Character C, Global or common. 409C H, dummy arguments. 410C Y (but not YP), local variables. 411C YP, parameter. 412C Integer M and N, global or common. 413C K, dummy arguments. 414C I, local variables. 415C J (but not JP), loop control. 416C JP, parameter. 417C Real A to F and Q to X, global or common. 418C P (but not PP), dummy arguments. 419C Z, local variables. 420C PP, parameter. 421C 422 IMPLICIT NONE 423C 424 CHARACTER*(*) HNAME 425C 426C ------------------------------------------------------------------ 427C 428C 429C 430C 431C 432C 433C 434C 435C 436C 437C* Section 1 . Print message and terminate. 438C ------------------------------------------------------------------ 439C 440 100 CONTINUE 441C 442 WRITE (*,9001) HNAME 443C 444 CALL ABORT 445C 446C ------------------------------------------------------------------ 447C 448C 449C 450C 451C 452C 453C 454C 455C 456C* Section 9 . Format statements. 457C ------------------------------------------------------------------ 458C 459 900 CONTINUE 460C 461 9001 FORMAT (1H ,'ABORTX : Routine ',A,' has requested program', 462 C ' termination.') 463C 464 RETURN 465C 466 END 467 SUBROUTINE SETPAR (KBIT,KNEG,KPR) 468C 469C**** SETPAR - Set number of bits in word. Set maximum negative integer. 470C 471C Purpose. 472C -------- 473C 474C Set number of bits in word. Set maximum negative integer. 475C 476C** Interface. 477C ---------- 478C 479C CALL SETPAR (KBIT,KNEG,KPR) 480C 481C Integer K. 482C Real P. 483C Logical O. 484C Character H. 485C 486C Input Parameters. 487C ----------------- 488C 489C KPR - Debug print switch. 490C 1 , print out. 491C 0 , No print out. 492C 493C Output Parameters. 494C ------------------ 495C 496C KBIT - Number of bits in computer word. 497C 498C KNEG - Maximum negative integer. 499C 500C Method. 501C ------- 502C 503C Values are assigned. 504C 505C Externals. 506C ---------- 507C 508C None. 509C 510C Reference. 511C ---------- 512C 513C None. 514C 515C Comments. 516C --------- 517C 518C Cray version of routine. 519C Routine contains Sections 0 to 3 and Section 9. 520C 521C Author. 522C ------- 523C 524C J. Hennessy ECMWF 28.10.91 525C 526C Modifications. 527C -------------- 528C 529C None. 530C 531C ------------------------------------------------------------------ 532C 533C 534C 535C 536C 537C 538C 539C 540C 541C 542C* Section 0 . Definition of variables. Data statements. 543C ------------------------------------------------------------------ 544C 545C* Prefix conventions for variable names. 546C 547C Logical L (but not LP), global or common. 548C O, dummy arguments. 549C G, local variable. 550C LP, parameter. 551C Character C, Global or common. 552C H, dummy arguments. 553C Y (but not YP), local variables. 554C YP, parameter. 555C Integer M and N, global or common. 556C K, dummy arguments. 557C I, local variables. 558C J (but not JP), loop control. 559C JP, parameter. 560C Real A to F and Q to X, global or common. 561C P (but not PP), dummy arguments. 562C Z, local variables. 563C PP, parameter. 564C 565 IMPLICIT NONE 566C 567 INTEGER KBIT 568 INTEGER KNEG 569 INTEGER KPR 570C 571C ------------------------------------------------------------------ 572C 573C 574C 575C 576C 577C 578C 579C 580C 581C 582C* Section 1 . Assign values. 583C ------------------------------------------------------------------ 584C 585 100 CONTINUE 586C 587 IF (KPR.EQ.1) WRITE (*,*) ' SETPAR : Section 1.' 588C 589 KBIT = 64 590 KNEG = -9223372036854775807 591C 592C ------------------------------------------------------------------ 593C 594C 595C 596C 597C 598C 599C 600C 601C 602C* Section 9 . Return to calling routine. Format statements. 603C ------------------------------------------------------------------ 604C 605 900 CONTINUE 606C 607 IF (KPR.EQ.1) 608 C THEN 609 WRITE (*,*) ' SETPAR : Section 9.' 610 WRITE (*,*) ' Output values set -' 611 WRITE (*,9001) KBIT 612 WRITE (*,9002) KNEG 613 ENDIF 614C 615 9001 FORMAT (1H ,' KBIT = ',I3) 616C 617 9002 FORMAT (1H ,' KNEG = ',I22) 618C 619 RETURN 620C 621 END 622 SUBROUTINE GSBITE (KS,KD,KSKST,KSIZE,KSKBTW,K,KBPW,KMASK,HADIR) 623C 624C**** GSBITE - Extraction/insertion of bits from/to bitstream on Cray. 625C 626C Purpose. 627C -------- 628C 629C Vectorising extraction/insertion of bits from/to bitstream. 630C 631C** Interface. 632C ---------- 633C 634C CALL GSBITE (KS,KD,KSKST,KSIZE,KSKBTW,K,KBPW,KMASK,HADIR) 635C 636C Integer K. 637C Real P. 638C Logical O. 639C Character H. 640C 641C Input Parameters. 642C ----------------- 643C 644C KS - If HADIR='D', input bit stream, else output 645C bit stream. 646C KD - If HADIR='D', output words, else input words. 647C KSKST - Number of bits skipped at beginning of KS. 648C KSIZE - Number of bits to be extracted to one word 649C of KD. 650C KSKBTW - Number of bits skipped between two words to 651C be extracted. 652C K - Number of words to be extracted into KD. If 653C less than or equal to 0 only calculate KBPW 654C and KMASK. 655C KBPW - Number of bits per word in KS,calculated if 0. 656C KMASK - Masks for bit patterns, calculated if 657C KMASK(2) is 0. 658C HADIR - Direction of conversion: 'D' for decoding, ie 659C extract words KD(1...K) from bits 660C KS(KSKST+1....) 661C If not 'D', encode, i.e. pack words 662C KD(1....K) into bits 663C KS(KSKST+1.....KSKST+K*(KSIZE+KSKBTW)) 664C 665C Output Parameters. 666C ------------------ 667C 668C KS,KD - See above. 669C KSKST - Updated to number of bits used, i.e. to 670C KSKST+K*(KSIZE+KSKBTW) 671C KBPW - If 0 on input, number of bits in each word 672C of KS. 673C KMASK - If KMASK(2) was 0 on input, bit pattern masks. 674C 675C Method. 676C ------- 677C 678C Vector loop is over repeatedly occurring bit patterns. 679C 680C Externals. 681C ---------- 682C 683C None. 684C 685C Reference. 686C ---------- 687C 688C None. 689C 690C Comments. 691C --------- 692C 693C This routine is for the Cray only. 694C Variable names do not conform to the standard. 695C 696C Author. 697C ------- 698C 699C G.J.Cats 08 Dec 87 700C 701C Modifications. 702C -------------- 703C 704C J. Hennessy ECMWF 09.09.91 705C Introductory comments changed to conform to standard. 706C 707C ------------------------------------------------------------------ 708C 709 DIMENSION KS(*),KD(*),KMASK(*) 710 CHARACTER*1 HADIR 711C 712C STATEMENT FUNCTIONS TO MANIPULATE BITS IN WORDS OF 64 BITS 713C 714C DATA ONES/7777777777777777B/ 715C DATA OOOS/0B/ 716C 717C 1. SINGLE BIT MANIPULATIONS 718C 719C 1.1 SET BIT KBIT IN WORD PW 720C 721 IBSET(KW,KBIT)=OR(KW,SHIFT(1B,KBIT)) 722C 723C 2. WORD MANIPULATIONS, BIT BY BIT 724C 725C 2.1 ARE WORDS PW1 AND PW2 EQUAL? 726C 727C LOGICAL NLEQAL 728C NLEQAL(PW1,PW2)=(PW1.XOR.PW2).EQ.0B 729C 730C 2.2 BITWISE AND AND OR 731C 732 IAND(K1,K2)=AND(K1,K2) 733 IOR (K1,K2)= OR(K1,K2) 734C 735C 2.3 BITWISE NEGATION 736C 737 NOT(K)=COMPL(K) 738C 739C 2.4 SHIFT (LEFT FOR KSH POSITIVE, RIGHT FOR KSH NEGATIVE 740C 741 ISHFT(K,KSH)=CVMGP(SHIFTL(K,KSH),SHIFTR(K,-KSH),KSH) 742C 743C 3. SPECIAL PURPOSE 744C 745C 3.1 TAKE 4 LAST BITS OF KW, PUT THEM IN PW AT POS K*4-1 746C 747C SETLEV(PW,KW,K)=OR(AND(PW,SHIFT(0B.EQV.17B,K*4-4)), 748C +SHIFT(AND(17B,KW),K*4-4)) 749C 750C 3.2 EXTRACT FIELD [K*4-1:4] FROM PW 751C 752C MGTLEV(PW,K)=AND(17B,SHIFT(PW,68-K*4)) 753C 754C 1. COMPLETE KBPW AND KMASK, RETURN IF 0 WORDS ARE TO BE EXTRACTED 755C 756 IF(KBPW.EQ.0)THEN 757 IS=KS(1) 758 KS(1)=1 759 1101 CONTINUE 760 IF(KS(1).NE.0)THEN 761 KBPW=KBPW+1 762 KS(1)=ISHFT(KS(1),1) 763 GOTO 1101 764 ENDIF 765 KS(1)=IS 766 ENDIF 767 IF(KMASK(2).EQ.0)THEN 768 KMASK(KBPW+1)=0 769 DO 1110 J=KBPW,1,-1 770 KMASK(J)=IBSET(KMASK(J+1),KBPW-J) 771 1110 CONTINUE 772 ENDIF 773 IF(K.LE.0)RETURN 774C 775C 2. PRESET KD TO 0 IF KD IS OUTPUT I.E. WHEN DECODING 776C 777 IF(HADIR.EQ.'D')THEN 778 DO 2101 J=1,K 779 KD(J)=0 780 2101 CONTINUE 781 ENDIF 782C 783C 3. CALCULATE SEVERAL PARAMETERS FOR LOOPING (FOR EFFICIENCY, THE 784C CODE OF SECTIONS 3.3 AND 3.4 FOR K=1 IS SEPARATED INTO 3.2) 785C 786C 3.1 NUMBER OF BITS USED PER WORD, INITIAL NR OF SKIPPED BITS 787C 788 ISTEP=KSIZE+KSKBTW 789 ISKWS=KSKST 790C 791C 3.2 VECTOR LOOP LENGTH AND STEP SIZE IN KD IF K=1;KS STEP IRRELVNT 792C 793 IF(K.EQ.1)THEN 794 ILL=1 795 IBDL=2 796 ISTD=1 797 ELSE 798C 799C 3.3 STEP SIZES IN KS,KD: INVERSE OF LARGEST FACTOR OF ISTEP,KBPW 800C 801 ILCF=KBPW 802 ISHF=ISTEP 803 331 CONTINUE 804 IF(ILCF.EQ.ISHF)GOTO 332 805 IF(ILCF.EQ.1)GOTO 332 806 IF(ILCF.GT.ISHF)THEN 807 ILCF=ILCF-ISHF 808 ELSE 809 ISHF=ISHF-ILCF 810 ENDIF 811 GOTO 331 812 332 CONTINUE 813 ISTD=KBPW/ILCF 814 ISTS=ISTEP/ILCF 815C 816C 3.4 VECTOR LOOP LENGTH AND SWITCH-OVER POINT FOR SMALLER LOOP 817C 818 ILL=(K-1)/ISTD+1 819 IBDL=K-(ILL-1)*ISTD 820 ENDIF 821C 822C 4. LOOP OVER FIRST ISTD WORDS OF KD (TRAILS THE VECTOR LOOP) 823C 824 DO 790 JBD=1,ISTD 825C 826C 4.1 LAST BIT IN KS TO BE TREATED 827C 828 IENBS=ISKWS+KSIZE 829C 830C 4.2 NR OF WORDS OF KS TO BE SKIPPED, NR OF BITS IN THOSE AND THIS 831C 832 ISKW=ISKWS/KBPW 833 ISTA=ISKW*KBPW 834 ISKB=ISKWS-ISTA 835C 836C 4.3 MASK AND LEFT SHIFT FOR THE REMAINING BITS 837C 838 IMASK=KMASK(ISKB+1) 839 ISH=KSIZE+ISKB 840C 841C 4.4 POSITION OF CURRENT WORD OF KS 842C 843 IBS=ISKW+1 844C 845C 5. LOOP OVER WORDS OF KS CONTRIBUTING TO ONE WORD OF KD 846C 847 500 CONTINUE 848C 849C 5.1 UPDATE SHIFT AND LAST BIT IN CURRENT WORD 850C 851 ISH=ISH-KBPW 852 IEND=ISTA+KBPW 853C 854C 5.2 IS LAST BIT OF CURRENT WORD OUTSIDE RANGE TO BE EXTRACTED 855C 856 IF(IEND.GT.IENBS)THEN 857 ISH=IENBS-IEND 858 IMASK=IAND(IMASK,NOT(KMASK(KBPW+ISH+1))) 859 ENDIF 860C 861C 5.3 INITIAL OFFSETS FOR VECTOR ELEMENTS IN VECTOR LOOP 862C 863 IOS=0 864 IOD=0 865C 866C 6. VECTOR LOOP IS OVER REPEATEDLY OCCURRING BITPATTERNS/MASKS 867C 868 IF(HADIR.EQ.'D')THEN 869CDIR$ IVDEP 870 DO 611 JI=1,ILL 871 KD(JBD+IOD)=IOR(KD(JBD+IOD),ISHFT(IAND(IMASK,KS(IBS+IOS)),ISH)) 872 IOD=IOD+ISTD 873 IOS=IOS+ISTS 874 611 CONTINUE 875 ELSE 876CDIR$ IVDEP 877 DO 612 JI=1,ILL 878 KS(IBS+IOS)=IOR( 879 + IAND( KS(IBS+IOS), NOT(IMASK)), 880 + IAND(ISHFT(KD(JBD+IOD),-ISH), IMASK )) 881 IOD=IOD+ISTD 882 IOS=IOS+ISTS 883 612 CONTINUE 884 ENDIF 885C 886C 7. END LOOPS 887C 888C 7.1 PREPARE FOR END OF LOOP OVER WORDS OF KS WITIHN ONE KD WORD 889C 890 ISTA=ISTA+KBPW 891C 892C 7.2 NEXT WORD OF KD IF EXTRACTION NOT COMPLETED 893C 894 IF(ISTA.LT.IENBS)THEN 895 IMASK=KMASK(1) 896 IBS=IBS+1 897 GOTO 500 898 ENDIF 899C 900C 7.8 PREPARE FOR END OF LOOP OVER FIRST WORDS OF KD 901C 902 IF(JBD.EQ.IBDL)ILL=ILL-1 903 ISKWS=ISKWS+ISTEP 904C 905C 7.9 END LOOP OVER FIRST WORDS OF KD 906C 907 790 CONTINUE 908C 909C 8. FINISHED: UPDATE KSKST AND RETURN 910C 911 KSKST=KSKST+K*ISTEP 912C 913 RETURN 914 END 915 SUBROUTINE GBYTE (SOURCE,DEST,IOFSET,IBYTSZ) 916C 917C**** GBYTE - Extract a single bit field. Cray routine. 918C 919C* FUNCTION: GET A SINGLE BIT FIELD FROM SOURCE INTO DEST 920C* 921C* INPUT : SOURCE(1)= WORD CONTAINING START OF BIT FIELD 922C* DEST = TARGET WORD 923C* IOFSET = OFFSET IN BITS FOR START OF THE FIELD 924C* IBYTSZ = LENGTH OF FIELD IN BITS 925C* 926C* OUTPUT : SOURCE,IOFSET,IBYTSZ UNCHANGED 927C* DEST CONTAINS FIELD RIGHT JUSTIFIED 928C* 929C* AUTHOR : M.MIQUEU 08/1981 (REWRITTEN FROM J.MARTELLET'S) 930C* 931 PARAMETER(NBPW=64) 932 INTEGER SOURCE(1),DEST 933 INTEGER SH1 934 SH1=IOFSET+IBYTSZ-NBPW 935 936 IF(SH1.GT.0) GO TO 2 937 938 939C BYTES DO NOT SPAN WORDS 940 941 942 SH1=NBPW+SH1 943 944 945 DEST=AND( 946 1 SHIFT(SOURCE(1),SH1), 947 2 SHIFT(MASK(IBYTSZ),IBYTSZ) 948 3 ) 949 950 RETURN 951 952C BYTE SPANS WORDS 953 9542 CONTINUE 955 956 957 DEST=OR( 958 1 SHIFT( 959 2 AND(SOURCE(1),COMPL(MASK(IOFSET))) 960 3 ,SH1), 961 4 SHIFT( 962 5 AND(SOURCE(2),MASK(SH1)) 963 6 ,SH1) 964 7 ) 965 966 967 968 RETURN 969 END 970 SUBROUTINE GBYTES (S,D,ISKIP1,IBSIZ,ISKIP2,NBYTES,KWOFF) 971C 972C**** GBYTES - Extract a number of bit fields. Cray routine. 973C 974C S CONTAINS A BIT STRING OF INDEFINITE LENGTH. GBYTES WILL 975C EXTRACT NBYTES BITSTRINGS, IBSIZ BITS LONG, AND STORE THEM 976C RIGHT JUSTIFIED 0 FILL, INTO SUCCESSIVE WORDS OF D. THE 977C SUCCESSIVE BITSTRINGS START AT BIT POSITIONS 978C ISKIP1+1+(IBYTE-1)*(IBSIZ+ISKIP2) 979C IN THE BIT STRING S. I.E. SKIP ISKIP1 BITS AT THE START, 980C AND ISKIP2 BITS BETWEEN THE EXTRACTED STRINGS. 981C BIT ISKP+1 IN A STRING IS FOUND IN WORD IS=1+ISKIP/NBPW IN S, 982C WHERE NBPW IS THE NUMBER OF BITS PER WORD. THE STARTING BIT 983C IS FOUND BY SKIPPING MOD(ISKP,NBPW) BITS IN THAT WORD. 984C KWOFF IS AN OPTIONAL 7TH PARAMETER, WHICH DEFAULTS TO 0 985C IF PRESENT KWOFF BITS ARE TOTALLY IGNORED AT THE START OF A WORD 986C THUS IF A PACKED CYBER BIT STRING IS TRANSFERRED TO THE 987C CRAY, WITH EACH 60 BIT CYBER WORD PLACED AT THE RIGHT END OF 988C A 64 BIT CRAY WORD, A BYTE SEQUENCE WHICH WAS ORIGINALLY 989C LOCATED WITH START POINTS IN ARITHMETIC PROGRESSION ON THE 990C CYBER, WILL NO LONGER HAVE THIS PROPERTY ON THE CRAY. BY 991C USING THE ROUTINE WITH KWOFF=4, THE ELEMENTS OF THE BYTE 992C SEQUENCE CAN BE EXTRACTED ON THE CRAY, USING THE SAME SKIPS 993C AS WERE USED ON THE CYBER. 994C 995 PARAMETER(NBPW=64) 996 DIMENSION S(2) , D(NBYTES) 997 INTEGER SH1 998 IGNORE = 0 999 IF(NUMARG().GT.6) IGNORE = KWOFF 1000 IS=1+ISKIP1/(NBPW-IGNORE) 1001 ISKIP = MOD(ISKIP1,NBPW-IGNORE) + IGNORE 1002 ISTEP = ISKIP2+IBSIZ 1003 DO 75 IBYTE = 1 , NBYTES 1004C WITH THE STARTING WORD AND BIT POSITION DETERMINED, THE 1005C DESIRED EXTRACTION CAN BE DONE BY 1006C*** CALL GBYTE(S(IS),D(IBYTE),ISKIP,IBSIZ) 1007C BUT SINCE THE CODE IS SHORT IT IS INSERTED IN-LINE. 1008 SH1 = ISKIP+IBSIZ 1009 IF(SH1.GT.NBPW) GO TO 50 1010C BYTE COMES FROM 1 WORD OF S 1011 D(IBYTE) = AND( SHIFT(S(IS),SH1),SHIFT(MASK(IBSIZ),IBSIZ)) 1012 GO TO 65 1013 50 CONTINUE 1014 SH1 =SH1-NBPW 1015C BYTE COMES FROM 2 WORDS OF S. 1016 D(IBYTE) = OR(SHIFT(AND(S(IS),COMPL(MASK(ISKIP))),SH1) 1017 1 , 1018 2 SHIFT(AND(SHIFT(S(IS+1),IGNORE),MASK(SH1)),SH1) 1019 3 ) 1020 65 CONTINUE 1021C UPDATE STARTING WORD AND BIT POSITION 1022 ISKIP = ISKIP+ISTEP 1023 IF(ISKIP.LT.NBPW) GO TO 75 1024 ISKIP =ISKIP-NBPW 1025 IS = IS+1+ISKIP/(NBPW-IGNORE) 1026 ISKIP = MOD(ISKIP,NBPW-IGNORE) + IGNORE 1027 75 CONTINUE 1028 RETURN 1029 END 1030 SUBROUTINE SBYTE (DEST,SOURCE,IOFSET,IBYTSZ) 1031C 1032C**** SBYTE - Insert a single bit field. Cray routine. 1033C 1034C* FUNCTION: STORE A SINGLE BIT FIELD FROM SOURCE INTO DEST 1035C* 1036C* INPUT : SOURCE = WORD CONTAINING BIT FIELD RIGHT JUSTIFIED 1037C* DEST(1) = 1ST TARGET WORD 1038C* IOFSET = OFFSET IN BITS FOR START OF THE FIELD 1039C* IBYTSZ = LENGTH OF FIELD IN BITS ; .LE.WORD SIZE ..... 1040C* 1041C* OUTPUT : SOURCE,IOFSET,IBYTSZ UNCHANGED 1042C* DEST(1) AND EVENTUALLY DEST(2) CONTAIN FIELD 1043C* 1044C* AUTHOR : M.MIQUEU 08/1981 (REWRITTEN FROM J.MARTELLET'S) 1045C* 1046 PARAMETER(NBPW=64) 1047 INTEGER SOURCE,DEST(1) 1048 INTEGER SH1,SH2,SH3 1049 SH1=IOFSET+IBYTSZ 1050 IF(SH1.GT.NBPW) GO TO 2 1051 1052 SH2=NBPW-SH1 1053 IF(SH2.LT.0) SH2=NBPW-SH2 1054 1055C BYTE DOES NOT SPAN WORDS 1056 1057 1058 DEST(1)=SHIFT( 1059 1 OR( 1060 2 AND(SHIFT(DEST(1),SH1), 1061 3 SHIFT(COMPL(MASK(IBYTSZ)),IBYTSZ) ) 1062 4 , 1063 5 AND(SOURCE, 1064 6 COMPL(SHIFT(COMPL(MASK(IBYTSZ)),IBYTSZ)) ) 1065 7 ) 1066 8 ,SH2) 1067 1068 1069 1070 RETURN 1071 10722 CONTINUE 1073 1074C BYTE SPANS 2 WORDS 1075 1076 SH3=2*NBPW-SH1 1077 1078 1079 DEST(1)=OR( 1080 1 AND(DEST(1),MASK(IOFSET)) 1081 2 , 1082 3 AND(SHIFT(SOURCE,SH3) , COMPL(MASK(IOFSET)) ) 1083 4 ) 1084 1085 DEST(2)=OR( 1086 1 AND(DEST(2) , COMPL(MASK(SH1-NBPW)) ) 1087 2 , 1088 3 SHIFT( AND(SOURCE , COMPL(MASK(SH3)) ) ,SH3) 1089 4 ) 1090 1091 1092 1093 RETURN 1094 END 1095 SUBROUTINE SBYTES (D,S,ISKIP1,IBSIZ,ISKIP2,NBYTES,KWOFF) 1096C 1097C**** SBYTES - Insert a number of bit fields. Cray routine. 1098C 1099C REVERSES THE ACTION OF GBYTES, TAKING FIELDS FROM S AND 1100C INSERTING THEM INTO A BIT STRING IN D. SEE GBYTES. 1101C AUTHOR D. ROBERTSON AUG,1981 1102C 1103 PARAMETER(NBPW=64) 1104 DIMENSION D(2) , S(NBYTES) 1105 INTEGER SH1,SH2,SH3 1106 IGNORE = 0 1107 IF(NUMARG().GT.6) IGNORE = KWOFF 1108 ID=1+ISKIP1/(NBPW-IGNORE) 1109 ISKIP = MOD(ISKIP1,NBPW-IGNORE) + IGNORE 1110 ISTEP = ISKIP2+IBSIZ 1111 DO 75 IBYTE = 1 , NBYTES 1112C WITH THE STARTING WORD AND BIT POSITION KNOWN, THE 1113C DESIRED INSERTION CAN BE DONE BY 1114C** CALL SBYTE(D(ID),S(IBYTE),ISKIP,IBSIZ) 1115C BUT THE CODE IS SHORT ENOUGH TO GO IN-LINE. 1116 SH1 = ISKIP+IBSIZ 1117 IF(SH1.GT.NBPW) GO TO 50 1118 SH2 = NBPW-SH1 1119 IF(SH2.LT.0) SH2 = NBPW-SH2 1120C BYTE GOES INTO 1 WORD OF D. 1121 D(ID) = SHIFT(OR(AND(SHIFT(D(ID),SH1),MASK(NBPW-IBSIZ)), 1122 1 AND(S(IBYTE),SHIFT(MASK(IBSIZ),IBSIZ))),SH2) 1123 GO TO 65 1124 50 CONTINUE 1125C BYTE GOES INTO 2 WORDS OF D. 1126 SH3 = 2*NBPW-SH1 1127 D(ID)=OR(AND(D(ID),MASK(ISKIP)), 1128 1 AND(SHIFT(S(IBYTE),SH3),COMPL(MASK(ISKIP)))) 1129 D(ID+1)=OR(AND(D(ID+1),SHIFT(COMPL(MASK(SH1-NBPW)),NBPW-IGNORE) 1130 1 ), 1131 2 SHIFT(AND(S(IBYTE),COMPL(MASK(SH3))),SH3-IGNORE)) 1132 65 CONTINUE 1133C UPDATE STARTING WORD AND BIT POSITION 1134 ISKIP = ISKIP+ISTEP 1135 IF(ISKIP.LT.NBPW) GO TO 75 1136 ISKIP = ISKIP - NBPW 1137 ID = ID+1+ISKIP/(NBPW-IGNORE) 1138 ISKIP = MOD(ISKIP,NBPW-IGNORE) + IGNORE 1139 75 CONTINUE 1140 RETURN 1141 END 1142