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

Go to the source code of this file.

Functions/Subroutines

subroutine surfaces (inpc, textpart, set, istartset, iendset, ialset, nset, nset_, nalset, nalset_, nk, ne, istep, istat, n, iline, ipol, inl, ipoinp, inp, lakon, ipoinpc)
 

Function/Subroutine Documentation

◆ surfaces()

subroutine surfaces ( character*1, dimension(*)  inpc,
character*132, dimension(16)  textpart,
character*81, dimension(*)  set,
integer, dimension(*)  istartset,
integer, dimension(*)  iendset,
integer, dimension(*)  ialset,
integer  nset,
integer  nset_,
integer  nalset,
integer  nalset_,
integer  nk,
integer  ne,
integer  istep,
integer  istat,
integer  n,
integer  iline,
integer  ipol,
integer  inl,
integer, dimension(2,*)  ipoinp,
integer, dimension(3,*)  inp,
character*8, dimension(*)  lakon,
integer, dimension(0:*)  ipoinpc 
)
22 !
23 ! reading the input deck: *SURFACE
24 !
25  implicit none
26 !
27  character*1 type,inpc(*)
28  character*8 lakon(*)
29  character*20 label,newlabel
30  character*81 set(*),noset,elset,noelset
31  character*132 textpart(16)
32 !
33  integer nset,nset_,nalset,nalset_,istep,istat,n,key,i,nk,ne,
34  & j,istartset(*),iendset(*),ialset(*),ipos,iline,ipol,inl,
35  & ipoinp(2,*),inp(3,*),iside,l,k,kstart,kend,ipoinpc(0:*),
36  & iset,nn,kincrement
37 !
38  if(istep.gt.0) then
39  write(*,*) '*ERROR reading *SURFACE: *SURFACE should be placed'
40  write(*,*) ' before all step definitions'
41  call exit(201)
42  endif
43 !
44  kstart=0
45  kend=0
46 !
47  type='T'
48 !
49  do i=2,n
50  if(textpart(i)(1:5).eq.'NAME=')
51  & then
52  noelset(1:80)=textpart(i)(6:85)
53  noelset(81:81)=' '
54  if(textpart(i)(86:86).ne.' ') then
55  write(*,*)
56  & '*ERROR reading *SURFACE: surface name too long'
57  write(*,*) ' (more than 80 characters)'
58  write(*,*) ' surface name:',textpart(i)(1:132)
59  call exit(201)
60  endif
61  elseif(textpart(i)(1:5).eq.'TYPE=') then
62  if(textpart(i)(6:12).eq.'ELEMENT') then
63  type='T'
64  elseif(textpart(i)(6:9).eq.'NODE') then
65  type='S'
66  else
67  write(*,*)
68  & '*ERROR reading *SURFACE: unknown surface type'
69  call exit(201)
70  endif
71  else
72  write(*,*)
73  & '*WARNING reading *SURFACE: parameter not recognized:'
74  write(*,*) ' ',
75  & textpart(i)(1:index(textpart(i),' ')-1)
76  call inputwarning(inpc,ipoinpc,iline,
77  &"*SURFACE%")
78  endif
79  enddo
80 !
81  ipos=index(noelset,' ')
82  if(ipos.eq.1) then
83  write(*,*) '*ERROR reading *SURFACE: no name specified'
84  call exit(201)
85  endif
86  noelset(ipos:ipos)=type
87 !
88 ! check whether new set or old set (a *SURFACE can be used to
89 ! extend an already existing surface)
90 !
91  do iset=1,nset
92  if(set(iset).eq.noelset) then
93 !
94 ! existent set
95 !
96  if(iendset(iset).eq.nalset) then
97  exit
98  else
99 !
100 ! rearranging set information towards the end
101 !
102  nn=iendset(iset)-istartset(iset)+1
103  if(nalset+nn.gt.nalset_) then
104  write(*,*)'*ERROR in noelsets: increase nalset_'
105  call exit(201)
106  endif
107  do k=1,nn
108  ialset(nalset+k)=ialset(istartset(iset)+k-1)
109  enddo
110  do k=istartset(iset),nalset
111  ialset(k)=ialset(k+nn)
112  enddo
113  do k=1,nset
114  if(istartset(k).gt.iendset(iset)) then
115  istartset(k)=istartset(k)-nn
116  iendset(k)=iendset(k)-nn
117  endif
118  enddo
119  istartset(iset)=nalset-nn+1
120  iendset(iset)=nalset
121  exit
122  endif
123  endif
124  enddo
125  if(iset.gt.nset) then
126  nset=nset+1
127  if(nset.gt.nset_) then
128  write(*,*) '*ERROR in noelsets: increase nset_'
129  call exit(201)
130  endif
131  set(nset)=noelset
132  istartset(nset)=nalset+1
133  iendset(nset)=0
134  iset=nset
135  endif
136 !
137  if(type.eq.'S') then
138 !
139 ! node surface
140 !
141  do
142  call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
143  & ipoinp,inp,ipoinpc)
144  if((istat.lt.0).or.(key.eq.1)) then
145  if(iendset(nset).eq.0) then
146  nset=nset-1
147  endif
148  return
149  endif
150  if(n.gt.1) then
151  write(*,*) '*ERROR reading *SURFACE: only one entry per'
152  write(*,*) ' line allowed'
153  call inputerror(inpc,ipoinpc,iline,
154  &"*SURFACE%")
155  endif
156 !
157  if(nalset+1.gt.nalset_) then
158  write(*,*) '*ERROR reading *SURFACE: increase nalset_'
159  call exit(201)
160  endif
161 !
162  read(textpart(1)(1:10),'(i10)',iostat=istat)ialset(nalset+1)
163  if(istat.gt.0) then
164  noset=textpart(1)(1:80)
165  noset(81:81)=' '
166  ipos=index(noset,' ')
167  noset(ipos:ipos)='N'
168  do i=1,nset
169  if(set(i).eq.noset) then
170  do j=istartset(i),iendset(i)
171  if(ialset(j).gt.0) then
172  nalset=nalset+1
173  if(nalset.gt.nalset_) then
174  write(*,*)
175  & '*ERROR reading *SURFACE: increase nalset_'
176  call exit(201)
177  endif
178  ialset(nalset)=ialset(j)
179  else
180  kstart=ialset(nalset-1)
181  kend=ialset(nalset)
182  nalset=nalset-1
183  kincrement=-ialset(j)
184  do k=kstart+kincrement,kend,kincrement
185  nalset=nalset+1
186  if(nalset.gt.nalset_) then
187  write(*,*)
188  & '*ERROR reading *SURFACE: increase nalset_'
189  call exit(201)
190  endif
191  ialset(nalset)=k
192  enddo
193  endif
194  enddo
195  iendset(iset)=nalset
196  exit
197  endif
198  enddo
199  if(i.gt.nset) then
200  noset(ipos:ipos)=' '
201  write(*,*) '*ERROR reading *SURFACE: node set ',noset
202  write(*,*) ' does not exist'
203  call exit(201)
204  endif
205  else
206  if(ialset(nalset+1).gt.nk) then
207  write(*,*) '*WARNING reading *SURFACE: value ',
208  & ialset(nalset+1)
209  write(*,*) ' in set ',set(iset),' > nk'
210  else
211  nalset=nalset+1
212  iendset(iset)=nalset
213  endif
214  endif
215  enddo
216 !
217  else
218 !
219 ! element surface
220 !
221  do
222  call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
223  & ipoinp,inp,ipoinpc)
224  if((istat.lt.0).or.(key.eq.1)) then
225  if(iendset(nset).eq.0) then
226  nset=nset-1
227  endif
228  return
229  endif
230  if(nalset+1.gt.nalset_) then
231  write(*,*) '*ERROR reading *SURFACE: increase nalset_'
232  call exit(201)
233  endif
234 !
235  read(textpart(2)(1:20),'(a20)',iostat=istat) label
236 !
237  if(label(2:4).eq.'NEG') then
238  label(2:4)='1 '
239  elseif(label(2:4).eq.'POS') then
240  label(2:4)='2 '
241  endif
242  if(label(2:2).eq.'N') then
243  label(2:2)='5'
244  elseif(label(2:2).eq.'P') then
245  label(2:2)='6'
246  endif
247 !
248  if((label(1:2).ne.'S1').and.(label(1:2).ne.'S2').and.
249  & (label(1:2).ne.'S3').and.(label(1:2).ne.'S4').and.
250  & (label(1:2).ne.'S5').and.(label(1:2).ne.'S6')) then
251  call inputerror(inpc,ipoinpc,iline,
252  &"*SURFACE%")
253  endif
254 !
255  read(textpart(1)(1:10),'(i10)',iostat=istat)l
256  if(istat.gt.0) then
257  elset=textpart(1)(1:80)
258  elset(81:81)=' '
259  ipos=index(elset,' ')
260  elset(ipos:ipos)='E'
261  do i=1,nset
262  if(set(i).eq.elset) then
263  do j=istartset(i),iendset(i)
264  l=ialset(j)
265  if(l.gt.0) then
266  kstart=kend
267  kend=l
268  nalset=nalset+1
269  if(nalset.gt.nalset_) then
270  write(*,*)
271  & '*ERROR reading *SURFACE: increase nalset_'
272  call exit(201)
273  endif
274  newlabel=label
275  if((lakon(l)(1:2).eq.'CP').or.
276  & (lakon(l)(2:2).eq.'A')) then
277  if(label(1:2).eq.'S1') then
278  newlabel(1:2)='S3'
279  elseif(label(1:2).eq.'S2') then
280  newlabel(1:2)='S4'
281  elseif(label(1:2).eq.'S3') then
282  newlabel(1:2)='S5'
283  elseif(label(1:2).eq.'S4') then
284  newlabel(1:2)='S6'
285  elseif(label(1:2).eq.'S5') then
286  newlabel(1:2)='S1'
287  elseif(label(1:2).eq.'S6') then
288  newlabel(1:2)='S2'
289  endif
290  endif
291  read(newlabel(2:2),'(i1)',iostat=istat) iside
292  ialset(nalset)=iside+10*l
293  else
294  kstart=kstart
295  nalset=nalset-1
296  kincrement=-ialset(j)
297  do l=kstart+kincrement,kend,kincrement
298  nalset=nalset+1
299  if(nalset.gt.nalset_) then
300  write(*,*)
301  & '*ERROR reading *SURFACE: increase nalset_'
302  call exit(201)
303  endif
304  newlabel=label
305  if((lakon(l)(1:2).eq.'CP').or.
306  & (lakon(l)(2:2).eq.'A')) then
307  if(label(1:2).eq.'S1') then
308  newlabel(1:2)='S3'
309  elseif(label(1:2).eq.'S2') then
310  newlabel(1:2)='S4'
311  elseif(label(1:2).eq.'S3') then
312  newlabel(1:2)='S5'
313  elseif(label(1:2).eq.'S4') then
314  newlabel(1:2)='S6'
315  elseif(label(1:2).eq.'S5') then
316  newlabel(1:2)='S1'
317  elseif(label(1:2).eq.'S6') then
318  newlabel(1:2)='S2'
319  endif
320  endif
321  read(newlabel(2:2),'(i1)',iostat=istat)
322  & iside
323  ialset(nalset)=iside+10*l
324  enddo
325  endif
326  enddo
327  iendset(iset)=nalset
328  exit
329  endif
330  enddo
331  if(i.gt.nset) then
332  elset(ipos:ipos)=' '
333  write(*,*) '*ERROR reading *SURFACE: element set ',
334  & elset
335  write(*,*) ' does not exist'
336  call exit(201)
337  endif
338  else
339  if(l.gt.ne) then
340  write(*,*) '*WARNING reading *SURFACE: element ',
341  & l
342  write(*,*) ' in set ',set(iset),' > ne'
343  else
344  newlabel=label
345  if((lakon(l)(1:2).eq.'CP').or.
346  & (lakon(l)(2:2).eq.'A')) then
347  if(label(1:2).eq.'S1') then
348  newlabel(1:2)='S3'
349  elseif(label(1:2).eq.'S2') then
350  newlabel(1:2)='S4'
351  elseif(label(1:2).eq.'S3') then
352  newlabel(1:2)='S5'
353  elseif(label(1:2).eq.'S4') then
354  newlabel(1:2)='S6'
355  elseif(label(1:2).eq.'S5') then
356  newlabel(1:2)='S1'
357  elseif(label(1:2).eq.'S6') then
358  newlabel(1:2)='S2'
359  endif
360  endif
361  read(newlabel(2:2),'(i1)',iostat=istat) iside
362  nalset=nalset+1
363  ialset(nalset)=iside+10*l
364  iendset(iset)=nalset
365  endif
366  endif
367  enddo
368  endif
369 !
370  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
inputerror
subroutine inputerror(inpc, ipoinpc, iline, text)
Definition: inputerror.f:20
Hosted by OpenAircraft.com, (Michigan UAV, LLC)