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