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
|
SUBROUTINE CMDISC
C
C THIS SUBROUTINE DETERMINES THE DISCONNECTED DEGREES OF FREEDOM
C AND GENERATES DISCONNECTION ENTRIES WHICH ARE MERGED WITH THE
C CONNECTION ENTRIES
C
EXTERNAL ORF
INTEGER SCSFIL,Z,SCORE,COMBO,IPTR(7),SCCONN,BUF3,CE(9),
1 ORF,SCDISC,DE(9),AAA(2),SCR1,SCR2,BUF2,OUTT
COMMON /CMB001/ SCR1,SCR2,SCBDAT,SCSFIL,SCCONN,SCMCON,SCTOC,
1 GEOM4,CASECC
COMMON /CMB002/ BUF1,BUF2,BUF3,BUF4,BUF5,SCORE,LCORE,INPT,OUTT
COMMON /CMB003/ COMBO(7,5),CONSET,IAUTO,TOLER,NPSUB
COMMON /CMB004/ TDAT(6),NIPNEW
COMMON /ZZZZZZ/ Z(1)
DATA AAA / 4HCMDI,4HSC /
C
C
NWD = NPSUB+2
ISVCOR = SCORE
ITOT = 0
ILEN = LCORE
NN = 0
KK = SCORE
CALL OPEN (*200,SCSFIL,Z(BUF3),0)
C
C LOOP ON THE NUMBER OF PSEUDO STRUCTURES READING THE SIL,C TABLE
C INTO CORE FOR EACH. THE ARRAY IPTR(I) POINTS TO THE START OF
C THE I-TH TABLE IN CORE
C
DO 40 I = 1,NPSUB
NCSUB = COMBO(I,5)
C
C FIND SIL, C TABLE
C
DO 10 J = 1,NCSUB
CALL FWDREC (*210,SCSFIL)
10 CONTINUE
KK = KK + NN
IPTR(I) = KK
CALL READ (*210,*20,SCSFIL,Z(KK),LCORE,1,NN)
GO TO 220
C
C ZERO OUT SIL VALUES, LOCATION WILL STORE CNEW
C
20 DO 30 J = 1,NN,2
Z(KK+J-1) = 0
30 CONTINUE
LCORE = LCORE - NN
ITOT = ITOT + NN
CALL SKPFIL (SCSFIL,1)
40 CONTINUE
CALL CLOSE (SCSFIL,1)
C
C ALL EQSS HAVE BEEN PROCESSED, NOW SCAN THE CONNECTION ENTRIES
C AND GET CNEW VALUES.
C
CALL OPEN (*200,SCCONN,Z(BUF3),0)
C
C READ AND PROCESS CONNECTION ENTRIES ONE AT A TIME
C
50 CALL READ (*80,*60,SCCONN,CE,10,1,NN)
60 DO 70 I = 1,NPSUB
IF (CE(2+I) .EQ. 0) GO TO 70
C
C TRANSLATE CODED IP TO ACTUAL IP, COMPUTE LOCATION IN OPEN CORE
C AND UPDATE CNEW
C
IP = CE(2+I) - 1000000*(CE(2+I)/1000000)
LOC = IPTR(I) + 2*IP - 2
Z(LOC) = ORF(Z(LOC),CE(1))
70 CONTINUE
GO TO 50
C
C ALL CONNECTIONS HAVE BEEN ACCOUNTED FOR,NOW DETERMINE DISCONN.
C
80 CONTINUE
SCDISC = SCR1
IF (SCR1 .EQ. SCCONN) SCDISC = SCR2
CALL OPEN (*200,SCDISC,Z(BUF2),1)
DO 130 I = 1,NPSUB
IF (I .LT. NPSUB) LEN = IPTR(I+1) - IPTR(I)
IF (I .EQ. NPSUB) LEN = ITOT - IPTR(I)
ISTRT = IPTR(I)
DO 120 J = 1,LEN,2
DO 90 KDH = 1,9
DE(KDH) = 0
90 CONTINUE
IP = J/2 + 1
LOC = ISTRT + J - 1
C
C POINT IS TOTALLY DISCONNECTED
C
IF (Z(LOC) .EQ. Z(LOC+1)) GO TO 120
IF (Z(LOC) .NE. 0) GO TO 100
C
C POINT IS TOTALLY CONNECTED
C
DE(1) = Z(LOC+1)
DE(2) = 2**I
DE(2+I) = IP
GO TO 110
C
C POINT IS PARTIALLY DISCONNECTED
C
100 DE(1) = Z(LOC+1) - Z(LOC)
DE(2) = 2**I
DE(2+I) = IP
110 CALL WRITE (SCDISC,DE,NWD,1)
120 CONTINUE
130 CONTINUE
CALL EOF (SCDISC)
CALL CLOSE (SCDISC,1)
KK = SCORE
LCORE = ILEN
CALL OPEN (*200,SCDISC,Z(BUF2),0)
CALL REWIND (SCCONN)
ID = 1
140 CALL READ (*150,*160,SCDISC,Z(KK),LCORE,1,NNN)
GO TO 220
150 ID = 2
CALL READ (*170,*160,SCCONN,Z(KK),LCORE,1,NNN)
GO TO 220
160 KK = KK + NWD
LCORE = LCORE - NWD
IF (LCORE .LT. NWD) GO TO 220
IF (ID .EQ. 1) GO TO 140
GO TO 150
170 CALL CLOSE (SCCONN,1)
CALL CLOSE (SCDISC,1)
CALL OPEN (*200,SCCONN,Z(BUF3),1)
LEN = KK - SCORE
NIPNEW = LEN/NWD
DO 180 I = 1,LEN,NWD
Z(SCORE+I) = IABS(Z(SCORE+I))
180 CONTINUE
CALL SORT (0,0,NWD,2,Z(SCORE),LEN)
DO 190 I = 1,LEN,NWD
CALL WRITE (SCCONN,Z(SCORE+I-1),NWD,1)
190 CONTINUE
CALL EOF (SCCONN)
CALL CLOSE (SCCONN,1)
CALL CLOSE (SCDISC,1)
SCORE = ISVCOR
LCORE = ILEN
RETURN
C
200 IMSG = -1
GO TO 230
210 IMSG = -2
GO TO 230
220 IMSG = -8
230 CALL MESAGE (IMSG,IFILE,AAA)
RETURN
END
|
