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
|
SUBROUTINE SETLVL (NEWNM,NUMB,OLDNMS,ITEST,IBIT)
C
C CREATES A NEW SUBSTRUCTURE NEWNM WHERE
C - NEWNM IS AN INDEPENDENT SUBSTRUCTURE IF NUMB = 0
C - NEWNM IS REDUCED FROM THE FIRST SUBSTRUCTURE IN THE ARRAY OLDNMS
C - NEWNM RESULTS FROM COMBINING THE FIRST I SUBSTRUCTURES IN THE
C ARRAY OLDNMS IF NUMB = I
C
C THE OUTPUT VARIABLE ITEST TAKES ON ONE OF THE FOLLOWING VALUES
C 4 IF ONE OR MORE SUBSTRUCTURES IN OLDNMS DO NOT EXIST
C 7 IF NEWNM ALREADY EXISTS
C 8 IF ONE OF THE SUBSTRUCTURES IN OLDNMS HAS ALREADY
C BEEN USED IN A REDUCTION OR COMBINATION
C 1 OTHERWISE
C
C IF ITEST IS SET TO 4, NUMB WILL BE SET TO THE NUMBER OF
C SUBSTRUCTURES IN OLDNMS THAT DO NOT EXIST AND THE FIRST NUMB NAMES
C IN OLDNMS WILL BE SET TO THE NAMES OF THOSE SUBSTRUCTURES THAT DO
C NOT EXIST. BIT IBIT OF THE FIRST MDI WORD IS SET TO INDICATE THE
C APPROPRIATE TYPE OF SUBSTRUCTURE. IF IBIT IS ZERO NO CHANGE IS
C MADE TO THE MDI
C
IMPLICIT INTEGER (A-Z)
EXTERNAL LSHIFT,ANDF,ORF,COMPLF
LOGICAL DITUP,MDIUP
DIMENSION NEWNM(2),OLDNMS(14),IOLD(7),NMSBR(2)
COMMON /ZZZZZZ/ BUF(1)
COMMON /SOF / DIT,DITPBN,DITLBN,DITSIZ,DITNSB,DITBL,
1 IODUM(8),MDI,MDIPBN,MDILBN,MDIBL,
2 NXTDUM(15),DITUP,MDIUP
DATA IEMPTY/ 4H /, NMSBR / 4HSETL,4HVL /
DATA LL,CS , HL / 2,2,2 /
DATA IB / 1 /
C
CALL CHKOPN (NMSBR(1))
ITEST = 1
CALL FDSUB (NEWNM(1),I)
IF (I .NE. -1) GO TO 500
IF (NUMB .EQ. 0) GO TO 20
C
C MAKE SURE THAT ALL THE SUBSTRUCTURES IN OLDNMS DO EXIST.
C
ICOUNT = 0
DO 10 I = 1,NUMB
K = 2*(I-1) + 1
CALL FDSUB (OLDNMS(K),IOLD(I))
IF (IOLD(I) .GT. 0) GO TO 10
ICOUNT = ICOUNT + 1
KK = 2*(ICOUNT-1) + 1
OLDNMS(KK ) = OLDNMS(K )
OLDNMS(KK+1) = OLDNMS(K+1)
10 CONTINUE
IF (ICOUNT .EQ. 0) GO TO 20
NUMB = ICOUNT
GO TO 510
20 CALL CRSUB (NEWNM(1),INEW)
IF (NUMB .EQ. 0) RETURN
C
C NEWNM IS NOT A BASIC SUBSTRUCTURE (LEVEL 0).
C UPDATE NEWNM S DIRECTORY IN THE MDI.
C
CALL FMDI (INEW,IMDI)
LLMASK = COMPLF(LSHIFT(1023,20))
BUF(IMDI+LL) = ORF(ANDF(BUF(IMDI+LL),LLMASK),LSHIFT(IOLD(1),20))
IF (IBIT .NE. 0) BUF(IMDI+IB) = ORF(BUF(IMDI+IB),LSHIFT(1,IBIT))
MDIUP = .TRUE.
C
C UPDATE IN THE MDI THE DIRECTORIES OF THE SUBSTRUCTURES IN OLDNMS.
C
IF (NUMB .GT. 7) NUMB = 7
MASKCS = COMPLF(LSHIFT(1023,10))
DO 50 I = 1,NUMB
CALL FMDI (IOLD(I),IMDI)
IF (ANDF(BUF(IMDI+HL),1023) .EQ. 0) GO TO 40
ICOUNT = I
GO TO 520
40 BUF(IMDI+HL) = ORF(BUF(IMDI+HL),INEW)
MDIUP = .TRUE.
IF (NUMB .EQ. 1) RETURN
IF (I .EQ. NUMB) GO TO 130
BUF(IMDI+CS) = ORF(ANDF(BUF(IMDI+CS),MASKCS),LSHIFT(IOLD(I+1),10))
50 CONTINUE
130 BUF(IMDI+CS) = ORF(ANDF(BUF(IMDI+CS),MASKCS),LSHIFT(IOLD(1),10))
RETURN
C
C NEWNM ALREADY EXISTS.
C
500 ITEST = 7
RETURN
C
C ONE OR MORE OF THE SUBSTRUCTURES IN OLDNMS DO NOT EXIST.
C
510 ITEST = 4
RETURN
C
C ONE OF THE SUBSTRUCTURES IN OLDNMS HAS ALREADY BEEN USED IN A
C REDUCTION OR COMBINATION. REMOVE ALL CHANGES THAT HAVE BEEN MADE.
C
520 ITEST = 8
CALL FDIT (INEW,IDIT)
BUF(IDIT ) = IEMPTY
BUF(IDIT+1) = IEMPTY
DITUP = .TRUE.
IF (2*INEW .NE. DITSIZ) GO TO 525
DITSIZ = DITSIZ - 2
525 DITNSB = DITNSB - 1
CALL FMDI (INEW,IMDI)
BUF(IMDI+LL) = ANDF(BUF(IMDI+LL),LLMASK)
MDIUP = .TRUE.
ICOUNT = ICOUNT - 1
IF (ICOUNT .LT. 1) RETURN
DO 530 I = 1,ICOUNT
CALL FMDI (IOLD(I),IMDI)
BUF(IMDI+HL) = ANDF(BUF(IMDI+HL),COMPLF(1023))
BUF(IMDI+CS) = ANDF(BUF(IMDI+CS),MASKCS)
MDIUP = .TRUE.
530 CONTINUE
RETURN
END
|
