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

Go to the source code of this file.

Functions/Subroutines

subroutine distributingcouplings (inpc, textpart, ipompc, nodempc, coefmpc, nmpc, nmpc_, mpcfree, nk, ikmpc, ilmpc, labmpc, istep, istat, n, iline, ipol, inl, ipoinp, inp, ipoinpc, lakon, kon, ipkon, set, nset, istartset, iendset, ialset, co)
 

Function/Subroutine Documentation

◆ distributingcouplings()

subroutine distributingcouplings ( character*1, dimension(*)  inpc,
character*132, dimension(16)  textpart,
integer, dimension(*)  ipompc,
integer, dimension(3,*)  nodempc,
real*8, dimension(*)  coefmpc,
integer  nmpc,
integer  nmpc_,
integer  mpcfree,
integer  nk,
integer, dimension(*)  ikmpc,
integer, dimension(*)  ilmpc,
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, dimension(0:*)  ipoinpc,
character*8, dimension(*)  lakon,
integer, dimension(*)  kon,
integer, dimension(*)  ipkon,
character*81, dimension(*)  set,
integer  nset,
integer, dimension(*)  istartset,
integer, dimension(*)  iendset,
integer, dimension(*)  ialset,
real*8, dimension(3,*)  co 
)
23 !
24 ! reading the input deck: *DISTRIBUTING COUPLING
25 !
26  implicit none
27 !
28  character*1 inpc(*)
29  character*8 lakon(*)
30  character*20 labmpc(*)
31  character*81 set(*),elset,noset
32  character*132 textpart(16)
33 !
34  integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,istep,istat,
35  & n,i,j,key,nk,node,
36  & mpcfreeold,ikmpc(*),ilmpc(*),id,idof,iline,ipol,inl,
37  & ipoinp(2,*),inp(3,*),ipoinpc(0:*),irefnode,
38  & k,ipos,kon(*),ipkon(*),nset,idir,newmpc,
39  & istartset(*),iendset(*),ialset(*),indexm,ielem
40 !
41  real*8 coefmpc(*),co(3,*),weight,totweight
42 !
43  elset(1:1)=' '
44  do i=2,n
45  if(textpart(i)(1:6).eq.'ELSET=') then
46  elset=textpart(i)(7:86)
47  elset(81:81)=' '
48  ipos=index(elset,' ')
49  elset(ipos:ipos)='E'
50  else
51  write(*,*) '*WARNING reading *DISTRIBUTING COUPLING:'
52  write(*,*) ' parameter not recognized:'
53  write(*,*) ' ',
54  & textpart(i)(1:index(textpart(i),' ')-1)
55  call inputwarning(inpc,ipoinpc,iline,
56  &"*DISTRIBUTING COUPLING%")
57  endif
58  enddo
59 !
60  if(elset(1:1).eq.' ') then
61  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
62  write(*,*) ' no element set given'
63  call inputerror(inpc,ipoinpc,iline,
64  &"*DISTRIBUTING COUPLING%")
65  endif
66 !
67 ! check whether the element set exists
68 !
69  do i=1,nset
70  if(set(i).eq.elset) exit
71  enddo
72  if(i.gt.nset) then
73  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
74  write(*,*) ' element set ',elset(1:ipos-1),
75  & ' is not defined'
76  call exit(201)
77  endif
78 !
79 ! check whether only one element belongs
80 ! to the set
81 !
82  if(istartset(i).ne.iendset(i)) then
83  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
84  write(*,*) ' element set ',elset(1:ipos-1),
85  & ' contains more than one element'
86  call exit(201)
87  endif
88 !
89 ! check whether the element is a DCOUP3D element
90 !
91  ielem=ialset(istartset(i))
92  if(lakon(ielem)(1:7).ne.'DCOUP3D') then
93  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
94  write(*,*) ' element ',ielem,' is not a'
95  write(*,*) ' DCOUP3D element'
96  call exit(201)
97  endif
98 !
99 ! the reference node belongs to the DCOUP3D element
100 !
101  irefnode=kon(ipkon(ielem)+1)
102  newmpc=0
103  totweight=0.d0
104 !
105 ! generate a MPC for dof 1
106 !
107  do
108  call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
109  & ipoinp,inp,ipoinpc)
110  if((istat.lt.0).or.(key.eq.1)) exit
111 !
112  read(textpart(1)(1:10),'(i10)',iostat=istat) node
113  if(istat.eq.0) then
114  if(node.gt.nk) then
115  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
116  write(*,*) ' node ',node,' is not defined'
117  call exit(201)
118  endif
119 !
120 ! if first node : new MPC
121 !
122  if(newmpc.eq.0) then
123  idof=8*(node-1)+1
124  call nident(ikmpc,idof,nmpc,id)
125  if(id.gt.0) then
126  if(ikmpc(id).eq.idof) then
127  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
128  write(*,*) ' dof 1 of node ',node,
129  & ' is already used'
130  call exit(201)
131  endif
132  endif
133 !
134  nmpc=nmpc+1
135  if(nmpc.gt.nmpc_) then
136  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
137  write(*,*) ' increase nmpc_'
138  call exit(201)
139  endif
140  ipompc(nmpc)=mpcfree
141  labmpc(nmpc)=' '
142  ipompc(nmpc)=mpcfree
143 !
144 ! updating ikmpc and ilmpc
145 !
146  do j=nmpc,id+2,-1
147  ikmpc(j)=ikmpc(j-1)
148  ilmpc(j)=ilmpc(j-1)
149  enddo
150  ikmpc(id+1)=idof
151  ilmpc(id+1)=nmpc
152 !
153  newmpc=1
154  endif
155 !
156 ! reading the weight
157 !
158  read(textpart(2)(1:20),'(f20.0)',iostat=istat) weight
159  if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
160  &"*DISTRIBUTING COUPLING%")
161  totweight=totweight+weight
162 !
163 ! new term in MPC
164 !
165  nodempc(1,mpcfree)=node
166  nodempc(2,mpcfree)=1
167  coefmpc(mpcfree)=weight
168  mpcfree=nodempc(3,mpcfree)
169 !
170  else
171 !
172 ! node set
173 !
174  read(textpart(1)(1:80),'(a80)',iostat=istat) noset
175  read(textpart(2)(1:20),'(f20.0)',iostat=istat) weight
176  if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
177  &"*DISTRIBUTING COUPLING%")
178  noset(81:81)=' '
179  ipos=index(noset,' ')
180  noset(ipos:ipos)='N'
181  do i=1,nset
182  if(set(i).eq.noset) exit
183  enddo
184  if(i.gt.nset) then
185  noset(ipos:ipos)=' '
186  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
187  write(*,*) ' node set ',noset
188  write(*,*) ' has not yet been defined. '
189  call inputerror(inpc,ipoinpc,iline,
190  &"*DISTRIBUTING COUPLING%")
191  call exit(201)
192  endif
193  do j=istartset(i),iendset(i)
194  if(ialset(j).gt.0) then
195  node=ialset(j)
196  totweight=totweight+weight
197 !
198  if(newmpc.eq.0) then
199  idof=8*(node-1)+1
200  call nident(ikmpc,idof,nmpc,id)
201  if(id.gt.0) then
202  if(ikmpc(id).eq.idof) then
203  write(*,*)
204  & '*ERROR reading *DISTRIBUTING COUPLING:'
205  write(*,*) ' dof 1 of node ',node,
206  & ' is already used'
207  call exit(201)
208  endif
209  endif
210 !
211  nmpc=nmpc+1
212  if(nmpc.gt.nmpc_) then
213  write(*,*)
214  & '*ERROR reading *DISTRIBUTING COUPLING:'
215  write(*,*) ' increase nmpc_'
216  call exit(201)
217  endif
218  ipompc(nmpc)=mpcfree
219  labmpc(nmpc)=' '
220  ipompc(nmpc)=mpcfree
221 !
222 ! updating ikmpc and ilmpc
223 !
224  do k=nmpc,id+2,-1
225  ikmpc(k)=ikmpc(k-1)
226  ilmpc(k)=ilmpc(k-1)
227  enddo
228  ikmpc(id+1)=idof
229  ilmpc(id+1)=nmpc
230 !
231  newmpc=1
232  endif
233 !
234 ! new term in MPC
235 !
236  nodempc(1,mpcfree)=node
237  nodempc(2,mpcfree)=1
238  coefmpc(mpcfree)=weight
239  mpcfree=nodempc(3,mpcfree)
240 !
241  else
242  node=ialset(j-2)
243  do
244  node=node-ialset(j)
245  if(node.ge.ialset(j-1)) exit
246  totweight=totweight+weight
247 !
248 ! new term in MPC
249 !
250  nodempc(1,mpcfree)=node
251  nodempc(2,mpcfree)=1
252  coefmpc(mpcfree)=weight
253  mpcfree=nodempc(3,mpcfree)
254  enddo
255  endif
256  enddo
257  endif
258  enddo
259 !
260 ! reference node
261 !
262  nodempc(1,mpcfree)=irefnode
263  nodempc(2,mpcfree)=1
264  coefmpc(mpcfree)=-totweight
265  mpcfreeold=mpcfree
266  mpcfree=nodempc(3,mpcfree)
267  nodempc(3,mpcfreeold)=0
268 !
269 ! dofs 2 and 3
270 !
271  do idir=2,3
272 !
273  indexm=ipompc(nmpc)
274  node=nodempc(1,indexm)
275 !
276  idof=8*(node-1)+idir
277  call nident(ikmpc,idof,nmpc,id)
278  if(id.gt.0) then
279  if(ikmpc(id).eq.idof) then
280  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
281  write(*,*) ' dof',idir,' of node ',node,
282  & ' is already used'
283  call exit(201)
284  endif
285  endif
286 !
287  nmpc=nmpc+1
288  if(nmpc.gt.nmpc_) then
289  write(*,*) '*ERROR reading *DISTRIBUTING COUPLING:'
290  write(*,*) ' increase nmpc_'
291  call exit(201)
292  endif
293  ipompc(nmpc)=mpcfree
294  labmpc(nmpc)=' '
295  ipompc(nmpc)=mpcfree
296 !
297 ! updating ikmpc and ilmpc
298 !
299  do j=nmpc,id+2,-1
300  ikmpc(j)=ikmpc(j-1)
301  ilmpc(j)=ilmpc(j-1)
302  enddo
303  ikmpc(id+1)=idof
304  ilmpc(id+1)=nmpc
305 !
306  do
307  nodempc(1,mpcfree)=nodempc(1,indexm)
308  nodempc(2,mpcfree)=idir
309  coefmpc(mpcfree)=coefmpc(indexm)
310  if(nodempc(3,indexm).eq.0) then
311  mpcfreeold=mpcfree
312  mpcfree=nodempc(3,mpcfree)
313  nodempc(3,mpcfreeold)=0
314  exit
315  else
316  mpcfree=nodempc(3,mpcfree)
317  indexm=nodempc(3,indexm)
318  endif
319  enddo
320  enddo
321 !
322  return
inputwarning
subroutine inputwarning(inpc, ipoinpc, iline, text)
Definition: inputwarning.f:20
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)