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
|
SUBROUTINE CMCKCD
C
C THIS SUBROUTINE DETERMINES WHETHER MANUALLY SPECIFIED CONNECTION
C ENTRIES ARE ALLOWABLE BASED ON THE PRESCRIBED GEOMETRIC TOLERANCE.
C
INTEGER SCSFIL,COMBO,SCORE,IST(7),SCCONN,CE(9),AAA(2),
1 BUF2,OUTT
DIMENSION IPNUM(7),COORD(7,3),DIFF2(3)
CHARACTER UFM*23,UWM*25,UIM*29
COMMON /XMSSG / UFM,UWM,UIM
COMMON /CMB001/ SCR1,SCR2,SCBDAT,SCSFIL,SCCONN,SCMCON,SCTOC,
1 GEOM4,CASECC,SCCSTM,SCR3
COMMON /CMB002/ BUF1,BUF2,BUF3,BUF4,BUF5,SCORE,LCORE,INTP,OUTT
COMMON /CMB003/ COMBO(7,5),CONSET,IAUTO,TOLER,NPSUB,CONECT,TRAN,
1 MCON,RESTCT(7,7),ISORT,ORIGIN(7,3),IPRINT
COMMON /ZZZZZZ/ Z(1)
COMMON /BLANK / STEP,IDRY
DATA AAA / 4HCMCK,4HCD /
C
C READ ALL BGSS INTO OPEN CORE
C
IT = 2
IERR = 0
LLCO = LCORE
J = 0
IFILE = SCSFIL
CALL OPEN (*200,SCSFIL,Z(BUF2),0)
DO 30 I = 1,NPSUB
NREC = COMBO(I,5) + 1
DO 10 JJ = 1,NREC
CALL FWDREC (*210,SCSFIL)
10 CONTINUE
CALL READ (*210,*20,SCSFIL,Z(SCORE+J),LLCO,1,NNN)
GO TO 220
20 IST(I) = SCORE + J
J = J + NNN
LLCO = LLCO - NNN
CALL SKPFIL (SCSFIL,1)
30 CONTINUE
CALL CLOSE (SCSFIL,1)
C
C READ CONNECTION ENTRIES AND LOAD INTO COORD ARRAY
C
IFILE = SCCONN
CALL OPEN (*200,SCCONN,Z(BUF2),0)
40 CALL READ (*180,*50,SCCONN,CE,10,1,NNN)
C
C LOAD COORD ARRAY
C CE(3)... UP TO CE(9) ARE INTERNAL POINT NO.
C IZ(IADD) IS THE COORD (CSTM) ID OF THE INTERNAL PTS.
C Z(IADD+1,+2,+3) ARE THE COORD. ORIGINS
C
50 NPT = 0
DO 80 I = 1,NPSUB
IF (CE(I+2)) 80,80,60
60 NPT = NPT + 1
IADD = 4*(CE(I+2)-1) + IST(I)
IPNUM(NPT) = CE(I+2)
DO 70 J = 1,3
COORD(NPT,J) = Z(IADD+J)
70 CONTINUE
80 CONTINUE
C
C COMPARE ALL PAIRS OF COORDINATES AGAINST TOLER.
C
NPTM1 = NPT - 1
DO 170 I = 1,NPTM1
IT = IT - 1
JJ = I + 1
DO 160 J = JJ,NPT
DO 90 KK = 1,3
DIFF2(KK) = (COORD(J,KK)-COORD(I,KK))**2
90 CONTINUE
SUM = 0.0
DO 100 KK = 1,3
SUM = SUM + DIFF2(KK)
100 CONTINUE
DIST = SQRT(SUM)
IF (DIST .LE. TOLER) GO TO 160
IF (IT .GT. 1) GO TO 120
WRITE (OUTT,110) UFM
110 FORMAT (A23,' 6514, ERRORS HAVE BEEN FOUND IN MANUALLY SPECIFIED',
1 ' CONNECTION ENTRIES. SUMMARY FOLLOWS')
IERR = 1
IDRY =-2
IT = 2
120 IF (IT .GT. 2) GO TO 140
WRITE (OUTT,130) (CE(KDH),KDH=1,NNN)
130 FORMAT ('0*** GEOMETRIC ERRORS HAVE BEEN FOUND IN THE FOLLOWING',
1 ' CONNECTION ENTRY', /5X,9I10)
IT = 3
140 WRITE (OUTT,150) IPNUM(I),(COORD(I,MM),MM=1,3),
1 IPNUM(J),(COORD(J,MM),MM=1,3)
150 FORMAT ('0*** IP NUMBER',I10,13H COORDINATES ,3E16.6,4H AND, /,
1 ' IP NUMBER',I10,13H COORDINATES ,3E16.6,
2 ' ARE NOT WITHIN TOLER UNITS.')
160 CONTINUE
170 CONTINUE
GO TO 40
C
180 IF (IERR .EQ. 0) WRITE (OUTT,190) UIM
190 FORMAT (A29,' 6516, ALL MANUAL CONNECTIONS SPECIFIED ARE ',
1 'ALLOWABLE WITH RESPECT TO TOLERANCE')
CALL CLOSE (SCCONN,1)
GO TO 250
C
200 IMSG = -1
GO TO 230
210 IMSG = -2
GO TO 230
220 IMSG = -8
230 CALL MESAGE (IMSG,IFILE,AAA)
C
250 RETURN
END
|
