1!
2!     CalculiX - A 3-dimensional finite element program
3!              Copyright (C) 1998-2021 Guido Dhondt
4!
5!     This program is free software; you can redistribute it and/or
6!     modify it under the terms of the GNU General Public License as
7!     published by the Free Software Foundation(version 2);
8!
9!
10!     This program is distributed in the hope that it will be useful,
11!     but WITHOUT ANY WARRANTY; without even the implied warranty of
12!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13!     GNU General Public License for more details.
14!
15!     You should have received a copy of the GNU General Public License
16!     along with this program; if not, write to the Free Software
17!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
18!
19      subroutine cfluxs(inpc,textpart,set,istartset,iendset,
20     &  ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_,iamforc,
21     &  amname,nam,ntrans,trab,inotr,co,ikforc,ilforc,nk,
22     &  cflux_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_,
23     &  namtot_,namta,amta,iaxial,ipoinpc,idefforc,ipompc,nodempc,
24     &  nmpc,ikmpc,ilmpc,labmpc,iamplitudedefault,namtot,ier)
25!
26!     reading the input deck: *CFLUX
27!
28      implicit none
29!
30      logical cflux_flag,user,add
31!
32      character*1 inpc(*)
33      character*20 labmpc(*)
34      character*80 amplitude,amname(*)
35      character*81 set(*),noset
36      character*132 textpart(16)
37!
38      integer istartset(*),iendset(*),ialset(*),nodeforc(2,*),
39     &  nset,nforc,nforc_,istep,istat,n,i,j,k,l,iforcdir,key,
40     &  iamforc(*),nam,iamplitude,ntrans,inotr(2,*),ipos,ikforc(*),
41     &  ilforc(*),nk,iline,ipol,inl,ipoinp(2,*),inp(3,*),nam_,namtot,
42     &  namtot_,namta(3,*),idelay,ndirforc(*),isector,iaxial,
43     &  ipoinpc(0:*),idefforc(*),ipompc(*),id,
44     &  nodempc(3,*),nmpc,ikmpc(*),ilmpc(*),iamplitudedefault,ier
45!
46      real*8 xforc(*),forcval,co(3,*),trab(7,*),amta(2,*)
47!
48      iamplitude=iamplitudedefault
49      idelay=0
50      user=.false.
51      add=.false.
52      isector=0
53!
54      if(istep.lt.1) then
55         write(*,*) '*ERROR reading *CFLUX: *CFLUX should only be used'
56         write(*,*) '  within a STEP'
57         ier=1
58         return
59      endif
60!
61      do i=2,n
62         if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.cflux_flag)) then
63            do j=1,nforc
64               if(ndirforc(j).eq.0) xforc(j)=0.d0
65            enddo
66         elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then
67            read(textpart(i)(11:90),'(a80)') amplitude
68            do j=nam,1,-1
69               if(amname(j).eq.amplitude) then
70                  iamplitude=j
71                  exit
72               endif
73            enddo
74            if(j.eq.0) then
75               write(*,*)'*ERROR reading *CFLUX: nonexistent amplitude'
76               write(*,*) '  '
77               call inputerror(inpc,ipoinpc,iline,
78     &              "*CFLUX%",ier)
79               return
80            endif
81            iamplitude=j
82         elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN
83            if(idelay.ne.0) then
84               write(*,*)
85     &           '*ERROR reading *CFLUX: the parameter TIME DELAY'
86               write(*,*) '       is used twice in the same keyword'
87               write(*,*) '       '
88               call inputerror(inpc,ipoinpc,iline,
89     &              "*CFLUX%",ier)
90               return
91            else
92               idelay=1
93            endif
94            nam=nam+1
95            if(nam.gt.nam_) then
96               write(*,*) '*ERROR reading *CFLUX: increase nam_'
97               ier=1
98               return
99            endif
100            amname(nam)='
101     &                                 '
102            if(iamplitude.eq.0) then
103               write(*,*) '*ERROR reading *CFLUX: time delay must be'
104               write(*,*) '       preceded by the amplitude parameter'
105               ier=1
106               return
107            endif
108            namta(3,nam)=sign(iamplitude,namta(3,iamplitude))
109            iamplitude=nam
110c            if(nam.eq.1) then
111c               namtot=0
112c            else
113c               namtot=namta(2,nam-1)
114c            endif
115            namtot=namtot+1
116            if(namtot.gt.namtot_) then
117               write(*,*) '*ERROR cfluxes: increase namtot_'
118               ier=1
119               return
120            endif
121            namta(1,nam)=namtot
122            namta(2,nam)=namtot
123c            call reorderampl(amname,namta,nam)
124            read(textpart(i)(11:30),'(f20.0)',iostat=istat)
125     &           amta(1,namtot)
126            if(istat.gt.0) then
127               call inputerror(inpc,ipoinpc,iline,
128     &              "*CFLUX%",ier)
129               return
130            endif
131         elseif(textpart(i)(1:4).eq.'USER') then
132            user=.true.
133         elseif(textpart(i)(1:3).eq.'ADD') then
134            add=.true.
135         else
136            write(*,*)
137     &        '*WARNING reading *CFLUX: parameter not recognized:'
138            write(*,*) '         ',
139     &                 textpart(i)(1:index(textpart(i),' ')-1)
140            call inputwarning(inpc,ipoinpc,iline,
141     &"*CFLUX%")
142         endif
143      enddo
144!
145      if(user.and.(iamplitude.ne.0)) then
146         write(*,*) '*WARNING: no amplitude definition is allowed'
147         write(*,*) '          for heat fluxes defined by a'
148         write(*,*) '          user routine'
149         iamplitude=0
150      endif
151!
152      do
153         call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
154     &        ipoinp,inp,ipoinpc)
155         if((istat.lt.0).or.(key.eq.1)) return
156!
157         read(textpart(2)(1:10),'(i10)',iostat=istat) iforcdir
158         if(istat.gt.0) then
159            call inputerror(inpc,ipoinpc,iline,
160     &           "*CFLUX%",ier)
161            return
162         endif
163         if((iforcdir.ne.0).and.(iforcdir.ne.11)) then
164            write(*,*) '*ERROR reading *CFLUX: nonexistent degree of '
165            write(*,*) '       freedom. '
166            call inputerror(inpc,ipoinpc,iline,
167     &           "*CFLUX%",ier)
168            return
169         endif
170         iforcdir=0
171!
172         if(textpart(3)(1:1).eq.' ') then
173            forcval=0.d0
174         else
175            read(textpart(3)(1:20),'(f20.0)',iostat=istat) forcval
176            if(istat.gt.0) then
177               call inputerror(inpc,ipoinpc,iline,
178     &              "*CFLUX%",ier)
179               return
180            endif
181            if(iaxial.eq.180) forcval=forcval/iaxial
182         endif
183!
184!        dummy flux consisting of the first primes
185!
186         if(user) forcval=1.2357111317d0
187!
188         read(textpart(1)(1:10),'(i10)',iostat=istat) l
189         if(istat.eq.0) then
190            if(l.gt.nk) then
191               write(*,*) '*ERROR reading *CFLUX: node ',l
192               write(*,*) '       is not defined'
193               ier=1
194               return
195            endif
196            call forcadd(l,iforcdir,forcval,
197     &        nodeforc,ndirforc,xforc,nforc,nforc_,iamforc,
198     &        iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc,
199     &        isector,add,user,idefforc,ipompc,nodempc,
200     &        nmpc,ikmpc,ilmpc,labmpc)
201         else
202            read(textpart(1)(1:80),'(a80)',iostat=istat) noset
203            noset(81:81)=' '
204            ipos=index(noset,' ')
205            noset(ipos:ipos)='N'
206c            do i=1,nset
207c               if(set(i).eq.noset) exit
208c            enddo
209            call cident81(set,noset,nset,id)
210            i=nset+1
211            if(id.gt.0) then
212              if(noset.eq.set(id)) then
213                i=id
214              endif
215            endif
216            if(i.gt.nset) then
217               noset(ipos:ipos)=' '
218               write(*,*) '*ERROR reading *CFLUX: node set ',noset
219               write(*,*) '  has not yet been defined. '
220               call inputerror(inpc,ipoinpc,iline,
221     &              "*CFLUX%",ier)
222               return
223            endif
224            do j=istartset(i),iendset(i)
225               if(ialset(j).gt.0) then
226               call forcadd(ialset(j),iforcdir,forcval,
227     &           nodeforc,ndirforc,xforc,nforc,nforc_,iamforc,
228     &           iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc,
229     &           isector,add,user,idefforc,ipompc,nodempc,
230     &           nmpc,ikmpc,ilmpc,labmpc)
231               else
232                  k=ialset(j-2)
233                  do
234                     k=k-ialset(j)
235                     if(k.ge.ialset(j-1)) exit
236                     call forcadd(k,iforcdir,forcval,
237     &                 nodeforc,ndirforc,xforc,nforc,nforc_,
238     &                 iamforc,iamplitude,nam,ntrans,trab,inotr,co,
239     &                 ikforc,ilforc,isector,add,user,idefforc,
240     &                 ipompc,nodempc,nmpc,ikmpc,ilmpc,labmpc)
241                  enddo
242               endif
243            enddo
244         endif
245      enddo
246!
247      return
248      end
249
250