c---------------------------------------------------------------------------- c VALUE: .WORD 0,8,4,12,2,10,6,14,1,9,5,13,3,11,7,15 c C .ENTRY DECEBS ^M ; my comments below (EEE) C MOVZWL @B^4(AP),R0 ; put first input (IVAL) in r0 C ASHL I^#-4,R0,R1 ; r1 holds input shifted 4 bit to right C ASHL I^#-4,R1,R2 ; r2 holds input shifted 8 bits right C MOVW W^VALUE[R2],R2 ; r2 holds the value of VALUE array c ; pointed to by R2 (1st index is 0) C BICB2 I^#^XF0,R1 ; r1 holds itself w/ bits 4-7 set to 0 C BICW2 I^#^XFF0,R0 ; r0 holds itself w/ bits 4-11 set to 0 C BEQL 10$ ; if r0 EQ 0 then jump to $10 C INCL R2 ; if r0 NE 0 then increment by 1 C10$: ASHL S^#8,R2,R2 ; r2 holds r2 shifted 8 bits to left C ADDW3 R2,W^VALUE[R1],@B^4(AP) ; returns 1st arg (IVAL) C ADDW3 S^#1,W^VALUE[R0],@B^8(AP) ; returns 2nd arg (IBAND) C RET subroutine DECEBS(IVAL,IBAND) implicit integer*2 (I-N) integer*2 VALUE(16) /0,8,4,12,2,10,6,14,1,9,5,13,3,11,7,15/ C WRITE (*,*) '-IN DECEBS' ireg0 = ival ireg1 = ishft(ival, -4) ireg2 = ishft(ireg1, -4) ireg2 = value(ireg2+1) ireg1 = iand(ireg1, 'FF0F'x) ! compliment 'f0'x ireg0 = iand(ireg0, 'F00F'x) ! compliment 'ff0'x if (ireg0 .ne. 0) ireg2 = ireg2 + 1 ireg2 = ishft(ireg2, 8) ival = ireg2 + value(ireg1+1) iband = value(ireg0+1) + 1 C WRITE (*,*) '-OUT DECEBS' return end c---------------------------------------------------------------------------- C .ENTRY ISDBTW ^M<> ! my comments below (EEE) c MOVZBL @B^4(AP),R0 ! r0 holds input c ASHL I^#-5,R0,R1 ! r1 holds input shifted to right 5 bits c BICB2 I^#^XE0,R0 ! r0 holds itself w/ bits 5-7 set to 0 c SUBL3 R1,S^#6,R1 ! r1 holds r1 minus 6 c BLSS 10$ ! if r1 lt 0 then goto 10$ c BISB2 S^#^X20,R0 ! r0 hole the OR of '20'x and r0 c ASHL R1,R0,R0 ! r0 hold R0 shifted left by the c ! result of the above subtraction (r1) c10$: RET integer*2 function ISDBTW(ICNT) implicit integer*2 (I-N) C WRITE (*,*) '---IN ISDBTW ' ireg1 = ishft(icnt, -5) isdbtw = iand(icnt, 'FF1F'x) ! compliment 'e0'x ireg1 = 6 - ireg1 if (ireg1 .ge. 0) then isdbtw = ior(isdbtw, '20'x) isdbtw = ishft(isdbtw, ireg1) endif C WRITE (*,*) '---OUT ISDBTW ' return end c---------------------------------------------------------------------------- subroutine DECIMH() C**** C Decompression routine for the image header C Input: integer*2 array INB C Ouput: IOUT(19:31) and, if flare mode 0, EBS words IOUT(72:77) C Calls: IPEELB, DECEBS, ISWAP (assembler code in HXIMASS.MAR) C**** implicit integer*2 (I-N) integer*2 IOUT(3840),INB(2108) common /PEELB/ IB,IS,IP common /IMAGE/ IOUT,INB equivalence (XI,IOUT(19)) IB = 3 IS = 0 c if (INB(1) .eq. "162556) then if (INB(1) .eq. '162556'o) then IB = 4 IS = 4 end if IP = 12 XI = 4096.*IPEELB(INB)+IPEELB(INB) ! IMAGE INDEX IP = 5 IOUT(21) = IPEELB(INB) ! VERSION # c if (IOUT(21) .eq. "17) return if (IOUT(21) .eq. '17'o) return IP = 7 IOUT(22) = IPEELB(INB) ! DURATION do I=23,24 IP = 10 IOUT(I) = IPEELB(INB) ! HV1-HV2 IP = 2 call IPEELB(INB) ! SKIP 2 BITS end do IP = 1 do I=25,29 IOUT(I) = IPEELB(INB) ! STATUS BITS end do IP = 4 call IPEELB(INB) ! SKIP 4 BITS IP = 3 IOUT(30) = IPEELB(INB) ! FLARE-MODE IOUT(31) = -1 ! COARSE+FINE+SLITS-COUNT if (IOUT(30) .ne. 0) return IP = 12 ! EBS-WORDS do I=1,6 IVAL = IPEELB(INB) call DECEBS(IVAL,IBAND) if (IBAND .ge. 1 .or. IBAND .le. 6) IOUT(IBAND+71) = ISWAP(IVAL) end do return end C***** subroutine DECIM0() C ***** C Decompression routine for flare mode 0 C Input: integer*2 array INB C Output: IOUT(92), IOUT(193:3678+IOUT(22)) C Calls: IPEELB, ISDBTW (assembler code in HAXIMASS.MAR) C ***** implicit integer*2 (I-N) integer*2 IOUT(3840),INB(2108) real*4 ANE(7) common /IMAGE/ IOUT,INB common /TABARRAY/ ITAB common /PEELB/ IB,IS,IP equivalence (ANE,IOUT(3649)) integer*2 ITAB(576) ! Regulates relocation form RAM adress to image pixel number ? & /0,8,9,1,2,10,11,3,4,12,13,5,6,14,15,7,112,120,121,113,114,122,123,115,116,124,125,117,118,126,127, & 119,17,16,28,29,41,40,52,53,54,55,43,42,30,31,19,18,65,64,76,77,89,88,100,101,102,103,91,90,78,79,67, & 66,25,24,36,37,49,48,60,61,62,63,51,50,38,39,27,26,73,72,84,85,97,96,108,109,110,111,99,98,86,87,75, & 74,21,20,32,33,45,44,56,57,58,59,47,46,34,35,23,22,69,68,80,81,93,92,104,105,106,107,95,94,82,83,71, & 70,247,246,266,267,287,286,306,307,308,309,289,288,268,269,249,248,251,250,270,271,291,290,310,311, & 312,313,293,292,272,273,253,252,173,172,188,189,207,206,226,227,228,229,209,208,190,191,175,174,177, & 176,192,193,211,210,230,231,232,233,213,212,194,195,179,178,327,326,346,347,365,364,380,381,382,383, & 367,366,348,349,329,328,331,330,350,351,369,368,384,385,386,387,371,370,352,353,333,332,243,242,262, & 263,283,282,302,303,304,305,285,284,264,265,245,244,255,254,274,275,295,294,314,315,316,317,297,296, & 276,277,257,256,169,168,184,185,203,202,222,223,224,225,205,204,186,187,171,170,181,180,196,197,215, & 214,234,235,236,237,217,216,198,199,183,182,323,322,342,343,361,360,376,377,378,379,363,362,344,345, & 325,324,335,334,354,355,373,372,388,389,390,391,375,374,356,357,337,336,129,128,136,137,147,146,158, & 159,160,161,149,148,138,139,131,130,133,132,140,141,151,150,162,163,164,165,153,152,142,143,135,134, & 395,394,406,407,417,416,424,425,426,427,419,418,408,409,397,396,399,398,410,411,421,420,428,429,430, & 431,423,422,412,413,401,400,201,200,220,221,241,240,260,261,281,280,300,301,321,320,340,341,219,218, & 238,239,259,258,278,279,299,298,318,319,339,338,358,359,145,144,156,157,393,392,404,405,155,154,166, & 167,403,402,414,415,508,509,510,511,468,469,470,471,472,473,474,475,432,433,434,435,452,453,454,455, & 456,457,458,459,460,461,462,463,464,465,466,467,488,489,490,491,484,485,486,487,480,481,482,483,476, & 477,478,479,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,448,449,450,451,444,445, & 446,447,440,441,442,443,436,437,438,439,528,529,530,531,532,533,534,535,512,513,514,515,516,517,518, & 519,536,537,538,539,540,541,542,543,520,521,522,523,524,525,526,527,548,549,550,551,544,545,546,547, & 560,561,562,563,564,565,566,567,552,553,554,555,556,557,558,559,568,569,570,571,572,573,574,575/ IP = 12 c IOUT(92) = IPEELB(INB)-"6477 IOUT(92) = IPEELB(INB)-'6477'o IP = 8 do I=1,6 ! each of 6 bands K = 193+(I-1)*576 do J=1,576 ! counts in each of the bands IOUT(K+ITAB(J)) = ISDBTW(IPEELB(INB)) end do if (I .eq. 1) then c IB = IB+"300 IB = IB+'300'o else if (I .eq. 2) then c IB = IB+"20 IB = IB+'20'o do J=1,7 ! IOUT(3649:3662) ANE(J) = ISDBTW(IPEELB(INB))*4096.+ISDBTW(IPEELB(INB)) end do do J=3663,3678 IOUT(J) = ISDBTW(IPEELB(INB)) end do c IB = IB+"22 IB = IB+'22'o else if (I .eq. 3 .or. I .eq. 5) then c IB = IB+"100 IB = IB+'100'o else if (I .eq. 4) then IBB = IB ! Store current IB, IS temporarily ISS = IS do J=1,IOUT(22) IOUT(3678+J) = ISDBTW(IPEELB(INB)) end do c IB = IBB+"300 ! "300=64 : min. time resolution 64*0.125 s ?? IB = IBB+'300'o ! "300=64 : min. time resolution 64*0.125 s ?? IS = ISS end if end do return end C *** subroutine DECIM1() C ***** C Decompression routine for flare modes 1 and 2 C Input: integer*2 array INB C integer*2 INAD (number of relevant bytes in INAD) C Output: ? C Calls: IPEELB, ISDBTW (assembler code in HAXIMASS.MAR) C SUBGRP subgroup decompression subroutine (code appended) C ***** implicit integer*2 (I-N) integer*2 IOUT(3840),INB(2108),IOV(64),INDA(4)/1,5,2,6/,ITAB(576) c integer*2 JOFI(6)/"0,"1400,"2600,"4000,"5400,"6600/ ,JGR(5)/"1077,"2477,"3677,"5077,"6477/ integer*2 JOFI(6)/'0'o,'1400'o,'2600'o,'4000'o,'5400'o,'6600'o/ ,JGR(5)/'1077'o,'2477'o,'3677'o,'5077'o,'6477'o/ real*4 ANE(7) common /IMAGE/ IOUT,INB,INAD common /PEELB/ IB,IS,IP common /TABARRAY/ ITAB equivalence (ANE,IOUT(3649)),(IOV,IOUT(93)),(NO,IOUT(92)) C*** HEM + DFM: FLM=1 : BAND 2 & 6; FLM=2 : BAND 1 & 5 + 2 & 6 C INPUT-RANGE R512 -> R543 do I=193,3806 IOUT(I) = -1 end do IHEM = 2*IOUT(30) IP = 8 do I=1,IHEM if (IHEM .eq. 4) then ! Flare mode 2: bands 1 & 5 + 2 & 6 IM = INDA(I) else ! Flare mode 1: band 2 & 6 IM = 2 if (I .eq. 2) IM = 6 end if K = 193+(IM-1)*576 do J=512,543 IOUT(K+ITAB(J+1)) = ISDBTW(IPEELB(INB)) end do call IPEELB(INB) end do IP = 10 ! *** COURSE+FINE+SLIT-COUNTER (IOUT(31)) ICFS = 4*IPEELB(INB) IP = 2 IOUT(31) = ICFS+4096*IPEELB(INB) IP = 8 ! *** RATES (IOUT(3649)-(3678)) do I=1,7 ! IOUT(3649:3662) ANE(I) = ISDBTW(IPEELB(INB))*4096.+ISDBTW(IPEELB(INB)) end do do I=3663,3678 IOUT(I) = ISDBTW(IPEELB(INB)) end do do I=1,IOUT(22) ! *** DATA-TRANSFER-PULSES (IOUT(3679)-(3806)) IOUT(3678+I) = ISDBTW(IPEELB(INB)) end do NBITS = IOUT(22)*8 IP = 24-mod(NBITS,24) if (IP .ne. 24) call IPEELB(INB) ! SKIP REST MOD 12 BITS IP = 12 ! *** OVERFLOW'S c NO = IPEELB(INB)-"6477 NO = IPEELB(INB)-'6477'o NO = min(NO,64) do I=1,NO IOV(I) = IPEELB(INB) end do NO1 = 0 ! *** SUBGROUPS WITH OVERFLOW IN IMAGE 1 do I=1,NO if (NO1 .ne. 0 .and. IOV(I) .gt. 576) then IB = IB+21 else if (NO1 .ne. 0) then J = 1 do while (IOV(J) .ne. IOV(I)) J = J+1 end do if (J .eq. I) then call SUBGRP(IMAX,NF) NO1 = NO1+1 else IB = IB+21 end if else if (IOV(I) .le. 576) then call SUBGRP(IMAX,NF) NO1 = NO1+1 end if end do IP = 8 ! *** SLIT-DATA do I=1,6 c ISL = "660 ! "660=432 ISL = '660'o ! "660=432 K = 193+(I-1)*576 do J=1,20 IOUT(K+ITAB(ISL+1)) = ISDBTW(IPEELB(INB)) ISL = ISL+4 end do end do NF = 0 !*** COARSE + FINE SUBGROUPS IMAX = ((INAD-IB)*8-IS-24)/6 do while (IMAX .gt. 0 .and. NF .lt. 76) call SUBGRP(IMAX,NF) end do do I=1,NO ! *** INSERT OVERFLOW'S C********************************************************* C** CONVERT "4K-RAM ADDR." INTO A "RELOCATION ADDR." C********************************************************* C INPUT : IOV(I): 4K-RAM ADDR. (RANGE 0-->"7677) C IMNR: IMAGE # (1-->6) C OUTPUT : IMAD: RELOC.ADDR. IN "IM" (RANGE 0-->575) C********************************************************** IMNR = 1 do while (IMNR .lt. 6 .and. IOV(I) .gt. JGR(IMNR)) IMNR = IMNR+1 end do IMAD = IOV(I)-JOFI(IMNR) ! Safety belt: prevent subscript out of range if (0 .le. IMAD .and. IMAD .le. 575) then J = 193+(IMNR-1)*576+ITAB(IMAD+1) if (IOUT(J) .le. 28671) IOUT(J) = IOUT(J)+4096 end if ! Safety belt: prevent integer overflow end do return end C *** subroutine SUBGRP(IMAX,NF) implicit integer*2 (I-N) integer*2 IOUT(3840),INB(2108),LZ(6),ITAB(576),IR common /IMAGE/ IOUT,INB common /PEELB/ IB,IS,IP common /TABARRAY/ ITAB C********************************************* C** SUBGROUP DECOMPRESSION ROUTINE ** C********************************************* C INPUT/OUTPUT: IMAX: # OF (6 bit ?) BYTES LEFT IN "IN" C OUTPUT: NF : # OF FINE-SUBGROUPS C C CALLED SUBR.: IPEELB C********************************************* IP = 7 ISA = 4*IPEELB(INB) ! SUBGROUP-ADDR. if (ISA .ge. 128 .and. ISA .le. 431) NF=NF+1 IP = 2 LZ(6) = IPEELB(INB) ! LEADING ZERO'S BAND 6 LZ(6) = LZ(6)+4 if (LZ(6) .eq. 7) LZ(6) = 3 IP = 3 do I=1,5 LZ(I) = IPEELB(INB) ! LEADING ZERO'S BAND 1 - 5 end do IMAX = IMAX-4 if (IMAX .le. 0) then IMAX = 0 return end if IP=6 if (IOUT(193+ITAB(ISA+1)) .ge. 0) then IB = IB+18 IMAX = IMAX-24 if (IMAX .lt. 0) IMAX = 0 return end if do I=1,6 if (LZ(I) .eq. 7) LZ(I)=6 KZ = (2**(7-LZ(I)))/2 K = 193+(I-1)*576 do J=1,4 IRAM = ISA+J-1 ! RELOC. ADDR. (0->575) IOUT(K+ITAB(IRAM+1)) = KZ*IPEELB(INB) ! FILL PICTURE ELEMENT ADDR. IN BAND "I" IMAX = IMAX-1 if (IMAX .eq. 0) return end do end do return end