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
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
SUBROUTINE APDB2 (IBUF1,IBUF2,NEXT,LEFT,NSTNS,NLINES,XSIGN,
1 LCSTM,ACSTM,NODEX,NODEI,ISILC,XYZB)
C
C GENERATE GTKA TRANSFORMATION MATRIX FOR SWEPT TURBOPROP
C BLADES (AERODYNAMIC THEORY NUMBER 7).
C
EXTERNAL ANDF
LOGICAL MULTI,OMIT,SINGLE,DEBUG
INTEGER GM,GO,GTKA,SCR1,SCR2,CORE,IDATA(7),
1 UM,UO,UR,USG,USB,UL,UA,UF,US,UN,UG,USET1,
2 GTKG,GKNB,GKM,GKAB,GKF,GKS,GKO,GKN,GSIZE,
3 ANDF,RD,RDREW,WRT,WRTREW,CLSREW,TGKG(7)
DIMENSION ITRL(7),XYZB(4,NSTNS),IZ(1),Z(1),RDATA(7),
1 TA(3,3),TBL(3),TBLA(3),TBLT(3),TBLR(3),
2 ACSTM(1),NODEX(1),NODEI(1),ISILC(1)
COMMON /SYSTEM/ KSYSTM(54),IPREC
COMMON /TWO / ITWO(32)
COMMON /ZZZZZZ/ CORE(1)
COMMON /ZBLPKX/ AP(4),II
COMMON /BITPOS/ UM,UO,UR,USG,USB,UL,UA,UF,US,UN,UG
COMMON /PATX / LC,N,NO,NY,USET1,IBC(7)
COMMON /NAMES / RD,RDREW,WRT,WRTREW,CLSREW
COMMON /APDBUG/ DEBUG
EQUIVALENCE (Z(1),CORE(1))
EQUIVALENCE (Z(1),IZ(1)), (IDATA(1),RDATA(1))
DATA SINGLE, MULTI,OMIT /.TRUE.,.TRUE.,.TRUE./
C
USET = 102
GM = 106
GO = 107
GTKA = 204
SCR1 = 301
SCR2 = 302
GKNB = 303
GKM = 304
GKAB = 305
ITRL(1) = USET
CALL RDTRL (ITRL)
GSIZE = ITRL(3)
IF (ANDF(ITRL(5),ITWO(UM)) .EQ. 0) MULTI = .FALSE.
IF (ANDF(ITRL(5),ITWO(US)) .EQ. 0) SINGLE= .FALSE.
IF (ANDF(ITRL(5),ITWO(UO)) .EQ. 0) OMIT = .FALSE.
IF (.NOT.(MULTI .OR. SINGLE .OR. OMIT)) SCR2 = GTKA
GTKG = SCR2
C
C OPEN SCR1 TO READ BLADE NODE DATA
C
C T
C OPEN SCR2 TO WRITE G MATRIX OF ORDER (GSIZE X KSIZE)
C KG
C
CALL GOPEN (SCR1,Z(IBUF1),RDREW)
CALL GOPEN (GTKG,Z(IBUF2),WRTREW)
TGKG(1) = GTKG
TGKG(2) = 0
TGKG(3) = GSIZE
TGKG(4) = 2
TGKG(5) = 1
TGKG(6) = 0
TGKG(7) = 0
C
C SET-UP CALL TO TRANSS VIA PRETRS
C
IF (LCSTM .GT. 0) CALL PRETRS (ACSTM,LCSTM)
C
C LOOP ON STREAMLINES
C
DO 50 NLINE = 1,NLINES
C
C READ STREAMLINE NODE DATA FROM SCR1
C
DO 10 NST = 1,NSTNS
CALL FREAD (SCR1,IDATA,7,0)
IF (DEBUG) CALL BUG1 ('SCR1 IDATA',10,IDATA,7)
NODEX(NST) = IDATA(1)
NODEI(NST) = IDATA(2)
ISILC(NST) = IDATA(3)
XYZB(1,NST)= RDATA(4)
XYZB(2,NST)= RDATA(5)
XYZB(3,NST)= RDATA(6)
XYZB(4,NST)= RDATA(7)
10 CONTINUE
C
C GENERATE BASIC TO LOCAL TRANSFORMATION MATRIX FOR THIS STREAMLINE
C
CALL APDB2A (NLINES,NLINE,SCR1,NSTNS,XSIGN,XYZB(2,1),
1 XYZB(2,NSTNS),TBLT,TBLR)
C
C SET TRANSFORMATION TO TRANSLATION FIRST
C
DO 15 NN = 1,3
15 TBL(NN) = TBLT(NN)
C
C LOOP FOR TRANSLATION THEN ROTATION
C
NDEG = 0
DO 45 NLOOP = 1,2
IF (DEBUG) CALL BUG1 ('MAT-TBL ' ,18,TBL,3)
C
C LOOP ON COMPUTING STATIONS
C
DO 40 NCS = 1,NSTNS
C
C LOCATE GLOBAL TO BASIC TRANSFORMATION MATRIX
C
RDATA(1) = XYZB(1,NCS)
IF (LCSTM.EQ.0 .OR. IDATA(1).EQ.0) GO TO 20
CALL TRANSS (XYZB(1,NCS),TA)
CALL GMMATS (TBL,1,3,0,TA,3,3,0,TBLA)
GO TO 25
20 TBLA(1) = TBL(1)
TBLA(2) = TBL(2)
TBLA(3) = TBL(3)
25 CONTINUE
IF (DEBUG) CALL BUG1 ('MAT-TBLA ',25,TBLA,3)
C
C COMPUTE LOCATION IN G-SET USING SIL
C KODE = 1 FOR GRID POINT
C KODE = 2 FOR SCALAR POINT (NOT ALLOWED, CHECK WAS MADE BY APDB)
C
ISIL = ISILC(NCS)/10
CALL BLDPK (1,1,GTKG,0,0)
C
C OUTPUT GKG(TRANSPOSE) = GTKG
C II IS ROW POSITION
C
DO 30 ICOL = 1,3
II = ISIL + NDEG
AP(1) = TBLA(ICOL)
IF (DEBUG) CALL BUG1 ('ISIL ',28,ISIL,1)
IF (DEBUG) CALL BUG1 ('MAT-AP ',29,AP,1)
CALL ZBLPKI
ISIL = ISIL + 1
30 CONTINUE
CALL BLDPKN (GTKG,0,TGKG)
40 CONTINUE
C
C CHANGE BASIC TO LOCAL TRANSFORMATION TO ROTATION
C
DO 43 NN = 1,3
43 TBL(NN) = TBLR(NN)
NDEG = 3
45 CONTINUE
50 CONTINUE
CALL CLOSE (SCR1,CLSREW)
CALL CLOSE (GTKG,CLSREW)
CALL WRTTRL (TGKG)
C
C CREATE GTKA MATRIX
C
IF (MULTI .OR. SINGLE .OR. OMIT) GO TO 60
GO TO 100
60 CONTINUE
LC = KORSZ(CORE)
GKF = GKNB
GKS = GKM
GKO = GKS
USET1 = USET
C
C REDUCE TO N-SET IF MULTI POINT CONSTRAINTS
C
GKN = GTKG
IF (.NOT.MULTI) GO TO 70
IF (.NOT.SINGLE .AND. .NOT.OMIT) GKN = GTKA
CALL CALCV (SCR1,UG,UN,UM,CORE)
CALL SSG2A (GTKG,GKNB,GKM,SCR1)
CALL SSG2B (GM,GKM,GKNB,GKN,1,IPREC,1,SCR1)
C
C PARTITION INTO F-SET IF SINGLE POINT CONSTRAINTS
C
70 IF (.NOT.SINGLE) GO TO 80
IF (.NOT.OMIT ) GKF = GTKA
CALL CALCV (SCR1,UN,UF,US,CORE)
CALL SSG2A (GKN,GKF,0,SCR1)
GO TO 90
C
C REDUCE TO A-SET IF OMITS
C
80 GKF = GKN
90 IF (.NOT.OMIT) GO TO 100
CALL CALCV (SCR1,UF,UA,UO,CORE)
CALL SSG2A (GKF,GKAB,GKO,SCR1)
CALL SSG2B (GO,GKO,GKAB,GTKA,1,IPREC,1,SCR1)
100 RETURN
END
|
