Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/bnk14.ban
There are 3 other files named bnk14.ban in the archive. Click here to see a list.
C *** BANK ***
C
C SUBROUTINE TO MERGE TWO BANKS TOGETHER EITHER ONE APPENDED TO THE
C OTHER, OR AS AN UPDATE FOR THE OTHER.
C
SUBROUTINE MERGE(IDONE)
COMMON /DEV/ IDLG,ICC,IBNK,IUPGR,ITMPRY,MPROG,I2TMP
COMMON /MRG/ BNKU,IPJU,IPGU,NMATCH,MATCH(20)
COMMON /GEN/ IPROJA,IPROGA,NV,NO,BNKNM,DATCR,NPROJR,NPROGR
COMMON /SET/ NHVSET,IVSET(2,30), NHOSET,IOSET(2,30)
DIMENSION ISAV(4000,3),INPUT(125),NNS(18,6),NPUT(125),MMS(18,6)
DIMENSION LX(60,2),IDD(13000),IUVN(20),IMODUV(20)
DIMENSION L1(125),L2(125),L3(125),IPATH(3)
EQUIVALENCE (INPUT,NNS),(MISS,AMISS),(NPUT,MMS),(LX,INPUT)
EQUIVALENCE(IDD,ISAV)
DOUBLE PRECISION BNKNM,BNKU
DATA MISS/"400000000000/
IPATH(1)=IPJU
IPATH(2)=IPGU
IPATH(3)=0
IDONE=0
IF(BNKU.NE.0) GO TO 2
WRITE(IDLG,1)
1 FORMAT(' NO BANK WAS SPECIFIED IN THE MERGE')
RETURN
C
C FIND OUT COMBINED SET OF VARIABLES (UP TO 4000)
C FIRST THE RESIDENT BANK THEN THE UPDAT BANK
C ISAV(*,1)=NAME OF VARIABLE
C ISAV(*,2)=COUNTER PART IN UPDAT BANK (0 IF NONE EXIST)
C ISAV(*,3)=MODE (IF>2 THEN ITS RESIDENT VALUE PLUS 10*(UPDT+1)
C
2 IF(NV.LE.4000) GO TO 5
WRITE (IDLG,6)
6 FORMAT(' TOO MANY VARIABLES')
RETURN
5 NB=(NO+124)/125
NBLKR=NB*NV+1
NBR=(NV+5)/6
DO 3 I=1,NBR
IEND=6
IF((I*6).GT.NV) IEND=NV-(I-1)*6
READ(IBNK#(NBLKR+I)) INPUT
ISUB=(I-1)*6
DO 4 J=1,IEND
ISAV(ISUB+J,1)=NNS(1,J)
ISAV(ISUB+J,2)=0
4 ISAV(ISUB+J,3)=NNS(10,J)
3 CONTINUE
C
C NOW UPDATE BANK - ISAV HAS NV SETS NUSED WILL INDICATE HOW
C MANY DIFFERENT VARIABLES WERE IN BOTH BANK COMBINED. IF UPDAT
C BANK MODE DOES NOT AGREE FOR SAME VARIABLE AS IN RESIDENT BANK
C ISAV(*,2) WILL EQUAL 10 TIMES THE MODE OF THE UPDATE BANK PLUS
C 1 ADDED TO THE MODE ALREADY EXISTING FOR THE RESIDENT BANK
C
NUSED=NV
OPEN(UNIT=ITMPRY,DEVICE='DSK',FILE=BNKU,MODE='BINARY',
1DIRECTORY=IPATH,ACCESS='RANDIN',RECORD SIZE=126)
READ(ITMPRY#1) INPUT
IF(INPUT(8).EQ.'V2') GO TO 49
WRITE(IDLG,48)
48 FORMAT(' THE UPDATE BANK WAS CREATED WITH AN EXPERIMENTAL'/
1' MODEL OF THE BANK PROGRAM. TO UPDATE THE BANK RUN BANKUP'/
2' ON AREA 220,220. IF THE BANK DOES NOT BELONG TO YOU'/
3' CONTACT THE OWNER AND HAVE HIM RUN THE PROGRAM')
CALL RELEAS (ITMPRY)
RETURN
49 NVU=INPUT(1)
NOU=INPUT(2)
NB=(NOU+124)/125
NBLKU=NB*NVU+1
NBU=(NVU+5)/6
DO 10 I=1,NBU
IEND=6
IF((I*6).GT.NVU) IEND=NVU-(I-1)*6
READ(ITMPRY#(NBLKU+I)) INPUT
DO 11 J=1,IEND
DO 12 K=1,NV
IF(ISAV(K,1).NE.NNS(1,J)) GO TO 12
ISAV(K,2)=(I-1)*6+J
IF(ISAV(K,3).EQ.NNS(10,J)) GO TO 11
IF (ISAV(K,3).LE.9) GO TO 9
WRITE(IDLG,7)
7 FORMAT(' THE UPDATE BANK HAD TWO VARIABLES WITH THE SAME NAME')
CALL RELEAS (ITMPRY)
RETURN
9 ISAV(K,3)=ISAV(K,3)+10*(NNS(10,J)+1)
GO TO 11
12 CONTINUE
NUSED=NUSED+1
IF(NUSED.LE.4000) GO TO 8
WRITE(IDLG,6)
CALL RELEAS (ITMPRY)
RETURN
8 ISAV(NUSED,1)=NNS(1,J)
ISAV(NUSED,2)=(I-1)*6+J
11 CONTINUE
10 CONTINUE
C
C ALL TAKEN CARE OF NOW - START NEW FILE
C
NOBASU=(NOU+124)/125
NOBASR=(NO+124)/125
IF(NMATCH.GT.0) GO TO 100
OPEN(UNIT=IUPGR,DEVICE='DSK',FILE='TMP.DAT',MODE='BINARY',
1ACCESS='SEQOUT',RECORD SIZE=126)
READ(IBNK#1) INPUT
INPUT(1)=NUSED
INPUT(2)=NO+NOU
WRITE(IUPGR) INPUT
NOBASN=(NOU+NO+124)/125
NOBEG=NO-(NOBASR-1)*125
DO 13 I=1,NUSED
IF(I.GT.NV) GO TO 20
C VARIABLE DOES NOT EXIST IN OLD BANK
IBASE=(I-1)*NOBASR+1
IF(NOBASR.LE.1) GO TO 15
DO 14 J=1,NOBASR-1
READ(IBNK#(IBASE+J)) INPUT
14 WRITE(IUPGR) INPUT
15 READ(IBNK#(IBASE+NOBASR)) INPUT
IF(NOBEG.LT.125) GO TO 25
C JUST ADD BLOCKS FROM UPDATE BANK
WRITE(IUPGR) INPUT
IF(ISAV(I,2).EQ.0) GO TO 17
24 IVB=ISAV(I,2)
IBASE=(IVB-1)*NOBASU+1
DO 16 J=1,NOBASU
READ(ITMPRY#(IBASE+J)) INPUT
IF(ISAV(I,3).GT.9) CALL CNGMOD(INPUT,ISAV(I,3),1,1)
16 WRITE(IUPGR) INPUT
GO TO 13
17 DO 18 J=1,125
18 INPUT(J)=MISS
DO 19 J=1,NOBASU
19 WRITE(IUPGR) INPUT
GO TO 13
C RESIDENT BANK NO VARIABLE FOR THIS ONE
20 DO 21 J=1,125
21 INPUT(J)=MISS
IF(NOBASR.LE.1) GO TO 23
DO 22 J=1,NOBASR-1
22 WRITE(IUPGR) INPUT
23 IF(NOBEG.LT.125) GO TO 25
WRITE(IUPGR) INPUT
GO TO 24
25 J=0
IVB=ISAV(I,2)
IF(IVB.NE.0) GO TO 36
DO 35 K=1,125
35 NPUT(K)=MISS
36 IBASE=(IVB-1)*NOBASU+1
KBEG=1
KEND=125-NOBEG
LBEG=KEND+1
LEND=125
26 J=J+1
IF(J.GT.NOBASU) GO TO 33
IF(IVB.EQ.0) GO TO 37
READ(ITMPRY#(IBASE+J)) NPUT
IF(ISAV(I,3).GT.9) CALL CNGMOD(NPUT,ISAV(I,3),1,1)
37 IADD=J*125
IF(IADD.LE.NOU) GO TO 28
IF((IADD-125+KEND).LT.NOU)GO TO 27
KEND=NOU-IADD+125
LBEG=0
GO TO 28
27 LEND=NOU-IADD+125
28 DO 29 K=KBEG,KEND
29 INPUT(NOBEG+K)=NPUT(K)
IF(KEND.EQ.(125-NOBEG)) GO TO 31
DO 30 K=NOBEG+KEND+1,125
30 INPUT(K)=MISS
31 WRITE(IUPGR) INPUT
IF(LBEG.EQ.0) GO TO 13
DO 32 L=LBEG,LEND
32 INPUT(L-KEND)=NPUT(L)
GO TO 26
33 DO 34 L=LEND-KEND+1,125
34 INPUT(L)=MISS
WRITE(IUPGR) INPUT
13 CONTINUE
C
C DONE WITH DATA
C
50 NB=NBR-1
IF(NB.LT.1) GO TO 52
DO 51 I=1,NB
READ(IBNK#(NBLKR+I)) INPUT
51 WRITE(IUPGR) INPUT
C
C FINISHED ALL BUT LAST BLOCK OF MAIN DATA NAME & DESC BLOCKS
C
52 READ(IBNK#(NBLKR+NBR)) INPUT
IF(NUSED.EQ.NV) GO TO 56
NK=NV-NB*6+1
NL=NV+1
53 IF(NK.LE.6) GO TO 54
WRITE(IUPGR) INPUT
NK=1
54 NB=(ISAV(NL,2)+5)/6
READ(ITMPRY#(NB+NBLKU))NPUT
NJ=ISAV(NL,2)-(NB-1)*6
DO 55 J=1,18
55 NNS(J,NK)=MMS(J,NJ)
NK=NK+1
NL=NL+1
IF(NL.LE.NUSED) GO TO 53
56 WRITE(IUPGR) INPUT
CALL RELEAS (ITMPRY)
NV=NUSED
NO=NO+NOU
NHVSET=1
IVSET(1,1)=1
IVSET(2,1)=NV
NHOSET=1
IOSET(1,1)=1
IOSET(2,1)=NO
CLOSE(UNIT=IBNK,DISPOSE='RENAME',FILE='HOLD.TMP')
CLOSE(UNIT=IUPGR,DISPOSE='RENAME',FILE=BNKNM,PROTECTION="155)
OPEN(UNIT=IUPGR,DEVICE='DSK',FILE='HOLD.TMP')
CLOSE(UNIT=IUPGR,DISPOSE='DELETE')
IDONE=1
RETURN
C
C MATCH WERE USED
C
100 IF(((NO+NOU)*(NMATCH+1)).LE.13000) GO TO 102
WRITE(IDLG,101)
101 FORMAT(' THE TWO BANKS TO BE MERGED ARE TOO LARGE FOR THE'/
1' INCORE SORT. PLEASE CONTACT DICK HOUCHARD SO WE MIGHT'/
2' KNOW A NEED EXISTS.')
CALL RELEAS (ITMPRY)
RETURN
102 DO 105 I=1,NMATCH
IF(MATCH(I).EQ.-1) GO TO 120
IF(ISAV(MATCH(I),2).NE.0) GO TO 114
WRITE(IDLG,106) ISAV(MATCH(I),1)
106 FORMAT(' THERE WAS NO UPDATE VARIABLE ',A5)
CALL RELEAS (ITMPRY)
RETURN
114 IUVN(I)=ISAV(MATCH(I),2)
IMODUV(I)=ISAV(MATCH(I),3)
GO TO 105
120 IUVN(I)=-1
105 CONTINUE
OPEN(UNIT=IUPGR,DEVICE='DSK',FILE='RECS.DAT',MODE='BINARY',
1ACCESS='SEQOUT',RECORD SIZE=126)
C
C STORE MATCHING VARIABLES AND MODES FOR A FEW COMPUTATIONS
C
DO 103 I=1,NUSED,125
K=I+124
IF(K.GT.NUSED) K=NUSED
WRITE(IUPGR) (ISAV(J,2),J=I,K)
103 WRITE(IUPGR) (ISAV(J,3),J=I,K)
CALL RELEAS (IUPGR)
C
C READ DATA FROM RESIDNET BANK
C
NCOMB=NO+NOU
NCOL=NMATCH+1
ISS1=NCOMB*NMATCH
DO 107 I=1,NO
ISUB=ISS1+I
107 IDD(ISUB)=I
DO 108 I=1,NOBASR
IEND=125
IF((I*125).GT.NO) IEND=NO-(I-1)*125
DO 109 J=1,NMATCH
IF(MATCH(J).EQ.-1) GO TO 116
IBLK=(MATCH(J)-1)*NOBASR+1+I
READ(IBNK#IBLK) INPUT
ISS1=(J-1)*NCOMB+(I-1)*125
DO 110 K=1,IEND
ISUB=ISS1+K
110 IDD(ISUB)=INPUT(K)
GO TO 109
116 ISS1=(J-1)*NCOMB+(I-1)*125
LBASE=(I-1)*125
DO 117 K=1,IEND
ISUB=ISS1+K
117 IDD(ISUB)=LBASE+K
109 CONTINUE
108 CONTINUE
C
C READ DATA FROM UPPDATE BANK
C
DO 111 I=1,NOBASU
IEND=125
IF((I*125).GT.NOU) IEND=NOU-(I-1)*125
DO 112 J=1,NMATCH
IF(IUVN(J).EQ.-1) GO TO 118
IBLK=(IUVN(J)-1)*NOBASU+1+I
READ(ITMPRY#IBLK) INPUT
IF(IMODUV(J).GT.9) CALL CNGMOD(INPUT,IMODUV(J),1,1)
ISS1=(J-1)*NCOMB+(I-1)*125+NO
DO 113 K=1,IEND
ISUB=ISS1+K
113 IDD(ISUB)=INPUT(K)
112 CONTINUE
GO TO 111
118 LBASE=(I-1)*125
ISS1=(J-1)*NCOMB+(I-1)*125+NO
DO 119 K=1,IEND
ISUB=ISS1+K
119 IDD(ISUB)=LBASE+K
111 CONTINUE
ISS1=NCOMB*NMATCH+NO
DO 115 J=1,NOU
115 IDD(ISS1+J)=J
C
C SORT BOTH FILES NOW
C
CALL SORT(IDD,NCOMB,NCOL,1,NO)
CALL SORT(IDD,NCOMB,NCOL,NO+1,NCOMB)
C
C NOW MERGE
C
L=1
J=NO+1
130 DO 131 K=1,NMATCH
ISS1=(K-1)*NCOMB
ISUBR=ISS1+L
ISUBU=ISS1+J
IF(IDD(ISUBR).GT.IDD(ISUBU)) GO TO 132
IF(IDD(ISUBR).LT.IDD(ISUBU)) GO TO 133
131 CONTINUE
IDD(L)=IDD(NMATCH*NCOMB+L)
IDD(NCOMB+L)=IDD(NMATCH*NCOMB+J)
IDD(NMATCH*NCOMB+J)=0
L=L+1
IF(L.GT.NO) GO TO 136
J=J+1
IF(J.GT.NCOMB) GO TO 135
GO TO 130
132 J=J+1
IF(J.GT.NCOMB) GO TO 135
GO TO 130
133 IDD(L)=IDD(NMATCH*NCOMB+L)
IDD(NCOMB+L)=0
L=L+1
IF(L.GT.NO) GO TO 136
GO TO 130
135 IDD(L)=IDD(NMATCH*NCOMB+L)
IDD(NCOMB+L)=0
L=L+1
IF(L.LE.NO) GO TO 135
136 J=NO+1
137 IF(IDD(NCOMB*NMATCH+J).EQ.0) GO TO 138
IDD(L)=0
IDD(NCOMB+L)=IDD(NCOMB*NMATCH+J)
L=L+1
138 J=J+1
IF(J.LE.NCOMB) GO TO 137
NTOT=L-1
C
C MERGE ACCOMPLISHED SORT RESIDNET BANK INTO ORIGINAL ORDER
C
CALL SORT(IDD,NCOMB,2,1,NO)
C
C NOW PUT FILES TOGETHER
C
OPEN(UNIT=IUPGR,DEVICE='DSK',FILE='LIST.DAT',MODE='BINARY',
1ACCESS='SEQOUT',RECORD SIZE=126)
DO 153 J=1,NTOT
ISUB1=IDD(J)
IDD(J)=IDD(NCOMB+J)
IDD(NCOMB+J)=ISUB1
153 CONTINUE
DO 150 J=1,NO,125
JEND=J+124
IF(JEND.GT.NO) JEND=NO
L=(J/125)*125
DO 151 K=J,JEND
151 IDD(NCOMB+K)=IDD(NCOMB+K)-L
JJ=J
150 CALL SORT(IDD,NCOMB,2,JJ,JEND)
J=NO+1
IF(NTOT.GT.NO) CALL SORT(IDD,NCOMB,2,J,NTOT)
DO 157 K=J,NTOT
ISUB=((K-1)/125)*125
157 IDD(NCOMB+K)=K-ISUB
DO 152 J=1,NTOT,125
JEND=J+124
IF(JEND.GT.NTOT) JEND=NTOT
DO 156 K=J,JEND
IX=(IDD(K)+124)/125
IF(IX.NE.0) IDD(K)=IDD(K)-(IX-1)*125
ISUB=K-J+1
L1(ISUB)=IDD(K)
L2(ISUB)=IDD(K+NCOMB)
L3(ISUB)=IX
156 CONTINUE
WRITE(IUPGR) L1
WRITE(IUPGR) L2
WRITE(IUPGR) L3
152 CONTINUE
CALL RELEAS(IUPGR)
OPEN(UNIT=IUPGR,DEVICE='DSK',FILE='RECS.DAT',MODE='BINARY',
1ACCESS='SEQIN',RECORD SIZE=126)
DO 155 I=1,NUSED,125
K=I+124
IF(K.GT.NUSED) K=NUSED
READ(IUPGR) (ISAV(J,2),J=I,K)
READ(IUPGR) (ISAV(J,3),J=I,K)
155 CONTINUE
CLOSE(UNIT=IUPGR,DISPOSE='DELETE')
OPEN(UNIT=IUPGR,DEVICE='DSK',FILE='TMP.DAT',MODE='BINARY',
1ACCESS='SEQOUT',RECORD SIZE=126)
READ(IBNK#1) INPUT
INPUT(1)=NUSED
INPUT(2)=NTOT
WRITE(IUPGR)INPUT
OPEN(UNIT=I2TMP,DEVICE='DSK',FILE='LIST.DAT',MODE='BINARY',
1ACCESS='RANDIN',RECORD SIZE=126)
NOBASE=(NTOT+124)/125
DO 200 I=1,NUSED
DO 201 J=1,NOBASE
IREC=(J-1)*3+1
READ(I2TMP#IREC) L1
READ(I2TMP#(IREC+1)) L2
READ(I2TMP#(IREC+2)) L3
IF(I.GT.NV) GO TO 203
IF(J.GT.NOBASR) GO TO 203
C PICK UP RESIDENT PORTION
IREC=(I-1)*NOBASR+1+J
READ(IBNK#IREC) INPUT
IF((J*125).LE.NO) GO TO 205
KEND=NO-(J-1)*125
DO 202 K=KEND+1,125
202 INPUT(K)=MISS
GO TO 205
203 DO 204 K=1,125
204 INPUT(K)=MISS
C UPDATE BANK NOW
205 IF(ISAV(I,2).EQ.0) GO TO 201
IBASE=(ISAV(I,2)-1)*NOBASU+1
ISPEC=0
KEND=125
IF((J*125).GT.NTOT) KEND=NTOT-(J-1)*125
DO 206 K=1,KEND
IF(L1(K).EQ.0) GO TO 206
IF(L3(K).EQ.ISPEC) GO TO 207
ISPEC=L3(K)
KSPEC=IBASE+ISPEC
READ(ITMPRY#KSPEC) NPUT
207 IF(NPUT(L1(K)).EQ.MISS) GO TO 206
INPUT(L2(K))=NPUT(L1(K))
IF(I.GT.NV) GO TO 206
IF(ISAV(I,3).GT.9) CALL CNGMOD(INPUT,ISAV(I,3),L2(K),2)
206 CONTINUE
IF(I.LE.NV) GO TO 201
IF(ISAV(I,3).GT.9) CALL CNGMOD(INPUT,ISAV(I,3),1,1)
201 WRITE(IUPGR) INPUT
200 CONTINUE
C
C WRITE OUT NAME AND DESCRIPTION BLOCKS NOW
C
350 NB=NBR-1
IF(NB.LT.1) GO TO 352
DO 351 I=1,NB
READ(IBNK#(NBLKR+I)) INPUT
351 WRITE(IUPGR) INPUT
C
C
352 READ(IBNK#(NBLKR+NBR)) INPUT
IF(NUSED.EQ.NV) GO TO 356
NK=NV-NB*6+1
NL=NV+1
353 IF(NK.LE.6) GO TO 354
WRITE(IUPGR) INPUT
NK=1
354 NB=(ISAV(NL,2)+5)/6
READ(ITMPRY#(NB+NBLKU)) NPUT
NJ=ISAV(NL,2)-(NB-1)*6
DO 355 J=1,18
355 NNS(J,NK)=MMS(J,NJ)
NK=NK+1
NL=NL+1
IF(NL.LE.NUSED) GO TO 353
356 WRITE(IUPGR) INPUT
CLOSE(UNIT=I2TMP,DISPOSE='DELETE')
CALL RELEAS (ITMPRY)
NV=NUSED
NO=NTOT
NHVSET=1
IVSET(1,1)=1
IVSET(2,1)=NV
NHOSET=1
IOSET(1,1)=1
IOSET(2,1)=NO
CLOSE(UNIT=IBNK,DISPOSE='RENAME',FILE='HOLD.TMP')
CLOSE(UNIT=IUPGR,DISPOSE='RENAME',FILE=BNKNM,PROTECTION="155)
OPEN(UNIT=IBNK,DEVICE='DSK',FILE='HOLD.TMP')
CLOSE(UNIT=IBNK,DISPOSE='DELETE')
IDONE=1
RETURN
END
SUBROUTINE CNGMOD(INPUT,L,M,KK)
DIMENSION INPUT(125),IS(5)
EQUIVALENCE (MISS,AMISS),(X,IX)
DATA MISS/"400000000000/
IEND=125
IF(KK.EQ.2) IEND=M
C ASSUMBE FLOAT TO ALPHA
IL=1
C IS IT FLOAT TO FIX
IF(L.EQ.12) IL=2
C IS IT ALPHA TO FLOAT
IF(L.EQ.20) IL=3
C IS IT ALPHA TO FIX
IF(L.EQ.22) IL=4
C IS IT FIX TO FLOAT
IF(L.EQ.30) IL=5
C IS IT FIX TO ALPHA
IF(L.EQ.31) IL=6
IF(M.GT.125) RETURN
DO 1 I=M,IEND
IF(INPUT(I).EQ.MISS) GO TO 1
GO TO (2,20,30,40,50,60)IL
2 IX=INPUT(I)
IF((X.LT.9999.).AND.(X.GT.-999.)) GO TO 5
IX=X
IF((IX.LE.99999).AND.(IX.GT.-9999)) GO TO 3
INPUT(I)=MISS
GO TO 1
3 INPUT(I)=0
ENCODE(5,4,INPUT(I)) IX
4 FORMAT(I5)
GO TO 7
5 INPUT(I)=0
ENCODE(5,6,INPUT(I)) X
6 FORMAT(F5.0)
GO TO 7
7 DECODE(5,8,INPUT(I)) IS
8 FORMAT(5A1)
9 IF(IS(1).NE.' ') GO TO 11
DO 10 J=2,5
10 IS(J-1)=IS(J)
IS(5)=' '
GO TO 9
11 ENCODE(5,8,INPUT(I)) IS
GO TO 1
C
20 IX=INPUT(I)
INPUT(I)=X
GO TO 1
C
30 DECODE(5,8,INPUT(I)) IS
DO 31 J=1,5
IF(IS(J).EQ.'-') GO TO 31
IF(IS(J).EQ.' ') GO TO 31
IF(IS(J).EQ.'.') GO TO 31
IF((IS(J).GE.'0').AND.(IS(J).LE.'9')) GO TO 31
INPUT(I)=MISS
GO TO 1
31 CONTINUE
32 IF(IS(5).NE.' ') GO TO 34
DO 33 J=5,2,-1
33 IS(J)=IS(J-1)
IS(1)=' '
GO TO 32
34 ENCODE(5,8,INPUT(I)) IS
DECODE(5,6,INPUT(I)) X
INPUT(I)=IX
GO TO 1
C
40 DECODE(5,8,INPUT(I)) IS
DO 41 J=1,5
IF(IS(J).EQ.'-') GO TO 41
IF(IS(J).EQ.' ') GO TO 41
IF(IS(J).EQ.'.') GO TO 45
IF(IS(J).EQ.',') GO TO 45
IF((IS(J).GT.'0').AND.(IS(J).LE.'9')) GO TO 41
47 INPUT(I)=MISS
GO TO 1
41 CONTINUE
42 IF(IS(5).NE.' ') GO TO 44
DO 43 J=5,2,-1
43 IS(J)=IS(J-1)
IS(1)=' '
GO TO 42
44 ENCODE(5,8,IX) IS
DECODE(5,4,IX) INPUT(I)
GO TO 1
45 IF(J.EQ.1) GO TO 47
DO 46 K=J,5
46 IS(K)=' '
GO TO 42
C
50 X=INPUT(I)
INPUT(I)=IX
GOTO 1
C
60 IX=INPUT(I)
IF((IX.LE.99999).AND.(IX.GE.-9999)) GO TO 61
INPUT(I)=MISS
GO TO 1
61 INPUT(I)=0
ENCODE(5,4,INPUT(I)) IX
DECODE(5,8,INPUT(I)) IS
62 IF(IS(1).NE.' ') GO TO 64
DO 63 J=2,5
63 IS(J-1)=IS(J)
IS(5)=' '
GO TO 62
64 ENCODE(5,8,INPUT(I)) IS
GO TO 1
1 CONTINUE
RETURN
END
SUBROUTINE SORT(ID,INDEX,NCOL,IBEG,IEND)
DIMENSION ID(1),IU(16),IL(16),IG(21)
NSRTF=NCOL-1
C
C SORT FROM ACM (SINGLETON METHOD)
C
M=1
II=IBEG
J=IEND
11 IF(II.GE.J) GO TO 18
12 K=II
IJ=(J+II)/2
I=-1
31 I=I+1
IF(I.GT.NSRTF) GO TO 13
IT1=ID(I*INDEX+IJ)
IT2=ID(I*INDEX+II)
IF(IT2.EQ.IT1) GO TO 31
IF(IT2.LT.IT1) GO TO 13
GO TO 32
32 DO 60 N=0,NSRTF
ISUB=(N*INDEX+IJ)
ISUB1=(N*INDEX+II)
ISAV=ID(ISUB)
ID(ISUB)=ID(ISUB1)
60 ID(ISUB1)=ISAV
13 LL=J
I=-1
34 I=I+1
IF(I.GT.NSRTF) GO TO 55
IT1=ID(I*INDEX+IJ)
IT2=ID(I*INDEX+J)
IF(IT2.EQ.IT1) GO TO 34
IF(IT2.GT.IT1) GO TO 55
GO TO 35
35 DO 61 N=0,NSRTF
ISUB=(N*INDEX+IJ)
ISUB1=(N*INDEX+J)
ISAV=ID(ISUB)
ID(ISUB)=ID(ISUB1)
61 ID(ISUB1)=ISAV
I=-1
37 I=I+1
IF(I.GT.NSRTF) GO TO 39
IT1=ID(I*INDEX+IJ)
IT2=ID(I*INDEX+II)
IF(IT2.EQ.IT1) GO TO 37
IF(IT2.LT.IT1) GO TO 55
GO TO 38
39 IF(IJ.EQ.II) GO TO 55
PAUSE '39'
38 DO 62 N=0,NSRTF
ISUB=(N*INDEX+IJ)
ISUB1=(N*INDEX+II)
ISAV=ID(ISUB)
ID(ISUB)=ID(ISUB1)
62 ID(ISUB1)=ISAV
55 DO 56 L=0,NSRTF
56 IG(L+1)=ID(L*INDEX+IJ)
GO TO 15
14 DO 63 N=0,NSRTF
ISUB=(N*INDEX+LL)
ISUB1=(N*INDEX+K)
ISAV=ID(ISUB)
ID(ISUB)=ID(ISUB1)
63 ID(ISUB1)=ISAV
15 LL=LL-1
I=-1
40 I=I+1
IF(I.GT.NSRTF) GO TO 16
IT1=IG(I+1)
IT2=ID(I*INDEX+LL)
IF(IT2.EQ.IT1) GO TO 40
IF(IT2.GT.IT1) GO TO 15
GO TO 16
16 K=K+1
I=-1
42 I=I+1
IF(I.GT.NSRTF) GO TO 43
IT1=IG(I+1)
IT2=ID(I*INDEX+K)
IF(IT2.EQ.IT1) GO TO 42
IF(IT2.LT.IT1) GO TO 16
GO TO 43
43 IF(K.LE.LL) GO TO 14
IF((LL-II).LE.(J-K)) GO TO 17
IL(M)=II
IU(M)=LL
II=K
M=M+1
GO TO 19
17 IL(M)=K
IU(M)=J
J=LL
M=M+1
GO TO 19
18 M=M-1
IF(M.EQ.0) GO TO 70
II=IL(M)
J=IU(M)
19 IF((J-II).GE.11) GO TO 12
IF(II.EQ.IBEG) GO TO 11
C
C
II=II-1
20 II=II+1
IF(II.EQ.J) GO TO 18
DO 64 N=0,NSRTF
64 IG(N+1)=ID(N*INDEX+II+1)
I=-1
45 I=I+1
IF(I.GT.NSRTF) GO TO 20
IT1=IG(I+1)
IT2=ID(I*INDEX+II)
IF(IT2.EQ.IT1) GO TO 45
IF(IT2.LT.IT1) GO TO 20
46 K=II
21 DO 65 N=0,NSRTF
65 ID(N*INDEX+K+1)=ID(N*INDEX+K)
K=K-1
I=-1
48 I=I+1
IF(I.GT.NSRTF) GO TO 49
IT1=IG(I+1)
IT2=ID(I*INDEX+K)
IF(IT2.EQ.IT1) GO TO 48
IF(IT1.LT.IT2) GO TO 21
49 DO 66 N=0,NSRTF
66 ID(N*INDEX+K+1)=IG(N+1)
GO TO 20
C
C DONE WITH SORT
C
70 RETURN
END