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 straightmpc(ipompc,nodempc,coefmpc, 20 & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, 21 & ikboun,ilboun,nboun,nboun_,xboun,inode,node,co,typeboun) 22! 23! generates MPC's for nodes staying on a straight line defined 24! by two nodes a and b. The parameter inode indicates how many 25! times the present routine was called within the same *MPC 26! definition. For inode=1 "node" is node a, for inode=2 "node" 27! is node b. Starting with inode=3 MPC's are defined. 28! 29 implicit none 30! 31 character*1 typeboun(*) 32 character*20 labmpc(*) 33! 34 integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_, 35 & ikmpc(*), 36 & ilmpc(*),node,id,mpcfreeold,j,idof,l,nodeboun(*),nodea,nodeb, 37 & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,inode,jmax,k 38! 39 real*8 coefmpc(3,*),co(3,*),dd,dmax,xboun(*) 40! 41 save nodea,nodeb,jmax 42! 43 if(inode.eq.1) then 44 nodea=node 45 return 46 elseif(inode.eq.2) then 47 nodeb=node 48 dmax=0.d0 49 do k=1,3 50 dd=abs((co(k,nodea)-co(k,nodeb))) 51 if(dd.gt.dmax) then 52 dmax=dd 53 jmax=k 54 endif 55 enddo 56 return 57 endif 58! 59 nk=nk+1 60 if(nk.gt.nk_) then 61 write(*,*) '*ERROR in straightmpc: increase nk_' 62 call exit(201) 63 endif 64 do j=1,3 65 if(j.eq.jmax) cycle 66 idof=8*(node-1)+j 67 call nident(ikmpc,idof,nmpc,id) 68 if(id.gt.0) then 69 if(ikmpc(id).eq.idof) then 70 write(*,*) '*WARNING in straightmpc: DOF for node ',node 71 write(*,*) ' in direction ',j,' has been used' 72 write(*,*) ' on the dependent side of another MPC' 73 write(*,*) ' STRAIGHT constraint cannot be applied' 74 cycle 75 endif 76 endif 77 nmpc=nmpc+1 78 if(nmpc.gt.nmpc_) then 79 write(*,*) '*ERROR in straightmpc: increase nmpc_' 80 call exit(201) 81 endif 82! 83 ipompc(nmpc)=mpcfree 84 labmpc(nmpc)='STRAIGHT ' 85! 86 do l=nmpc,id+2,-1 87 ikmpc(l)=ikmpc(l-1) 88 ilmpc(l)=ilmpc(l-1) 89 enddo 90 ikmpc(id+1)=idof 91 ilmpc(id+1)=nmpc 92! 93 nodempc(1,mpcfree)=node 94 nodempc(2,mpcfree)=j 95 mpcfree=nodempc(3,mpcfree) 96 nodempc(1,mpcfree)=node 97 nodempc(2,mpcfree)=jmax 98 mpcfree=nodempc(3,mpcfree) 99 nodempc(1,mpcfree)=nodea 100 nodempc(2,mpcfree)=j 101 mpcfree=nodempc(3,mpcfree) 102 nodempc(1,mpcfree)=nodea 103 nodempc(2,mpcfree)=jmax 104 mpcfree=nodempc(3,mpcfree) 105 nodempc(1,mpcfree)=nodeb 106 nodempc(2,mpcfree)=j 107 mpcfree=nodempc(3,mpcfree) 108 nodempc(1,mpcfree)=nodeb 109 nodempc(2,mpcfree)=jmax 110 mpcfree=nodempc(3,mpcfree) 111 nodempc(1,mpcfree)=nk 112 nodempc(2,mpcfree)=j 113 mpcfreeold=mpcfree 114 mpcfree=nodempc(3,mpcfree) 115 nodempc(3,mpcfreeold)=0 116 idof=8*(nk-1)+j 117 call nident(ikboun,idof,nboun,id) 118 nboun=nboun+1 119 if(nboun.gt.nboun_) then 120 write(*,*) '*ERROR in straightmpc: increase nboun_' 121 call exit(201) 122 endif 123 nodeboun(nboun)=nk 124 ndirboun(nboun)=j 125 typeboun(nboun)='U' 126 do l=nboun,id+2,-1 127 ikboun(l)=ikboun(l-1) 128 ilboun(l)=ilboun(l-1) 129 enddo 130 ikboun(id+1)=idof 131 ilboun(id+1)=nboun 132 enddo 133! 134 return 135 end 136