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
|
SUBROUTINE AMPB(PHIDH,GTKA,D1JK,D2JK,D1JE,D2JE,USETA,
1 DJH1,DJH2,GKI,SCR1,SCR2,SCR3)
C
C THE PURPOSE OF THIS SUBROUTINE IS TO SOLVE FOR THE DJH MATRICES.
C IT ALSO COMPUTES GKI FOR LATER USE.
C THE STEPS ARE,
C
C 1. PHIDH GOES TO 1 1 1
C 1 PHIA 1 1
C 1 ----- 1 ---- 1
C 1 1 1
C 1 1 1
C
C 2. GKI =GTKA$PHIA
C
C 3. DJI1=D1JK*GKI
C 4. DJI2=D2JK*GKI
C 5.
C 6. DJH1= 1 DJI1 1 D1JE 1
C 1 1 1
C 7. DJH2= 1 DJI2 1 D2JE 1
C
C
C
INTEGER PHIDH,GTKA,D1JK,D2JK,D1JE,D2JE,USETA,DJH1,DJH2,GKI,
1 SCR1,SCR2,SCR3,PHIA,DJI1,DJI2,MCB(7),UD,UA,UE
C
COMMON /BLANK/NOUE
COMMON /PATX/LC,NS0,NS1,NS2,IUSET
COMMON /BITPOS/UM,UO,UR,USG,USB,UL,UA,UF,US,UN,UG,UE,UP,UNE,UFE,UD
1 ,UPS,USA,UK,UPA
COMMON/ZZZZZZ/Z(1)
COMMON/SYSTEM/SYSBUF,NOUT,SKIP(52),IPREC
COMMON /AMPCOM/ NCOLJ
C
C-----------------------------------------------------------------------
C
MCB(1)=PHIDH
CALL RDTRL(MCB)
NOH=MCB(2)
C
C DETERMINE IF PHIDH MUST BE MODIFIED
C
IF(NOUE.EQ.-1)GO TO 20
C
C BUILD PARTITIONING VECTORS
C
IUSET = USETA
LC=KORSZ(Z)
CALL CALCV(SCR1,UD,UA,UE,Z)
CALL AMPB1(SCR2,NOH-NOUE,NOUE)
C
C PERFORM PARTITION
C RP CP
CALL AMPB2(PHIDH,SCR3,0,0,0,SCR2,SCR1,0,0)
PHIA=SCR3
GO TO 30
C
C NO MOD REQUIRED
C
20 PHIA=PHIDH
30 CONTINUE
C
C COMPUTE GKI
C
CALL SSG2B(GTKA,PHIA,0,GKI,1,IPREC,1,SCR1)
C
C START COMPUTATION OF DJH MATRICES
C
DJI1=SCR3
DJI2=SCR3
IF(NOUE.GT.0)GO TO 40
DJI1=DJH1
DJI2=DJH2
40 CONTINUE
CALL SSG2B(D1JK,GKI,0,DJI1,1,IPREC,1,SCR1)
IF(NOUE.EQ.-1)GO TO 50
CALL MERGED(DJI1,D1JE,0,0,DJH1,SCR2,0,0,NCOLJ)
50 CONTINUE
CALL SSG2B(D2JK,GKI,0,DJI2,1,IPREC,1,SCR1)
IF(NOUE.EQ.-1)GO TO 60
CALL MERGED(DJI2,D2JE,0,0,DJH2,SCR2,0,0,NCOLJ)
60 CONTINUE
RETURN
END
|
