CalculiX  2.13
A Free Software Three-Dimensional Structural Finite Element Program
Functions/Subroutines
selectcyclicsymmetrymodess.f File Reference

Go to the source code of this file.

Functions/Subroutines

subroutine selectcyclicsymmetrymodess (inpc, textpart, cs, ics, tieset, istartset, iendset, ialset, ipompc, nodempc, coefmpc, nmpc, nmpc_, ikmpc, ilmpc, mpcfree, mcs, set, nset, labmpc, istep, istat, n, iline, ipol, inl, ipoinp, inp, nmethod, key, ipoinpc)
 

Function/Subroutine Documentation

◆ selectcyclicsymmetrymodess()

subroutine selectcyclicsymmetrymodess ( character*1, dimension(*)  inpc,
character*132, dimension(16)  textpart,
real*8, dimension(17,*)  cs,
integer, dimension(*)  ics,
character*81, dimension(3,*)  tieset,
integer, dimension(*)  istartset,
integer, dimension(*)  iendset,
integer, dimension(*)  ialset,
integer, dimension(*)  ipompc,
integer, dimension(3,*)  nodempc,
real*8, dimension(*)  coefmpc,
integer  nmpc,
integer  nmpc_,
integer, dimension(*)  ikmpc,
integer, dimension(*)  ilmpc,
integer  mpcfree,
integer  mcs,
character*81, dimension(*)  set,
integer  nset,
character*20, dimension(*)  labmpc,
integer  istep,
integer  istat,
integer  n,
integer  iline,
integer  ipol,
integer  inl,
integer, dimension(2,*)  ipoinp,
integer, dimension(3,*)  inp,
integer  nmethod,
integer  key,
integer, dimension(0:*)  ipoinpc 
)
24 !
25 ! reading the input deck: *SELECT CYCLIC SYMMETRY MODES
26 !
27  implicit none
28 !
29  character*1 inpc(*)
30  character*20 labmpc(*)
31  character*81 set(*),leftset,tieset(3,*)
32  character*132 textpart(16)
33 !
34  integer istep,istat,n,key,i,ns(5),ics(*),istartset(*),
35  & iendset(*),ialset(*),id,ipompc(*),nodempc(3,*),nmpc,nmpc_,
36  & ikmpc(*),ilmpc(*),mpcfree,i1(2),i2(2),i3,i4,i5,j,k,
37  & mpcfreeold,idof,node,ileft,nset,irepeat,ipoinpc(0:*),
38  & mpc,iline,ipol,inl,ipoinp(2,*),inp(3,*),mcs,lprev,ij,nmethod
39 !
40  real*8 coefmpc(*),csab(7),x1(2),x2(2),x3,x4,x5,dd,xn,yn,zn,
41  & cs(17,*)
42 !
43 ! irepeat indicates whether the step was preceded by another
44 ! cyclic symmetry step (irepeat=1) or not (irepeat=0)
45 !
46  data irepeat /0/
47  save irepeat
48 !
49  if(istep.eq.0) then
50  write(*,*)'*ERROR in selcycsymmods:'
51  write(*,*)' *SELECT CYCLIC SYMMETRY MODES'
52  write(*,*)' should be placed within a step definition'
53  call exit(201)
54  endif
55 !
56 ! check whether in case of cyclic symmetry the frequency procedure
57 ! is chosen
58 !
59  if(nmethod.ne.2) then
60  write(*,*) '*ERROR in selcycsymmods: the only valid procedure'
61  write(*,*) ' for cyclic symmetry calculations'
62  write(*,*) ' with nodal diameters is *FREQUENCY'
63  call exit(201)
64  endif
65 !
66  ns(2)=0
67  ns(3)=0
68 !
69  do i=2,n
70  if(textpart(i)(1:5).eq.'NMIN=') then
71  read(textpart(i)(6:15),'(i10)',iostat=istat) ns(2)
72  if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
73  &"*SELECT CYCLIC SYMMETRY MODES%")
74  elseif(textpart(i)(1:5).eq.'NMAX=') then
75  read(textpart(i)(6:15),'(i10)',iostat=istat) ns(3)
76  if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
77  &"*SELECT CYCLIC SYMMETRY MODES%")
78  else
79  write(*,*)
80  & '*WARNING in selcycsymmods: parameter not recognized:'
81  write(*,*) ' ',
82  & textpart(i)(1:index(textpart(i),' ')-1)
83  call inputwarning(inpc,ipoinpc,iline,
84  &"*SELECT CYCLIC SYMMETRY MODES%")
85  endif
86  enddo
87 !
88 ! check the input
89 !
90  if(ns(2).lt.0) then
91  ns(2)=0
92  write(*,*) '*WARNING in selcycsymmods: minimum nodal'
93  write(*,*) ' diameter must be nonnegative'
94  endif
95  if(ns(3).lt.ns(2)) then
96  write(*,*) '*ERROR in selcycsymmods: maximum nodal'
97  write(*,*) ' diameter should not exceed minimal one'
98  call exit(201)
99  endif
100 !
101 ! loop over all cyclic symmetry parts
102 !
103  do ij=1,mcs
104  ns(1)=int(cs(1,ij))
105  ns(4)=int(cs(4,ij))
106  leftset=tieset(2,int(cs(17,ij)))
107  lprev=int(cs(14,ij))
108  do i=1,7
109  csab(i)=cs(5+i,ij)
110  enddo
111 !
112 ! check whether cyclic symmetry axis is part of the structure
113 !
114  do i=1,nset
115  if(set(i).eq.leftset) exit
116  enddo
117  ileft=i
118 !
119 ! if this step was preceded by a cyclic symmetry step:
120 ! check for MPC's for nodes on the cyclic symmetry axis
121 ! and delete them
122 !
123  if(irepeat.eq.1) then
124  do i=1,ns(4)
125  node=ics(lprev+i)
126  if(node.lt.0) then
127  node=-node
128  do k=1,3
129  idof=8*(node-1)+k
130  call nident(ikmpc,idof,nmpc,id)
131  if(id.gt.0) then
132  if(ikmpc(id).eq.idof) then
133 c write(*,*) 'removing MPC',node,k
134  mpc=ilmpc(id)
135  call mpcrem(mpc,mpcfree,nodempc,nmpc,ikmpc,
136  & ilmpc,labmpc,coefmpc,ipompc)
137  endif
138  endif
139  enddo
140  endif
141  enddo
142  endif
143 !
144  do i=1,ns(4)
145  node=ics(lprev+i)
146  if(node.lt.0) then
147  node=-node
148  if(ns(2).ne.ns(3)) then
149  if((ns(2).eq.0).or.(ns(2).eq.1)) then
150  write(*,*) '*ERROR: axis of cyclic symmetry'
151  write(*,*) ' is part of the structure;'
152  write(*,*) ' nodal diameters 0, 1, and'
153  write(*,*) ' those above must be each in'
154  write(*,*) ' separate steps.'
155  call exit(201)
156  endif
157  endif
158 !
159 ! specifying special MPC's for nodes on the axis
160 !
161 ! normal along the axis
162 !
163  xn=csab(4)-csab(1)
164  yn=csab(5)-csab(2)
165  zn=csab(6)-csab(3)
166  dd=dsqrt(xn*xn+yn*yn+zn*zn)
167  xn=xn/dd
168  yn=yn/dd
169  zn=zn/dd
170 !
171 ! nodal diameter 0
172 !
173  if(ns(2).eq.0) then
174  if(dabs(xn).gt.1.d-10) then
175  i1(1)=2
176  i1(2)=3
177  i2(1)=1
178  i2(2)=1
179  x1(1)=xn
180  x1(2)=xn
181  x2(1)=-yn
182  x2(2)=-zn
183  elseif(dabs(yn).gt.1.d-10) then
184  i1(1)=1
185  i1(2)=3
186  i2(1)=2
187  i2(2)=2
188  x1(1)=yn
189  x1(2)=yn
190  x2(1)=-xn
191  x2(2)=-zn
192  elseif(dabs(zn).gt.1.d-10) then
193  i1(1)=1
194  i1(2)=2
195  i2(1)=3
196  i2(2)=3
197  x1(1)=zn
198  x1(2)=zn
199  x2(1)=-xn
200  x2(2)=-yn
201  endif
202 !
203 ! generating two MPC's expressing that the nodes cannot
204 ! move in planes perpendicular to the cyclic symmetry
205 ! axis
206 !
207  do k=1,2
208  idof=8*(node-1)+i1(k)
209  call nident(ikmpc,idof,nmpc,id)
210  if(id.gt.0) then
211  if(ikmpc(id).eq.idof) then
212  write(*,*) '*ERROR in selcycsymmods:'
213  write(*,*) ' node',node,
214  & ' on cyclic symmetry'
215  write(*,*) ' axis is used in other MPC'
216  call exit(201)
217  endif
218  endif
219  nmpc=nmpc+1
220  ipompc(nmpc)=mpcfree
221  labmpc(nmpc)=' '
222 !
223 ! updating ikmpc and ilmpc
224 !
225  do j=nmpc,id+2,-1
226  ikmpc(j)=ikmpc(j-1)
227  ilmpc(j)=ilmpc(j-1)
228  enddo
229  ikmpc(id+1)=idof
230  ilmpc(id+1)=nmpc
231 !
232  nodempc(1,mpcfree)=node
233  nodempc(2,mpcfree)=i1(k)
234  coefmpc(mpcfree)=x1(k)
235  mpcfree=nodempc(3,mpcfree)
236  if(mpcfree.eq.0) then
237  write(*,*) '*ERROR in selcycsymmods:'
238  write(*,*) ' increase memmpc_'
239  call exit(201)
240  endif
241  nodempc(1,mpcfree)=node
242  nodempc(2,mpcfree)=i2(k)
243  coefmpc(mpcfree)=x2(k)
244  mpcfreeold=mpcfree
245  mpcfree=nodempc(3,mpcfree)
246  if(mpcfree.eq.0) then
247  write(*,*) '*ERROR in selcycsymmods:'
248  write(*,*) ' increase memmpc_'
249  call exit(201)
250  endif
251  nodempc(3,mpcfreeold)=0
252  enddo
253  elseif(ns(2).eq.1) then
254 !
255 ! nodal diameter 1
256 !
257  if(dabs(xn).gt.1.d-10) then
258  i3=1
259  i4=2
260  i5=3
261  x3=xn
262  x4=yn
263  x5=zn
264  elseif(dabs(yn).gt.1.d-10) then
265  i3=2
266  i4=2
267  i5=3
268  x3=yn
269  x4=xn
270  x5=zn
271  else
272  i3=3
273  i4=1
274  i5=2
275  x3=zn
276  x4=xn
277  x5=yn
278  endif
279 !
280 ! generating one MPC expressing that the nodes should
281 ! not move along the axis
282 !
283  idof=8*(node-1)+i3
284  call nident(ikmpc,idof,nmpc,id)
285  if(id.gt.0) then
286  if(ikmpc(id).eq.idof) then
287  write(*,*) '*ERROR in selcycsymmods:'
288  write(*,*) ' node',node,
289  & ' on cyclic symmetry'
290  write(*,*) ' axis is used in other MPC'
291  call exit(201)
292  endif
293  endif
294  nmpc=nmpc+1
295  ipompc(nmpc)=mpcfree
296  labmpc(nmpc)=' '
297 !
298 ! updating ikmpc and ilmpc
299 !
300  do j=nmpc,id+2,-1
301  ikmpc(j)=ikmpc(j-1)
302  ilmpc(j)=ilmpc(j-1)
303  enddo
304  ikmpc(id+1)=idof
305  ilmpc(id+1)=nmpc
306 !
307  nodempc(1,mpcfree)=node
308  nodempc(2,mpcfree)=i3
309  coefmpc(mpcfree)=x3
310  mpcfree=nodempc(3,mpcfree)
311  if(mpcfree.eq.0) then
312  write(*,*) '*ERROR in selcycsymmods:'
313  write(*,*) ' increase memmpc_'
314  call exit(201)
315  endif
316  nodempc(1,mpcfree)=node
317  nodempc(2,mpcfree)=i4
318  coefmpc(mpcfree)=x4
319  mpcfree=nodempc(3,mpcfree)
320  if(mpcfree.eq.0) then
321  write(*,*) '*ERROR in selcycsymmods:'
322  write(*,*) ' increase memmpc_'
323  call exit(201)
324  endif
325  nodempc(1,mpcfree)=node
326  nodempc(2,mpcfree)=i5
327  coefmpc(mpcfree)=x5
328  mpcfreeold=mpcfree
329  mpcfree=nodempc(3,mpcfree)
330  if(mpcfree.eq.0) then
331  write(*,*) '*ERROR in selcycsymmods:'
332  write(*,*) ' increase memmpc_'
333  call exit(201)
334  endif
335  nodempc(3,mpcfreeold)=0
336  else
337  do k=1,3
338  idof=8*(node-1)+k
339  call nident(ikmpc,idof,nmpc,id)
340  if(id.gt.0) then
341  if(ikmpc(id).eq.idof) then
342  write(*,*) '*ERROR in selcycsymmods:'
343  write(*,*) ' node',node,
344  & ' on cyclic symmetry'
345  write(*,*) ' axis is used in other MPC'
346  call exit(201)
347  endif
348  endif
349  nmpc=nmpc+1
350  ipompc(nmpc)=mpcfree
351  labmpc(nmpc)=' '
352 !
353 ! updating ikmpc and ilmpc
354 !
355  do j=nmpc,id+2,-1
356  ikmpc(j)=ikmpc(j-1)
357  ilmpc(j)=ilmpc(j-1)
358  enddo
359  ikmpc(id+1)=idof
360  ilmpc(id+1)=nmpc
361 !
362  nodempc(1,mpcfree)=node
363  nodempc(2,mpcfree)=k
364  coefmpc(mpcfree)=1.d0
365  mpcfreeold=mpcfree
366  mpcfree=nodempc(3,mpcfree)
367  if(mpcfree.eq.0) then
368  write(*,*) '*ERROR in selcycsymmods:'
369  write(*,*) ' increase memmpc_'
370  call exit(201)
371  endif
372  nodempc(3,mpcfreeold)=0
373  enddo
374  endif
375  endif
376  enddo
377 !
378  cs(2,ij)=ns(2)+0.5
379  cs(3,ij)=ns(3)+0.5
380  enddo
381 !
382  if(irepeat.eq.0) irepeat=1
383 !
384  call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
385  & ipoinp,inp,ipoinpc)
386 !
387 c do j=1,nmpc
388 c call writempc(ipompc,nodempc,coefmpc,labmpc,j)
389 c enddo
390 !
391  return
inputwarning
subroutine inputwarning(inpc, ipoinpc, iline, text)
Definition: inputwarning.f:20
x1
static double * x1
Definition: filtermain.c:48
mpcrem
subroutine mpcrem(i, mpcfree, nodempc, nmpc, ikmpc, ilmpc, labmpc, coefmpc, ipompc)
Definition: mpcrem.f:21
getnewline
subroutine getnewline(inpc, textpart, istat, n, key, iline, ipol, inl, ipoinp, inp, ipoinpc)
Definition: getnewline.f:21
nident
subroutine nident(x, px, n, id)
Definition: nident.f:26
inputerror
subroutine inputerror(inpc, ipoinpc, iline, text)
Definition: inputerror.f:20
Hosted by OpenAircraft.com, (Michigan UAV, LLC)