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<R2>    	; 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
