1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
SUBROUTINE BPACK (IG,I,J,L)
C
IMPLICIT INTEGER (A-Z)
C
CDC NEXT 2 LINES FOR CDC AND UNIVAC ONLY
C EXTERNAL ORF, LSHIFT
C INTEGER IG(1)
C
C NEXT LINE FOR IBM, VAX, AND MACHINES THAT HAVE INTEGER*2
INTEGER*2 IG(1)
C
COMMON /BANDB / NBIT, DUM3B(3), IPASS, NW, DUM1B,
1 NBPW
COMMON /BANDS / DUM4S(4), II1, DUM5S(5), MASK
C
C THIS ROUTINE IS USED ONLY IN BANDIT MODULE
C
C PACK INTERNAL GRID NO. INTO IG TABLE. SEE BUNPK FOR UNPACKING
C TABLE IG IS PACKED COLUMN-WISE.
C USE APPROP. PORTION OF THIS ROUTINE FOR DIFFERENT TYPE OF MACHINE.
C IPASS=COUNTER ON NUMBER OF CALLS TO PACK/UNPACK
C
C NOTE - THIS ROUTINE DOES NOT CHECK NOR ZERO OUT THE PACKING SLOT
C BEFORE PACKING.
C L IS ASSUMED TO BE A POSITIVE INTEGER, NBIT BITS OR LESS
C
IPASS=IPASS+1
LOC =J-1
C
C ********************************************
C UNIVAC AND CDC MACHINES
C (IG SHOULD BE IN INTEGER*4 HERE)
C ********************************************
C
C N1 =II1*(LOC/NW)+I
C N2 =MOD(LOC,NW)*NBIT+NBIT
C LOC=ORF(IG(N1),LSHIFT(L,NBPW-N2))
C IG(N1)=LOC
C
C RETURN
C
C ********************************************
C IBM AND VAX MACHINES
C (IG IS SET TO INTEGER*2 IN BPACK AND BUNPK, ELSEWHERE INTEGER*4)
C INTEGER*2 IG(1)
C ********************************************
C
N1=II1*LOC+I
IG(N1)=L
RETURN
END
|
