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

Go to the source code of this file.

Functions/Subroutines

subroutine radiates (inpc, textpart, set, istartset, iendset, ialset, nset, nelemload, sideload, xload, nload, nload_, ielmat, ntmat_, iamload, amname, nam, lakon, ne, radiate_flag, istep, istat, n, iline, ipol, inl, ipoinp, inp, physcon, nam_, namtot_, namta, amta, ipoinpc, mi)
 

Function/Subroutine Documentation

◆ radiates()

subroutine radiates ( 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, dimension(2,*)  nelemload,
character*20, dimension(*)  sideload,
real*8, dimension(2,*)  xload,
integer  nload,
integer  nload_,
integer, dimension(mi(3),*)  ielmat,
integer  ntmat_,
integer, dimension(2,*)  iamload,
character*80, dimension(*)  amname,
integer  nam,
character*8, dimension(*)  lakon,
integer  ne,
logical  radiate_flag,
integer  istep,
integer  istat,
integer  n,
integer  iline,
integer  ipol,
integer  inl,
integer, dimension(2,*)  ipoinp,
integer, dimension(3,*)  inp,
real*8, dimension(*)  physcon,
integer  nam_,
integer  namtot_,
integer, dimension(3,*)  namta,
real*8, dimension(2,*)  amta,
integer, dimension(0:*)  ipoinpc,
integer, dimension(*)  mi 
)
24 !
25 ! reading the input deck: *RADIATE
26 !
27  implicit none
28 !
29  logical radiate_flag,environmentnode,surface
30 !
31  character*1 inpc(*)
32  character*3 cavlabel
33  character*8 lakon(*)
34  character*20 sideload(*),label
35  character*80 amname(*),amplitude
36  character*81 set(*),elset
37  character*132 textpart(16)
38 !
39  integer istartset(*),iendset(*),ialset(*),nelemload(2,*),mi(*),
40  & ielmat(mi(3),*),nset,nload,nload_,ntmat_,istep,istat,n,
41  & i,j,l,key,iload,
42  & iamload(2,*),nam,iamptemp,ipos,ne,node,iampradi,iline,ipol,
43  & inl,ipoinp(2,*),inp(3,*),nam_,namtot,namtot_,namta(3,*),
44  & idelay1,idelay2,ipoinpc(0:*)
45 !
46  real*8 xload(2,*),xmagradi,xmagtemp,physcon(*),amta(2,*)
47 !
48  iamptemp=0
49  iampradi=0
50  idelay1=0
51  idelay2=0
52  cavlabel=' '
53 !
54  environmentnode=.false.
55  surface=.false.
56 !
57  if(istep.lt.1) then
58  write(*,*) '*ERROR in radiates: *RADIATE should only be used'
59  write(*,*) ' within a STEP'
60  call exit(201)
61  endif
62 !
63  if(physcon(2).le.0.d0) then
64  write(*,*) '*ERROR in radiates: *RADIATE card was selected'
65  write(*,*) ' but no *PHYSICAL CONSTANTS card encountered'
66  call exit(201)
67  endif
68 !
69  do i=2,n
70  if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.radiate_flag)) then
71  do j=1,nload
72  if(sideload(j)(1:1).eq.'R') then
73  xload(1,j)=0.d0
74  endif
75  enddo
76  elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then
77  read(textpart(i)(11:90),'(a80)') amplitude
78  do j=nam,1,-1
79  if(amname(j).eq.amplitude) then
80  iamptemp=j
81  exit
82  endif
83  enddo
84  if(j.eq.0) then
85  write(*,*)'*ERROR in radiates: nonexistent amplitude'
86  write(*,*) ' '
87  call inputerror(inpc,ipoinpc,iline,
88  &"*RADIATE%")
89  call exit(201)
90  endif
91  iamptemp=j
92  elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN
93  if(idelay1.ne.0) then
94  write(*,*) '*ERROR in radiates: the parameter TIME DELAY'
95  write(*,*) ' is used twice in the same keyword'
96  write(*,*) ' '
97  call inputerror(inpc,ipoinpc,iline,
98  &"*RADIATE%")
99  call exit(201)
100  else
101  idelay1=1
102  endif
103  nam=nam+1
104  if(nam.gt.nam_) then
105  write(*,*) '*ERROR in radiates: increase nam_'
106  call exit(201)
107  endif
108  amname(nam)='
109  & '
110  if(iamptemp.eq.0) then
111  write(*,*) '*ERROR in radiates: time delay must be'
112  write(*,*) ' preceded by the amplitude parameter'
113  call exit(201)
114  endif
115  namta(3,nam)=sign(iamptemp,namta(3,iamptemp))
116  iamptemp=nam
117  if(nam.eq.1) then
118  namtot=0
119  else
120  namtot=namta(2,nam-1)
121  endif
122  namtot=namtot+1
123  if(namtot.gt.namtot_) then
124  write(*,*) '*ERROR radiates: increase namtot_'
125  call exit(201)
126  endif
127  namta(1,nam)=namtot
128  namta(2,nam)=namtot
129  read(textpart(i)(11:30),'(f20.0)',iostat=istat)
130  & amta(1,namtot)
131  if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
132  &"*RADIATE%")
133  elseif(textpart(i)(1:19).eq.'RADIATIONAMPLITUDE=') then
134  read(textpart(i)(20:99),'(a80)') amplitude
135  do j=nam,1,-1
136  if(amname(j).eq.amplitude) then
137  iampradi=j
138  exit
139  endif
140  enddo
141  if(j.eq.0) then
142  write(*,*)'*ERROR in radiates: nonexistent amplitude'
143  write(*,*) ' '
144  call inputerror(inpc,ipoinpc,iline,
145  &"*RADIATE%")
146  call exit(201)
147  endif
148  iampradi=j
149  elseif(textpart(i)(1:19).eq.'RADIATIONTIMEDELAY=') THEN
150  if(idelay2.ne.0) then
151  write(*,*) '*ERROR in radiates: the parameter RADIATION'
152  write(*,*) ' TIME DELAY is used twice in the'
153  write(*,*) ' same keyword; '
154  call inputerror(inpc,ipoinpc,iline,
155  &"*RADIATE%")
156  call exit(201)
157  else
158  idelay2=1
159  endif
160  nam=nam+1
161  if(nam.gt.nam_) then
162  write(*,*) '*ERROR in radiates: increase nam_'
163  call exit(201)
164  endif
165  amname(nam)='
166  & '
167  if(iampradi.eq.0) then
168  write(*,*) '*ERROR in radiates: radiation time delay'
169  write(*,*) ' must be preceded by the radiation'
170  write(*,*) ' amplitude parameter'
171  call exit(201)
172  endif
173  namta(3,nam)=sign(iampradi,namta(3,iampradi))
174  iampradi=nam
175  if(nam.eq.1) then
176  namtot=0
177  else
178  namtot=namta(2,nam-1)
179  endif
180  namtot=namtot+1
181  if(namtot.gt.namtot_) then
182  write(*,*) '*ERROR radiates: increase namtot_'
183  call exit(201)
184  endif
185  namta(1,nam)=namtot
186  namta(2,nam)=namtot
187  read(textpart(i)(20:39),'(f20.0)',iostat=istat)
188  & amta(1,namtot)
189  if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
190  &"*RADIATE%")
191  elseif(textpart(i)(1:7).eq.'ENVNODE') THEN
192  environmentnode=.true.
193  elseif(textpart(i)(1:7).eq.'CAVITY=') THEN
194  read(textpart(i)(8:10),'(a3)',iostat=istat) cavlabel
195  else
196  write(*,*)
197  & '*WARNING in radiates: parameter not recognized:'
198  write(*,*) ' ',
199  & textpart(i)(1:index(textpart(i),' ')-1)
200  call inputwarning(inpc,ipoinpc,iline,
201  &"*RADIATE%")
202  endif
203  enddo
204 !
205  do
206  call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
207  & ipoinp,inp,ipoinpc)
208  if((istat.lt.0).or.(key.eq.1)) return
209 !
210  read(textpart(2)(1:20),'(a20)',iostat=istat) label
211 !
212  label(18:20)=cavlabel
213 !
214 ! compatibility with ABAQUS for shells
215 !
216  if(label(2:4).eq.'NEG') label(2:4)='1 '
217  if(label(2:4).eq.'POS') label(2:4)='2 '
218  if(label(2:2).eq.'N') label(2:2)='5'
219  if(label(2:2).eq.'P') label(2:2)='6'
220 !
221 ! reference temperature and radiation coefficient
222 ! (for non uniform loading: use user routine radiation.f)
223 !
224  if((label(3:4).ne.'NU').and.(label(5:5).ne.'N')) then
225  if(environmentnode) then
226  read(textpart(3)(1:10),'(i10)',iostat=istat) node
227  else
228  read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagtemp
229  node=0
230  endif
231  if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
232  &"*RADIATE%")
233  read(textpart(4)(1:20),'(f20.0)',iostat=istat) xmagradi
234  if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
235  &"*RADIATE%")
236  else
237  if(environmentnode) then
238  read(textpart(3)(1:10),'(i10)',iostat=istat) node
239  else
240  read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagtemp
241  node=0
242  endif
243  if(istat.gt.0) call inputerror(inpc,ipoinpc,iline,
244  &"*RADIATE%")
245  endif
246  if(((label(1:2).ne.'R1').and.(label(1:2).ne.'R2').and.
247  & (label(1:2).ne.'R0').and.
248  & (label(1:2).ne.'R3').and.(label(1:2).ne.'R4').and.
249  & (label(1:2).ne.'R5').and.(label(1:2).ne.'R6')).or.
250  & ((label(3:5).ne.' ').and.(label(3:5).ne.'NU ').and.
251  & (label(3:5).ne.'CR ').and.(label(3:5).ne.'CRN'))) then
252  call inputerror(inpc,ipoinpc,iline,
253  &"*RADIATE%")
254  endif
255 !
256  read(textpart(1)(1:10),'(i10)',iostat=istat) l
257  if(istat.eq.0) then
258  if(l.gt.ne) then
259  write(*,*) '*ERROR in radiates: element ',l
260  write(*,*) ' is not defined'
261  call exit(201)
262  endif
263 !
264  if((lakon(l)(1:2).eq.'CP').or.
265  & (lakon(l)(2:2).eq.'A').or.
266  & (lakon(l)(7:7).eq.'E').or.
267  & (lakon(l)(7:7).eq.'S').or.
268  & (lakon(l)(7:7).eq.'A')) then
269  if(label(1:2).eq.'R1') then
270  label(1:2)='R3'
271  elseif(label(1:2).eq.'R2') then
272  label(1:2)='R4'
273  elseif(label(1:2).eq.'R3') then
274  label(1:2)='R5'
275  elseif(label(1:2).eq.'R4') then
276  label(1:2)='R6'
277  elseif(label(1:2).eq.'R5') then
278  label(1:2)='R1'
279  elseif(label(1:2).eq.'R6') then
280  label(1:2)='R2'
281  endif
282  endif
283  call loadaddt(l,label,xmagradi,xmagtemp,nelemload,sideload,
284  & xload,nload,nload_,iamload,iamptemp,iampradi,nam,node,
285  & iload)
286  else
287  read(textpart(1)(1:80),'(a80)',iostat=istat) elset
288  elset(81:81)=' '
289  ipos=index(elset,' ')
290  elset(ipos:ipos)='E'
291  do i=1,nset
292  if(set(i).eq.elset) exit
293  enddo
294  if(i.gt.nset) then
295 !
296 ! check for facial surface
297 !
298  surface=.true.
299  elset(ipos:ipos)='T'
300  do i=1,nset
301  if(set(i).eq.elset) exit
302  enddo
303  if(i.gt.nset) then
304  elset(ipos:ipos)=' '
305  write(*,*) '*ERROR in radiates: element set '
306  write(*,*) ' or facial surface ',elset
307  write(*,*) ' has not yet been defined. '
308  call inputerror(inpc,ipoinpc,iline,
309  & "*RADIATE%")
310  call exit(201)
311  endif
312  endif
313 !
314  l=ialset(istartset(i))
315  if(surface) then
316  write(label(2:2),'(i1)') l-10*(l/10)
317  l=l/10
318  endif
319  if((lakon(l)(1:2).eq.'CP').or.
320  & (lakon(l)(2:2).eq.'A').or.
321  & (lakon(l)(7:7).eq.'E').or.
322  & (lakon(l)(7:7).eq.'S').or.
323  & (lakon(l)(7:7).eq.'A')) then
324  if(label(1:2).eq.'R1') then
325  label(1:2)='R3'
326  elseif(label(1:2).eq.'R2') then
327  label(1:2)='R4'
328  elseif(label(1:2).eq.'R3') then
329  label(1:2)='R5'
330  elseif(label(1:2).eq.'R4') then
331  label(1:2)='R6'
332  elseif(label(1:2).eq.'R5') then
333  label(1:2)='R1'
334  elseif(label(1:2).eq.'R6') then
335  label(1:2)='R2'
336  endif
337  endif
338 !
339  do j=istartset(i),iendset(i)
340  if(ialset(j).gt.0) then
341  l=ialset(j)
342  if(surface) then
343  write(label(2:2),'(i1)') l-10*(l/10)
344  l=l/10
345  endif
346  call loadaddt(l,label,xmagradi,xmagtemp,nelemload,
347  & sideload,xload,nload,nload_,iamload,
348  & iamptemp,iampradi,nam,node,iload)
349  else
350  l=ialset(j-2)
351  do
352  l=l-ialset(j)
353  if(l.ge.ialset(j-1)) exit
354  call loadaddt(l,label,xmagradi,xmagtemp,nelemload,
355  & sideload,xload,nload,nload_,iamload,
356  & iamptemp,iampradi,nam,node,iload)
357  enddo
358  endif
359  enddo
360  endif
361  enddo
362 !
363  return
inputwarning
subroutine inputwarning(inpc, ipoinpc, iline, text)
Definition: inputwarning.f:20
loadaddt
subroutine loadaddt(nelement, label, valfilm, valtemp, nelemload, sideload, xload, nload, nload_, iamload, iamptemp, iampfilm, nam, node, iload)
Definition: loadaddt.f:22
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)