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
|
SUBROUTINE AMP
C
C THIS IS THE DMAP DRIVER FOR AMP
C
C DMAP CALLING SEQUENCE
C
C AMP AJJL,SKJ,D1JK,D2JK,GTKA,PHIDH,D1JE,D2JE,USETA,AERO/
C QHHL,QJHL/V,N,NOVE/V,N,XQHHL $
C
C D1JE AND D2JE MAY BE PURGED
C
C QHHL AND QJHL ARE APPEND TYPE FILES
C
C QJHL MAY BE PURGED
C
C DATA BLOCK ASSIGNMENTS COMPUTED BY USE
C
C SCR1 --OLD QHHL AMPA A,D
C SCR2 --OLD QJHL AMPA A,C
C SCR3 --INDEX OF WORK TO BE DONE AMPA A,MOD
C SCR4 --DJH1 AMPB B,C
C SCR5 --DJH2 AMPB B,C
C SCR6 --GKI AMPB B,D
C SCR7 --DJH AMPC C,C
C SCR8 --QJHUA AMPC C,D
C SCR9 --SCRATCH FILE B,C,D
C SCR10 --SCRATCH FILE B,C,D
C SCR11 --SCRATCH FILE B,C,D
C SCR12 --SCRATCH FILE C
C SCR13 --SCRATCH FILE C
C SCR14 --SCRATCH FILE C
C
C VARIABLES
C NAME MEANING
C ------- ---------------
C NCOL NUMBER OF COLUMNS IN SUBMATRIX OF AJJL
C NSUB ACTUAL NUMBER OF SUBMATRICES ON AJJL
C XM CURRENT M
C XK CURRENT K
C AJJCOL COLUMN NUMBER IN AJJL WHERE CURRENT SUBMATRIX STARTS
C QHHCOL COLUMN NUMBER IN QHH AND QJH WHERE SUBMATRIX STARTS
C 0 MEANS RECOMPUTE
C NGP NUMBER OF GROUPS IN AJJL
C NGPD PAIRS FOR EACH GROUP - 1--THEORY -1 =D.L.
C 2--NUMBER OF COLUM
C 2--NUMBER OF COLS IN GROUP
C NOH NUMBER OF H D.O.F.
C IDJH FLAG TO RECOMPUTE DJH IF K CHANGES
C IMAX NUMBER OF M-K PAIRS
C IANY FLAG TO INDICATE SOME CALCULATION MUST BE PERFORMED
C ITL MAXIMUM TIME FOR ANY LOOP
C XKO OLD VALUE OF K
C
C
INTEGER AJJL,SKJ,D1JK,D2JK,GTKA,PHIDH,D1JE,D2JE,USETA,AERO,QHHL,
1 QJHL, SCR1,SCR2,SCR3,SCR4,SCR5,SCR6,SCR7, SCR8,SCR9,
2 SCR10,SCR11,SCR12,SCR13,SCR14,SYSBUF,XQHHL,AJJCOL,QHHCOL,
3 MCB(7),NAME(2)
INTEGER QHJL
COMMON /SYSTEM/SYSBUF,NOUT
COMMON /BLANK/NOUE,XQHHL,IGUST
COMMON /AMPCOM/NCOL,NSUB,XM,XK,AJJCOL,QHHCOL,NGP,NGPD(2,30),
1 MCBQHH(7),MCBQJH(7),NOH,IDJH
1 ,MCBRJH(7)
COMMON /CDCMPX/ISK(32),IB,IBBAR
COMMON /ZZZZZZ/ IZ(1)
DATA AJJL,SKJ,D1JK,D2JK,GTKA,PHIDH,D1JE,D2JE,USETA,AERO/
1 101 ,102 ,103 ,104 ,105 ,106 ,107 ,108 ,109 ,110 /
DATA QHHL,QJHL,NAME /201,202,4HAMP ,1H /
DATA QHJL /203/
DATA SCR1,SCR2,SCR3,SCR4,SCR5,SCR6,SCR7,SCR8,SCR9,SCR10,SCR11,
1SCR12,SCR13,SCR14/301,302,303,304,305,306,307,308,309,310,311,312,
2 313,314 /
C
C INITIALIZE
C
IBUF1 = KORSZ(IZ) -SYSBUF+1
MCB(1) = PHIDH
CALL RDTRL(MCB(1))
NOH=MCB(2)
MCBRJH(1)=QHJL
IB = 0
IBBAR = 0
C
C BUILD INDEXES
C
CALL AMPA(AERO,QJHL,QHHL,AJJL,SCR1,SCR2,SCR3,IMAX,IANY)
C
C COMPUTE DJH AND GKI
C
C
C IF NO NEW VALUES ARE TO BE COMPUTED SKIP AMPB
C
IF(IANY.NE.0)GO TO 90
CALL AMPB(PHIDH,GTKA,D1JK,D2JK,D1JE,D2JE,USETA,SCR4,SCR5,SCR6,
1 SCR9,SCR10,SCR11)
90 CONTINUE
C
C LOOP ON MK PAIRS
C
XKO=-1.0
IOP=0
ITL=0
DO 100 I = 1, IMAX
CALL KLOCK(ITS)
CALL GOPEN(SCR3,IZ(IBUF1),IOP)
IOP=2
CALL FREAD(SCR3,XM,4,1)
CALL CLOSE(SCR3,2)
C
C COMPUTE QJH
C
IDJH=0
IF(XK.EQ.XKO)IDJH=1
CALL AMPC(SCR4,SCR5,SCR7,AJJL,QJHL,SCR2,SCR8,SCR9,SCR10,SCR11,
1 SCR12,SCR13,SCR14)
IF(QHHCOL .EQ. 0) XKO = XK
C
C COMPUTE QHH
C
IF(MCBQHH(1).LE.0)GO TO 50
CALL AMPD(SCR8,SCR1,SKJ,SCR6,QHHL,SCR9,SCR10,SCR11,SCR12)
50 CONTINUE
IF(I.EQ.IMAX)GO TO 100
C
C CHECK TIME
C
CALL KLOCK(ITF)
CALL TMTOGO(ITMTO)
ITL=MAX0(ITF-ITS,1,ITL)
IF(1.1*ITL.GE.ITMTO)GO TO 200
100 CONTINUE
C
C FINISH UP
C
110 IF(MCBQHH(1).GT.0)CALL WRTTRL(MCBQHH)
IF(MCBQJH(1).GT.0)CALL WRTTRL(MCBQJH)
XQHHL=-1
IF(IGUST .LE. 0) RETURN
C
C COMPUTE QHJL
C NOTE QHJL IS REALLY QJHL
C
C FIRST COMPUTE GKH ONTO SCR4
C
C
CALL AMPE(PHIDH,GTKA,SCR4,SCR5,SCR6,USETA)
C
C LOOP ON GROUPS WITHIN MK PAIRS FOR QHJL
C
CALL AMPF(SKJ,SCR4,AJJL,QHJL,SCR3,IMAX,SCR5,SCR6,SCR7,SCR8,SCR9,
1 SCR10,SCR11,SCR12,SCR13,SCR1)
RETURN
C
C INSUFFICIENT TIME TO COMPLETE
C
200 CALL MESAGE(45,IMAX-I,NAME)
GO TO 110
END
|
