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 createinterfacempcs(imastnode,xmastnor,nmastnode,
20     &  ikmpc,ilmpc,nmpc,ipompc,nodempc,coefmpc,labmpc,mpcfree,ikboun,
21     &  nboun)
22!
23      character*20 labmpc(*)
24!
25      integer imastnode(*),nmastnode,ikmpc(*),ilmpc(*),nmpc,
26     &  nodempc(3,*),kflag,i,j,node,lnor(3),three,k,id,id1,
27     &  ikboun(*),nboun,mpcfree,m,ipompc(*),mpcfreeold
28!
29      real*8 xmastnor(3,*),coefmpc(*),xnor(3)
30!
31      kflag=-2
32      three=3
33!
34      loop: do i=1,nmastnode
35         node=imastnode(i)
36!
37!        sorting the components of the normal in the node
38!
39         do j=1,3
40            xnor(j)=xmastnor(j,i)
41            lnor(j)=j
42         enddo
43         call dsort(xnor,lnor,three,kflag)
44!
45         do k=1,3
46            j=lnor(k)
47            idof=8*(node-1)+j
48            call nident(ikmpc,idof,nmpc,id)
49            if(id.gt.0) then
50               if(ikmpc(id).eq.idof)cycle
51            endif
52            call nident(ikboun,idof,nboun,id1)
53            if(id1.gt.0) then
54               if(ikboun(id1).eq.idof)cycle
55            endif
56            if(dabs(xnor(k)).lt.1.d-20)cycle
57!
58!           create a MPC corresponding to A.n=0
59!
60            nmpc=nmpc+1
61            labmpc(nmpc)='                    '
62            ipompc(nmpc)=mpcfree
63!
64!     updating ikmpc and ilmpc
65!
66            do m=nmpc,id+2,-1
67               ikmpc(m)=ikmpc(m-1)
68               ilmpc(m)=ilmpc(m-1)
69            enddo
70            ikmpc(id+1)=idof
71            ilmpc(id+1)=nmpc
72!
73            nodempc(1,mpcfree)=node
74            nodempc(2,mpcfree)=j
75            coefmpc(mpcfree)=xmastnor(j,i)
76            mpcfree=nodempc(3,mpcfree)
77            if(mpcfree.eq.0) then
78               write(*,*)
79     &            '*ERROR in createinterfacempcs: increase memmpc_'
80               call exit(201)
81            endif
82!
83            j=j+1
84            if(j.gt.3)j=1
85            nodempc(1,mpcfree)=node
86            nodempc(2,mpcfree)=j
87            coefmpc(mpcfree)=xmastnor(j,i)
88            mpcfree=nodempc(3,mpcfree)
89            if(mpcfree.eq.0) then
90               write(*,*)
91     &            '*ERROR in createinterfacempcs: increase memmpc_'
92               call exit(201)
93            endif
94!
95            j=j+1
96            if(j.gt.3)j=1
97            nodempc(1,mpcfree)=node
98            nodempc(2,mpcfree)=j
99            coefmpc(mpcfree)=xmastnor(j,i)
100            mpcfreeold=mpcfree
101            mpcfree=nodempc(3,mpcfree)
102            if(mpcfree.eq.0) then
103               write(*,*)
104     &            '*ERROR in createinterfacempcs: increase memmpc_'
105               call exit(201)
106            endif
107            nodempc(3,mpcfreeold)=0
108!
109            cycle loop
110         enddo
111!
112         write(*,*) '*WARNING in createinterfacempcs: no A.n MPC'
113         write(*,*) '         created for node ',node
114!
115      enddo loop
116!
117      return
118      end
119