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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
|
SUBROUTINE CDCMPD (*,IX,X,DX)
C
C DOUBLE-PRECISION VERSION OF CDCOMP
C (THIS ROUTINE WAS PREVIOUSLY CALLED CDCOMP AND IS NOW RENAMED
C TO CDCMPD) BY G.CHAN/SPERRY 6/85
C
C TO ELIMINATE IBM UNDERFLOW MESSAGES, THIS VERSION ZEROS OUT
C THE COMPUTED DX ELEMENT IF /IT/ IS LESS THAN 1.0D-38
C
C CDCOMP WILL DECOMPOSE A COMPLEX UNSYMETRIC MATRIX INTO A UNIT LOWE
C TRIANGULAR MATRIX AND AN UPPER TRIANGULAR MATRIX,USING PARTIAL
C PIVOTING WITHIN THE LOWER BAND
C
C DEFINITION OF INPUT PARAMETERS
C
C FILEA = MATRIX CONTROL BLOCK FOR THE INPUT MATRIX A
C FILEL = MATRIX CONTROL BLOCK FOR THE OUTPUT MATRIX L
C FILEU = MATRIX CONTROL BLOCK FOR THE OUTPUT MATRIX U
C SR1FIL = SCRATCH FILE
C SR2FIL = SCRATCH FILE
C SR3FIL = SCRATCH FILE
C NX = NUMBER OF CELLS OF CORE AVAILABLE AT IX
C DET = CELL WHERE THE DETERMINATE OF A WILL BE STORED
C POWER = SCALE FACTOR TO BE APPLIED TO THE DETERMINATE
C (DETERMINATE = DET*10**POWER)
C MINDIA = CELL WHERE THE VALUE OF THE MINIMUM DIAGONAL WILL BE S
C IX = BLOCK OF CORE AVAILABLE AS WORKING STORAGE TO DECOMP
C X = SAME BLOCK AS IX, BUT TYPED REAL
C DX = SAME BLOCK AS IX, BUT TYPED DOUBLE PRECISION
C
INTEGER FILEA ,FILEL ,FILEU ,POWER ,
1 SYSBUF ,FORMA ,TYPEA ,RDP ,
2 TYPEL ,EOL ,PARM(5) ,BUFA ,
3 OUTBUF ,SR1BUF ,SR2BUF ,SR3BUF ,
4 B ,BBAR ,C ,CBAR ,
5 BBAR1 ,R ,CCOUNT ,CBCNT ,
6 SCRFLG ,END ,BBBAR ,BBBAR1 ,
7 COUNT ,SR2FL ,SR3FL ,SR1FIL ,
8 SR2FIL ,SR3FIL ,SQR ,SYM ,
9 FLAG ,ITRAN(6)
DOUBLE PRECISION DZ(2) ,DA(2) ,DET ,MAX(2) ,
1 MINDIA ,DX(1) ,DTRN(2) ,DX1 ,
2 DX2 ,EPSI
DIMENSION IX(1) ,X(1)
CHARACTER UFM*23 ,UWM*25 ,UIM*29
COMMON /XMSSG / UFM ,UWM ,UIM
COMMON /CDCMPX/ FILEA(7) ,FILEL(7) ,FILEU(7) ,SR1FIL ,
1 SR2FIL ,SR3FIL ,DET(2) ,POWER ,
2 NX ,MINDIA ,B ,BBAR ,
3 C ,CBAR ,R
COMMON /SYSTEM/ SYSBUF ,NOUT
COMMON /NAMES / RD ,RDREW ,WRT ,WRTREW ,
1 REW ,NOREW ,EOFNRW ,RSP ,
2 RDP ,CSP ,CDP ,SQR ,
3 RECT ,DIAG ,LOWTRI ,UPRTRI ,
4 SYM ,ROW ,IDENT
COMMON /ZNTPKX/ A(4) ,II ,EOL
COMMON /DESCRP/ LENGTH ,MAJOR
COMMON /ZBLPKX/ Z(4) ,JJ
COMMON /UNPAKX/ ITYPEX ,IXY ,JXY ,INCRX
COMMON /PACKX / ITYPE1 ,ITYPE2 ,IY ,JY ,
1 INCRY
EQUIVALENCE (DA(1),A(1)) ,(DZ(1),Z(1)) ,
1 (FORMA,FILEA(4)) ,(TYPEA,FILEA(5)) ,
2 (NCOL,FILEA(3)) ,(TYPEL,FILEL(5)) ,
3 (ITRAN(1),ITRN) ,(ITRAN(2),JTRN) ,
4 (ITRAN(3),DTRN(1))
DATA PARM(3), PARM(4) /4HCDCO,4HMP /
DATA IBEGN , IEND /4HBEGN,4HEND /
DATA EPSI / 1.0D-38 /
C
C BUFFER ALLOCATION
C
BUFA = NX - SYSBUF
IBUFL = BUFA - SYSBUF
OUTBUF = IBUFL - SYSBUF
SR1BUF = OUTBUF - SYSBUF
SR2BUF = SR1BUF - SYSBUF
SR3BUF = SR2BUF - SYSBUF
ICRQ =-SR3BUF
IF (ICRQ .GT. 0) GO TO 1715
DET(1) = 1.D0
DET(2) = 0.D0
POWER = 0
MINDIA = 1.D+25
ITERM = 0
IF (FILEA(1) .LT. 0) ITERM = 1
FILEA(1) = IABS(FILEA(1))
C
C WRITE THE HEADER RECORD ON THE OUTPUT TAPES AND INITIALIZE THE
C TRAILER RECORDS.
C
CALL GOPEN (FILEL,IX(IBUFL),WRTREW)
PARM(2) = SR2FIL
CALL OPEN (*1680,SR2FIL,IX(OUTBUF),WRTREW)
CALL FNAME (FILEU(1),X(1))
CALL WRITE (SR2FIL,X(1),2,1)
FILEL(2) = 0
FILEL(3) = NCOL
FILEL(4) = 4
FILEL(6) = 0
FILEL(7) = 0
FILEU(2) = 0
FILEU(3) = NCOL
FILEU(4) = 5
FILEU(6) = 0
FILEU(7) = 0
C
C CALL GENVEC TO PICK B,BBAR,C,CBAR, AND R
C
IF (B.GT.0 .AND. BBAR.GT.0) GO TO 11
CALL GENVEC (*1720,IX(BUFA),FILEA(1),NX,IX(1),NCOL,B,BBAR,C,CBAR,
1 R,2)
11 CONTINUE
BBAR1 = BBAR + 1
BBBAR = MIN0(B+BBAR,NCOL)
BBBAR1 = BBBAR - 1
SCRFLG = 0
IF (R .LT. BBBAR1) SCRFLG = 1
IF (SCRFLG .EQ. 0) GO TO 20
ICRQ = (BBBAR1-R)*4*BBAR
CALL PAGE2(2)
WRITE (NOUT,15) UIM,ICRQ
15 FORMAT (A29,' 2177, SPILL WILL OCCUR IN COMPLEX UNSYMMETRIC ',
1 'DECOMPOSITION.', /1X,I10,
2 ' ADDITIONAL WORDS NEEDED TO STAY IN CORE.')
C
C INITIALIZE POINTERS TO SPECIFIC AREAS OF CORE
C
20 I1 = 1
IPAK = I1 + 2*BBAR*R + BBBAR/2 + 1
I1SP = BBAR*R*4 + 1
I2 = IPAK
I3SP = (I2 + 2*MIN0(NCOL,BBBAR + BBAR))*2 - 1
I3 = I2 + 2*MIN0(NCOL,BBBAR+BBAR) + C
I4SP = I3SP + (BBAR+2)*C*4 - 2*C
I4 = I3 + 2*BBAR1*C + CBAR
I5 = I4 + 2*BBBAR*CBAR
I6SP = (I5 + 2*C*CBAR)*2 - 1
I7SP = I6SP + CBAR
PARM(5) = IBEGN
CALL CONMSG (PARM(3),3,0)
END = I7SP + C
C
C DEFINITION OF KEY PROGRAM PARAMETERS
C
C I1 = POINTER TO AREA WHERE COMPLETED COLUMNS OF L ARE STORED
C I1SP = POINTER TO AREA WHERE THE PERMUTATION INDEXES ARE STORED
C IPAK = POINTER TO AREA WHERE COLUMNS WILL BE PACKED FROM
C I2 = POINTER TO AREA WHERE THE NEXT COLUMN OF A IS STORED
C I3 = POINTER TO AREA WHERE ACTIVE COLUMNS ARE STORED
C I4 = POINTER TO AREA WHERE ACTIVE ROWS ARE STORED
C I5 = POINTER TO AREA WHERE INTERACTION ELEMENTS ARE STORED
C I6SP = POINTER TO AREA WHERE SEQUENCED ACTIVE ROW INDICES
C ARE STORED
C I7SP = POINTER TO AREA WHERE SEQUENCED ACTIVE COLUMN INDICES
C ARE STORED
C B = UPPER HALF-BAND
C BBAR = LOWER HALF-BAND
C C = NUMBER OF ACTIVE COLUMNS
C CBAR = NUMBER OF ACTIVE ROWS
C R = NUMBER OF COLUMNS OF L THAT CAN BE STORED IN CORE
C JPOS = CURRENT PIVOTAL COLUMN INDEX
C JPOSL = NEXT COLUMN OF L TO BE WRITTEN OUT
C LCOL = NUMBER OF COLUMNS OF L CURRENTLY STORED IN CORE OR ON
C SCRATCH FILES
C CCOUNT = CURRENT NUMBER OF ACTIVE COLUMNS
C CBCNT = CURRENT NUMBER OF ACTIVE ROWS
C ITRN = ROW INDEX OF NEXT ACTIVE COLUMN ELEMENT
C JTRN = COLUMN INDEX OF NEXT ACTIVE COLUMN ELEMENT
C IOFF = ROW POSITION OF THE FIRST ELEMENT IN AREA II
C ITERM = IF NONZERO, TERMINATE BEFORE THE RE-WRITE
C NCOL = SIZE OF THE INPUT MATRIX
C BBBAR = B + BBAR
C BBAR1 = BBAR + 1
C BBBAR1 = B + BBAR - 1
C SCRFLG = NONZERO MEANS SPILL
C
C ****************************************************************
C RE-WRITE THE UPPER TRIANGLE OF ACTIVE ELEMENTS IN THE TRANSPOSED
C ORDER
C ****************************************************************
C
PARM(2) = FILEA(1)
CALL OPEN (*1680,FILEA(1),IX(BUFA),RDREW)
CCOUNT = 0
IF (C .EQ. 0) GO TO 40
CALL CTRNSP (IX(1),X(1),NX,FILEA(1),B,SR1FIL)
C
C ZERO CORE
C
40 DO 50 I = 1,END
50 X(I) = 0.
IF (C .EQ. 0) GO TO 260
C
C ****************************************************************
C OPEN THE FILE CONTAINING THE TRANSPOSED ACTIVE ELEMENTS AND READ
C IN THE FIRST BBAR + 1 ROWS
C ****************************************************************
C
PARM(2) = SR1FIL
CALL OPEN (*1680,SR1FIL,IX(SR1BUF),RD)
K = 0
60 CALL READ (*1690,*1700,SR1FIL,ITRAN(1),6,0,FLAG)
IF (ITRN .GT. 0) GO TO 70
CALL CLOSE (SR1FIL,REW)
GO TO 140
70 IF (ITRN .GT. K+1) GO TO 130
C
C DETERMINE IF COLUMN IS ALREADY ACTIVE
C
IF (JTRN .LE. BBBAR) GO TO 60
KK = 0
80 IN1 = I3SP + KK
IF (IX(IN1) .EQ. JTRN) GO TO 90
KK = KK + 1
IF (KK-C) 80,100,1710
C
C ADD IN ACTIVE ELEMENT TO EXISTING COLUMN
C
90 IN1 = I3 + 2*KK*BBAR1 + K + K
DX(IN1 ) = DTRN(1)
DX(IN1+1) = DTRN(2)
IF (DABS(DX(IN1 )) .LT. EPSI) DX(IN1 ) = 0.0D0
IF (DABS(DX(IN1+1)) .LT. EPSI) DX(IN1+1) = 0.0D0
GO TO 60
C
C CREATE NEW ACTIVE COLUMN
C
100 CCOUNT = CCOUNT + 1
KK = 0
110 IN1 = I3SP + KK
IF (IX(IN1) .EQ. 0) GO TO 120
KK = KK + 1
IF (KK - C) 110,1710,1710
120 IX(IN1) = JTRN
IN1 = IN1 + C
IX(IN1) = K + 1
IN1 = I3 + 2*KK*BBAR1 + K + K
DX(IN1 ) = DTRN(1)
DX(IN1+1) = DTRN(2)
IF (DABS(DX(IN1 )) .LT. EPSI) DX(IN1 ) = 0.0D0
IF (DABS(DX(IN1+1)) .LT. EPSI) DX(IN1+1) = 0.0D0
GO TO 60
130 K = K + 1
IF (K-BBAR1) 70,140,1710
C
C SET INDEXES IN AREA VII TO POINT TO THE ACTIVE COLUMNS IN SEQUENCE
C
140 ASSIGN 260 TO KK
150 IN1 = I7SP
K = 0
160 IN2 = I3SP + K
IF (IX(IN2)) 1710,180,190
170 IN1 = IN1 + 1
180 K = K + 1
IF (K-C) 160,250,1710
190 IF (IN1 .NE. I7SP) GO TO 200
IX(IN1) = K
GO TO 170
200 KKK = 0
210 IN3 = IN1 - KKK
IF (IN3 .GT. I7SP) GO TO 220
IX(IN3) = K
GO TO 170
220 IN4 = I3SP + IX(IN3-1)
IF (IX(IN2)-IX(IN4)) 240,1710,230
230 IX(IN3) = K
GO TO 170
240 IX(IN3) = IX(IN3-1)
KKK = KKK + 1
GO TO 210
250 GO TO KK, (260,1570)
260 CONTINUE
C
C INITIALIZE
C
SR2FL = FILEU(1)
SR3FL = SR3FIL
JPOS = 1
PARM(2) = FILEA(1)
CALL FWDREC (*1690,FILEA(1))
LCOL = 0
CBCNT = 0
JPOSL = 0
270 IF (JPOS .GT. NCOL) GO TO 1670
C
C ****************************************************************
C READ NEXT COLUMN OF A INTO AREA II
C ****************************************************************
C
IOFF = MAX0(1,JPOS-BBBAR1)
COUNT = CBCNT
CALL INTPK (*1720,FILEA(1),0,CDP,0)
K = 1
IF (JPOS .GT. BBBAR) K = JPOS - B + 1
280 IF (EOL) 400,290,400
290 CALL ZNTPKI
IF (II .LT. K) GO TO 280
K = JPOS + BBAR
300 IF (II .GT. K) GO TO 330
C
C READ ELEMENTS WITHIN THE BAND INTO AREA II
C
IN1 = I2 + 2*(II-IOFF)
DX(IN1 ) = DA(1)
DX(IN1+1) = DA(2)
IF (DABS(DX(IN1 )) .LT. EPSI) DX(IN1 ) = 0.0D0
IF (DABS(DX(IN1+1)) .LT. EPSI) DX(IN1+1) = 0.0D0
310 IF (EOL) 400,320,400
320 CALL ZNTPKI
GO TO 300
C
C TAKE CARE OF ACTIVE ELEMENTS BELOW THE BAND
C
330 KK = 0
340 IN1 = I4SP + KK
IF (IX(IN1)-II) 350,360,350
350 KK = KK + 1
IF (KK-CBAR) 340,370,1710
C
C ADD IN ACTIVE ELEMENT TO EXISTING ROW
C
360 IN1 = I4 + 2*(KK+1)*BBBAR - 2
DX(IN1 ) = DA(1)
DX(IN1+1) = DA(2)
IF (DABS(DX(IN1 )) .LT. EPSI) DX(IN1 ) = 0.0D0
IF (DABS(DX(IN1+1)) .LT. EPSI) DX(IN1+1) = 0.0D0
GO TO 310
C
C CREATE NEW ACTIVE ROW
C
370 KK = 0
380 IN1 = I4SP + KK
IF (IX(IN1) .EQ. 0) GO TO 390
KK = KK + 1
IF (KK-CBAR) 380,1710,1710
390 IX(IN1) = II
IN1 = IN1 + CBAR
IX(IN1) = JPOS
IN1 = I4 + (KK+1)*BBBAR*2 - 2
DX(IN1 ) = DA(1)
DX(IN1+1) = DA(2)
IF (DABS(DX(IN1 )) .LT. EPSI) DX(IN1 ) = 0.0D0
IF (DABS(DX(IN1+1)) .LT. EPSI) DX(IN1+1) = 0.0D0
CBCNT = CBCNT + 1
GO TO 310
C
C ARRANGE ACTIVE ROW INDEXES IN SEQUENCE AND STORE THEM IN AREA VI
C
400 IF (COUNT .EQ. CBCNT) GO TO 500
IN1 = I6SP
K = 0
410 IN2 = I4SP + K
IF (IX(IN2)) 1710,430,440
420 IN1 = IN1 + 1
430 K = K + 1
IF (K-CBAR) 410,500,1710
440 IF (IN1 .NE. I6SP) GO TO 450
IX(IN1) = K
GO TO 420
450 KK = 0
460 IN3 = IN1 - KK
IF (IN3 .GT. I6SP) GO TO 470
IX(IN3) = K
GO TO 420
470 IN4 = I4SP + IX(IN3-1)
IF (IX(IN2)-IX(IN4)) 490,1710,480
480 IX(IN3) = K
GO TO 420
490 IX(IN3) = IX(IN3-1)
KK = KK + 1
GO TO 460
500 CONTINUE
C
C TEST FOR POSSIBLE MERGING BETWEEN AN INACTIVE-ACTIVE COLUMN AND
C THE CURRENT PIVOTAL COLUMN
C
IF (CCOUNT .EQ. 0) GO TO 600
IN1 = IX(I7SP) + I3SP
IF (IX(IN1)-JPOS) 1710,510,600
C
C MERGE ACTIVE COLUMN AND CURRENT PIVOTAL COLUMN AND ZERO THAT
C ACTIVE COLUMN IN AREA III
C
510 IX(IN1) = 0
IN1 = IN1 + C
IX(IN1) = 0
IN1 = I3 + IX(I7SP)*BBAR1*2
CCOUNT = CCOUNT - 1
KK = 0
520 IN2 = IN1 + KK + KK
IN3 = I2 + KK + KK
DX(IN3 ) = DX(IN3 ) + DX(IN2 )
DX(IN3+1) = DX(IN3+1) + DX(IN2+1)
DX(IN2 ) = 0.D0
DX(IN2+1) = 0.D0
KK = KK + 1
IF (KK-BBAR1) 520,530,1710
C
C MERGE INTERACTION ELEMENTS
C
530 CONTINUE
IF (CBCNT .EQ. 0) GO TO 580
IN1 = I5 + 2*IX(I7SP)*CBAR
K = 0
540 IN2 = I4SP + K
IF (IX(IN2) .EQ. 0) GO TO 560
IN3 = IN1 + 2*K
IF (DABS(DX(IN3)).LT.EPSI .AND. DABS(DX(IN3+1)).LT.EPSI)
1 GO TO 560
IF (IX(IN2) .GT. JPOS+BBAR) GO TO 570
C
C STORE ELEMENT WITHIN THE LOWER BAND
C
IN2 = I2 + 2*(IX(IN2)-IOFF)
DX(IN2 ) = DX(IN2 ) - DX(IN3 )
DX(IN2+1) = DX(IN2+1) - DX(IN3+1)
550 DX(IN3 ) = 0.D0
DX(IN3+1) = 0.D0
560 K = K + 1
IF (K-CBAR) 540,580,1710
C
C STORE ELEMENT IN THE ACTIVE ROW
C
570 IN2 = I4 + 2*(K+1)*BBBAR - 2
DX(IN2+1) = DX(IN2+1) - DX(IN3+1)
DX(IN3+1) = 0.D0
DX(IN2 ) = DX(IN2) - DX(IN3)
DX(IN3 ) = 0.D0
GO TO 550
C
C MOVE THE POINTERS IN AREA VII UP ONE
C
580 IN1 = I7SP + CCOUNT - 1
DO 590 I = I7SP,IN1
590 IX(I) = IX(I+1)
IX(IN1+1) = 0
600 IF (LCOL .EQ. 0) GO TO 830
C
C ****************************************************************
C OPERATE ON THE CURRENT COLUMN OF A BY ALL PREVIOUS COLUMNS OF L,
C MAKING NOTED INTERCHANGES AS YOU GO
C ****************************************************************
C
IF (SCRFLG .EQ. 0) GO TO 630
IF (LCOL-(R-1)) 630,620,610
610 PARM(2) = SR2FL
CALL OPEN (*1680,SR2FL,IX(SR2BUF),RD)
620 PARM(2) = SR3FL
CALL OPEN (*1680,SR3FL,IX(SR3BUF),WRTREW)
630 LL = 0
LLL = 0
LLLL = 0
C
C PICK UP INTERCHANGE INDEX FOR COLUMN JPOSL + LL + 1
C
640 IN1 = I1SP + LL
INTCHN = IX(IN1)
IN2 = I2 + LL + LL
IF (INTCHN .EQ. 0) GO TO 650
C
C PERFORM ROW INTERCHANGE
C
IN1 = IN2 + 2*INTCHN
DA( 1) = DX(IN1)
DX(IN1) = DX(IN2)
DX(IN2) = DA(1)
DA(1 ) = DX(IN1+1)
DX(IN1+1) = DX(IN2+1)
DX(IN2+1) = DA(1)
650 CONTINUE
C
C COMPUTE THE CONTRIBUTION FROM THAT COLUMN
C
END = MIN0(BBAR1,NCOL-(JPOSL+LL))
IF (DABS(DX(IN2)).LT.EPSI .AND. DABS(DX(IN2+1)).LT.EPSI)
1 GO TO 720
IN1 = I1 + 2*LLL*BBAR
CALL CLOOP (DX(IN2+2),DX(IN1),DX(IN2),END-1)
IF (CBCNT .EQ. 0) GO TO 720
C
C TEST TO SEE IF AN INACTIVE-ACTIVE ROW CONTRIBUTION SHOULD BE
C ADDED IN
C
KKK = 0
690 IN3 = I6SP + KKK
IN1 = IX(IN3) + I4SP
IF (IX(IN1) .GT. JPOS+BBAR) GO TO 720
KK = IN1 + CBAR
IF (IX(KK) .GT. JPOSL+LL+1) GO TO 710
IF (IX(IN1)-JPOSL-BBAR1 .LE. LL) GO TO 710
C
C ADD IN EFFECT OF THE INACTIVE-ACTIVE ROW
C
IN4 = I2 + 2*(IX(IN1)-IOFF)
K = I4 + 2*(JPOSL+BBBAR - JPOS+LL + IX(IN3)*BBBAR)
DX1 = DX(K )
DX2 = DX(K+1)
IF (DABS(DX1) .LT. EPSI) DX1 = 0.0D0
IF (DABS(DX2) .LT. EPSI) DX2 = 0.0D0
DX(IN4 ) = DX(IN4 ) - DX1*DX(IN2) + DX2*DX(IN2+1)
DX(IN4+1) = DX(IN4+1) - DX(IN2+1)*DX1 - DX(IN2)*DX2
IF (DABS(DX(IN4 )) .LT. EPSI) DX(IN4 ) = 0.0D0
IF (DABS(DX(IN4+1)) .LT. EPSI) DX(IN4+1) = 0.0D0
710 KKK = KKK + 1
IF (KKK .LT. CBCNT) GO TO 690
720 LL = LL + 1
LLL = LLL + 1
IF (LL .EQ. LCOL) GO TO 780
IF (LL-R+1) 640,730,760
730 IF (R .EQ. BBBAR1) GO TO 640
IN1 = I1 + 2*LL*BBAR
750 ICRQ = IN1 + BBAR*4 - 1 - SR3BUF
IF (ICRQ .GT. 0) GO TO 1715
IBBAR4 = BBAR*4
CALL READ (*1690,*1700,SR2FL,DX(IN1),IBBAR4,0,FLAG)
GO TO 640
760 IN1 = I1 + (LLL-1)*BBAR *2
IF (LL.EQ.R .AND. LCOL.EQ.BBBAR1) GO TO 770
CALL WRITE (SR3FL,DX(IN1),4*BBAR,0)
770 LLL = LLL - 1
GO TO 750
780 CONTINUE
C
C COMPUTE ELEMENTS FOR THE ACTIVE ROWS
C
IF (CBCNT .EQ. 0) GO TO 830
K = 0
790 IN1 = I4SP + K
IF (IX(IN1) .GT. JPOS+BBAR) GO TO 810
800 K = K + 1
IF (K-CBAR) 790,830,1710
810 IN1 = IN1 + CBAR
IF (IX(IN1) .EQ. JPOS) GO TO 800
KKK = MAX0(0,BBBAR-JPOS+IX(IN1)-1)
IN2 = I4 + 2*K*BBBAR - 2
IN3 = I2 + 2*(KKK-1-MAX0(0,BBBAR-JPOS))
IN1 = IN2 + 2*BBBAR
IN2 = IN2 + 2*KKK
820 IN2 = IN2 + 2
KKK = KKK + 1
IN3 = IN3 + 2
DX(IN1 ) = DX(IN1 ) - DX(IN2)*DX(IN3) + DX(IN2+1)*DX(IN3+1)
DX(IN1+1) = DX(IN1+1) - DX(IN2+1)*DX(IN3) - DX(IN2)*DX(IN3+1)
IF (DABS(DX(IN1 )) .LT. EPSI) DX(IN1 ) = 0.0D0
IF (DABS(DX(IN1+1)) .LT. EPSI) DX(IN1+1) = 0.0D0
IF (KKK-BBBAR1) 820,800,1710
C
C SEARCH THE LOWER BAND FOR THE MAXIMUM ELEMENT AND INTERCHANGE
C ROWS TO BRING IT TO THE DIAGONAL
C
830 K = 1
IN1 = I2 + (JPOS-IOFF)*2
DX1 = 0.D0
DX2 = 0.D0
IF (DABS(DX(IN1 )) .GT. EPSI) DX1 = DX(IN1 )**2
IF (DABS(DX(IN1+1)) .GT. EPSI) DX2 = DX(IN1+1)**2
MAX(1) = DX1 + DX2
INTCHN = 0
END = MIN0(BBAR1,NCOL-JPOS+1)
IF (END .EQ. 1) GO TO 870
840 IN2 = IN1 + K + K
DX1 = 0.D0
DX2 = 0.D0
IF (DABS(DX(IN2 )) .GT. EPSI) DX1 = DX(IN2 )**2
IF (DABS(DX(IN2+1)) .GT. EPSI) DX2 = DX(IN2+1)**2
DX2 = DX2 + DX1
IF (DX2 .GT. MAX(1)) GO TO 860
850 K = K + 1
IF (K-END) 840,870,1710
860 MAX(1) = DX2
INTCHN = K
GO TO 850
C
870 IF (INTCHN .EQ. 0) GO TO 880
C
C INTERCHANGE ROWS IN AREA II
C
DET(1) = -DET(1)
DET(2) = -DET(2)
C
MAX(1) = DX(IN1)
IN2 = IN1 + 2*INTCHN
DX(IN1) = DX(IN2)
DX(IN2) = MAX(1)
MAX(1) = DX(IN1+1)
DX(IN1+1) = DX(IN2+1)
DX(IN2+1) = MAX(1)
C
C STORE THE PERMUTATION INDEX
C
IN2 = I1SP + LCOL
IX(IN2) = INTCHN
C
C DIVIDE THE LOWER BAND BY THE DIAGONAL ELEMENT
C
880 DX1 = 0.D0
DX2 = 0.D0
IF (DABS(DX(IN1 )) .GT. EPSI) DX1 = DX(IN1 )**2
IF (DABS(DX(IN1+1)) .GT. EPSI) DX2 = DX(IN1+1)**2
DA(1) = DX1 + DX2
IF (DABS(DA(1)) .LT. EPSI) GO TO 1720
MAX(1) = DX(IN1 )/DA(1)
MAX(2) =-DX(IN1+1)/DA(1)
MINDIA = DMIN1(DSQRT(DA(1)),MINDIA)
DA(1) = DMAX1(DABS(DET(1)),DABS(DET(2)))
890 IF (DA(1) .LE. 10.D0) GO TO 900
DET(1) = DET(1)*.1D0
DET(2) = DET(2)*.1D0
DA(1) = DA(1) *.1D0
POWER = POWER + 1
GO TO 890
900 IF (DA(1).GE. .1D0) GO TO 910
DET(1) = DET(1)*10.D0
DET(2) = DET(2)*10.D0
DA(1) = DA(1) *10.D0
POWER = POWER - 1
GO TO 900
910 DA(1) = DET(1)*DX(IN1) - DET(2)*DX(IN1+1)
DET(2) = DET(2)*DX(IN1) + DET(1)*DX(IN1+1)
DET(1) = DA(1)
K = 1
END = MIN0(BBAR1,NCOL-JPOS+1)
IF (END .EQ. 1) GO TO 930
920 IN2 = IN1 + K + K
DA(1) = DX(IN2)*MAX(1) - DX(IN2+1)*MAX(2)
DX(IN2+1) = DX(IN2)*MAX(2) + DX(IN2+1)*MAX(1)
DX(IN2 ) = DA(1)
IF (DABS(DX(IN2 )) .LT. EPSI) DX(IN2 ) = 0.0D0
IF (DABS(DX(IN2+1)) .LT. EPSI) DX(IN2+1) = 0.0D0
K = K + 1
IF (K-END) 920,930,1710
930 IF (CBCNT .EQ. 0) GO TO 950
C
C DIVIDE THE ACTIVE ROWS BY THE DIAGONAL
C
K = 0
IN1 = I4 + 2*BBBAR1
940 DA( 1) = DX(IN1)*MAX(1) - DX(IN1+1)*MAX(2)
DX(IN1+1) = DX(IN1)*MAX(2) + DX(IN1+1)*MAX(1)
DX(IN1 ) = DA(1)
IF (DABS(DX(IN1 )) .LT. EPSI) DX(IN1 ) = 0.0D0
IF (DABS(DX(IN1+1)) .LT. EPSI) DX(IN1+1) = 0.0D0
IN1 = IN1 + 2*BBBAR
K = K + 1
IF (K-CBAR) 940,950,1710
950 CONTINUE
C
C INTERCHANGE ACTIVE COLUMNS AND ADD IN EFFECT OF THE CURRENT COLUMN
C
IF (CCOUNT .EQ. 0) GO TO 1000
IF (JPOS .LT. BBBAR) GO TO 1000
INTCH = IX(I1SP)
K = 0
960 IN1 = I3SP + K
IF (INTCH .EQ. 0) GO TO 970
IN1 = I3 + 2*K*BBAR1
IN2 = IN1 + INTCH + INTCH
DA( 1) = DX(IN1)
DX(IN1) = DX(IN2)
DX(IN2) = DA(1)
DA(1 ) = DX(IN1+1)
DX(IN1+1) = DX(IN2+1)
DX(IN2+1) = DA(1)
970 KK = 1
IN2 = I1 - 2
IN1 = I3 + 2*K*BBAR1
IF (DABS(DX(IN1)).LT.EPSI .AND. DABS(DX(IN1+1)).LT.EPSI)
1 GO TO 990
980 IN3 = IN1 + KK + KK
IN4 = IN2 + KK + KK
DX(IN3 ) = DX(IN3 ) - DX(IN1)*DX(IN4) + DX(IN1+1)*DX(IN4+1)
DX(IN3+1) = DX(IN3+1) - DX(IN1)*DX(IN4+1) - DX(IN1+1)*DX(IN4)
IF (DABS(DX(IN3 )) .LT. EPSI) DX(IN3 ) = 0.0D0
IF (DABS(DX(IN3+1)) .LT. EPSI) DX(IN3+1) = 0.0D0
KK = KK + 1
IF (KK-BBAR1) 980,990,1710
990 K = K + 1
IF (K-C) 960,1000,1710
C
C WRITE OUT THE NEXT COLUMN OF U AND THE ROW OF ACTIVE ELEMENTS
C
1000 PARM(2) = SR2FIL
CALL BLDPK (CDP,TYPEL,SR2FIL,0,0)
IN1 = I2
JJ = IOFF
1010 DZ(1) = DX(IN1 )
DZ(2) = DX(IN1+1)
IF (DABS(DZ(1)).LT.EPSI .AND. DABS(DZ(2)).LT.EPSI) GO TO 1030
CALL ZBLPKI
1030 IN1 = IN1 + 2
JJ = JJ + 1
IF (JJ-JPOS) 1010,1010,1040
1040 IF (DABS(DX(IN1-2)).LT.EPSI .AND. DABS(DX(IN1-1)).LT.EPSI)
1 GO TO 1720
C
C PACK ACTIVE COLUMN ELEMENTS ALSO
C
IF (CCOUNT .EQ. 0) GO TO 1090
IF (JPOS .LT. BBBAR) GO TO 1090
K = 0
1060 IN1 = I7SP + K
IN2 = IX(IN1) + I3SP
GO TO 1080
1070 K = K + 1
IF (K-CCOUNT) 1060,1090,1710
1080 IN3 = I3 + 2*(IX(IN1)*BBAR1)
DZ(1) = DX(IN3 )
DZ(2) = DX(IN3+1)
IF (DABS(DZ(1)).LT.EPSI .AND. DABS(DZ(2)).LT.EPSI) GO TO 1070
JJ = IX(IN2)
CALL ZBLPKI
GO TO 1070
1090 CALL BLDPKN (SR2FIL,0,FILEU)
C
C COMPUTE ACTIVE ROW-COLUMN INTERACTION
C
IF (CCOUNT.EQ.0 .OR. CBCNT.EQ.0) GO TO 1140
IF (JPOS .LT. BBBAR) GO TO 1140
K = 0
1100 CONTINUE
IN1 = I3 + 2*K*BBAR1
IF (DABS(DX(IN1)).LT.EPSI .AND. DABS(DX(IN1+1)).LT.EPSI)
1 GO TO 1130
KK = 0
1110 IN2 = I4 + 2*KK*BBBAR
IF (DABS(DX(IN2)).LT.EPSI .AND. DABS(DX(IN2+1)).LT.EPSI)
1 GO TO 1120
IN3 = I5 + 2*(K*CBAR+KK)
DX(IN3 ) = DX(IN3 ) + DX(IN2)*DX(IN1) - DX(IN2+1)*DX(IN1+1)
DX(IN3+1) = DX(IN3+1) + DX(IN2)*DX(IN1+1) + DX(IN2+1)*DX(IN1)
IF (DABS(DX(IN3 )) .LT. EPSI) DX(IN3 ) = 0.0D0
IF (DABS(DX(IN3+1)) .LT. EPSI) DX(IN3+1) = 0.0D0
1120 KK = KK + 1
IF (KK-CBAR) 1110,1130,1710
1130 K = K + 1
IF (K-C) 1100,1140,1710
C
C MOVE ELEMENTS IN AREA III UP ONE CELL
C
1140 IF (CCOUNT .EQ. 0) GO TO 1190
IF (JPOS .LT. BBBAR) GO TO 1190
K = 0
1150 IN1 = I3SP + K
IF (IX(IN1) .EQ. 0) GO TO 1180
KK = 0
IN1 = I3 + 2*K*BBAR1
1160 IN2 = IN1 + KK + KK
DX(IN2 ) = DX(IN2+2)
DX(IN2+1) = DX(IN2+3)
KK = KK + 1
IF (KK-BBAR) 1160,1170,1710
1170 DX(IN2+2) = 0.D0
DX(IN2+3) = 0.D0
1180 K = K + 1
IF (K-C) 1150,1190,1710
C
C
C DETERMINE IF A COLUMN OF L CAN BE WRITTEN OUT
C
1190 IF (LCOL-BBBAR1) 1370,1200,1200
C
C OUTPUT A COLUMN OF L
C
1200 PARM(2) = FILEL(1)
JPOSL = JPOSL + 1
CALL BLDPK (CDP,TYPEL,FILEL(1),0,0)
C
C STORE THE PERMUTATION INDEX AS THE DIAGONAL ELEMENT
C
JJ = JPOSL
DZ(1) = IX(I1SP)
DZ(2) = 0.D0
CALL ZBLPKI
K = 0
1210 JJ = JPOSL + K + 1
IN2 = I1 + K + K
DZ(1) = DX(IN2 )
DZ(2) = DX(IN2+1)
IF (DABS(DZ(1)).LT.EPSI .AND. DABS(DZ(2)).LT.EPSI) GO TO 1230
CALL ZBLPKI
1230 K = K + 1
IF (K-BBAR) 1210,1240,1710
C
C PACK ACTIVE ROW ELEMENTS ALSO
C
1240 IF (CBCNT .EQ. 0) GO TO 1280
K = 0
1250 IN1 = I6SP + K
IN2 = I4 + (IX(IN1)*BBBAR)*2
IN1 = IX(IN1) + I4SP
JJ = IX(IN1)
DZ(1) = DX(IN2 )
DZ(2) = DX(IN2+1)
IF (DABS(DZ(1)).LT.EPSI .AND. DABS(DZ(2)).LT.EPSI) GO TO 1270
CALL ZBLPKI
1270 K = K + 1
IF (K-CBCNT) 1250,1280,1710
1280 CALL BLDPKN (FILEL,0,FILEL)
C
C MOVE PERMUTATION INDICES OVER ONE ELEMENT
C
END = I1SP + LCOL
DO 1290 I = I1SP,END
1290 IX(I) = IX(I+1)
C
C MOVE ELEMENTS IN AREA I OVER ONE COLUMN
C
K = 0
IF (SCRFLG .EQ. 0) GO TO 1310
CALL CLOSE (SR2FL,REW)
CALL OPEN (*1680,SR2FL,IX(SR2BUF),RD)
IF (R .GT. 2) GO TO 1310
ICRQ = I1 + BBAR*4 - 1 - SR3BUF
IF (ICRQ .GT. 0) GO TO 1715
IBBAR4 = BBAR*4
CALL READ (*1690,*1700,SR2FL,DX(I1),IBBAR4,0,FLAG)
GO TO 1360
1310 IN1 = I1 + K*BBAR*2
IN2 = IN1 + BBAR+BBAR
CALL CXLOOP (DX(IN1),DX(IN2),BBAR)
K = K + 1
IF (K-R+2) 1310,1340,1360
1340 IF (R-BBBAR1) 1350,1310,1710
1350 ICRQ = IN2 + BBAR*4 - 1 - SR3BUF
IF (ICRQ .GT. 0) GO TO 1715
IBBAR4 = BBAR*4
CALL READ (*1690,*1700,SR2FL,DX(IN2),IBBAR4,0,FLAG)
1360 LCOL = LCOL - 1
C
C STORE CURRENT COLUMN OF L
C
1370 IF (CBCNT .EQ. 0) GO TO 1420
C
C MOVE ELEMENTS IN AREA IV UP ONE CELL
C
K = 0
1380 IN1 = I4SP + K
IF (IX(IN1) .EQ. 0) GO TO 1410
KK = 0
IN1 = I4 + 2*K*BBBAR
1390 IN2 = IN1 + KK+KK
DX(IN2 ) = DX(IN2+2)
DX(IN2+1) = DX(IN2+3)
KK = KK + 1
IF (KK-BBBAR1) 1390,1400,1710
1400 DX(IN2+2) = 0.D0
DX(IN2+3) = 0.D0
1410 K = K + 1
IF (K-CBAR) 1380,1420,1710
1420 IF (SCRFLG .NE. 0) GO TO 1450
C
C STORE COLUMN IN CORE
C
1430 IN1 = I1 + 2*LCOL*BBAR
END = MIN0(BBAR,NCOL-JPOS)
IF (END .EQ. 0) GO TO 1480
K = 0
IN3 = I2 + 2*(JPOS-IOFF+1)
1440 IN2 = IN1 + K + K
IN4 = IN3 + K + K
DX(IN2 ) = DX(IN4 )
DX(IN2+1) = DX(IN4+1)
K = K + 1
IF (K-END) 1440,1480,1710
C
C STORE COLUMN ON THE SCRATCH FILE
C
1450 IF (LCOL-R+1) 1430,1470,1460
1460 IN1 = I1 + (LLL-1)*BBAR*2
CALL WRITE (SR3FL,DX(IN1),BBAR*4,0)
1470 IN1 = I2 + 2*(JPOS-IOFF+1)
CALL WRITE (SR3FL,DX(IN1),BBAR*4,0)
C
C CLOSE SCRATCH FILES AND SWITCH THE POINTERS TO THEM
C
CALL CLOSE (SR3FL,REW)
CALL CLOSE (SR2FL,REW)
IN1 = SR2FL
SR2FL = SR3FL
SR3FL = IN1
1480 LCOL = LCOL + 1
IF (C .EQ. 0) GO TO 1570
IF (JPOS .LT . BBBAR) GO TO 1570
C
C READ IN THE NEXT ROW OF ACTIVE COLUMN ELEMENTS
C
COUNT = CCOUNT
IF (ITRN .LT. 0) GO TO 1570
1490 IF (ITRN .GT. JPOS-B+2) GO TO 1560
C
C TEST TO SEE IF COLUMN IS ALREADY ACTIVE
C
K = 0
1500 IN1 = I3SP + K
IF (IX(IN1) .EQ. JTRN) GO TO 1540
K = K + 1
IF (K-C) 1500,1510,1710
C
C CREATE A NEW ACTIVE COLUMN
C
1510 K = 0
1520 IN1 = I3SP + K
IF (IX(IN1) .EQ. 0) GO TO 1530
K = K + 1
IF (K-C) 1520,1710,1710
1530 IX(IN1) = JTRN
IN1 = IN1 + C
IX(IN1) = ITRN
IN1 = I3 + 2*(K+1)*BBAR1 - 2
DX(IN1 ) = DTRN(1)
DX(IN1+1) = DTRN(2)
IF (DABS(DX(IN1 )) .LT. EPSI) DX(IN1 ) = 0.0D0
IF (DABS(DX(IN1+1)) .LT. EPSI) DX(IN1+1) = 0.0D0
CCOUNT = CCOUNT + 1
GO TO 1550
C
C STORE ELEMENT IN EXISTING COLUMN
C
1540 IN1 = I3 + 2*(K+1)*BBAR1 - 2
DX(IN1 ) = DX(IN1 ) + DTRN(1)
DX(IN1+1) = DX(IN1+1) + DTRN(2)
1550 CALL READ (*1690,*1700,SR1FIL,ITRAN(1),6,0,FLAG)
IF (ITRN .GT. 0) GO TO 1490
CALL CLOSE (SR1FIL,REW)
1560 IF (CCOUNT .EQ. COUNT) GO TO 1570
C
C RE-ARRANGE INDEXES IN SEQUENTIAL ORDER
C
ASSIGN 1570 TO KK
GO TO 150
1570 CONTINUE
JPOS = JPOS + 1
C
C ZERO AREA II
C
END = I2 + 2*MIN0(JPOS-IOFF+BBAR-1,NCOL-1) + 1
DO 1590 I = I2,END
1590 DX(I) = 0.D0
C
C TEST TO SEE IF ROW INTERACTION ELEMENTS WILL MERGE INTO AREA III
C
IF (CBCNT .EQ. 0) GO TO 270
IF (CCOUNT .EQ. 0) GO TO 1640
IF (JPOS-1 .LT. BBBAR) GO TO 270
IN1 = I4SP
K = 0
1600 IN2 = IN1 + K
IF (IX(IN2) .EQ. JPOS-B+1) GO TO 1610
K = K + 1
IF (K .LT. CBAR) GO TO 1600
GO TO 270
1610 IN1 = I5 + K + K
IN2 = I3 + BBAR + BBAR
K = 0
1620 DX(IN2 ) = DX(IN2 ) - DX(IN1 )
DX(IN2+1) = DX(IN2+1) - DX(IN1+1)
DX(IN1 ) = 0.D0
DX(IN1+1) = 0.D0
IN2 = IN2 + BBAR1 + BBAR1
IN1 = IN1 + CBAR + CBAR
K = K + 1
IF (K .LT. C) GO TO 1620
C
C TEST TO SEE IF A ACTIVE ROW HAS BEEN ELIMINATED
C
1640 IN1 = IX(I6SP) + I4SP
IF (IX(IN1)-JPOSL-BBAR1) 270,1650,270
C
C ELIMINATE THE ACTIVE ROW
C
1650 IX(IN1) = 0
IN1 = IN1 + CBAR
IX(IN1) = 0
CBCNT = CBCNT - 1
C
C MOVE INDEXES IN AREA VI UP ONE
C
IN1 = I6SP + CBCNT - 1
DO 1660 I = I6SP,IN1
1660 IX(I) = IX(I+1)
IX(IN1+1) = 0
GO TO 270
C
C FINISH WRITING OUT THE COMPLETED COLUMNS OF L
C
1670 CALL CLOSE (SR1FIL,REW)
CALL CLOSE (FILEL,NOREW)
CALL CLOSE (SR2FIL,NOREW)
CALL COMFIN (ITERM,SCRFLG,SR2FL,JPOSL,I1SP,BBAR,I1,CBCNT,IPAK,R,
1 BBBAR1,BBBAR,I6SP,I4,I4SP,IX,DX,X,LCOL)
PARM(5) = IEND
CALL CONMSG (PARM(3),3,0)
FILEU(7) = BBBAR
RETURN
C
C ERROR EXITS
C
1680 PARM(1) = -1
GO TO 1730
1690 PARM(1) = -2
GO TO 1730
1700 PARM(1) = -3
GO TO 1730
1710 PARM(1) = -25
GO TO 1730
1715 PARM(1) = -8
PARM(2) = ICRQ
GO TO 1730
C
C SINGULAR MATRIX - CLOSE ALL FILES AND RETURN TO USER
C
1720 CALL CLOSE (FILEA(1),REW)
CALL CLOSE (FILEL(1),REW)
CALL CLOSE (FILEU(1),REW)
CALL CLOSE (SR1FIL,REW)
CALL CLOSE (SR2FIL,REW)
CALL CLOSE (SR3FIL,REW)
FILEU(2) = BBBAR
RETURN 1
C
1730 CALL MESAGE (PARM(1),PARM(2),PARM(3))
RETURN
END
|
