Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bank/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