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 forcadd(node,i,val,nodeforc,ndirforc,xforc,
20     &     nforc,nforc_,iamforc,iamplitude,nam,ntrans,trab,inotr,co,
21     &     ikforc,ilforc,isector,add,user,idefforc,ipompc,nodempc,
22     &     nmpc,ikmpc,ilmpc,labmpc)
23!
24!     adds a cload condition to the data base
25!
26      implicit none
27!
28      logical add,user
29!
30      character*20 labmpc(*)
31!
32      integer nodeforc(2,*),ndirforc(*),node,i,nforc,nforc_,j,
33     &     iamforc(*),iamplitude,nam,ntrans,inotr(2,*),itr,idf(3),
34     &     ikforc(*),ilforc(*),idof,id,k,isector,idefforc(*),ipompc(*),
35     &     nodempc(3,*),nmpc,ikmpc(*),ilmpc(*)
36!
37      real*8 xforc(*),val,trab(7,*),a(3,3),co(3,*)
38!
39      if(ntrans.eq.0) then
40        itr=0
41      else
42        itr=inotr(1,node)
43      endif
44!
45!     checking for boundary conditions on rotational dofs of
46!     distributing couplings
47!
48      if((i.ge.4).and.(i.le.6)) then
49!
50!     rotational dof
51!
52        idof=8*(node-1)+i
53        call nident(ikmpc,idof,nmpc,id)
54        if(id.gt.0) then
55          if(ikmpc(id).eq.idof) then
56            if(labmpc(ilmpc(id))(1:14).eq.'ROTTRACOUPLING') then
57              node=nodempc(1,nodempc(3,ipompc(ilmpc(id))))
58              i=nodempc(2,nodempc(3,ipompc(ilmpc(id))))
59              itr=0
60            endif
61          endif
62        endif
63      endif
64!
65!     change: transformations on rotations are taken into account
66!     by the normal of the mean rotation MPC, not by expanding the
67!     MPC in Carthesian coordinates
68!
69!
70!     no transformation applies to the node
71!
72      idof=8*(node-1)+i
73      call nident(ikforc,idof,nforc,id)
74      if(id.gt.0) then
75        do
76          if(ikforc(id).eq.idof) then
77            k=ilforc(id)
78            if(nodeforc(2,k).eq.isector) then
79              if(add.or.(idefforc(k).eq.1)) then
80                if(nam.gt.0) then
81                  if(iamforc(k).ne.iamplitude) then
82                    write(*,*) '*ERROR in forcadd:'
83                    write(*,*) '       it is not allowed to '
84                    write(*,*)'       define two concentrated'
85                    write(*,*) '       loads/fluxes'
86                    write(*,*) '       different amplitudes '
87                    write(*,*) '       in one step'
88                    write(*,*) 'node: ',node,' dof:',i
89                    call exit(201)
90                  endif
91                endif
92                xforc(k)=xforc(k)+val
93              else
94                xforc(k)=val
95                if(.not.user) idefforc(k)=1
96              endif
97              if(nam.gt.0) iamforc(k)=iamplitude
98              return
99            endif
100            id=id-1
101            if(id.eq.0) exit
102          else
103            exit
104          endif
105        enddo
106      endif
107!
108      nforc=nforc+1
109      if(nforc.gt.nforc_) then
110        write(*,*) '*ERROR in forcadd: increase nforc_'
111        call exit(201)
112      endif
113      nodeforc(1,nforc)=node
114      nodeforc(2,nforc)=isector
115      ndirforc(nforc)=i
116      xforc(nforc)=val
117      if(.not.user) idefforc(nforc)=1
118      if(nam.gt.0) iamforc(nforc)=iamplitude
119!
120!     updating ikforc and ilforc
121!
122      do j=nforc,id+2,-1
123        ikforc(j)=ikforc(j-1)
124        ilforc(j)=ilforc(j-1)
125      enddo
126      ikforc(id+1)=idof
127      ilforc(id+1)=nforc
128!
129      return
130      end
131
132