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