diff -Nru calculix-ccx-2.1/ccx_2.1/src/absolute_relative.f calculix-ccx-2.3/ccx_2.1/src/absolute_relative.f --- calculix-ccx-2.1/ccx_2.1/src/absolute_relative.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/absolute_relative.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,434 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine absolute_relative(node1,node2,nodem,nelem,lakon, - & kon,ipkon, nactdog,identity,ielprop,prop,iflag,v, - & xflow,f,nodef,idirf,df,cp,R,physcon,numf,set,mi) -! -! orifice element -! - implicit none -! - logical identity - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, - & ielprop(*),nodef(4),idirf(4),index,iflag, - & ipkon(*),kon(*),nelemswirl,mi(2) -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R, - & p1,p2,T1,T2,cp,physcon(*),km1,kp1,kdkm1, - & kdkp1,u,pi,Qred_crit,pt1,pt2,Tt1,Tt2,ct,fact, - & Cp_cor -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif (iflag.eq.1)then -! - kappa=(cp/(cp-R)) - pi=4.d0*datan(1.d0) - index=ielprop(nelem) - qred_crit=dsqrt(kappa/R)* - & (1+0.5d0*(kappa-1))**(-0.5*(kappa+1)/(kappa-1)) -! -! Because the flow value is independant of the chosen -! coordinate system initial mass flow value is set to -! dsqrt(T1)*P1*Qred_crit with Qred_crit/2 = 0.02021518917 -! with consideration to flow direction -! - node1=kon(ipkon(nelem)+1) - node2=kon(ipkon(nelem)+3) - p1=v(2,node1) - p2=v(2,node2) - T1=v(0,node1) - T2=v(0,node2) -! - if(p1.gt.p2) then - xflow=0.75/dsqrt(T1)*P1*qred_crit - else - xflow=-0.75/dsqrt(T1)*P1*qred_crit - endif -! - elseif(iflag.eq.2) then -! - numf=4 - kappa=(cp/(cp-R)) - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - kdkp1=kappa/kp1 -! - index=ielprop(nelem) -! - u=prop(index+1) - ct=prop(index+2) -! - if(ct.eq.0) then - nelemswirl=prop(index+3) -! -! previous element is a preswirl nozzle -! - if(lakon(nelemswirl)(2:5).eq.'ORPN') then - ct=prop(ielprop(nelemswirl)+5) -! -! previous element is a forced vortex -! - elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then - ct=prop(ielprop(nelemswirl)+7) -! -! previous element is a free vortex -! - elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then - ct=prop(ielprop(nelemswirl)+9) - endif - endif -! - pt1=v(2,node1) - pt2=v(2,node2) -! - if(lakon(nelem)(2:4).eq.'ATR') then -! - if(u/CT.ge.2) then -! - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! -! in the case of a negative flow direction -! - if(xflow.le.0d0) then - write(*,*)'' - write(*,*)'*WARNING:' - write(*,*)'in element',nelem - write(*,*)'TYPE=ABSOLUTE TO RELATIVE' - write(*,*)'mass flow negative!' - write(*,*)'check results and element definition' - endif -! - else - pt1=v(2,node2) - pt2=v(2,node1) - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - if(xflow.le.0) then - write(*,*)'' - write(*,*)'*WARNING:' - write(*,*)'in element',nelem - write(*,*)'TYPE=ABSOLUTE TO RELATIVE' - write(*,*)'mass flow negative!' - write(*,*)'check results and element definition' - endif -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif -! - elseif(lakon(nelem)(2:4).eq.'RTA') then -! - if(u/CT.lt.2) then -! - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! - if(xflow.le.0d0) then - write(*,*)'' - write(*,*)'*WARNING:' - write(*,*)'in element',nelem - write(*,*)'TYPE=RELATIVE TO ABSOLUTE' - write(*,*)'mass flow negative!' - write(*,*)'check results and element definition' - endif -! - else -! - pt1=v(2,node2) - pt2=v(2,node1) - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - if(xflow.le.0) then - write(*,*)'' - write(*,*)'*WARNING:' - write(*,*)'in element',nelem - write(*,*)'TYPE=RELATIVE TO ABSOLUTE' - write(*,*)'mass flow negative!' - write(*,*)'check results and element definition' - endif -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 -! - endif - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 -! -! computing temperature corrected Cp=Cp(T) coefficient - call cp_corrected(cp,Tt1,Tt2,cp_cor) -! - if(Tt1.lt.273) then - Tt1= Tt2 - endif -! - if(cp_cor.eq.0) then - cp_cor=cp - endif -! -! transformation from absolute system to relative system -! - if(lakon(nelem)(2:4).eq.'ATR') then -! - fact=1+(u**2-2*u*ct)/(2*Cp_cor*Tt1) -! - f=Pt2-Pt1*(fact)**kdkm1 -! -! pressure node 1 -! - df(1)=-fact**kdkm1 -! -! temperature node1 -! - df(2)=-pt1*Kdkm1*(-(u**2-2*u*ct)/(2*Cp_cor*Tt1**2)) - & *fact**(kdkm1-1) -! -! mass flow node m -! - df(3)=0 -! -! pressure node 2 -! - df(4)=1 -! -! transformation from relative system to absolute system -! - elseif(lakon(nelem)(2:4).eq.'RTA') then -! - fact=1-(u**2-2*u*ct)/(2*Cp*Tt1) -! - f=Pt2-Pt1*(fact)**kdkm1 -! - df(1)=-fact**kdkm1 -! - df(2)=-Pt1*Kdkm1*((u**2-2*u*ct)/(2*Cp*Tt1**2)) - & *fact**(kdkm1-1) -! - df(3)=0 -! - df(4)=1 -! - endif - - elseif(iflag.eq.3) then - - kappa=(cp/(cp-R)) - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - kdkp1=kappa/kp1 -! - index=ielprop(nelem) -! - u=prop(index+1) - ct=prop(index+2) -! - if(ct.eq.0) then - nelemswirl=prop(index+3) -! -! previous element is a preswirl nozzle -! - if(lakon(nelemswirl)(2:5).eq.'ORPN') then - ct=prop(ielprop(nelemswirl)+5) -! -! previous element is a forced vortex -! - elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then - ct=prop(ielprop(nelemswirl)+7) -! -! previous element is a free vortex -! - elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then - ct=prop(ielprop(nelemswirl)+9) - endif - endif -! - pt1=v(2,node1) - pt2=v(2,node2) -! - if(lakon(nelem)(2:4).eq.'ATR') then -! - if(u/CT.ge.2) then -! - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! -! in the case of a negative flow direction -! - if(xflow.le.0d0) then - write(*,*)'' - write(*,*)'*WARNING:' - write(*,*)'in element',nelem - write(*,*)'TYPE=ABSOLUTE TO RELATIVE' - write(*,*)'mass flow negative!' - write(*,*)'check results and element definition' - endif -! - else - pt1=v(2,node2) - pt2=v(2,node1) - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - if(xflow.le.0) then - write(*,*)'' - write(*,*)'*WARNING:' - write(*,*)'in element',nelem - write(*,*)'TYPE=ABSOLUTE TO RELATIVE' - write(*,*)'mass flow negative!' - write(*,*)'check results and element definition' - endif -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif -! - elseif(lakon(nelem)(2:4).eq.'RTA') then -! - if(u/CT.lt.2) then -! - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! - if(xflow.le.0d0) then - write(*,*)'' - write(*,*)'*WARNING:' - write(*,*)'in element',nelem - write(*,*)'TYPE=RELATIVE TO ABSOLUTE' - write(*,*)'mass flow negative!' - write(*,*)'check results and element definition' - endif -! - else -! - pt1=v(2,node2) - pt2=v(2,node1) - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - if(xflow.le.0) then - write(*,*)'' - write(*,*)'*WARNING:' - write(*,*)'in element',nelem - write(*,*)'TYPE=RELATIVE TO ABSOLUTE' - write(*,*)'mass flow negative!' - write(*,*)'check results and element definition' - endif -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 -! - endif - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 -! -! computing temperature corrected Cp=Cp(T) coefficient - call cp_corrected(cp,Tt1,Tt2,cp_cor) -! - if(Tt1.lt.273) then - Tt1= Tt2 - endif -! - if(cp_cor.eq.0) then - cp_cor=cp - endif - - write(1,*) '' - write(1,55) 'In line',int(nodem/100),' from node',node1, - &' to node', node2,': air massflow rate=',xflow,'kg/s' -! &,', oil massflow rate=',xflow_oil,'kg/s' - 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) - -! if(inv.eq.1) then - write(1,56)' Inlet node ',node1,': Tt1= ',Tt1, - & 'K, Ts1= ',Tt1,'K, Pt1= ',Pt1/1E5, - & 'Bar' - write(1,*)' element T ',set(numf)(1:20) - write(1,57)' u= ',u,'m/s ,Ct= ',Ct,'m/s' - write(1,56)' Outlet node ',node2,': Tt2= ',T2, - & 'K, Ts2= ',Tt2,'K, Ptt2= ',Pt2/1e5, - & 'Bar' -! - 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A,f9.5) - 57 FORMAT(1X,A,f6.2,A,f6.2,A) - - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/add_bo_st.f calculix-ccx-2.3/ccx_2.1/src/add_bo_st.f --- calculix-ccx-2.1/ccx_2.1/src/add_bo_st.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/add_bo_st.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine add_bo_st(au,jq,irow,i,j,value) -! -! stores the boundary stiffness coefficient (i,j) with value "value" -! in the stiffness matrix stored in spare matrix format -! - implicit none -! - integer jq(*),irow(*),i,j,ipointer,id - real*8 au(*),value -! - call nident(irow(jq(j)),i,jq(j+1)-jq(j),id) -! - ipointer=jq(j)+id-1 -! - if(irow(ipointer).ne.i) then -c write(*,*) i,j,ipointer,irow(ipointer) - write(*,*) '*ERROR in add_bo_st: coefficient should be 0' - stop - else - au(ipointer)=au(ipointer)+value - endif -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/addimd.f calculix-ccx-2.3/ccx_2.1/src/addimd.f --- calculix-ccx-2.1/ccx_2.1/src/addimd.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/addimd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,43 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine addimd(imd,nmd,node) -! -! adds entity "node" to field imd. imd contains the -! entities selected by the user in which results are to be -! calculated in a modal dynamics calculation -! - implicit none -! - integer imd(*),nmd,node,id,l -! - call nident(imd,node,nmd,id) - do - if(id.gt.0) then - if(imd(id).eq.node)exit - endif - nmd=nmd+1 - do l=nmd,id+2,-1 - imd(l)=imd(l-1) - enddo - imd(id+1)=node - exit - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/addimdnodedof.f calculix-ccx-2.3/ccx_2.1/src/addimdnodedof.f --- calculix-ccx-2.1/ccx_2.1/src/addimdnodedof.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/addimdnodedof.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,71 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine addimdnodedof(node,k,ikmpc,ilmpc,ipompc, - & nodempc,nmpc,imdnode,nmdnode,imddof,nmddof,nactdof,mi, - & imdmpc,nmdmpc,imdboun,nmdboun,ikboun,nboun) -! -! node was kept by the user in a modal dynamics calculation; -! the present routine checks DOF k of node; if this DOF belongs -! to a MPC all independent nodes and DOF's of the MPC have to be kept -! - implicit none -! - integer node,k,idof,ikmpc(*),ilmpc(*),ipompc(*),nodempc(3,*), - & nmpc,imdnode(*),nmdnode,imddof(*),nmddof,id,ist,index,jdof, - & mi(2),nactdof(0:mi(2),*),imdmpc(*),nmdmpc,imdboun(*),nmdboun, - & ikboun(*),nboun -! - idof=nactdof(k,node) -c write(*,*) 'addimdnodedof ',node,k,idof - if(idof.eq.0) then - idof=(node-1)*8+k -! -! checking for mpc's -! - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - call addimd(imdmpc,nmdmpc,id) - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - do - call addimd(imdnode,nmdnode,nodempc(1,index)) - jdof=nactdof(nodempc(2,index),nodempc(1,index)) - if(jdof.ne.0) call addimd(imddof,nmddof,jdof) - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif -! -! checking for spc's -! - call nident(ikboun,idof,nboun,id) - if(id.gt.0) then - if(ikboun(id).eq.idof) then - call addimd(imdboun,nmdboun,id) - endif - endif - else - call addimd(imddof,nmddof,idof) - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/add_pr.f calculix-ccx-2.3/ccx_2.1/src/add_pr.f --- calculix-ccx-2.1/ccx_2.1/src/add_pr.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/add_pr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine add_pr(au,ad,icol,jq,i,j,value,i0,i1) -! -! stores coefficient (i,j) in the stiffness matrix stored in -! profile format -! - implicit none -! - integer icol(*),jq(*),i,j,ii,jj,ipointer,i0,i1 - real*8 ad(*),au(*),value -! - if(i.eq.j) then - if(i0.eq.i1) then - ad(i)=ad(i)+value - else - ad(i)=ad(i)+2.d0*value - endif - return - elseif(i.gt.j) then - ii=j - jj=i - else - ii=i - jj=j - endif -! - if(ii.lt.jq(jj)) then - write(*,*) '*ERROR in add_pr: coefficient should be 0' - stop - else - ipointer=icol(jj)-jj+ii+1 - au(ipointer)=au(ipointer)+value - endif -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/add_sm_ei.f calculix-ccx-2.3/ccx_2.1/src/add_sm_ei.f --- calculix-ccx-2.1/ccx_2.1/src/add_sm_ei.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/add_sm_ei.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine add_sm_ei(au,ad,aub,adb,jq,irow,i,j,value,valuem, - & i0,i1) -! -! stores the stiffness coefficient (i,j) with value "value" -! in the stiffness matrix stored in spare matrix format and -! the mass coefficient (i,j) with value "valuem" in the lumped -! mass matrix -! - implicit none -! - integer jq(*),irow(*),i,j,ii,jj,ipointer,id,i0,i1 - real*8 ad(*),au(*),adb(*),aub(*),value,valuem -! - if(i.eq.j) then - if(i0.eq.i1) then - ad(i)=ad(i)+value - adb(i)=adb(i)+valuem - else - ad(i)=ad(i)+2.d0*value - adb(i)=adb(i)+2.d0*valuem - endif - return - elseif(i.gt.j) then - ii=i - jj=j - else - ii=j - jj=i - endif -c write(*,*) ii,jj,value,valuem -! - call nident(irow(jq(jj)),ii,jq(jj+1)-jq(jj),id) -! - ipointer=jq(jj)+id-1 -! - if(irow(ipointer).ne.ii) then - write(*,*) '*ERROR in add_sm_ei: coefficient should be 0' - write(*,*) i,j,ii,jj,ipointer,irow(ipointer) -c stop - else - au(ipointer)=au(ipointer)+value - aub(ipointer)=aub(ipointer)+valuem - endif -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/add_sm_fl.f calculix-ccx-2.3/ccx_2.1/src/add_sm_fl.f --- calculix-ccx-2.1/ccx_2.1/src/add_sm_fl.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/add_sm_fl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine add_sm_fl(aub,adb,jq,irow,i,j,value, - & i0,i1) -! -! stores the coefficient (i,j) with value "value" in the -! fluid matrix -! - implicit none -! - integer jq(*),irow(*),i,j,ii,jj,ipointer,id,i0,i1 - real*8 adb(*),aub(*),value -! - if(i.eq.j) then - if(i0.eq.i1) then - adb(i)=adb(i)+value - else - adb(i)=adb(i)+2.d0*value - endif - return - elseif(i.gt.j) then - ii=i - jj=j - else - ii=j - jj=i - endif -! - call nident(irow(jq(jj)),ii,jq(jj+1)-jq(jj),id) -! - ipointer=jq(jj)+id-1 -! - if(irow(ipointer).ne.ii) then - write(*,*) '*ERROR in add_sm_ei: coefficient should be 0' - write(*,*) i,j,ii,jj,ipointer,irow(ipointer) - else - aub(ipointer)=aub(ipointer)+value - endif -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/add_sm_st_as.f calculix-ccx-2.3/ccx_2.1/src/add_sm_st_as.f --- calculix-ccx-2.1/ccx_2.1/src/add_sm_st_as.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/add_sm_st_as.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine add_sm_st_as(au,ad,jq,irow,i,j,value,i0,i1,nzs) -! -! stores the stiffness coefficient (i,j) with value "value" -! in the stiffness matrix stored in spare matrix format -! - implicit none -! - integer jq(*),irow(*),i,j,ii,jj,ipointer,id,i0,i1,nzs(3),ioffset - real*8 ad(*),au(*),value -! - if(i.eq.j) then - if(i0.eq.i1) then - ad(i)=ad(i)+value - else - ad(i)=ad(i)+2.d0*value - endif - return - elseif(i.gt.j) then - ioffset=0 - ii=i - jj=j - else - ioffset=nzs(3) - ii=j - jj=i - endif -! - call nident(irow(jq(jj)),ii,jq(jj+1)-jq(jj),id) -! - ipointer=jq(jj)+id-1 -! - if(irow(ipointer).ne.ii) then - write(*,*) '*ERROR in add_sm_st: coefficient should be 0' - stop - else - ipointer=ipointer+ioffset - au(ipointer)=au(ipointer)+value - endif -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/add_sm_st.f calculix-ccx-2.3/ccx_2.1/src/add_sm_st.f --- calculix-ccx-2.1/ccx_2.1/src/add_sm_st.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/add_sm_st.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine add_sm_st(au,ad,jq,irow,i,j,value,i0,i1) -! -! stores the stiffness coefficient (i,j) with value "value" -! in the stiffness matrix stored in spare matrix format -! - implicit none -! - integer jq(*),irow(*),i,j,ii,jj,ipointer,id,i0,i1 - real*8 ad(*),au(*),value -! - if(i.eq.j) then - if(i0.eq.i1) then - ad(i)=ad(i)+value - else - ad(i)=ad(i)+2.d0*value - endif - return - elseif(i.gt.j) then - ii=i - jj=j - else - ii=j - jj=i - endif -! - call nident(irow(jq(jj)),ii,jq(jj+1)-jq(jj),id) -! - ipointer=jq(jj)+id-1 -! - if(irow(ipointer).ne.ii) then - write(*,*) '*ERROR in add_sm_st: coefficient should be 0' - stop - else - au(ipointer)=au(ipointer)+value - endif -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/allocation.f calculix-ccx-2.3/ccx_2.1/src/allocation.f --- calculix-ccx-2.1/ccx_2.1/src/allocation.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/allocation.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1530 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine allocation(nload,nforc,nboun,nk,ne,nmpc, - & nset,nalset,nmat,ntmat,npmat,norien,nam,nprint, - & mi,ntrans,set,meminset,rmeminset,ncs, - & namtot,ncmat,memmpc,ne1d,ne2d,nflow,jobnamec,irstrt, - & ithermal,nener,nstate,irestartstep,inpc,ipoinp,inp, - & ntie,nbody,nprop,ipoinpc,nevdamp) -! -! calculates a conservative estimate of the size of the -! fields to be allocated -! -! the underscores were dropped since they caused problems in the -! DDD debugger. -! -! meminset=total # of terms in sets -! rmeminset=total # of reduced terms (due to use of generate) in -! sets -! - implicit none -! - logical igen,lin,frequency,isochoric,cyclicsymmetry -! - character*1 selabel,sulabel,inpc(*) - character*5 llab - character*8 label - character*20 mpclabel - character*81 set(*),noset,elset,leftset,rightset,noelset, - & surface - character*132 jobnamec(*),textpart(16) -! - integer nload,nforc,nboun,nk,ne,nmpc,nset,nalset, - & nmat,ntmat,npmat,norien,nam,nprint,kode,iline, - & istat,n,key,meminset(*),i,js,inoset,mi(2),ii,ipol,inl, - & ibounstart,ibounend,ibound,ntrans,ntmatl,npmatl,ityp,l, - & ielset,nope,nteller,nterm,ialset(16),ncs,rmeminset(*), - & ileftset,irightset,namtot,ncmat,nconstants,memmpc,j,ipos, - & maxrmeminset,ne1d,ne2d,necper,necpsr,necaxr,nesr, - & neb32,nn,nflow,nradiate,irestartread,irestartstep,icntrl, - & irstrt,ithermal(2),nener,nstate,ipoinp(2,*),inp(3,*), - & ntie,nbody,nprop,ipoinpc(0:*),idepvar,nevdamp -! - real*8 temperature,tempact,xfreq,tpinc,tpmin,tpmax -! - integer nentries - parameter(nentries=14) -! -! in the presence of mechanical steps the highest number -! of DOF is at least 3 -! - if(ithermal(2).ne.2) mi(2)=3 -! -! initialisation of ipoinp -! - do i=1,nentries - if(ipoinp(1,i).ne.0) then - ipol=i - inl=ipoinp(1,i) - iline=inp(1,inl)-1 - exit - endif - enddo -! - istat=0 -! - nset=0 - maxrmeminset=0 - necper=0 - necpsr=0 - necaxr=0 - nesr=0 - neb32=0 - nradiate=0 - ncs=0 -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - do - if(istat.lt.0) then - exit - endif -! - if(textpart(1)(1:10).eq.'*AMPLITUDE') then - nam=nam+1 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - namtot=namtot+4 - enddo - elseif(textpart(1)(1:9).eq.'*BOUNDARY') then - nam=nam+1 - namtot=namtot+1 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit -! - read(textpart(2)(1:10),'(i10)',iostat=istat) ibounstart - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! - if(textpart(3)(1:1).eq.' ') then - ibounend=ibounstart - else - read(textpart(3)(1:10),'(i10)',iostat=istat) ibounend - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - ibound=ibounend-ibounstart+1 - ibound=max(1,ibound) - ibound=min(3,ibound) -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - nboun=nboun+ibound - if(ntrans.gt.0) then - nmpc=nmpc+ibound - memmpc=memmpc+4*ibound - nk=nk+1 - endif - else - read(textpart(1)(1:80),'(a80)',iostat=istat) noset - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - do i=1,nset - if(set(i).eq.noset) then - nboun=nboun+ibound*meminset(i) - if(ntrans.gt.0)then - nmpc=nmpc+ibound*meminset(i) - memmpc=memmpc+4*ibound*meminset(i) - nk=nk+meminset(i) - endif - exit - endif - enddo - endif - enddo - elseif(textpart(1)(1:6).eq.'*CFLUX') then - nam=nam+1 - namtot=namtot+1 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - nforc=nforc+1 - else - read(textpart(1)(1:80),'(a80)',iostat=istat) noset - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - do i=1,nset - if(set(i).eq.noset) then - nforc=nforc+meminset(i) - exit - endif - enddo - endif - enddo - elseif(textpart(1)(1:6).eq.'*CLOAD') then - nam=nam+1 - namtot=namtot+1 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - if(ntrans.eq.0) then - nforc=nforc+1 - else - nforc=nforc+3 - endif - else - read(textpart(1)(1:80),'(a80)',iostat=istat) noset - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - do i=1,nset - if(set(i).eq.noset) then - if(ntrans.eq.0) then - nforc=nforc+meminset(i) - else - nforc=nforc+3*meminset(i) - endif - exit - endif - enddo - endif - enddo - elseif((textpart(1)(1:13).eq.'*CONDUCTIVITY').or. - & (textpart(1)(1:8).eq.'*DENSITY').or. - & (textpart(1)(1:10).eq.'*EXPANSION').or. - & (textpart(1)(1:15).eq.'*FLUIDCONSTANTS').or. - & (textpart(1)(1:13).eq.'*SPECIFICHEAT')) then - ntmatl=0 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - enddo - elseif(textpart(1)(1:15).eq.'*CONTACTDAMPING') then - ncmat=max(5,ncmat) - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:12).eq.'*CONTACTPAIR') then - ntie=ntie+1 - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:13).eq.'*CONTACTPRINT') then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - nprint=nprint+n - enddo - elseif(textpart(1)(1:6).eq.'*CREEP') then - if(ityp.eq.2) then - nstate=max(nstate,13) - else - nstate=max(nstate,7) - endif - ncmat=max(9,ncmat) - npmat=max(2,npmat) - if(ncmat.ge.9) ncmat=max(19,ncmat) - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:16).eq.'*CYCLICHARDENING') then - ntmatl=0 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(3)(1:20),'(f20.0)',iostat=istat) - & temperature - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(ntmatl.eq.0) then - npmatl=0 - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - tempact=temperature - elseif(temperature.ne.tempact) then - npmatl=0 - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - tempact=temperature - endif - npmatl=npmatl+1 - npmat=max(npmatl,npmat) - enddo - elseif(textpart(1)(1:20).eq.'*CYCLICSYMMETRYMODEL') then -! -! possible MPC's: static temperature, displacements(velocities) -! and static pressure -! - nk=nk+1 - nmpc=nmpc+5*ncs - memmpc=memmpc+125*ncs - ntrans=ntrans+1 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - enddo -c call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, -c & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:8).eq.'*DASHPOT') then - nmat=nmat+1 - frequency=.false. - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - read(textpart(2)(1:20),'(f20.0)',iostat=istat) - & xfreq - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(xfreq.gt.0.d0) frequency=.true. - iline=iline-1 - if(.not.frequency) then - ntmatl=0 - ncmat=max(2,ncmat) - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - enddo - else - ntmatl=0 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(3)(1:20),'(f20.0)',iostat=istat) - & temperature - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(ntmatl.eq.0) then - npmatl=0 - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - tempact=temperature - elseif(temperature.ne.tempact) then - npmatl=0 - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - tempact=temperature - endif - npmatl=npmatl+1 - npmat=max(npmatl,npmat) - enddo - if(ncmat.ge.9) ncmat=max(19,ncmat) - endif -c nmat=nmat+1 -c ntmatl=0 -c ncmat=max(2,ncmat) -c do -c call getnewline(inpc,textpart,istat,n,key,iline,ipol, -c & inl,ipoinp,inp,ipoinpc) -c if((istat.lt.0).or.(key.eq.1)) exit -c ntmatl=ntmatl+1 -c ntmat=max(ntmatl,ntmat) -c enddo - elseif(textpart(1)(1:22).eq.'*DEFORMATIONPLASTICITY') then - ncmat=max(5,ncmat) - ntmatl=0 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - enddo - elseif(textpart(1)(1:7).eq.'*DEPVAR') then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(1)(1:10),'(i10)',iostat=istat) idepvar - nstate=max(nstate,idepvar) - enddo - elseif(textpart(1)(1:20).eq.'*DISTRIBUTEDCOUPLING') then - do i=2,n - if(textpart(i)(1:8).eq.'SURFACE=') then - surface=textpart(i)(9:88) - ipos=index(surface,' ') - surface(ipos:ipos)='T' - exit - endif - enddo - do i=1,nset - if(set(i).eq.surface) then -! -! worst case: 8 nodes per element face -! - nk=nk+8*meminset(i) -! -! 1 distributed coupling MPC -! - nmpc=nmpc+1 -! -! 3 terms * # of nodes +1 parallel to coupling -! direction -! - memmpc=memmpc+24*meminset(i)+1 - exit -! - endif - enddo - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif((textpart(1)(1:6).eq.'*DLOAD').or. - & (textpart(1)(1:6).eq.'*DFLUX').or. - & (textpart(1)(1:5).eq.'*FILM')) then - if(textpart(1)(1:5).ne.'*FILM') then - nam=nam+1 - namtot=namtot+1 - else - nam=nam+2 - namtot=namtot+2 - endif - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(2)(1:5),'(a5)',iostat=istat) llab - if((llab.eq.'GRAV ').or.(llab.eq.'CENTR').or. - & (llab.eq.'NEWTO')) then - nbody=nbody+1 - cycle - endif - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - nload=nload+1 - else - read(textpart(1)(1:80),'(a80)',iostat=istat) elset - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - do i=1,nset - if(set(i).eq.elset) then - nload=nload+meminset(i) - exit - endif - enddo - endif - enddo - elseif((textpart(1)(1:8).eq.'*DYNAMIC').or. - & (textpart(1)(1:32).eq.'*COUPLEDTEMPERATURE-DISPLACEMENT')) - & then - if((mi(1).eq.1).or.(mi(1).eq.8).or.(mi(1).eq.27)) then - mi(1)=27 - elseif(mi(1).eq.4) then - mi(1)=15 - else - mi(1)=18 - endif - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:8).eq.'*ELPRINT') then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - nprint=nprint+n - enddo - elseif(textpart(1)(1:8).eq.'*ELASTIC') then - ntmatl=0 - ityp=2 - ncmat=max(2,ncmat) - do i=2,n - if(textpart(i)(1:5).eq.'TYPE=') then - if(textpart(i)(6:8).eq.'ISO') then - ityp=2 - ncmat=max(2,ncmat) - elseif((textpart(i)(6:10).eq.'ORTHO').or. - & (textpart(i)(6:10).eq.'ENGIN')) then - ityp=9 - ncmat=max(9,ncmat) - elseif(textpart(i)(6:10).eq.'ANISO') then - ityp=21 - ncmat=max(21,ncmat) - endif - exit - endif - enddo - if(ityp.eq.2) then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - enddo - elseif(ityp.eq.9) then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - iline=iline+1 - enddo - elseif(ityp.eq.21) then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - iline=iline+2 - enddo - endif - elseif((textpart(1)(1:8).eq.'*ELEMENT').and. - & (textpart(1)(1:14).ne.'*ELEMENTOUTPUT')) then - ielset=0 - isochoric=.false. -! - loop1: do i=2,n - if(textpart(i)(1:6).eq.'ELSET=') then - elset=textpart(i)(7:86) - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - ielset=1 - do js=1,nset - if(set(js).eq.elset) exit - enddo - if(js.gt.nset) then - nset=nset+1 - set(nset)=elset - endif - elseif(textpart(i)(1:5).eq.'TYPE=') then - read(textpart(i)(6:13),'(a8)') label - if(label.eq.' ') then - write(*,*) - & '*ERROR in allocation: element type is lacking' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - if(label(1:2).eq.'DC') then - label(1:7)=label(2:8) - label(8:8)=' ' - endif - if((label.eq.'C3D20 ').or. - & (label.eq.'F3D20 ')) then - mi(1)=max(mi(1),27) - nope=20 - elseif((label(1:8).eq.'C3D20R ').or. - & (label(1:8).eq.'F3D20R ')) then - mi(1)=max(mi(1),8) - nope=20 - elseif(label(1:8).eq.'C3D20RI ') then - mi(1)=max(mi(1),8) - nope=20 - isochoric=.true. - elseif((label.eq.'C3D8R ').or. - & (label.eq.'F3D8R ')) then - mi(1)=max(mi(1),1) - nope=8 - elseif((label.eq.'C3D10 ').or. - & (label.eq.'F3D10 ')) then - mi(1)=max(mi(1),4) - nope=10 - elseif((label.eq.'C3D4 ').or. - & (label.eq.'F3D4 ')) then - mi(1)=max(mi(1),1) - nope=4 - elseif((label.eq.'C3D15 ').or. - & (label.eq.'F3D15 ')) then - mi(1)=max(mi(1),9) - nope=15 - elseif((label.eq.'C3D6 ').or. - & (label.eq.'F3D6 ')) then - mi(1)=max(mi(1),2) - nope=6 - elseif((label.eq.'CPE8R ').or. - & (label.eq.'CPS8R ').or. - & (label.eq.'CAX8R ').or. - & (label.eq.'S8R ').or. - & (label.eq.'C3D8 ').or. - & (label.eq.'F3D8 ')) then - mi(1)=max(mi(1),8) - nope=8 - elseif((label.eq.'CPE8 ').or. - & (label.eq.'CPS8 ').or. - & (label.eq.'CAX8 ').or. - & (label.eq.'S8 ')) then - mi(1)=max(mi(1),27) - nope=8 - elseif((label.eq.'CPE6 ').or. - & (label.eq.'CPS6 ').or. - & (label.eq.'CAX6 ').or. - & (label.eq.'S6 ')) then - mi(1)=max(mi(1),9) - nope=6 - elseif(label.eq.'B32 ') then - mi(1)=max(mi(1),27) - nope=3 - elseif(label.eq.'B32R ') then - mi(1)=max(mi(1),8) - nope=3 - elseif(label(1:8).eq.'DASHPOTA') then - label='EDSHPTA2' - nope=2 - elseif(label(1:1).eq.'D') then - nope=3 - mi(2)=max(3,mi(2)) - elseif(label(1:7).eq.'SPRINGA') then - mi(1)=max(mi(1),1) - label='ESPRNGA2' - nope=2 - elseif(label.eq.'GAPUNI ') then - nope=2 - endif - if(label(1:1).eq.'F') mi(2)=max(mi(2),4) - endif - enddo loop1 -! - loop2:do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(1)(1:10),'(i10)',iostat=istat) i - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(label(1:2).ne.'C3') then - if(label(1:3).eq.'CPE') then - necper=necper+1 - elseif(label(1:2).eq.'CP') then - necpsr=necpsr+1 - elseif(label(1:1).eq.'C') then - necaxr=necaxr+1 - elseif(label(1:1).eq.'S') then - nesr=nesr+1 - elseif(label(1:1).eq.'B') then - neb32=neb32+1 - elseif(label(1:1).eq.'D') then - nflow=nflow+1 - endif - endif - nteller=n-1 - if(nteller.lt.nope) then - do - call getnewline(inpc,textpart,istat,n,key,iline, - & ipol,inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit loop2 - if(nteller+n.gt.nope) n=nope-nteller - nteller=nteller+n - if(nteller.eq.nope) exit - enddo - endif - ne=max(ne,i) - if(ielset.eq.1) then - meminset(js)=meminset(js)+1 - rmeminset(js)=rmeminset(js)+1 - endif -! -! up to 8 new mpc's with 22 terms in each mpc -! (21 = 7 nodes x 3 dofs + inhomogeneous term) -! - if(isochoric) then - nmpc=nmpc+8 - nk=nk+8 - nboun=nboun+8 - memmpc=memmpc+176 - endif - enddo loop2 - elseif((textpart(1)(1:5).eq.'*NSET').or. - & (textpart(1)(1:6).eq.'*ELSET')) then - if(textpart(1)(1:5).eq.'*NSET') - & then - noelset=textpart(2)(6:85) - noelset(81:81)=' ' - ipos=index(noelset,' ') - noelset(ipos:ipos)='N' - kode=0 - else - noelset=textpart(2)(7:86) - noelset(81:81)=' ' - ipos=index(noelset,' ') - noelset(ipos:ipos)='E' - kode=1 - endif -! -! check whether new set name or old one -! - do js=1,nset - if(set(js).eq.noelset) exit - enddo - if(js.gt.nset) then - nset=nset+1 - set(nset)=noelset - nn=nset - else - nn=js - endif -! - if((n.gt.2).and.(textpart(3)(1:8).eq.'GENERATE')) then - igen=.true. - else - igen=.false. - endif - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - if(igen) then - if(textpart(2)(1:1).eq.' ') - & textpart(2)=textpart(1) - if(textpart(3)(1:1).eq.' ') - & textpart(3)='1 ' - do i=1,3 - read(textpart(i)(1:10),'(i10)',iostat=istat) - & ialset(i) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - meminset(nn)=meminset(nn)+ - & (ialset(2)-ialset(1))/ialset(3)+1 - rmeminset(nn)=rmeminset(nn)+3 - else - do i=1,n - read(textpart(i)(1:10),'(i10)',iostat=istat) - & ialset(i) - if(istat.gt.0) then - noelset=textpart(i)(1:80) - noelset(81:81)=' ' - ipos=index(noelset,' ') - if(kode.eq.0) then - noelset(ipos:ipos)='N' - else - noelset(ipos:ipos)='E' - endif - do j=1,nset - if(noelset.eq.set(j)) then - meminset(nn)=meminset(nn)+ - & meminset(j) - rmeminset(nn)=rmeminset(nn)+ - & rmeminset(j) - exit - endif - enddo - else - meminset(nn)=meminset(nn)+1 - rmeminset(nn)=rmeminset(nn)+1 - endif - enddo - endif - enddo - elseif(textpart(1)(1:9).eq.'*EQUATION') then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(1)(1:10),'(i10)',iostat=istat) nterm - if(ntrans.eq.0) then - nmpc=nmpc+1 - memmpc=memmpc+nterm - else - nmpc=nmpc+3 - memmpc=memmpc+3*nterm - endif - ii=0 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ii=ii+n/3 - if(ii.eq.nterm) exit - enddo - enddo - elseif(textpart(1)(1:13).eq.'*FACEPRINT') then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - nprint=nprint+n - enddo - elseif(textpart(1)(1:4).eq.'*GAP') then - elset=' ' - do i=2,n - if(textpart(i)(1:6).eq.'ELSET=') then - elset=textpart(i)(7:86) - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - exit - endif - enddo - if(elset.ne.' ') then - do i=1,nset - if(set(i).eq.elset) then - nk=nk+2+2*meminset(i) - nmpc=nmpc+meminset(i) - nboun=nboun+2*meminset(i) - memmpc=memmpc+8*meminset(i) - endif - enddo - endif - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:13).eq.'*FLUIDSECTION') then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - nprop=nprop+8 - enddo - elseif(textpart(1)(1:9).eq.'*FRICTION') then - ncmat=max(7,ncmat) - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:13).eq.'*HYPERELASTIC') then - ntmatl=0 - ityp=-7 - do i=2,n - if(textpart(i)(1:12).eq.'ARRUDA-BOYCE') then - ityp=-1 - ncmat=max(3,ncmat) - elseif(textpart(i)(1:13).eq.'MOONEY-RIVLIN') then - ityp=-2 - ncmat=max(3,ncmat) - elseif(textpart(i)(1:8).eq.'NEOHOOKE') then - ityp=-3 - ncmat=max(2,ncmat) - elseif(textpart(i)(1:5).eq.'OGDEN') then - ityp=-4 - ncmat=max(3,ncmat) - elseif(textpart(i)(1:10).eq.'POLYNOMIAL') then - ityp=-7 - ncmat=max(3,ncmat) - elseif(textpart(i)(1:17).eq.'REDUCEDPOLYNOMIAL') - & then - ityp=-10 - ncmat=max(2,ncmat) - elseif(textpart(i)(1:11).eq.'VANDERWAALS') then - ityp=-13 - ncmat=max(5,ncmat) - elseif(textpart(i)(1:4).eq.'YEOH') then - ityp=-14 - ncmat=max(6,ncmat) - elseif(textpart(i)(1:2).eq.'N=') then - if(textpart(i)(3:3).eq.'1') then - elseif(textpart(i)(3:3).eq.'2') then - if(ityp.eq.-4) then - ityp=-5 - ncmat=max(6,ncmat) - elseif(ityp.eq.-7) then - ityp=-8 - ncmat=max(7,ncmat) - elseif(ityp.eq.-10) then - ityp=-11 - ncmat=max(4,ncmat) - endif - elseif(textpart(i)(3:3).eq.'3') then - if(ityp.eq.-4) then - ityp=-6 - ncmat=max(9,ncmat) - elseif(ityp.eq.-7) then - ityp=-9 - ncmat=max(12,ncmat) - elseif(ityp.eq.-10) then - ityp=-12 - ncmat=max(6,ncmat) - endif - endif - endif - enddo - if((ityp.ne.-6).and.(ityp.ne.-9)) then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmat,ntmatl) - enddo - else - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmat,ntmatl) - iline=iline+1 - enddo - endif - elseif(textpart(1)(1:10).eq.'*HYPERFOAM') then - ntmatl=0 - ityp=-15 - ncmat=max(3,ncmat) - do i=2,n - if(textpart(i)(1:2).eq.'N=') then - if(textpart(i)(3:3).eq.'1') then - elseif(textpart(i)(3:3).eq.'2') then - ityp=-16 - ncmat=max(6,ncmat) - elseif(textpart(i)(3:3).eq.'3') then - ityp=-17 - ncmat=max(9,ncmat) - endif - endif - enddo - if(ityp.ne.-17) then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmat,ntmatl) - enddo - else - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmat,ntmatl) - iline=iline+1 - enddo - endif - elseif(textpart(1)(1:9).eq.'*MATERIAL') then - nmat=nmat+1 - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:13).eq.'*MODALDAMPING') then - if(textpart(2)(1:8).ne.'RAYLEIGH') then - nevdamp=0 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(1)(1:10),'(i10)',iostat=istat) i - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - nevdamp = max(nevdamp,i) - read(textpart(2)(1:10),'(i10)',iostat=istat) i - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - nevdamp = max(nevdamp,i) - enddo - else - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - endif - elseif(textpart(1)(1:4).eq.'*MPC') then - mpclabel=' ' - if((mpclabel(1:8).ne.'STRAIGHT').and. - & (mpclabel(1:4).ne.'PLANE')) then - nk=nk+1 - nmpc=nmpc+1 - nboun=nboun+1 - memmpc=memmpc+1 - endif - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - do i=1,n - read(textpart(i)(1:10),'(i10)',iostat=istat) ialset(i) - if(mpclabel.eq.' ') - & mpclabel=textpart(i)(1:20) - if(istat.gt.0) then - noelset=textpart(i)(1:80) - noelset(81:81)=' ' - ipos=index(noelset,' ') - noelset(ipos:ipos)='N' - do j=1,nset - if(noelset.eq.set(j)) then - if(mpclabel(1:8).eq.'STRAIGHT') then - nk=nk+2*meminset(j) - nmpc=nmpc+2*meminset(j) - nboun=nboun+2*meminset(j) - memmpc=memmpc+14*meminset(j) - elseif(mpclabel(1:5).eq.'PLANE') then - nk=nk+meminset(j) - nmpc=nmpc+meminset(j) - nboun=nboun+meminset(j) - memmpc=memmpc+13*meminset(j) - else - memmpc=memmpc+meminset(j) - endif - exit - endif - enddo - else - if(mpclabel(1:8).eq.'STRAIGHT') then - nk=nk+2 - nmpc=nmpc+2 - nboun=nboun+2 - memmpc=memmpc+14 - elseif(mpclabel(1:5).eq.'PLANE') then - nk=nk+1 - nmpc=nmpc+1 - nboun=nboun+1 - memmpc=memmpc+13 - else - memmpc=memmpc+1 - endif - endif - enddo - enddo - elseif((textpart(1)(1:5).eq.'*NODE').and. - & (textpart(1)(1:10).ne.'*NODEPRINT').and. - & (textpart(1)(1:9).ne.'*NODEFILE').and. - & (textpart(1)(1:11).ne.'*NODEOUTPUT')) then - inoset=0 - loop3: do i=2,n - if(textpart(i)(1:5).eq.'NSET=') then - noset=textpart(i)(6:85) - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - inoset=1 - do js=1,nset - if(set(js).eq.noset) exit - enddo - if(js.gt.nset) then - nset=nset+1 - set(nset)=noset - endif - endif - enddo loop3 -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(1)(1:10),'(i10)',iostat=istat) i - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - nk=max(nk,i) - if(inoset.eq.1) then - meminset(js)=meminset(js)+1 - rmeminset(js)=rmeminset(js)+1 - endif - enddo - elseif(textpart(1)(1:10).eq.'*NODEPRINT') then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - nprint=nprint+n - enddo - elseif(textpart(1)(1:12).eq.'*ORIENTATION') then - norien=norien+1 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - enddo - elseif(textpart(1)(1:8).eq.'*PLASTIC') then - if(ityp.eq.2) then - nstate=max(nstate,13) - else - nstate=max(nstate,14) - endif - ntmatl=0 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(3)(1:20),'(f20.0)',iostat=istat) - & temperature - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(ntmatl.eq.0) then - npmatl=0 - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - tempact=temperature - elseif(temperature.ne.tempact) then - npmatl=0 - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - tempact=temperature - endif - npmatl=npmatl+1 - npmat=max(npmatl,npmat) - enddo - if(ncmat.ge.9) ncmat=max(19,ncmat) - elseif(textpart(1)(1:19).eq.'*PRE-TENSIONSECTION') then - do i=2,n - if(textpart(i)(1:8).eq.'SURFACE=') then - surface=textpart(i)(9:88) - ipos=index(surface,' ') - surface(ipos:ipos)='T' - exit - endif - enddo - do i=1,nset - if(set(i).eq.surface) then -! -! worst case: 8 nodes per element face -! - nk=nk+8*meminset(i) -! -! 2 MPC's per node perpendicular to tension direction -! + 1 MPC in tension direction -! - nmpc=nmpc+16*meminset(i)+1 -! -! 6 terms per MPC perpendicular to tension direction -! + 6 terms * # of nodes +1 parallel to tension -! direction -! - memmpc=memmpc+96*meminset(i)+48*meminset(i)+1 - exit -! - endif - enddo - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:8).eq.'*RADIATE') then - nam=nam+2 - namtot=namtot+2 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(2)(1:5),'(a5)',iostat=istat) llab - if((llab.eq.'GRAV ').or.(llab.eq.'CENTR')) exit - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - nload=nload+1 - nradiate=nradiate+1 - else - read(textpart(1)(1:80),'(a80)',iostat=istat) elset - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - do i=1,nset - if(set(i).eq.elset) then - nload=nload+meminset(i) - nradiate=nradiate+meminset(i) - exit - endif - enddo - endif - enddo - elseif(textpart(1)(1:8).eq.'*RESTART') then - irestartread=0 - irestartstep=0 - do i=1,n - if(textpart(i)(1:4).eq.'READ') then - irestartread=1 - if(irestartstep.eq.0) irestartstep=1 - endif - if(textpart(i)(1:5).eq.'STEP=') then - read(textpart(i)(6:15),'(i10)',iostat=istat) - & irestartstep - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - enddo - if(irestartread.eq.1) then - icntrl=1 - call restartshort(nset,nload,nbody,nforc,nboun,nk,ne, - & nmpc,nalset,nmat,ntmat,npmat,norien,nam,nprint, - & mi,ntrans,ncs,namtot,ncmat,memmpc, - & ne1d,ne2d,nflow,set,meminset,rmeminset,jobnamec, - & irestartstep,icntrl,ithermal,nener,nstate,ntie) - irstrt=-1 - else - endif - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:10).eq.'*RIGIDBODY') then - noset=' - & ' - elset=' - & ' - do i=2,n - if(textpart(i)(1:5).eq.'NSET=') - & then - noset=textpart(i)(6:85) - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - exit - elseif(textpart(i)(1:6).eq.'ELSET=') - & then - elset=textpart(i)(7:86) - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - exit - endif - enddo - if(noset(1:1).ne.' ') then - do i=1,nset - if(set(i).eq.noset) then - nk=nk+2+meminset(i) - nmpc=nmpc+3*meminset(i) - memmpc=memmpc+18*meminset(i) - nboun=nboun+3*meminset(i) - endif - enddo - elseif(elset(1:1).ne.' ') then - do i=1,nset - if(set(i).eq.elset) then - nk=nk+2+20*meminset(i) - nmpc=nmpc+60*meminset(i) - memmpc=memmpc+360*meminset(i) - nboun=nboun+60*meminset(i) - endif - enddo - endif - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:7).eq.'*SPRING') then - nmat=nmat+1 - lin=.true. - do i=2,n - if(textpart(i)(1:9).eq.'NONLINEAR') then - lin=.false. - exit - endif - enddo - if(lin) then - ntmatl=0 - ncmat=max(2,ncmat) - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - enddo - else - ntmatl=0 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(3)(1:20),'(f20.0)',iostat=istat) - & temperature - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(ntmatl.eq.0) then - npmatl=0 - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - tempact=temperature - elseif(temperature.ne.tempact) then - npmatl=0 - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - tempact=temperature - endif - npmatl=npmatl+1 - npmat=max(npmatl,npmat) - enddo - if(ncmat.ge.9) ncmat=max(19,ncmat) - endif - elseif(textpart(1)(1:9).eq.'*SURFACE ') then - nset=nset+1 - sulabel='T' - do i=2,n - if(textpart(i)(1:5).eq.'NAME=') - & then - set(nset)=textpart(i)(6:85) - set(nset)(81:81)=' ' - elseif(textpart(i)(1:9).eq.'TYPE=NODE') then - sulabel='S' - endif - enddo - ipos=index(set(nset),' ') - set(nset)(ipos:ipos)=sulabel - if(sulabel.eq.'S') then - selabel='N' - else - selabel='E' - endif - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(1)(1:10),'(i10)',iostat=istat) ialset(1) - if(istat.gt.0) then - noset=textpart(1)(1:80) - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)=selabel - do i=1,nset-1 - if(set(i).eq.noset) then - meminset(nset)=meminset(nset)+meminset(i) -c rmeminset(nset)=rmeminset(nset)+rmeminset(i) -! -! surfaces are stored in expanded form -! (no equivalent to generate) -! - rmeminset(nset)=rmeminset(nset)+meminset(i) - endif - enddo - else - meminset(nset)=meminset(nset)+1 - rmeminset(nset)=rmeminset(nset)+1 - endif - enddo - elseif(textpart(1)(1:16).eq.'*SURFACEBEHAVIOR') then - ncmat=max(2,ncmat) - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:19).eq.'*SURFACEINTERACTION') then - nmat=nmat+1 - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:11).eq.'*TEMPERATURE') then - nam=nam+1 - namtot=namtot+1 - elseif(textpart(1)(1:4).eq.'*TIE') then - ntie=ntie+1 - cyclicsymmetry=.false. - do i=1,n - if((textpart(i)(1:14).eq.'CYCLICSYMMETRY').or. - & (textpart(i)(1:10).eq.'MULTISTAGE')) then - cyclicsymmetry=.true. - endif - enddo - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if(.not.cyclicsymmetry) cycle - if((istat.lt.0).or.(key.eq.1)) cycle - leftset=textpart(1)(1:80) - leftset(81:81)=' ' - ipos=index(leftset,' ') - leftset(ipos:ipos)='S' - rightset=textpart(2)(1:80) - rightset(81:81)=' ' - ipos=index(rightset,' ') - rightset(ipos:ipos)='S' - ileftset=0 - irightset=0 - do i=1,nset - if(set(i).eq.leftset) then - ileftset=i - elseif(set(i).eq.rightset) then - irightset=i - endif - enddo - if((ileftset.ne.0).and.(irightset.ne.0)) then - ncs=ncs+max(meminset(ileftset),meminset(irightset)) - else - write(*,*) '*ERROR in allocation: either the slave' - write(*,*) ' set or the master set in a *TIE' - write(*,*) ' option or both do not exist' - stop - endif - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:11).eq.'*TIMEPOINTS') then - igen=.false. - nam=nam+1 - do i=2,n - if(textpart(i)(1:8).eq.'GENERATE') then - igen=.true. - exit - endif - enddo - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - if(igen)then - if(n.lt.3)then - write(*,*)'*ERROR in allocation: *TIMEPOINTS' - call inputerror(inpc,ipoinpc,iline) - stop - else - read(textpart(1)(1:20),'(f20.0)',iostat=istat) - & tpmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) - & tpmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) - & tpinc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! - if((tpinc.le.0).or.(tpmin.ge.tpmax)) then - write(*,*) '*ERROR in allocation: *TIMEPOINTS' - call inputerror(inpc,ipoinpc,iline) - stop - else - namtot=namtot+2+INT((tpmax-tpmin)/tpinc) - endif - - endif - else - namtot=namtot+8 - endif - enddo - elseif(textpart(1)(1:10).eq.'*TRANSFORM') then - ntrans=ntrans+1 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - enddo - elseif(textpart(1)(1:13).eq.'*USERMATERIAL') then - ntmatl=0 - do i=2,n - if(textpart(i)(1:10).eq.'CONSTANTS=') then - read(textpart(i)(11:20),'(i10)',iostat=istat) - % nconstants - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - ncmat=max(nconstants,ncmat) - exit - endif - enddo - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmatl=ntmatl+1 - ntmat=max(ntmatl,ntmat) - do i=2,(nconstants-1)/8+1 - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - enddo - enddo - else - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - endif - enddo -! - do i=1,nset - nalset=nalset+rmeminset(i) - maxrmeminset=max(maxrmeminset,rmeminset(i)) - enddo -! -! extra space needed for rearrangement in elements.f and -! noelsets.f -! - nalset=nalset+maxrmeminset -! - nmpc=nmpc+1 - memmpc=memmpc+1 -! - if(irstrt.eq.0) then - ne1d=neb32 - ne2d=necper+necpsr+necaxr+nesr - endif -! -! introducing a fake tie for axisymmetric elements -! (needed for cavity radiation) -! - if(necaxr.gt.0) ntie=max(1,ntie) -! -! providing space for the expansion of shell and beam elements -! to genuine volume elements -! - nk=nk+3*8*ne2d+8*3*ne1d - if(ne1d.gt.0) then - nboun=nboun*9 - nforc=nforc*9 - elseif(ne2d.gt.0) then - nboun=nboun*4 - nforc=nforc*4 - endif -! -! providing for rigid nodes (knots) -! -! number of knots: 8*ne2d+3*ne1d -! number of expanded nodes: 3*8*ne2d+8*3*ne1d -! -! number of extra nodes (1 rotational node and -! 1 expansion node per knot -! and one inhomogeneous term node per expanded node) -! - nk=nk+(2+3)*8*ne2d+(2+8)*3*ne1d -! -! number of equations (3 per expanded node) -! - nmpc=nmpc+3*(3*8*ne2d+8*3*ne1d) -! -! number of terms: 7 per equation -! - memmpc=memmpc+7*3*(3*8*ne2d+8*3*ne1d) -! -! number of SPC's: 1 per DOF per expanded node -! - nboun=nboun+3*(3*8*ne2d+8*3*ne1d) -! -! temperature DOF in knots -! - nmpc=nmpc+(3*8*ne2d+8*3*ne1d) - memmpc=memmpc+2*(3*8*ne2d+8*3*ne1d) -! -! extra MPCs to avoid undefinid rotation of rigid body nodes -! lying on a line -! - nmpc=nmpc+3*8*ne2d+8*3*ne1d - memmpc=memmpc+3*(3*8*ne2d+8*3*ne1d) -! -! expanding the MPCs: 2-node MPC link (2D elements) or -! 5-node MPC link (1D elements) between nodes defined by -! the user and generated mid-nodes -! -c nmpc=nmpc+3*ne1d+8*ne2d -c memmpc=memmpc+15*ne1d+24*ne2d -! -! extra nodes for the radiation boundary conditions -! - nk=nk+nradiate -! - write(*,*) - write(*,*) ' The numbers below are estimated upper bounds' - write(*,*) - write(*,*) ' number of:' - write(*,*) - write(*,*) ' nodes: ',nk - write(*,*) ' elements: ',ne - write(*,*) ' one-dimensional elements: ',ne1d - write(*,*) ' two-dimensional elements: ',ne2d - write(*,*) ' integration points per element: ',mi(1) - write(*,*) - write(*,*) ' distributed facial loads: ',nload - write(*,*) ' distributed volumetric loads: ',nbody - write(*,*) ' concentrated loads: ',nforc - write(*,*) ' single point constraints: ',nboun - write(*,*) ' multiple point constraints: ',nmpc - write(*,*) ' terms in all multiple point constraints: ',memmpc - write(*,*) ' tie constraints: ',ntie - write(*,*) ' dependent nodes tied by cyclic constraints: ',ncs - write(*,*) - write(*,*) ' sets: ',nset - write(*,*) ' terms in all sets: ',nalset - write(*,*) - write(*,*) ' materials: ',nmat - write(*,*) ' constants per material and temperature: ',ncmat - write(*,*) ' temperature points per material: ',ntmat - write(*,*) ' plastic data points per material: ',npmat - write(*,*) - write(*,*) ' orientations: ',norien - write(*,*) ' amplitudes: ',nam - write(*,*) ' data points in all amplitudes: ',namtot - write(*,*) ' print requests: ',nprint - write(*,*) ' transformations: ',ntrans - write(*,*) ' property cards: ',nprop - write(*,*) -! - return - end - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/allocont.f calculix-ccx-2.3/ccx_2.1/src/allocont.f --- calculix-ccx-2.1/ccx_2.1/src/allocont.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/allocont.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,175 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine allocont(ncont,ntie,tieset,nset,set,istartset, - & iendset,ialset,lakon,ncone,tietol,ismallsliding,kind,mortar) -! -! counting the number of triangles needed for the -! triangulation of the contact master surfaces -! -! ismallsliding = 0: large sliding -! = 1: small sliding -! = 2: in-face sliding -! - implicit none -! - character*1 kind - character*8 lakon(*) - character*81 tieset(3,*),mastset,set(*),slavset -! - integer ncont,ntie,i,j,k,nset,istartset(*),iendset(*),ialset(*), - & imast,nelem,jface,ncone,islav,ismallsliding,ipos,mortar -! - real*8 tietol(*) -! -! number of master triangles -! - ncont=0 -! -! number of slave nodes -! - ncone=0 -! - do i=1,ntie -! -! check for contact conditions -! - if(tieset(1,i)(81:81).eq.kind) then - if(tietol(i).lt.-1.5d0) then - ismallsliding=2 - elseif(tietol(i).lt.-0.5d0) then - ismallsliding=max(ismallsliding,1) - endif - mastset=tieset(3,i) -! -! determining the master surface -! - do j=1,nset - if(set(j).eq.mastset) exit - enddo - if(j.gt.nset) then - write(*,*) '*ERROR in allocont: master surface', - & mastset - write(*,*) ' does not exist' - stop - endif - imast=j -! - do j=istartset(imast),iendset(imast) - if(ialset(j).gt.0) then -! - nelem=int(ialset(j)/10.d0) - jface=ialset(j)-10*nelem -! - if(lakon(nelem)(4:4).eq.'2') then - ncont=ncont+6 - elseif(lakon(nelem)(4:4).eq.'8') then - ncont=ncont+2 - elseif(lakon(nelem)(4:5).eq.'10') then - ncont=ncont+4 - elseif(lakon(nelem)(4:4).eq.'4') then - ncont=ncont+1 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - ncont=ncont+4 - else - ncont=ncont+6 - endif - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - ncont=ncont+1 - else - ncont=ncont+2 - endif - endif -! - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit -! - nelem=int(k/10.d0) - jface=k-10*nelem -! - if(lakon(nelem)(4:4).eq.'2') then - ncont=ncont+6 - elseif(lakon(nelem)(4:4).eq.'8') then - ncont=ncont+2 - elseif(lakon(nelem)(4:5).eq.'10') then - ncont=ncont+4 - elseif(lakon(nelem)(4:4).eq.'4') then - ncont=ncont+1 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - ncont=ncont+4 - else - ncont=ncont+6 - endif - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - ncont=ncont+1 - else - ncont=ncont+2 - endif - endif -! - enddo - endif - enddo -! -! counting the slave nodes -! - slavset=tieset(2,i) - ipos=index(slavset,' ') - if(slavset(ipos-1:ipos-1).eq.'T') then - mortar=1 - endif -! -! determining the slave surface -! - do j=1,nset - if(set(j).eq.slavset) exit - enddo - if(j.gt.nset) then - write(*,*) '*ERROR in allocont: ', - & 'slave nodal surface ',slavset - write(*,*) ' does not exist' - stop - endif - islav=j -! - do j=istartset(islav),iendset(islav) - if(ialset(j).gt.0) then - ncone=ncone+1 - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - ncone=ncone+1 - enddo - endif - enddo -! - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/amplitudes.f calculix-ccx-2.3/ccx_2.1/src/amplitudes.f --- calculix-ccx-2.1/ccx_2.1/src/amplitudes.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/amplitudes.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,123 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine amplitudes(inpc,textpart,amname,amta,namta,nam, - & nam_,namtot_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & ipoinpc) -! -! reading the input deck: *AMPLITUDE -! - implicit none -! - logical user -! - character*1 inpc(*) - character*80 amname(*) - character*132 textpart(16) -! - integer namta(3,*),nam,nam_,istep,istat,n,key,i,namtot, - & namtot_,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),ipos, - & ipoinpc(0:*) -! - real*8 amta(2,*),x,y -! - user=.false. -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in amplitudes: *AMPLITUDE should be' - write(*,*) ' placed before all step definitions' - stop - endif -! - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in amplitudes: increase nam_' - stop - endif - namta(3,nam)=nam - amname(nam)=' - & ' -! - do i=2,n - if(textpart(i)(1:5).eq.'NAME=') then - amname(nam)=textpart(i)(6:85) - if(textpart(i)(86:86).ne.' ') then - write(*,*)'*ERROR in amplitudes: amplitude name too long' - write(*,*) ' (more than 80 characters)' - write(*,*) ' amplitude name:',textpart(i)(1:132) - stop - endif - elseif(textpart(i)(1:14).eq.'TIME=TOTALTIME') then - namta(3,nam)=-nam - elseif(textpart(i)(1:4).eq.'USER') then - namta(1,nam)=0 - namta(2,nam)=0 - user=.true. - endif - enddo -! - if(amname(nam).eq.' - & ') then - write(*,*) '*ERROR in amplitudes: Amplitude has no name' - call inputerror(inpc,ipoinpc,iline) - endif -! - if(.not.user) then - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namta(1,nam)=namtot+1 - endif -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - do i=1,4 - if(textpart(2*i-1)(1:1).ne.' ') then - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) '*ERROR in amplitudes: increase namtot_' - stop - endif - read(textpart(2*i-1),'(f20.0)',iostat=istat) x - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2*i),'(f20.0)',iostat=istat) y - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - amta(1,namtot)=x - amta(2,namtot)=y - namta(2,nam)=namtot - else - exit - endif - enddo - enddo -! - if(namta(1,nam).gt.namta(2,nam)) then - ipos=index(amname(nam),' ') - write(*,*) '*WARNING in amplitudes: *AMPLITUDE definition ', - & amname(nam)(1:ipos-1) - write(*,*) ' has no data points' - nam=nam-1 - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/angsum.f calculix-ccx-2.3/ccx_2.1/src/angsum.f --- calculix-ccx-2.1/ccx_2.1/src/angsum.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/angsum.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,144 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine angsum(lakon,kon,ipkon,neigh,ipneigh,co,node,itypflag, - & angle) -! -! computes the sum of all spaceangles of the element edges -! adjacent to a node -! - implicit none -! - integer kon(*),ipkon(*),ielem,j,k,lneigh4(3,4),indexe,nnr, - & neigh(2,*),ipneigh(*),index,m,lneigh8(3,8),nvertex,node,itypflag -! - real*8 co(3,*),angle,cotet(3,4),spaceangle -! - data lneigh4 /2,3,4,1,3,4,1,2,4,1,2,3/ -! - data lneigh8 /2,4,5,1,3,6,2,4,7,1,3,8, - & 1,6,8,2,5,7,3,6,8,4,5,7/ -! - character*8 lakon(*) -! - index=ipneigh(node) -! - angle=0.d0 - do j=1,3 - cotet(j,1)=co(j,node) - enddo - do - if(index.eq.0) exit - ielem=neigh(1,index) -! - if(lakon(ielem)(1:5).eq.'C3D20'.and.itypflag.eq.1) then - nvertex=8 - elseif(lakon(ielem)(1:5).eq.'C3D10'.and.itypflag.eq.2) then - nvertex=4 - elseif(lakon(ielem)(1:4).eq.'C3D8'.and.itypflag.eq.3) then - nvertex=8 - else - index=neigh(2,index) - cycle - endif -! - indexe=ipkon(ielem) - do m=1,nvertex - if(kon(indexe+m).eq.node) exit - enddo - do j=1,3 - if(nvertex.eq.4) then - nnr=kon(indexe+lneigh4(j,m)) - elseif(nvertex.eq.8) then - nnr=kon(indexe+lneigh8(j,m)) - endif - do k=1,3 - cotet(k,j+1)=co(k,nnr) - enddo - enddo - angle=angle+spaceangle(cotet) - index=neigh(2,index) - enddo -! - return - end -! - real*8 function spaceangle(cotet) -! - implicit none -! - integer i,j - real*8 vector(3,3),ca,cb,cc,ca2,cb2,cc2,sa,sb,sc,cosa,sina, - & cotanb,cotanc,a,b,c,angle,cotet(3,4),absval -! calculate normal vectors - do i=1,3 -! i is vector 1, 2 and 3 - do j=1,3 -! j is x,y,z - vector(j,i)=cotet(j,i+1)-cotet(j,1) - enddo - absval=dsqrt(vector(1,i)*vector(1,i) - & +vector(2,i)*vector(2,i) - & +vector(3,i)*vector(3,i)) - do j=1,3 - vector(j,i)=vector(j,i)/absval -! write(*,*) 'vektor ij',i,j,' ist',vector(i,j) - enddo - enddo -! - ca=vector(1,1)*vector(1,2)+vector(2,1)*vector(2,2)+ - & vector(3,1)*vector(3,2) - cb=vector(1,2)*vector(1,3)+vector(2,2)*vector(2,3)+ - & vector(3,2)*vector(3,3) - cc=vector(1,1)*vector(1,3)+vector(2,1)*vector(2,3)+ - & vector(3,1)*vector(3,3) -! - ca2=min(ca*ca,1.d0) - cb2=min(cb*cb,1.d0) - cc2=min(cc*cc,1.d0) -! - sa=dsqrt(1.d0-ca2) - sb=dsqrt(1.d0-cb2) - sc=dsqrt(1.d0-cc2) -! - if((dabs(sa).lt.1.d-8).or.(dabs(sb).lt.1.d-8).or. - & (dabs(sc).lt.1.d-8)) then - angle=0.d0 - return - endif -! -! sa=dsqrt(1.d0-ca*ca) -! sb=dsqrt(1.d0-cb*cb) -! sc=dsqrt(1.d0-cc*cc) -! - cosa=(ca-cb*cc)/(sb*sc) - sina=dsqrt(1.d0-cosa*cosa) - cotanb=(sc*cb/sb-cosa*cc)/sina - cotanc=(sb*cc/sc-cosa*cb)/sina -! - a=dacos(cosa) - b=datan(1.d0/cotanb) - c=datan(1.d0/cotanc) -! - if(b.lt.0) b=b+3.141592653589793d0 - if(c.lt.0) c=c+3.141592653589793d0 -! - spaceangle=a+b+c-3.141592653589793d0 -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/anisonl.f calculix-ccx-2.3/ccx_2.1/src/anisonl.f --- calculix-ccx-2.1/ccx_2.1/src/anisonl.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/anisonl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,522 +0,0 @@ - subroutine anisonl(w,vo,elas,s,ii1,jj1,weight) -! -! This routine replaces the following lines in e_c3d.f for -! an anisotropic material -! -! do i1=1,3 -! iii1=ii1+i1-1 -! do j1=1,3 -! jjj1=jj1+j1-1 -! do k1=1,3 -! do l1=1,3 -! s(iii1,jjj1)=s(iii1,jjj1) -! & +anisox(i1,k1,j1,l1)*w(k1,l1) -! do m1=1,3 -! s(iii1,jjj1)=s(iii1,jjj1) -! & +anisox(i1,k1,m1,l1)*w(k1,l1) -! & *vo(j1,m1) -! & +anisox(m1,k1,j1,l1)*w(k1,l1) -! & *vo(i1,m1) -! do n1=1,3 -! s(iii1,jjj1)=s(iii1,jjj1) -! & +anisox(m1,k1,n1,l1) -! & *w(k1,l1)*vo(i1,m1)*vo(j1,n1) -! enddo -! enddo -! enddo -! enddo -! enddo -! enddo -! - integer ii1,jj1 - real*8 w(3,3),vo(3,3),elas(21),s(60,60),weight -! - s(ii1,jj1)=s(ii1,jj1)+((elas( 1)+elas( 1)*vo(1,1) - &+elas( 7)*vo(1,2)+elas(11)*vo(1,3)+(elas( 1)+elas( 1)*vo(1,1)+ - &elas( 7)*vo(1,2)+elas(11)*vo(1,3))*vo(1,1)+(elas( 7)+elas( 7)* - &vo(1,1)+elas(10)*vo(1,2)+elas(14)*vo(1,3))*vo(1,2)+(elas(11)+ - &elas(11)*vo(1,1)+elas(14)*vo(1,2)+elas(15)*vo(1,3))*vo(1,3))* - &w(1,1) - &+(elas( 7)+elas( 7)*vo(1,1) - &+elas( 2)*vo(1,2)+elas(16)*vo(1,3)+(elas( 7)+elas( 7)*vo(1,1)+ - &elas( 2)*vo(1,2)+elas(16)*vo(1,3))*vo(1,1)+(elas(10)+elas(10)* - &vo(1,1)+elas( 8)*vo(1,2)+elas(19)*vo(1,3))*vo(1,2)+(elas(14)+ - &elas(14)*vo(1,1)+elas(12)*vo(1,2)+elas(20)*vo(1,3))*vo(1,3))* - &w(1,2) - &+(elas(11)+elas(11)*vo(1,1) - &+elas(16)*vo(1,2)+elas( 4)*vo(1,3)+(elas(11)+elas(11)*vo(1,1)+ - &elas(16)*vo(1,2)+elas( 4)*vo(1,3))*vo(1,1)+(elas(14)+elas(14)* - &vo(1,1)+elas(19)*vo(1,2)+elas( 9)*vo(1,3))*vo(1,2)+(elas(15)+ - &elas(15)*vo(1,1)+elas(20)*vo(1,2)+elas(13)*vo(1,3))*vo(1,3))* - &w(1,3) - &+(elas( 7)+elas( 7)*vo(1,1) - &+elas(10)*vo(1,2)+elas(14)*vo(1,3)+(elas( 7)+elas( 7)*vo(1,1)+ - &elas(10)*vo(1,2)+elas(14)*vo(1,3))*vo(1,1)+(elas( 2)+elas( 2)* - &vo(1,1)+elas( 8)*vo(1,2)+elas(12)*vo(1,3))*vo(1,2)+(elas(16)+ - &elas(16)*vo(1,1)+elas(19)*vo(1,2)+elas(20)*vo(1,3))*vo(1,3))* - &w(2,1) - &+(elas(10)+elas(10)*vo(1,1) - &+elas( 8)*vo(1,2)+elas(19)*vo(1,3)+(elas(10)+elas(10)*vo(1,1)+ - &elas( 8)*vo(1,2)+elas(19)*vo(1,3))*vo(1,1)+(elas( 8)+elas( 8)* - &vo(1,1)+elas( 3)*vo(1,2)+elas(17)*vo(1,3))*vo(1,2)+(elas(19)+ - &elas(19)*vo(1,1)+elas(17)*vo(1,2)+elas(21)*vo(1,3))*vo(1,3))* - &w(2,2) - &+(elas(14)+elas(14)*vo(1,1) - &+elas(19)*vo(1,2)+elas( 9)*vo(1,3)+(elas(14)+elas(14)*vo(1,1)+ - &elas(19)*vo(1,2)+elas( 9)*vo(1,3))*vo(1,1)+(elas(12)+elas(12)* - &vo(1,1)+elas(17)*vo(1,2)+elas( 5)*vo(1,3))*vo(1,2)+(elas(20)+ - &elas(20)*vo(1,1)+elas(21)*vo(1,2)+elas(18)*vo(1,3))*vo(1,3))* - &w(2,3) - &+(elas(11)+elas(11)*vo(1,1) - &+elas(14)*vo(1,2)+elas(15)*vo(1,3)+(elas(11)+elas(11)*vo(1,1)+ - &elas(14)*vo(1,2)+elas(15)*vo(1,3))*vo(1,1)+(elas(16)+elas(16)* - &vo(1,1)+elas(19)*vo(1,2)+elas(20)*vo(1,3))*vo(1,2)+(elas( 4)+ - &elas( 4)*vo(1,1)+elas( 9)*vo(1,2)+elas(13)*vo(1,3))*vo(1,3))* - &w(3,1) - &+(elas(14)+elas(14)*vo(1,1) - &+elas(12)*vo(1,2)+elas(20)*vo(1,3)+(elas(14)+elas(14)*vo(1,1)+ - &elas(12)*vo(1,2)+elas(20)*vo(1,3))*vo(1,1)+(elas(19)+elas(19)* - &vo(1,1)+elas(17)*vo(1,2)+elas(21)*vo(1,3))*vo(1,2)+(elas( 9)+ - &elas( 9)*vo(1,1)+elas( 5)*vo(1,2)+elas(18)*vo(1,3))*vo(1,3))* - &w(3,2) - &+(elas(15)+elas(15)*vo(1,1) - &+elas(20)*vo(1,2)+elas(13)*vo(1,3)+(elas(15)+elas(15)*vo(1,1)+ - &elas(20)*vo(1,2)+elas(13)*vo(1,3))*vo(1,1)+(elas(20)+elas(20)* - &vo(1,1)+elas(21)*vo(1,2)+elas(18)*vo(1,3))*vo(1,2)+(elas(13)+ - &elas(13)*vo(1,1)+elas(18)*vo(1,2)+elas( 6)*vo(1,3))*vo(1,3))* - &w(3,3))*weight - s(ii1,jj1+1)=s(ii1,jj1+1)+((elas( 7)+elas( 1)*vo(2,1) - &+elas( 7)*vo(2,2)+elas(11)*vo(2,3)+(elas( 7)+elas( 1)*vo(2,1)+ - &elas( 7)*vo(2,2)+elas(11)*vo(2,3))*vo(1,1)+(elas(10)+elas( 7)* - &vo(2,1)+elas(10)*vo(2,2)+elas(14)*vo(2,3))*vo(1,2)+(elas(14)+ - &elas(11)*vo(2,1)+elas(14)*vo(2,2)+elas(15)*vo(2,3))*vo(1,3))* - &w(1,1) - &+(elas( 2)+elas( 7)*vo(2,1) - &+elas( 2)*vo(2,2)+elas(16)*vo(2,3)+(elas( 2)+elas( 7)*vo(2,1)+ - &elas( 2)*vo(2,2)+elas(16)*vo(2,3))*vo(1,1)+(elas( 8)+elas(10)* - &vo(2,1)+elas( 8)*vo(2,2)+elas(19)*vo(2,3))*vo(1,2)+(elas(12)+ - &elas(14)*vo(2,1)+elas(12)*vo(2,2)+elas(20)*vo(2,3))*vo(1,3))* - &w(1,2) - &+(elas(16)+elas(11)*vo(2,1) - &+elas(16)*vo(2,2)+elas( 4)*vo(2,3)+(elas(16)+elas(11)*vo(2,1)+ - &elas(16)*vo(2,2)+elas( 4)*vo(2,3))*vo(1,1)+(elas(19)+elas(14)* - &vo(2,1)+elas(19)*vo(2,2)+elas( 9)*vo(2,3))*vo(1,2)+(elas(20)+ - &elas(15)*vo(2,1)+elas(20)*vo(2,2)+elas(13)*vo(2,3))*vo(1,3))* - &w(1,3) - &+(elas(10)+elas( 7)*vo(2,1) - &+elas(10)*vo(2,2)+elas(14)*vo(2,3)+(elas(10)+elas( 7)*vo(2,1)+ - &elas(10)*vo(2,2)+elas(14)*vo(2,3))*vo(1,1)+(elas( 8)+elas( 2)* - &vo(2,1)+elas( 8)*vo(2,2)+elas(12)*vo(2,3))*vo(1,2)+(elas(19)+ - &elas(16)*vo(2,1)+elas(19)*vo(2,2)+elas(20)*vo(2,3))*vo(1,3))* - &w(2,1) - &+(elas( 8)+elas(10)*vo(2,1) - &+elas( 8)*vo(2,2)+elas(19)*vo(2,3)+(elas( 8)+elas(10)*vo(2,1)+ - &elas( 8)*vo(2,2)+elas(19)*vo(2,3))*vo(1,1)+(elas( 3)+elas( 8)* - &vo(2,1)+elas( 3)*vo(2,2)+elas(17)*vo(2,3))*vo(1,2)+(elas(17)+ - &elas(19)*vo(2,1)+elas(17)*vo(2,2)+elas(21)*vo(2,3))*vo(1,3))* - &w(2,2) - &+(elas(19)+elas(14)*vo(2,1) - &+elas(19)*vo(2,2)+elas( 9)*vo(2,3)+(elas(19)+elas(14)*vo(2,1)+ - &elas(19)*vo(2,2)+elas( 9)*vo(2,3))*vo(1,1)+(elas(17)+elas(12)* - &vo(2,1)+elas(17)*vo(2,2)+elas( 5)*vo(2,3))*vo(1,2)+(elas(21)+ - &elas(20)*vo(2,1)+elas(21)*vo(2,2)+elas(18)*vo(2,3))*vo(1,3))* - &w(2,3) - &+(elas(14)+elas(11)*vo(2,1) - &+elas(14)*vo(2,2)+elas(15)*vo(2,3)+(elas(14)+elas(11)*vo(2,1)+ - &elas(14)*vo(2,2)+elas(15)*vo(2,3))*vo(1,1)+(elas(19)+elas(16)* - &vo(2,1)+elas(19)*vo(2,2)+elas(20)*vo(2,3))*vo(1,2)+(elas( 9)+ - &elas( 4)*vo(2,1)+elas( 9)*vo(2,2)+elas(13)*vo(2,3))*vo(1,3))* - &w(3,1) - &+(elas(12)+elas(14)*vo(2,1) - &+elas(12)*vo(2,2)+elas(20)*vo(2,3)+(elas(12)+elas(14)*vo(2,1)+ - &elas(12)*vo(2,2)+elas(20)*vo(2,3))*vo(1,1)+(elas(17)+elas(19)* - &vo(2,1)+elas(17)*vo(2,2)+elas(21)*vo(2,3))*vo(1,2)+(elas( 5)+ - &elas( 9)*vo(2,1)+elas( 5)*vo(2,2)+elas(18)*vo(2,3))*vo(1,3))* - &w(3,2) - &+(elas(20)+elas(15)*vo(2,1) - &+elas(20)*vo(2,2)+elas(13)*vo(2,3)+(elas(20)+elas(15)*vo(2,1)+ - &elas(20)*vo(2,2)+elas(13)*vo(2,3))*vo(1,1)+(elas(21)+elas(20)* - &vo(2,1)+elas(21)*vo(2,2)+elas(18)*vo(2,3))*vo(1,2)+(elas(18)+ - &elas(13)*vo(2,1)+elas(18)*vo(2,2)+elas( 6)*vo(2,3))*vo(1,3))* - &w(3,3))*weight - s(ii1,jj1+2)=s(ii1,jj1+2)+((elas(11)+elas( 1)*vo(3,1) - &+elas( 7)*vo(3,2)+elas(11)*vo(3,3)+(elas(11)+elas( 1)*vo(3,1)+ - &elas( 7)*vo(3,2)+elas(11)*vo(3,3))*vo(1,1)+(elas(14)+elas( 7)* - &vo(3,1)+elas(10)*vo(3,2)+elas(14)*vo(3,3))*vo(1,2)+(elas(15)+ - &elas(11)*vo(3,1)+elas(14)*vo(3,2)+elas(15)*vo(3,3))*vo(1,3))* - &w(1,1) - &+(elas(16)+elas( 7)*vo(3,1) - &+elas( 2)*vo(3,2)+elas(16)*vo(3,3)+(elas(16)+elas( 7)*vo(3,1)+ - &elas( 2)*vo(3,2)+elas(16)*vo(3,3))*vo(1,1)+(elas(19)+elas(10)* - &vo(3,1)+elas( 8)*vo(3,2)+elas(19)*vo(3,3))*vo(1,2)+(elas(20)+ - &elas(14)*vo(3,1)+elas(12)*vo(3,2)+elas(20)*vo(3,3))*vo(1,3))* - &w(1,2) - &+(elas( 4)+elas(11)*vo(3,1) - &+elas(16)*vo(3,2)+elas( 4)*vo(3,3)+(elas( 4)+elas(11)*vo(3,1)+ - &elas(16)*vo(3,2)+elas( 4)*vo(3,3))*vo(1,1)+(elas( 9)+elas(14)* - &vo(3,1)+elas(19)*vo(3,2)+elas( 9)*vo(3,3))*vo(1,2)+(elas(13)+ - &elas(15)*vo(3,1)+elas(20)*vo(3,2)+elas(13)*vo(3,3))*vo(1,3))* - &w(1,3) - &+(elas(14)+elas( 7)*vo(3,1) - &+elas(10)*vo(3,2)+elas(14)*vo(3,3)+(elas(14)+elas( 7)*vo(3,1)+ - &elas(10)*vo(3,2)+elas(14)*vo(3,3))*vo(1,1)+(elas(12)+elas( 2)* - &vo(3,1)+elas( 8)*vo(3,2)+elas(12)*vo(3,3))*vo(1,2)+(elas(20)+ - &elas(16)*vo(3,1)+elas(19)*vo(3,2)+elas(20)*vo(3,3))*vo(1,3))* - &w(2,1) - &+(elas(19)+elas(10)*vo(3,1) - &+elas( 8)*vo(3,2)+elas(19)*vo(3,3)+(elas(19)+elas(10)*vo(3,1)+ - &elas( 8)*vo(3,2)+elas(19)*vo(3,3))*vo(1,1)+(elas(17)+elas( 8)* - &vo(3,1)+elas( 3)*vo(3,2)+elas(17)*vo(3,3))*vo(1,2)+(elas(21)+ - &elas(19)*vo(3,1)+elas(17)*vo(3,2)+elas(21)*vo(3,3))*vo(1,3))* - &w(2,2) - &+(elas( 9)+elas(14)*vo(3,1) - &+elas(19)*vo(3,2)+elas( 9)*vo(3,3)+(elas( 9)+elas(14)*vo(3,1)+ - &elas(19)*vo(3,2)+elas( 9)*vo(3,3))*vo(1,1)+(elas( 5)+elas(12)* - &vo(3,1)+elas(17)*vo(3,2)+elas( 5)*vo(3,3))*vo(1,2)+(elas(18)+ - &elas(20)*vo(3,1)+elas(21)*vo(3,2)+elas(18)*vo(3,3))*vo(1,3))* - &w(2,3) - &+(elas(15)+elas(11)*vo(3,1) - &+elas(14)*vo(3,2)+elas(15)*vo(3,3)+(elas(15)+elas(11)*vo(3,1)+ - &elas(14)*vo(3,2)+elas(15)*vo(3,3))*vo(1,1)+(elas(20)+elas(16)* - &vo(3,1)+elas(19)*vo(3,2)+elas(20)*vo(3,3))*vo(1,2)+(elas(13)+ - &elas( 4)*vo(3,1)+elas( 9)*vo(3,2)+elas(13)*vo(3,3))*vo(1,3))* - &w(3,1) - &+(elas(20)+elas(14)*vo(3,1) - &+elas(12)*vo(3,2)+elas(20)*vo(3,3)+(elas(20)+elas(14)*vo(3,1)+ - &elas(12)*vo(3,2)+elas(20)*vo(3,3))*vo(1,1)+(elas(21)+elas(19)* - &vo(3,1)+elas(17)*vo(3,2)+elas(21)*vo(3,3))*vo(1,2)+(elas(18)+ - &elas( 9)*vo(3,1)+elas( 5)*vo(3,2)+elas(18)*vo(3,3))*vo(1,3))* - &w(3,2) - &+(elas(13)+elas(15)*vo(3,1) - &+elas(20)*vo(3,2)+elas(13)*vo(3,3)+(elas(13)+elas(15)*vo(3,1)+ - &elas(20)*vo(3,2)+elas(13)*vo(3,3))*vo(1,1)+(elas(18)+elas(20)* - &vo(3,1)+elas(21)*vo(3,2)+elas(18)*vo(3,3))*vo(1,2)+(elas( 6)+ - &elas(13)*vo(3,1)+elas(18)*vo(3,2)+elas( 6)*vo(3,3))*vo(1,3))* - &w(3,3))*weight - s(ii1+1,jj1)=s(ii1+1,jj1)+((elas( 7)+elas( 7)*vo(1,1) - &+elas(10)*vo(1,2)+elas(14)*vo(1,3)+(elas( 1)+elas( 1)*vo(1,1)+ - &elas( 7)*vo(1,2)+elas(11)*vo(1,3))*vo(2,1)+(elas( 7)+elas( 7)* - &vo(1,1)+elas(10)*vo(1,2)+elas(14)*vo(1,3))*vo(2,2)+(elas(11)+ - &elas(11)*vo(1,1)+elas(14)*vo(1,2)+elas(15)*vo(1,3))*vo(2,3))* - &w(1,1) - &+(elas(10)+elas(10)*vo(1,1) - &+elas( 8)*vo(1,2)+elas(19)*vo(1,3)+(elas( 7)+elas( 7)*vo(1,1)+ - &elas( 2)*vo(1,2)+elas(16)*vo(1,3))*vo(2,1)+(elas(10)+elas(10)* - &vo(1,1)+elas( 8)*vo(1,2)+elas(19)*vo(1,3))*vo(2,2)+(elas(14)+ - &elas(14)*vo(1,1)+elas(12)*vo(1,2)+elas(20)*vo(1,3))*vo(2,3))* - &w(1,2) - &+(elas(14)+elas(14)*vo(1,1) - &+elas(19)*vo(1,2)+elas( 9)*vo(1,3)+(elas(11)+elas(11)*vo(1,1)+ - &elas(16)*vo(1,2)+elas( 4)*vo(1,3))*vo(2,1)+(elas(14)+elas(14)* - &vo(1,1)+elas(19)*vo(1,2)+elas( 9)*vo(1,3))*vo(2,2)+(elas(15)+ - &elas(15)*vo(1,1)+elas(20)*vo(1,2)+elas(13)*vo(1,3))*vo(2,3))* - &w(1,3) - &+(elas( 2)+elas( 2)*vo(1,1) - &+elas( 8)*vo(1,2)+elas(12)*vo(1,3)+(elas( 7)+elas( 7)*vo(1,1)+ - &elas(10)*vo(1,2)+elas(14)*vo(1,3))*vo(2,1)+(elas( 2)+elas( 2)* - &vo(1,1)+elas( 8)*vo(1,2)+elas(12)*vo(1,3))*vo(2,2)+(elas(16)+ - &elas(16)*vo(1,1)+elas(19)*vo(1,2)+elas(20)*vo(1,3))*vo(2,3))* - &w(2,1) - &+(elas( 8)+elas( 8)*vo(1,1) - &+elas( 3)*vo(1,2)+elas(17)*vo(1,3)+(elas(10)+elas(10)*vo(1,1)+ - &elas( 8)*vo(1,2)+elas(19)*vo(1,3))*vo(2,1)+(elas( 8)+elas( 8)* - &vo(1,1)+elas( 3)*vo(1,2)+elas(17)*vo(1,3))*vo(2,2)+(elas(19)+ - &elas(19)*vo(1,1)+elas(17)*vo(1,2)+elas(21)*vo(1,3))*vo(2,3))* - &w(2,2) - &+(elas(12)+elas(12)*vo(1,1) - &+elas(17)*vo(1,2)+elas( 5)*vo(1,3)+(elas(14)+elas(14)*vo(1,1)+ - &elas(19)*vo(1,2)+elas( 9)*vo(1,3))*vo(2,1)+(elas(12)+elas(12)* - &vo(1,1)+elas(17)*vo(1,2)+elas( 5)*vo(1,3))*vo(2,2)+(elas(20)+ - &elas(20)*vo(1,1)+elas(21)*vo(1,2)+elas(18)*vo(1,3))*vo(2,3))* - &w(2,3) - &+(elas(16)+elas(16)*vo(1,1) - &+elas(19)*vo(1,2)+elas(20)*vo(1,3)+(elas(11)+elas(11)*vo(1,1)+ - &elas(14)*vo(1,2)+elas(15)*vo(1,3))*vo(2,1)+(elas(16)+elas(16)* - &vo(1,1)+elas(19)*vo(1,2)+elas(20)*vo(1,3))*vo(2,2)+(elas( 4)+ - &elas( 4)*vo(1,1)+elas( 9)*vo(1,2)+elas(13)*vo(1,3))*vo(2,3))* - &w(3,1) - &+(elas(19)+elas(19)*vo(1,1) - &+elas(17)*vo(1,2)+elas(21)*vo(1,3)+(elas(14)+elas(14)*vo(1,1)+ - &elas(12)*vo(1,2)+elas(20)*vo(1,3))*vo(2,1)+(elas(19)+elas(19)* - &vo(1,1)+elas(17)*vo(1,2)+elas(21)*vo(1,3))*vo(2,2)+(elas( 9)+ - &elas( 9)*vo(1,1)+elas( 5)*vo(1,2)+elas(18)*vo(1,3))*vo(2,3))* - &w(3,2) - &+(elas(20)+elas(20)*vo(1,1) - &+elas(21)*vo(1,2)+elas(18)*vo(1,3)+(elas(15)+elas(15)*vo(1,1)+ - &elas(20)*vo(1,2)+elas(13)*vo(1,3))*vo(2,1)+(elas(20)+elas(20)* - &vo(1,1)+elas(21)*vo(1,2)+elas(18)*vo(1,3))*vo(2,2)+(elas(13)+ - &elas(13)*vo(1,1)+elas(18)*vo(1,2)+elas( 6)*vo(1,3))*vo(2,3))* - &w(3,3))*weight - s(ii1+1,jj1+1)=s(ii1+1,jj1+1)+((elas(10)+elas( 7)*vo(2,1) - &+elas(10)*vo(2,2)+elas(14)*vo(2,3)+(elas( 7)+elas( 1)*vo(2,1)+ - &elas( 7)*vo(2,2)+elas(11)*vo(2,3))*vo(2,1)+(elas(10)+elas( 7)* - &vo(2,1)+elas(10)*vo(2,2)+elas(14)*vo(2,3))*vo(2,2)+(elas(14)+ - &elas(11)*vo(2,1)+elas(14)*vo(2,2)+elas(15)*vo(2,3))*vo(2,3))* - &w(1,1) - &+(elas( 8)+elas(10)*vo(2,1) - &+elas( 8)*vo(2,2)+elas(19)*vo(2,3)+(elas( 2)+elas( 7)*vo(2,1)+ - &elas( 2)*vo(2,2)+elas(16)*vo(2,3))*vo(2,1)+(elas( 8)+elas(10)* - &vo(2,1)+elas( 8)*vo(2,2)+elas(19)*vo(2,3))*vo(2,2)+(elas(12)+ - &elas(14)*vo(2,1)+elas(12)*vo(2,2)+elas(20)*vo(2,3))*vo(2,3))* - &w(1,2) - &+(elas(19)+elas(14)*vo(2,1) - &+elas(19)*vo(2,2)+elas( 9)*vo(2,3)+(elas(16)+elas(11)*vo(2,1)+ - &elas(16)*vo(2,2)+elas( 4)*vo(2,3))*vo(2,1)+(elas(19)+elas(14)* - &vo(2,1)+elas(19)*vo(2,2)+elas( 9)*vo(2,3))*vo(2,2)+(elas(20)+ - &elas(15)*vo(2,1)+elas(20)*vo(2,2)+elas(13)*vo(2,3))*vo(2,3))* - &w(1,3) - &+(elas( 8)+elas( 2)*vo(2,1) - &+elas( 8)*vo(2,2)+elas(12)*vo(2,3)+(elas(10)+elas( 7)*vo(2,1)+ - &elas(10)*vo(2,2)+elas(14)*vo(2,3))*vo(2,1)+(elas( 8)+elas( 2)* - &vo(2,1)+elas( 8)*vo(2,2)+elas(12)*vo(2,3))*vo(2,2)+(elas(19)+ - &elas(16)*vo(2,1)+elas(19)*vo(2,2)+elas(20)*vo(2,3))*vo(2,3))* - &w(2,1) - &+(elas( 3)+elas( 8)*vo(2,1) - &+elas( 3)*vo(2,2)+elas(17)*vo(2,3)+(elas( 8)+elas(10)*vo(2,1)+ - &elas( 8)*vo(2,2)+elas(19)*vo(2,3))*vo(2,1)+(elas( 3)+elas( 8)* - &vo(2,1)+elas( 3)*vo(2,2)+elas(17)*vo(2,3))*vo(2,2)+(elas(17)+ - &elas(19)*vo(2,1)+elas(17)*vo(2,2)+elas(21)*vo(2,3))*vo(2,3))* - &w(2,2) - &+(elas(17)+elas(12)*vo(2,1) - &+elas(17)*vo(2,2)+elas( 5)*vo(2,3)+(elas(19)+elas(14)*vo(2,1)+ - &elas(19)*vo(2,2)+elas( 9)*vo(2,3))*vo(2,1)+(elas(17)+elas(12)* - &vo(2,1)+elas(17)*vo(2,2)+elas( 5)*vo(2,3))*vo(2,2)+(elas(21)+ - &elas(20)*vo(2,1)+elas(21)*vo(2,2)+elas(18)*vo(2,3))*vo(2,3))* - &w(2,3) - &+(elas(19)+elas(16)*vo(2,1) - &+elas(19)*vo(2,2)+elas(20)*vo(2,3)+(elas(14)+elas(11)*vo(2,1)+ - &elas(14)*vo(2,2)+elas(15)*vo(2,3))*vo(2,1)+(elas(19)+elas(16)* - &vo(2,1)+elas(19)*vo(2,2)+elas(20)*vo(2,3))*vo(2,2)+(elas( 9)+ - &elas( 4)*vo(2,1)+elas( 9)*vo(2,2)+elas(13)*vo(2,3))*vo(2,3))* - &w(3,1) - &+(elas(17)+elas(19)*vo(2,1) - &+elas(17)*vo(2,2)+elas(21)*vo(2,3)+(elas(12)+elas(14)*vo(2,1)+ - &elas(12)*vo(2,2)+elas(20)*vo(2,3))*vo(2,1)+(elas(17)+elas(19)* - &vo(2,1)+elas(17)*vo(2,2)+elas(21)*vo(2,3))*vo(2,2)+(elas( 5)+ - &elas( 9)*vo(2,1)+elas( 5)*vo(2,2)+elas(18)*vo(2,3))*vo(2,3))* - &w(3,2) - &+(elas(21)+elas(20)*vo(2,1) - &+elas(21)*vo(2,2)+elas(18)*vo(2,3)+(elas(20)+elas(15)*vo(2,1)+ - &elas(20)*vo(2,2)+elas(13)*vo(2,3))*vo(2,1)+(elas(21)+elas(20)* - &vo(2,1)+elas(21)*vo(2,2)+elas(18)*vo(2,3))*vo(2,2)+(elas(18)+ - &elas(13)*vo(2,1)+elas(18)*vo(2,2)+elas( 6)*vo(2,3))*vo(2,3))* - &w(3,3))*weight - s(ii1+1,jj1+2)=s(ii1+1,jj1+2)+((elas(14)+elas( 7)*vo(3,1) - &+elas(10)*vo(3,2)+elas(14)*vo(3,3)+(elas(11)+elas( 1)*vo(3,1)+ - &elas( 7)*vo(3,2)+elas(11)*vo(3,3))*vo(2,1)+(elas(14)+elas( 7)* - &vo(3,1)+elas(10)*vo(3,2)+elas(14)*vo(3,3))*vo(2,2)+(elas(15)+ - &elas(11)*vo(3,1)+elas(14)*vo(3,2)+elas(15)*vo(3,3))*vo(2,3))* - &w(1,1) - &+(elas(19)+elas(10)*vo(3,1) - &+elas( 8)*vo(3,2)+elas(19)*vo(3,3)+(elas(16)+elas( 7)*vo(3,1)+ - &elas( 2)*vo(3,2)+elas(16)*vo(3,3))*vo(2,1)+(elas(19)+elas(10)* - &vo(3,1)+elas( 8)*vo(3,2)+elas(19)*vo(3,3))*vo(2,2)+(elas(20)+ - &elas(14)*vo(3,1)+elas(12)*vo(3,2)+elas(20)*vo(3,3))*vo(2,3))* - &w(1,2) - &+(elas( 9)+elas(14)*vo(3,1) - &+elas(19)*vo(3,2)+elas( 9)*vo(3,3)+(elas( 4)+elas(11)*vo(3,1)+ - &elas(16)*vo(3,2)+elas( 4)*vo(3,3))*vo(2,1)+(elas( 9)+elas(14)* - &vo(3,1)+elas(19)*vo(3,2)+elas( 9)*vo(3,3))*vo(2,2)+(elas(13)+ - &elas(15)*vo(3,1)+elas(20)*vo(3,2)+elas(13)*vo(3,3))*vo(2,3))* - &w(1,3) - &+(elas(12)+elas( 2)*vo(3,1) - &+elas( 8)*vo(3,2)+elas(12)*vo(3,3)+(elas(14)+elas( 7)*vo(3,1)+ - &elas(10)*vo(3,2)+elas(14)*vo(3,3))*vo(2,1)+(elas(12)+elas( 2)* - &vo(3,1)+elas( 8)*vo(3,2)+elas(12)*vo(3,3))*vo(2,2)+(elas(20)+ - &elas(16)*vo(3,1)+elas(19)*vo(3,2)+elas(20)*vo(3,3))*vo(2,3))* - &w(2,1) - &+(elas(17)+elas( 8)*vo(3,1) - &+elas( 3)*vo(3,2)+elas(17)*vo(3,3)+(elas(19)+elas(10)*vo(3,1)+ - &elas( 8)*vo(3,2)+elas(19)*vo(3,3))*vo(2,1)+(elas(17)+elas( 8)* - &vo(3,1)+elas( 3)*vo(3,2)+elas(17)*vo(3,3))*vo(2,2)+(elas(21)+ - &elas(19)*vo(3,1)+elas(17)*vo(3,2)+elas(21)*vo(3,3))*vo(2,3))* - &w(2,2) - &+(elas( 5)+elas(12)*vo(3,1) - &+elas(17)*vo(3,2)+elas( 5)*vo(3,3)+(elas( 9)+elas(14)*vo(3,1)+ - &elas(19)*vo(3,2)+elas( 9)*vo(3,3))*vo(2,1)+(elas( 5)+elas(12)* - &vo(3,1)+elas(17)*vo(3,2)+elas( 5)*vo(3,3))*vo(2,2)+(elas(18)+ - &elas(20)*vo(3,1)+elas(21)*vo(3,2)+elas(18)*vo(3,3))*vo(2,3))* - &w(2,3) - &+(elas(20)+elas(16)*vo(3,1) - &+elas(19)*vo(3,2)+elas(20)*vo(3,3)+(elas(15)+elas(11)*vo(3,1)+ - &elas(14)*vo(3,2)+elas(15)*vo(3,3))*vo(2,1)+(elas(20)+elas(16)* - &vo(3,1)+elas(19)*vo(3,2)+elas(20)*vo(3,3))*vo(2,2)+(elas(13)+ - &elas( 4)*vo(3,1)+elas( 9)*vo(3,2)+elas(13)*vo(3,3))*vo(2,3))* - &w(3,1) - &+(elas(21)+elas(19)*vo(3,1) - &+elas(17)*vo(3,2)+elas(21)*vo(3,3)+(elas(20)+elas(14)*vo(3,1)+ - &elas(12)*vo(3,2)+elas(20)*vo(3,3))*vo(2,1)+(elas(21)+elas(19)* - &vo(3,1)+elas(17)*vo(3,2)+elas(21)*vo(3,3))*vo(2,2)+(elas(18)+ - &elas( 9)*vo(3,1)+elas( 5)*vo(3,2)+elas(18)*vo(3,3))*vo(2,3))* - &w(3,2) - &+(elas(18)+elas(20)*vo(3,1) - &+elas(21)*vo(3,2)+elas(18)*vo(3,3)+(elas(13)+elas(15)*vo(3,1)+ - &elas(20)*vo(3,2)+elas(13)*vo(3,3))*vo(2,1)+(elas(18)+elas(20)* - &vo(3,1)+elas(21)*vo(3,2)+elas(18)*vo(3,3))*vo(2,2)+(elas( 6)+ - &elas(13)*vo(3,1)+elas(18)*vo(3,2)+elas( 6)*vo(3,3))*vo(2,3))* - &w(3,3))*weight - s(ii1+2,jj1)=s(ii1+2,jj1+0)+((elas(11)+elas(11)*vo(1,1) - &+elas(14)*vo(1,2)+elas(15)*vo(1,3)+(elas( 1)+elas( 1)*vo(1,1)+ - &elas( 7)*vo(1,2)+elas(11)*vo(1,3))*vo(3,1)+(elas( 7)+elas( 7)* - &vo(1,1)+elas(10)*vo(1,2)+elas(14)*vo(1,3))*vo(3,2)+(elas(11)+ - &elas(11)*vo(1,1)+elas(14)*vo(1,2)+elas(15)*vo(1,3))*vo(3,3))* - &w(1,1) - &+(elas(14)+elas(14)*vo(1,1) - &+elas(12)*vo(1,2)+elas(20)*vo(1,3)+(elas( 7)+elas( 7)*vo(1,1)+ - &elas( 2)*vo(1,2)+elas(16)*vo(1,3))*vo(3,1)+(elas(10)+elas(10)* - &vo(1,1)+elas( 8)*vo(1,2)+elas(19)*vo(1,3))*vo(3,2)+(elas(14)+ - &elas(14)*vo(1,1)+elas(12)*vo(1,2)+elas(20)*vo(1,3))*vo(3,3))* - &w(1,2) - &+(elas(15)+elas(15)*vo(1,1) - &+elas(20)*vo(1,2)+elas(13)*vo(1,3)+(elas(11)+elas(11)*vo(1,1)+ - &elas(16)*vo(1,2)+elas( 4)*vo(1,3))*vo(3,1)+(elas(14)+elas(14)* - &vo(1,1)+elas(19)*vo(1,2)+elas( 9)*vo(1,3))*vo(3,2)+(elas(15)+ - &elas(15)*vo(1,1)+elas(20)*vo(1,2)+elas(13)*vo(1,3))*vo(3,3))* - &w(1,3) - &+(elas(16)+elas(16)*vo(1,1) - &+elas(19)*vo(1,2)+elas(20)*vo(1,3)+(elas( 7)+elas( 7)*vo(1,1)+ - &elas(10)*vo(1,2)+elas(14)*vo(1,3))*vo(3,1)+(elas( 2)+elas( 2)* - &vo(1,1)+elas( 8)*vo(1,2)+elas(12)*vo(1,3))*vo(3,2)+(elas(16)+ - &elas(16)*vo(1,1)+elas(19)*vo(1,2)+elas(20)*vo(1,3))*vo(3,3))* - &w(2,1) - &+(elas(19)+elas(19)*vo(1,1) - &+elas(17)*vo(1,2)+elas(21)*vo(1,3)+(elas(10)+elas(10)*vo(1,1)+ - &elas( 8)*vo(1,2)+elas(19)*vo(1,3))*vo(3,1)+(elas( 8)+elas( 8)* - &vo(1,1)+elas( 3)*vo(1,2)+elas(17)*vo(1,3))*vo(3,2)+(elas(19)+ - &elas(19)*vo(1,1)+elas(17)*vo(1,2)+elas(21)*vo(1,3))*vo(3,3))* - &w(2,2) - &+(elas(20)+elas(20)*vo(1,1) - &+elas(21)*vo(1,2)+elas(18)*vo(1,3)+(elas(14)+elas(14)*vo(1,1)+ - &elas(19)*vo(1,2)+elas( 9)*vo(1,3))*vo(3,1)+(elas(12)+elas(12)* - &vo(1,1)+elas(17)*vo(1,2)+elas( 5)*vo(1,3))*vo(3,2)+(elas(20)+ - &elas(20)*vo(1,1)+elas(21)*vo(1,2)+elas(18)*vo(1,3))*vo(3,3))* - &w(2,3) - &+(elas( 4)+elas( 4)*vo(1,1) - &+elas( 9)*vo(1,2)+elas(13)*vo(1,3)+(elas(11)+elas(11)*vo(1,1)+ - &elas(14)*vo(1,2)+elas(15)*vo(1,3))*vo(3,1)+(elas(16)+elas(16)* - &vo(1,1)+elas(19)*vo(1,2)+elas(20)*vo(1,3))*vo(3,2)+(elas( 4)+ - &elas( 4)*vo(1,1)+elas( 9)*vo(1,2)+elas(13)*vo(1,3))*vo(3,3))* - &w(3,1) - &+(elas( 9)+elas( 9)*vo(1,1) - &+elas( 5)*vo(1,2)+elas(18)*vo(1,3)+(elas(14)+elas(14)*vo(1,1)+ - &elas(12)*vo(1,2)+elas(20)*vo(1,3))*vo(3,1)+(elas(19)+elas(19)* - &vo(1,1)+elas(17)*vo(1,2)+elas(21)*vo(1,3))*vo(3,2)+(elas( 9)+ - &elas( 9)*vo(1,1)+elas( 5)*vo(1,2)+elas(18)*vo(1,3))*vo(3,3))* - &w(3,2) - &+(elas(13)+elas(13)*vo(1,1) - &+elas(18)*vo(1,2)+elas( 6)*vo(1,3)+(elas(15)+elas(15)*vo(1,1)+ - &elas(20)*vo(1,2)+elas(13)*vo(1,3))*vo(3,1)+(elas(20)+elas(20)* - &vo(1,1)+elas(21)*vo(1,2)+elas(18)*vo(1,3))*vo(3,2)+(elas(13)+ - &elas(13)*vo(1,1)+elas(18)*vo(1,2)+elas( 6)*vo(1,3))*vo(3,3))* - &w(3,3))*weight - s(ii1+2,jj1+1)=s(ii1+2,jj1+1)+((elas(14)+elas(11)*vo(2,1) - &+elas(14)*vo(2,2)+elas(15)*vo(2,3)+(elas( 7)+elas( 1)*vo(2,1)+ - &elas( 7)*vo(2,2)+elas(11)*vo(2,3))*vo(3,1)+(elas(10)+elas( 7)* - &vo(2,1)+elas(10)*vo(2,2)+elas(14)*vo(2,3))*vo(3,2)+(elas(14)+ - &elas(11)*vo(2,1)+elas(14)*vo(2,2)+elas(15)*vo(2,3))*vo(3,3))* - &w(1,1) - &+(elas(12)+elas(14)*vo(2,1) - &+elas(12)*vo(2,2)+elas(20)*vo(2,3)+(elas( 2)+elas( 7)*vo(2,1)+ - &elas( 2)*vo(2,2)+elas(16)*vo(2,3))*vo(3,1)+(elas( 8)+elas(10)* - &vo(2,1)+elas( 8)*vo(2,2)+elas(19)*vo(2,3))*vo(3,2)+(elas(12)+ - &elas(14)*vo(2,1)+elas(12)*vo(2,2)+elas(20)*vo(2,3))*vo(3,3))* - &w(1,2) - &+(elas(20)+elas(15)*vo(2,1) - &+elas(20)*vo(2,2)+elas(13)*vo(2,3)+(elas(16)+elas(11)*vo(2,1)+ - &elas(16)*vo(2,2)+elas( 4)*vo(2,3))*vo(3,1)+(elas(19)+elas(14)* - &vo(2,1)+elas(19)*vo(2,2)+elas( 9)*vo(2,3))*vo(3,2)+(elas(20)+ - &elas(15)*vo(2,1)+elas(20)*vo(2,2)+elas(13)*vo(2,3))*vo(3,3))* - &w(1,3) - &+(elas(19)+elas(16)*vo(2,1) - &+elas(19)*vo(2,2)+elas(20)*vo(2,3)+(elas(10)+elas( 7)*vo(2,1)+ - &elas(10)*vo(2,2)+elas(14)*vo(2,3))*vo(3,1)+(elas( 8)+elas( 2)* - &vo(2,1)+elas( 8)*vo(2,2)+elas(12)*vo(2,3))*vo(3,2)+(elas(19)+ - &elas(16)*vo(2,1)+elas(19)*vo(2,2)+elas(20)*vo(2,3))*vo(3,3))* - &w(2,1) - &+(elas(17)+elas(19)*vo(2,1) - &+elas(17)*vo(2,2)+elas(21)*vo(2,3)+(elas( 8)+elas(10)*vo(2,1)+ - &elas( 8)*vo(2,2)+elas(19)*vo(2,3))*vo(3,1)+(elas( 3)+elas( 8)* - &vo(2,1)+elas( 3)*vo(2,2)+elas(17)*vo(2,3))*vo(3,2)+(elas(17)+ - &elas(19)*vo(2,1)+elas(17)*vo(2,2)+elas(21)*vo(2,3))*vo(3,3))* - &w(2,2) - &+(elas(21)+elas(20)*vo(2,1) - &+elas(21)*vo(2,2)+elas(18)*vo(2,3)+(elas(19)+elas(14)*vo(2,1)+ - &elas(19)*vo(2,2)+elas( 9)*vo(2,3))*vo(3,1)+(elas(17)+elas(12)* - &vo(2,1)+elas(17)*vo(2,2)+elas( 5)*vo(2,3))*vo(3,2)+(elas(21)+ - &elas(20)*vo(2,1)+elas(21)*vo(2,2)+elas(18)*vo(2,3))*vo(3,3))* - &w(2,3) - &+(elas( 9)+elas( 4)*vo(2,1) - &+elas( 9)*vo(2,2)+elas(13)*vo(2,3)+(elas(14)+elas(11)*vo(2,1)+ - &elas(14)*vo(2,2)+elas(15)*vo(2,3))*vo(3,1)+(elas(19)+elas(16)* - &vo(2,1)+elas(19)*vo(2,2)+elas(20)*vo(2,3))*vo(3,2)+(elas( 9)+ - &elas( 4)*vo(2,1)+elas( 9)*vo(2,2)+elas(13)*vo(2,3))*vo(3,3))* - &w(3,1) - &+(elas( 5)+elas( 9)*vo(2,1) - &+elas( 5)*vo(2,2)+elas(18)*vo(2,3)+(elas(12)+elas(14)*vo(2,1)+ - &elas(12)*vo(2,2)+elas(20)*vo(2,3))*vo(3,1)+(elas(17)+elas(19)* - &vo(2,1)+elas(17)*vo(2,2)+elas(21)*vo(2,3))*vo(3,2)+(elas( 5)+ - &elas( 9)*vo(2,1)+elas( 5)*vo(2,2)+elas(18)*vo(2,3))*vo(3,3))* - &w(3,2) - &+(elas(18)+elas(13)*vo(2,1) - &+elas(18)*vo(2,2)+elas( 6)*vo(2,3)+(elas(20)+elas(15)*vo(2,1)+ - &elas(20)*vo(2,2)+elas(13)*vo(2,3))*vo(3,1)+(elas(21)+elas(20)* - &vo(2,1)+elas(21)*vo(2,2)+elas(18)*vo(2,3))*vo(3,2)+(elas(18)+ - &elas(13)*vo(2,1)+elas(18)*vo(2,2)+elas( 6)*vo(2,3))*vo(3,3))* - &w(3,3))*weight - s(ii1+2,jj1+2)=s(ii1+2,jj1+2)+((elas(15)+elas(11)*vo(3,1) - &+elas(14)*vo(3,2)+elas(15)*vo(3,3)+(elas(11)+elas( 1)*vo(3,1)+ - &elas( 7)*vo(3,2)+elas(11)*vo(3,3))*vo(3,1)+(elas(14)+elas( 7)* - &vo(3,1)+elas(10)*vo(3,2)+elas(14)*vo(3,3))*vo(3,2)+(elas(15)+ - &elas(11)*vo(3,1)+elas(14)*vo(3,2)+elas(15)*vo(3,3))*vo(3,3))* - &w(1,1) - &+(elas(20)+elas(14)*vo(3,1) - &+elas(12)*vo(3,2)+elas(20)*vo(3,3)+(elas(16)+elas( 7)*vo(3,1)+ - &elas( 2)*vo(3,2)+elas(16)*vo(3,3))*vo(3,1)+(elas(19)+elas(10)* - &vo(3,1)+elas( 8)*vo(3,2)+elas(19)*vo(3,3))*vo(3,2)+(elas(20)+ - &elas(14)*vo(3,1)+elas(12)*vo(3,2)+elas(20)*vo(3,3))*vo(3,3))* - &w(1,2) - &+(elas(13)+elas(15)*vo(3,1) - &+elas(20)*vo(3,2)+elas(13)*vo(3,3)+(elas( 4)+elas(11)*vo(3,1)+ - &elas(16)*vo(3,2)+elas( 4)*vo(3,3))*vo(3,1)+(elas( 9)+elas(14)* - &vo(3,1)+elas(19)*vo(3,2)+elas( 9)*vo(3,3))*vo(3,2)+(elas(13)+ - &elas(15)*vo(3,1)+elas(20)*vo(3,2)+elas(13)*vo(3,3))*vo(3,3))* - &w(1,3) - &+(elas(20)+elas(16)*vo(3,1) - &+elas(19)*vo(3,2)+elas(20)*vo(3,3)+(elas(14)+elas( 7)*vo(3,1)+ - &elas(10)*vo(3,2)+elas(14)*vo(3,3))*vo(3,1)+(elas(12)+elas( 2)* - &vo(3,1)+elas( 8)*vo(3,2)+elas(12)*vo(3,3))*vo(3,2)+(elas(20)+ - &elas(16)*vo(3,1)+elas(19)*vo(3,2)+elas(20)*vo(3,3))*vo(3,3))* - &w(2,1) - &+(elas(21)+elas(19)*vo(3,1) - &+elas(17)*vo(3,2)+elas(21)*vo(3,3)+(elas(19)+elas(10)*vo(3,1)+ - &elas( 8)*vo(3,2)+elas(19)*vo(3,3))*vo(3,1)+(elas(17)+elas( 8)* - &vo(3,1)+elas( 3)*vo(3,2)+elas(17)*vo(3,3))*vo(3,2)+(elas(21)+ - &elas(19)*vo(3,1)+elas(17)*vo(3,2)+elas(21)*vo(3,3))*vo(3,3))* - &w(2,2) - &+(elas(18)+elas(20)*vo(3,1) - &+elas(21)*vo(3,2)+elas(18)*vo(3,3)+(elas( 9)+elas(14)*vo(3,1)+ - &elas(19)*vo(3,2)+elas( 9)*vo(3,3))*vo(3,1)+(elas( 5)+elas(12)* - &vo(3,1)+elas(17)*vo(3,2)+elas( 5)*vo(3,3))*vo(3,2)+(elas(18)+ - &elas(20)*vo(3,1)+elas(21)*vo(3,2)+elas(18)*vo(3,3))*vo(3,3))* - &w(2,3) - &+(elas(13)+elas( 4)*vo(3,1) - &+elas( 9)*vo(3,2)+elas(13)*vo(3,3)+(elas(15)+elas(11)*vo(3,1)+ - &elas(14)*vo(3,2)+elas(15)*vo(3,3))*vo(3,1)+(elas(20)+elas(16)* - &vo(3,1)+elas(19)*vo(3,2)+elas(20)*vo(3,3))*vo(3,2)+(elas(13)+ - &elas( 4)*vo(3,1)+elas( 9)*vo(3,2)+elas(13)*vo(3,3))*vo(3,3))* - &w(3,1) - &+(elas(18)+elas( 9)*vo(3,1) - &+elas( 5)*vo(3,2)+elas(18)*vo(3,3)+(elas(20)+elas(14)*vo(3,1)+ - &elas(12)*vo(3,2)+elas(20)*vo(3,3))*vo(3,1)+(elas(21)+elas(19)* - &vo(3,1)+elas(17)*vo(3,2)+elas(21)*vo(3,3))*vo(3,2)+(elas(18)+ - &elas( 9)*vo(3,1)+elas( 5)*vo(3,2)+elas(18)*vo(3,3))*vo(3,3))* - &w(3,2) - &+(elas( 6)+elas(13)*vo(3,1) - &+elas(18)*vo(3,2)+elas( 6)*vo(3,3)+(elas(13)+elas(15)*vo(3,1)+ - &elas(20)*vo(3,2)+elas(13)*vo(3,3))*vo(3,1)+(elas(18)+elas(20)* - &vo(3,1)+elas(21)*vo(3,2)+elas(18)*vo(3,3))*vo(3,2)+(elas( 6)+ - &elas(13)*vo(3,1)+elas(18)*vo(3,2)+elas( 6)*vo(3,3))*vo(3,3))* - &w(3,3))*weight -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/anisotropic.f calculix-ccx-2.3/ccx_2.1/src/anisotropic.f --- calculix-ccx-2.1/ccx_2.1/src/anisotropic.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/anisotropic.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,112 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine anisotropic(anisol,anisox) -! -! expands the 21 anisotropic elastic constants into a -! 3x3x3x3 matrix -! - implicit none -! - real*8 anisol(21),anisox(3,3,3,3) -! - anisox(1,1,1,1)=anisol(1) - anisox(1,1,1,2)=anisol(7) - anisox(1,1,1,3)=anisol(11) - anisox(1,1,2,1)=anisol(7) - anisox(1,1,2,2)=anisol(2) - anisox(1,1,2,3)=anisol(16) - anisox(1,1,3,1)=anisol(11) - anisox(1,1,3,2)=anisol(16) - anisox(1,1,3,3)=anisol(4) - anisox(1,2,1,1)=anisol(7) - anisox(1,2,1,2)=anisol(10) - anisox(1,2,1,3)=anisol(14) - anisox(1,2,2,1)=anisol(10) - anisox(1,2,2,2)=anisol(8) - anisox(1,2,2,3)=anisol(19) - anisox(1,2,3,1)=anisol(14) - anisox(1,2,3,2)=anisol(19) - anisox(1,2,3,3)=anisol(9) - anisox(1,3,1,1)=anisol(11) - anisox(1,3,1,2)=anisol(14) - anisox(1,3,1,3)=anisol(15) - anisox(1,3,2,1)=anisol(14) - anisox(1,3,2,2)=anisol(12) - anisox(1,3,2,3)=anisol(20) - anisox(1,3,3,1)=anisol(15) - anisox(1,3,3,2)=anisol(20) - anisox(1,3,3,3)=anisol(13) - anisox(2,1,1,1)=anisol(7) - anisox(2,1,1,2)=anisol(10) - anisox(2,1,1,3)=anisol(14) - anisox(2,1,2,1)=anisol(10) - anisox(2,1,2,2)=anisol(8) - anisox(2,1,2,3)=anisol(19) - anisox(2,1,3,1)=anisol(14) - anisox(2,1,3,2)=anisol(19) - anisox(2,1,3,3)=anisol(9) - anisox(2,2,1,1)=anisol(2) - anisox(2,2,1,2)=anisol(8) - anisox(2,2,1,3)=anisol(12) - anisox(2,2,2,1)=anisol(8) - anisox(2,2,2,2)=anisol(3) - anisox(2,2,2,3)=anisol(17) - anisox(2,2,3,1)=anisol(12) - anisox(2,2,3,2)=anisol(17) - anisox(2,2,3,3)=anisol(5) - anisox(2,3,1,1)=anisol(16) - anisox(2,3,1,2)=anisol(19) - anisox(2,3,1,3)=anisol(20) - anisox(2,3,2,1)=anisol(19) - anisox(2,3,2,2)=anisol(17) - anisox(2,3,2,3)=anisol(21) - anisox(2,3,3,1)=anisol(20) - anisox(2,3,3,2)=anisol(21) - anisox(2,3,3,3)=anisol(18) - anisox(3,1,1,1)=anisol(11) - anisox(3,1,1,2)=anisol(14) - anisox(3,1,1,3)=anisol(15) - anisox(3,1,2,1)=anisol(14) - anisox(3,1,2,2)=anisol(12) - anisox(3,1,2,3)=anisol(20) - anisox(3,1,3,1)=anisol(15) - anisox(3,1,3,2)=anisol(20) - anisox(3,1,3,3)=anisol(13) - anisox(3,2,1,1)=anisol(16) - anisox(3,2,1,2)=anisol(19) - anisox(3,2,1,3)=anisol(20) - anisox(3,2,2,1)=anisol(19) - anisox(3,2,2,2)=anisol(17) - anisox(3,2,2,3)=anisol(21) - anisox(3,2,3,1)=anisol(20) - anisox(3,2,3,2)=anisol(21) - anisox(3,2,3,3)=anisol(18) - anisox(3,3,1,1)=anisol(4) - anisox(3,3,1,2)=anisol(9) - anisox(3,3,1,3)=anisol(13) - anisox(3,3,2,1)=anisol(9) - anisox(3,3,2,2)=anisol(5) - anisox(3,3,2,3)=anisol(18) - anisox(3,3,3,1)=anisol(13) - anisox(3,3,3,2)=anisol(18) - anisox(3,3,3,3)=anisol(6) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/applybounk.f calculix-ccx-2.3/ccx_2.1/src/applybounk.f --- calculix-ccx-2.1/ccx_2.1/src/applybounk.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/applybounk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine applybounk(nodeboun,ndirboun,nboun,xbounact, - & iponoel,vold,ipompc,nodempc,coefmpc,nmpc,nfreestream, - & ifreestream,nsolidsurf,isolidsurf,xsolidsurf, - & inoel,physcon,compressible,ielmat,nshcon,shcon,nrhcon, - & rhcon,voldtu,ntmat_,labmpc,inomat,mi) -! -! applies turbulence boundary conditions -! - implicit none -! - character*20 labmpc(*) -! - integer turbulent -! - integer nodeboun(*),ndirboun(*),i,j,nboun,node, - & index,nodei,ndiri,ist,ipompc(*),nodempc(3,*),nmpc, - & ndir,nfreestream,ifreestream(*),iponoel(*), - & inoel,imat,ielmat(*),ntmat_,nshcon(*),nrhcon(*),compressible, - & nsolidsurf,isolidsurf(*),inomat(*),mi(2) -! - real*8 vold(0:mi(2),*),xbounact(*),residuk,size,coefmpc(*), - & xtu,xkin,temp,r,dvi,rho,physcon(*),shcon(0:3,ntmat_,*), - & rhcon(0:1,ntmat_,*),xsolidsurf(*),voldtu(2,*),residut, - & correctionk,correctiont -! -! freestream conditions -! - xtu=5.5d0*physcon(5)/physcon(8) -c xkin=10.d0**(-3.5d0)*xtu - xkin=10.d0**(-2.d0)*xtu - do j=1,nfreestream - node=ifreestream(j) - imat=inomat(node) - if(imat.eq.0) cycle - temp=vold(0,node) - call materialdata_dvi(imat,ntmat_,temp,shcon,nshcon,dvi) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) -! -! density for gases -! - if(compressible.eq.1) then - r=shcon(3,1,imat) - rho=vold(4,node)/ - & (r*(vold(0,node)-physcon(1))) - else - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) - endif -! - voldtu(1,node)=xkin*dvi - voldtu(2,node)=xtu*rho - enddo -! -! solid boundary conditions -! - do j=1,nsolidsurf - node=isolidsurf(j) - imat=inomat(node) - if(imat.eq.0) cycle - temp=vold(0,node) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_dvi(imat,ntmat_,temp,shcon,nshcon,dvi) -! -! density for gases -! - if(compressible.eq.1) then - r=shcon(3,1,imat) - rho=vold(4,node)/ - & (r*(vold(0,node)-physcon(1))) - else - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) - endif -! - voldtu(1,node)=0.d0 - voldtu(2,node)=800.d0*dvi/(xsolidsurf(j)**2) -c write(*,*) 'applybounk ',node,xsolidsurf(j) - enddo -! -! taking fluid pressure MPC's into account: it is assumed -! that cyclic fluid pressure MPC's also apply to the turbulent -! parameters -! - do i=1,nmpc - if(labmpc(i)(1:6).ne.'CYCLIC') cycle - ist=ipompc(i) - ndir=nodempc(2,ist) - if(ndir.ne.4) cycle - node=nodempc(1,ist) -! -! check whether fluid MPC -! - imat=inomat(node) - if(imat.eq.0) cycle -c index=iponoel(node) -c if(index.le.0) cycle -! - index=nodempc(3,ist) - residuk=coefmpc(ist)*voldtu(1,node) - residut=coefmpc(ist)*voldtu(2,node) - size=coefmpc(ist)**2 - if(index.ne.0) then - do - nodei=nodempc(1,index) -c ndiri=nodempc(2,index) -! - residuk=residuk+coefmpc(index)*voldtu(1,nodei) - residut=residut+coefmpc(index)*voldtu(2,nodei) - size=size+coefmpc(index)**2 - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif -! -! correcting all terms of the MPC -! - residuk=residuk/size - residut=residut/size -! - correctionk=-residuk*coefmpc(ist) - correctiont=-residut*coefmpc(ist) - voldtu(1,node)=voldtu(1,node)+correctionk - voldtu(2,node)=voldtu(2,node)+correctiont - index=nodempc(3,ist) - if(index.ne.0) then - do - nodei=nodempc(1,index) -c ndiri=nodempc(2,index) -! - correctionk=-residuk*coefmpc(index) - correctiont=-residut*coefmpc(index) - voldtu(1,nodei)=voldtu(1,nodei)+correctionk - voldtu(2,nodei)=voldtu(2,nodei)+correctiont - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/applybounp.f calculix-ccx-2.3/ccx_2.1/src/applybounp.f --- calculix-ccx-2.1/ccx_2.1/src/applybounp.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/applybounp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,121 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine applybounp(nodeboun,ndirboun,nboun,xbounact, - & ithermal,nk,iponoel,inoel,vold,voldtu,t1act,isolidsurf, - & nsolidsurf,xsolidsurf,nfreestream,ifreestream,turbulent, - & voldaux,shcon,nshcon,rhcon,nrhcon,ielmat,ntmat_,physcon,v, - & ipompc,nodempc,coefmpc,nmpc,inomat,mi) -! -! applies velocity boundary conditions -! - implicit none -! - integer turbulent -! - integer nrhcon(*),ielmat(*),ntmat_,nodeboun(*),isolidsurf(*), - & ndirboun(*),nshcon(*),nk,i,nboun,node,imat,ithermal,iponoel(*), - & inoel(3,*),nsolidsurf,ifreenode,ifreestream(*),nfreestream,k, - & index,ipompc(*),nodempc(3,*),nmpc,ist,ndir,inomat(*),ndiri, - & nodei,mi(2) -! - real*8 rhcon(0:1,ntmat_,*),vold(0:mi(2),*),xbounact(*),shcon, - & voldtu(2,*),t1act(*),temp,r,dvi,xsolidsurf(*),reflength, - & refkin,reftuf,refvel,cp,voldaux(0:4,*),physcon(*),v(0:mi(2),*), - & coefmpc(*),fixed_pres,size,correction,residu -! -! inserting the pressure boundary conditions -! - do i=1,nboun - if(ndirboun(i).ne.4) cycle -! - node=nodeboun(i) - v(4,node)=xbounact(i)-vold(4,node) - enddo -! -! inserting the pressure MPC conditions -! - do i=1,nmpc - ist=ipompc(i) - ndir=nodempc(2,ist) - if(ndir.ne.4) cycle - node=nodempc(1,ist) -! -! check whether fluid MPC -! - imat=inomat(node) - if(imat.eq.0) cycle -! - index=nodempc(3,ist) - residu=coefmpc(ist)*(voldaux(ndir,node)+v(ndir,node)) - size=(coefmpc(ist))**2 - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! -c idof=8*(nodei-1)+ndiri -c call nident(ikboun,idof,nboun,id) -c if(id.ne.0) then -c if(ikboun(id).eq.idof) then -c index=nodempc(3,index) -c if(index.eq.0) exit -c cycle -c endif -c endif -! - residu=residu+coefmpc(index)* - & (voldaux(ndiri,nodei)+v(ndiri,nodei)) - size=size+(coefmpc(index))**2 - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif -! -! correcting all terms of the MPC -! - residu=residu/size -! - correction=-residu*coefmpc(ist) - v(ndir,node)=v(ndir,node)+correction - index=nodempc(3,ist) - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! -c idof=8*(nodei-1)+ndiri -c call nident(ikboun,idof,nboun,id) -c if(id.ne.0) then -c if(ikboun(id).eq.idof) then -c index=nodempc(3,index) -c if(index.eq.0) exit -c cycle -c endif -c endif -! - correction=-residu*coefmpc(index) - v(ndiri,nodei)=v(ndiri,nodei)+correction - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/applybounpgas.f calculix-ccx-2.3/ccx_2.1/src/applybounpgas.f --- calculix-ccx-2.1/ccx_2.1/src/applybounpgas.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/applybounpgas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,205 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine applybounpgas(nodeboun,ndirboun,nboun,xbounact, - & iponoel,vold,ipompc,nodempc,coefmpc,nmpc,inomat,matname, - & nshcon,shcon,nrhcon,rhcon,physcon,ntmat_, - & voldaux,mi) -! -! applies pressure boundary conditions for gases -! - implicit none -! - character*80 matname(*) -! - integer turbulent -! - integer nodeboun(*),ndirboun(*),i,nboun,node,iponoel(*), - & index,nodei,ndiri,ist,ipompc(*),nodempc(3,*),nmpc, - & ndir,inomat(*),imat,nshcon(*),nrhcon(*),k, - & ntmat_,mi(2) -! - real*8 vold(0:mi(2),*),xbounact(*),residu,size,coefmpc(*), - & correction, - & shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),physcon(*), - & cp,r,rho,voldaux(0:4,*),temp -! -! inserting the pressure boundary conditions vor gases -! - do i=1,nboun - if(ndirboun(i).ne.4) cycle -! - node=nodeboun(i) - if(inomat(node).eq.0) cycle - vold(4,node)=xbounact(i) -! -! update the conservative variables -! - imat=inomat(node) - temp=vold(0,node) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_cp_sec(imat,ntmat_,temp,shcon, - & nshcon,cp,physcon) - r=shcon(3,1,imat) - if(r.lt.1.d-10) then - write(*,*) '*ERROR in applybounpgas: specific gas ' - write(*,*) 'constant for material ',matname(imat) - write(*,*) 'is close to zero; maybe it has' - write(*,*) 'not been defined' - stop - endif - if(vold(0,node)-physcon(1).le.1.d-10) then - write(*,*) '*ERROR in applybounpgas: absolute temperature ' - write(*,*) ' is nearly zero; maybe absolute zero ' - write(*,*) ' was wrongly defined or not defined' - write(*,*) ' at all (*PHYSICAL CONSTANTS card)' - stop - endif - rho=vold(4,node)/(r*(vold(0,node)-physcon(1))) - voldaux(0,node)=rho*(cp*(temp-physcon(1))+ - & (vold(1,node)**2+vold(2,node)**2+vold(3,node)**2) - & /2.d0)-vold(4,node) - voldaux(4,node)=rho - do k=1,3 - voldaux(k,node)=rho*vold(k,node) - enddo - enddo -! -! taking fluid pressure MPC's into account -! - do i=1,nmpc - ist=ipompc(i) - ndir=nodempc(2,ist) - if(ndir.ne.4) cycle - node=nodempc(1,ist) -! -! check whether fluid MPC -! - imat=inomat(node) - if(imat.eq.0) cycle -! - index=nodempc(3,ist) - residu=coefmpc(ist)*vold(ndir,node) - size=coefmpc(ist)**2 - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! - residu=residu+coefmpc(index)*vold(ndiri,nodei) - size=size+coefmpc(index)**2 - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif -! -! correcting all terms of the MPC -! - residu=residu/size -! - correction=-residu*coefmpc(ist) - vold(4,node)=vold(4,node)+correction -! -! update the conservative variables -! - imat=inomat(nodei) - temp=vold(0,nodei) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_cp_sec(imat,ntmat_,temp,shcon, - & nshcon,cp,physcon) - r=shcon(3,1,imat) - if(r.lt.1.d-10) then - write(*,*) '*ERROR in applybounpgas: specific gas ' - write(*,*) 'constant for material ',matname(imat) - write(*,*) 'is close to zero; maybe it has' - write(*,*) 'not been defined' - stop - endif - if(vold(0,nodei)-physcon(1).le.1.d-10) then - write(*,*) - & '*ERROR in applybounpgas: absolute temperature ' - write(*,*) - & ' is nearly zero; maybe absolute zero ' - write(*,*) - & ' was wrongly defined or not defined' - write(*,*) - & ' at all (*PHYSICAL CONSTANTS card)' - stop - endif - rho=vold(4,nodei)/(r*(vold(0,nodei)-physcon(1))) - voldaux(0,nodei)=rho*(cp*(temp-physcon(1))+ - & (vold(1,nodei)**2+vold(2,nodei)**2+vold(3,nodei)**2) - & /2.d0)-vold(4,nodei) - voldaux(4,nodei)=rho - do k=1,3 - voldaux(k,nodei)=rho*vold(k,nodei) - enddo - index=nodempc(3,ist) - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! - correction=-residu*coefmpc(index) - vold(ndiri,nodei)=vold(ndiri,nodei)+correction -! -! update the conservative variables -! - imat=inomat(nodei) - temp=vold(0,nodei) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_cp_sec(imat,ntmat_,temp,shcon, - & nshcon,cp,physcon) - r=shcon(3,1,imat) - if(r.lt.1.d-10) then - write(*,*) '*ERROR in applybounpgas: specific gas ' - write(*,*) 'constant for material ',matname(imat) - write(*,*) 'is close to zero; maybe it has' - write(*,*) 'not been defined' - stop - endif - if(vold(0,nodei)-physcon(1).le.1.d-10) then - write(*,*) - & '*ERROR in applybounpgas: absolute temperature ' - write(*,*) - & ' is nearly zero; maybe absolute zero ' - write(*,*) - & ' was wrongly defined or not defined' - write(*,*) - & ' at all (*PHYSICAL CONSTANTS card)' - stop - endif - rho=vold(4,nodei)/(r*(vold(0,nodei)-physcon(1))) - voldaux(0,nodei)=rho*(cp*(temp-physcon(1))+ - & (vold(1,nodei)**2+vold(2,nodei)**2+vold(3,nodei)**2) - & /2.d0)-vold(4,nodei) - voldaux(4,nodei)=rho - do k=1,3 - voldaux(k,nodei)=rho*vold(k,nodei) - enddo - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/applybount.f calculix-ccx-2.3/ccx_2.1/src/applybount.f --- calculix-ccx-2.1/ccx_2.1/src/applybount.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/applybount.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,236 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine applybount(nodeboun,ndirboun,nboun,xbounact, - & iponoel,vold,ipompc,nodempc,coefmpc,nmpc,inomat,matname, - & nshcon,shcon,nrhcon,rhcon,physcon,compressible,ntmat_, - & voldaux,mi) -! -! applies temperature boundary conditions -! - implicit none -! - character*80 matname(*) -! - integer nodeboun(*),ndirboun(*),i,nboun,node,iponoel(*), - & index,nodei,ndiri,ist,ipompc(*),nodempc(3,*),nmpc, - & ndir,inomat(*),imat,nshcon(*),nrhcon(*),k,compressible, - & ntmat_,mi(2) -! - real*8 vold(0:mi(2),*),xbounact(*),residu,size,coefmpc(*), - & correction, - & temp,shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),physcon(*), - & cp,r,rho,voldaux(0:4,*) -! -! inserting the temperature boundary conditions -! - do i=1,nboun - if(ndirboun(i).ne.0) cycle -! - node=nodeboun(i) - if(inomat(node).eq.0) cycle - vold(0,node)=xbounact(i) -! -! update the conservative variables -! - imat=inomat(node) - temp=vold(0,node) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_cp_sec(imat,ntmat_,temp,shcon, - & nshcon,cp,physcon) -! -! different treatment for gases and liquids -! - if(compressible.eq.1) then - r=shcon(3,1,imat) - if(r.lt.1.d-10) then - write(*,*) '*ERROR in applybount: specific gas ' - write(*,*) 'constant for material ',matname(imat) - write(*,*) 'is close to zero; maybe it has' - write(*,*) 'not been defined' - stop - endif - if(vold(0,node)-physcon(1).le.1.d-10) then - write(*,*) '*ERROR in applybount: absolute temperature ' - write(*,*) ' is nearly zero; maybe absolute zero ' - write(*,*) ' was wrongly defined or not defined' - write(*,*) ' at all (*PHYSICAL CONSTANTS card)' - stop - endif - rho=vold(4,node)/(r*(vold(0,node)-physcon(1))) - voldaux(0,node)=rho*(cp*(temp-physcon(1))+ - & (vold(1,node)**2+vold(2,node)**2+vold(3,node)**2) - & /2.d0)-vold(4,node) - else - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) - voldaux(0,node)=rho*(cp*(temp-physcon(1))+ - & (vold(1,node)**2+vold(2,node)**2+vold(3,node)**2) - & /2.d0) - endif - voldaux(4,node)=rho - do k=1,3 - voldaux(k,node)=rho*vold(k,node) - enddo - enddo -! -! taking fluid temperature MPC's into account -! - do i=1,nmpc - ist=ipompc(i) - ndir=nodempc(2,ist) - if(ndir.ne.0) cycle - node=nodempc(1,ist) -! -! check whether fluid MPC -! - imat=inomat(node) - if(imat.eq.0) cycle -c index=iponoel(node) -c if(index.le.0) cycle -! - index=nodempc(3,ist) - residu=coefmpc(ist)*vold(ndir,node) - size=coefmpc(ist)**2 - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! - residu=residu+coefmpc(index)*vold(ndiri,nodei) - size=size+coefmpc(index)**2 - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif -! -! correcting all terms of the MPC -! - residu=residu/size -! - correction=-residu*coefmpc(ist) - vold(0,node)=vold(0,node)+correction -! -! update the conservative variables -! - imat=inomat(node) - temp=vold(0,node) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_cp_sec(imat,ntmat_,temp,shcon, - & nshcon,cp,physcon) -! -! different treatment for gases and liquids -! - if(compressible.eq.1) then - r=shcon(3,1,imat) - if(r.lt.1.d-10) then - write(*,*) '*ERROR in applybount: specific gas ' - write(*,*) 'constant for material ',matname(imat) - write(*,*) 'is close to zero; maybe it has' - write(*,*) 'not been defined' - stop - endif - if(vold(0,node)-physcon(1).le.1.d-10) then - write(*,*) '*ERROR in applybount: absolute temperature ' - write(*,*) ' is nearly zero; maybe absolute zero ' - write(*,*) ' was wrongly defined or not defined' - write(*,*) ' at all (*PHYSICAL CONSTANTS card)' - stop - endif - rho=vold(4,node)/(r*(vold(0,node)-physcon(1))) - voldaux(0,node)=rho*(cp*(temp-physcon(1))+ - & (vold(1,node)**2+vold(2,node)**2+vold(3,node)**2) - & /2.d0)-vold(4,node) - else - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) - voldaux(0,node)=rho*(cp*(temp-physcon(1))+ - & (vold(1,node)**2+vold(2,node)**2+vold(3,node)**2) - & /2.d0) - endif - voldaux(4,node)=rho - do k=1,3 - voldaux(k,node)=rho*vold(k,node) - enddo -! - index=nodempc(3,ist) - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! - correction=-residu*coefmpc(index) - vold(ndiri,nodei)=vold(ndiri,nodei)+correction -! -! update the conservative variables -! - imat=inomat(nodei) - temp=vold(0,nodei) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_cp_sec(imat,ntmat_,temp,shcon, - & nshcon,cp,physcon) -! -! different treatment for gases and liquids -! - if(compressible.eq.1) then - r=shcon(3,1,imat) - if(r.lt.1.d-10) then - write(*,*) '*ERROR in applybount: specific gas ' - write(*,*) 'constant for material ',matname(imat) - write(*,*) 'is close to zero; maybe it has' - write(*,*) 'not been defined' - stop - endif - if(vold(0,nodei)-physcon(1).le.1.d-10) then - write(*,*) - & '*ERROR in applybount: absolute temperature ' - write(*,*) - & ' is nearly zero; maybe absolute zero ' - write(*,*) - & ' was wrongly defined or not defined' - write(*,*) - & ' at all (*PHYSICAL CONSTANTS card)' - stop - endif - rho=vold(4,nodei)/(r*(vold(0,nodei)-physcon(1))) - voldaux(0,nodei)=rho*(cp*(temp-physcon(1))+ - & (vold(1,nodei)**2+vold(2,nodei)**2+vold(3,nodei)**2) - & /2.d0)-vold(4,nodei) - else - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) - voldaux(0,nodei)=rho*(cp*(temp-physcon(1))+ - & (vold(1,nodei)**2+vold(2,nodei)**2+vold(3,nodei)**2) - & /2.d0) - endif - voldaux(4,nodei)=rho - do k=1,3 - voldaux(k,nodei)=rho*vold(k,nodei) - enddo -! - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/applybounv.f calculix-ccx-2.3/ccx_2.1/src/applybounv.f --- calculix-ccx-2.1/ccx_2.1/src/applybounv.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/applybounv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,305 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine applybounv(nodeboun,ndirboun,nboun,xbounact, - & ithermal,nk,iponoel,inoel,vold,voldtu,t1act,isolidsurf, - & nsolidsurf,xsolidsurf,nfreestream,ifreestream,turbulent, - & voldaux,shcon,nshcon,rhcon,nrhcon,ielmat,ntmat_,physcon,v, - & compressible,ismooth,nmpc,nodempc,ipompc,coefmpc,inomat, - & mi) -! -! applies velocity boundary conditions -! - implicit none -! - integer turbulent,compressible -! - integer nrhcon(*),ielmat(*),ntmat_,nodeboun(*),isolidsurf(*), - & ndirboun(*),nshcon(*),nk,i,nboun,node,imat,ithermal,iponoel(*), - & inoel(3,*),nsolidsurf,ifreenode,ifreestream(*),nfreestream,k, - & index,ismooth,indexi,nodei,nmpc,nodempc(3,*),ipompc(*), - & ist,ndir,ndiri,inomat(*),mi(2) -! - real*8 rhcon(0:1,ntmat_,*),rho,vold(0:mi(2),*),xbounact(*),shcon, - & voldtu(2,*),t1act(*),temp,xsolidsurf(*),reflength, - & refkin,reftuf,refvel,voldaux(0:4,*),physcon(*),v(0:mi(2),*), - & rhoi,coefmpc(*),residu,size,correction -! -! inserting the velocity boundary conditions -! - do i=1,nboun - if((ndirboun(i).lt.1).or.(ndirboun(i).gt.3)) cycle -! - node=nodeboun(i) -! -! check whether fluid SPC -! - imat=inomat(node) - if(imat.eq.0) cycle - if(compressible.eq.0) then -! -! determining rho from the material constants (for incompressible -! fluids) -! - temp=vold(0,node) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) - else -! -! determining rho from the solution field (for compressible fluids) -! - rho=voldaux(4,node) - endif - if(ismooth.eq.0) then -! -! in case of no smoothing (incompressible fluids or -! pre-smoothing call of compressible fluids) -! - v(ndirboun(i),node)=xbounact(i)*rho - & -voldaux(ndirboun(i),node) - else -! -! in case of smoothing: update voldaux (only for compressible -! fluids) -! - voldaux(ndirboun(i),node)=xbounact(i)*rho - endif - enddo -! -! taking velocity MPC's into account -! - if(ismooth.eq.0) then - do i=1,nmpc - ist=ipompc(i) - ndir=nodempc(2,ist) - if((ndir.lt.1).or.(ndir.gt.3)) cycle - node=nodempc(1,ist) -! -! check whether fluid MPC -! - imat=inomat(node) - if(imat.eq.0) cycle - if(compressible.eq.0) then -! -! determining rho from the material constants (for incompressible -! fluids) -! - temp=vold(0,node) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) - else -! -! determining rho from the solution field (for compressible fluids) -! - rho=voldaux(4,node)+v(4,node) - endif -! - index=nodempc(3,ist) - residu=coefmpc(ist)*(voldaux(ndir,node)+v(ndir,node))/rho - size=(coefmpc(ist)/rho)**2 - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! -! determining rho -! - if(compressible.eq.0) then -! -! determining rho from the material constants (for incompressible -! fluids) -! - imat=inomat(nodei) - if(imat.eq.0) cycle - temp=vold(0,nodei) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rhoi,physcon) - call materialdata_rho(rhcon,nrhcon,imat,rhoi, - & temp,ntmat_) - else -! -! determining rho from the solution field (for compressible fluids) -! - rhoi=voldaux(4,nodei)+v(4,nodei) - endif -! - residu=residu+coefmpc(index)* - & (voldaux(ndiri,nodei)+v(ndiri,nodei))/rhoi - size=size+(coefmpc(index)/rhoi)**2 - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif -! -! correcting all terms of the MPC -! - residu=residu/size -! - correction=-residu*coefmpc(ist)/rho - v(ndir,node)=v(ndir,node)+correction - index=nodempc(3,ist) - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! -! determining rho -! - if(compressible.eq.0) then -! -! determining rho from the material constants (for incompressible -! fluids) -! - imat=inomat(nodei) - if(imat.eq.0) cycle - temp=vold(0,nodei) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rhoi,physcon) - call materialdata_rho(rhcon,nrhcon,imat,rhoi, - & temp,ntmat_) - else -! -! determining rho from the solution field (for compressible fluids) -! - rhoi=voldaux(4,nodei)+v(4,nodei) - endif -! - correction=-residu*coefmpc(index)/rhoi - v(ndiri,nodei)=v(ndiri,nodei)+correction - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - enddo - else -! -! smoothing procedure: voldaux has already been updated -! - do i=1,nmpc - ist=ipompc(i) - ndir=nodempc(2,ist) - if((ndir.lt.1).or.(ndir.gt.3)) cycle - node=nodempc(1,ist) -! -! check whether fluid MPC -! - imat=inomat(node) - if(imat.eq.0) cycle - if(compressible.eq.0) then -! -! determining rho from the material constants (for incompressible -! fluids) -! - temp=vold(0,node) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho,physcon) - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) - else -! -! determining rho from the solution field (for compressible fluids) -! - rho=voldaux(4,node)+v(4,node) - endif -! - index=nodempc(3,ist) - residu=coefmpc(ist)*voldaux(ndir,node)/rho - size=(coefmpc(ist)/rho)**2 - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! -! determining rho -! - if(compressible.eq.0) then -! -! determining rho from the material constants (for incompressible -! fluids) -! - imat=inomat(nodei) - if(imat.eq.0) cycle - temp=vold(0,nodei) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rhoi,physcon) - call materialdata_rho(rhcon,nrhcon,imat,rhoi, - & temp,ntmat_) - else -! -! determining rho from the solution field (for compressible fluids) -! - rhoi=voldaux(4,nodei) - endif -! - residu=residu+coefmpc(index)* - & voldaux(ndiri,nodei)/rhoi - size=size+(coefmpc(index)/rhoi)**2 - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif -! -! correcting all terms of the MPC -! - residu=residu/size -! - correction=-residu*coefmpc(ist)/rho - voldaux(ndir,node)=voldaux(ndir,node)+correction - index=nodempc(3,ist) - if(index.ne.0) then - do - nodei=nodempc(1,index) - ndiri=nodempc(2,index) -! -! determining rho -! - if(compressible.eq.0) then -! -! determining rho from the material constants (for incompressible -! fluids) -! - imat=inomat(nodei) - if(imat.eq.0) cycle - temp=vold(0,nodei) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rhoi,physcon) - call materialdata_rho(rhcon,nrhcon,imat,rhoi, - & temp,ntmat_) - else -! -! determining rho from the solution field (for compressible fluids) -! - rhoi=voldaux(4,nodei) - endif -! - correction=-residu*coefmpc(index)/rhoi - voldaux(ndiri,nodei)=voldaux(ndiri,nodei)+correction - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - enddo - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/approxplane.f calculix-ccx-2.3/ccx_2.1/src/approxplane.f --- calculix-ccx-2.1/ccx_2.1/src/approxplane.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/approxplane.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,120 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine approxplane(col,straight,xn) -! -! calculate the equation of the planes through the -! edges of a quadrilateral and parallel to the vector xn together -! with a plane perpendicular to xn and through the center of gravity -! of the four corner nodes of the quadrilateral -! (so-called mean quadrilateral plane) with -! (col(1,1),col(2,1),col(3,1)),(col(1,2),col(2,2),col(3,2)), -! (col(1,3),col(2,3),col(3,3)),(col(1,4),col(2,4),col(3,4)) -! as vertices. The equation of the planes through the first edge -! (connecting the first and the second node) is of the form -! straight(1)*x+straight(2)*y+straight(3)*z+straight(4)=0, such that the -! vector (straight(1),straight(2),straight(3)) points outwards (replace -! (1) by (5),(9) and (13) for the second, third and fourth edge, -! similar offset for (2),(3) and (4); -! The equation of the mean quadrilateral plane is -! straight(17)*x+straight(18)*y+straight(19)*z+straight(20)=0 such -! that the quadrilateral is numbered clockwise when looking in the -! direction of vector (straight(17),straight(18),straight(19)). -! - implicit none -! - integer i -! - real*8 col(3,4),straight(20),p12(3),p23(3),p34(3),p41(3),dd,xn(3) -! -! sides of the quadrilateral -! - do i=1,3 - p12(i)=col(i,2)-col(i,1) - p23(i)=col(i,3)-col(i,2) - p34(i)=col(i,4)-col(i,3) - p41(i)=col(i,1)-col(i,4) - enddo -! -! mean normal to the quadrilateral (given) -! - do i=17,19 - straight(i)=xn(i) - enddo -! -! p12 x xn -! - straight(1)=p12(2)*xn(3)-p12(3)*xn(2) - straight(2)=p12(3)*xn(1)-p12(1)*xn(3) - straight(3)=p12(1)*xn(2)-p12(2)*xn(1) - dd=dsqrt(straight(1)*straight(1)+straight(2)*straight(2)+ - & straight(3)*straight(3)) - do i=1,3 - straight(i)=straight(i)/dd - enddo -! -! p23 x xn -! - straight(5)=p23(2)*xn(3)-p23(3)*xn(2) - straight(6)=p23(3)*xn(1)-p23(1)*xn(3) - straight(7)=p23(1)*xn(2)-p23(2)*xn(1) - dd=dsqrt(straight(5)*straight(5)+straight(6)*straight(6)+ - & straight(7)*straight(7)) - do i=5,7 - straight(i)=straight(i)/dd - enddo -! -! p34 x xn -! - straight(9)=p34(2)*xn(3)-p34(3)*xn(2) - straight(10)=p34(3)*xn(1)-p34(1)*xn(3) - straight(11)=p34(1)*xn(2)-p34(2)*xn(1) - dd=dsqrt(straight(9)*straight(9)+straight(10)*straight(10)+ - & straight(11)*straight(11)) - do i=9,11 - straight(i)=straight(i)/dd - enddo -! -! p41 x xn -! - straight(13)=p41(2)*xn(3)-p41(3)*xn(2) - straight(14)=p41(3)*xn(1)-p41(1)*xn(3) - straight(15)=p41(1)*xn(2)-p41(2)*xn(1) - dd=dsqrt(straight(13)*straight(13)+straight(14)*straight(14)+ - & straight(15)*straight(15)) - do i=13,15 - straight(i)=straight(i)/dd - enddo -! -! determining the inhomogeneous terms -! - straight(4)=-straight(1)*col(1,1)-straight(2)*col(2,1)- - & straight(3)*col(3,1) - straight(8)=-straight(5)*col(1,2)-straight(6)*col(2,2)- - & straight(7)*col(3,2) - straight(12)=-straight(9)*col(1,3)-straight(10)*col(2,3)- - & straight(11)*col(3,3) - straight(16)=-straight(13)*col(1,4)-straight(14)*col(2,4)- - & straight(15)*col(3,4) - straight(20)=-xn(1)*(col(1,1)+col(1,2)+col(1,3)+col(1,4))/4.d0 - & -xn(2)*(col(2,1)+col(2,2)+col(2,3)+col(2,4))/4.d0 - & -xn(3)*(col(3,1)+col(3,2)+col(3,3)+col(3,4))/4.d0 -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/arpackbu.c calculix-ccx-2.3/ccx_2.1/src/arpackbu.c --- calculix-ccx-2.1/ccx_2.1/src/arpackbu.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/arpackbu.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,659 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#ifdef ARPACK - -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif -#ifdef PARDISO - #include "pardiso.h" -#endif - -void arpackbu(double *co, int *nk, int *kon, int *ipkon, char *lakon, - int *ne, - int *nodeboun, int *ndirboun, double *xboun, int *nboun, - int *ipompc, int *nodempc, double *coefmpc, char *labmpc, - int *nmpc, - int *nodeforc, int *ndirforc,double *xforc, int *nforc, - int *nelemload, char *sideload, double *xload, - int *nload, - double *ad, double *au, double *b,int *nactdof, - int *icol, int *jq, int *irow, int *neq, int *nzl, - int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, - int *ilboun, - double *elcon, int *nelcon, double *rhcon, int *nrhcon, - double *alcon, int *nalcon, double *alzero, int *ielmat, - int *ielorien, int *norien, double *orab, int *ntmat_, - double *t0, double *t1, double *t1old, - int *ithermal,double *prestr, int *iprestr, - double *vold,int *iperturb, double *sti, int *nzs, - int *kode, double *adb, double *aub,int *mei, double *fei, - char *filab, double *eme, - int *iexpl, double *plicon, int *nplicon, double *plkcon, - int *nplkcon, - double *xstate, int *npmat_, char *matname, int *mi, - int *ncmat_, int *nstate_, double *ener, char *output, - char *set, int *nset, int *istartset, - int *iendset, int *ialset, int *nprint, char *prlab, - char *prset, int *nener, int *isolver, double *trab, - int *inotr, int *ntrans, double *ttime,double *fmpc, - char *cbody, int *ibody,double *xbody, int *nbody){ - - char bmat[2]="G", which[3]="LM", howmny[2]="A", - description[13]=" "; - - int *inum=NULL,k,ido,dz,iparam[11],ipntr[11],lworkl, - info,rvec=1,*select=NULL,lfin,j,lint,iout,iconverged=0,ielas,icmd=0, - iinc=1,istep=1,*ncocon=NULL,*nshcon=NULL,nev,ncv,mxiter,jrow, - *ipobody=NULL,inewton=0,coriolis=0,ifreebody,symmetryflag=0, - inputformat=0,ngraph=1,mt=mi[1]+1,mass[2]={0,0}, stiffness=1, buckling=0, - rhsi=1, intscheme=0, noddiam=-1,*ipneigh=NULL,*neigh=NULL; - - double *stn=NULL,*v=NULL,*resid=NULL,*z=NULL,*workd=NULL, - *workl=NULL,*aux=NULL,*d=NULL,sigma,*temp_array=NULL, - *een=NULL,cam[5],*f=NULL,*fn=NULL,qa[3],*fext=NULL,time=0.,*epn=NULL, - *xstateini=NULL,*xstiff=NULL,*stiini=NULL,*vini=NULL,*stx=NULL, - *enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL,*cocon=NULL, - *shcon=NULL,*physcon=NULL,*qfx=NULL,*qfn=NULL,tol, *cgr=NULL, - *xloadold=NULL,reltime,*vr=NULL,*vi=NULL,*stnr=NULL,*stni=NULL, - *vmax=NULL,*stnmax=NULL,*cs=NULL; - - /* buckling routine; only for mechanical applications */ - - /* dummy arguments for the results call */ - - double *veold=NULL,*accold=NULL,bet,gam,dtime; - -#ifdef SGI - int token; -#endif - - /* copying the frequency parameters */ - - nev=mei[0]; - ncv=mei[1]; - mxiter=mei[2]; - tol=fei[0]; - - /* calculating the stresses due to the buckling load; this is a second - order calculation if iperturb != 0 */ - - *nmethod=1; - - /* assigning the body forces to the elements */ - - if(*nbody>0){ - ifreebody=*ne+1; - ipobody=NNEW(int,2*ifreebody**nbody); - for(k=1;k<=*nbody;k++){ - FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, - iendset,ialset,&inewton,nset,&ifreebody,&k)); - RENEW(ipobody,int,2*(*ne+ifreebody)); - } - RENEW(ipobody,int,2*(ifreebody-1)); - } - - /* determining the internal forces and the stiffness coefficients */ - - f=NNEW(double,neq[0]); - - /* allocating a field for the stiffness matrix */ - - xstiff=NNEW(double,27*mi[0]**ne); - -// iout=-1; - v=NNEW(double,mt**nk); - fn=NNEW(double,mt**nk); - stx=NNEW(double,6*mi[0]**ne); - - iout=-1; - if(*iperturb==0){ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t0,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xboun,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[0],veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, - &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, - sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, - fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - }else{ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1old,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xboun,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[0],veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, - &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, - sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, - fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - } - - free(v);free(fn);free(stx); - iout=1; - - /* determining the system matrix and the external forces */ - - ad=NNEW(double,neq[0]); - au=NNEW(double,nzs[0]); - fext=NNEW(double,neq[0]); - - if(*iperturb==0){ - FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, - ikmpc,ilmpc,ikboun,ilboun, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_, - t0,t0,ithermal,prestr,iprestr,vold,iperturb,sti, - &nzs[0],stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, - xstiff,npmat_,&dtime,matname,mi, - ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme,physcon, - shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc,&coriolis, - ibody,xloadold,&reltime,veold)); - } - else{ - FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, - ikmpc,ilmpc,ikboun,ilboun, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_, - t0,t1old,ithermal,prestr,iprestr,vold,iperturb,sti, - &nzs[0],stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, - xstiff,npmat_,&dtime,matname,mi, - ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme,physcon, - shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc,&coriolis, - ibody,xloadold,&reltime,veold)); - } - - /* determining the right hand side */ - - b=NNEW(double,neq[0]); - for(k=0;k0) free(ipobody); - - if(*nmethod==1){return;} - - /* loop checking the plausibility of the buckling factor - if (5*sigmad[0]/sigma)||(50000.0) FORTRAN(writehe,(&j)); - - memset(&v[0],0.,sizeof(double)*mt**nk); - if(*iperturb==0){ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum, - stx,elcon, - nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, - norien,orab,ntmat_,t0,t0,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,&z[lint], - nodeboun,ndirboun,xboun,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[0],veold,accold,&bet, - &gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, - xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,&istep,&iinc));} - else{ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum, - stx,elcon, - nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, - norien,orab,ntmat_,t0,t1old,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,&z[lint], - nodeboun,ndirboun,xboun,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[0],veold,accold,&bet, - &gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, - xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - } - - ++*kode; - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, - fn,&d[j],epn,ielmat,matname,enern,xstaten,nstate_,&istep,&iinc, - iperturb,ener,mi,output,ithermal,qfn,&j,&noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,stx,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, - set,nset,istartset,iendset,ialset)); - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - } - - free(v);free(fn);free(stn);free(inum);free(stx);free(z);free(d);free(eei); - if(*nener==1){ - free(stiini);free(enerini);} - - if(strcmp1(&filab[261],"E ")==0) free(een); - if(strcmp1(&filab[522],"ENER")==0) free(enern); - - return; -} - -#endif diff -Nru calculix-ccx-2.1/ccx_2.1/src/arpack.c calculix-ccx-2.3/ccx_2.1/src/arpack.c --- calculix-ccx-2.1/ccx_2.1/src/arpack.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/arpack.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,618 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#ifdef ARPACK - -#include -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif -#ifdef MATRIXSTORAGE - #include "matrixstorage.h" -#endif -#ifdef PARDISO - #include "pardiso.h" -#endif - -void arpack(double *co, int *nk, int *kon, int *ipkon, char *lakon, - int *ne, - int *nodeboun, int *ndirboun, double *xboun, int *nboun, - int *ipompc, int *nodempc, double *coefmpc, char *labmpc, - int *nmpc, - int *nodeforc, int *ndirforc,double *xforc, int *nforc, - int *nelemload, char *sideload, double *xload, - int *nload, - double *ad, double *au, double *b, int *nactdof, - int *icol, int *jq, int *irow, int *neq, int *nzl, - int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, - int *ilboun, - double *elcon, int *nelcon, double *rhcon, int *nrhcon, - double *shcon, int *nshcon, double *cocon, int *ncocon, - double *alcon, int *nalcon, double *alzero, int *ielmat, - int *ielorien, int *norien, double *orab, int *ntmat_, - double *t0, double *t1, double *t1old, - int *ithermal,double *prestr, int *iprestr, - double *vold,int *iperturb, double *sti, int *nzs, - int *kode, double *adb, double *aub, - int *mei, double *fei, - char *filab, double *eme, - int *iexpl, double *plicon, int *nplicon, double *plkcon, - int *nplkcon, - double *xstate, int *npmat_, char *matname, int *mi, - int *ncmat_, int *nstate_, double *ener, char *jobnamec, - char *output, char *set, int *nset, int *istartset, - int *iendset, int *ialset, int *nprint, char *prlab, - char *prset, int *nener, int *isolver, double *trab, - int *inotr, int *ntrans, double *ttime, double *fmpc, - char *cbody, int *ibody,double *xbody, int *nbody){ - - /* calls the Arnoldi Package (ARPACK) */ - - char bmat[2]="G", which[3]="LM", howmny[2]="A", fneig[132]="", - description[13]=" "; - - int *inum=NULL,k,ido,dz,iparam[11],ipntr[11],lworkl,ngraph=1, - info,rvec=1,*select=NULL,lfin,j,lint,iout,ielas=1,icmd=0,mt=mi[1]+1, - iinc=1,istep=1,nev,ncv,mxiter,jrow,*ipobody=NULL,inewton=0,ifreebody, - mass[2]={1,1}, stiffness=1, buckling=0, rhsi=0, intscheme=0,noddiam=-1, - coriolis=0,symmetryflag=0,inputformat=0,*ipneigh=NULL,*neigh=NULL; - - double *stn=NULL,*v=NULL,*resid=NULL,*z=NULL,*workd=NULL, - *workl=NULL,*aux=NULL,*d=NULL,sigma=1,*temp_array=NULL, - *een=NULL,sum,cam[5],*f=NULL,*fn=NULL,qa[3],*fext=NULL,*epn=NULL, - *xstateini=NULL,*xstiff=NULL,*stiini=NULL,*vini=NULL,freq,*stx=NULL, - *enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL, - *physcon=NULL,*qfx=NULL,*qfn=NULL,tol,fmin,fmax,pi,*cgr=NULL, - *xloadold=NULL,reltime,*vr=NULL,*vi=NULL,*stnr=NULL,*stni=NULL, - *vmax=NULL,*stnmax=NULL,*cs=NULL; - - FILE *f1; - - /* dummy arguments for the results call */ - - double *veold=NULL,*accold=NULL,bet,gam,dtime,time; - -#ifdef SGI - int token; -#endif - - if((strcmp1(&filab[870],"PU ")==0)|| - (strcmp1(&filab[1479],"PHS ")==0)|| - (strcmp1(&filab[1566],"MAXU")==0)|| - (strcmp1(&filab[1653],"MAXS")==0)){ - printf("*ERROR in arpack: PU, PHS, MAXU and MAX was selected in a frequency calculation without cyclic symmetry;\n this is not correct\n"); - FORTRAN(stop,()); - } - - /* copying the frequency parameters */ - - pi=4.*atan(1.); - - nev=mei[0]; - ncv=mei[1]; - mxiter=mei[2]; - tol=fei[0]; - fmin=2*pi*fei[1]; - fmax=2*pi*fei[2]; - - /* assigning the body forces to the elements */ - - if(*nbody>0){ - ifreebody=*ne+1; - ipobody=NNEW(int,2*ifreebody**nbody); - for(k=1;k<=*nbody;k++){ - FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, - iendset,ialset,&inewton,nset,&ifreebody,&k)); - RENEW(ipobody,int,2*(*ne+ifreebody)); - } - RENEW(ipobody,int,2*(ifreebody-1)); - if(inewton==1){ - printf("*ERROR in arpackcs: generalized gravity loading is not allowed in frequency calculations"); - FORTRAN(stop,()); - } - } - - /* field for initial values of state variables (needed if - previous static step was viscoplastic */ - - if(*nstate_!=0){ - xstateini=NNEW(double,*nstate_*mi[0]**ne); - for(k=0;k<*nstate_*mi[0]**ne;++k){ - xstateini[k]=xstate[k]; - } - } - - /* determining the internal forces and the stiffness coefficients */ - - f=NNEW(double,neq[1]); - - /* allocating a field for the stiffness matrix */ - - xstiff=NNEW(double,27*mi[0]**ne); - - iout=-1; - v=NNEW(double,mt**nk); - fn=NNEW(double,mt**nk); - stx=NNEW(double,6*mi[0]**ne); - if(*ithermal>1){ - qfx=NNEW(double,3*mi[0]**ne); - } - if(*iperturb==0){ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t0,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xboun,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, - &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, - sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, - fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - }else{ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1old,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xboun,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, - &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, - sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, - fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - } - free(f);free(v);free(fn);free(stx);if(*ithermal>1){free(qfx);} - iout=1; - - /* filling in the matrix */ - - ad=NNEW(double,neq[1]); - au=NNEW(double,nzs[2]); - - adb=NNEW(double,neq[1]); - aub=NNEW(double,nzs[1]); - - fext=NNEW(double,neq[1]); - - if(*iperturb==0){ - FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, - ikmpc,ilmpc,ikboun,ilboun, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_, - t0,t0,ithermal,prestr,iprestr,vold,iperturb,sti, - nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, - xstiff,npmat_,&dtime,matname,mi, - ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme, - physcon,shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc, - &coriolis,ibody,xloadold,&reltime,veold)); - } - else{ - FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, - ikmpc,ilmpc,ikboun,ilboun, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_, - t0,t1old,ithermal,prestr,iprestr,vold,iperturb,sti, - nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, - xstiff,npmat_,&dtime,matname,mi, - ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme, - physcon,shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc, - &coriolis,ibody,xloadold,&reltime,veold)); - } - - free(fext); - - if(*nmethod==0){ - - /* error occurred in mafill: storing the geometry in frd format */ - - ++*kode;time=0.; - inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, - fn,&time,epn,ielmat,matname,enern,xstaten,nstate_,&istep,&iinc, - iperturb,ener,mi,output,ithermal,qfn,&j,&noddiam,trab,inotr,ntrans, - orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, - set,nset,istartset,iendset,ialset)); - - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - free(inum);FORTRAN(stop,()); - - } - - /* LU decomposition of the left hand matrix */ - - if(*isolver==0){ -#ifdef SPOOLES - spooles_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1], - &symmetryflag,&inputformat); -#else - printf("*ERROR in arpack: the SPOOLES library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==4){ -#ifdef SGI - token=1; - sgi_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1],token); -#else - printf("*ERROR in arpack: the SGI library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau_factor(ad,&au,adb,aub,&sigma,icol,&irow,&neq[1],&nzs[1]); -#else - printf("*ERROR in arpack: the TAUCS library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==6){ -#ifdef MATRIXSTORAGE - matrixstorage(ad,&au,adb,aub,&sigma,icol,&irow,&neq[1],&nzs[1], - ntrans,inotr,trab,co,nk,nactdof,jobnamec,mi); -#else - printf("*ERROR in arpack: the MATRIXSTORAGE library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1]); -#else - printf("*ERROR in arpack: the PARDISO library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - -/* free(au);free(ad);*/ - -/* calculating the eigenvalues and eigenmodes */ - - printf(" Calculating the eigenvalues and the eigenmodes\n\n"); - - ido=0; - dz=neq[1]; - iparam[0]=1; - iparam[2]=mxiter; - iparam[3]=1; - iparam[6]=3; - - lworkl=ncv*(8+ncv); - info=0; - - resid=NNEW(double,neq[1]); - long long zsize=ncv*neq[1]; - z=NNEW(double,zsize); - workd=NNEW(double,3*neq[1]); - workl=NNEW(double,lworkl); - - FORTRAN(dsaupd,(&ido,bmat,&neq[1],which,&nev,&tol,resid,&ncv,z,&dz,iparam,ipntr,workd, - workl,&lworkl,&info)); - - temp_array=NNEW(double,neq[1]); - - while((ido==-1)||(ido==1)||(ido==2)){ - if(ido==-1){ - FORTRAN(op,(&neq[1],aux,&workd[ipntr[0]-1],temp_array,adb,aub,icol,irow,nzl)); - } - if((ido==-1)||(ido==1)){ - - /* solve the linear equation system */ - - if(ido==-1){ - if(*isolver==0){ -#ifdef SPOOLES - spooles_solve(temp_array,&neq[1]); -#endif - } - else if(*isolver==4){ -#ifdef SGI - sgi_solve(temp_array,token); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau_solve(temp_array,&neq[1]); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_solve(temp_array,&neq[1]); -#endif - } - for(jrow=0;jrow1){ - qfn=NNEW(double,3**nk); - qfx=NNEW(double,3*mi[0]**ne); - } - - if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); - if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); - - temp_array=NNEW(double,neq[1]); - - lfin=0; - for(j=0;jd[j]) continue; - if(fmax>0.){ - if(fmax0) FORTRAN(writehe,(&j)); - - sum=0.; - for(k=0;k0.)&&(fmax>d[nev-1])){ - printf("\n*WARNING: not all frequencies in the requested interval might be found;\nincrease the number of requested frequencies\n"); - } - - if(mei[3]==1){ - fclose(f1); - } - - free(adb);free(aub);free(temp_array); - - free(v);free(fn);free(stn);free(inum);free(stx);free(resid); - free(z);free(workd);free(workl);free(select);free(d);free(xstiff); - free(ipobody); - - if(*ithermal>1){free(qfn);free(qfx);} - - if(*nstate_!=0){free(xstateini);} - - if(strcmp1(&filab[261],"E ")==0) free(een); - if(strcmp1(&filab[522],"ENER")==0) free(enern); - - for(k=0;k<6*mi[0]**ne;k++){eme[k]=0.;} - - return; -} - -#endif diff -Nru calculix-ccx-2.1/ccx_2.1/src/arpackcs.c calculix-ccx-2.3/ccx_2.1/src/arpackcs.c --- calculix-ccx-2.1/ccx_2.1/src/arpackcs.c 2010-03-04 19:51:40.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/arpackcs.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1417 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#ifdef ARPACK - -#include -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif -#ifdef PARDISO - #include "pardiso.h" -#endif - -void arpackcs(double *co, int *nk, int *kon, int *ipkon, char *lakon, - int *ne, - int *nodeboun, int *ndirboun, double *xboun, int *nboun, - int *ipompc, int *nodempc, double *coefmpc, char *labmpc, - int *nmpc, - int *nodeforc, int *ndirforc,double *xforc, int *nforc, - int *nelemload, char *sideload, double *xload, - int *nload, - double *ad, double *au, double *b, int *nactdof, - int *icol, int *jq, int *irow, int *neq, int *nzl, - int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, - int *ilboun, - double *elcon, int *nelcon, double *rhcon, int *nrhcon, - double *alcon, int *nalcon, double *alzero, int *ielmat, - int *ielorien, int *norien, double *orab, int *ntmat_, - double *t0, double *t1, double *t1old, - int *ithermal,double *prestr, int *iprestr, - double *vold,int *iperturb, double *sti, int *nzs, - int *kode, double *adb, double *aub,int *mei, double *fei, - char *filab, double *eme, - int *iexpl, double *plicon, int *nplicon, double *plkcon, - int *nplkcon, - double *xstate, int *npmat_, char *matname, int *mi, - int *ics, double *cs, int *mpcend, int *ncmat_, - int *nstate_, int *mcs, int *nkon, double *ener, - char *jobnamec, char *output, char *set, int *nset, - int *istartset, - int *iendset, int *ialset, int *nprint, char *prlab, - char *prset, int *nener, int *isolver, double *trab, - int *inotr, int *ntrans, double *ttime, double *fmpc, - char *cbody, int *ibody, double *xbody, int *nbody, - int *nevtot){ - - /* calls the Arnoldi Package (ARPACK) for cyclic symmetry calculations */ - - char bmat[2]="G", which[3]="LM", howmny[2]="A",*lakont=NULL, - description[13]=" ",fneig[132]=""; - int *inum=NULL,k,ido,dz,iparam[11],ipntr[11],lworkl,idir, - info,rvec=1,*select=NULL,lfin,j,lint,iout=1,nm,index,inode,id,i,idof, - ielas,icmd=0,kk,l,nkt,icntrl,*kont=NULL,*ipkont=NULL,*inumt=NULL, - *ielmatt=NULL,net,imag,icomplex,kkv,kk6,iinc=1,istep=1,nev,ncv, - mxiter,lprev,ilength,ij,i1,i2,iel,ielset,node,indexe,nope,ml1, - *inocs=NULL,*ielcs=NULL,jj,l1,l2,ngraph,is,jrow,*ipobody=NULL, - *inotrt=NULL,symmetryflag=0,inputformat=0,inewton=0,ifreebody; - int mass=1, stiffness=1, buckling=0, rhsi=0, intscheme=0,*ncocon=NULL, - coriolis=0,iworsttime,l3,idummy=1,iray,mt; - double *stn=NULL,*v=NULL,*resid=NULL,*z=NULL,*workd=NULL,*vr=NULL, - *workl=NULL,*aux=NULL,*d=NULL,sigma=1,*temp_array=NULL,*vini=NULL, - *een=NULL,cam[5],*f=NULL,*fn=NULL,qa[3],*fext=NULL,*epn=NULL,*stiini=NULL, - *xstateini=NULL,theta,pi,*coefmpcnew=NULL,*xstiff=NULL,*vi=NULL, - *vt=NULL,*fnt=NULL,*stnt=NULL,*eent=NULL,*cot=NULL,t[3],ctl,stl, - *t1t=NULL,freq,*stx=NULL,*enern=NULL,*enernt=NULL,*xstaten=NULL, - *eei=NULL,*enerini=NULL,*cocon=NULL,*qfx=NULL,*qfn=NULL,*qfnt=NULL, - tol,fmin,fmax,xreal,ximag,*cgr=NULL,*xloadold=NULL,reltime,constant, - vreal,vimag,*stnr=NULL,*stni=NULL,stnreal,stnimag,*vmax=NULL, - *stnmax=NULL,vl[4],stnl[6],dd,v1,v2,v3,bb,cc,al[3],cm,cn,tt, - worstpsmax,vray[3],worstumax,p1[3],p2[3],q[3],tan[3]; - FILE *f1; - - /* dummy arguments for the results call */ - - double *veold=NULL,*accold=NULL,bet,gam,dtime,time; - - int *ipneigh=NULL,*neigh=NULL; - -#ifdef SGI - int token; -#endif - - mt=mi[1]+1; - pi=4.*atan(1.); - constant=180./pi; - - /* copying the frequency parameters */ - - nev=mei[0]; - ncv=mei[1]; - mxiter=mei[2]; - tol=fei[0]; - fmin=2*pi*fei[1]; - fmax=2*pi*fei[2]; - - /* assigning the body forces to the elements */ - - if(*nbody>0){ - ifreebody=*ne+1; - ipobody=NNEW(int,2*ifreebody**nbody); - for(k=1;k<=*nbody;k++){ - FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, - iendset,ialset,&inewton,nset,&ifreebody,&k)); - RENEW(ipobody,int,2*(*ne+ifreebody)); - } - RENEW(ipobody,int,2*(ifreebody-1)); - if(inewton==1){ - printf("*ERROR in arpackcs: generalized gravity loading is not allowed in frequency calculations"); - FORTRAN(stop,()); - } - } - - /* determining the internal forces and the stiffness coefficients */ - - f=NNEW(double,*neq); - - /* allocating a field for the stiffness matrix */ - - xstiff=NNEW(double,27*mi[0]**ne); - - iout=-1; - v=NNEW(double,mt**nk); - fn=NNEW(double,mt**nk); - stx=NNEW(double,6*mi[0]**ne); - if(*iperturb==0){ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t0,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xboun,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq,veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, - &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, - sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, - fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - }else{ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1old,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xboun,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq,veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, - &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, - sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, - fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - } - free(f);free(v);free(fn);free(stx); - iout=1; - - /* determining the maximum number of sectors to be plotted */ - - ngraph=1; - for(j=0;j<*mcs;j++){ - if(cs[17*j+4]>ngraph) ngraph=cs[17*j+4]; - } - - /* assigning nodes and elements to sectors */ - - inocs=NNEW(int,*nk); - ielcs=NNEW(int,*ne); - ielset=cs[12]; - if((*mcs!=1)||(ielset!=0)){ - for(i=0;i<*nk;i++) inocs[i]=-1; - for(i=0;i<*ne;i++) ielcs[i]=-1; - } - - for(i=0;i<*mcs;i++){ - is=cs[17*i+4]; - if((is==1)&&(*mcs==1)) continue; - ielset=cs[17*i+12]; - if(ielset==0) continue; - for(i1=istartset[ielset-1]-1;i10){ - iel=ialset[i1]-1; - if(ipkon[iel]<0) continue; - ielcs[iel]=i; - indexe=ipkon[iel]; - if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; - else {nope=6;} - for(i2=0;i2=ialset[i1-1]-1) break; - if(ipkon[iel]<0) continue; - ielcs[iel]=i; - indexe=ipkon[iel]; - if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; - else {nope=6;} - for(i2=0;i20){inotrt=NNEW(int,2**nk*ngraph);} - if((strcmp1(&filab[0],"U ")==0)||(strcmp1(&filab[870],"PU ")==0)) -// real and imaginary part of the displacements - vt=NNEW(double,2*mt**nk*ngraph); - if(strcmp1(&filab[87],"NT ")==0) - t1t=NNEW(double,*nk*ngraph); - if((strcmp1(&filab[174],"S ")==0)||(strcmp1(&filab[1479],"PHS ")==0)) -// real and imaginary part of the stresses - stnt=NNEW(double,2*6**nk*ngraph); - if(strcmp1(&filab[261],"E ")==0) - eent=NNEW(double,6**nk*ngraph); - if(strcmp1(&filab[348],"RF ")==0) - fnt=NNEW(double,mt**nk*ngraph); - if(strcmp1(&filab[522],"ENER")==0) - enernt=NNEW(double,*nk*ngraph); - - kont=NNEW(int,*nkon*ngraph); - ipkont=NNEW(int,*ne*ngraph); - for(l=0;l<*ne*ngraph;l++)ipkont[l]=-1; - lakont=NNEW(char,8**ne*ngraph); - inumt=NNEW(int,*nk*ngraph); - ielmatt=NNEW(int,*ne*ngraph); - - nkt=ngraph**nk; - net=ngraph**ne; - - /* copying the coordinates of the first sector */ - - for(l=0;l<3**nk;l++){cot[l]=co[l];} - if(*ntrans>0){for(l=0;l<*nk;l++){inotrt[2*l]=inotr[2*l];}} - for(l=0;l<*nkon;l++){kont[l]=kon[l];} - for(l=0;l<*ne;l++){ipkont[l]=ipkon[l];} - for(l=0;l<8**ne;l++){lakont[l]=lakon[l];} - for(l=0;l<*ne;l++){ielmatt[l]=ielmat[l];} - - /* generating the coordinates for the other sectors */ - - icntrl=1; - - FORTRAN(rectcyl,(cot,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filab,&imag,mi)); - - for(jj=0;jj<*mcs;jj++){ - is=cs[17*jj+4]; - for(i=1;i0){inotrt[2*l+i*2**nk]=inotrt[2*l];} - } - } - for(l=0;l<*nkon;l++){kont[l+i**nkon]=kon[l]+i**nk;} - for(l=0;l<*ne;l++){ - if(ielcs[l]==jj){ - if(ipkon[l]>=0){ - ipkont[l+i**ne]=ipkon[l]+i**nkon; - ielmatt[l+i**ne]=ielmat[l]; - for(l1=0;l1<8;l1++){ - l2=8*l+l1; - lakont[l2+i*8**ne]=lakon[l2]; - } - } - } - } - } - } - - icntrl=-1; - - FORTRAN(rectcyl,(cot,vt,fnt,stnt,qfnt,eent,cs,&nkt,&icntrl,t,filab,&imag,mi)); - - /* check that the tensor fields which are extrapolated from the - integration points are requested in global coordinates */ - - if(strcmp1(&filab[174],"S ")==0){ - if((strcmp1(&filab[179],"L")==0)&&(*norien>0)){ - printf("\n*WARNING in arpackcs: element fields in cyclic symmetry calculations\n cannot be requested in local orientations;\n the global orientation will be used \n\n"); - strcpy1(&filab[179],"G",1); - } - } - - if(strcmp1(&filab[261],"E ")==0){ - if((strcmp1(&filab[266],"L")==0)&&(*norien>0)){ - printf("\n*WARNING in arpackcs: element fields in cyclic symmetry calculation\n cannot be requested in local orientations;\n the global orientation will be used \n\n"); - strcpy1(&filab[266],"G",1); - } - } - - if(strcmp1(&filab[1479],"PHS ")==0){ - if((strcmp1(&filab[1484],"L")==0)&&(*norien>0)){ - printf("\n*WARNING in arpackcs: element fields in cyclic symmetry calculation\n cannot be requested in local orientations;\n the global orientation will be used \n\n"); - strcpy1(&filab[1484],"G",1); - } - } - - if(strcmp1(&filab[1653],"MAXS")==0){ - if((strcmp1(&filab[1658],"L")==0)&&(*norien>0)){ - printf("\n*WARNING in arpackcs: element fields in cyclic symmetry calculation\n cannot be requested in local orientations;\n the global orientation will be used \n\n"); - strcpy1(&filab[1658],"G",1); - } - } - - /* allocating fields for magnitude and phase information of - displacements and stresses */ - - if(strcmp1(&filab[870],"PU")==0){ - vr=NNEW(double,mt*nkt); - vi=NNEW(double,mt*nkt); - } - - if(strcmp1(&filab[1479],"PHS")==0){ - stnr=NNEW(double,6*nkt); - stni=NNEW(double,6*nkt); - } - - if(strcmp1(&filab[1566],"MAXU")==0){ - vmax=NNEW(double,4*nkt); - } - - if(strcmp1(&filab[1653],"MAXS")==0){ - stnmax=NNEW(double,7*nkt); - } - - /* start of output calculations */ - - lfin=0; - for(j=0;jd[j]) continue; - if(fmax>0.){ - if(fmax0)FORTRAN(writehe,(&j)); - - eei=NNEW(double,6*mi[0]**ne); - if(*nener==1){ - stiini=NNEW(double,6*mi[0]**ne); - enerini=NNEW(double,mi[0]**ne);} - - memset(&v[0],0.,sizeof(double)*2*mt**nk); - - for(k=0;k<*neq;k+=*neq/2){ - - for(i=0;i<6*mi[0]**ne;i++){eme[i]=0.;} - - if(k==0) {kk=0;kkv=0;kk6=0;if(*nprint>0)FORTRAN(writere,());} - else {kk=*nk;kkv=mt**nk;kk6=6**nk;if(*nprint>0)FORTRAN(writeim,());} - - /* generating the cyclic MPC's (needed for nodal diameters - different from 0 */ - - for(i=0;i<*nmpc;i++){ - index=ipompc[i]-1; - /* check whether thermal mpc */ - if(nodempc[3*index+1]==0) continue; - coefmpcnew[index]=coefmpc[index]; - while(1){ - index=nodempc[3*index+2]; - if(index==0) break; - index--; - - icomplex=0; - inode=nodempc[3*index]; - if(strcmp1(&labmpc[20*i],"CYCLIC")==0){ - icomplex=atoi(&labmpc[20*i+6]);} - else if(strcmp1(&labmpc[20*i],"SUBCYCLIC")==0){ - for(ij=0;ij<*mcs;ij++){ - lprev=cs[ij*17+13]; - ilength=cs[ij*17+3]; - FORTRAN(nident,(&ics[lprev],&inode,&ilength,&id)); - if(id!=0){ - if(ics[lprev+id-1]==inode){icomplex=ij+1;break;} - } - } - } - - if(icomplex!=0){ - idir=nodempc[3*index+1]; - idof=nactdof[mt*(inode-1)+idir]-1; - if(idof==-1){xreal=1.;ximag=1.;} - else{xreal=z[lint+idof];ximag=z[lint+idof+*neq/2];} - if(k==0) { - if(fabs(xreal)<1.e-30)xreal=1.e-30; - coefmpcnew[index]=coefmpc[index]* - (cs[17*(icomplex-1)+14]+ximag/xreal*cs[17*(icomplex-1)+15]);} - else { - if(fabs(ximag)<1.e-30)ximag=1.e-30; - coefmpcnew[index]=coefmpc[index]* - (cs[17*(icomplex-1)+14]-xreal/ximag*cs[17*(icomplex-1)+15]);} - } - else{coefmpcnew[index]=coefmpc[index];} - } - } - - if(*iperturb==0){ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,&v[kkv],&stn[kk6],inum, - stx,elcon, - nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, - norien,orab,ntmat_,t0,t0,ithermal, - prestr,iprestr,filab,eme,&een[kk6],iperturb, - f,&fn[kkv],nactdof,&iout,qa,vold,&z[lint+k], - nodeboun,ndirboun,xboun,nboun,ipompc, - nodempc,coefmpcnew,labmpc,nmpc,nmethod,cam,neq,veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,&enern[kk],sti, - xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,&istep,&iinc));} - else{ - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,&v[kkv],&stn[kk6],inum, - stx,elcon, - nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, - norien,orab,ntmat_,t0,t1old,ithermal, - prestr,iprestr,filab,eme,&een[kk6],iperturb, - f,&fn[kkv],nactdof,&iout,qa,vold,&z[lint+k], - nodeboun,ndirboun,xboun,nboun,ipompc, - nodempc,coefmpcnew,labmpc,nmpc,nmethod,cam,neq,veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,&enern[kk],sti, - xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - } - - } - free(eei); - if(*nener==1){free(stiini);free(enerini);} - - if(strcmp1(&filab[1566],"MAXU")==0){ - - /* determining the ray vector; the components of the - ray vector are the coordinates of the node in node set - RAY */ - - iray=0; - for(i=0;i<*nset;i++){ - if(strcmp1(&set[81*i],"RAYN")==0){ - iray=ialset[istartset[i]-1]; - vray[0]=co[3*iray-3]; - vray[1]=co[3*iray-2]; - vray[2]=co[3*iray-1]; - break; - } - } - if(iray==0){ - printf("/n*ERROR in arpackcs: no light ray vector/n/n"); - FORTRAN(stop,()); - } - - /* initialization */ - - for(l1=0;l1<4**nk;l1++){vmax[l1]=0.;} - - /* vector p1 is a point on the rotation axis - vector p2 is a unit vector along the axis */ - - for(l2=0;l2<3;l2++){p1[l2]=cs[5+l2];} - for(l2=0;l2<3;l2++){p2[l2]=cs[8+l2]-p1[l2];} - dd=sqrt(p2[0]*p2[0]+p2[1]*p2[1]+p2[2]*p2[2]); - for(l2=0;l2<3;l2++){p2[l2]/=dd;} - - /* determine the time for the worst displacement - orthogonal to a give light ray vector ; */ - - for(l1=0;l1<*nk;l1++){ - - /* determining a vector through node (l1+1) and - orthogonal to the rotation axis */ - - for(l2=0;l2<3;l2++){q[l2]=co[3*l1+l2]-p1[l2];} - dd=q[0]*p2[0]+q[1]*p2[1]+q[2]*p2[2]; - for(l2=0;l2<3;l2++){q[l2]-=dd*p2[l2];} - - /* determining a vector tan orthogonal to vector q - and the ray vector */ - - tan[0]=q[1]*vray[2]-q[2]*vray[1]; - tan[1]=q[2]*vray[0]-q[0]*vray[2]; - tan[2]=q[0]*vray[1]-q[1]*vray[0]; - - printf("tangent= %d,%e,%e,%e\n",l1,tan[0],tan[1],tan[2]); - - worstumax=0.; - iworsttime=0; - for(l3=0;l3<360;l3++){ - ctl=cos(l3/constant); - stl=sin(l3/constant); - for(l2=1;l2<4;l2++){ - l=mt*l1+l2; - vl[l2]=ctl*v[l]-stl*v[l+mt**nk]; - } - - /* displacement component along the tangent vector - (no absolute value!) */ - - dd=vl[1]*tan[0]+vl[2]*tan[1]+vl[3]*tan[2]; - if(dd>worstumax){ - worstumax=dd; - iworsttime=l3; - } - } - ctl=cos(iworsttime/constant); - stl=sin(iworsttime/constant); - for(l2=1;l2<4;l2++){ - l=mt*l1+l2; - vl[l2]=ctl*v[l]-stl*v[l+mt**nk]; - } - vmax[4*l1]=1.*iworsttime; - vmax[4*l1+1]=vl[1]; - vmax[4*l1+2]=vl[2]; - vmax[4*l1+3]=vl[3]; - - } - } - - /* determine the time for the worst principal stress anywhere - in the structure; the worst principal stress is the maximum - of the absolute value of the principal stresses */ - - if(strcmp1(&filab[1653],"MAXS")==0){ - - /* determining the set of nodes for the - worst principal stress calculation */ - - ielset=0; - for(i=0;i<*nset;i++){ - if(strcmp1(&set[81*i],"STRESSDOMAINN")==0){ - ielset=i+1; - break; - } - } - if(ielset==0){ - printf("\n*ERROR in arpackcs: no node set for MAXS\n"); - printf(" (must have the name STRESSDOMAIN)\n\n"); - FORTRAN(stop,()); - } - -// worstpsmax=0.; -// iworsttime=0; - for(i1=istartset[ielset-1]-1;i10){ - l1=ialset[i1]-1; - - /* for(l1=0;l1<*nk;l1++){*/ - - worstpsmax=0.; - for(l3=0;l3<360;l3++){ - ctl=cos(l3/constant); - stl=sin(l3/constant); - for(l2=0;l2<6;l2++){ - l=6*l1+l2; - stnl[l2]=ctl*stn[l]-stl*stn[l+6**nk]; - } - - /* determining the eigenvalues */ - - v1=stnl[0]+stnl[1]+stnl[2]; - v2=stnl[1]*stnl[2]+stnl[0]*stnl[2]+stnl[0]*stnl[1]- - (stnl[5]*stnl[5]+stnl[4]*stnl[4]+stnl[3]*stnl[3]); - v3=stnl[0]*(stnl[1]*stnl[2]-stnl[5]*stnl[5]) - -stnl[3]*(stnl[3]*stnl[2]-stnl[4]*stnl[5]) - +stnl[4]*(stnl[3]*stnl[5]-stnl[4]*stnl[1]); - bb=v2-v1*v1/3.; - cc=-2.*v1*v1*v1/27.+v1*v2/3.-v3; - if(fabs(bb)<=1.e-10){ - if(fabs(cc)>1.e-10){ - al[0]=-pow(cc,(1./3.)); - }else{ - al[0]=0.; - } - al[1]=al[0]; - al[2]=al[0]; - }else{ - cm=2.*sqrt(-bb/3.); - cn=3.*cc/(cm*bb); - if(fabs(cn)>1.){ - if(cn>1.){ - cn=1.; - }else{ - cn=-1.; - } - } - tt=(atan2(sqrt(1.-cn*cn),cn))/3.; - al[0]=cm*cos(tt); - al[1]=cm*cos(tt+2.*pi/3.); - al[2]=cm*cos(tt+4.*pi/3.); - } - for(l2=0;l2<3;l2++){ - al[l2]+=v1/3.; - } - dd=fabs(al[0]); - if(fabs(al[1])>dd) dd=fabs(al[1]); - if(fabs(al[2])>dd) dd=fabs(al[2]); - if(dd>worstpsmax){ - worstpsmax=dd; -// iworsttime=l3; - stnmax[7*l1]=dd; - for(l2=1;l2<7;l2++){ - stnmax[7*l1+l2]=stnl[l2-1]; - } - } - } - - }else{ - l1=ialset[i1-2]-1; - do{ - l1=l1-ialset[i1]; - if(l1>=ialset[i1-1]-1) break; - - worstpsmax=0.; - for(l3=0;l3<360;l3++){ - ctl=cos(l3/constant); - stl=sin(l3/constant); - for(l2=0;l2<6;l2++){ - l=6*l1+l2; - stnl[l2]=ctl*stn[l]-stl*stn[l+6**nk]; - } - - /* determining the eigenvalues */ - - v1=stnl[0]+stnl[1]+stnl[2]; - v2=stnl[1]*stnl[2]+stnl[0]*stnl[2]+stnl[0]*stnl[1]- - (stnl[5]*stnl[5]+stnl[4]*stnl[4]+stnl[3]*stnl[3]); - v3=stnl[0]*(stnl[1]*stnl[2]-stnl[5]*stnl[5]) - -stnl[3]*(stnl[3]*stnl[2]-stnl[4]*stnl[5]) - +stnl[4]*(stnl[3]*stnl[5]-stnl[4]*stnl[1]); - bb=v2-v1*v1/3.; - cc=-2.*v1*v1*v1/27.+v1*v2/3.-v3; - if(fabs(bb)<=1.e-10){ - if(fabs(cc)>1.e-10){ - al[0]=-pow(cc,(1./3.)); - }else{ - al[0]=0.; - } - al[1]=al[0]; - al[2]=al[0]; - }else{ - cm=2.*sqrt(-bb/3.); - cn=3.*cc/(cm*bb); - if(fabs(cn)>1.){ - if(cn>1.){ - cn=1.; - }else{ - cn=-1.; - } - } - tt=(atan2(sqrt(1.-cn*cn),cn))/3.; - al[0]=cm*cos(tt); - al[1]=cm*cos(tt+2.*pi/3.); - al[2]=cm*cos(tt+4.*pi/3.); - } - for(l2=0;l2<3;l2++){ - al[l2]+=v1/3.; - } - dd=fabs(al[0]); - if(fabs(al[1])>dd) dd=fabs(al[1]); - if(fabs(al[2])>dd) dd=fabs(al[2]); - if(dd>worstpsmax){ - worstpsmax=dd; -// iworsttime=l3; - stnmax[7*l1]=dd; - for(l2=1;l2<7;l2++){ - stnmax[7*l1+l2]=stnl[l2-1]; - } - } - } - - }while(1); - } - } - - /* storing the stresses at the time of the worst - principal stress anywhere in the structure */ - -/* for(l1=0;l1<*nk;l1++){ - ctl=cos(iworsttime/constant); - stl=sin(iworsttime/constant); - for(l2=0;l2<6;l2++){ - l=6*l1+l2; - stnl[l2]=ctl*stn[l]-stl*stn[l+6**nk]; - }*/ - - /* determining the eigenvalues */ - -/* v1=stnl[0]+stnl[1]+stnl[2]; - v2=stnl[1]*stnl[2]+stnl[0]*stnl[2]+stnl[0]*stnl[1]- - (stnl[5]*stnl[5]+stnl[4]*stnl[4]+stnl[3]*stnl[3]); - v3=stnl[0]*(stnl[1]*stnl[2]-stnl[5]*stnl[5]) - -stnl[3]*(stnl[3]*stnl[2]-stnl[4]*stnl[5]) - +stnl[4]*(stnl[3]*stnl[5]-stnl[4]*stnl[1]); - bb=v2-v1*v1/3.; - cc=-2.*v1*v1*v1/27.+v1*v2/3.-v3; - if(fabs(bb)<=1.e-10){ - if(fabs(cc)>1.e-10){ - al[0]=-pow(cc,(1./3.)); - }else{ - al[0]=0.; - } - al[1]=al[0]; - al[2]=al[0]; - }else{ - cm=2.*sqrt(-bb/3.); - cn=3.*cc/(cm*bb); - if(fabs(cn)>1.){ - if(cn>1.){ - cn=1.; - }else{ - cn=-1.; - } - } - tt=(atan2(sqrt(1.-cn*cn),cn))/3.; - al[0]=cm*cos(tt); - al[1]=cm*cos(tt+2.*pi/3.); - al[2]=cm*cos(tt+4.*pi/3.); - } - for(l2=0;l2<3;l2++){ - al[l2]+=v1/3.; - } - dd=fabs(al[0]); - if(fabs(al[1])>dd) dd=fabs(al[1]); - if(fabs(al[2])>dd) dd=fabs(al[2]); - stnmax[7*l1]=dd; - for(l2=1;l2<7;l2++){ - stnmax[7*l1+l2]=stnl[l2-1]; - } - }*/ - } - - /* mapping the results to the other sectors */ - - for(l=0;l<*nk;l++){inumt[l]=inum[l];} - - icntrl=2;imag=1; - - FORTRAN(rectcyl,(co,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filab,&imag,mi)); - - /* vi and stni are abused to temporarily contain the imaginary part - of the displacements and stresses for all sectors, at first in - cylindrical coordinates, then in rectangular coordinates */ - - if((strcmp1(&filab[0],"U ")==0)||(strcmp1(&filab[870],"PU ")==0)) - for(l=0;l0){vi[l]=90.;} - else{vi[l]=-90.;} - } - else{ - vi[l]=atan(vimag/vreal)*constant; - if(vreal<0) vi[l]+=180.; - } - } - } - } - - /* determining magnitude and phase for the stress */ - - if(strcmp1(&filab[1479],"PHS")==0){ - for(l1=0;l10){stni[l]=90.;} - else{stni[l]=-90.;} - } - else{ - stni[l]=atan(stnimag/stnreal)*constant; - if(stnreal<0) stni[l]+=180.; - } - } - } - } - - ++*kode; - freq=d[j]/6.283185308; - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(cot,&nkt,kont,ipkont,lakont,&net,vt,stnt,inumt,nmethod,kode, - filab,eent,t1t,fnt,&freq,epn,ielmatt,matname,enernt,xstaten,nstate_, - &istep,&iinc,iperturb,ener,mi,output,ithermal,qfn,&j,&nm, - trab,inotrt,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,stx,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,&net,cs, - set,nset,istartset,iendset,ialset)); - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - - } - - if((fmax>0.)&&(fmax>d[nev-1])){ - printf("\n*WARNING: not all frequencies in the requested interval might be found;\nincrease the number of requested frequencies\n"); - } - - free(adb);free(aub);free(temp_array);free(coefmpcnew); - - free(v);free(fn);free(stn);free(inum);free(stx);free(resid); - free(z);free(workd);free(workl);free(select);free(d); - - if(strcmp1(&filab[261],"E ")==0) free(een); - if(strcmp1(&filab[522],"ENER")==0) free(enern); - - if((strcmp1(&filab[0],"U ")==0)||(strcmp1(&filab[870],"PU ")==0)) free(vt); - if(strcmp1(&filab[87],"NT ")==0) free(t1t); - if((strcmp1(&filab[174],"S ")==0)||(strcmp1(&filab[1479],"PHS ")==0)) free(stnt); - if(strcmp1(&filab[261],"E ")==0) free(eent); - if(strcmp1(&filab[348],"RF ")==0) free(fnt); - if(strcmp1(&filab[522],"ENER")==0) free(enernt); - - free(cot);free(kont);free(ipkont);free(lakont);free(inumt);free(ielmatt); - if(*ntrans>0){free(inotrt);} - - if(mei[3]==1){ - (*nevtot)+=nev; - fclose(f1); - } - - } - - free(inocs);free(ielcs);free(xstiff); - free(ipobody); - - if(strcmp1(&filab[870],"PU")==0){free(vr);free(vi);} - if(strcmp1(&filab[1479],"PHS")==0){free(stnr);free(stni);} - if(strcmp1(&filab[1566],"MAXU")==0){free(vmax);} - if(strcmp1(&filab[1653],"MAXS")==0){free(stnmax);} - - for(i=0;i<6*mi[0]**ne;i++){eme[i]=0.;} - - return; -} - -#endif diff -Nru calculix-ccx-2.1/ccx_2.1/src/attach.f calculix-ccx-2.3/ccx_2.1/src/attach.f --- calculix-ccx-2.1/ccx_2.1/src/attach.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/attach.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,351 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine attach(pneigh,pnode,nterms,ratio,dist,xil,etl) -! -! ataches node with coordinates in "pnode" to the face containing -! "nterms" nodes with coordinates in field "pneigh" (nterms < 9). -! cave: the coordinates are stored in pneigh(1..3,*) -! - implicit none -! - integer nterms,i,j,imin,jmin -! - real*8 ratio(8),pneigh(3,8),pnode(3),dummy, - & a(-1:1,-1:1),xi(-1:1,-1:1),et(-1:1,-1:1),p(3),aold(-1:1,-1:1), - & xiold(-1:1,-1:1),etold(-1:1,-1:1),distmin,xiopt,etopt, - & d1,d2,d3,d4,dist,xil,etl -! -c d1=0.25d0 -c d2=3.125d-2 -c d3=3.9063d-3 -c d4=1.d-3 - d1=1.d-1 - d2=1.d-2 - d3=1.d-4 - d4=1.d-6 -! -! initialisation -! - do i=-1,1 - do j=-1,1 - xi(i,j)=i*d1 - et(i,j)=j*d1 - call distattach(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, - & ratio,nterms) - enddo - enddo -! -! minimizing the distance from the face to the node -! - do - distmin=a(0,0) - imin=0 - jmin=0 - do i=-1,1 - do j=-1,1 - if(a(i,j).lt.distmin) then - distmin=a(i,j) - imin=i - jmin=j - endif - enddo - enddo -! -! exit if minimum found -! - if((imin.eq.0).and.(jmin.eq.0)) exit -! - do i=-1,1 - do j=-1,1 - aold(i,j)=a(i,j) - xiold(i,j)=xi(i,j) - etold(i,j)=et(i,j) - enddo - enddo -! - do i=-1,1 - do j=-1,1 - if((i+imin.ge.-1).and.(i+imin.le.1).and. - & (j+jmin.ge.-1).and.(j+jmin.le.1)) then - a(i,j)=aold(i+imin,j+jmin) - xi(i,j)=xiold(i+imin,j+jmin) - et(i,j)=etold(i+imin,j+jmin) - else - xi(i,j)=xi(i,j)+imin*d1 - et(i,j)=et(i,j)+jmin*d1 -! - xi(i,j)=min(xi(i,j),1.d0) - xi(i,j)=max(xi(i,j),-1.d0) - et(i,j)=min(et(i,j),1.d0) - et(i,j)=max(et(i,j),-1.d0) -! - call distattach(xi(i,j),et(i,j),pneigh, - & pnode,a(i,j),p,ratio,nterms) -! write(*,*) a(i,j) - endif - enddo - enddo - enddo -! -! 2nd run -! initialisation -! - xiopt=xi(0,0) - etopt=et(0,0) - do i=-1,1 - do j=-1,1 - xi(i,j)=xiopt+i*d2 - et(i,j)=etopt+j*d2 - xi(i,j)=min(xi(i,j),1.d0) - xi(i,j)=max(xi(i,j),-1.d0) - et(i,j)=min(et(i,j),1.d0) - et(i,j)=max(et(i,j),-1.d0) - call distattach(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, - & ratio,nterms) - enddo - enddo -! -! minimizing the distance from the face to the node -! - do - distmin=a(0,0) - imin=0 - jmin=0 - do i=-1,1 - do j=-1,1 - if(a(i,j).lt.distmin) then - distmin=a(i,j) - imin=i - jmin=j - endif - enddo - enddo -! -! exit if minimum found -! - if((imin.eq.0).and.(jmin.eq.0)) exit -! - do i=-1,1 - do j=-1,1 - aold(i,j)=a(i,j) - xiold(i,j)=xi(i,j) - etold(i,j)=et(i,j) - enddo - enddo -! - do i=-1,1 - do j=-1,1 - if((i+imin.ge.-1).and.(i+imin.le.1).and. - & (j+jmin.ge.-1).and.(j+jmin.le.1)) then - a(i,j)=aold(i+imin,j+jmin) - xi(i,j)=xiold(i+imin,j+jmin) - et(i,j)=etold(i+imin,j+jmin) - else - xi(i,j)=xi(i,j)+imin*d2 - et(i,j)=et(i,j)+jmin*d2 -! - xi(i,j)=min(xi(i,j),1.d0) - xi(i,j)=max(xi(i,j),-1.d0) - et(i,j)=min(et(i,j),1.d0) - et(i,j)=max(et(i,j),-1.d0) -! - call distattach(xi(i,j),et(i,j),pneigh, - & pnode,a(i,j),p,ratio,nterms) -! write(*,*) a(i,j) - endif - enddo - enddo - enddo -! -! 3rd run -! initialisation -! - xiopt=xi(0,0) - etopt=et(0,0) - do i=-1,1 - do j=-1,1 - xi(i,j)=xiopt+i*d3 - et(i,j)=etopt+j*d3 - xi(i,j)=min(xi(i,j),1.d0) - xi(i,j)=max(xi(i,j),-1.d0) - et(i,j)=min(et(i,j),1.d0) - et(i,j)=max(et(i,j),-1.d0) - call distattach(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, - & ratio,nterms) - enddo - enddo -! -! minimizing the distance from the face to the node -! - do - distmin=a(0,0) - imin=0 - jmin=0 - do i=-1,1 - do j=-1,1 - if(a(i,j).lt.distmin) then - distmin=a(i,j) - imin=i - jmin=j - endif - enddo - enddo -! -! exit if minimum found -! - if((imin.eq.0).and.(jmin.eq.0)) exit -! - do i=-1,1 - do j=-1,1 - aold(i,j)=a(i,j) - xiold(i,j)=xi(i,j) - etold(i,j)=et(i,j) - enddo - enddo -! - do i=-1,1 - do j=-1,1 - if((i+imin.ge.-1).and.(i+imin.le.1).and. - & (j+jmin.ge.-1).and.(j+jmin.le.1)) then - a(i,j)=aold(i+imin,j+jmin) - xi(i,j)=xiold(i+imin,j+jmin) - et(i,j)=etold(i+imin,j+jmin) - else - xi(i,j)=xi(i,j)+imin*d3 - et(i,j)=et(i,j)+jmin*d3 -! - xi(i,j)=min(xi(i,j),1.d0) - xi(i,j)=max(xi(i,j),-1.d0) - et(i,j)=min(et(i,j),1.d0) - et(i,j)=max(et(i,j),-1.d0) -! - call distattach(xi(i,j),et(i,j),pneigh, - & pnode,a(i,j),p,ratio,nterms) -! write(*,*) a(i,j) - endif - enddo - enddo - enddo -! -! 4th run -! initialisation -! - xiopt=xi(0,0) - etopt=et(0,0) - do i=-1,1 - do j=-1,1 - xi(i,j)=xiopt+i*d4 - et(i,j)=etopt+j*d4 - xi(i,j)=min(xi(i,j),1.d0) - xi(i,j)=max(xi(i,j),-1.d0) - et(i,j)=min(et(i,j),1.d0) - et(i,j)=max(et(i,j),-1.d0) - call distattach(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, - & ratio,nterms) - enddo - enddo -! -! minimizing the distance from the face to the node -! - do - distmin=a(0,0) - imin=0 - jmin=0 - do i=-1,1 - do j=-1,1 - if(a(i,j).lt.distmin) then - distmin=a(i,j) - imin=i - jmin=j - endif - enddo - enddo -! -! exit if minimum found -! - if((imin.eq.0).and.(jmin.eq.0)) exit -! - do i=-1,1 - do j=-1,1 - aold(i,j)=a(i,j) - xiold(i,j)=xi(i,j) - etold(i,j)=et(i,j) - enddo - enddo -! - do i=-1,1 - do j=-1,1 - if((i+imin.ge.-1).and.(i+imin.le.1).and. - & (j+jmin.ge.-1).and.(j+jmin.le.1)) then - a(i,j)=aold(i+imin,j+jmin) - xi(i,j)=xiold(i+imin,j+jmin) - et(i,j)=etold(i+imin,j+jmin) - else - xi(i,j)=xi(i,j)+imin*d4 - et(i,j)=et(i,j)+jmin*d4 -! - xi(i,j)=min(xi(i,j),1.d0) - xi(i,j)=max(xi(i,j),-1.d0) - et(i,j)=min(et(i,j),1.d0) - et(i,j)=max(et(i,j),-1.d0) -! - call distattach(xi(i,j),et(i,j),pneigh, - & pnode,a(i,j),p,ratio,nterms) -! write(*,*) a(i,j) - endif - enddo - enddo - enddo -! - call distattach(xi(0,0),et(0,0),pneigh,pnode,a(0,0),p, - & ratio,nterms) -! - do i=1,3 - pnode(i)=p(i) - enddo -! - dist=a(0,0) -! - if(nterms.eq.3) then - xil=(xi(0,0)+1.d0)/2.d0 - etl=(et(0,0)+1.d0)/2.d0 - if(xil+etl.gt.1.d0) then - dummy=xil - xil=1.d0-etl - etl=1.d0-dummy - endif - elseif(nterms.eq.4) then - xil=xi(0,0) - etl=et(0,0) - elseif(nterms.eq.6) then - xil=(xi(0,0)+1.d0)/2.d0 - etl=(et(0,0)+1.d0)/2.d0 - if(xil+etl.gt.1.d0) then - dummy=xil - xil=1.d0-etl - etl=1.d0-dummy - endif - elseif(nterms.eq.8) then - xil=xi(0,0) - etl=et(0,0) - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/bdfill.c calculix-ccx-2.3/ccx_2.1/src/bdfill.c --- calculix-ccx-2.1/ccx_2.1/src/bdfill.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/bdfill.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,168 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -/* - *Calculate the entries of Bd and Dd, and insert them into the data structure -*/ - -void bdfill(int **irowbdp, int *jqbd, - double **aubdp, double *bdd,int *nzsbd, int *ntie, int *ipkon, int *kon, - char *lakon, int *nslavnode, int *nmastnode, int *imastnode, - int *islavnode, int *islavsurf, int *imastsurf, double *pmastsurf, - int *itiefac, int *neq, int *nactdof, double *co, double *vold, - int *iponoels, int *inoels, int *mi, double *gapmints, double *gap, - double* pslavsurf,double* pslavdual){ - - int i, j, k,l,m, idof1,idofs,idofm, nodes, nodem, kflag, index, indexold, - *mast1=NULL, *irowbd=NULL,ifree,*ipointer=NULL,mt=mi[1]+1,contint; - - double contribution=0.0, *aubd=NULL,gapcont=0.0; - - irowbd = *irowbdp; aubd=*aubdp; - - ifree = 0; - ipointer=NNEW(int,neq[1]); - mast1=NNEW(int,*nzsbd); - - /* calculating the off-diagonal terms and storing them in aubd */ - - /* meaning of the fields in FORTRAN notation: - ipointer(i): points to an element in field aubd belonging to column i - aubd(ipointer(i)): value of that element - irowbd(ipointer(i)): row to which that element belongs - mast1(ipointer(i)): points to another element in field aubd belonging - to column i, unless zero. - */ - - for( i=0; i<*ntie; i++){ - for(j=nslavnode[i]; j0)&&(idofm>0)){ //insertion for active dofs - insertas(ipointer, &irowbd, &mast1, &idofs, &idofm, &ifree, nzsbd, - &contribution, &aubd); - // printf("idofs =%d , ifofm =%d, cont = %e\n",idofs,idofm,contribution); - } - //} - } - } - } - } - - *nzsbd=ifree; - RENEW(irowbd,int,*nzsbd); - RENEW(aubd,double,*nzsbd); - - //replace mast1 by the column numbers - - for(i=0; i0) - bdd[idof1-1]+=contribution; - } - } - } - - *irowbdp = irowbd; *aubdp=aubd; - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/beamsections.f calculix-ccx-2.3/ccx_2.1/src/beamsections.f --- calculix-ccx-2.1/ccx_2.1/src/beamsections.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/beamsections.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,281 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine beamsections(inpc,textpart,set,istartset,iendset, - & ialset,nset,ielmat,matname,nmat,ielorien,orname,norien, - & thicke,ipkon,iponor,xnor,ixfree, - & offset,lakon,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & ipoinpc) -! -! reading the input deck: *BEAM SECTION -! - implicit none -! - character*1 inpc(*) - character*4 section - character*8 lakon(*) - character*80 matname(*),orname(*),material,orientation - character*81 set(*),elset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),ielmat(*),ipoinpc(0:*), - & ielorien(*),ipkon(*),iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - integer nset,nmat,norien,istep,istat,n,key,i,j,k,l,imaterial, - & iorientation,ipos,m,iponor(2,*),ixfree, - & indexx,indexe,irstrt -! - real*8 thicke(2,*),thickness1,thickness2,p(3),xnor(*),offset(2,*), - & offset1,offset2,dd -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in beamsections: *SOLID SECTION should' - write(*,*) ' be placed before all step definitions' - stop - endif -! - offset1=0.d0 - offset2=0.d0 - orientation=' - & ' - section=' ' -! - do i=2,n - if(textpart(i)(1:9).eq.'MATERIAL=') then - material=textpart(i)(10:89) - elseif(textpart(i)(1:12).eq.'ORIENTATION=') then - orientation=textpart(i)(13:92) - elseif(textpart(i)(1:6).eq.'ELSET=') then - elset=textpart(i)(7:86) - elset(21:21)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - elseif(textpart(i)(1:8).eq.'SECTION=') then - if(textpart(i)(9:12).eq.'CIRC') then - section='CIRC' - elseif(textpart(i)(9:12).eq.'RECT') then - section='RECT' - else - write(*,*) '*ERROR in beamsections: unknown section' - stop - endif - elseif(textpart(i)(1:8).eq.'OFFSET1=') then - read(textpart(i)(9:28),'(f20.0)',iostat=istat) offset1 - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:8).eq.'OFFSET2=') then - read(textpart(i)(9:28),'(f20.0)',iostat=istat) offset2 - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - enddo -! -! check whether a sections was defined -! - if(section.eq.' ') then - write(*,*) '*ERROR in beamsections: no section defined' - stop - endif -! -! check for the existence of the set,the material and orientation -! - do i=1,nmat - if(matname(i).eq.material) exit - enddo - if(i.gt.nmat) then - write(*,*) '*ERROR in beamsections: nonexistent material' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - imaterial=i -! - if(orientation.eq.' - & ') then - iorientation=0 - else - do i=1,norien - if(orname(i).eq.orientation) exit - enddo - if(i.gt.norien) then - write(*,*)'*ERROR in beamsections: nonexistent orientation' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iorientation=i - endif -! - do i=1,nset - if(set(i).eq.elset) exit - enddo - if(i.gt.nset) then - elset(ipos:ipos)=' ' - write(*,*) '*ERROR in beamsections: element set ',elset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! -! assigning the elements of the set the appropriate material, -! orientation number, section and offset(s) -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - if(lakon(ialset(j))(1:1).ne.'B') then - write(*,*) '*ERROR in beamsections: *BEAM SECTION can' - write(*,*) ' only be used for beam elements.' - write(*,*) ' Element ',ialset(j),' is not a beam el - &ement.' - stop - endif - ielmat(ialset(j))=imaterial - ielorien(ialset(j))=iorientation - offset(1,ialset(j))=offset1 - offset(2,ialset(j))=offset2 - if(section.eq.'RECT') then - lakon(ialset(j))(8:8)='R' - else - lakon(ialset(j))(8:8)='C' - endif - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - if(lakon(k)(1:1).ne.'B') then - write(*,*) '*ERROR in beamsections: *BEAM SECTION can' - write(*,*) ' only be used for beam elements.' - write(*,*) ' Element ',k,' is not a beam element - &.' - stop - endif - ielmat(k)=imaterial - ielorien(k)=iorientation - offset(1,k)=offset1 - offset(2,k)=offset2 - if(section.eq.'RECT') then - lakon(k)(8:8)='R' - else - lakon(k)(8:8)='C' - endif - enddo - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! -! assigning a thickness to the elements -! - read(textpart(1)(1:20),'(f20.0)',iostat=istat) thickness1 - if(istat.gt.0) then - write(*,*) - & '*ERROR in beamsections: first beam thickness is lacking' - call inputerror(inpc,ipoinpc,iline) - endif - if(n.gt.1) then - read(textpart(2)(1:20),'(f20.0)',iostat=istat) thickness2 - if(istat.gt.0) then - write(*,*) - & '*ERROR in beamsections: second beam thickness is lacking' - call inputerror(inpc,ipoinpc,iline) - endif - else - thickness2=thickness1 - endif - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - indexe=ipkon(ialset(j)) - do l=1,8 - thicke(1,indexe+l)=thickness1 - thicke(2,indexe+l)=thickness2 - enddo - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - indexe=ipkon(k) - do l=1,8 - thicke(1,indexe+l)=thickness1 - thicke(2,indexe+l)=thickness2 - enddo - enddo - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return -! -! assigning normal direction 1 for the beam -! - indexx=-1 - read(textpart(1)(1:20),'(f20.0)',iostat=istat) p(1) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) p(2) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) p(3) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - dd=dsqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3)) - if(dd.lt.1.d-10) then - write(*,*) '*ERROR in beamsections: normal in direction 1' - write(*,*) ' has zero size' - stop - endif - do j=1,3 - p(j)=p(j)/dd - enddo - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - indexe=ipkon(ialset(j)) - do l=1,8 - if(indexx.eq.-1) then - indexx=ixfree - do m=1,3 - xnor(indexx+m)=p(m) - enddo - ixfree=ixfree+6 - endif - iponor(1,indexe+l)=indexx - enddo - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - indexe=ipkon(k) - do l=1,8 - if(indexx.eq.-1) then - indexx=ixfree - do m=1,3 - xnor(indexx+m)=p(m) - enddo - ixfree=ixfree+6 - endif - iponor(1,indexe+l)=indexx - enddo - enddo - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/bodyadd.f calculix-ccx-2.3/ccx_2.1/src/bodyadd.f --- calculix-ccx-2.1/ccx_2.1/src/bodyadd.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/bodyadd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,179 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine bodyadd(cbody,ibody,xbody,nbody,nbody_,set,label, - & iamplitude,xmagnitude,p1,p2,bodyf,xbodyold,lc) -! -! adds a volumetric dload condition to the data base -! - implicit none -! - character*20 label - character*81 set,cbody(*) -! - integer ibody(3,*),nbody,nbody_,id,iamplitude,ilabel,i,j,id1,lc -! - real*8 xbody(7,*),p1(3),p2(3),bodyf(3),xmagnitude,xbodyold(7,*), - & dd,p(3) -! -! assigning a number to the load type (stored in ibody(1,*)) -! - if(label(1:7).eq.'CENTRIF') then - ilabel=1 - elseif(label(1:4).eq.'GRAV') then - ilabel=2 - elseif(label(1:6).eq.'NEWTON') then - ilabel=3 - endif -! -! normalizing the direction for gravity forces -! - if(ilabel.eq.2) then - dd=dsqrt(bodyf(1)*bodyf(1)+bodyf(2)*bodyf(2)+bodyf(3)*bodyf(3)) - do i=1,3 - bodyf(i)=bodyf(i)/dd - enddo - endif -! -! checking whether a similar load type was already assigned to the -! same set -! - call cident(cbody,set,nbody,id) -! - if(id.ne.0) then - do - if(id.eq.0) exit - if(cbody(id).eq.set) then - if(ibody(1,id).eq.ilabel) then -! -! for gravity forces the gravity direction is -! checked; if the direction is different,it is -! a new loading -! - if(ilabel.eq.2) then - if(dabs(bodyf(1)*xbody(2,id)+bodyf(2)*xbody(3,id)+ - & bodyf(3)*xbody(4,id)-1.d0).gt.1.d-10) then - id=id-1 - cycle - endif - endif -! -! for centrifugal loads the centrifugal axis is -! checked -! - if(ilabel.eq.1) then - if(dabs(p2(1)*xbody(5,id)+p2(2)*xbody(6,id)+ - & p2(3)*xbody(7,id)-1.d0).gt.1.d-10) then - id=id-1 - cycle - endif - do i=1,3 - p(i)=xbody(1+i,id)-p1(i) - enddo - dd=dsqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3)) - if(dd.gt.1.d-10) then - do i=1,3 - p(i)=p(i)/dd - enddo - if(dabs(p(1)*xbody(5,id)+p(2)*xbody(6,id)+ - & p(3)*xbody(7,id)-1.d0).gt.1.d-10) then - id=id-1 - cycle - endif - endif - endif -! -! check for the same loadcase -! - if(ibody(3,id).ne.lc) then - id=id-1 - cycle - endif -! - ibody(2,id)=iamplitude - ibody(3,id)=lc - if(ilabel.eq.1) then - xbody(1,id)=xmagnitude - xbody(2,id)=p1(1) - xbody(3,id)=p1(2) - xbody(4,id)=p1(3) - xbody(5,id)=p2(1) - xbody(6,id)=p2(2) - xbody(7,id)=p2(3) - elseif(ilabel.eq.2) then - xbody(1,id)=xmagnitude - xbody(2,id)=bodyf(1) - xbody(3,id)=bodyf(2) - xbody(4,id)=bodyf(3) - endif - return - endif - id=id-1 - else - exit - endif - enddo - endif -! -! new set/loadtype combination -! - nbody=nbody+1 - if(nbody.gt.nbody_) then - write(*,*) '*ERROR in bodyadd: increase nbody_' - stop - endif -! -! reordering the arrays -! - do i=nbody,id+2,-1 - cbody(i)=cbody(i-1) - do j=1,3 - ibody(j,i)=ibody(j,i-1) - enddo - do j=1,7 - xbody(j,i)=xbody(j,i-1) - xbodyold(j,i)=xbodyold(j,i-1) - enddo - enddo -! -! inserting the new values -! - id1=id+1 -! - cbody(id1)=set - ibody(1,id1)=ilabel - ibody(2,id1)=iamplitude - ibody(3,id1)=lc - if(ilabel.eq.1) then - xbody(1,id1)=xmagnitude - xbody(2,id1)=p1(1) - xbody(3,id1)=p1(2) - xbody(4,id1)=p1(3) - xbody(5,id1)=p2(1) - xbody(6,id1)=p2(2) - xbody(7,id1)=p2(3) - elseif(ilabel.eq.2) then - xbody(1,id1)=xmagnitude - xbody(2,id1)=bodyf(1) - xbody(3,id1)=bodyf(2) - xbody(4,id1)=bodyf(3) - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/bodyforce.f calculix-ccx-2.3/ccx_2.1/src/bodyforce.f --- calculix-ccx-2.1/ccx_2.1/src/bodyforce.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/bodyforce.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,87 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine bodyforce(cbody,ibody,ipobody,nbody,set,istartset, - & iendset,ialset,inewton,nset,ifreebody,k) -! -! assigns the body forces to the elements by use of field ipobody -! - implicit none -! - character*81 cbody(*),elset,set(*) -! - integer ibody(3,*),ipobody(2,*),i,j,l,istartset(*),nbody, - & iendset(*),ialset(*),kindofbodyforce,inewton,nset,istat, - & ifreebody,k -! - elset=cbody(k) - kindofbodyforce=ibody(1,k) - if(kindofbodyforce.eq.3) inewton=1 -! -! check whether element number or set name -! - read(elset,'(i21)',iostat=istat) l - if(istat.eq.0) then - if(ipobody(1,l).eq.0) then - ipobody(1,l)=k - else - ipobody(2,ifreebody)=ipobody(2,l) - ipobody(2,l)=ifreebody - ipobody(1,ifreebody)=k - ifreebody=ifreebody+1 - endif - return - endif -! -! set name -! - do i=1,nset - if(set(i).eq.elset) exit - enddo -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - l=ialset(j) - if(ipobody(1,l).eq.0) then - ipobody(1,l)=k - else - ipobody(2,ifreebody)=ipobody(2,l) - ipobody(2,l)=ifreebody - ipobody(1,ifreebody)=k - ifreebody=ifreebody+1 - endif - else - l=ialset(j-2) - do - l=l-ialset(j) - if(l.ge.ialset(j-1)) exit - if(ipobody(1,l).eq.0) then - ipobody(1,l)=k - else - ipobody(2,ifreebody)=ipobody(2,l) - ipobody(2,l)=ifreebody - ipobody(1,ifreebody)=k - ifreebody=ifreebody+1 - endif - enddo - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/bounadd.f calculix-ccx-2.3/ccx_2.1/src/bounadd.f --- calculix-ccx-2.1/ccx_2.1/src/bounadd.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/bounadd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,264 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine bounadd(node,is,ie,val,nodeboun,ndirboun,xboun, - & nboun,nboun_,iamboun,iamplitude,nam,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, - & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc,type, - & typeboun,nmethod,iperturb,fixed,vold,nodetrue,mi) -! -! adds a boundary condition to the data base -! - implicit none -! - logical fixed -! - character*1 type,typeboun(*) - character*20 labmpc(*) -! - integer nodeboun(*),ndirboun(*),node,is,ie,nboun,nboun_,i,j, - & iamboun(*),iamplitude,nam,ipompc(*),nodempc(3,*),nmpc,nmpc_, - & mpcfree,inotr(2,*),ntrans,ikboun(*),ilboun(*),ikmpc(*), - & ilmpc(*),itr,idof,newnode,number,id,idofnew,idnew,nk,nk_, - & mpcfreenew,nmethod,iperturb,ii,nodetrue,mi(2) -! - real*8 xboun(*),val,coefmpc(*),trab(7,*),a(3,3),co(3,*), - & vold(0:mi(2),*) -! - if(ntrans.le.0) then - itr=0 - elseif(inotr(1,node).eq.0) then - itr=0 - else - itr=inotr(1,node) - endif -! - if((itr.eq.0).or.(is.eq.0).or.(is.eq.11).or.(is.eq.8)) then -! -! no transformation applies: simple SPC -! - loop: do ii=is,ie - if(ii.le.3) then - i=ii - elseif(ii.eq.4) then - i=5 - elseif(ii.eq.5) then - i=6 - elseif(ii.eq.6) then - i=7 - elseif(ii.eq.8) then - i=4 - elseif(ii.eq.11) then - i=0 - else - write(*,*) '*ERROR in bounadd: unknown DOF: ', - & ii - stop - endif - if((fixed).and.(i<5)) then - val=vold(i,nodetrue) - elseif(fixed) then - write(*,*) '*ERROR in bounadd: parameter FIXED cannot' - write(*,*) ' be used for rotations' - stop - endif - idof=8*(node-1)+i - call nident(ikboun,idof,nboun,id) - if(id.gt.0) then - if(ikboun(id).eq.idof) then - j=ilboun(id) - xboun(j)=val - typeboun(j)=type - if(nam.gt.0) iamboun(j)=iamplitude - cycle loop - endif - endif - nboun=nboun+1 - if(nboun.gt.nboun_) then - write(*,*) '*ERROR in bounadd: increase nboun_' - stop - endif - if((nmethod.eq.4).and.(iperturb.le.1)) then - write(*,*) '*ERROR in bounadd: in a modal dynamic step' - write(*,*) ' new SPCs are not allowed' - stop - endif - nodeboun(nboun)=node - ndirboun(nboun)=i - xboun(nboun)=val - typeboun(nboun)=type - if(nam.gt.0) iamboun(nboun)=iamplitude -! -! updating ikboun and ilboun -! - do j=nboun,id+2,-1 - ikboun(j)=ikboun(j-1) - ilboun(j)=ilboun(j-1) - enddo - ikboun(id+1)=idof - ilboun(id+1)=nboun - enddo loop - else -! -! transformation applies: SPC is MPC in global carthesian -! coordinates -! - call transformatrix(trab(1,itr),co(1,node),a) - do ii=is,ie - if(ii.le.3) then - i=ii - elseif(ii.eq.4) then - i=5 - elseif(ii.eq.5) then - i=6 - elseif(ii.eq.6) then - i=7 - elseif(ii.eq.8) then - i=4 - elseif(ii.eq.11) then - i=0 - else - write(*,*) '*ERROR in bounadd: unknown DOF: ', - & ii - stop - endif - if((fixed).and.(i<5)) then - val=vold(i,nodetrue) - elseif(fixed) then - write(*,*) '*ERROR in bounadd: parameter FIXED cannot' - write(*,*) ' be used for rotations' - stop - endif - if(inotr(2,node).ne.0) then - newnode=inotr(2,node) - idofnew=8*(newnode-1)+i - call nident(ikboun,idofnew,nboun,idnew) - if(idnew.gt.0) then - if(ikboun(idnew).eq.idofnew) then - j=ilboun(idnew) - xboun(j)=val - typeboun(j)=type - if(nam.gt.0) iamboun(j)=iamplitude - cycle - endif - endif - else -! -! new node is generated for the inhomogeneous MPC term -! - if((nmethod.eq.4).and.(iperturb.le.1)) then - write(*,*)'*ERROR in bounadd: in a modal dynamic step' - write(*,*) ' new SPCs are not allowed' - stop - endif - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in bounadd: increase nk_' - stop - endif - newnode=nk - inotr(2,node)=newnode - idofnew=8*(newnode-1)+i - idnew=nboun -! -! copying the initial conditions from node into newnode -! - do j=0,mi(2) - vold(j,newnode)=vold(j,node) - enddo -c write(*,*) ' bounadd ',nk,vold(0,nk),node,vold(0,node) - endif -! -! new mpc -! - do number=1,3 - idof=8*(node-1)+number - call nident(ikmpc,idof,nmpc,id) - if(id.ne.0) then - if(ikmpc(id).eq.idof) cycle - endif - if(dabs(a(number,i)).lt.1.d-5) cycle - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in bounadd: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - exit - enddo -! - number=number-1 - do j=1,3 - number=number+1 - if(number.gt.3) number=1 - if(dabs(a(number,i)).lt.1.d-5) cycle - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=number - coefmpc(mpcfree)=a(number,i) - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) '*ERROR in bounadd: increase nmpc_' - stop - endif - enddo - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=i - coefmpc(mpcfree)=-1.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) '*ERROR in bounadd: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew -! -! nonhomogeneous term -! - nboun=nboun+1 - if(nboun.gt.nboun_) then - write(*,*) '*ERROR in bounadd: increase nboun_' - stop - endif - nodeboun(nboun)=newnode - ndirboun(nboun)=i - xboun(nboun)=val - typeboun(nboun)=type - if(nam.gt.0) iamboun(nboun)=iamplitude -! -! updating ikboun and ilboun -! - do j=nboun,idnew+2,-1 - ikboun(j)=ikboun(j-1) - ilboun(j)=ilboun(j-1) - enddo - ikboun(idnew+1)=idofnew - ilboun(idnew+1)=nboun -! - enddo - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/boundaries.f calculix-ccx-2.3/ccx_2.1/src/boundaries.f --- calculix-ccx-2.1/ccx_2.1/src/boundaries.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/boundaries.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,340 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine boundaries(inpc,textpart,set,istartset,iendset, - & ialset,nset,nodeboun,ndirboun,xboun,nboun,nboun_,nk, - & iamboun,amname,nam,ipompc,nodempc,coefmpc,nmpc,nmpc_, - & mpcfree,inotr,trab,ntrans,ikboun,ilboun,ikmpc,ilmpc,nk_, - & co,labmpc,boun_flag,typeboun,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,nam_,namtot_,namta,amta,nmethod,iperturb, - & iaxial,ipoinpc,vold,mi) -! -! reading the input deck: *INITIAL CONDITIONS -! - implicit none -! - logical boun_flag,user,massflowrate,fixed -! - character*1 typeboun(*),type,inpc(*) - character*20 labmpc(*) - character*80 amname(*),amplitude - character*81 set(*),noset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),nodeboun(*),ndirboun(*), - & nset,nboun,nboun_,istep,istat,n,i,j,k,l,ibounstart,ibounend, - & key,nk,iamboun(*),nam,iamplitude,ipompc(*),nodempc(3,*), - & nmpc,nmpc_,mpcfree,inotr(2,*),ikboun(*),ilboun(*),ikmpc(*), - & ilmpc(*),nmpcold,id,idof,index1,ntrans,nk_,ipos,m,node,is,ie, - & iline,ipol,inl,ipoinp(2,*),inp(3,*),nam_,namtot,namtot_, - & namta(3,*),idelay,nmethod,iperturb,lc,iaxial,ipoinpc(0:*), - & ktrue,mi(2) -! - real*8 xboun(*),bounval,coefmpc(*),trab(7,*),co(3,*),amta(2,*), - & vold(0:mi(2),*) -! - type='B' - iamplitude=0 - idelay=0 - user=.false. - massflowrate=.false. - fixed=.false. - lc=1 -! - do i=2,n - if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.boun_flag)) then -! -! spc's in nonglobal coordinates result in mpc's -! removing these mpc's -! necessary and sufficient condition for a MPC to be removed: -! - on the dependent side a node "a" corresponding to SPC "b" -! (no matter which DOF); SPC "b" is applied in direction "c" of -! node "a" and corresponds to node "d" to account for the -! inhomogeneous term -! - on the independent side a term for node "d" in direction "c". -! - if(ntrans.gt.0) then - nmpcold=nmpc - do j=1,nk - if(inotr(2,j).gt.0) then - do k=1,3 - idof=8*(inotr(2,j)-1)+k - call nident(ikboun,idof,nboun,id) - if(id.gt.0) then - if(ikboun(id).eq.idof) then -! -! if a SPC is defined in direction k for a node j for which a -! local coordinate system applies, then the coordinate system -! number is stored in inotr(1,j) and the additional node -! for the inhomogeneous term is stored in inotr(2,j). The -! SPC DOF is (inotr(2,j)-1)*3+k, however, the independent -! MPC DOF is (j-1)*3+l, where l can be different from k, -! since (j-1)*3+k might already be taken by another MPC, or -! the coefficient for this direction might be zero. -! - loop: do l=1,3 - idof=8*(j-1)+l - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - index1=ipompc(ilmpc(id)) - if(index1.eq.0) cycle - do - if((nodempc(1,index1).eq. - & inotr(2,j)).and. - & (nodempc(2,index1).eq.k)) - & then - nodempc(3,index1)=mpcfree - mpcfree=ipompc(ilmpc(id)) - ipompc(ilmpc(id))=0 - do m=id,nmpc-1 - ikmpc(m)=ikmpc(m+1) - ilmpc(m)=ilmpc(m+1) - enddo - ikmpc(nmpc)=0 - ilmpc(nmpc)=0 - nmpc=nmpc-1 - exit - endif - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif - endif - enddo loop -! - endif - endif - enddo - endif - enddo -! -! getting rid of the superfluous lines in ipompc and labmpc -! - k=0 - do j=1,nmpcold - if(ipompc(j).ne.0) then - k=k+1 - ipompc(k)=ipompc(j) - labmpc(k)=labmpc(j) - index1=ipompc(j) - idof=8*(nodempc(1,index1)-1)+nodempc(2,index1) - call nident(ikmpc,idof,nmpc,id) - if(id.eq.0) then - write(*,*) '*ERROR in boundaries' - stop - elseif(ikmpc(id).ne.idof) then - write(*,*) '*ERROR in boundaries' - stop - endif - ilmpc(id)=k - endif - enddo - endif -! -! removing the boundary conditions defined by a *BOUNDARY -! statement -! - loop1: do - if(nboun.gt.0) then - do j=1,nboun - if(typeboun(j).eq.'B') then - node=nodeboun(j) - is=ndirboun(j) - ie=ndirboun(j) - call bounrem(node,is,ie,nodeboun,ndirboun,xboun, - & nboun,iamboun,nam,ikboun,ilboun,typeboun) - cycle loop1 - endif - enddo - exit - endif - exit - enddo loop1 -c nboun=0 - elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then - read(textpart(i)(11:90),'(a80)') amplitude - do j=nam,1,-1 - if(amname(j).eq.amplitude) then - iamplitude=j - exit - endif - enddo - if(j.gt.nam) then - write(*,*)'*ERROR in boundaries: nonexistent amplitude' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iamplitude=j - elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN - if(idelay.ne.0) then - write(*,*) '*ERROR in boundaries: the parameter TIME' - write(*,*) ' DELAY is used twice in the same' - write(*,*) ' keyword; ' - call inputerror(inpc,ipoinpc,iline) - stop - else - idelay=1 - endif - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in boundaries: increase nam_' - stop - endif - amname(nam)=' - & ' - if(iamplitude.eq.0) then - write(*,*) '*ERROR in boundaries: time delay must be' - write(*,*) ' preceded by the amplitude parameter' - stop - endif - namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) - iamplitude=nam - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) '*ERROR boundaries: increase namtot_' - stop - endif - namta(1,nam)=namtot - namta(2,nam)=namtot - read(textpart(i)(11:30),'(f20.0)',iostat=istat) - & amta(1,namtot) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:9).eq.'LOADCASE=') then - read(textpart(i)(10:19),'(i10)',iostat=istat) lc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(nmethod.ne.5) then - write(*,*) '*ERROR in boundaries: the parameter LOAD' - write(*,*) ' CASE is only allowed in STEADY STATE' - write(*,*) ' DYNAMICS calculations' - stop - endif - elseif(textpart(i)(1:4).eq.'USER') then - user=.true. - elseif(textpart(i)(1:8).eq.'MASSFLOW') then - massflowrate=.true. - elseif(textpart(i)(1:5).eq.'FIXED') then - fixed=.true. - endif - enddo -! - if(user.and.(iamplitude.ne.0)) then - write(*,*) '*WARNING: no amplitude definition is allowed' - write(*,*) ' for temperatures defined by a' - write(*,*) ' user routine' - iamplitude=0 - endif -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return -! - read(textpart(2)(1:10),'(i10)',iostat=istat) ibounstart - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -c if(ibounstart.eq.11) ibounstart=0 -! - if(textpart(3)(1:1).eq.' ') then - ibounend=ibounstart - else - read(textpart(3)(1:10),'(i10)',iostat=istat) ibounend - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif -! - if(textpart(4)(1:1).eq.' ') then - bounval=0.d0 - else - read(textpart(4)(1:20),'(f20.0)',iostat=istat) bounval - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - if((massflowrate).and.(iaxial.ne.0)) bounval=bounval/iaxial -! -! dummy temperature consisting of the first primes -! - if(user) bounval=1.2357111317d0 -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - if((l.gt.nk).or.(l.le.0)) then - write(*,*) '*ERROR in boundaries:' - write(*,*) ' node ',l,' is not defined' - stop - endif - ktrue=l - if(lc.ne.1) l=l+nk - call bounadd(l,ibounstart,ibounend,bounval, - & nodeboun,ndirboun,xboun,nboun,nboun_, - & iamboun,iamplitude,nam,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, - & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vold,ktrue,mi) - else - read(textpart(1)(1:80),'(a80)',iostat=istat) noset - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - do i=1,nset - if(set(i).eq.noset) exit - enddo - if(i.gt.nset) then - noset(ipos:ipos)=' ' - write(*,*) '*ERROR in boundaries: node set ',noset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - k=ialset(j) - ktrue=k - if(lc.ne.1) k=k+nk - call bounadd(k,ibounstart,ibounend,bounval, - & nodeboun,ndirboun,xboun,nboun,nboun_, - & iamboun,iamplitude,nam,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, - & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vold,ktrue,mi) - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - ktrue=k - if(lc.ne.1) k=k+nk - call bounadd(k,ibounstart,ibounend,bounval, - & nodeboun,ndirboun,xboun,nboun,nboun_, - & iamboun,iamplitude,nam,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, - & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_, - & labmpc,type,typeboun,nmethod,iperturb,fixed, - & vold,ktrue,mi) - enddo - endif - enddo - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/bounrem.f calculix-ccx-2.3/ccx_2.1/src/bounrem.f --- calculix-ccx-2.1/ccx_2.1/src/bounrem.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/bounrem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine bounrem(node,is,ie,nodeboun,ndirboun,xboun, - & nboun,iamboun,nam,ikboun,ilboun,typeboun) -! -! removes boundary conditions in directions is up to and including -! ie in node "node" in the data base; no transformation is allowed -! in the node -! - implicit none -! - character*1 typeboun(*) -! - integer nodeboun(*),ndirboun(*),node,is,ie,nboun,i,j, - & iamboun(*),nam,ikboun(*),ilboun(*),idof,id,iboun -! - real*8 xboun(*) -! - do i=is,ie - idof=8*(node-1)+i - call nident(ikboun,idof,nboun,id) - if(id.gt.0) then - if(ikboun(id).eq.idof) then - iboun=ilboun(id) - do j=iboun,nboun-1 - nodeboun(j)=nodeboun(j+1) - ndirboun(j)=ndirboun(j+1) - xboun(j)=xboun(j+1) - typeboun(j)=typeboun(j+1) - if(nam.gt.0) iamboun(j)=iamboun(j+1) - enddo - do j=id,nboun-1 - ikboun(j)=ikboun(j+1) - ilboun(j)=ilboun(j+1) - enddo - do j=1,nboun-1 - if(ilboun(j).ge.iboun) then - ilboun(j)=ilboun(j)-1 - endif - enddo - nboun=nboun-1 - else - write(*,*) '*ERROR in bounrem: the boundary condition' - write(*,*) ' cannot be removed since it has' - write(*,*) ' not been defined' - stop - endif - else - write(*,*) '*ERROR in bounrem: the boundary condition' - write(*,*) ' cannot be removed since it has' - write(*,*) ' not been defined' - stop - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/buckles.f calculix-ccx-2.3/ccx_2.1/src/buckles.f --- calculix-ccx-2.1/ccx_2.1/src/buckles.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/buckles.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,158 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine buckles(inpc,textpart,nmethod,mei,fei, - & nforc,nload,ithermal,iprestr,nbody,t0,t1,nk,iperturb, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,isolver,ipoinpc) -! -! reading the input deck: *BUCKLE -! - implicit none -! - character*1 inpc(*) - character*20 solver - character*132 textpart(16) -! - integer nmethod,mei(4),istep,istat,n,key,ncv,mxiter, - & nforc,nload,ithermal,iprestr,i,nk,iperturb(2),iline,ipol,inl, - & ipoinp(2,*),inp(3,*),nev,isolver,nbody,ipoinpc(0:*) -! - real*8 fei(3),t0(*),t1(*),tol -! - if(istep.lt.1) then - write(*,*) '*ERROR in buckles: *BUCKLE can only be used' - write(*,*) ' within a STEP' - stop - endif -! -! no heat transfer analysis -! - if(ithermal.gt.1) then - ithermal=1 - endif -! -! default solver -! - if(isolver.eq.0) then - solver(1:7)='SPOOLES' - elseif(isolver.eq.2) then - solver(1:16)='ITERATIVESCALING' - elseif(isolver.eq.3) then - solver(1:17)='ITERATIVECHOLESKY' - elseif(isolver.eq.4) then - solver(1:3)='SGI' - elseif(isolver.eq.5) then - solver(1:5)='TAUCS' - elseif(isolver.eq.7) then - solver(1:7)='PARDISO' - endif -! - do i=2,n - if(textpart(i)(1:7).eq.'SOLVER=') then - read(textpart(i)(8:27),'(a20)') solver - endif - enddo -! - if(solver(1:7).eq.'SPOOLES') then - isolver=0 - elseif(solver(1:16).eq.'ITERATIVESCALING') then - write(*,*) '*WARNING in frequencies: the iterative scaling' - write(*,*) ' procedure is not available for buckling' - write(*,*) ' calculations; the default solver is used' - elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then - write(*,*) '*WARNING in frequencies: the iterative scaling' - write(*,*) ' procedure is not available for buckling' - write(*,*) ' calculations; the default solver is used' - elseif(solver(1:3).eq.'SGI') then - isolver=4 - elseif(solver(1:5).eq.'TAUCS') then - isolver=5 - elseif(solver(1:7).eq.'PARDISO') then - isolver=7 - else - write(*,*) '*WARNING in buckles: unknown solver;' - write(*,*) ' the default solver is used' - endif -! - if((isolver.eq.2).or.(isolver.eq.3)) then - write(*,*) '*ERROR in buckles: the default solver ', - & solver - write(*,*) ' cannot be used for buckling calculations ' - stop - endif -! - nmethod=3 - if(iperturb(1).gt.1) iperturb(1)=0 - iperturb(2)=0 -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*) '*ERROR in buckles: definition not complete' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - read(textpart(1)(1:10),'(i10)',iostat=istat) nev - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(nev.le.0) then - write(*,*) '*ERROR in buckles: less than 1 eigenvalue re - &quested' - stop - endif - read(textpart(2)(1:20),'(f20.0)',iostat=istat) tol - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(tol.le.0.) then - tol=1.d-2 - endif - read(textpart(3)(1:10),'(i10)',iostat=istat) ncv - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(ncv.le.0) then - ncv=4*nev - endif - ncv=ncv+nev - read(textpart(4)(1:10),'(i10)',iostat=istat) mxiter - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(mxiter.le.0) then - mxiter=1000 - endif -! -! removing the natural boundary conditions -! - nforc=0 - nload=0 - nbody=0 - iprestr=0 - if(ithermal.eq.1) then - do i=1,nk - t1(i)=t0(i) - enddo - endif -! - mei(1)=nev - mei(2)=ncv - mei(3)=mxiter - fei(1)=tol -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/BUGS calculix-ccx-2.3/ccx_2.1/src/BUGS --- calculix-ccx-2.1/ccx_2.1/src/BUGS 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/BUGS 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -==== -BUGS Version 2.1 -==== - -- Ogden material with 2 or 3 equal eigenvalues does not work - properly diff -Nru calculix-ccx-2.1/ccx_2.1/src/calcresidual.c calculix-ccx-2.3/ccx_2.1/src/calcresidual.c --- calculix-ccx-2.1/ccx_2.1/src/calcresidual.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/calcresidual.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,121 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif - - -void calcresidual(int *nmethod, int *neq, double *b, double *fext, double *f, - int *iexpl, int *nactdof, double *aux1, double *aux2, double *vold, - double *vini, double *dtime, double *accold, int *nk, double *adb, - double *aub, int *icol, int *irow, int *nzl, double *alpha, - double *fextini, double *fini, int *islavnode, int *nslavnode, - int *imastnode, int *nmastnode, int *mortar, int *ntie,double *f_cm, - double* f_cs, int *mi){ - - int j,k,nodes,nodem,i,mt=mi[1]+1; - double scal1; - - /* residual for a static analysis */ - - if(*nmethod!=4){ - for(k=0;k0: input error) -! - logical boun_flag,cload_flag,dload_flag,temp_flag,elprint_flag, - & nodeprint_flag,elfile_flag,nodefile_flag,contactfile_flag, - & dflux_flag,cflux_flag,film_flag,radiate_flag,out3d, - & solid,network,faceprint_flag,contactprint_flag -! - character*1 typeboun(*),inpc(*) - character*3 output - character*87 filab(*) - character*6 prlab(*) - character*8 lakon(*) - character*20 labmpc(*),sideload(*) - character*80 matname(*),orname(*),amname(*) - character*81 set(*),prset(*),tieset(3,*),cbody(*) - character*132 jobnamec(*),textpart(16) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & nodeforc(2,*),ndirforc(*),nelemload(2,*),iaxial,j, - & istartset(*),iendset(*),ialset(*),ipkon(*),ics(*), - & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), - & namta(3,*),iamforc(*),iamload(2,*),iamt1(*),ipoinpc(0:*), - & iamboun(*),inotr(2,*),ikboun(*),ilboun(*),ikmpc(*),ilmpc(*), - & iponor(2,*),knor(*),ikforc(*),ilforc(*),iponoel(*),inoel(3,*), - & infree(4),ixfree,ikfree,inoelfree,iponoelmax,rig(*),nshcon(*), - & ncocon(2,*),nodebounold(*),ielprop(*),nprop,nprop_,maxsectors, - & ndirbounold(*),nnn(*),nline,ipoinp(2,*),inp(3,*), - & ianisoplas,cfd,ifile_output -! - integer nalset,nalset_,nmat,nmat_,ntmat_,norien,norien_, - & nmethod,nk,ne,nboun,nmpc,nmpc_,mpcfree,i,istat,n, - & key,nk_,ne_,nboun_,ncs_,namtot_,nstate_,iviewfile, - & isolver,ithermal(2),iperturb(*),iprestr,istep,mei(4),nkon, - & nprint,nload,nload_,nforc,nforc_,nlabel,iumat, - & nset,nset_,nprint_,nam,nam_,jout(2),ncmat_,itpamp, - & ierror,idrct,jmax(2),iexpl,iplas,npmat_,mi(2),ntrans,ntrans_, - & M_or_SPC,nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),nflow, - & memmpc_,ne1d,ne2d,nener,irstrt,ii,maxlenmpc,inl,ipol, - & iline,mcs,ntie,ntie_,lprev,newstep,nbody,nbody_,ibody(3,*) -! - real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),fmpc(*), - & xload(2,*),alzero(*),offset(2,*),prop(*), - & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*), - & alcon(0:6,ntmat_,*),thicke(2,*),thickn(2,*),xnor(*), - & t1(*),orab(7,*),prestr(6,mi(1),*),amta(2,*), - & veold(0:mi(2),*),t0(*),plicon(0:2*npmat_,ntmat_,*), - & plkcon(0:2*npmat_,ntmat_,*),trab(7,*),dcs(*), - & shcon(0:3,ntmat_,*),cocon(0:6,ntmat_,*), - & ctrl(*),vold(0:mi(2),*),xbounold(*),xforcold(*), - & xloadold(*),t1old(*),eme(*),sti(*),ener(*), - & xstate(nstate_,mi(1),*),ttime,qaold(2),cs(17,*),tietol(*), - & xbody(7,*),xbodyold(7,*) -! - real*8 fei(3),tinc,tper,xmodal(*),tmin,tmax, - & alpha,physcon(*) -! - save iaxial,solid,ianisoplas,network,out3d -! - integer nentries - parameter(nentries=14) -! - newstep=0 - iviewfile=0 -! - maxsectors=1 - if(mcs.ne.0) then - do i=1,mcs - maxsectors=max(maxsectors,int(cs(1,i))) - enddo - endif -! - do i=1,nentries - if(ipoinp(1,i).ne.0) then - ipol=i - inl=ipoinp(1,i) - iline=inp(1,inl)-1 - exit - endif - enddo -! - ixfree=infree(1) - ikfree=infree(2) - inoelfree=infree(3) - iponoelmax=infree(4) -! - iexpl=0 -! -! the following flag is used to check whether any SPC's or MPC's -! are used before transformation definitions -! - M_or_SPC=0 -! -! the flags indicate whether some specific keyword cards already -! occurred (needed to determine the effect of OP=NEW or to check -! whether the element or nodal output selection should be reset) -! - boun_flag=.false. - cload_flag=.false. - dload_flag=.false. - temp_flag=.false. - elprint_flag=.false. - nodeprint_flag=.false. - faceprint_flag=.false. - contactprint_flag=.false. - contactfile_flag=.false. - elfile_flag=.false. - nodefile_flag=.false. - film_flag=.false. - dflux_flag=.false. - radiate_flag=.false. - cflux_flag=.false. -! - nprint_=nprint -! - nprint=0 -! - if(istep.eq.0) then -! -! initializing the maxima -! - ne_=ne - nset_=nset - nalset_=nalset - nmat_=nmat - norien_=norien - ntrans_=ntrans - ntie_=ntie -! - nmethod=0 -! - ne=0 - nset=0 - nalset=0 - nmat=0 - norien=0 - ntrans=0 - ntie=0 -! - lprev=0 -! - do i=1,ne_ - ipkon(i)=-1 - enddo -! - if((ne1d.gt.0).or.(ne2d.gt.0)) then - do i=1,nlabel - filab(i)=' I ' - enddo - out3d=.false. - else - do i=1,nlabel - filab(i)=' ' - enddo - out3d=.true. - endif -! - iaxial=0 - solid=.false. - network=.false. - ianisoplas=0 -! - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - loop: do -! - if(istat.lt.0) then - write(*,*) - write(*,*) 'Job finished' - write(*,*) - return - endif -! - if(textpart(1)(1:10).eq.'*AMPLITUDE') then - call amplitudes(inpc,textpart,amname,amta,namta,nam, - & nam_,namtot_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, - & inp,ipoinpc) -! - elseif(textpart(1)(1:12).eq.'*BEAMSECTION') then - call beamsections(inpc,textpart,set,istartset,iendset, - & ialset,nset,ielmat,matname,nmat,ielorien,orname,norien, - & thicke,ipkon,iponor,xnor,ixfree, - & offset,lakon,irstrt,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:9).eq.'*BOUNDARY') then - M_or_SPC=1 - call boundaries(inpc,textpart,set,istartset,iendset, - & ialset,nset,nodeboun,ndirboun,xboun,nboun,nboun_,nk, - & iamboun,amname,nam,ipompc,nodempc,coefmpc,nmpc,nmpc_, - & mpcfree,inotr,trab,ntrans,ikboun,ilboun,ikmpc,ilmpc, - & nk_,co,labmpc,boun_flag,typeboun,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,nam_,namtot_,namta,amta,nmethod, - & iperturb,iaxial,ipoinpc,vold,mi) - boun_flag=.true. -! - elseif(textpart(1)(1:7).eq.'*BUCKLE') then - call buckles(inpc,textpart,nmethod,mei,fei, - & nforc,nload,ithermal,iprestr,nbody,t0,t1,nk,iperturb, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,isolver,ipoinpc) -! - elseif(textpart(1)(1:6).eq.'*CFLUX') then - call cfluxes(inpc,textpart,set,istartset,iendset, - & ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, - & amname,nam,ntrans,trab,inotr,co,ikforc,ilforc,nk, - & cflux_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_, - & namtot_,namta,amta,iaxial,ipoinpc) - cflux_flag=.true. - - elseif(textpart(1)(1:6).eq.'*CLOAD') then - call cloads(inpc,textpart,set,istartset,iendset, - & ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_, - & iamforc,amname,nam,ntrans,trab,inotr,co,ikforc,ilforc, - & nk,cload_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & nam_,namtot_,namta,amta,nmethod,iaxial,iperturb,ipoinpc, - & maxsectors) - cload_flag=.true. -! - elseif(textpart(1)(1:13).eq.'*CONDUCTIVITY') then - call conductivities(inpc,textpart,cocon,ncocon, - & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:15).eq.'*CONTACTDAMPING') then - call contactdampings(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - elseif(textpart(1)(1:12).eq.'*CONTACTFILE') then - ifile_output=3 - call noelfiles(inpc,textpart,jout,filab,nmethod, - & nodefile_flag,elfile_flag,ifile_output,nener,ithermal, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,out3d,nlabel, - & amname,nam,itpamp,idrct,ipoinpc,cfd,contactfile_flag, - & set,nset) - contactfile_flag=.true. -! - elseif(textpart(1)(1:12).eq.'*CONTACTPAIR') then - call contactpairs(inpc,textpart,tieset,cs,istep, - & istat,n,iline,ipol,inl,ipoinp,inp,ntie,ntie_, - & iperturb,matname,nmat,ipoinpc,tietol) -! - elseif(textpart(1)(1:13).eq.'*CONTACTPRINT') then - call contactprints(inpc,textpart,nprint,nprint_,jout, - & prlab,prset,contactprint_flag,ithermal,istep,istat,n, - & iline,ipol,inl,ipoinp,inp,amname,nam,itpamp,idrct, - & ipoinpc,nener) - contactprint_flag=.true. -! - elseif(textpart(1)(1:9).eq.'*CONTROLS') then - call controlss(inpc,textpart,ctrl,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:32).eq.'*COUPLEDTEMPERATURE-DISPLACEMENT') - & then - call couptempdisps(inpc,textpart,nmethod,iperturb,isolver, - & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline, - & ipol,inl,ipoinp,inp,ipoinpc,alpha,ctrl,iexpl) -! - elseif(textpart(1)(1:6).eq.'*CREEP') then - call creeps(inpc,textpart,nelcon,nmat,ntmat_,npmat_, - & plicon,nplicon,elcon,iplas,iperturb,nstate_,ncmat_, - & matname,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & ipoinpc,ianisoplas) -! - elseif(textpart(1)(1:16).eq.'*CYCLICHARDENING') then - call cychards(inpc,textpart,nelcon,nmat,ntmat_, - & npmat_,plicon,nplicon,ncmat_,elcon,matname, - & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:20).eq.'*CYCLICSYMMETRYMODEL') then - call cycsymmods(inpc,textpart,set,istartset,iendset, - & ialset,nset,tieset,tietol,co,nk,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,ikmpc,ilmpc,mpcfree,dcs(lprev+1), - & dcs(ncs_+lprev+1),ics(lprev+1),ics(ncs_+lprev+1), - & ics(2*ncs_+lprev+1),dcs(2*ncs_+lprev+1), - & dcs(3*ncs_+lprev+1),ncs_,cs,labmpc,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,ntie,mcs,lprev,ithermal, - & dcs(4*ncs_+1),dcs(6*ncs_+1),dcs(8*ncs_+1),dcs(10*ncs_+1), - & ics(3*ncs_+1),ics(5*ncs_+1),ics(7*ncs_+1),ics(8*ncs_+1), - & dcs(12*ncs_+1),ne,ipkon,kon,lakon,ics(14*ncs_+1), - & ics(15*ncs_+1),ics(16*ncs_+1),ics(18*ncs_+1),ipoinpc, - & maxsectors,trab,ntrans,ntrans_,jobnamec,vold,cfd,mi) -! - elseif(textpart(1)(1:8).eq.'*DASHPOT') then - call dashpots(inpc,textpart,nelcon,nmat,ntmat_,npmat_, - & plicon,nplicon, - & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,nmat_,set,istartset,iendset,ialset, - & nset,ielmat,ielorien,ipoinpc) -! - elseif(textpart(1)(1:22).eq.'*DEFORMATIONPLASTICITY') then - call defplasticities(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb, - & iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:8).eq.'*DENSITY') then - call densities(inpc,textpart,rhcon,nrhcon, - & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:7).eq.'*DEPVAR') then - call depvars(inpc,textpart,nelcon,nmat, - & nstate_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & ncocon,ipoinpc) -! - elseif(textpart(1)(1:6).eq.'*DFLUX') then - call dfluxes(inpc,textpart,set,istartset,iendset, - & ialset,nset,nelemload,sideload,xload,nload,nload_, - & ielmat,ntmat_,iamload,amname,nam,lakon,ne,dflux_flag, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_,namtot_, - & namta,amta,ipoinpc) - dflux_flag=.true. -! - elseif(textpart(1)(1:20).eq.'*DISTRIBUTEDCOUPLING') then - call distrubutedcouplings(inpc,textpart,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,nk,ikmpc,ilmpc, - & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc, - & lakon,kon,ipkon,set,nset,istartset,iendset,ialset,co) -! - elseif(textpart(1)(1:6).eq.'*DLOAD') then - call dloads(inpc,textpart,set,istartset,iendset, - & ialset,nset,nelemload,sideload,xload,nload,nload_, - & ielmat,iamload, - & amname,nam,lakon,ne,dload_flag,istep,istat,n, - & iline,ipol,inl,ipoinp,inp,cbody,ibody,xbody,nbody,nbody_, - & xbodyold,iperturb,physcon,nam_,namtot_,namta,amta,nmethod, - & ipoinpc,maxsectors) - dload_flag=.true. -! - elseif(textpart(1)(1:8).eq.'*DYNAMIC') then - call dynamics(inpc,textpart,nmethod,iperturb,tinc,tper, - & tmin,tmax,idrct,alpha,iexpl,isolver,istep, - & istat,n,iline,ipol,inl,ipoinp,inp,ithermal,ipoinpc,cfd) -! - elseif(textpart(1)(1:8).eq.'*ELASTIC') then - call elastics(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n, - & iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif((textpart(1)(1:8).eq.'*ELEMENT').and. - & (textpart(1)(1:14).ne.'*ELEMENTOUTPUT')) then - call elements(inpc,textpart,kon,ipkon,lakon,nkon, - & ne,ne_,set,istartset,iendset,ialset,nset,nset_,nalset, - & nalset_,mi(1),ixfree,iponor,xnor,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,iaxial,ipoinpc,solid,cfd, - & network) -! - elseif((textpart(1)(1:7).eq.'*ELFILE').or. - & (textpart(1)(1:14).eq.'*ELEMENTOUTPUT')) then - ifile_output=2 - call noelfiles(inpc,textpart,jout,filab,nmethod, - & nodefile_flag,elfile_flag,ifile_output,nener,ithermal, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,out3d,nlabel, - & amname,nam,itpamp,idrct,ipoinpc,cfd,contactfile_flag, - & set,nset) - elfile_flag=.true. -! - elseif(textpart(1)(1:8).eq.'*ELPRINT') then - call elprints(inpc,textpart,set, - & nset,nprint,nprint_,jout, - & prlab,prset,nmethod,elprint_flag,nener,ithermal, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,amname,nam,itpamp, - & idrct,ipoinpc) - elprint_flag=.true. -! - elseif(textpart(1)(1:6).eq.'*ELSET') then - call noelsets(inpc,textpart,set,istartset,iendset,ialset, - & nset,nset_,nalset,nalset_,nk,ne,irstrt,istep,istat,n, - & iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:8).eq.'*ENDSTEP') then - exit -! - elseif(textpart(1)(1:9).eq.'*EQUATION') then - M_or_SPC=1 - call equations(inpc,textpart,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,nk,co,trab,inotr,ntrans,ikmpc,ilmpc, - & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:10).eq.'*EXPANSION') then - call expansions(inpc,textpart,alcon,nalcon, - & alzero,nmat,ntmat_,irstrt,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:10).eq.'*FACEPRINT') then - call faceprints(inpc,textpart,set,istartset,iendset,ialset, - & nset,nset_,nalset,nprint,nprint_,jout, - & prlab,prset,faceprint_flag,ithermal,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,amname,nam,itpamp,idrct,ipoinpc,cfd) - faceprint_flag=.true. -! - elseif(textpart(1)(1:5).eq.'*FILM') then - call films(inpc,textpart,set,istartset,iendset, - & ialset,nset,nelemload,sideload,xload,nload,nload_, - & ielmat,ntmat_,iamload,amname,nam,lakon,ne,film_flag, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_,namtot_, - & namta,amta,ipoinpc) - film_flag=.true. -! - elseif(textpart(1)(1:15).eq.'*FLUIDCONSTANTS') then - call fluidconstants(inpc,textpart,shcon,nshcon, - & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:13).eq.'*FLUIDSECTION') then - call fluidsections(inpc,textpart,set,istartset,iendset, - & ialset,nset,ielmat,matname,nmat, - & irstrt,istep,istat,n, - & iline,ipol,inl,ipoinp,inp,lakon,ielprop,nprop, - & nprop_,prop,iaxial,ipoinpc) -! - elseif(textpart(1)(1:10).eq.'*FREQUENCY') then - call frequencies(inpc,textpart,nmethod, - & mei,fei,iperturb,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,ithermal,isolver,xboun,nboun,ipoinpc) -! - elseif(textpart(1)(1:9).eq.'*FRICTION') then - call frictions(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:4).eq.'*GAP') then - call gaps(inpc,textpart,set,istartset,iendset, - & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc, - & coefmpc,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon, - & ipkon,kon,nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,iperturb,ne_,co,xboun,ctrl,typeboun, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,iamboun,nam, - & inotr,trab,ntrans,nmethod,ipoinpc,mi) -! - elseif(textpart(1)(1:8).eq.'*HEADING') then - call headings(inpc,textpart,istat,n,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:13).eq.'*HEATTRANSFER') then - call heattransfers(inpc,textpart,nmethod,iperturb,isolver, - & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline, - & ipol,inl,ipoinp,inp,alpha,mei,fei,ipoinpc,ctrl,ttime) -! - elseif(textpart(1)(1:13).eq.'*HYPERELASTIC') then - call hyperelastics(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb, - & iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:10).eq.'*HYPERFOAM') then - call hyperfoams(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb,iline, - & ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:18).eq.'*INITIALCONDITIONS') then - call initialconditions(inpc,textpart,set,istartset,iendset, - & ialset,nset,t0,t1,prestr,iprestr,ithermal,veold,inoelfree, - & nk_,mi(1),istep,istat,n,iline,ipol,inl,ipoinp,inp,lakon, - & kon,co,ne,ipkon,vold,ipoinpc,xstate,nstate_) -! - elseif(textpart(1)(1:9).eq.'*MATERIAL') then - call materials(inpc,textpart,matname,nmat,nmat_, - & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:13).eq.'*MODALDAMPING') then - call modaldampings(inpc,textpart,nmethod,xmodal,istep, - & istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:13).eq.'*MODALDYNAMIC') then - call modaldynamics(inpc,textpart,nmethod,tinc,tper,iexpl, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,iperturb, - & isolver,cs,mcs,ipoinpc,idrct,ctrl,tmin,tmax, - & nforc,nload,nbody,iprestr,t0,t1,ithermal,nk,vold,veold, - & xmodal,set,nset,mi) -! - elseif(textpart(1)(1:4).eq.'*MPC') then - call mpcs(inpc,textpart,set,istartset,iendset, - & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc, - & coefmpc,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon, - & ipkon,kon,nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,iperturb,ne_,co,xboun,ctrl,typeboun, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:11).eq.'*NOANALYSIS') then - call noanalysis(inpc,textpart,nmethod,iperturb,istep, - & istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc,tper) -! - elseif(textpart(1)(1:15).eq.'*NODALTHICKNESS') then - call nodalthicknesses(inpc,textpart,set,istartset,iendset, - & ialset,nset,thickn,nk,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,iaxial,ipoinpc) -! - elseif((textpart(1)(1:5).eq.'*NODE').and. - & (textpart(1)(1:10).ne.'*NODEPRINT').and. - & (textpart(1)(1:11).ne.'*NODEOUTPUT').and. - & (textpart(1)(1:9).ne.'*NODEFILE')) then - call nodes(inpc,textpart,co,nk,nk_,set,istartset,iendset, - & ialset,nset,nset_,nalset,nalset_,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,ipoinpc) -! - elseif((textpart(1)(1:9).eq.'*NODEFILE').or. - & (textpart(1)(1:11).eq.'*NODEOUTPUT')) then - ifile_output=1 - call noelfiles(inpc,textpart,jout,filab,nmethod, - & nodefile_flag,elfile_flag,ifile_output,nener,ithermal, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,out3d,nlabel, - & amname,nam,itpamp,idrct,ipoinpc,cfd,contactfile_flag, - & set,nset) - nodefile_flag=.true. -! - elseif(textpart(1)(1:10).eq.'*NODEPRINT') then - call nodeprints(inpc,textpart,set,istartset,iendset,ialset, - & nset,nset_,nalset,nprint,nprint_,jout, - & prlab,prset,nodeprint_flag,ithermal,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,amname,nam,itpamp,idrct,ipoinpc,cfd) - nodeprint_flag=.true. -! - elseif(textpart(1)(1:7).eq.'*NORMAL') then - call normals(inpc,textpart,iponor,xnor,ixfree, - & ipkon,kon,nk,nk_,ne,lakon,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:5).eq.'*NSET') then - call noelsets(inpc,textpart,set,istartset,iendset,ialset, - & nset,nset_,nalset,nalset_,nk,ne,irstrt,istep,istat,n, - & iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:12).eq.'*ORIENTATION') then - call orientations(inpc,textpart,orname,orab,norien, - & norien_,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:18).eq.'*PHYSICALCONSTANTS') then - call physicalconstants(inpc,textpart,physcon, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:8).eq.'*PLASTIC') then - call plastics(inpc,textpart,nelcon,nmat,ntmat_,npmat_, - & plicon,nplicon,plkcon,nplkcon,iplas,iperturb,nstate_, - & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,ipoinpc,ianisoplas) -! - elseif(textpart(1)(1:19).eq.'*PRE-TENSIONSECTION') then - call pretensionsections(inpc,textpart,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,nk,ikmpc,ilmpc, - & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc, - & lakon,kon,ipkon,set,nset,istartset,iendset,ialset,co) -! - elseif(textpart(1)(1:8).eq.'*RADIATE') then - call radiates(inpc,textpart,set,istartset,iendset, - & ialset,nset,nelemload,sideload,xload,nload,nload_, - & ielmat,ntmat_,iamload,amname,nam,lakon,ne,radiate_flag, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,physcon,nam_, - & namtot_,namta,amta,ipoinpc) - radiate_flag=.true. -! - elseif(textpart(1)(1:8).eq.'*RESTART') then - call restarts(istep,nset,nload,nforc, nboun,nk,ne, - & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint, - & mi(1),ntrans,ncs_,namtot_,ncmat_,mpcfree, - & maxlenmpc,ne1d, - & ne2d,nflow,nlabel,iplas,nkon,ithermal,nmethod, - & iperturb,nstate_,nener,set,istartset,iendset,ialset,co, - & kon,ipkon,lakon,nodeboun,ndirboun,iamboun,xboun,ikboun, - & ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, - & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc, - & nelemload,iamload,sideload,xload, - & elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,plicon, - & nplicon,plkcon,nplkcon,orname,orab,ielorien,trab,inotr, - & amname,amta,namta,t0,t1,iamt1,veold,ielmat, - & matname,prlab,prset,filab,vold,nodebounold, - & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, - & iponor,xnor,knor,thickn,thicke,offset,iponoel, - & inoel,rig,shcon,nshcon,cocon, - & ncocon,ics,sti,ener,xstate,jobnamec,infree,nnn, - & irstrt,inpc,textpart,istat,n,key,prestr,iprestr, - & cbody,ibody,xbody,nbody,xbodyold,ttime,qaold, - & cs,mcs,output,physcon,ctrl,typeboun,iline,ipol,inl, - & ipoinp,inp,fmpc,tieset,ntie,ipoinpc) -! - elseif(textpart(1)(1:10).eq.'*RIGIDBODY') then - call rigidbodies(inpc,textpart,set,istartset,iendset, - & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc, - & coefmpc,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon, - & ipkon,kon,nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,iperturb,ne_,ctrl,typeboun, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,co,ipoinpc) -! - elseif(textpart(1)(1:26).eq.'*SELECTCYCLICSYMMETRYMODES') then - call selcycsymmods(inpc,textpart,cs,ics,tieset,istartset, - & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc, - & ilmpc,mpcfree,mcs,set,nset,labmpc,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,nmethod,key,ipoinpc) -! - elseif(textpart(1)(1:13).eq.'*SHELLSECTION') then - call shellsections(inpc,textpart,set,istartset,iendset, - & ialset,nset,ielmat,matname,nmat,ielorien,orname, - & norien,thicke,kon,ipkon,offset,irstrt,istep,istat,n, - & iline,ipol,inl,ipoinp,inp,lakon,iaxial,ipoinpc) -! - elseif(textpart(1)(1:13).eq.'*SOLIDSECTION') then - call solidsections(inpc,textpart,set,istartset,iendset, - & ialset,nset,ielmat,matname,nmat,ielorien,orname, - & norien,lakon,thicke,kon,ipkon,irstrt,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,cs,mcs,iaxial,ipoinpc) -! - elseif(textpart(1)(1:20).eq.'*SPECIFICGASCONSTANT') then - call specificgasconstants(inpc,textpart,shcon,nshcon, - & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:13).eq.'*SPECIFICHEAT') then - call specificheats(inpc,textpart,shcon,nshcon, - & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:7).eq.'*SPRING') then - call springs(inpc,textpart,nelcon,nmat,ntmat_,npmat_, - & plicon,nplicon, - & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,nmat_,set,istartset,iendset,ialset, - & nset,ielmat,ielorien,ipoinpc) -! - elseif(textpart(1)(1:7).eq.'*STATIC') then - call statics(inpc,textpart,nmethod,iperturb,isolver,istep, - & istat,n,tinc,tper,tmin,tmax,idrct,iline,ipol,inl,ipoinp, - & inp,ithermal,cs,ics,tieset,istartset, - & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc, - & ilmpc,mpcfree,mcs,set,nset,labmpc,ipoinpc,iexpl,cfd,ttime, - & iaxial) -! - elseif(textpart(1)(1:20).eq.'*STEADYSTATEDYNAMICS') then - call steadystatedynamics(inpc,textpart,nmethod, - & iexpl,istep,istat,n,iline,ipol,inl,ipoinp,inp,iperturb, - & isolver,xmodal,cs,mcs,ipoinpc,nforc,nload,nbody,iprestr, - & t0,t1,ithermal,nk) -! - elseif(textpart(1)(1:5).eq.'*STEP') then - call steps(inpc,textpart,iperturb,iprestr,nbody,nforc, - & nload,ithermal,t0,t1,nk,irstrt,istep,istat,n, - & jmax,ctrl,iline,ipol,inl,ipoinp,inp,newstep, - & ipoinpc,physcon) -! - elseif(textpart(1)(1:9).eq.'*SURFACE ') then - call surfaces(inpc,textpart,set,istartset,iendset,ialset, - & nset,nset_,nalset,nalset_,nk,ne,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,lakon,ipoinpc) -! - elseif(textpart(1)(1:16).eq.'*SURFACEBEHAVIOR') then - call surfacebehaviors(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:19).eq.'*SURFACEINTERACTION') then - call surfaceinteractions(inpc,textpart,matname,nmat,nmat_, - & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,nrhcon, - & ipoinpc) -! - elseif(textpart(1)(1:12).eq.'*TEMPERATURE') then - call temperatures(inpc,textpart,set,istartset,iendset, - & ialset,nset,t0,t1,nk,ithermal,iamt1,amname,nam, - & inoelfree,nk_,nmethod,temp_flag,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,nam_,namtot_,namta,amta,ipoinpc) - temp_flag=.true. -! - elseif(textpart(1)(1:4).eq.'*TIE') then - call ties(inpc,textpart,tieset,tietol,istep, - & istat,n,iline,ipol,inl,ipoinp,inp,ntie,ntie_,ipoinpc) -! - elseif(textpart(1)(1:11).eq.'*TIMEPOINTS') then - call timepointss(inpc,textpart,amname,amta,namta,nam, - & nam_,namtot_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, - & inp,ipoinpc) -! - elseif(textpart(1)(1:10).eq.'*TRANSFORM') then - if(M_or_SPC.eq.1) then - write(*,*) '*WARNING in calinput: SPCs or MPCs have' - write(*,*) ' been defined before the definition' - write(*,*) ' of a transformation' - endif - call transforms(inpc,textpart,trab,ntrans,ntrans_, - & inotr,set,istartset,iendset,ialset,nset,istep,istat, - & n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:34).eq. - & '*UNCOUPLEDTEMPERATURE-DISPLACEMENT') then - call uncouptempdisps(inpc,textpart,nmethod,iperturb,isolver, - & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline, - & ipol,inl,ipoinp,inp,ipoinpc,alpha,ctrl) -! - elseif(textpart(1)(1:13).eq.'*USERMATERIAL') then - call usermaterials(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,iperturb,iumat,irstrt,istep,istat,n, - & iline,ipol,inl,ipoinp,inp,cocon,ncocon,ipoinpc) -! - elseif(textpart(1)(1:17).eq.'*VALUESATINFINITY') then - call valuesatinf(inpc,textpart,physcon, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! - elseif(textpart(1)(1:11).eq.'*VIEWFACTOR') then - call viewfactors(textpart,iviewfile,istep,inpc, - & istat,n,key,iline,ipol,inl,ipoinp,inp,jobnamec,ipoinpc) -! - elseif(textpart(1)(1:7).eq.'*VISCO') then - call viscos(inpc,textpart,nmethod,iperturb,isolver,istep, - & istat,n,tinc,tper,tmin,tmax,idrct,iline,ipol,inl,ipoinp, - & inp,ipoinpc) -! - elseif(inpc(iline-1).eq.inpc(iline)) then - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - else - write(*,*) '*WARNING in calinput. Card image cannot be inter - &preted:' - call inputwarning(inpc,ipoinpc,iline) - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - endif -! - enddo loop -! -! check whether the *END STEP card was preceded by a *STEP card -! - if(newstep.eq.0) then - write(*,*) '*ERROR in calinput: *END STEP card in step ', - & istep+1 - write(*,*) ' was not preceded by a *STEP card' - endif -! -! reorganizing the input in field inpc -! - j=1 - do - if(j.eq.1) then - inp(1,j)=iline+1 - else -c inp(1,j)=inp(1,inl)-iline - inp(1,j)=inp(1,inl) - endif -c inp(2,j)=inp(2,inl)-iline - inp(2,j)=inp(2,inl) - if(inp(3,inl).eq.0) then - inp(3,j)=0 - ipoinp(2,nentries)=j - exit - else - inl=inp(3,inl) - inp(3,j)=j+1 - j=j+1 - endif - enddo - do j=1,nentries-1 - ipoinp(1,j)=0 - enddo - ipoinp(1,nentries)=1 -c do j=iline+1,nline -c inpc(j-iline)=inpc(j) -c enddo -c nline=nline-iline -c call writeinput(inpc,ipoinp,inp,nline,ipoinp(2,12)) -! -! expanding the 1-D and 2-D elements to volume elements -! treating the incompressibility constraint -! - call gen3delem(kon,ipkon,lakon,ne,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,ikboun,ilboun,nboun, - & nboun_,nodeboun,ndirboun,xboun,iamboun,nam, - & inotr,trab,nk,nk_,iponoel,inoel,iponor,xnor,thicke,thickn, - & knor,istep,offset,t0,t1,ikforc,ilforc,rig,nforc, - & nforc_,nodeforc,ndirforc,xforc,iamforc,nelemload,sideload, - & nload,ithermal,ntrans,co,ixfree,ikfree,inoelfree,iponoelmax, - & iperturb,tinc,tper,tmin,tmax,ctrl,typeboun,nmethod,nset,set, - & istartset,iendset,ialset,prop,ielprop,vold,mi) -! -! New multistage Routine Call -! - call multistages(nkon,set,istartset,iendset, - & ialset,nset,tieset,tietol,co,nk,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,ikmpc,ilmpc,mpcfree,dcs(lprev+1), - & dcs(ncs_+lprev+1),ics(lprev+1),ics(ncs_+lprev+1), - & ics(2*ncs_+lprev+1),dcs(2*ncs_+lprev+1), - & dcs(3*ncs_+lprev+1),ncs_,cs,labmpc,ntie,mcs, - & dcs(4*ncs_+1),dcs(6*ncs_+1),dcs(8*ncs_+1),dcs(10*ncs_+1), - & ics(3*ncs_+1),ics(5*ncs_+1),ics(7*ncs_+1),ics(8*ncs_+1), - & dcs(12*ncs_+1),ne,ipkon,kon,lakon,ics(14*ncs_+1), - & ics(16*ncs_+1),ics(18*ncs_+1)) -! - infree(1)=ixfree - infree(2)=ikfree - infree(3)=inoelfree - infree(4)=iponoelmax -! -! check of the selected options -! - if(((iplas.eq.0).and.(ianisoplas.eq.0)).or.(nmethod.eq.2)) then - if(filab(6)(1:4).eq.'PEEQ') then - write(*,*) '*WARNING in calinput: PEEQ-output requested' - write(*,*) ' yet no (visco)plastic calculation' - filab(6)=' ' - endif - ii=0 - do i=1,nprint - if(prlab(i)(1:4).eq.'PEEQ') then - write(*,*) '*WARNING in calinput: PEEQ-output requested' - write(*,*) ' yet no (visco)plastic calculation' - cycle - endif - ii=ii+1 - prlab(ii)=prlab(i) - prset(ii)=prset(i) - enddo - nprint=ii - endif -! - if(ithermal(1).eq.0) then - if(filab(2)(1:2).eq.'NT') then - write(*,*) '*WARNING in calinput: temperature output' - write(*,*) ' requested, yet no thermal loading' - write(*,*) ' active' - filab(2)=' ' - endif - ii=0 - do i=1,nprint - if(prlab(i)(1:4).eq.'NT ') then - write(*,*) '*WARNING in calinput: temperature output' - write(*,*) ' requested, yet no thermal loading' - write(*,*) ' active' - cycle - endif - ii=ii+1 - prlab(ii)=prlab(i) - prset(ii)=prset(i) - enddo - nprint=ii - endif -! - if(ithermal(1).le.1) then - if(filab(9)(1:3).eq.'HFL') then - write(*,*) '*WARNING in calinput: heat flux output' - write(*,*) ' requested, yet no heat transfer' - write(*,*) ' calculation' - endif - if(filab(10)(1:3).eq.'RFL') then - write(*,*) '*WARNING in calinput: heat source output' - write(*,*) ' requested, yet no heat transfer' - write(*,*) ' calculation' - endif - endif -! -! check whether a material was assigned to each active element -! - ierror=0 - do i=1,ne - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).eq.'G') cycle - if(ielmat(i).eq.0) then - ierror=1 - write(*,*) '*ERROR in calinput: no material was assigned' - write(*,*) ' to element ',i - endif - enddo - if(ierror.eq.1) stop -! -! check whether the density was defined for dynamic calculations -! and transient thermal calculations -! - if(((nbody.gt.0).or. - & (nmethod.eq.2).or.(nmethod.eq.4)).and.(cfd.eq.0)) then - ierror=0 - do i=1,nmat - if((nrhcon(i).ne.0).or.(matname(i)(1:6).eq.'SPRING').or. - & (matname(i)(1:7).eq.'DASHPOT')) then - ierror=ierror+1 - else - write(*,*)'*WARNING in calinput: no density was assigned' - write(*,*) ' to material ', - & matname(i)(1:index(matname(i),' ')-1), - & ' in a dynamic' - write(*,*) ' calculation or a calculation with' - write(*,*) ' centrifugal or gravitational loads' - endif - enddo - if(ierror.eq.0) then - write(*,*) '*ERROR in calinput: no density was assigned' - write(*,*) ' to any material ', - & ' in a dynamic' - write(*,*) ' calculation or a calculation with' - write(*,*) ' centrifugal or gravitational loads' - stop - endif - endif -! -! check whether the specific heat was defined for -! transient thermal calculations -! - if((nmethod.eq.2).or.(nmethod.eq.4)) then - if(ithermal(1).ge.2) then - ierror=0 - do i=1,nmat - if(nshcon(i).ne.0) then - ierror=ierror+1 - else - write(*,*) '*WARNING in calinput: no specific heat ' - write(*,*) ' was assigned to material ', - & matname(i)(1:index(matname(i),' ')-1), - & ' in a transient' - write(*,*) ' heat transfer calculation' - write(*,*) - endif - enddo - if(ierror.eq.0) then - write(*,*) '*ERROR in calinput: no specific heat was' - write(*,*) ' assigned to any material ', - & ' in a transient' - write(*,*) ' heat transfer calculation' - stop - endif - endif - endif -! -! check whether a *FLUID CONSTANTS card was used for -! 3D compressible fluid calculations -! -c if((cfd).and.((iexpl.eq.1).or.(iexpl.eq.3))) then - if((cfd.eq.1).or.network) then - ierror=0 - do i=1,nmat - if(nshcon(i).ne.0) then - ierror=ierror+1 - else - write(*,*) '*WARNING in calinput: no specific heat ' - write(*,*) ' was assigned to material ', - & matname(i)(1:index(matname(i),' ')-1), - & ' in a transient' - write(*,*) ' heat transfer calculation' - write(*,*) - endif - enddo - if(ierror.eq.0) then - write(*,*) '*ERROR in calinput: no specific heat was' - write(*,*) ' assigned to any material ', - & ' in a transient' - write(*,*) ' heat transfer calculation' - stop - endif - endif -! -! check whether the elastic constants were defined for -! mechanical calculations -! - if((ithermal(1).ne.2).and.solid) then - ierror=0 - do i=1,nmat - if(nelcon(1,i).ne.0) then - ierror=ierror+1 - else - write(*,*)'*WARNING in calinput: no elastic constants ' - write(*,*)' were assigned to material ', - & matname(i)(1:index(matname(i),' ')-1) - write(*,*) ' in a (thermo)mechanical calculation' - write(*,*) - endif - enddo - if(ierror.eq.0) then - write(*,*) '*ERROR in calinput: no elastic constants' - write(*,*) ' were assigned to any material in a' - write(*,*) ' (thermo)mechanical calculation' - stop - endif - endif -! -! check whether the conductivity was defined for thermal calculations -! - if((ithermal(1).ge.2).and.(cfd.eq.0)) then - ierror=0 - do i=1,nmat - if(ncocon(1,i).ne.0) then - ierror=ierror+1 - else - write(*,*) '*WARNING in calinput: no conductivity ' - write(*,*) - & ' constants were assigned to material ', - & matname(i)(1:index(matname(i),' ')-1) - write(*,*) ' in a thermo(mechanical) calculation' - write(*,*) - endif - enddo - endif -! -! check whether the conductivity was defined for 3D compressible -! fluid calculations or 3D incompressible thermal fluid calculations -! -c if(((ithermal(1).ge.1).and.(fluid).and. -c & ((iexpl.eq.0).or.(iexpl.eq.2))).or. -c & ((fluid).and.((iexpl.eq.1).or.(iexpl.eq.3)))) then -c ierror=0 -c do i=1,nmat -c if(ncocon(1,i).ne.0) then -c ierror=ierror+1 -c else -c write(*,*) '*WARNING in calinput: no conductivity ' -c write(*,*) -c & ' constants were assigned to material ', -c & matname(i)(1:index(matname(i),' ')-1) -c write(*,*) ' in a thermo(mechanical) calculation' -c write(*,*) -c endif -c enddo -c if(ierror.eq.0) then -c write(*,*) '*ERROR in calinput: no conductivity constants' -c write(*,*) ' were assigned to any material in a' -c write(*,*) ' thermal fluid calculation' -c stop -c endif -c endif -! - if(cfd.eq.1) then - if(iperturb(1).eq.0) then - iperturb(1)=2 - elseif(iperturb(1).eq.1) then - write(*,*) '*ERROR in calinput: PERTURBATION and fluids' - write(*,*) ' are mutually exclusive; ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! -! copying the initial conditions into vold; for ithermal(1)>1 -! the thermal conditions are copied in CalculiX.c -! -cc if(istep.eq.1) then -cc if(ithermal(1).eq.1) then -cc do i=1,nk -cc vold(0,i)=t0(i) -cc enddo -cc endif -c do i=1,nk -c do j=1,3 -c vold(j,i)=veold(j,i) -c enddo -c enddo -cc endif - endif -! - write(*,*) - write(*,*) 'STEP ',istep - write(*,*) - if(nmethod.eq.0) then - write(*,*) 'No analysis was selected' - elseif(nmethod.eq.1) then - write(*,*) 'Static analysis was selected' - elseif(nmethod.eq.2) then - write(*,*) 'Frequency analysis was selected' - elseif(nmethod.eq.3) then - write(*,*) 'Buckling analysis was selected' - elseif(nmethod.eq.4) then - write(*,*) 'Linear dynamic analysis was selected' - endif - write(*,*) - if(iperturb(1).eq.1) then - write(*,*) 'Perturbation parameter is active' - write(*,*) - elseif(iperturb(1).eq.2) then - write(*,*) 'Nonlinear geometric effects are taken into account' - write(*,*) - elseif(iperturb(1).eq.3) then - write(*,*) 'Nonlinear geometric effects and nonlinear ' - write(*,*) 'material laws are taken into account' - write(*,*) - endif -! -c write(*,*) 'spc' -c do i=1,nboun -c write(*,'(4i7,1x,e11.4)') -c & i,nodeboun(i),ndirboun(i),iamboun(i),xboun(i) -c enddo -c write(*,*) 'cload' -c do i=1,nforc -c write(*,'(4i7,1x,e11.4)') -c & i,nodeforc(1,i),ndirforc(i),iamforc(i),xforc(i) -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/carbon_seal.f calculix-ccx-2.3/ccx_2.1/src/carbon_seal.f --- calculix-ccx-2.1/ccx_2.1/src/carbon_seal.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/carbon_seal.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,192 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine carbon_seal(node1,node2,nodem,nelem,lakon, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,R,physcon,dvi,numf,set,mi) -! -! carbon seal element calculated with Richter method -! Richter "Rohrhydraulik", Springer ,1971,p. 175 -! - implicit none -! - logical identity - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, - & ielprop(*),nodef(4),idirf(4),index,iflag, - & inv,mi(2) -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),R,d,l, - & p1,p2,T1,physcon(*),dvi,pi,s,T2 -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif (iflag.eq.1)then -! - index=ielprop(nelem) - d=prop(index+1) - s=prop(index+2) - l=prop(index+3) - pi=4.d0*datan(1.d0) -! - p1=v(2,node1) - p2=v(2,node2) - if(p1.ge.p2) then - inv=1 - T1=v(0,node1)+physcon(1) - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - T1=v(0,node2)+physcon(1) - endif -! - if(lakon(nelem)(2:6).eq.'CARBS') then -! -! gapflow -! Richter "Rohrhydraulik", Springer ,1971,p. 175 -! - xflow=inv*Pi*d*s**3*(P1**2-P2**2)/(24.d0*R*T1*dvi*l) - - elseif(lakon(nelem)(2:6).ne.'CARBS') then - write(*,*) '*WARNING in Carbon_seal.f' - write(*,*) 'unable to perform carbon seal calculation' - write(*,*) 'check input file' - endif -! - elseif (iflag.eq.2)then -! - numf=4 - p1=v(2,node1) - p2=v(2,node2) - if(p1.ge.p2) then - inv=1 - xflow=v(1,nodem) - T1=v(0,node1)+physcon(1) - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - xflow=-v(1,nodem) - T1=v(0,node2)+physcon(1) - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 -! - index=ielprop(nelem) - d=prop(index+1) - s=prop(index+2) - l=prop(index+3) - pi=4.d0*datan(1.d0) - -! - if (lakon(nelem)(2:8).eq.'CARBS') then -! - f=xflow*T1-pi*d*s**3*(P1**2-P2**2)/(24.d0*R*dvi*l) -! - df(1)=-(pi*d*s**3*P1)/(12.d0*R*dvi*l) - df(2)=xflow - df(3)=T1 - df(4)=(pi*d*s**3*P2)/(12.d0*R*dvi*l) -! - endif - - elseif(iflag.eq.3) then - p1=v(2,node1) - p2=v(2,node2) - if(p1.ge.p2) then - inv=1 - xflow=v(1,nodem) - T1=v(0,node1)+physcon(1) - T2=v(0,node2)+physcon(1) - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - xflow=-v(1,nodem) - T1=v(0,node2)+physcon(1) - T2=v(0,node1)+physcon(1) - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif - - write(1,*) '' - write(1,55) 'In line',int(nodem/100),' from node',node1, - &' to node', node2,': air massflow rate=',xflow,'kg/s' -! &,', oil massflow rate=',xflow_oil,'kg/s' - 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) - - if(inv.eq.1) then - write(1,56)' Inlet node ',node1,': Tt1=',T1, - & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' - - write(1,*)' element G ',set(numf)(1:20) - - write(1,56)' Outlet node ',node2,': Tt2=',T2, - & 'K, Ts2=',T2,'K, Pt2=',P2/1e5,'Bar' -! - else if(inv.eq.-1) then - write(1,56)' Inlet node ',node2,': Tt1=',T1, - & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' - & - write(1,*)' element G ',set(numf)(1:20) - - write(1,56)' Outlet node ',node1,': Tt2=',T2, - & 'K, Ts2=',T2,'K, Pt2=',P2/1e5, 'Bar' - - endif - - 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A) - - - - - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/cascade.c calculix-ccx-2.3/ccx_2.1/src/cascade.c --- calculix-ccx-2.1/ccx_2.1/src/cascade.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cascade.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,725 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include - -#ifdef SPOOLES -#include -#include -#include -#endif - -#include "CalculiX.h" - -#define min(a,b) ((a) <= (b) ? (a) : (b)) -#define max(a,b) ((a) >= (b) ? (a) : (b)) - -void cascade(int *ipompc, double **coefmpcp, int **nodempcp, int *nmpc, - int *mpcfree, int *nodeboun, int *ndirboun, int*nboun, int*ikmpc, - int *ilmpc, int *ikboun, int *ilboun, int *mpcend, int *mpcmult, - char *labmpc, int *nk, int *memmpc_, int *icascade, int *maxlenmpc, - int *callfrommain, int *iperturb, int *ithermal){ - - /* detects cascaded mpc's and decascades them; checks multiple - occurrence of the same dependent DOF's in different mpc/spc's - - data structure of ipompc,coefmpc,nodempc: - for each mpc, e.g. i, - -the nodes are stored in nodempc(1,ipompc(i)), - nodempc(1,nodempc(3,ipompc(i))), - nodempc(1,nodempc(3,nodempc(3,ipompc(i))))... till - nodempc(3,nodempc(3,nodempc(3,.......))))))=0; - -the corresponding directions in nodempc(2,ipompc(i)), - nodempc(2,nodempc(3,ipompc(i))),..... - -the corresponding coefficient in coefmpc(ipompc(i)), - coefmpc(nodempc(3,ipompc(i))),..... - the mpc is written as a(1)u(i1,j1)+a(2)u(i2,j2)+... - +....a(k)u(ik,jk)=0, the first term is the dependent term, - the others are independent, at least after execution of the - present routine. The mpc's must be homogeneous, otherwise a - error message is generated and the program stops. */ - - int i,j,index,id,idof,nterm,idepend,*nodempc=NULL, - ispooles,iexpand,ichange,indexold, - mpc,indexnew,index1,index2,index1old,index2old,*jmpc=NULL,nl; - - double coef,*coefmpc=NULL; - -#ifdef SPOOLES - - int irow,icolumn,node,idir,irownl,icolnl,*ipointer=NULL,*icoef=NULL, - ifree,*indepdof=NULL,nindep; - - double *xcoef=NULL,b; - - DenseMtx *mtxB, *mtxX ; - Chv *rootchv ; - ChvManager *chvmanager ; - SubMtxManager *mtxmanager ; - FrontMtx *frontmtx ; - InpMtx *mtxA ; - double tau = 100.; - double cpus[10] ; - ETree *frontETree ; - FILE *msgFile ; - Graph *graph ; - int jrhs, msglvl=0, nedges,error, - nent, neqns, nrhs, pivotingflag=1, seed=389, - symmetryflag=2, type=1,maxdomainsize,maxzeros,maxsize; - int *oldToNew ; - int stats[20] ; - IV *newToOldIV, *oldToNewIV ; - IVL *adjIVL, *symbfacIVL ; -#endif - - nodempc=*nodempcp; - coefmpc=*coefmpcp; - - /* for(i=0;i<*nmpc;i++){ - j=i+1; - FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); - }*/ - - jmpc=NNEW(int,*nmpc); - idepend=0; - -/* check whether a node is used as a dependent node in a MPC - and in a SPC */ - - for(i=0;i<*nmpc;i++){ - if(*nboun>0){ - FORTRAN(nident,(ikboun,&ikmpc[i],nboun,&id));} - else{id=0;} - if(id>0){ - if(ikboun[id-1]==ikmpc[i]){ - printf("*ERROR in cascade: the DOF corresponding to \n node %d in direction %d is detected on the \n dependent side of a MPC and a SPC\n", - (ikmpc[i])/8+1,ikmpc[i]-8*((ikmpc[i])/8)); - FORTRAN(stop,()); - } - } - } - -/* check whether there are user mpc's: in user MPC's the - dependent DOF can change, however, the number of terms - cannot change */ - - for(i=0;i<*nmpc;i++){ - - /* linear mpc */ - - /* because of the next line the size of field labmpc - has to be defined as 20*nmpc+1: without "+1" an - undefined field is accessed */ - - if((strcmp1(&labmpc[20*i]," ")==0) || - (strcmp1(&labmpc[20*i],"CYCLIC")==0) || -/* ((strcmp1(&labmpc[20*i],"CYCLIC")==0)&&(*ithermal==2)) ||*/ - (strcmp1(&labmpc[20*i],"SUBCYCLIC")==0)|| - (strcmp1(&labmpc[20*i],"CONTACT")==0)|| - (*iperturb<2)) jmpc[i]=0; - - /* nonlinear mpc */ - - else if((strcmp1(&labmpc[20*i],"RIGID")==0) || - (strcmp1(&labmpc[20*i],"KNOT")==0) || -/* ((strcmp1(&labmpc[20*i],"CYCLIC")==0)&&(*ithermal!=2)) ||*/ - (strcmp1(&labmpc[20*i],"PLANE")==0) || - (strcmp1(&labmpc[20*i],"STRAIGHT")==0)|| - (strcmp1(&labmpc[20*i],"ISOCHORIC")==0)) jmpc[i]=1; - - /* user mpc */ - - else{ - jmpc[i]=1; - if(*icascade==0) *icascade=1; - } - } - -/* decascading */ - - ispooles=0; - - /* decascading using simple substitution */ - - do{ - ichange=0; - for(i=0;i<*nmpc;i++){ - if(jmpc[i]==1) nl=1; - else nl=0; - iexpand=0; - index=nodempc[3*ipompc[i]-1]; - if(index==0) continue; - do{ - idof=(nodempc[3*index-3]-1)*8+nodempc[3*index-2]; - FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); - if((id>0)&&(ikmpc[id-1]==idof)){ - - /* a term on the independent side of the MPC is - detected as dependent node in another MPC */ - - indexold=nodempc[3*index-1]; - coef=coefmpc[index-1]; - mpc=ilmpc[id-1]; - - /* no expansion of there is a dependence of a - nonlinear MPC on another linear or nonlinear MPC - and the call is from main */ - - if((jmpc[mpc-1]==1)||(nl==1)){ - *icascade=2; - if(idepend==0){ - printf("*INFO in cascade: linear MPCs and\n"); - printf(" nonlinear MPCs depend on each other\n"); - printf(" common node: %d in direction %d\n\n",nodempc[3*index-3],nodempc[3*index-2]); - idepend=1;} - if(*callfrommain==1){ - index=nodempc[3*index-1]; - if(index!=0) continue; - else break;} - } - -/* printf("*INFO in cascade: DOF %d of node %d is expanded\n", - nodempc[3*index-2],nodempc[3*index-3]);*/ - - /* collecting terms corresponding to the same DOF */ - - index1=ipompc[i]; - do{ - index2old=index1; - index2=nodempc[3*index1-1]; - if(index2==0) break; - do{ - if((nodempc[3*index1-3]==nodempc[3*index2-3])&& - (nodempc[3*index1-2]==nodempc[3*index2-2])){ - coefmpc[index1-1]+=coefmpc[index2-1]; - nodempc[3*index2old-1]=nodempc[3*index2-1]; - nodempc[3*index2-1]=*mpcfree; - *mpcfree=index2; - index2=nodempc[3*index2old-1]; - if(index2==0) break; - } - else{ - index2old=index2; - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - }while(1); - index1=nodempc[3*index1-1]; - if(index1==0) break; - }while(1); - - /* check for zero coefficients on the dependent side */ - - index1=ipompc[i]; - /* index1old=0; - do {*/ - if(fabs(coefmpc[index1-1])<1.e-10){ - /* if(index1old==0){*/ - printf("*ERROR in cascade: zero coefficient on the\n"); - printf(" dependent side of an equation\n"); - printf(" dependent node: %d",nodempc[3*index1-3]); - FORTRAN(stop,()); - } - /* else{ - nodempc[3*index1old-1]=nodempc[3*index1-1]; - nodempc[3*index1-1]=*mpcfree; - *mpcfree=index1; - index1=nodempc[3*index1old-1]; - } - } - else{ - index1old=index1; - index1=nodempc[3*index1-1]; - } - if(index1==0) break; - }while(1);*/ - - ichange=1;iexpand=1; - if((strcmp1(&labmpc[20*i]," ")==0)&& - (strcmp1(&labmpc[20*(mpc-1)],"CYCLIC")==0)) - strcpy1(&labmpc[20*i],"SUBCYCLIC",9); - indexnew=ipompc[mpc-1]; - coef=-coef/coefmpc[indexnew-1]; - indexnew=nodempc[3*indexnew-1]; - do{ - coefmpc[index-1]=coef*coefmpc[indexnew-1]; - nodempc[3*index-3]=nodempc[3*indexnew-3]; - nodempc[3*index-2]=nodempc[3*indexnew-2]; - indexnew=nodempc[3*indexnew-1]; - if(indexnew!=0){ - nodempc[3*index-1]=*mpcfree; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in cascade: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(j=*mpcfree;j<*memmpc_;j++){ - nodempc[3*j-1]=j+1; - } - nodempc[3**memmpc_-1]=0; - } - continue; - } - else{ - nodempc[3*index-1]=indexold; - break; - } - }while(1); - break; - } - else{ - index=nodempc[3*index-1]; - if(index!=0) continue; - else break; - } - }while(1); - if(iexpand==0) continue; - - /* one term of the mpc was expanded - collecting terms corresponding to the same DOF */ - - index1=ipompc[i]; - do{ - index2old=index1; - index2=nodempc[3*index1-1]; - if(index2==0) break; - do{ - if((nodempc[3*index1-3]==nodempc[3*index2-3])&& - (nodempc[3*index1-2]==nodempc[3*index2-2])){ - coefmpc[index1-1]+=coefmpc[index2-1]; - nodempc[3*index2old-1]=nodempc[3*index2-1]; - nodempc[3*index2-1]=*mpcfree; - *mpcfree=index2; - index2=nodempc[3*index2old-1]; - if(index2==0) break; - } - else{ - index2old=index2; - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - }while(1); - index1=nodempc[3*index1-1]; - if(index1==0) break; - }while(1); - - /* check for zero coefficients on the dependent and - independent side */ - - index1=ipompc[i]; - index1old=0; - do { - if(fabs(coefmpc[index1-1])<1.e-10){ - if(index1old==0){ - printf("*ERROR in cascade: zero coefficient on the\n"); - printf(" dependent side of an equation\n"); - printf(" dependent node: %d",nodempc[3*index1-3]); - FORTRAN(stop,()); - } - else{ - nodempc[3*index1old-1]=nodempc[3*index1-1]; - nodempc[3*index1-1]=*mpcfree; - *mpcfree=index1; - index1=nodempc[3*index1old-1]; - } - } - else{ - index1old=index1; - index1=nodempc[3*index1-1]; - } - if(index1==0) break; - }while(1); - } - if(ichange==0) break; - }while(1); - - /* decascading using spooles */ - -#ifdef SPOOLES - if((*icascade==1)&&(ispooles==1)){ - if ( (msgFile = fopen("spooles.out", "a")) == NULL ) { - fprintf(stderr, "\n fatal error in spooles.c" - "\n unable to open file spooles.out\n") ; - } - ipointer=NNEW(int,7**nk); - indepdof=NNEW(int,7**nk); - icoef=NNEW(int,2**memmpc_); - xcoef=NNEW(double,*memmpc_); - ifree=0; - nindep=0; - - for(i=*nmpc-1;i>-1;i--){ - index=ipompc[i]; - while(1){ - idof=8*(nodempc[3*index-3]-1)+nodempc[3*index-2]-1; - -/* check whether idof is a independent dof which has not yet been - stored in indepdof */ - - FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); - if((id==0)||(ikmpc[id-1]!=idof)){ - FORTRAN(nident,(indepdof,&idof,&nindep,&id)); - if((id==0)||(indepdof[id-1]!=idof)){ - for(j=nindep;j>id;j--){ - indepdof[j]=indepdof[j-1]; - } - indepdof[id]=idof; - nindep++; - } - } - - icoef[2*ifree]=i+1; - icoef[2*ifree+1]=ipointer[idof]; - xcoef[ifree]=coefmpc[index-1]; - ipointer[idof]=++ifree; - index=nodempc[3*index-1]; - if(index==0) break; - } - } - -/* filling the left hand side */ - - nent=*memmpc_; - neqns=*nmpc; - mtxA = InpMtx_new() ; - InpMtx_init(mtxA, INPMTX_BY_ROWS, type, nent, neqns) ; - - for(i=0;i<*nmpc;i++){ - idof=ikmpc[i]; - icolumn=ilmpc[i]-1; - if(strcmp1(&labmpc[20*icolumn],"RIGID")==0) icolnl=1; - else icolnl=0; - index=ipointer[idof-1]; - while(1){ - irow=icoef[2*index-2]-1; - if(irow!=icolumn){ - if(strcmp1(&labmpc[20*irow],"RIGID")==0)irownl=1; - else irownl=0; - if((irownl==1)||(icolnl==1)){ - *icascade=2; - InpMtx_free(mtxA); - printf("*ERROR in cascade: linear and nonlinear MPCs depend on each other"); - FORTRAN(stop,()); - } - } - if((strcmp1(&labmpc[20*irow]," ")==0)&& - (strcmp1(&labmpc[20*icolumn],"CYCLIC")==0)){ - strcpy1(&labmpc[20*irow],"SUBCYCLIC",9);} - coef=xcoef[index-1]; - InpMtx_inputRealEntry(mtxA,irow,icolumn,coef); - index=icoef[2*index-1]; - if(index==0) break; - } - ipointer[idof-1]=0; - } - - InpMtx_changeStorageMode(mtxA, INPMTX_BY_VECTORS) ; - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n input matrix") ; - InpMtx_writeForHumanEye(mtxA, msgFile) ; - fflush(msgFile) ; - } -/*--------------------------------------------------------------------*/ -/* - ------------------------------------------------- - STEP 2 : find a low-fill ordering - (1) create the Graph object - (2) order the graph using multiple minimum degree - ------------------------------------------------- -*/ - graph = Graph_new() ; - adjIVL = InpMtx_fullAdjacency(mtxA) ; - nedges = IVL_tsize(adjIVL) ; - Graph_init2(graph, 0, neqns, 0, nedges, neqns, nedges, adjIVL, - NULL, NULL) ; - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n graph of the input matrix") ; - Graph_writeForHumanEye(graph, msgFile) ; - fflush(msgFile) ; - } - maxdomainsize=800;maxzeros=1000;maxsize=64; - /*maxdomainsize=neqns/100;*/ - /*frontETree = orderViaMMD(graph, seed, msglvl, msgFile) ;*/ - /*frontETree = orderViaND(graph,maxdomainsize,seed,msglvl,msgFile); */ - /*frontETree = orderViaMS(graph,maxdomainsize,seed,msglvl,msgFile);*/ - frontETree=orderViaBestOfNDandMS(graph,maxdomainsize,maxzeros, - maxsize,seed,msglvl,msgFile); - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n front tree from ordering") ; - ETree_writeForHumanEye(frontETree, msgFile) ; - fflush(msgFile) ; - } -/*--------------------------------------------------------------------*/ -/* - ----------------------------------------------------- - STEP 3: get the permutation, permute the matrix and - front tree and get the symbolic factorization - ----------------------------------------------------- -*/ - oldToNewIV = ETree_oldToNewVtxPerm(frontETree) ; - oldToNew = IV_entries(oldToNewIV) ; - newToOldIV = ETree_newToOldVtxPerm(frontETree) ; - ETree_permuteVertices(frontETree, oldToNewIV) ; - InpMtx_permute(mtxA, oldToNew, oldToNew) ; -/* InpMtx_mapToUpperTriangle(mtxA) ;*/ - InpMtx_changeCoordType(mtxA,INPMTX_BY_CHEVRONS); - InpMtx_changeStorageMode(mtxA,INPMTX_BY_VECTORS); - symbfacIVL = SymbFac_initFromInpMtx(frontETree, mtxA) ; - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n old-to-new permutation vector") ; - IV_writeForHumanEye(oldToNewIV, msgFile) ; - fprintf(msgFile, "\n\n new-to-old permutation vector") ; - IV_writeForHumanEye(newToOldIV, msgFile) ; - fprintf(msgFile, "\n\n front tree after permutation") ; - ETree_writeForHumanEye(frontETree, msgFile) ; - fprintf(msgFile, "\n\n input matrix after permutation") ; - InpMtx_writeForHumanEye(mtxA, msgFile) ; - fprintf(msgFile, "\n\n symbolic factorization") ; - IVL_writeForHumanEye(symbfacIVL, msgFile) ; - fflush(msgFile) ; - } -/*--------------------------------------------------------------------*/ -/* - ------------------------------------------ - STEP 4: initialize the front matrix object - ------------------------------------------ -*/ - frontmtx = FrontMtx_new() ; - mtxmanager = SubMtxManager_new() ; - SubMtxManager_init(mtxmanager, NO_LOCK, 0) ; - FrontMtx_init(frontmtx, frontETree, symbfacIVL, type, symmetryflag, - FRONTMTX_DENSE_FRONTS, pivotingflag, NO_LOCK, 0, NULL, - mtxmanager, msglvl, msgFile) ; -/*--------------------------------------------------------------------*/ -/* - ----------------------------------------- - STEP 5: compute the numeric factorization - ----------------------------------------- -*/ - chvmanager = ChvManager_new() ; - ChvManager_init(chvmanager, NO_LOCK, 1) ; - DVfill(10, cpus, 0.0) ; - IVfill(20, stats, 0) ; - rootchv = FrontMtx_factorInpMtx(frontmtx, mtxA, tau, 0.0, chvmanager, - &error,cpus, stats, msglvl, msgFile) ; - ChvManager_free(chvmanager) ; - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n factor matrix") ; - FrontMtx_writeForHumanEye(frontmtx, msgFile) ; - fflush(msgFile) ; - } - if ( rootchv != NULL ) { - fprintf(msgFile, "\n\n matrix found to be singular\n") ; - exit(-1) ; - } - if(error>=0){ - fprintf(msgFile,"\n\nerror encountered at front %d",error); - exit(-1); - } -/*--------------------------------------------------------------------*/ -/* - -------------------------------------- - STEP 6: post-process the factorization - -------------------------------------- -*/ - FrontMtx_postProcess(frontmtx, msglvl, msgFile) ; - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n factor matrix after post-processing") ; - FrontMtx_writeForHumanEye(frontmtx, msgFile) ; - fflush(msgFile) ; - } - -/* reinitialize nodempc */ - - *mpcfree=1; - for(j=0;j<*nmpc;j++){ - ipompc[j]=0;} - -/* filling the RHS */ - - jrhs=0; - nrhs=1; - mtxB=DenseMtx_new(); - mtxX=DenseMtx_new(); - - for(i=nindep;i>0;i--){ - idof=indepdof[i-1]; - if(ipointer[idof]>0){ - -/* new RHS column */ - - DenseMtx_init(mtxB, type, 0, 0, neqns, nrhs, 1, neqns) ; - DenseMtx_zero(mtxB) ; - - index=ipointer[idof]; - while(1){ - irow=icoef[2*index-2]-1; - coef=xcoef[index-1]; - DenseMtx_setRealEntry(mtxB,irow,jrhs,coef); - index=icoef[2*index-1]; - if(index==0) break; - } - - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n rhs matrix in original ordering") ; - DenseMtx_writeForHumanEye(mtxB, msgFile) ; - fflush(msgFile) ; - } - -/*--------------------------------------------------------------------*/ -/* - --------------------------------------------------------- - STEP 8: permute the right hand side into the new ordering - --------------------------------------------------------- -*/ - DenseMtx_permuteRows(mtxB, oldToNewIV) ; - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n right hand side matrix in new ordering") ; - DenseMtx_writeForHumanEye(mtxB, msgFile) ; - fflush(msgFile) ; - } -/*--------------------------------------------------------------------*/ -/* - ------------------------------- - STEP 9: solve the linear system - ------------------------------- -*/ - DenseMtx_init(mtxX, type, 0, 0, neqns, nrhs, 1, neqns) ; - DenseMtx_zero(mtxX) ; - FrontMtx_solve(frontmtx, mtxX, mtxB, mtxmanager,cpus, msglvl, msgFile) ; - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n solution matrix in new ordering") ; - DenseMtx_writeForHumanEye(mtxX, msgFile) ; - fflush(msgFile) ; - } -/*--------------------------------------------------------------------*/ -/* - -------------------------------------------------------- - STEP 10: permute the solution into the original ordering - -------------------------------------------------------- -*/ - DenseMtx_permuteRows(mtxX, newToOldIV) ; - if ( msglvl > 1 ) { - fprintf(msgFile, "\n\n solution matrix in original ordering") ; - DenseMtx_writeForHumanEye(mtxX, msgFile) ; - fflush(msgFile) ; - } - - - for(j=0;j<*nmpc;j++){ - b=DenseMtx_entries(mtxX)[j]; - if(fabs(b)>1.e-10){ - nodempc[3**mpcfree-1]=ipompc[j]; - node=(int)((idof+8)/8); - idir=idof+1-8*(node-1); - nodempc[3**mpcfree-3]=node; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=b; - ipompc[j]=(*mpcfree)++; - if(*mpcfree>*memmpc_){ - *memmpc_=(int)(1.1**memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - } - } - } - } - } -/*--------------------------------------------------------------------*/ -/* - ----------- - free memory - ----------- -*/ - FrontMtx_free(frontmtx) ; - DenseMtx_free(mtxB) ; - DenseMtx_free(mtxX) ; - IV_free(newToOldIV) ; - IV_free(oldToNewIV) ; - InpMtx_free(mtxA) ; - ETree_free(frontETree) ; - IVL_free(symbfacIVL) ; - SubMtxManager_free(mtxmanager) ; - Graph_free(graph) ; - -/* diagonal terms */ - - for(i=0;i<*nmpc;i++){ - j=ilmpc[i]-1; - idof=ikmpc[i]; - node=(int)((idof+7)/8); - idir=idof-8*(node-1); - nodempc[3**mpcfree-1]=ipompc[j]; - nodempc[3**mpcfree-3]=node; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=1.; - ipompc[j]=(*mpcfree)++; - if(*mpcfree>*memmpc_){ - *memmpc_=(int)(1.1**memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - } - } - - free(ipointer);free(indepdof);free(icoef);free(xcoef); - - fclose(msgFile); - - } -#endif - -/* determining the effective size of nodempc and coefmpc for - the reallocation*/ - - *mpcend=0; - *mpcmult=0; - *maxlenmpc=0; - for(i=0;i<*nmpc;i++){ - index=ipompc[i]; - *mpcend=max(*mpcend,index); - nterm=1; - while(1){ - index=nodempc[3*index-1]; - if(index==0){ - *mpcmult+=nterm*(nterm-1); - *maxlenmpc=max(*maxlenmpc,nterm); - break; - } - *mpcend=max(*mpcend,index); - nterm++; - } - } - - free(jmpc); - - *nodempcp=nodempc; - *coefmpcp=coefmpc; - - /* for(i=0;i<*nmpc;i++){ - j=i+1; - FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); - }*/ - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/ccx_2.1.c calculix-ccx-2.3/ccx_2.1/src/ccx_2.1.c --- calculix-ccx-2.1/ccx_2.1/src/ccx_2.1.c 2010-03-04 19:53:32.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ccx_2.1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1207 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#ifdef CALCULIX_MPI -#include -#endif - -#include -#include -#include -#include -#include "CalculiX.h" - -#ifdef CALCULIX_MPI -int myid = 0, nproc = 0; -#endif - -int main(int argc,char *argv[]) -{ - -int *kon=NULL, *nodeboun=NULL, *ndirboun=NULL, *ipompc=NULL, - *nodempc=NULL, *nodeforc=NULL, *ndirforc=NULL, - *nelemload=NULL, - *nnn=NULL, *nactdof=NULL, *icol=NULL,*ics=NULL, - *jq=NULL, *mast1=NULL, *irow=NULL, *rig=NULL, - *ikmpc=NULL, *ilmpc=NULL, *ikboun=NULL, *ilboun=NULL, - *npn=NULL, *adj=NULL, *xadj=NULL, *iw=NULL, *nreorder=NULL, - *mmm=NULL, *xnpn=NULL, *ipointer=NULL, - *istartset=NULL, *iendset=NULL, *ialset=NULL, *ielmat=NULL, - *ielorien=NULL, *nrhcon=NULL, *nodebounold=NULL, *ndirbounold=NULL, - *nelcon=NULL, *nalcon=NULL, *iamforc=NULL, *iamload=NULL, - *iamt1=NULL, *namta=NULL, *ipkon=NULL, *iamboun=NULL, - *nplicon=NULL, *nplkcon=NULL, *inotr=NULL, *iponor=NULL, *knor=NULL, - *ikforc=NULL, *ilforc=NULL, *iponoel=NULL, *inoel=NULL, *nshcon=NULL, - *ncocon=NULL,*ibody=NULL, *inum1=NULL,*ielprop=NULL, - *inum2=NULL,*ipoinpc=NULL,cfd=0,mt; - -double *co=NULL, *xboun=NULL, *coefmpc=NULL, *xforc=NULL, - *xload=NULL, *ad=NULL, *au=NULL, *xbounold=NULL, *xforcold=NULL, - *b=NULL, *vold=NULL, *sti=NULL, *xloadold=NULL, *xnor=NULL, - *reorder=NULL,*dcs=NULL, *thickn=NULL, *thicke=NULL, *offset=NULL, - *elcon=NULL, *rhcon=NULL, *alcon=NULL, *alzero=NULL, *t0=NULL, *t1=NULL, - *prestr=NULL, *orab=NULL, *amta=NULL, *veold=NULL, *accold=NULL, - *adb=NULL, *aub=NULL, *t1old=NULL, *eme=NULL, *plicon=NULL, *plkcon=NULL, - *xstate=NULL, *trab=NULL, *ener=NULL, *shcon=NULL, *cocon=NULL, - *cs=NULL,*tietol=NULL,*fmpc=NULL,*prop=NULL, - *xbody=NULL,*xbodyold=NULL; - -double ctrl[27]={4.5,8.5,9.5,16.5,10.5,4.5,0.,5.5,0.,0.,0.25,0.5,0.75,0.85,0.,0.,1.5,0.,0.005,0.01,0.,0.,0.02,1.e-5,1.e-3,1.e-8,1.e30}; - -char *sideload=NULL, *set=NULL, *matname=NULL, *orname=NULL, *amname=NULL, - *filab=NULL, *lakon=NULL, *labmpc=NULL, *prlab=NULL, *prset=NULL, - jobnamec[396]="",jobnamef[132]="",output[4]="frd", *typeboun=NULL, - *inpc=NULL,*tieset=NULL,*cbody=NULL; - -int nk,ne,nboun,nmpc,nforc,nload,nprint,nset,nalset,nentries=14, - nmethod,neq[3]={0,0,0},i,mpcfree=1,mei[4],j,nzl,nam,nbounold=0, - nforcold=0,nloadold=0,nbody,nbody_=0,nbodyold=0, - k,nzs[3],nmpc_=0,nload_=0,nforc_=0,istep,istat,nboun_=0, - iperturb[2]={0,0},nmat,ntmat_=0,norien,ithermal[2]={0,0}, - iprestr,kode,isolver=0, - jout[2]={1,1},nlabel,nkon=0,idrct,jmax[2],iexpl,nevtot=0, -// iplas=0,npmat_=0,mi[2]={0,0},ntrans,mpcend=-1,namtot_=0,iumat=0,mpcmult, - iplas=0,npmat_=0,mi[2]={0,3},ntrans,mpcend=-1,namtot_=0,iumat=0,mpcmult, - icascade=0,maxlenmpc,mpcinfo[4],ne1d=0,ne2d=0,infree[4]={0,0,0,0}, - callfrommain,nflow=0,jin=0,irstrt=0,nener=0,jrstrt=0,nenerold, - nline,ipoinp[2*nentries],*inp=NULL,ntie,ntie_=0,mcs=0,kflag=2,nprop_=0, - nprop=0,itpamp=0,iviewfile,nkold,nevdamp_=0; - -int *meminset=NULL,*rmeminset=NULL; - -int nzs_,nk_=0,ne_=0,nset_=0,nalset_=0,nmat_=0,norien_=0,nam_=0, - ntrans_=0,ncs_=0,nstate_=0,ncmat_=0,memmpc_=0,nprint_=0; - -double fei[3],tinc,tper,tmin,tmax,*xmodal=NULL, - alpha,ttime=0.,qaold[2]={0.,0.},physcon[9]={0.,0.,0.,0.,0.,0.,0.,0.,0.}; - - -#ifdef CALCULIX_MPI -MPI_Init(&argc, &argv) ; -MPI_Comm_rank(MPI_COMM_WORLD, &myid) ; -MPI_Comm_size(MPI_COMM_WORLD, &nproc) ; -#endif - - -if(argc==1){printf("Usage: CalculiX.exe -i jobname\n");FORTRAN(stop,());} -else{ - for(i=1;i=0) { - - fflush(stdout); - - /* in order to reduce the number of variables to be transferred to - the subroutines, the max. field sizes are (for most fields) copied - into the real sizes */ - - nzs[1]=nzs_; - nprint=nprint_; - - if((istep == 0)||(irstrt<0)) { - ne=ne_; - nset=nset_; - nalset=nalset_; - nmat=nmat_; - norien=norien_; - ntrans=ntrans_; - ntie=ntie_; - - /* allocating space before the first step */ - - /* coordinates and topology */ - - co=NNEW(double,3*nk_); - kon=NNEW(int,28*ne_); - ipkon=NNEW(int,ne_); - lakon=NNEW(char,8*ne_); - - /* property cards */ - - ielprop=NNEW(int,ne_); - for(i=0;i0){xstate=NNEW(double,nstate_*mi[0]*ne);} - - /* material orientation */ - - orname=NNEW(char,80*norien); - orab=NNEW(double,7*norien); - ielorien=NNEW(int,ne_); - - /* transformations */ - - trab=NNEW(double,7*ntrans); - inotr=NNEW(int,2*nk_); - - /* amplitude definitions */ - - amname=NNEW(char,80*nam_); - amta=NNEW(double,2*namtot_); - namta=NNEW(int,3*nam_); - - /* temperatures */ - - if((ne1d==0)&&(ne2d==0)){ - t0=NNEW(double,nk_); - t1=NNEW(double,nk_);} - else{ - t0=NNEW(double,3*nk_); - t1=NNEW(double,3*nk_);} - iamt1=NNEW(int,nk_); - - prestr=NNEW(double,6*mi[0]*ne_); - vold=NNEW(double,mt*nk_); - veold=NNEW(double,mt*nk_); - - ielmat=NNEW(int,ne_); - - matname=NNEW(char,80*nmat); - - filab=NNEW(char,87*nlabel); - - /* tied constraints */ - - if(ntie_>0){ - tieset=NNEW(char,243*ntie_); - tietol=NNEW(double,ntie_); - cs=NNEW(double,17*ntie_); - } - - /* temporary fields for cyclic symmetry calculations */ - - if(ncs_>0){ - ics=NNEW(int,24*ncs_); - dcs=NNEW(double,30*ncs_); - } - - } - else { - - /* allocating and reallocating space for subsequent steps */ - - if((nmethod != 4) && ((nmethod != 1) || (iperturb[0] < 2))){ - veold=NNEW(double,mt*nk_); - } - else{ - RENEW(veold,double,mt*nk_); - memset(&veold[mt*nk],0,sizeof(double)*mt*(nk_-nk)); - } - RENEW(vold,double,mt*nk_); - memset(&vold[mt*nk],0,sizeof(double)*mt*(nk_-nk)); - - /* if(nmethod != 4){free(accold);}*/ - - RENEW(nodeboun,int,nboun_); - RENEW(ndirboun,int,nboun_); - RENEW(typeboun,char,nboun_); - RENEW(xboun,double,nboun_); - RENEW(ikboun,int,nboun_); - RENEW(ilboun,int,nboun_); - - RENEW(nodeforc,int,2*nforc_); - RENEW(ndirforc,int,nforc_); - RENEW(xforc,double,nforc_); - RENEW(ikforc,int,nforc_); - RENEW(ilforc,int,nforc_); - - RENEW(nelemload,int,2*nload_); - RENEW(sideload,char,20*nload_); - RENEW(xload,double,2*nload_); - - RENEW(cbody,char,81*nbody_); - RENEW(ibody,int,3*nbody_); - RENEW(xbody,double,7*nbody_); - RENEW(xbodyold,double,7*nbody_); - for(i=7*nbodyold;i<7*nbody_;i++) xbodyold[i]=0; - - if(nam > 0) { - RENEW(iamforc,int,nforc_); - RENEW(iamload,int,2*nload_); - RENEW(iamboun,int,nboun_); - RENEW(amname,char,80*nam_); - RENEW(amta,double,2*namtot_); - RENEW(namta,int,3*nam_); - } - - RENEW(ipompc,int,nmpc_); - - RENEW(labmpc,char,20*nmpc_+1); - RENEW(ikmpc,int,nmpc_); - RENEW(ilmpc,int,nmpc_); - RENEW(fmpc,double,nmpc_); - - if(ntrans > 0){ - RENEW(inotr,int,2*nk_); - } - - RENEW(co,double,3*nk_); - - if(ithermal[0] != 0){ - if((ne1d==0)&&(ne2d==0)){ - RENEW(t0,double,nk_); - RENEW(t1,double,nk_); - } - if(nam > 0) {RENEW(iamt1,int,nk_);} - } - - } - - /* allocation of fields in the restart file */ - - if(irstrt<0){ - nodebounold=NNEW(int,nboun_); - ndirbounold=NNEW(int,nboun_); - xbounold=NNEW(double,nboun_); - xforcold=NNEW(double,nforc_); - xloadold=NNEW(double,2*nload_); - if(ithermal[0]!=0) t1old=NNEW(double,nk_); - sti=NNEW(double,6*mi[0]*ne); - eme=NNEW(double,6*mi[0]*ne); - if(nener==1)ener=NNEW(double,mi[0]*ne*2); - nnn=NNEW(int,nk_); - } - - nenerold=nener; - nkold=nk; - - /* reading the input file */ - - FORTRAN(calinput,(co,&nk,kon,ipkon,lakon,&nkon,&ne, - nodeboun,ndirboun,xboun,&nboun, - ipompc,nodempc,coefmpc,&nmpc,&nmpc_,nodeforc,ndirforc,xforc,&nforc, - &nforc_,nelemload,sideload,xload,&nload,&nload_, - &nprint,prlab,prset,&mpcfree,&nboun_,mei,set,istartset,iendset, - ialset,&nset,&nalset,elcon,nelcon,rhcon,nrhcon,alcon,nalcon, - alzero,t0,t1,matname,ielmat,orname,orab,ielorien,amname, - amta,namta,&nam,&nmethod,iamforc,iamload,iamt1, - ithermal,iperturb,&istat,&istep,&nmat,&ntmat_,&norien,prestr, - &iprestr,&isolver,fei,veold,&tinc,&tper, - xmodal,filab,jout,&nlabel,&idrct, - jmax,&tmin,&tmax,&iexpl,&alpha,iamboun,plicon,nplicon, - plkcon,nplkcon,&iplas,&npmat_,mi,&nk_,trab,inotr,&ntrans, - ikboun,ilboun,ikmpc,ilmpc,ics,dcs,&ncs_,&namtot_,cs,&nstate_, - &ncmat_,&iumat,&mcs,labmpc,iponor,xnor,knor,thickn,thicke, - ikforc,ilforc,offset,iponoel,inoel,rig,infree,nshcon,shcon, - cocon,ncocon,physcon,&nflow, - ctrl,&memmpc_,&maxlenmpc,&ne1d,&ne2d,&nener,vold,nodebounold, - ndirbounold,xbounold,xforcold,xloadold,t1old,eme, - sti,ener,xstate,jobnamec,nnn,&irstrt,&ttime, - qaold,output,typeboun,inpc,&nline,ipoinp,inp,tieset,tietol, - &ntie,fmpc,cbody,ibody,xbody,&nbody,&nbody_,xbodyold,&nam_, - ielprop,&nprop,&nprop_,prop,&itpamp,&iviewfile,ipoinpc,&cfd)); - -/* FORTRAN(writeboun,(nodeboun,ndirboun,xboun,typeboun,&nboun));*/ - - if(istat<0) break; - - /*RENEW(inpc,char,(long long)132*nline);*/ - /* RENEW(inp,int,3*ipoinp[23]); */ - - if(istep == 1) { - - /* reallocating space in the first step */ - - /* allocating and initializing fields pointing to the previous step */ - - RENEW(vold,double,mt*nk); - sti=NNEW(double,6*mi[0]*ne); - - /* strains */ - - eme=NNEW(double,6*mi[0]*ne); - - /* residual stresses/strains */ - - if(iprestr==1) { - RENEW(prestr,double,6*mi[0]*ne); - for(i=0;i1){ - for(i=0;i0){ - RENEW(ielprop,int,ne); - RENEW(prop,double,nprop); - }else{ - free(ielprop);free(prop); - } - - /* fields for 1-D and 2-D elements */ - - if((ne1d!=0)||(ne2d!=0)){ - RENEW(iponor,int,2*nkon); - RENEW(xnor,double,infree[0]); - RENEW(knor,int,infree[1]); - free(thickn); - RENEW(thicke,double,2*nkon); - RENEW(offset,double,2*ne); - RENEW(inoel,int,3*(infree[2]-1)); - RENEW(iponoel,int,infree[3]); - RENEW(rig,int,infree[3]); - } - - /* set definitions */ - - RENEW(set,char,81*nset); - RENEW(istartset,int,nset); - RENEW(iendset,int,nset); - RENEW(ialset,int,nalset); - - /* material properties */ - - RENEW(elcon,double,(ncmat_+1)*ntmat_*nmat); - RENEW(nelcon,int,2*nmat); - - RENEW(rhcon,double,2*ntmat_*nmat); - RENEW(nrhcon,int,nmat); - - RENEW(shcon,double,4*ntmat_*nmat); - RENEW(nshcon,int,nmat); - - RENEW(cocon,double,7*ntmat_*nmat); - RENEW(ncocon,int,2*nmat); - - RENEW(alcon,double,7*ntmat_*nmat); - RENEW(nalcon,int,2*nmat); - RENEW(alzero,double,nmat); - - RENEW(matname,char,80*nmat); - RENEW(ielmat,int,ne); - - /* allocating space for the state variables */ - - /* if(nstate_>0){ - xstate=NNEW(double,nstate_*mi[0]*ne); - }*/ - - /* next statements for plastic materials and nonlinear springs */ - - if(npmat_>0){ - RENEW(plicon,double,(2*npmat_+1)*ntmat_*nmat); - RENEW(nplicon,int,(ntmat_+1)*nmat); - }else{ - free(plicon);free(nplicon); - } - /* next statements only for plastic materials */ - - if(iplas!=0){ - RENEW(plkcon,double,(2*npmat_+1)*ntmat_*nmat); - RENEW(nplkcon,int,(ntmat_+1)*nmat); - } - else{ - free(plkcon);free(nplkcon); - } - - /* material orientation */ - - if(norien > 0) { - RENEW(orname,char,80*norien); - RENEW(ielorien,int,ne); - RENEW(orab,double,7*norien); - } - else { - free(orname); - free(ielorien); - free(orab); - } - - /* amplitude definitions */ - - if(nam > 0) { - RENEW(amname,char,80*nam); - RENEW(namta,int,3*nam); - RENEW(amta,double,2*namta[3*nam-2]); - } - else { - free(amname); - free(amta); - free(namta); - free(iamforc); - free(iamload); - free(iamboun); - } - - if(ntrans > 0){ - RENEW(trab,double,7*ntrans); - } - else{free(trab);free(inotr);} - - if(ithermal[0] == 0){free(t0);free(t1);} - if((ithermal[0] == 0)||(nam<=0)){free(iamt1);} - - if(ncs_>0){ - RENEW(ics,int,ncs_); - free(dcs);} - - - /* tied contact constraints: generate appropriate MPC's */ - - tiedcontact(&ntie, tieset, &nset, set,istartset, iendset, ialset, - lakon, ipkon, kon,tietol,&nmpc, &mpcfree, &memmpc_, - &ipompc, &labmpc, &ikmpc, &ilmpc,&fmpc, &nodempc, &coefmpc, - ithermal, co, vold,&cfd,&nmpc_,mi); - - }else{ - - /* reallocating space in all but the first step (>1) */ - - RENEW(vold,double,mt*nk); - - /* if the SPC boundary conditions were changed in the present step, - they have to be rematched with those in the last step. Removed SPC - boundary conditions do not appear any more (this is different from - forces and loads, where removed forces or loads are reset to zero; - a removed SPC constraint does not have a numerical value any more) */ - - reorder=NNEW(double,nboun); - nreorder=NNEW(int,nboun); - if(nbounold 0) { - RENEW(amname,char,80*nam); - RENEW(namta,int,3*nam); - RENEW(amta,double,2*namta[3*nam-2]); - } - - } - - /* reallocating fields for all steps (>=1) */ - - RENEW(co,double,3*nk); - - RENEW(nodeboun,int,nboun); - RENEW(ndirboun,int,nboun); - RENEW(typeboun,char,nboun); - RENEW(xboun,double,nboun); - RENEW(ikboun,int,nboun); - RENEW(ilboun,int,nboun); - - RENEW(nodeforc,int,2*nforc); - RENEW(ndirforc,int,nforc); - RENEW(xforc,double,nforc); - RENEW(ikforc,int,nforc); - RENEW(ilforc,int,nforc); - - RENEW(nelemload,int,2*nload); - RENEW(sideload,char,20*nload); - RENEW(xload,double,2*nload); - - RENEW(cbody,char,81*nbody); - RENEW(ibody,int,3*nbody); - RENEW(xbody,double,7*nbody); - RENEW(xbodyold,double,7*nbody); - - RENEW(ipompc,int,nmpc); - RENEW(labmpc,char,20*nmpc+1); - RENEW(ikmpc,int,nmpc); - RENEW(ilmpc,int,nmpc); - RENEW(fmpc,double,nmpc); - - /* energy */ - - if((nener==1)&&(nenerold==0)){ - ener=NNEW(double,mi[0]*ne*2); - if((istep>1)&&(iperturb[0]>1)){ - printf("*ERROR in CalculiX: in nonlinear calculations"); - printf(" energy output must be selected in the first step"); - FORTRAN(stop,()); - } - } - - /* initial velocities and accelerations */ - - if((nmethod == 4) || ((nmethod == 1) && (iperturb[0] >= 2))) { - RENEW(veold,double,mt*nk); - } - else {free(veold);} - - if((nmethod == 4)&&(iperturb[0]>1)) { - accold=NNEW(double,mt*nk); - } - - if(nam > 0) { - RENEW(iamforc,int,nforc); - RENEW(iamload,int,2*nload); - RENEW(iamboun,int,nboun); - } - - /* temperature loading */ - - if(ithermal[0] != 0){ - if((ne1d==0)&&(ne2d==0)){ - RENEW(t0,double,nk); - RENEW(t1,double,nk); - } - if(nam > 0) {RENEW(iamt1,int,nk);} - } - - if(ntrans > 0){ - RENEW(inotr,int,2*nk); - } - - /* sorting the elements with distributed loads */ - - if(nload>0){ - if(nam>0){ - FORTRAN(isortiddc2,(nelemload,iamload,xload,xloadold,sideload,&nload,&kflag)); - }else{ - FORTRAN(isortiddc1,(nelemload,xload,xloadold,sideload,&nload,&kflag)); - } - } - - /* calling the user routine ufaceload (can be empty) */ - - FORTRAN(ufaceload,(co,ipkon,kon,lakon,nelemload,sideload,&nload)); - - /* decascading MPC's and renumbering the equations: only necessary - if MPC's changed */ - - if(((istep == 1)||(ntrans>0)||(mpcend<0)||(nk!=nkold))&&(icascade==0)) { - - /* decascading the MPC's */ - - printf(" Decascading the MPC's\n\n"); - - callfrommain=1; - cascade(ipompc,&coefmpc,&nodempc,&nmpc, - &mpcfree,nodeboun,ndirboun,&nboun,ikmpc, - ilmpc,ikboun,ilboun,&mpcend,&mpcmult, - labmpc,&nk,&memmpc_,&icascade,&maxlenmpc, - &callfrommain,iperturb,ithermal); - - if(istep==1) nnn=NNEW(int,nk); - else RENEW(nnn,int,nk); - for(i=1;i<=nk;++i) - nnn[i-1]=i; - -// if((icascade==0)&&(isolver!=6)){ - if((icascade==10)&&(isolver!=6)){ - - /* renumbering the nodes */ - - printf(" Renumbering the nodes to decrease the profile:\n"); - fflush(stdout); - - npn=NNEW(int,20*ne+mpcend); - adj=NNEW(int,380*ne+mpcmult); - xadj=NNEW(int,nk+1); - iw=NNEW(int,3*nk+1); - mmm=NNEW(int,nk); - xnpn=NNEW(int,ne+nmpc+1); - inum1=NNEW(int,nk); - inum2=NNEW(int,nk); - - FORTRAN(renumber,(&nk,kon,ipkon,lakon,&ne,ipompc,nodempc,&nmpc,nnn, - npn,adj,xadj,iw,mmm,xnpn,inum1,inum2)); - - free(npn);free(adj);free(xadj);free(iw);free(mmm);free(xnpn); - free(inum1);free(inum2); - } - - } - - /* determining the matrix structure: changes if SPC's have changed */ - - if(icascade==0) printf(" Determining the structure of the matrix:\n"); - - nactdof=NNEW(int,mt*nk); - mast1=NNEW(int,nzs[1]); - irow=NNEW(int,nzs[1]); - - if((mcs==0)||(cs[1]<0)){ - - icol=NNEW(int,4*nk); - jq=NNEW(int,4*nk+1); - ipointer=NNEW(int,4*nk); - - if(icascade==0){ - mastruct(&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,&nboun,ipompc, - nodempc,&nmpc,nactdof,icol,jq,&mast1,&irow,&isolver,neq,nnn, - ikmpc,ilmpc,ipointer,nzs,&nmethod,ithermal, - ikboun,ilboun,iperturb,mi); - } - else{neq[0]=1;neq[1]=1;neq[2]=1;} - } - else{ - - icol=NNEW(int,8*nk); - jq=NNEW(int,8*nk+1); - ipointer=NNEW(int,8*nk); - - mastructcs(&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,&nboun, - ipompc,nodempc,&nmpc,nactdof,icol,jq,&mast1,&irow,&isolver, - neq,nnn,ikmpc,ilmpc,ipointer,nzs,&nmethod, - ics,cs,labmpc,&mcs,mi); - } - - free(ipointer);free(mast1); - if(icascade==0)RENEW(irow,int,nzs[2]); - - /* nmethod=1: static analysis */ - /* nmethod=2: frequency analysis */ - /* nmethod=3: buckling analysis */ - /* nmethod=4: linear dynamic analysis */ - - if((nmethod<=1)||(iperturb[0]>1)) - { - if(iperturb[0]<2){ - - prespooles(co,&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,xboun,&nboun, - ipompc,nodempc,coefmpc,labmpc,&nmpc,nodeforc,ndirforc,xforc, - &nforc, nelemload,sideload,xload,&nload, - ad,au,b,nactdof,&icol,jq,&irow,neq,&nzl,&nmethod,ikmpc, - ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,ielmat,ielorien,&norien,orab,&ntmat_, - t0,t1,t1old,ithermal,prestr,&iprestr, vold,iperturb,sti,nzs, - &kode,adb,aub,filab,eme,&iexpl,plicon, - nplicon,plkcon,nplkcon,xstate,&npmat_,matname, - &isolver,mi,&ncmat_,&nstate_,cs,&mcs,&nkon,ener, - xbounold,xforcold,xloadold,amname,amta,namta, - &nam,iamforc,iamload,iamt1,iamboun,&ttime, - output,set,&nset,istartset,iendset,ialset,&nprint,prlab, - prset,&nener,trab,inotr,&ntrans,fmpc,cbody,ibody,xbody,&nbody, - xbodyold,&tper); - - } - - else{ - - mpcinfo[0]=memmpc_;mpcinfo[1]=mpcfree;mpcinfo[2]=icascade; - mpcinfo[3]=maxlenmpc; - - nonlingeo(&co,&nk,&kon,&ipkon,&lakon,&ne,nodeboun,ndirboun,xboun,&nboun, - &ipompc,&nodempc,&coefmpc,&labmpc,&nmpc,nodeforc,ndirforc,xforc, - &nforc, nelemload,sideload,xload,&nload, - ad,au,b,nactdof,&icol,jq,&irow,neq,&nzl,&nmethod,&ikmpc, - &ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,&ielmat,&ielorien,&norien,orab,&ntmat_, - t0,t1,t1old,ithermal,prestr,&iprestr, - &vold,iperturb,sti,nzs,&kode,adb,aub,filab,&idrct,jmax, - jout,&tinc,&tper,&tmin,&tmax,eme,xbounold,xforcold,xloadold, - veold,accold,amname,amta,namta, - &nam,iamforc,iamload,iamt1,&alpha, - &iexpl,iamboun,plicon,nplicon,plkcon,nplkcon, - xstate,&npmat_,&istep,&ttime,matname,qaold,mi, - &isolver,&ncmat_,&nstate_,&iumat,cs,&mcs,&nkon,&ener, - mpcinfo,nnn,output, - shcon,nshcon,cocon,ncocon,physcon,&nflow,ctrl, - set,&nset,istartset,iendset,ialset,&nprint,prlab, - prset,&nener,ikforc,ilforc,trab,inotr,&ntrans,&fmpc, - cbody,ibody,xbody,&nbody,xbodyold,ielprop,prop, - &ntie,tieset,&itpamp,&iviewfile,jobnamec,tietol); - - memmpc_=mpcinfo[0];mpcfree=mpcinfo[1];icascade=mpcinfo[2]; - maxlenmpc=mpcinfo[3]; - - - } - } - else if(nmethod==2) - { - /* FREQUENCY ANALYSIS */ - - if((mcs==0)||(cs[1]<0)){ -#ifdef ARPACK - arpack(co,&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,xboun,&nboun, - ipompc,nodempc,coefmpc,labmpc,&nmpc,nodeforc,ndirforc,xforc, - &nforc, nelemload,sideload,xload,&nload, - ad,au,b,nactdof,icol,jq,irow,neq,&nzl,&nmethod,ikmpc, - ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, - shcon,nshcon,cocon,ncocon, - alcon,nalcon,alzero,ielmat,ielorien,&norien,orab,&ntmat_, - t0,t1,t1old,ithermal,prestr,&iprestr,vold,iperturb,sti,nzs, - &kode,adb,aub,mei,fei,filab, - eme,&iexpl,plicon,nplicon,plkcon,nplkcon, - xstate,&npmat_,matname,mi,&ncmat_,&nstate_,ener,jobnamec, - output,set,&nset,istartset,iendset,ialset,&nprint,prlab, - prset,&nener,&isolver,trab,inotr,&ntrans,&ttime,fmpc,cbody, - ibody,xbody,&nbody);} -#else - printf("*ERROR in CalculiX: the ARPACK library is not linked\n\n"); - FORTRAN(stop,());} -#endif - - else{ -#ifdef ARPACK - arpackcs(co,&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,xboun,&nboun, - ipompc,nodempc,coefmpc,labmpc,&nmpc,nodeforc,ndirforc,xforc, - &nforc, nelemload,sideload,xload,&nload, - ad,au,b,nactdof,icol,jq,irow,neq,&nzl,&nmethod,ikmpc, - ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,ielmat,ielorien,&norien,orab,&ntmat_, - t0,t1,t1old,ithermal,prestr,&iprestr, - vold,iperturb,sti,nzs,&kode,adb,aub,mei,fei,filab, - eme,&iexpl,plicon,nplicon,plkcon,nplkcon, - xstate,&npmat_,matname,mi,ics,cs,&mpcend,&ncmat_, - &nstate_,&mcs,&nkon,ener,jobnamec,output,set,&nset,istartset, - iendset,ialset,&nprint,prlab, - prset,&nener,&isolver,trab,inotr,&ntrans,&ttime,fmpc,cbody, - ibody,xbody,&nbody,&nevtot);} -#else - printf("*ERROR in CalculiX: the ARPACK library is not linked\n\n"); - FORTRAN(stop,());} -#endif - - } - else if(nmethod==3) - { -#ifdef ARPACK - arpackbu(co,&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,xboun,&nboun, - ipompc,nodempc,coefmpc,labmpc,&nmpc,nodeforc,ndirforc,xforc, - &nforc, - nelemload,sideload,xload,&nload, - ad,au,b,nactdof,icol,jq,irow,neq,&nzl,&nmethod,ikmpc, - ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,ielmat,ielorien,&norien,orab,&ntmat_, - t0,t1,t1old,ithermal,prestr,&iprestr, - vold,iperturb,sti,nzs,&kode,adb,aub,mei,fei,filab, - eme,&iexpl,plicon,nplicon,plkcon,nplkcon, - xstate,&npmat_,matname,mi,&ncmat_,&nstate_,ener,output, - set,&nset,istartset,iendset,ialset,&nprint,prlab, - prset,&nener,&isolver,trab,inotr,&ntrans,&ttime,fmpc,cbody, - ibody,xbody,&nbody); -#else - printf("*ERROR in CalculiX: the ARPACK library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(nmethod==4) - { - if((ne1d!=0)||(ne2d!=0)){ - printf(" *WARNING: 1-D or 2-D elements may cause problems in modal dynamic calculations\n"); - printf(" ensure that point loads defined in a *MODAL DYNAMIC step\n"); - printf(" and applied to nodes belonging to 1-D or 2-D elements have been\n"); - printf(" applied to the same nodes in the preceding FREQUENCY step with\n"); - printf(" magnitude zero; look at example shellf.inp for a guideline.\n\n");} - - printf(" Composing the dynamic response from the eigenmodes\n\n"); - - dyna(&co,&nk,&kon,&ipkon,&lakon,&ne,&nodeboun,&ndirboun,&xboun,&nboun, - &ipompc,&nodempc,&coefmpc,&labmpc,&nmpc,nodeforc,ndirforc,xforc,&nforc, - nelemload,sideload,xload,&nload, - &nactdof,neq,&nzl,icol,irow,&nmethod,&ikmpc,&ilmpc,&ikboun,&ilboun, - elcon,nelcon,rhcon,nrhcon,cocon,ncocon, - alcon,nalcon,alzero,&ielmat,&ielorien,&norien,orab,&ntmat_,&t0, - &t1,ithermal,prestr,&iprestr,&vold,iperturb,&sti,nzs, - &tinc,&tper,xmodal,&veold,amname,amta, - namta,&nam,iamforc,iamload,&iamt1, - jout,&kode,filab,&eme,xforcold,xloadold, - &t1old,&iamboun,&xbounold,&iexpl,plicon, - nplicon,plkcon,nplkcon,xstate,&npmat_,matname, - mi,&ncmat_,&nstate_,&ener,jobnamec,&ttime,set,&nset, - istartset,iendset,&ialset,&nprint,prlab, - prset,&nener,trab,&inotr,&ntrans,&fmpc,cbody,ibody,xbody,&nbody, - xbodyold,&istep,&isolver,jq,output,&mcs,&nkon,&mpcend,ics,cs, - &ntie,tieset,&idrct,jmax,&tmin,&tmax,ctrl,&itpamp,tietol,&nalset,&nnn); - } - else if(nmethod==5) - { - if((ne1d!=0)||(ne2d!=0)){ - printf(" *WARNING: 1-D or 2-D elements may cause problems in steady state calculations\n"); - printf(" ensure that point loads defined in a *STEADY STATE DYNAMICS step\n"); - printf(" and applied to nodes belonging to 1-D or 2-D elements have been\n"); - printf(" applied to the same nodes in the preceding FREQUENCY step with\n"); - printf(" magnitude zero; look at example shellf.inp for a guideline.\n\n");} - - printf(" Composing the steady state response from the eigenmodes\n\n"); - - steadystate(&co,&nk,&kon,&ipkon,&lakon,&ne,&nodeboun,&ndirboun,&xboun,&nboun, - &ipompc,&nodempc,&coefmpc,&labmpc,&nmpc,nodeforc,ndirforc,xforc,&nforc, - nelemload,sideload,xload,&nload, - &nactdof,neq,&nzl,icol,irow,&nmethod,&ikmpc,&ilmpc,&ikboun,&ilboun, - elcon,nelcon,rhcon,nrhcon,cocon,ncocon, - alcon,nalcon,alzero,&ielmat,&ielorien,&norien,orab,&ntmat_,&t0, - &t1,ithermal,prestr,&iprestr,&vold,iperturb,sti,nzs, - &tinc,&tper,xmodal,veold,amname,amta, - namta,&nam,iamforc,iamload,&iamt1, - jout,&kode,filab,&eme,xforcold,xloadold, - &t1old,&iamboun,&xbounold,&iexpl,plicon, - nplicon,plkcon,nplkcon,xstate,&npmat_,matname, - mi,&ncmat_,&nstate_,&ener,jobnamec,&ttime,set,&nset, - istartset,iendset,ialset,&nprint,prlab, - prset,&nener,trab,&inotr,&ntrans,&fmpc,cbody,ibody,xbody,&nbody, - xbodyold,&istep,&isolver,jq,output,&mcs,&nkon,ics,cs,&mpcend,&nnn); - } - - free(nactdof); - free(icol); - free(jq); - free(irow); - - /* deleting the perturbation loads and temperatures */ - - if((iperturb[0] == 1)&&(nmethod==3)) { - nforc=0; - nload=0; - nbody=0; - if(ithermal[0] == 1) { - for(k=0;k 0) { - for (i=0;i0){ - if(namta[3*iamboun[i]-1]>0){ - iamboun[i]=0; - xboun[i]=xbounold[i];} - } - } - for (i=0;i0){ - if(namta[3*iamforc[i]-1]>0){ - iamforc[i]=0; - xforc[i]=xforcold[i];} - } - } - for (i=0;i<2*nload;i++){ - if(iamload[i]>0){ - if(namta[3*iamload[i]-1]>0){ - iamload[i]=0; - xload[i]=xloadold[i];} - } - } - for (i=1;i<3*nbody;i=i+3){ - if(ibody[i]>0){ - if(namta[3*ibody[i]-1]>0){ - ibody[i]=0; - xbody[7*(i-1)/3]=xbodyold[7*(i-1)/3];} - } - } - if(ithermal[0]==1) { - if(iamt1[i]>0){ - if(namta[3*iamt1[i]-1]>0){ - iamt1[i]=0; - t1[i]=t1old[i];} - } - } - } - } - - - if((nmethod == 4)&&(iperturb[0]>1)) free(accold); - - if(irstrt>0){ - jrstrt++; - if(jrstrt==irstrt){ - jrstrt=0; - FORTRAN(restartwrite,(&istep, &nset, &nload, &nforc, &nboun, &nk, &ne, - &nmpc, &nalset, &nmat, &ntmat_, &npmat_, &norien, &nam, &nprint, - mi, &ntrans, &ncs_, &namtot_, &ncmat_, &mpcend,&maxlenmpc, &ne1d, - &ne2d, &nflow, &nlabel, &iplas, &nkon,ithermal,&nmethod,iperturb, - &nstate_,&nener, set, istartset, iendset, ialset, co, kon, ipkon, - lakon, nodeboun, ndirboun, iamboun, xboun, ikboun, ilboun, ipompc, - nodempc, coefmpc, labmpc, ikmpc, ilmpc, nodeforc, ndirforc, iamforc, - xforc, ikforc, ilforc, nelemload, iamload, sideload, xload, - elcon, nelcon, rhcon, nrhcon, alcon, nalcon, - alzero, plicon, nplicon, plkcon, nplkcon, orname, orab, ielorien, - trab, inotr, amname, amta, namta, t0, t1, iamt1, veold, - ielmat,matname, prlab,prset,filab, vold,nodebounold, - ndirbounold, xbounold, xforcold, xloadold, t1old, eme, - iponor, xnor, knor, thickn, thicke, offset, iponoel, inoel, rig, - shcon, nshcon, cocon, ncocon, ics, - sti, ener, xstate, jobnamec,infree,nnn,prestr,&iprestr,cbody, - ibody,xbody,&nbody,xbodyold,&ttime,qaold,cs,&mcs,output, - physcon,ctrl,typeboun,fmpc,tieset,&ntie)); - } - } - -} - - FORTRAN(closefile,()); - -#ifdef CALCULIX_MPI -MPI_Finalize(); -#endif - - return 0; - -} - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_bleedtapping.f calculix-ccx-2.3/ccx_2.1/src/cd_bleedtapping.f --- calculix-ccx-2.1/ccx_2.1/src/cd_bleedtapping.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_bleedtapping.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,138 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! this function enable to determine the discharge coefficient of bleed -! tappings -! - subroutine cd_bleedtapping(ps2,ps1,ps1pt1,nummer,curve,x_tab,y_tab - & ,cd) -! -! -! in : SImultation of the secondary air system of aero engines -! K.J.KUTZ T.M. SPEER -! Transactions of the ASME vol.116 April 1994 -! - implicit none -! - integer nummer,id,i,number,curve,index - real*8 x_tab(15),y_tab(15) -! -! Fig.7 tapping with lip -! - real*8 cdx1(9) - data cdx1 - & /0.24d0,0.52d0,0.8d0,1.14d0,1.42d0,1.9d0,2.5d0,3d0,3.4d0/ -! - - real*8 cdy1(9) - data cdy1 - & /0.167d0,0.310d0,0.467d0,0.611d0,0.711d0,0.789d0,0.833d0, - & 0.866d0,0.888d0/ -! -! Fig.7 tapping without lip -! - real*8 cdx2(7) - data cdx2 - & /1.0d0,1.14d0,1.42d0,1.9d0,2.5d0,3.0d0,3.4d0/ - - real*8 cdy2(7) - data cdy2 - & /0.d0,0.122d0,0.377d0,0.7d0,0.766d0,0.769d0,0.772d0/ - - real*8 ps2,ps1,dab,ps2pt1,ps1pt1,cdy(15),cd,cdx(20), - & dabmax -! - ps2pt1=ps2/ps1 - dabmax=100.d0 -! - if(nummer.eq.0) then - if (curve.eq.1) then - index=9 - write(*,*) - write(*,*) 'Cd calculations will be performed using' - write(*,*) 'Cd-Kurven HP3 Schlitz;Kurve Nr. 1' - do i=1,index - cdx(i)=cdx1(i) - cdy(i)=cdy1(i) - enddo -! - elseif(curve.eq.2) then - index=7 - write(*,*) - write(*,*) 'Cd calculations will be performed using' - write(*,*) 'Cd-Kurven HP3 Schlitz;Kurve Nr. 2' - do i=1,index - cdx(i)=cdx2(i) - cdy(i)=cdy2(i) - enddo -! - elseif(curve.gt.2) then - write(*,*) - write(*,*) 'no characteristic available under this index' - write(*,*) 'cd is implicitely assumed equal to 1' - cd=1.d0 - return - endif -! -! psvptv ratio between the static pressure in the main canal -! and the total pressure in the main canal -! -! check whether ps1/pt1 less than 1 , if not then a warning is sent and -! the calculation will peroceed with an "oversized" dab -! - if(abs(1.d0-ps2pt1).le.dabmax*(1.d0-ps1pt1)) then - dab=(1.d0-ps2pt1)/(1.d0-ps1pt1) - else - dab=dabmax - write(*,*) 'in cd_bleedtapping.f: ps1/pt1=',ps1pt1 - write(*,*) 'the calculation will proceed with DAB=100.' - endif -! -! determination of cd with the caracteristics -! - call ident(cdx,dab,index,id) - if(id.eq.1) then - cd=cdy(1) - elseif(id.ge.index) then - cd=cdy(index) - else - cd=cdy(id)+(cdy(id+1)-cdy(id)) - & *(dab-cdx(id))/(cdx(id+1)-cdx(id)) - endif -! - else - if(abs(1.d0-ps2pt1).le.dabmax*(1.d0-ps1pt1)) then - dab=(1.d0-ps2pt1)/(1.d0-ps1pt1) - else - dab=dabmax - write(*,*) 'in cd_bleedtapping.f: ps1/pt1=',ps1pt1 - write(*,*) 'the calculation will proceed with DAB=100.' - endif - - call ident(x_tab,dab,nummer,id) - if(id.le.1d0) then - cd=y_tab(1) - elseif(id.ge.nummer) then - cd=y_tab(nummer) - else - cd=y_tab(id)+(y_tab(id+1)-y_tab(id)) - & *(dab-x_tab(id))/(x_tab(id+1)-x_tab(id)) - endif - endif - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_bragg.f calculix-ccx-2.3/ccx_2.1/src/cd_bragg.f --- calculix-ccx-2.1/ccx_2.1/src/cd_bragg.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_bragg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,136 +0,0 @@ -! -! this subroutine enables to calculate a compressibility correction factor -! following the results that can be found in: -! -! S.L.Bragg -! "Effect of conpressibility on the discharge coefficient of orifices -! and convergent nozzles" -! Journal of Mechanical engineering vol 2 No 1 1960 -! - subroutine cd_bragg(cd,p2p1,cdbragg) -! - implicit none -! - integer nx,ny,idx,idy,i,j -! - real*8 cd,p2p1,cdbragg,z1,z2,z3,z4,et,xi -! - real*8 cd_tab (12) - data cd_tab - & /0.457d0,0.500d0,0.550d0,0.600d0,0.650d0,0.700d0, - & 0.750d0,0.800d0,0.850d0,0.900d0,0.950d0,1.000d0/ -! - real*8 p2p1_tab (19) - data p2p1_tab - & /0.00d0,0.10d0,0.15d0,0.20d0,0.25d0,0.30d0,0.35d0,0.40d0, - & 0.45d0,0.50d0,0.55d0,0.60d0,0.65d0,0.70d0,0.75d0,0.80d0, - & 0.85d0,0.90d0,1.00d0/ -! - real*8 cd_bragg_tab(19,12) - data ((cd_bragg_tab(i,j),i=1,19),j=1,12) - & /0.754d0,0.735d0,0.724d0,0.712d0,0.701d0,0.688d0,0.672d0, - & 0.655d0,0.633d0,0.610d0,0.590d0,0.570d0,0.549d0,0.530d0, - & 0.514d0,0.500d0,0.488d0,0.477d0,0.454d0, -! - & 0.789d0,0.770d0,0.760d0,0.749d0,0.747d0,0.733d0,0.709d0, - & 0.691d0,0.672d0,0.650d0,0.628d0,0.606d0,0.588d0,0.572d0, - & 0.558d0,0.543d0,0.531d0,0.520d0,0.500d0, -! - & 0.833d0,0.815d0,0.805d0,0.796d0,0.783d0,0.771d0,0.758d0, - & 0.740d0,0.720d0,0.700d0,0.675d0,0.655d0,0.638d0,0.621d0, - & 0.607d0,0.592d0,0.580d0,0.569d0,0.550d0, -! - & 0.870d0,0.855d0,0.846d0,0.828d0,0.827d0,0.815d0,0.801d0, - & 0.786d0,0.769d0,0.749d0,0.725d0,0.704d0,0.685d0,0.670d0, - & 0.654d0,0.641d0,0.630d0,0.619d0,0.600d0, -! - & 0.902d0,0.890d0,0.882d0,0.875d0,0.867d0,0.855d0,0.842d0, - & 0.830d0,0.811d0,0.792d0,0.773d0,0.751d0,0.732d0,0.718d0, - & 0.700d0,0.689d0,0.678d0,0.668d0,0.650d0, -! - & 0.929d0,0.920d0,0.912d0,0.908d0,0.900d0,0.890d0,0.880d0, - & 0.869d0,0.852d0,0.835d0,0.815d0,0.794d0,0.778d0,0.761d0, - & 0.749d0,0.736d0,0.725d0,0.716d0,0.700d0, -! - & 0.952d0,0.946d0,0.940d0,0.936d0,0.930d0,0.921d0,0.913d0, - & 0.903d0,0.889d0,0.873d0,0.854d0,0.836d0,0.820d0,0.808d0, - & 0.796d0,0.785d0,0.775d0,0.766d0,0.750d0, -! - & 0.970d0,0.966d0,0.962d0,0.958d0,0.953d0,0.948d0,0.941d0, - & 0.935d0,0.923d0,0.909d0,0.890d0,0.874d0,0.860d0,0.849d0, - & 0.838d0,0.829d0,0.820d0,0.812d0,0.800d0, -! - & 0.983d0,0.9805d0,0.98d0,0.978d0,0.975d0,0.970d0,0.965d0, - & 0.958d0,0.950d0,0.949d0,0.926d0,0.911d0,0.900d0,0.890d0, - & 0.881d0,0.874d0,0.867d0,0.860d0,0.850d0, -! - & 0.992d0,0.991d0,0.990d0,0.989d0,0.988d0,0.985d0,0.981d0, - & 0.980d0,0.973d0,0.967d0,0.956d0,0.943d0,0.935d0,0.928d0, - & 0.920d0,0.915d0,0.910d0,0.907d0,0.900d0, -! - & 0.999d0,0.999d0,0.998d0,0.998d0,0.998d0,0.997d0,0.995d0, - & 0.992d0,0.990d0,0.988d0,0.981d0,0.975d0,0.970d0,0.964d0, - & 0.960d0,0.958d0,0.954d0,0.952d0,0.950d0, -! - & 1.000d0,1.000d0,1.000d0,1.000d0,1.000d0,1.000d0,1.000d0, - & 1.000d0,1.000d0,1.000d0,1.000d0,1.000d0,1.000d0,1.000d0, - & 1.000d0,1.000d0,1.000d0,1.000d0,1.000d0/ -! - nx=19 - ny=12 -! - call ident(p2p1_tab,p2p1,nx,idx) - call ident(cd_tab,cd,ny,idy) -! - if (idx.eq.0) then - if(idy.eq.0) then - cdbragg=cd_bragg_tab(1,1) - else - if(idy.eq.ny) then - cdbragg=cd_bragg_tab(1,ny) - else - cdbragg=cd_bragg_tab(1,idy)+(cd_bragg_tab(1,idy+1) - & -cd_bragg_tab(1,idy)) - & *(cd-cd_tab(idy))/(cd_tab(idy+1)-cd_tab(idy)) - endif - endif -! - elseif(idx.ge.nx) then - if(idy.le.0) then - cdbragg=cd_bragg_tab(nx,1) - else - if(idy.ge.ny) then - cdbragg=cd_bragg_tab(nx,ny) - else - cdbragg=cd_bragg_tab(nx,idy)+ - & (cd_bragg_tab(nx,idy+1)-cd_bragg_tab(nx,idy)) - & *(cd-cd_tab(idy))/(cd_tab(idy+1)-cd_tab(idy)) - endif - endif - else - if(idy.le.0) then -! - cdbragg=cd_bragg_tab(idx,1)+(cd_bragg_tab(idx+1,1) - & -cd_bragg_tab(idx,1)) - & *(p2p1-p2p1_tab(idx))/(p2p1_tab(idx+1) - & -p2p1_tab(idx)) - elseif(idy.ge.ny) then - cdbragg=cd_bragg_tab(idx,ny)+(cd_bragg_tab(idx+1,ny) - & -cd_bragg_tab(idx,ny)) - & *(p2p1-p2p1_tab(idx))/(p2p1_tab(idx+1) - & -p2p1_tab(idx)) - else - xi=(p2p1-p2p1_tab(idx))/(p2p1_tab(idx+1) - & -p2p1_tab(idx)) - et=(cd-cd_tab(idy))/(cd_tab(idy+1)-cd_tab(idy)) - z1=cd_bragg_tab(idx,idy) - z2=cd_bragg_tab(idx+1,idy) - z3=cd_bragg_tab(idx,idy+1) - z4=cd_bragg_tab(idx+1,idy+1) - cdbragg=(1-xi)*(1-et)*z1+(1-xi)*et*z3 - & +xi*(1-et)*z2+xi*et*z4 - endif - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_chamfer.f calculix-ccx-2.3/ccx_2.1/src/cd_chamfer.f --- calculix-ccx-2.1/ccx_2.1/src/cd_chamfer.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_chamfer.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine cd_chamfer(l,d,p_up,p_down,angle,cd) -! -! calculates the discharge coefficient of holes with chamfered inlets -! using N. Hay and A.Spencer -! "Disharge coefficient of Cooling holes with radiused and chamfered -! inlets" ASME 91-GT-269 -! -! Nota:the radius correction is not used here due to the unreliability -! of the results proposed check first line of table 1 -! - implicit none -! - integer i,j,idx,idy,nx,ny -! - real*8 l,d,p_up,p_down,angle,puzpd,lzd,xi,et,z1,z2,z3,z4, - & cd, tab_cd(3,4), tab30(3,4),tab45(3,4) -! - real*8 xpuzpd(3) - data xpuzpd /1.2d0,1.6d0,2.2d0/ -! - real*8 ylzd (4) - data ylzd /0.25d0,0.50d0,1.00d0,2.00d0/ -! - data ((tab30(i,j),i=1,3),j=1,4) - & /1.45d0,1.31d0,1.24d0, - & 1.35d0,1.28d0,1.21d0, - & 1.23d0,1.19d0,1.13d0, - & 1.20d0,1.18d0,1.10d0/ -! - data ((tab45(i,j),i=1,3),j=1,4) - & /1.19d0,1.19d0,1.16d0, - & 1.23d0,1.19d0,1.13d0, - & 1.14d0,1.11d0,1.07d0, - & 1.11d0,1.09d0,1.03d0/ -! - nx=3 - ny=4 -! - lzd=l/d - puzpd=p_up/p_down -! - call ident(xpuzpd,puzpd,nx,idx) - call ident(ylzd,lzd,ny,idy) -! - if (abs(angle-30.d0).le.0.1d0) then - do i=1,3 - do j=1,4 - tab_cd(i,j)=tab30(i,j) - enddo - enddo -! - elseif(abs(angle-45.d0).le.0.1d0) then - do i=1,3 - do j=1,4 - tab_cd(i,j)=tab45(i,j) - enddo - enddo - else - write(*,*) 'in cd_chamfer.f :unacceptable angle',angle,'grad' - stop - endif -! - if (idx.eq.0) then - if(idy.eq.0) then - cd=tab_cd(1,1) - else - if(idy.eq.ny) then - cd=tab_cd(1,ny) - else - cd=tab_cd(1,idy)+(tab_cd(1,idy+1)-tab_cd(1,idy)) - & *(lzd-ylzd(idy))/(ylzd(idy+1)-ylzd(idy)) - endif - endif -! - elseif(idx.ge.nx) then - if(idy.le.0) then - cd=tab_cd(nx,1) - else - if(idy.ge.ny) then - cd=tab_cd(nx,ny) - else - cd=tab_cd(1,idy)+(tab_cd(1,idy+1)-tab_cd(1,idy)) - & *(lzd-ylzd(idy))/(ylzd(idy+1)-ylzd(idy)) - endif - endif - else - if(idy.le.0) then - cd=tab_cd(idx,1)+(tab_cd(idx+1,1)-tab_cd(idx,1)) - & *(puzpd-xpuzpd(idx))/(xpuzpd(idx+1)-xpuzpd(idx)) - elseif(idy.ge.ny) then - cd=tab_cd(idx,ny)+(tab_cd(idx+1,ny)-tab_cd(idx,ny)) - & *(puzpd-xpuzpd(idx))/(xpuzpd(idx+1)-xpuzpd(idx)) - else - xi=(puzpd-xpuzpd(idx))/(xpuzpd(idx+1)-xpuzpd(idx)) - et=(lzd-ylzd(idy))/(ylzd(idy+1)-ylzd(idy)) - z1=tab_cd(idx,idy) - z2=tab_cd(idx+1,idy) - z3=tab_cd(idx,idy+1) - z4=tab_cd(idx+1,idy+1) - cd=(1-xi)*(1-et)*z1+(1-xi)*et*z3 - & +xi*(1-et)*z2+xi*et*z4 - endif - endif -! - write(*,*)'chamfer correction equals to',cd -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_lab_1spike.f calculix-ccx-2.3/ccx_2.1/src/cd_lab_1spike.f --- calculix-ccx-2.1/ccx_2.1/src/cd_lab_1spike.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_lab_1spike.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,117 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! -! this subroutine enables to calculate the discharge coefcieint of -! a labyrinth with one fin as a function of the ratio b/s and the -! pressure ratio Pdownstream/Pupstream -! the results are interpolated -! -! the relevant data can be found in: -! "Air System Correlations Part 1: Labyrinth Seals" -! H.Zimmermann and K.H. Wollf -! ASME 98-GT-206 -! fig 11 p 7 -! - subroutine cd_lab_1spike(pt0zps1,s,b,cd_1spike) -! - implicit none -! - integer nx,ny,idx,idy -! - real*8 pt0zps1,s,b,cd_1spike,z1,z2,z3,z4,xi,et,pdszpus,bzs -! - real*8 Pdszpus_tab(7) - data pdszpus_tab - & /0.400d0,0.500d0,0.555d0,0.625d0,0.714d0,0.833d0,1.000d0/ -! - real*8 bzs_tab(9) - data bzs_tab - & /0.250d0,0.285d0,0.330d0,0.400d0,0.5000d0,0.660d0,1d0,2d0,4d0/ -! - real*8 cd_1spike_tab(7,9) - data cd_1spike_tab - & /0.930d0,0.875d0,0.830d0,0.790d0,0.750d0,0.700d0,0.650d0, - & 0.930d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.660d0, - & 0.930d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.660d0, - & 0.918d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.670d0, - & 0.912d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.675d0, - & 0.900d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.687d0, - & 0.900d0,0.875d0,0.830d0,0.800d0,0.750d0,0.725d0,0.687d0, - & 0.912d0,0.875d0,0.862d0,0.837d0,0.800d0,0.785d0,0.743d0, - & 0.912d0,0.880d0,0.870d0,0.860d0,0.860d0,0.855d0,0.850d0/ - bzs=b/s - pdszpus=1/pt0zps1 - nx=7 - ny=9 -! - call ident(pdszpus_tab,pdszpus,nx,idx) - call ident(bzs_tab,bzs,ny,idy) -! - if (idx.eq.0) then - if(idy.eq.0) then - cd_1spike=cd_1spike_tab(1,1) - else - if(idy.eq.ny) then - cd_1spike=cd_1spike_tab(1,ny) - else - cd_1spike=cd_1spike_tab(1,idy)+(cd_1spike_tab(1,idy+1) - & -cd_1spike_tab(1,idy)) - & *(bzs-bzs_tab(idy))/(bzs_tab(idy+1)-bzs_tab(idy)) - endif - endif -! - elseif(idx.ge.nx) then - if(idy.le.0) then - cd_1spike=cd_1spike_tab(nx,1) - else - if(idy.ge.ny) then - cd_1spike=cd_1spike_tab(nx,ny) - else - cd_1spike=cd_1spike_tab(nx,idy)+ - & (cd_1spike_tab(nx,idy+1)-cd_1spike_tab(nx,idy)) - & *(bzs-bzs_tab(idy))/(bzs_tab(idy+1)-bzs_tab(idy)) - endif - endif - else - if(idy.le.0) then -! - cd_1spike=cd_1spike_tab(idx,1)+(cd_1spike_tab(idx+1,1) - & -cd_1spike_tab(idx,1)) - & *(pdszpus-pdszpus_tab(idx))/(pdszpus_tab(idx+1) - & -pdszpus_tab(idx)) - elseif(idy.ge.ny) then - cd_1spike=cd_1spike_tab(idx,ny)+(cd_1spike_tab(idx+1,ny) - & -cd_1spike_tab(idx,ny)) - & *(pdszpus-pdszpus_tab(idx))/(pdszpus_tab(idx+1) - & -pdszpus_tab(idx)) - else - xi=(pdszpus-pdszpus_tab(idx))/(pdszpus_tab(idx+1) - & -pdszpus_tab(idx)) - et=(bzs-bzs_tab(idy))/(bzs_tab(idy+1)-bzs_tab(idy)) - z1=cd_1spike_tab(idx,idy) - z2=cd_1spike_tab(idx+1,idy) - z3=cd_1spike_tab(idx,idy+1) - z4=cd_1spike_tab(idx+1,idy+1) - cd_1spike=(1-xi)*(1-et)*z1+(1-xi)*et*z3 - & +xi*(1-et)*z2+xi*et*z4 - endif - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_lab_cdrzcdlab.f calculix-ccx-2.3/ccx_2.1/src/cd_lab_cdrzcdlab.f --- calculix-ccx-2.1/ccx_2.1/src/cd_lab_cdrzcdlab.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_lab_cdrzcdlab.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! This subroutine is a dummy subroutine , to the knowledge of the authors -! no public source is available for such data -! - - subroutine cd_lab_cdrzcdlab (t,s,hst,x,p1,p2,cd_cdrzcdlab) -! - implicit none -! -! integer -! - real*8 t,s,hst,x,p1,p2,cd_cdrzcdlab -! - t=t - s=s - hst=hst - x=x - p1=p1 - p2=p2 - cd_cdrzcdlab=1.d0 -! - write(*,*) '*WARNING while using subroutine cd_lab_cdrzcdlab.f' - write(*,*) 'cd implicitely taken equal to 1' -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_lab_correction.f calculix-ccx-2.3/ccx_2.1/src/cd_lab_correction.f --- calculix-ccx-2.1/ccx_2.1/src/cd_lab_correction.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_lab_correction.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,130 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! -! this subroutine enables to calculate thecorrection factor of the discharge -! coefficient of a labyrinth with one fin as a function of the ratio b/s and the -! pressure ratio Pdownstream/Pupstream -! the results are interpolated -! -! the relevant data can be found in: -! "Air System Correlations Part 1: Labyrinth Seals" -! H.Zimmermann and K.H. Wollf -! ASME 98-GT-206 -! fig 12 p 7 -! - subroutine cd_lab_correction(p1p2,s,b,cd_correction) -! - implicit none -! - integer nx,ny,idx,idy -! - real*8 s,b,cd_correction,z1,z2,z3,z4,xi,et,szb,p1p2 -! - real*8 puszpds_tab(7) - data puszpds_tab - & /1.d0,1.2d0,1.4d0,1.6d0,1.8d0,2.d0,2.5d0/ -! - real*8 szb_tab(9) - data szb_tab - & /0.25d0,0.5d0,1.d0,1.5d0,2d0,2.5d0,3d0,3.5d0,4d0/ -! - real*8 cd_correction_tab(9,7) - data cd_correction_tab - & /1.05d0,1.07d0,1.03d0,0.98d0,0.95d0,0.94d0,0.95d0,0.95d0,0.95d0, - & 1.15d0,1.07d0,1.02d0,0.95d0,0.92d0,0.91d0,0.91d0,0.92d0,0.92d0, - & 1.15d0,1.05d0,0.98d0,0.91d0,0.88d0,0.86d0,0.86d0,0.87d0,0.87d0, - & 1.15d0,1.04d0,0.95d0,0.87d0,0.85d0,0.84d0,0.83d0,0.83d0,0.83d0, - & 1.15d0,1.03d0,0.91d0,0.85d0,0.81d0,0.80d0,0.80d0,0.80d0,0.80d0, - & 1.15d0,1.01d0,0.90d0,0.82d0,0.79d0,0.79d0,0.77d0,0.77d0,0.77d0, - & 1.10d0,1.00d0,0.88d0,0.79d0,0.75d0,0.74d0,0.73d0,0.72d0,0.70d0/ -! - szb=s/b -! - nx=9 - ny=7 -! -! p1p2=1/p2p1 -! if ((p1p2.ge.2.5d0).or.(szb.ge.4d0))then -! write(*,*) '*WARNING in cd_lab_correction' -! write(*,*) 'p1p2>2.5 or szb>4' -! write(*,*) 'check input file' -! write(*,*) 'calculation will proceed using cd_lab_correction=1' -! cd_correction=1.d0 -! return -! endif -! - call ident(puszpds_tab,p1p2,ny,idy) - call ident(szb_tab,szb,nx,idx) -! - if (idx.eq.0) then - if(idy.eq.0) then - cd_correction=cd_correction_tab(1,1) - else - if(idy.eq.ny) then - cd_correction=cd_correction_tab(1,ny) - else - cd_correction=cd_correction_tab(1,idy) - & +(cd_correction_tab(1,idy+1)-cd_correction_tab(1,idy)) - & *(szb-szb_tab(idx))/(szb_tab(idx+1)-szb_tab(idx)) - endif - endif -! - elseif(idx.ge.nx) then - if(idy.le.0) then - cd_correction=cd_correction_tab(nx,1) - else - if(idy.ge.ny) then - cd_correction=cd_correction_tab(nx,ny) - else - cd_correction=cd_correction_tab(nx,idy) - & +(cd_correction_tab(nx,idy+1)-cd_correction_tab(nx,idy)) - & *(szb-szb_tab(idx))/(szb_tab(idx+1)-szb_tab(idx)) - endif - endif - else - if(idy.le.0) then -! - cd_correction=cd_correction_tab(idx,1) - & +(cd_correction_tab(idx+1,1)-cd_correction_tab(idx,1)) - & *(p1p2-puszpds_tab(idy))/(puszpds_tab(idy+1) - & -puszpds_tab(idy)) - elseif(idy.ge.ny) then - cd_correction=cd_correction_tab(idx,ny) - & +(cd_correction_tab(idx+1,ny)-cd_correction_tab(idx,ny)) - & *(p1p2-puszpds_tab(idy))/(puszpds_tab(idy+1) - & -puszpds_tab(idy)) - else - et=(p1p2-puszpds_tab(idy))/(puszpds_tab(idy+1) - & -puszpds_tab(idy)) - xi=(szb-szb_tab(idx))/(szb_tab(idx+1)-szb_tab(idx)) - z1=cd_correction_tab(idx,idy) - z2=cd_correction_tab(idx+1,idy) - z3=cd_correction_tab(idx,idy+1) - z4=cd_correction_tab(idx+1,idy+1) - cd_correction=(1-xi)*(1-et)*z1+(1-xi)*et*z3 - & +xi*(1-et)*z2+xi*et*z4 - endif - endif -! -! if (cd_correction.ge.1.d0)then -! cd_correction=1.d0 -! endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_lab_honeycomb.f calculix-ccx-2.3/ccx_2.1/src/cd_lab_honeycomb.f --- calculix-ccx-2.1/ccx_2.1/src/cd_lab_honeycomb.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_lab_honeycomb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! This subroutine enables to calculate the correction factor for a labyrinth seal -! wit a honeycomb stator -! s= gap, hl= width of a honeycomb cell -! the correction factors are interpolated from a table -! -! H.Zimmermann and K.h. Wolff -! "Air system correlations part 1 Labyrinth seals" -! asme 98-GT-206 -! - subroutine cd_lab_honeycomb(s,lc,cd_honeycomb) -! - implicit none -! - integer id -! - real*8 s,lc,cd_honeycomb,szlc -! -! lc=1/8 inch -! - real*8 szl(11) - data szl - & /0.05d0,0.06d0,0.075d0,0.081d0,0.1d0,0.13d0,0.15d0,0.16d0, - & 0.20d0,0.30d0,0.40d0/ -! - real*8 deltamp(11) - data deltamp - & /97.1d0,40d0,32d0,23d0,20d0,0d0,-3.3d0,-5.7d0,-8.5d0, - & -11.43d0,-12d0/ -! -! extrapolation - szlc=s/lc -! if (szlc.gt.0.40d0) then -! cd_honeycomb=deltamp(11) -! endif -! -! intrapolation -! - call ident(szl,szlc,11,id) -! call ident(yz,q,11,idy) - if(id.eq.1) then - cd_honeycomb=deltamp(1) - elseif(id.eq.11) then - cd_honeycomb=deltamp(11) - else - cd_honeycomb=deltamp(id)+(deltamp(id+1)-deltamp(id)) - & *(szlc-szl(id))/(szl(id+1)-szl(id)) - endif -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_lab_radius.f calculix-ccx-2.3/ccx_2.1/src/cd_lab_radius.f --- calculix-ccx-2.1/ccx_2.1/src/cd_lab_radius.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_lab_radius.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,90 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! This subroutines enables to caclulate a correction term linked to with the radius -! of the spike as a function of r/s (radius/gap) -! the parameter Hst ( height of the step ) enable to select either the table for a -! straight labyrinth (Hst=0) or for a stepped labyrinth -! -! H.Zimmermann and K.h. Wolff -! "Air system correlations part 1 Labyrinth seals" -! asme 98-GT-206 -! - subroutine cd_lab_radius(rad,s,hst,cd_radius) -! - implicit none -! - integer id,i,number -! - real*8 rad,s,cd_radius,rzs_tab(9),cd_sharp(9),rzs,hst -! - real*8 rzs_tab1(9) - data rzs_tab1 - & /0d0,0.05d0,0.100d0,0.150d0,0.200d0,0.250d0,0.300d0,0.350d0, - & 0.400d0/ -! - real*8 cd_sharp1(9) - data cd_sharp1 - & /1d0,1.025d0,1.10d0,1.11d0,1.12d0,1.125d0,1.126d0,1.127d0, - & 1.127d0/ -! - real*8 rzs_tab2(9) - data rzs_tab2 - & /0d0,0.05d0,075d0,0.100d0,0.15d0,0.20d0,0.25d0,0.30d0,0.40d0/ -! - real*8 cd_sharp2(9) - data cd_sharp2 - & /1d0,1.10d0,1.15d0,1.20d0,1.26d0,1.31d0,1.34d0,1.36d0,1.37d0/ -! - rzs=rad/s -! -! straight labyrinth -! - if(hst.eq.0d0) then - call ident(rzs_tab1,rzs,9,id) - number=9 - do i=1,9 - rzs_tab(i)=rzs_tab1(i) - cd_sharp(i)=cd_sharp1(i) - enddo -! -! stepped labyrinth -! - else - call ident(rzs_tab2,rzs,9,id) - number=9 - do i=1,9 - rzs_tab(i)=rzs_tab2(i) - cd_sharp(i)=cd_sharp2(i) - enddo - endif -! -! linear interpolation -! -! - if(id.eq.1) then - cd_radius=cd_sharp(1) - elseif(id.eq.number) then - cd_radius=cd_sharp(number) - else - cd_radius=cd_sharp(id)+(cd_sharp(id+1)-cd_sharp(id)) - & *(rzs-rzs_tab(id))/(rzs_tab(id+1)-rzs_tab(id)) - endif -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_lab_reynolds.f calculix-ccx-2.3/ccx_2.1/src/cd_lab_reynolds.f --- calculix-ccx-2.1/ccx_2.1/src/cd_lab_reynolds.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_lab_reynolds.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! this subroutine enables to calculate the discharge coefficient of a stepped labyrinth seal -! as a function of the reynolds number, the ratios s/l ,r/b and p1/p2 -! -! the related data can be found in -! "Some aerodynamic Aspects of Engine Secondary air systems" -! H. Zimmermann -! ASME 89-GT-209 -! Table p 7 -! - subroutine cd_lab_reynolds(reynolds,cd_reynolds) -! - implicit none -! - integer id -! - real*8 reynolds , cd_reynolds -! - real*8 tab_reynolds(6) - data tab_reynolds - & /220.d0,630.d0,1260d0,2300d0,3200d0,4300d0/ -! - real*8 tab_cd(6) - data tab_cd - & / 0.32d0,0.39d0,0.44d0,0.49d0,0.25d0,0.54d0/ - - call ident(tab_reynolds,reynolds,6,id) - - if(id.eq.1) then - cd_reynolds=tab_cd(1) - elseif(id.eq.18) then - cd_reynolds=tab_cd(6) - else - cd_reynolds=tab_cd(id)+(tab_cd(id+1)-tab_cd(id)) - & *(reynolds-tab_reynolds(id)) - & /(tab_reynolds(id+1)-tab_reynolds(id)) - endif -! - return -! - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_lab_straight.f calculix-ccx-2.3/ccx_2.1/src/cd_lab_straight.f --- calculix-ccx-2.1/ccx_2.1/src/cd_lab_straight.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_lab_straight.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,227 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! this subroutine enables to calculate the dicharge coefficient -! for a labyrinth with more than one spike -! as a function of the number of spikes(n), the pressure ratio (p2p1), -! the ratio between the gap and the breadth of the spike (s/b), -! the number of reynolds (reynolds) -! -! H.Zimmermann and K.h. Wolff -! "Air system correlations part 1 Labyrinth seals" -! asme 98-GT-206 -! - subroutine cd_lab_straight (n,p2p1,s,b,reynolds,cd_lab) -! - implicit none -! - integer i,j,n,idx,idy,nx,ny -! - real*8 szb,p2p1,p1p2,s,b,reynolds,cd_lab,z1,z2,z3,z4, - & et,xi -! - real*8 szb1(3) - data szb1 - & /0.230000d0,0.440000d0,0.830000d0/ -! - real*8 reynlds1(21) - data reynlds1 - & /100.0d0,200.0d0,300.d0,400.0d0,500.00d0,1000.0d0, - & 2000.d0,3000.d0,5000.d0,7000.d0,9000.d0,11000.d0,13000.d0, - & 15000.d0,18000.d0,21000.d0,25000.d0,30000.d0,35000.d0, - & 40000.d0,50000.d0/ -! - real*8 tcd1(3,21) - data ((tcd1(i,j),i=1,3),j=1,21) - & /0.470d0,0.330d0,0.230d0, - & 0.500d0,0.365d0,0.274d0, - & 0.517d0,0.385d0,0.300d0, - & 0.520d0,0.400d0,0.320d0, - & 0.530d0,0.415d0,0.333d0, - & 0.550d0,0.449d0,0.376d0, - & 0.575d0,0.483d0,0.420d0, - & 0.590d0,0.500d0,0.450d0, - & 0.607d0,0.530d0,0.480d0, - & 0.620d0,0.550d0,0.500d0, - & 0.625d0,0.565d0,0.515d0, - & 0.630d0,0.570d0,0.527d0, - & 0.630d0,0.580d0,0.540d0, - & 0.630d0,0.585d0,0.555d0, - & 0.630d0,0.589d0,0.565d0, - & 0.630d0,0.589d0,0.576d0, - & 0.630d0,0.590d0,0.580d0, - & 0.630d0,0.590d0,0.588d0, - & 0.630d0,0.590d0,0.590d0, - & 0.630d0,0.590d0,0.590d0, - & 0.630d0,0.590d0,0.590d0/ -! - real*8 szb2(3) - data szb2 - & /0.230000d0,0.440000d0,0.830000d0/ -! - real*8 reynlds2(21) - data reynlds2 - & /100.0d0,200.0d0,300.d0,400.0d0,500.00d0,1000.0d0, - & 2000.d0,3000.d0,5000.d0,7000.d0,9000.d0,11000.d0,13000.d0, - & 15000.d0,18000.d0,21000.d0,25000.d0,30000.d0,35000.d0, - & 40000.d0,50000.d0/ -! - real*8 tcd2(3,21) - data ((tcd2(i,j),i=1,3),j=1,21) - & /0.400d0,0.335d0,0.250d0, - & 0.445d0,0.390d0,0.308d0, - & 0.470d0,0.420d0,0.340d0, - & 0.490d0,0.440d0,0.360d0, - & 0.505d0,0.455d0,0.380d0, - & 0.550d0,0.500d0,0.442d0, - & 0.600d0,0.555d0,0.500d0, - & 0.625d0,0.580d0,0.525d0, - & 0.650d0,0.615d0,0.570d0, - & 0.660d0,0.640d0,0.600d0, - & 0.660d0,0.650d0,0.617d0, - & 0.660d0,0.655d0,0.635d0, - & 0.660d0,0.657d0,0.645d0, - & 0.660d0,0.660d0,0.650d0, - & 0.660d0,0.660d0,0.655d0, - & 0.660d0,0.660d0,0.660d0, - & 0.660d0,0.660d0,0.660d0, - & 0.660d0,0.660d0,0.660d0, - & 0.660d0,0.660d0,0.660d0, - & 0.660d0,0.660d0,0.660d0, - & 0.660d0,0.660d0,0.660d0/ -! - p1p2=1/p2p1 - szb=s/b -! -! which table is to be used? -! - if(n.le.2) then -! cd is interpolated in tcd1 -! - nx=3 - ny=22 -! interpolation in the 2d table. -! - call ident(szb1,szb,nx,idx) - call ident(reynlds1,reynolds,ny,idy) -! - if (idx.eq.0) then - if(idy.eq.0) then - cd_lab=tcd1(1,1) - else - if(idy.eq.ny) then - cd_lab=tcd1(1,ny) - else - cd_lab=tcd1(1,idy)+(tcd1(1,idy+1)-tcd1(1,idy)) - & *(reynolds-reynlds1(idy)) - & /(reynlds1(idy+1)-reynlds1(idy)) - endif - endif -! - elseif(idx.ge.nx) then - if(idy.le.0) then - cd_lab=tcd1(nx,1) - else - if(idy.ge.ny) then - cd_lab=tcd1(nx,ny) - else - cd_lab=tcd1(nx,idy)+(tcd1(nx,idy+1)-tcd1(nx,idy)) - & *(reynolds-reynlds1(idy)) - & /(reynlds1(idy+1)-reynlds1(idy)) - endif - endif - else - if(idy.le.0) then - - cd_lab=tcd1(idx,1)+(tcd1(idx+1,1)-tcd1(idx,1)) - & *(szb-szb1(idx))/(szb1(idx+1)-szb1(idx)) - elseif(idy.ge.ny) then - cd_lab=tcd1(idx,ny)+(tcd1(idx+1,ny)-tcd1(idx,ny)) - & *(szb-szb1(idx))/(szb1(idx+1)-szb1(idx)) - else - xi=(szb-szb1(idx))/(szb1(idx+1)-szb1(idx)) - et=(reynolds-reynlds1(idy))/ - & (reynlds1(idy+1)-reynlds1(idy)) - z1=tcd1(idx,idy) - z2=tcd1(idx+1,idy) - z3=tcd1(idx,idy+1) - z4=tcd1(idx+1,idy+1) - cd_lab=(1-xi)*(1-et)*z1+(1-xi)*et*z3 - & +xi*(1-et)*z2+xi*et*z4 - endif - endif -! - else -! cd is interpolated in tcd2 -! - nx=3 - ny=21 -! interpolation in the 2d table. -! - call ident(szb2,szb,nx,idx) - call ident(reynlds2,reynolds,ny,idy) -! - if (idx.eq.0) then - if(idy.eq.0) then - cd_lab=tcd2(1,1) - else - if(idy.eq.ny) then - cd_lab=tcd2(1,ny) - else - cd_lab=tcd2(1,idy)+(tcd2(1,idy+1)-tcd2(1,idy)) - & *(reynolds-reynlds2(idy)) - & /(reynlds2(idy+1)-reynlds2(idy)) - endif - endif -! - elseif(idx.ge.nx) then - if(idy.le.0) then - cd_lab=tcd2(nx,1) - else - if(idy.ge.ny) then - cd_lab=tcd2(nx,ny) - else - cd_lab=tcd2(nx,idy)+(tcd2(nx,idy+1)-tcd2(nx,idy)) - & *(reynolds-reynlds2(idy)) - & /(reynlds2(idy+1)-reynlds2(idy)) - endif - endif - else - if(idy.le.0) then - - cd_lab=tcd2(idx,1)+(tcd2(idx+1,1)-tcd2(idx,1)) - & *(szb-szb2(idx))/(szb2(idx+1)-szb2(idx)) - elseif(idy.ge.ny) then - cd_lab=tcd2(idx,ny)+(tcd2(idx+1,ny)-tcd2(idx,ny)) - & *(szb-szb2(idx))/(szb2(idx+1)-szb2(idx)) - else - xi=(szb-szb2(idx))/(szb2(idx+1)-szb2(idx)) - et=(reynolds-reynlds2(idy))/ - & (reynlds2(idy+1)-reynlds2(idy)) - z1=tcd2(idx,idy) - z2=tcd2(idx+1,idy) - z3=tcd2(idx,idy+1) - z4=tcd2(idx+1,idy+1) - cd_lab=(1-xi)*(1-et)*z1+(1-xi)*et*z3 - & +xi*(1-et)*z2+xi*et*z4 - endif - endif -! - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_lichtarowicz.f calculix-ccx-2.3/ccx_2.1/src/cd_lichtarowicz.f --- calculix-ccx-2.1/ccx_2.1/src/cd_lichtarowicz.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_lichtarowicz.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! This subroutines enables to calculate the reynolds number correction after: -! "Discharge coeffcients for incompressible non-cavitating flowthrough long orifices" -! A. Lichtarowicz, R.K duggins and E. Markland -! Journal Mechanical Engineering Science , vol 7, No. 2, 1965 -! - subroutine cd_lichtarowicz(cd,cdu,reynolds,amod,bdh) -! - implicit none -! -! integer -! - real*8 cdu,reynolds,amod,bdh,eps,A1,cd_diff,cd0,cd -! - cd0=cdu - cd_diff=1.d0 -! - do 10 while (cd_diff.ge.1E-3) -! - cd=cd0 - A1=20/(reynolds*dsqrt(1.d0-Amod**2))*(1.d0+2.25d0*bdh) - eps=(0.005d0*bdh)/(1.d0+7.5d0*(log10(0.00015d0*reynolds* - & dsqrt(1.d0-Amod**2)/cd))**2) - - cd=((-1/cdu+eps)+dsqrt((1/cdu-eps)**2.d0+4.d0*A1))/(2*A1) -! - cd_diff=dabs(cd-cd0) -! - cd0=cd -! - 10 continue -! write(*,*) 'lichtarowitz correction cd=',cd -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_Mcgreehan_Schotsch.f calculix-ccx-2.3/ccx_2.1/src/cd_Mcgreehan_Schotsch.f --- calculix-ccx-2.1/ccx_2.1/src/cd_Mcgreehan_Schotsch.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_Mcgreehan_Schotsch.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! -! this subroutine enables to calculate the basis incompressible -! discharge coefficient -! -! "Flow Characteristics of long orifices with rotation and corner radiusing" -! W.F. Mcgreehan and M.J. Schotsch -! ASME 87-GT-162 - - subroutine cd_Mcgreehan_Schotsch(rzdh,bdh,reynolds,cdu) -! - implicit none -! - real*8 cdu,bdh,reynolds,cd_re,rzdh,cd_r -! - cd_re=0.5885d0+372d0/reynolds -! -! the radius correction -! - cd_r=1-(0.008d0+0.992d0*exp(-5.5d0*rzdh-3.5d0*rzdh**2)) - & *(1-cd_re) -! - cdu=1.d0-(1.d0-cd_r)*(1d0+1.3d0*exp(-1.606d0*(bdh*bdh))) - & *(0.435d0+0.021d0*bdh) -! - return -! - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_ms_ms.f calculix-ccx-2.3/ccx_2.1/src/cd_ms_ms.f --- calculix-ccx-2.1/ccx_2.1/src/cd_ms_ms.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_ms_ms.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,75 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine cd_ms_ms(p1,p2,T1,rad,d,xl,kappa,r,reynolds,u,vid,cd) -! -! This subroutine enables to calculate the discharge coefficient for an -! orifice (shap edged , rotating..) following the results obtained -! by Mcgreehan and Schotsch -! The decription of the method can be found in : -! "Flow characteristics of long orifices with rotation and -! corner radiusing" -! ASME 87-GT-162 -! - implicit none -! - real*8 p1,p2,T1,rad,d,xl,kappa,r,reynolds,u,cd,qlim,q, - & c1,c2,c3,fakt,aux,rzd,lkorr,qkorr,rv,vid -! - qlim=10.d0 -! -! taking in account the influence of the Reynolds number -! - cd=0.5885d0+372.d0/reynolds - cd=min(cd,1.d0) -! -! taking in account the edge radius -! - rzd=rad/d - aux=exp(-(3.5d0*rzd+5.5d0)*rzd) - fakt=aux+0.008d0*(1.d0-aux) - cd=1.d0-fakt*(1.d0-cd) - cd=min(max(cd,0.d0),1.d0) -! -! taking in account the lenght of the orifice -! - lkorr=xl-rad - q=lkorr/d - qkorr=min(q,qlim) - fakt=(1.d0+1.3d0*exp(-1.606d0*qkorr**2.d0))* - & (0.435d0+0.021d0*qkorr)/(2.3d0*0.435d0) - cd=1.d0-fakt*(1.d0-cd) - cd=min(max(cd,0.d0),1.d0) -! -! taking in account the tangential velocity -! - if(u.ne.0d0) then - vid=dsqrt(2.d0*kappa/(kappa-1.d0)*r*T1* - & (1.d0-(p2/p1)**((kappa-1.d0)/kappa))) - rv=u/vid*(0.6d0/cd)**3 - c1=exp(-rv**1.2d0) - c2=0.5d0*rv**0.6d0*dsqrt(0.6d0/cd) - c3=exp(-0.5d0*rv**0.9d0) - cd=cd*(c1+c2*c3) - cd=min(max(cd,0.d0),1.d0) -! - endif -! -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_own_albers.f calculix-ccx-2.3/ccx_2.1/src/cd_own_albers.f --- calculix-ccx-2.1/ccx_2.1/src/cd_own_albers.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_own_albers.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine cd_own_albers(p1,p2,xl,d,cd,u,T1,R,kappa) -! - real*8 d,xl,p1,p2,cd,T1,R,kappa,u -! - p1=p1 - p2=p2 - xl=xl - d=d - u=u - T1=T1 - R=R - kappa=Kappa - cd=1.d0 - write(*,*) '*WARNING while using subroutine cd_own_albers.f' - write(*,*) 'cd implicitely taken equal to 1' - -! - return -! - end - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_pk_albers.f calculix-ccx-2.3/ccx_2.1/src/cd_pk_albers.f --- calculix-ccx-2.1/ccx_2.1/src/cd_pk_albers.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_pk_albers.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine cd_pk_albers(rad,d,xl,reynolds,p2,p1,beta,kappa,cd,u, - & T1,R) -! - implicit none -! - real*8 rad,d,xl,reynolds,p2,p1,beta,kappa, - & cd,R,u,T1 -! - rad=rad - d=d - xl=xl - reynolds=reynolds - p2=p2 - p1=p1 - beta=beta - kappa=kappa - R=R - u=u - T1=T1 - - - cd=1.d0 - - write(*,*) '*WARNING while using subroutine cd_pk_albers.f' - write(*,*) 'cd implicitely taken equal to 1' -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_pk_ms.f calculix-ccx-2.3/ccx_2.1/src/cd_pk_ms.f --- calculix-ccx-2.1/ccx_2.1/src/cd_pk_ms.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_pk_ms.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine cd_pk_ms(rad,d,xl,reynolds,p2,p1,beta,kappa,cd,u, - & T1,R) -! -! This subroutines enable to calculate the compressible discharge -! coefficient for thin and long orifices with corner radiusing; -! - implicit none -! - real*8 rad,d,xl,lqd,rqd,reynolds,p2,p1,p2p1,beta,beta_cor,kappa, - & cd,cdc_cl1,cdc_cl3,rldb,R,u,T1,c1,c2, - & c3,ms_cdr,rv,vid -! - p2p1=p2/p1 - rqd=rad/d - lqd=xl/d - rldb=max(lqd,0.d0) -! -! the method of cd calculation for a sharp edged aperture is only valid -! for beta comprised between 0 and 0.7 -! - if (beta.gt.0.7d0) then - beta_cor=0.7d0 - else - beta_cor=beta - endif -! -! differences between class1 or class2 or class3 -! - if (lqd.eq.rqd) then -! -! class1 -! - call pk_cdc_cl1(lqd,reynolds,p2p1,beta_cor,kappa,cdc_cl1) - cd=cdc_cl1 - else -! -! class2 or class3 (clas2 is a sub class of class3 ) -! - call pk_cdc_cl3(lqd,rqd,reynolds,p2p1,beta_cor,kappa,cdc_cl3) - cd=cdc_cl3 - endif -! -! if rotating orifice with Mac Greehan & Scotch -! The decription of the method can be found in : -! "Flow characteristics of long orifices with rotation and -! corner radiusing" ASME 87-GT-16 -! -! rotating case eq 17 - - if (u.ne.0) then - vid=dsqrt(2.d0*kappa/(kappa-1.d0)*R*T1* - & (1.d0-p2/p1**((kappa-1.d0)/kappa))) - rv=1000*u/vid*(cd/0.6)**(-3) - c1=exp(-rv**1.2d0) - c2=0.5*rv**(0.6d0)*(cd/0.6)**(-0.5d0) - c3=exp(-0.5d0*rv**0.9d0) - ms_cdr=cd*(c1+c2*c3) - cd=ms_cdr - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/cd_preswirlnozzle.f calculix-ccx-2.3/ccx_2.1/src/cd_preswirlnozzle.f --- calculix-ccx-2.1/ccx_2.1/src/cd_preswirlnozzle.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cd_preswirlnozzle.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! this function enable to determine the discharge coefficient of -! preswirl nozzles -! - subroutine cd_preswirlnozzle(ps2,pt1,number,curve,x_tab,y_tab,cd) -! -! -! in : SImultation of the secondary air system of aero engines -! K.J.KUTZ T.M. SPEER -! Transactions of the ASME vol.116 April 1994 -! - implicit none -! - integer id,number,curve -! - real*8 x_tab(15),y_tab(15) -! - real*8 cdxp(11) - data cdxp - & /0.4d0,0.45d0,0.50d0,0.55d0,0.60d0,0.65d0,0.70d0,0.75d0, - & 0.80d0,0.85d0,0.90d0/ -! - real*8 cdyp(11) - data cdyp - & /0.942d0,0.939d0,0.932d0,0.929d0,0.925d0,0.921d0,0.917d0, - & 0.910d0,0.899d0,0.881d0,0.873d0/ -! -! determination of cd with the caracteristics by interpolation -! - real*8 ps2,pt1,ps2vpt1,cd -! - ps2vpt1=ps2/pt1 - if(number.eq.0) then - call ident(cdxp,ps2vpt1,11,id) - if(id.eq.0.6d0) then - cd=cdyp(1) - elseif(id.ge.1) then - cd=cdyp(11) - else - cd=cdyp(id)+(cdyp(id+1)-cdyp(id)) - & *(ps2vpt1-cdxp(id))/(cdxp(id+1)-cdxp(id)) - endif - else - call ident(x_tab,ps2vpt1,number,id) - if(id.le.1d0) then - cd=y_tab(1) - elseif(id.ge.15) then - cd=y_tab(15) - else - cd=y_tab(id)+(y_tab(id+1)-y_tab(id)) - & *(ps2vpt1-x_tab(id))/(x_tab(id+1)-x_tab(id)) - endif - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cfluxes.f calculix-ccx-2.3/ccx_2.1/src/cfluxes.f --- calculix-ccx-2.1/ccx_2.1/src/cfluxes.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cfluxes.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,206 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine cfluxes(inpc,textpart,set,istartset,iendset, - & ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, - & amname,nam,ntrans,trab,inotr,co,ikforc,ilforc,nk, - & cflux_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_, - & namtot_,namta,amta,iaxial,ipoinpc) -! -! reading the input deck: *CFLUX -! - implicit none -! - logical cflux_flag,user,add -! - character*1 inpc(*) - character*80 amplitude,amname(*) - character*81 set(*),noset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),nodeforc(2,*), - & nset,nforc,nforc_,istep,istat,n,i,j,k,l,iforcdir,key, - & iamforc(*),nam,iamplitude,ntrans,inotr(2,*),ipos,ikforc(*), - & ilforc(*),nk,iline,ipol,inl,ipoinp(2,*),inp(3,*),nam_,namtot, - & namtot_,namta(3,*),idelay,ndirforc(*),isector,iaxial, - & ipoinpc(0:*) -! - real*8 xforc(*),forcval,co(3,*),trab(7,*),amta(2,*) -! - iamplitude=0 - idelay=0 - user=.false. - add=.false. - isector=0 -! - if(istep.lt.1) then - write(*,*) '*ERROR in cfluxes: *CFLUX should only be used' - write(*,*) ' within a STEP' - stop - endif -! - do i=2,n - if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.cflux_flag)) then - do j=1,nforc - if(ndirforc(j).eq.0) xforc(j)=0.d0 - enddo - elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then - read(textpart(i)(11:90),'(a80)') amplitude - do j=nam,1,-1 - if(amname(j).eq.amplitude) then - iamplitude=j - exit - endif - enddo - if(j.gt.nam) then - write(*,*)'*ERROR in cfluxes: nonexistent amplitude' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iamplitude=j - elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN - if(idelay.ne.0) then - write(*,*) '*ERROR in cfluxes: the parameter TIME DELAY' - write(*,*) ' is used twice in the same keyword' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - else - idelay=1 - endif - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in cfluxes: increase nam_' - stop - endif - amname(nam)=' - & ' - if(iamplitude.eq.0) then - write(*,*) '*ERROR in cfluxes: time delay must be' - write(*,*) ' preceded by the amplitude parameter' - stop - endif - namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) - iamplitude=nam - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) '*ERROR cfluxes: increase namtot_' - stop - endif - namta(1,nam)=namtot - namta(2,nam)=namtot - read(textpart(i)(11:30),'(f20.0)',iostat=istat) - & amta(1,namtot) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:4).eq.'USER') then - user=.true. - elseif(textpart(i)(1:3).eq.'ADD') then - add=.true. - endif - enddo -! - if(user.and.(iamplitude.ne.0)) then - write(*,*) '*WARNING: no amplitude definition is allowed' - write(*,*) ' for heat fluxes defined by a' - write(*,*) ' user routine' - iamplitude=0 - endif -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return -! - read(textpart(2)(1:10),'(i10)',iostat=istat) iforcdir - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if((iforcdir.ne.0).and.(iforcdir.ne.11)) then - write(*,*) '*ERROR in cfluxes: nonexistent degree of ' - write(*,*) ' freedom. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iforcdir=0 -! - if(textpart(3)(1:1).eq.' ') then - forcval=0.d0 - else - read(textpart(3)(1:20),'(f20.0)',iostat=istat) forcval - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(iaxial.ne.0) forcval=forcval/iaxial - endif -! -! dummy flux consisting of the first primes -! - if(user) forcval=1.2357111317d0 -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - if(l.gt.nk) then - write(*,*) '*ERROR in cfluxes: node ',l - write(*,*) ' is not defined' - stop - endif - call forcadd(l,iforcdir,forcval, - & nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, - & iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc, - & isector,add) - else - read(textpart(1)(1:80),'(a80)',iostat=istat) noset - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - do i=1,nset - if(set(i).eq.noset) exit - enddo - if(i.gt.nset) then - noset(ipos:ipos)=' ' - write(*,*) '*ERROR in cfluxes: node set ',noset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - call forcadd(ialset(j),iforcdir,forcval, - & nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, - & iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc, - & isector,add) - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - call forcadd(k,iforcdir,forcval, - & nodeforc,ndirforc,xforc,nforc,nforc_, - & iamforc,iamplitude,nam,ntrans,trab,inotr,co, - & ikforc,ilforc,isector,add) - enddo - endif - enddo - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/cflux.f calculix-ccx-2.3/ccx_2.1/src/cflux.f --- calculix-ccx-2.1/ccx_2.1/src/cflux.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cflux.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine cflux(flux,msecpt,kstep,kinc,time,node,coords,vold, - & mi) -! -! user subroutine cflux -! -! -! INPUT: -! -! msecpt number of flux values (for volume elements:1) -! kstep step number -! kinc increment number -! time(1) current step time -! time(2) current total time -! node node number -! coords(1..3) global coordinates of the node -! vold(0..4,1..nk) solution field in all nodes -! 0: temperature -! 1: displacement in global x-direction -! 2: displacement in global y-direction -! 3: displacement in global z-direction -! 4: static pressure -! mi(1) max # of integration points per element (max -! over all elements) -! mi(2) max degree of freedomm per node (max over all -! nodes) in fields like v(0:mi(2))... -! -! OUTPUT: -! -! flux(1..msecpt) concentrated flux in the node -! - implicit none -! - integer msecpt,kstep,kinc,node,mi(2) - real*8 flux(msecpt),time(2),coords(3),vold(0:mi(2),*) -! - flux(1)=10.d0 -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/changedepterm.f calculix-ccx-2.3/ccx_2.1/src/changedepterm.f --- calculix-ccx-2.1/ccx_2.1/src/changedepterm.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/changedepterm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine changedepterm(ikmpc,ilmpc,nmpc,mpc,idofrem,idofins) -! -! changes the dependent term in ikmpc and ilmpc for MPC mpc. -! - implicit none -! - integer ikmpc(*),ilmpc(*),nmpc,idofrem,idofins,id,k,mpc -! -! remove MPC from ikmpc -! - call nident(ikmpc,idofrem,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idofrem) then - do k=id+1,nmpc - ikmpc(k-1)=ikmpc(k) - ilmpc(k-1)=ilmpc(k) - enddo - else - write(*,*) '*ERROR in changedepterm' - write(*,*) ' ikmpc database corrupted' - stop - endif - else - write(*,*) '*ERROR in changedepterm' - write(*,*) ' ikmpc database corrupted' - stop - endif -! -! insert new MPC -! - call nident(ikmpc,idofins,nmpc-1,id) - if((id.gt.0).and.(ikmpc(id).eq.idofins)) then - write(*,*) '*ERROR in changedepterm: dependent DOF' - write(*,*) ' of nonlinear MPC cannot be changed' - write(*,*) ' since new dependent DOF is already' - write(*,*) ' used in another MPC' - stop - else - do k=nmpc,id+2,-1 - ikmpc(k)=ikmpc(k-1) - ilmpc(k)=ilmpc(k-1) - enddo - ikmpc(id+1)=idofins - ilmpc(id+1)=mpc - endif -! - return - end - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/characteristic.f calculix-ccx-2.3/ccx_2.1/src/characteristic.f --- calculix-ccx-2.1/ccx_2.1/src/characteristic.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/characteristic.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,223 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine characteristic(node1,node2,nodem,nelem, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,physcon,numf,set,mi) -! -! This subroutine is used to enables the processing of empiric -! given under the form -! massflow*dsqrt(T1)/Pt1=f((Pt1-Pt2)/Pt1) and T1=T2 -! characteristics the subroutine proceeds using -! linear interpolation to estimate the values for the whole characteristic -! note that the characteristic is implicitely containing the point (0,0) -! - implicit none -! - logical identity - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem, - & ielprop(*),nodef(4),idirf(4),index,iflag, - & inv,id,numf,npu,i,mi(2) -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(4), - & p1,p2,physcon(*), - & xpu(10),ypu(10),Qred,p1mp2zp1,T1,scal,T2 -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif ((iflag.eq.1).or.(iflag.eq.2)) then -! - index=ielprop(nelem) -! - npu=nint(prop(index+2)) - scal=prop(index+1) -! - do i=1,npu - xpu(i)=prop(index+2*i+1) - ypu(i)=prop(index+2*i+2) - enddo -! - p1=v(2,node1) - p2=v(2,node2) -! - if(p1.ge.p2) then - inv=1 - T1=v(0,node1)+physcon(1) - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - T1=v(0,node2)+physcon(1) - endif -! - p1mp2zp1=(P1-P2)/P1 -! - if(iflag.eq.1) then - - call ident(xpu,p1mp2zp1,npu,id) - if(id.le.2) then - Qred=scal*ypu(2)/xpu(2)*p1mp2zp1 - xflow=inv*Qred*P1/dsqrt(T1) - elseif(id.ge.npu) then - Qred=scal*ypu(npu-2) - xflow=inv*Qred*P1/dsqrt(T1) - else - Qred=scal*ypu(id)+(ypu(id+1)-ypu(id)) - & *(p1mp2zp1-xpu(id))/(xpu(id+1)-xpu(id)) - xflow=inv*Qred*P1/dsqrt(T1) - endif -! - elseif (iflag.eq.2) then - numf=4 -! - p1=v(2,node1) - p2=v(2,node2) - xflow=v(1,nodem) -! - if (p1.ge.p2) then -! - inv=1 - xflow=v(1,nodem) - T1=v(0,node1)+physcon(1) - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! - else -! - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - T1=v(0,node2)+physcon(1) - xflow=-v(1,nodem) - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 -! - df(2)=xflow/(2.d0*P1*dsqrt(T1)) - df(3)=inv*dsqrt(T1)/P1 -! - call ident(xpu,p1mp2zp1,npu,id) -! - if(id.lt.2) then - f=dabs(xflow)*dsqrt(T1)/p1-scal*ypu(2)/xpu(2)*p1mp2zp1 - df(4)=scal*ypu(2)/(xpu(2)*P1) - df(1)=-xflow*dsqrt(T1)/(P1**2.d0)-(P2/P1**2.d0) - & *scal*ypu(2)/xpu(2) -! - elseif(id.ge.npu) then - f=dabs(xflow)/P1*dsqrt(T1)-scal*ypu(npu) - df(4)=0.01d0 - df(1)=-xflow*dsqrt(T1)/P1**2 -! - else - f=dabs(xflow)/P1*dsqrt(T1)-(scal*ypu(id) - & +scal*(ypu(id+1)-ypu(id)) - & *(p1mp2zp1-xpu(id))/(xpu(id+1)-xpu(id))) -! - df(4)=scal*(ypu(id+1)-ypu(id))/(xpu(id+1)-xpu(id))*1/p1 -! - df(1)=-xflow*dsqrt(T1)/P1**2-(P2/P1**2) - & *(scal*(ypu(id+1)-ypu(id))/(xpu(id+1)-xpu(id))) - endif - endif - - elseif(iflag.eq.3) then - p1=v(2,node1) - p2=v(2,node2) - xflow=v(1,nodem) -! - if (p1.ge.p2) then -! - inv=1 - xflow=v(1,nodem) - T1=v(0,node1)+physcon(1) - T2=v(0,node2)+physcon(1) - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! - else -! - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - T1=v(0,node2)+physcon(1) - T2=v(0,node1)+physcon(1) - xflow=-v(1,nodem) - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif -! - write(1,*) '' - write(1,55) 'In line',int(nodem/100),' from node',node1, - & ' to node', node2,': air massflow rate=',xflow,'kg/s' -! - 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) -! - if(inv.eq.1) then - write(1,56)' Inlet node ',node1,': Tt1=',T1, - & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' - - write(1,*)' element G ',set(numf)(1:20) -! - write(1,56)' Outlet node ',node2,': Tt2=',T2, - & 'K, Ts2=',T2,'K, Pt2=',P2/1e5,'Bar' -! - else if(inv.eq.-1) then - write(1,56)' Inlet node ',node2,': Tt1=',T1, - & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' - & - write(1,*)' element G ',set(numf)(1:20) -! - write(1,56)' Outlet node ',node1,': Tt2=',T2, - & 'K, Ts2=',T2,'K, Pt2=',P2/1e5, 'Bar' -! - endif -! - 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A) -! - endif -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/checkarpackcs.f calculix-ccx-2.3/ccx_2.1/src/checkarpackcs.f --- calculix-ccx-2.1/ccx_2.1/src/checkarpackcs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/checkarpackcs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,219 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine checkarpackcs(iponoel,inoel,ne,ipkon,lakon, - & kon,iactnode,iactelem,iecovered,incovered,itime) -! - implicit none -! - character*8 lakon(*) -! - integer iponoel(*),inoel(2,*),ne,ipkon(*),kon(*),inoelfree, - & nope,indexe,iactelem(*),iactnode(*),iecovered(*),nactive, - & itime(*),i,j,k,index,node,node1,id,iref,ielem,iact,il,ih, - & incovered(*),nei1,nei2,nei3,ineigh10(3,10),ineigh20(3,20) -! - data ineigh10 /5,7,8,5,6,9,6,7,10,8,9,10, - & 1,2,2,2,3,3,3,1,1, - & 1,4,4,2,4,4,3,4,4/ - data ineigh20 /9,12,17,9,10,18,10,11,19,11,12,20, - & 13,16,17,13,14,18,14,15,19,15,16,20, - & 1,2,2,2,3,3,3,4,4,4,1,1, - & 5,6,6,6,7,7,7,8,8,8,5,5, - & 1,5,5,2,6,6,3,7,7,4,8,8/ -! -! determining the elements belonging to the nodes of -! the elements -! - inoelfree=1 - do i=1,ne - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).eq.'F') cycle - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - nope=15 - endif - indexe=ipkon(i) - do j=1,nope - node=kon(indexe+j) - inoel(1,inoelfree)=i - inoel(2,inoelfree)=iponoel(node) - iponoel(node)=inoelfree - inoelfree=inoelfree+1 - enddo - enddo -! -! determining an active (element,node) set -! - do i=1,ne - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).eq.'F') cycle - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - nope=15 - endif - indexe=ipkon(i) - node=kon(indexe+1) - iactelem(1)=i - iactnode(1)=node - incovered(node)=1 - nactive=1 - exit - enddo -! -! covering all elements through neighboring relations -! - do - if(nactive.eq.0) exit - ielem=iactelem(1) - write(*,*) 'ielem ',ielem -c do i=1,nactive -c write(*,*) iactelem(i),iactnode(i) -c enddo - node=iactnode(1) - iref=itime(node) - indexe=ipkon(ielem) -! -! removing the element from the active sets -! - do i=1,nactive-1 - iactelem(i)=iactelem(i+1) - iactnode(i)=iactnode(i+1) - enddo - iecovered(ielem)=1 - nactive=nactive-1 -! -! loop over all nodes belonging to the element -! - loop:do - do k=1,nope - node1=kon(indexe+k) - if(incovered(node1).eq.1) cycle -! -! checking for neighbors -! - if(nope.eq.20) then - nei1=kon(indexe+ineigh20(1,k)) - nei2=kon(indexe+ineigh20(2,k)) - nei3=kon(indexe+ineigh20(3,k)) - elseif(nope.eq.10) then - nei1=kon(indexe+ineigh10(1,k)) - nei2=kon(indexe+ineigh10(2,k)) - nei3=kon(indexe+ineigh10(3,k)) - else - write(*,*) '*ERROR in checkarpackcs: case not covered' - stop - endif - if(incovered(nei1).eq.1) then - iref=itime(nei1) - elseif(incovered(nei2).eq.1) then - iref=itime(nei2) - elseif(incovered(nei3).eq.1) then - iref=itime(nei3) - else - cycle - endif - - incovered(node1)=1 -c if(node1.eq.node) cycle -! -! checking for continuity of field time (to be done) -! - iact=itime(node1) - il=iact - ih=iact - if(iact.le.iref) then - do - ih=ih+180 - if(ih.ge.iref) exit - il=ih - enddo - else - do - il=il-180 - if(il.le.iref) exit - ih=il - enddo - endif - if((ih-iref)>(iref-il)) then - itime(node1)=il - else - itime(node1)=ih - endif - write(*,*) 'check ',node1,iref,iact,il,ih,itime(node1) -! -! covering all elements belonging to node node1 -! - index=iponoel(node1) - do - ielem=inoel(1,index) - if(iecovered(ielem).eq.0) then - call nident(iactelem,ielem,nactive,id) - if(id.gt.0) then - if(iactelem(id).eq.ielem) then -! -! element already belongs to the active set -! - index=inoel(2,index) - if(index.eq.0) exit - cycle - endif - endif -! -! new element to be added to the active set -! - nactive=nactive+1 - do j=nactive,id+2,-1 - iactelem(j)=iactelem(j-1) - iactnode(j)=iactnode(j-1) - enddo - iactelem(id+1)=ielem - iactnode(id+1)=node1 - endif - index=inoel(2,index) - if(index.eq.0) exit - enddo - enddo - do k=1,nope - node1=kon(indexe+k) - if(incovered(node1).eq.0) cycle loop - enddo - exit - enddo loop - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/checkconvergence.c calculix-ccx-2.3/ccx_2.1/src/checkconvergence.c --- calculix-ccx-2.1/ccx_2.1/src/checkconvergence.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/checkconvergence.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,507 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif - - -void checkconvergence(double *co, int *nk, int *kon, int *ipkon, char *lakon, - int *ne, double *stn, int *nmethod, - int *kode, char *filab, double *een, double *t1act, - double *time, double *epn,int *ielmat,char *matname, - double *enern, double *xstaten, int *nstate_, int *istep, - int *iinc, int *iperturb, double *ener, int *mi, char *output, - int *ithermal, double *qfn, int *mode, int *noddiam, double *trab, - int *inotr, int *ntrans, double *orab, int *ielorien, int *norien, - char *description,double *sti, - int *icutb, int *iit, double *dtime, double *qa, double *vold, - double *qam, double *ram1, double *ram2, double *ram, - double *cam, double *uam, int *ntg, double *ttime, - int *icntrl, double *theta, double *dtheta, double *veold, - double *vini, int *idrct, double *tper,int *istab, double *tmax, - int *nactdof, double *b, double *tmin, double *ctrl, double *amta, - int *namta, int *itpamp, int *inext, double *dthetaref, int *itp, - int *jprint, int *jout, int *uncoupled, double *t1, int *iitterm, - int *nelemload, int *nload, int *nodeboun, int *nboun, int *itg, - int *ndirboun, double *deltmx, int *iflagact,char *set,int *nset, - int *istartset,int *iendset,int *ialset){ - - int i0,ir,ip,ic,il,ig,ia,iest,iest1=0,iest2=0,iconvergence,idivergence, - ngraph=1,k,*ipneigh=NULL,*neigh=NULL,*inum=NULL,id,istart,iend,inew, - i,j,mt=mi[1]+1; - - double df,dc,db,dd,ran,can,rap,ea,cae,ral,da,*vr=NULL,*vi=NULL,*stnr=NULL, - *stni=NULL,*vmax=NULL,*stnmax=NULL,*cs=NULL,c1[2],c2[2],reftime, - *fn=NULL; - - i0=ctrl[0];ir=ctrl[1];ip=ctrl[2];ic=ctrl[3];il=ctrl[4];ig=ctrl[5];ia=ctrl[7]; - df=ctrl[10];dc=ctrl[11];db=ctrl[12];da=ctrl[13];dd=ctrl[16]; - ran=ctrl[18];can=ctrl[19];rap=ctrl[22]; - ea=ctrl[23];cae=ctrl[24];ral=ctrl[25]; - - /* check for forced divergence (due to divergence of a user material - routine */ - - if(qa[2]>0.){idivergence=1;}else{idivergence=0;} - - if(*ithermal!=2){ - if(qa[0]>ea*qam[0]){ - if(*iit<=ip){c1[0]=ran;} - else{c1[0]=rap;} - c2[0]=can; - } - else{ - c1[0]=ea; - c2[0]=cae; - } - if(ram1[0]1){ - if(qa[1]>ea*qam[1]){ - if(*iit<=ip){c1[1]=ran;} - else{c1[1]=rap;} - c2[1]=can; - } - else{ - c1[1]=ea; - c2[1]=cae; - } - if(ram1[1]1)&&(ram[0]<=c1[0]*qam[0])&&(*iflagact==0)&& - // if((*iit>1)&&(ram[0]<=c1[0]*qam[0])&& - ((cam[0]<=c2[0]*uam[0])|| - (((ram[0]*cam[0]il)&&(*idrct==0)){ - if(*idrct==0){ - *dtheta=*dthetaref*db; - *dthetaref=*dtheta; - printf(" convergence; the increment size is decreased to %e\n\n",*dtheta**tper); - if(*dtheta<*tmin){ - printf("\n *ERROR: increment size smaller than minimum\n"); - printf(" best solution and residuals are in the frd file\n\n"); - fn=NNEW(double,mt**nk); - inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; - FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, - nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, - ielorien,co,nelemload,nload,nodeboun,nboun,itg,ntg, - vold,ndirboun)); - ++*kode; - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn,inum, - nmethod,kode, - filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, - xstaten,nstate_,istep,iinc,iperturb,ener,mi,output, - ithermal,qfn,mode,noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - FORTRAN(uout,(vold,mi)); - FORTRAN(stop,()); - } - } - else{ - printf("convergence\n\n");} - } - - /* check whether next increment size can be increased */ - - else if(*iit<=ig){ - if((*istab==1)&&(*idrct==0)){ - *dtheta=*dthetaref*dd; - *dthetaref=*dtheta; - printf(" convergence; the increment size is increased to %e\n\n",*dtheta**tper); - } - else{ - *istab=1; - printf(" convergence\n\n"); - *dtheta=*dthetaref; - } - } - else{ - *istab=0; - printf(" convergence\n\n"); - *dtheta=*dthetaref; - } - - if((*dtheta>*tmax)&&(*idrct==0)){ - *dtheta=*tmax; - *dthetaref=*dtheta; - printf(" the increment size exceeds thetamax and is decreased to %e\n\n",*dtheta**tper); - } - - /* if itp=1 the increment just finished ends at a time point */ - - if((*itpamp>0)&&(*idrct==0)){ - if(*itp==1){ - *jprint=*jout; - }else{ - *jprint=*jout+1; - } - if(namta[3**itpamp-1]<0){ -// reftime=*ttime+*dtheta**tper+1.01e-6; - reftime=*ttime+*dtheta**tper; - }else{ -// reftime=*time+*dtheta**tper+1.01e-6; - reftime=*time+*dtheta**tper; - } - istart=namta[3**itpamp-3]; - iend=namta[3**itpamp-2]; - FORTRAN(identamta,(amta,&reftime,&istart,&iend,&id)); - if(id1.-*theta){ - *dtheta=1.-*theta; - *dthetaref=*dtheta; - printf(" the increment size exceeds the remainder of the step and is decreased to %e\n\n",*dtheta**tper); - if(*dtheta<=1.e-6){(*ttime)+=(*dtheta**tper);} - } - } - else{ - - /* check for the amount of iterations */ - - if(*iit>ic){ - printf("\n *ERROR: too many iterations needed\n"); - printf(" best solution and residuals are in the frd file\n\n"); - fn=NNEW(double,mt**nk); - inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; - FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal,nk,sti,stn, - ipkon,inum,kon,lakon,ne,mi,orab,ielorien,co, - nelemload,nload,nodeboun,nboun,itg,ntg,vold,ndirboun)); - ++*kode; - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn,inum,nmethod,kode, - filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, - xstaten,nstate_,istep,iinc,iperturb,ener,mi,output, - ithermal,qfn,mode,noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - FORTRAN(uout,(vold,mi)); - FORTRAN(stop,()); - } - - /* check for diverging residuals */ - - if((*iit>=i0)||(fabs(ram[0])>1.e20)||(fabs(cam[0])>1.e20)|| - (fabs(ram[1])>1.e20)||(fabs(cam[1])>1.e20)|| - (cam[2]>*deltmx)){ - if(*ithermal!=2){ - if((ram1[0]>ram2[0])&&(ram[0]>ram2[0])&&(ram[0]>c1[0]*qam[0])) - idivergence=1; - } - - /* for thermal calculations the maximum temperature change - is checked as well */ - - if(*ithermal>1){ - if((ram1[1]>ram2[1])&&(ram[1]>ram2[1])&&(ram[1]>c1[1]*qam[1])) - idivergence=1; - if(cam[2]>*deltmx) idivergence=2; - } - if(idivergence>0){ - if(*idrct==1) { - printf("\n *ERROR: solution seems to diverge; please try \n"); - printf(" automatic incrementation; program stops\n"); - printf(" best solution and residuals are in the frd file\n\n"); - fn=NNEW(double,mt**nk); - inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; - FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal,nk, - sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, - ielorien,co,nelemload,nload,nodeboun,nboun,itg,ntg, - vold,ndirboun)); - ++*kode; - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, - inum,nmethod,kode, - filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, - xstaten,nstate_,istep,iinc,iperturb,ener,mi,output, - ithermal,qfn,mode,noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - FORTRAN(uout,(vold,mi)); - FORTRAN(stop,()); - } - else { - if(qa[2]>0.){ - *dtheta=*dtheta*qa[2]; - }else{ - if(idivergence==1){ - *dtheta=*dtheta*df; - }else{ - *dtheta=*dtheta**deltmx/cam[2]*da; - } - } - *dthetaref=*dtheta; - printf(" divergence; the increment size is decreased to %e\n",*dtheta**tper); - printf(" the increment is reattempted\n\n"); - *istab=0; - if(*itp==1){ - *itp=0; - (*inext)--; - } - if(*dtheta<*tmin){ - printf("\n *ERROR: increment size smaller than minimum\n"); - printf(" best solution and residuals are in the frd file\n\n"); - fn=NNEW(double,mt**nk); - inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; - FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, - nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, - ielorien,co,nelemload,nload,nodeboun,nboun, - itg,ntg,vold,ndirboun)); - ++*kode; - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, - inum,nmethod,kode, - filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, - xstaten,nstate_,istep,iinc,iperturb,ener,mi, - output,ithermal,qfn,mode,noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - FORTRAN(uout,(vold,mi)); - FORTRAN(stop,()); - } - *icntrl=1; - (*icutb)++; - if(*icutb>ia){ - printf("\n *ERROR: too many cutbacks\n"); - printf(" best solution and residuals are in the frd file\n\n"); - fn=NNEW(double,mt**nk); - inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; - FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, - nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, - ielorien,co,nelemload,nload,nodeboun,nboun, - itg,ntg,vold,ndirboun)); - ++*kode; - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, - inum,nmethod,kode, - filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, - xstaten,nstate_,istep,iinc,iperturb,ener,mi, - output,ithermal,qfn,mode,noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - FORTRAN(uout,(vold,mi)); - FORTRAN(stop,()); - } - if(*uncoupled){ - if(*ithermal==1){ - (ctrl[0])/=4; - } - *ithermal=3; - } - return; - } - } - } - - /* check for too slow convergence */ - - if(*iit>=ir){ - if(*ithermal!=2){ - iest1=(int)ceil(*iit+log(ran*qam[0]/(ram[0]))/log(ram[0]/(ram1[0]))); - } - if(*ithermal>1){ - iest2=(int)ceil(*iit+log(ran*qam[1]/(ram[1]))/log(ram[1]/(ram1[1]))); - } - if(iest1>iest2){iest=iest1;}else{iest=iest2;} - if(iest>0){ - printf(" estimated number of iterations till convergence = %d\n", - iest); - } - if((iest>ic)||(*iit==ic)){ - - if(*idrct!=1){ - *dtheta=*dtheta*dc; - *dthetaref=*dtheta; - printf(" too slow convergence; the increment size is decreased to %e\n",*dtheta**tper); - printf(" the increment is reattempted\n\n"); - *istab=0; - if(*dtheta<*tmin){ - printf("\n *ERROR: increment size smaller than minimum\n"); - printf(" best solution and residuals are in the frd file\n\n"); - fn=NNEW(double,mt**nk); - inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; - FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, - nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, - ielorien,co,nelemload,nload,nodeboun,nboun, - itg,ntg,vold,ndirboun)); - ++*kode; - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, - inum,nmethod,kode, - filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, - xstaten,nstate_,istep,iinc,iperturb,ener, - mi,output,ithermal,qfn,mode,noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - FORTRAN(uout,(vold,mi)); - FORTRAN(stop,()); - } - *icntrl=1; - (*icutb)++; - if(*icutb>ia){ - printf("\n *ERROR: too many cutbacks\n"); - printf(" best solution and residuals are in the frd file\n\n"); - fn=NNEW(double,mt**nk); - inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; - FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, - nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, - ielorien,co,nelemload,nload,nodeboun,nboun, - itg,ntg,vold,ndirboun)); - ++*kode; - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, - inum,nmethod,kode, - filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, - xstaten,nstate_,istep,iinc,iperturb,ener,mi, - output,ithermal,qfn,mode,noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - FORTRAN(uout,(vold,mi)); - FORTRAN(stop,()); - } - if(*uncoupled){ - if(*ithermal==1){ - (ctrl[0])/=4; - } - *ithermal=3; - } - return; - } - } - } - - printf(" no convergence\n\n"); - - (*iit)++; - - } - - /* default value for qa[2] */ - - qa[2]=-1; - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/checkconvgas.c calculix-ccx-2.3/ccx_2.1/src/checkconvgas.c --- calculix-ccx-2.1/ccx_2.1/src/checkconvgas.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/checkconvgas.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,130 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif - -void checkconvgas(int *icutb, int *iin, - double *qamt, double *qamf, double *qamp, - double *ram1t, double *ram1f, double *ram1p, - double *ram2t, double *ram2f, double *ram2p, - double *ramt, double *ramf, double *ramp, - int *icntrl, double *dtheta, double *ctrl){ - - int i0,ir,ip,ic,il,ig,ia,idivergence; - - double c1t,c1f,c1p; - double df,dc,db,dd,ran,can,rap,ea,cae,ral; - - i0=ctrl[0];ir=ctrl[1];ip=ctrl[2];ic=ctrl[3];il=ctrl[4];ig=ctrl[5];ia=ctrl[7]; - df=ctrl[10];dc=ctrl[11];db=ctrl[12];dd=ctrl[16]; - ran=ctrl[18];can=ctrl[19];rap=ctrl[22]; - ea=ctrl[23];cae=ctrl[24];ral=ctrl[25]; - - /* temperature */ - - if(*iin<=ip){c1t=0.0001*ran;} - else{c1t=0.0001*rap;} - - /* mass flow */ - - if(*iin<=ip){c1f=0.0001*ran;} - else{c1f=0.0001*rap;} - - /* pressure */ - - if(*iin<=ip){c1p=0.0001*ran;} - else{c1p=0.0001*rap;} - - if(*ram1t<*ram2t) {*ram2t=*ram1t;} - if(*ram1f<*ram2f) {*ram2f=*ram1f;} - if(*ram1p<*ram2p) {*ram2p=*ram1p;} - - /* check for convergence or divergence */ - - if(((*ramt<=c1t**qamt)||(*ramt<1.e-8))&& - ((*ramf<=c1f**qamf)||(*ramf<1.e-15))&& - ((*ramp<=c1p**qamp)||(*ramp<1.e-8))&& - (*iin>3)){ - - /* increment convergence reached */ - - printf(" flow network: convergence\n\n"); - printf(" gas iteration:%d \n\n",*iin); - *icntrl=1; - *icutb=0; - } - - else { - - idivergence=0; - - /* divergence based on temperatures */ - - if((*iin>=20*i0)||(fabs(*ramt)>1.e20)){ - if((*ram1t>*ram2t)&&(*ramt>*ram2t)&&(*ramt>c1t**qamt)){ - idivergence=1; - } - } - - /* divergence based on the mass flux */ - - if((*iin>=20*i0)||(fabs(*ramf)>1.e20)){ - if((*ram1f>*ram2f)&&(*ramf>*ram2f)&&(*ramf>c1f**qamf)){ - idivergence=1; - } - } - - /* divergence based on pressures */ - - if((*iin>=20*i0)||(fabs(*ramp)>1.e20)){ - if((*ram1p>*ram2p)&&(*ramp>*ram2p)&&(*ramp>c1p**qamp)){ - idivergence=1; - } - } - - /* divergence based on singular matrix or negative pressures */ - - if(*iin==0) idivergence=1; - - if(idivergence==1){ - *dtheta=*dtheta*df; - printf("\n divergence; the increment size is decreased to %e\n",*dtheta); - printf(" the increment is reattempted\n\n"); - *iin=0; - (*icutb)++; - if(*icutb>ia){ - printf("\n *ERROR: too many cutbacks\n"); - FORTRAN(stop,()); - } - }else{ - printf(" no convergence\n\n"); - } - } - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/checkinclength.c calculix-ccx-2.3/ccx_2.1/src/checkinclength.c --- calculix-ccx-2.1/ccx_2.1/src/checkinclength.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/checkinclength.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif - -void checkinclength(double *time,double *ttime,double *theta, double *dtheta, - int *idrct, double *tper,double *tmax, double *tmin, double *ctrl, - double *amta,int *namta, int *itpamp, int *inext, double *dthetaref, - int *itp,int *jprint, int *jout){ - - int id,istart,iend,inew; - double reftime; - - int i0,ir,ip,ic,il,ig,ia; - double df,dc,db,dd,ran,can,rap,ea,cae,ral,da; - i0=ctrl[0];ir=ctrl[1];ip=ctrl[2];ic=ctrl[3];il=ctrl[4];ig=ctrl[5];ia=ctrl[7]; - df=ctrl[10];dc=ctrl[11];db=ctrl[12];da=ctrl[13];dd=ctrl[16]; - ran=ctrl[18];can=ctrl[19];rap=ctrl[22]; - ea=ctrl[23];cae=ctrl[24];ral=ctrl[25]; - - /* check whether the new increment size is not too big */ - - if(*dtheta>*tmax){ - *dtheta=*tmax; - printf(" the increment size exceeds thetamax and is decreased to %e\n\n",*dtheta**tper); - } - - /* if itp=1 the increment just finished ends at a time point */ - - if((*itpamp>0)&&(*idrct==0)){ - if(namta[3**itpamp-1]<0){ -/* reftime=*ttime+*dtheta**tper+1.01e-6;*/ -// reftime=*ttime+(*dtheta+1.01e-6)**tper; - reftime=*ttime+(*dtheta)**tper; - }else{ -/* reftime=*time+*dtheta**tper+1.01e-6;*/ -// reftime=*time+(*dtheta+1.01e-6)**tper; - reftime=*time+(*dtheta)**tper; - } - istart=namta[3**itpamp-3]; - iend=namta[3**itpamp-2]; - FORTRAN(identamta,(amta,&reftime,&istart,&iend,&id)); - if(id1.-*theta){ - *dtheta=1.-*theta; - *dthetaref=*dtheta; - printf(" the increment size exceeds the remainder of the step and is decreased to %e\n\n",*dtheta**tper); - if(*dtheta<=1.e-6){(*ttime)+=(*dtheta**tper);} - } - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/checkslavevertex.f calculix-ccx-2.3/ccx_2.1/src/checkslavevertex.f --- calculix-ccx-2.1/ccx_2.1/src/checkslavevertex.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/checkslavevertex.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine checkslavevertex(lvertex,nvertex,pvertex, - & itriacornerl,xl2) -! -! check whether triangular master vertex lies within the slave -! surface -! - implicit none -! - integer nvertex,lvertex(*),nodel,i, - & itriacornerl(*) -! - real*8 pvertex(3,*),xl2(3,*) -! - - if(nvertex.ne.0) then - nodel=lvertex(nvertex) - else - nodel=0 - endif - if(nodel.ne.0) then -! -! S-edge lvertex(nvertex) (local number, applies to -! the nodes as well as to the edges) was cut -! - if(itriacornerl(nodel).eq.1) then - nvertex=nvertex+1 - do i=1,3 - pvertex(i,nvertex)=xl2(i,nodel) - enddo - lvertex(nvertex)=0 -! - itriacornerl(nodel)=2 - endif - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/checktime.f calculix-ccx-2.3/ccx_2.1/src/checktime.f --- calculix-ccx-2.1/ccx_2.1/src/checktime.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/checktime.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine checktime(itpamp,namta,tinc,ttime,amta,tmin,inext,itp) -! -! checks whether tmin does not exceed the first time point, -! in case a time points amplitude is active -! - implicit none -! - integer namta(3,*),itpamp,id,inew,inext,istart,iend,itp -! - real*8 amta(2,*),tinc,ttime,tmin,reftime -! - if(itpamp.gt.0) then -! -! identifying the location in the time points amplitude -! of the starting time of the step -! - if(namta(3,itpamp).lt.0) then - reftime=ttime - else - reftime=0 - endif - istart=namta(1,itpamp) - iend=namta(2,itpamp) - call identamta(amta,reftime,istart,iend,id) - if(id.lt.istart) then - inext=istart - else - inext=id+1 - endif -! -! identifying the location in the time points amplitude -! of the starting point increased by tinc -! - if(namta(3,itpamp).lt.0) then - reftime=ttime+tinc - else - reftime=tinc - endif - istart=namta(1,itpamp) - iend=namta(2,itpamp) - call identamta(amta,reftime,istart,iend,id) - if(id.lt.istart) then - inew=istart - else - inew=id+1 - endif -! -! if the next time point precedes tinc or tmin -! appropriate action must be taken -! - if(inew.gt.inext) then - if(namta(3,itpamp).lt.0) then - tinc=amta(1,inext)-ttime - else - tinc=amta(1,inext) - endif - inext=inext+1 - itp=1 - if(tinc.lt.tmin) then - write(*,*) '*ERROR in checktime: a time point' - write(*,*) ' precedes the minimum time tmin' - stop - else - write(*,*) '*WARNING in checktime: a time point' - write(*,*) ' precedes the initial time' - write(*,*) ' increment tinc; tinc is' - write(*,*) ' decrease to ',tinc - endif - endif - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/checktriaedge.f calculix-ccx-2.3/ccx_2.1/src/checktriaedge.f --- calculix-ccx-2.1/ccx_2.1/src/checktriaedge.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/checktriaedge.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,327 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine checktriaedge(node1,node2,ipe,ime,iactiveline, - & nactiveline,intersec,xntersec,nvertex,pvertex,lvertex, - & ifreeintersec,xn,co,nopes,xl2,itri,idin,vold,mi) -! -! check whether triangular master edge cuts the slave surface -! edges -! - implicit none -! - logical invert,active -! - integer node1,node2,ipe(*),ime(4,*),indexl,iactiveline(3,*), - & nactiveline,id,indexi,intersec(2,*),nvertex,lvertex(13),i, - & idummy,ifreeintersec,nopes,nintersec,j,itri,index1,index2, - & k,node,ithree,idin,r1,mi(2) -! - real*8 xntersec(3,*),pvertex(3,*),pr(3),xm(3),xn(3),co(3,*), - & dd,xl2(3,*),rc(3),dc(3),al,dummy(3),ratio(8),dist,xil, - & etl,al2,inter(3),err,rand,vold(0:mi(2),*) -! - data ithree /3/ -! -! check whether the first node of the edge has a lower number -! than the second node. If not, the line is stored in reverse -! order in field ime and the invert flag is set to true -! - err=1d-6 -c call time(r1) -c call srand(REAL(MOD(r1,1000))) - invert=.false. - if(node2.lt.node1) then - node=node1 - node1=node2 - node2=node - invert=.true. - endif -! -! retrieving the number of the line in field ime: indexl -! - indexl=ipe(node1) - do - if(ime(1,indexl).eq.node2) exit - indexl=ime(4,indexl) - if(indexl.eq.0) then - write(*,*) '*ERROR in checktriaedge: line was not' - write(*,*) itri,"node1",node1, "node2",node2 - write(*,*) ' properly catalogued' - stop - endif - enddo -! -! check whether line is active (i.e. lies on the progressing -! front) -! - active=.false. - call nidentk(iactiveline,indexl,nactiveline,id,ithree) - if(id.gt.0) then - if(iactiveline(1,id).eq.indexl) then - active=.true. - endif - endif -! - if(active) then -! -! retrieving the intersection points and storing them in -! pvertex... -! - indexi=iactiveline(3,id) -! -! check whether there is at least one intersection -! - if(indexi.gt.0) then - nvertex=nvertex+1 - lvertex(nvertex)=intersec(1,indexi) - do i=1,3 - pvertex(i,nvertex)=xntersec(i,indexi) - enddo - indexi=intersec(2,indexi) -! -! check whether there is a second intersection -! - if(indexi.ne.0) then - nvertex=nvertex+1 -! -! for two intersections the orientation of the line -! is important -! - if(invert) then - lvertex(nvertex)=lvertex(nvertex-1) - lvertex(nvertex-1)=intersec(1,indexi) - do i=1,3 - pvertex(i,nvertex)=pvertex(i,nvertex-1) - pvertex(i,nvertex-1)=xntersec(i,indexi) - enddo - else - lvertex(nvertex)=intersec(1,indexi) - do i=1,3 - pvertex(i,nvertex)=xntersec(i,indexi) - enddo - endif - endif - endif -! -! remove the line from the active stack -! -! restore intersec/ifreeintersec -! - indexi=iactiveline(3,id) - do -! -! Inversion -! - idummy=indexi - indexi=intersec(2,indexi) - intersec(2,idummy)=0 - if(indexi.eq.0) exit - enddo -! -! restore iactiveline/nactiveline -! - nactiveline=nactiveline-1 - do i=id,nactiveline - do k=1,3 - iactiveline(k,i)=iactiveline(k,i+1) - enddo - enddo - else -! -! line was not active: check for intersections -! - do i=1,3 -c pr(i)=co(i,node2)-co(i,node1)+err*rand(1) - pr(i)=co(i,node2)+vold(i,node2)- - & co(i,node1)-vold(i,node1) -c WRITE(*,*) "pr",i,pr(i) - enddo -! -! normal on a plane through the line and vector xn -! - xm(1)=xn(2)*pr(3)-xn(3)*pr(2) - xm(2)=xn(3)*pr(1)-xn(1)*pr(3) - xm(3)=xn(1)*pr(2)-xn(2)*pr(1) - dd=dsqrt(xm(1)**2+xm(2)**2+xm(3)**2) - do i=1,3 - xm(i)=xm(i)/dd - enddo -! -! check for intersections with the slave edges -! - nintersec=0 - do j=1,nopes - if(j.ne.nopes) then - do i=1,3 - rc(i)=co(i,node1)+vold(i,node1)-xl2(i,j) - dc(i)=xl2(i,j+1)-xl2(i,j) -c rc(i)=co(i,node1)-xl2(i,j)+err*rand(1) -c dc(i)=xl2(i,j+1)-xl2(i,j)+err*rand(1) - enddo - else - do i=1,3 - rc(i)=co(i,node1)+vold(i,node1)-xl2(i,j) - dc(i)=xl2(i,1)-xl2(i,j) -c rc(i)=co(i,node1)-xl2(i,j)+err*rand(1) -c dc(i)=xl2(i,1)-xl2(i,j)+err*rand(1) - enddo - endif - al=(xm(1)*rc(1)+xm(2)*rc(2)+xm(3)*rc(3))/ - & (xm(1)*dc(1)+xm(2)*dc(2)+xm(3)*dc(3)) -! -! the intersection point must lie in between the -! triangular vertices -! - if((al.ge.1.d0).or.(al.le.0.d0)) cycle -! intersection found: catalogueing the line as active -! and storing the intersection -! - do i=1,3 - inter(i)=xl2(i,j)+al*dc(i) - enddo -c al2=(pr(1)*(inter(1)-co(1,node1))+pr(2)*(inter(2)-co(2,node1))+ -c & pr(3)*(inter(3)-co(3,node1)))/(pr(1)**2+pr(2)**2+pr(3)**2) - al2=(pr(1)*(inter(1)-co(1,node1)-vold(1,node1))+ - & pr(2)*(inter(2)-co(2,node1)-vold(2,node1))+ - & pr(3)*(inter(3)-co(3,node1)-vold(3,node1)))/ - &(pr(1)**2+pr(2)**2+pr(3)**2) - if((al2.ge.1.d0).or.(al2.le.0.d0)) cycle -! - if(nintersec.eq.0) then - nactiveline=nactiveline+1 - ifreeintersec=ifreeintersec+1 - do k=nactiveline,id+2,-1 - do i=1,3 - iactiveline(i,k)=iactiveline(i,k-1) - enddo - enddo - iactiveline(1,id+1)=indexl - iactiveline(2,id+1)=itri - iactiveline(3,id+1)=ifreeintersec - nintersec=nintersec+1 - elseif(nintersec.eq.1) then - ifreeintersec=ifreeintersec+1 - intersec(2,iactiveline(3,id+1))=ifreeintersec - nintersec=nintersec+1 - else - write(*,*) '*ERROR in checktriaedge: no more' - write(*,*) ' than two intersections allowed' - stop - endif -! -! update intersec and xntersec -! - intersec(1,ifreeintersec)=j - do i=1,3 - xntersec(i,ifreeintersec)=inter(i) - enddo - call attach(xl2,xntersec(1,ifreeintersec),nopes, - & ratio,dist,xil,etl) -c ifreeintersec=intersec(2,ifreeintersec) - intersec(2,ifreeintersec)=0 - enddo -! -! if there are two intersections, their order has to be -! checked -! - if(nintersec.eq.2) then -! -! check order of crossings -! - index1=iactiveline(3,id+1) - index2=intersec(2,index1) -! -! measuring the distance from node1 -! -c if(((xntersec(1,index1)-co(1,node1))**2+ -c & (xntersec(2,index1)-co(2,node1))**2+ -c & (xntersec(3,index1)-co(3,node1))**2).gt. -c & ((xntersec(1,index2)-co(1,node1))**2+ -c & (xntersec(2,index2)-co(2,node1))**2+ -c & (xntersec(3,index2)-co(3,node1))**2) ) then - if(((xntersec(1,index1)-co(1,node1)-vold(1,node1))**2+ - & (xntersec(2,index1)-co(2,node1)-vold(2,node1))**2+ - & (xntersec(3,index1)-co(3,node1)-vold(3,node1))**2).gt. - & ((xntersec(1,index2)-co(1,node1)-vold(1,node1))**2+ - & (xntersec(2,index2)-co(2,node1)-vold(2,node1))**2+ - & (xntersec(3,index2)-co(3,node1)-vold(3,node1))**2) )then -! - iactiveline(3,id+1)=index2 - intersec(2,index2)=index1 - intersec(2,index1)=0 - endif - endif -! - indexi=iactiveline(3,id+1) - if((indexi.gt.0).and.(nintersec.gt.0)) then - nvertex=nvertex+1 - lvertex(nvertex)=intersec(1,indexi) - do i=1,3 - pvertex(i,nvertex)=xntersec(i,indexi) - enddo - indexi=intersec(2,indexi) -! -! check whether there is a second intersection -! -c if((indexi.ne.0).or.(nintersec.eq.2)) then - if((indexi.ne.0)) then - nvertex=nvertex+1 -! -! for two intersections the orientation of the line -! is important -! - if(invert) then - lvertex(nvertex)=lvertex(nvertex-1) - lvertex(nvertex-1)=intersec(1,indexi) - do i=1,3 - pvertex(i,nvertex)=pvertex(i,nvertex-1) - pvertex(i,nvertex-1)=xntersec(i,indexi) - enddo - else - lvertex(nvertex)=intersec(1,indexi) - do i=1,3 - pvertex(i,nvertex)=xntersec(i,indexi) - enddo - endif - endif - endif -! -! if there are no intersections the line has to be set -! active if node1 lies inside -! - if((idin.gt.0).and.(nintersec.eq.0)) then - nactiveline=nactiveline+1 - do k=nactiveline,id+2,-1 - do i=1,3 - iactiveline(i,k)=iactiveline(i,k-1) - enddo - enddo - iactiveline(1,id+1)=indexl - iactiveline(2,id+1)=itri - iactiveline(3,id+1)=0 - endif - endif -! - if(invert) then - node=node1 - node1=node2 - node2=node - endif - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/checktriavertex.f calculix-ccx-2.3/ccx_2.1/src/checktriavertex.f --- calculix-ccx-2.1/ccx_2.1/src/checktriavertex.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/checktriavertex.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,124 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine checktriavertex(inodesin,nnodesin,node,nvertex,pvertex, - & lvertex,pnodesin,inodesout,nnodesout,nopes,slavstraight, - & xn,co,xl2,vold,mi) -! -! check whether triangular master vertex lies within the slave -! surface -! - implicit none -! - logical in -! - integer inodesin(*),nnodesin,node,idi,nvertex,lvertex(*),i, - & inodesout(*),nnodesout,ido,nopes,j,mi(2) -! - real*8 pvertex(3,*),pnodesin(3,*),slavstraight(20),xn(3),co(3,*), - & al,xl2(3,*),ratio(8),dist,xil,etl,vold(0:mi(2),*) -! - in=.false. -! - do -! -! check whether nodes was already calatogued as being -! inside the slave surface -! - call nident(inodesin,node,nnodesin,idi) - if(idi.gt.0) then - if(inodesin(idi).eq.node) then - in=.true. - nvertex=nvertex+1 - do i=1,3 - pvertex(i,nvertex)=pnodesin(i,idi) - enddo - lvertex(nvertex)=0 - exit - endif - endif -! -! check whether nodes was already calatogued as being -! outside the slave surface -! - call nident(inodesout,node,nnodesout,ido) - if(ido.gt.0) then - if(inodesout(ido).eq.node) exit - endif -! -! node is not catalogued: check whether node is inside -! or outside the slave surface -! - do i=1,nopes -c if((slavstraight(i*4-3)*co(1,node)+ -c & slavstraight(i*4-2)*co(2,node)+ -c & slavstraight(i*4-1)*co(3,node)+ - if((slavstraight(i*4-3)*(co(1,node)+vold(1,node))+ - & slavstraight(i*4-2)*(co(2,node)+vold(2,node))+ - & slavstraight(i*4-1)*(co(3,node)+vold(3,node))+ - & slavstraight(i*4)).gt.0.d0) exit - if(i.eq.nopes) in=.true. - enddo - if(in) then - nvertex=nvertex+1 - lvertex(nvertex)=0 -! -! projecting the node on the mean slave plane -! -c al=-xn(1)*co(1,node)-xn(2)*co(2,node)-xn(3)*co(3,node)- -c & slavstraight(nopes*4+4) - al=-xn(1)*(co(1,node)+vold(1,node))-xn(2)* - & (co(2,node)+vold(2,node))-xn(3)*(co(3,node)+vold(3,node))- - & slavstraight(nopes*4+4) - do i=1,3 - pvertex(i,nvertex)=co(i,node)+al*xn(i) - enddo -! -! projecting the node on the slave surface -! - call attach(xl2,pvertex,nopes,ratio,dist,xil,etl) -! -! cataloguein the node in inodesin -! - nnodesin=nnodesin+1 - do j=nnodesin,idi+2,-1 - inodesin(j)=inodesin(j-1) - do i=1,3 - pnodesin(i,j)=pnodesin(i,j-1) - enddo - enddo - inodesin(idi+1)=node - do i=1,3 - pnodesin(i,idi+1)=co(i,node)+vold(i,node) - enddo - exit - else -! -! cataloguein the node in inodesout -! - nnodesout=nnodesout+1 - do j=nnodesout,ido+2,-1 - inodesout(j)=inodesout(j-1) - enddo - inodesout(ido+1)=node - exit - endif - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/chksurf.f calculix-ccx-2.3/ccx_2.1/src/chksurf.f --- calculix-ccx-2.1/ccx_2.1/src/chksurf.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/chksurf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,391 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine chksurf(lakon,kon,ipkon,neigh,ipneigh,co,itypflag,node, - & icont,iscount,angmax) -! -! icont=1: element surfaces adjacent to a surface node have normal -! vectors which have an angle of less than 10 degree -! -> free surface assumed -! icont=0: -> edge assumed -! -! also counts the free surfaces adjacent to a node -! - implicit none -! - integer kon(*),ipkon(*),ielem,i,j,k,indexe, - & neigh(2,*),ipneigh(*),index,m,nvertex,itypflag,isurf,node,index1, - & ielem1,ncount,ntos8h(3,8),ntos4tet(3,4),iston8h(4,6), - & isnode, isidx,ifreesur(3),iston20h(8,6),iston10tet(6,4), - & iscount,lnod,icont,iston4tet(3,4) -! - real*8 co(3,*),angle,shpder8q(2,4,8),shpder6tri(2,3,6), - & vectors(3,3),vlen(2),lastvec(3),angtmp,xl(3,8), - & shpder4q(2,4,4),shpder3tri(2,3,3),angmax -! -! ntosX(j,k) returns the three surface id's j for the corner node k -! for the element surfaces adjacent to the node -! - data ntos8h /1,3,6,1,3,4,1,4,5,1,5,6,2,3,6,2,3,4,2,4,5,2,5,6/ -! - data ntos4tet /1,2,4,1,2,3,1,3,4,2,3,4/ -! -! istonX(j,k) returns the nodes j of the element surface k -! - data iston8h /1,2,3,4,5,8,7,6,1,5,6,2,2,6,7,3,3,7,8,4,4,8,5,1/ -! - data iston20h /1,2,3,4,9,10,11,12,5,8,7,6,16,15,14,13, - & 1,5,6,2,17,13,18,9,2,6,7,3,18,14,19,10, - & 3,7,8,4,19,15,20,11,4,8,5,1,20,16,17,12/ -! - data iston4tet /1,2,3,1,4,2,2,4,3,3,4,1/ -! - data iston10tet /1,2,3,5,6 ,7,1,4,2,8 ,9,5, - & 2,4,3,9,10,6,3,4,1,10,8,7/ -! -! shpder8q contains the first derivative of the shape functions -! of a 8 node quadrilateral element with shpder8q(i,j,k) where i -! can be 1 for the xi-derivative or 2 for the eta-derivative j -! can be 1-4 for the location in the corner nodes to be evaluated -! for the element nodes k -! - data shpder8q / - & -1.5d0,-1.5d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0, - & -0.5d0, 0.0d0, 1.5d0,-1.5d0, 0.0d0, 0.5d0, 0.0d0, 0.0d0, - & 0.0d0, 0.0d0, 0.0d0,-0.5d0, 1.5d0, 1.5d0,-0.5d0, 0.0d0, - & 0.0d0,-0.5d0, 0.0d0, 0.0d0, 0.5d0, 0.0d0,-1.5d0, 1.5d0, - & 2.0d0, 0.0d0,-2.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, - & 0.0d0, 0.0d0, 0.0d0, 2.0d0, 0.0d0,-2.0d0, 0.0d0, 0.0d0, - & 0.0d0, 0.0d0, 0.0d0, 0.0d0,-2.0d0, 0.0d0, 2.0d0, 0.0d0, - & 0.0d0, 2.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,-2.0d0/ -! -! same as above for a 4 node linear quadrilateral element -! - data shpder4q / - & -0.5d0,-0.5d0,-0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,-0.5d0, - & 0.5d0, 0.0d0, 0.5d0,-0.5d0, 0.0d0,-0.5d0, 0.0d0, 0.0d0, - & 0.0d0, 0.0d0, 0.0d0, 0.5d0, 0.5d0, 0.5d0, 0.5d0, 0.0d0, - & 0.0d0, 0.5d0, 0.0d0, 0.0d0,-0.5d0, 0.0d0,-0.5d0, 0.5d0/ -! -! same as above for a 6 node quadratic triangular element -! - data shpder6tri / - & -3.0d0,-3.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, - & -1.0d0, 0.0d0, 3.0d0, 0.0d0,-1.0d0, 0.0d0, - & 0.0d0,-1.0d0, 0.0d0,-1.0d0, 0.0d0, 3.0d0, - & 4.0d0, 0.0d0,-4.0d0,-4.0d0, 0.0d0, 0.0d0, - & 0.0d0, 0.0d0, 0.0d0, 4.0d0, 4.0d0, 0.0d0, - & 0.0d0, 4.0d0, 0.0d0, 0.0d0,-4.0d0,-4.0d0/ -! -! same as above for a 3 node linear triangular element -! - data shpder3tri / - & -1.0d0,-1.0d0,-1.0d0,-1.0d0,-1.0d0,-1.0d0, - & 1.0d0, 0.0d0, 1.0d0, 0.0d0, 1.0d0, 0.0d0, - & 0.0d0, 1.0d0, 0.0d0, 1.0d0, 0.0d0, 1.0d0/ -! - character*8 lakon(*) -! - index=ipneigh(node) - icont=1 - iscount=0 - angmax=0.d0 -! - do - if(index.eq.0) exit - ielem=neigh(1,index) -! - if(lakon(ielem)(1:5).eq.'C3D20'.and.itypflag.eq.1) then - nvertex=8 - elseif(lakon(ielem)(1:5).eq.'C3D10'.and.itypflag.eq.2) then - nvertex=4 - elseif(lakon(ielem)(1:4).eq.'C3D8'.and.itypflag.eq.3) then - nvertex=8 - elseif(lakon(ielem)(1:4).eq.'C3D4'.and.itypflag.eq.4) then - nvertex=4 - else - index=neigh(2,index) - cycle - endif -! -! find the index of the node in the element -! - indexe=ipkon(ielem) - do m=1,nvertex - if(kon(indexe+m).eq.node) exit - enddo -! -! the local node number is m -! -! now every surface has to be checked -! - do j=1,3 - ifreesur(j)=0 - enddo -! - do isurf=1,3 -! -! finding the global node numbers of the -! nodes of the surface -! - if(nvertex.eq.4) then -! -! isidx: index of the surface neighbouring the node -! - isidx=ntos4tet(isurf,m) - elseif(nvertex.eq.8) then - isidx=ntos8h(isurf,m) - endif -! -! find out, if there is any element neighbouring 'node', -! which has also those nodes (-> surface is within volume) -! - index1=ipneigh(node) - do - if(index1.eq.0) exit - ielem1=neigh(1,index1) - if( - & .not.( - & lakon(ielem1)(1:5).eq.'C3D20'.and.itypflag.eq.1 - & .or. - & lakon(ielem1)(1:5).eq.'C3D10'.and.itypflag.eq.2 - & .or. - & lakon(ielem1)(1:4).eq.'C3D8'.and.itypflag.eq.3 - & .or. - & lakon(ielem1)(1:4).eq.'C3D4'.and.itypflag.eq.4 - & ) - & .or.ielem.eq.ielem1 - & ) then - index1=neigh(2,index1) - cycle - endif -! -! check every corner node in the element -! - ncount=0 - do k=1,3 - if(nvertex.eq.4) then - isnode=kon(indexe+iston4tet(k,isidx)) - elseif(nvertex.eq.8) then - isnode=kon(indexe+iston8h(k,isidx)) - endif - do j=1,nvertex - if(kon(ipkon(ielem1)+j).eq.isnode) - & ncount=ncount+1 - enddo - enddo -! - if(ncount.eq.3) then -! -! surface isurf is not a free surface -! - ifreesur(isurf)=1 - endif -! - index1=neigh(2,index1) - enddo - enddo -! - do isurf=1,3 - if(ifreesur(isurf).eq.0) then - iscount=iscount+1 - do i=1,3 - do j=1,3 - vectors(j,i)=0.d0 - enddo - enddo -! -! free surface: find out local node number -! of the 'surface element' neighbouring the -! node to be evaluated -! - if(nvertex.eq.8) then - isidx=ntos8h(isurf,m) - do j=1,4 - if( (isidx.eq.1.and.m.eq.1) - & .or.(isidx.eq.2.and.m.eq.5) - & .or.(isidx.eq.3.and.m.eq.1) - & .or.(isidx.eq.4.and.m.eq.2) - & .or.(isidx.eq.5.and.m.eq.3) - & .or.(isidx.eq.6.and.m.eq.4)) then - lnod=1 - elseif( (isidx.eq.1.and.m.eq.2) - & .or.(isidx.eq.2.and.m.eq.8) - & .or.(isidx.eq.3.and.m.eq.5) - & .or.(isidx.eq.4.and.m.eq.6) - & .or.(isidx.eq.5.and.m.eq.7) - & .or.(isidx.eq.6.and.m.eq.8)) then - lnod=2 - elseif( (isidx.eq.1.and.m.eq.3) - & .or.(isidx.eq.2.and.m.eq.7) - & .or.(isidx.eq.3.and.m.eq.6) - & .or.(isidx.eq.4.and.m.eq.7) - & .or.(isidx.eq.5.and.m.eq.8) - & .or.(isidx.eq.6.and.m.eq.5)) then - lnod=3 - elseif( (isidx.eq.1.and.m.eq.4) - & .or.(isidx.eq.2.and.m.eq.6) - & .or.(isidx.eq.3.and.m.eq.2) - & .or.(isidx.eq.4.and.m.eq.3) - & .or.(isidx.eq.5.and.m.eq.4) - & .or.(isidx.eq.6.and.m.eq.1)) then - lnod=4 - endif - enddo -! -c do k=1,8 -c write(*,*) 'node',node,' nodes', -c & kon(indexe+iston20h(k,isidx)),'lnod',lnod -c enddo -! - if(itypflag.eq.1) then -! -! get coordinates of the 2d-element nodes -! - do k=1,8 - do j=1,3 - xl(j,k)=co(j,kon(indexe+iston20h(k,isidx))) - enddo - enddo -! -! vectors(j,i) (i=1,2) is the j-derivative for the -! coordinates i. -! - do k=1,8 - do i=1,3 - do j=1,2 - vectors(j,i)=vectors(j,i)+ - & xl(i,k)*shpder8q(j,lnod,k) - enddo - enddo - enddo -! - elseif(itypflag.eq.3) then - do k=1,4 - do j=1,3 - xl(j,k)=co(j,kon(indexe+iston8h(k,isidx))) - enddo - enddo - do k=1,4 - do i=1,3 - do j=1,2 - vectors(j,i)=vectors(j,i)+ - & xl(i,k)*shpder4q(j,lnod,k) - enddo - enddo - enddo - endif -! - elseif(nvertex.eq.4) then - isidx=ntos4tet(isurf,m) - do j=1,3 - if( (isidx.eq.1.and.m.eq.1) - & .or.(isidx.eq.2.and.m.eq.1) - & .or.(isidx.eq.3.and.m.eq.2) - & .or.(isidx.eq.4.and.m.eq.3)) then - lnod=1 - elseif( (isidx.eq.1.and.m.eq.2) - & .or.(isidx.eq.2.and.m.eq.4) - & .or.(isidx.eq.3.and.m.eq.4) - & .or.(isidx.eq.4.and.m.eq.4)) then - lnod=2 - elseif( (isidx.eq.1.and.m.eq.3) - & .or.(isidx.eq.2.and.m.eq.2) - & .or.(isidx.eq.3.and.m.eq.3) - & .or.(isidx.eq.4.and.m.eq.1)) then - lnod=3 - endif - enddo -! - if(itypflag.eq.2) then - do k=1,6 - do j=1,3 - xl(j,k)=co(j,kon(indexe+iston10tet(k,isidx))) - enddo - enddo - do k=1,6 - do i=1,3 - do j=1,2 - vectors(j,i)=vectors(j,i)+ - & xl(i,k)*shpder6tri(j,lnod,k) - enddo - enddo - enddo - elseif(itypflag.eq.4) then - do k=1,3 - do j=1,3 - xl(j,k)=co(j,kon(indexe+iston4tet(k,isidx))) - enddo - enddo - do k=1,3 - do i=1,3 - do j=1,2 - vectors(j,i)=vectors(j,i)+ - & xl(i,k)*shpder3tri(j,lnod,k) - enddo - enddo - enddo - endif -! - endif -! -! vectors(3,i) is the normal vector of the surface in the -! evaluated node 'node' -! - vectors(3,1)=vectors(1,2)*vectors(2,3) - & -vectors(1,3)*vectors(2,2) - vectors(3,2)=vectors(1,3)*vectors(2,1) - & -vectors(1,1)*vectors(2,3) - vectors(3,3)=vectors(1,1)*vectors(2,2) - & -vectors(1,2)*vectors(2,1) - vlen(2)=dsqrt(vectors(3,1)*vectors(3,1) - & +vectors(3,2)*vectors(3,2) - & +vectors(3,3)*vectors(3,3)) -! - if(iscount.gt.1) then - angtmp=dabs((vectors(3,1)*lastvec(1) - & +vectors(3,2)*lastvec(2) - & +vectors(3,3)*lastvec(3)) - & /(vlen(1)*vlen(2))) - if(angtmp.lt.1.d0) then - angle=57.29577951d0*dacos(angtmp) - if(angle.gt.angmax) angmax=angle - else - angle=0.d0 - endif -! -! if the angle between the normal vectors of two -! surfaces is greater than 10 degree, than it is -! assumed that an edge (dicontinuity) is present -! - if(angle.ge.10.d0) then - icont=0 - endif - endif -! - do j=1,3 - lastvec(j)=vectors(3,j) - enddo - vlen(1)=vlen(2) -! - endif - enddo - index=neigh(2,index) - enddo - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/cident20.f calculix-ccx-2.3/ccx_2.1/src/cident20.f --- calculix-ccx-2.1/ccx_2.1/src/cident20.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cident20.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! -! identifies the position id of px in an ordered array -! x of integers; -! -! id is such that x(id).le.px and x(id+1).gt.px -! - SUBROUTINE cIDENT20(X,PX,N,ID) - IMPLICIT none - character*20 x,px - integer n,id,n2,m - DIMENSION X(N) - id=0 - if(n.eq.0) return - N2=N+1 - do - M=(N2+ID)/2 - IF(PX.GE.X(M)) then - ID=M - else - N2=M - endif - IF((N2-ID).EQ.1) return - enddo - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/cident.f calculix-ccx-2.3/ccx_2.1/src/cident.f --- calculix-ccx-2.1/ccx_2.1/src/cident.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cident.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! -! identifies the position id of px in an ordered array -! x of integers; -! -! id is such that x(id).le.px and x(id+1).gt.px -! - SUBROUTINE cIDENT(X,PX,N,ID) - IMPLICIT none - character*81 x,px - integer n,id,n2,m - DIMENSION X(N) - id=0 - if(n.eq.0) return - N2=N+1 - do - M=(N2+ID)/2 - IF(PX.GE.X(M)) then - ID=M - else - N2=M - endif - IF((N2-ID).EQ.1) return - enddo - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/cloads.f calculix-ccx-2.3/ccx_2.1/src/cloads.f --- calculix-ccx-2.1/ccx_2.1/src/cloads.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/cloads.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,231 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine cloads(inpc,textpart,set,istartset,iendset, - & ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, - & amname,nam,ntrans,trab,inotr,co,ikforc,ilforc,nk, - & cload_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_, - & namtot_,namta,amta,nmethod,iaxial,iperturb,ipoinpc, - & maxsectors) -! -! reading the input deck: *CLOADS -! - implicit none -! - logical cload_flag,add -! - character*1 inpc(*) - character*80 amplitude,amname(*) - character*81 set(*),noset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),nodeforc(2,*), - & nset,nforc,nforc_,istep,istat,n,i,j,k,l,iforcdir,key, - & iamforc(*),nam,iamplitude,ntrans,inotr(2,*),ipos,ikforc(*), - & ilforc(*),nk,iline,ipol,inl,ipoinp(2,*),inp(3,*),nam_,namtot, - & namtot_,namta(3,*),idelay,lc,nmethod,ndirforc(*),isector, - & iperturb,iaxial,ipoinpc(0:*),maxsectors,jsector -! - real*8 xforc(*),forcval,co(3,*),trab(7,*),amta(2,*) -! - iamplitude=0 - idelay=0 - lc=1 - isector=0 - add=.false. -! - if(istep.lt.1) then - write(*,*) '*ERROR in cloads: *CLOAD should only be used' - write(*,*) ' within a STEP' - stop - endif -! - do i=2,n - if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.cload_flag)) then - do j=1,nforc - xforc(j)=0.d0 - enddo - elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then - read(textpart(i)(11:90),'(a80)') amplitude - do j=1,nam - if(amname(j).eq.amplitude) then - iamplitude=j - exit - endif - enddo - if(j.gt.nam) then - write(*,*)'*ERROR in cloads: nonexistent amplitude' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iamplitude=j - elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN - if(idelay.ne.0) then - write(*,*) '*ERROR in cloads: the parameter TIME DELAY' - write(*,*) ' is used twice in the same keyword' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - else - idelay=1 - endif - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in cloads: increase nam_' - stop - endif - amname(nam)=' - & ' - if(iamplitude.eq.0) then - write(*,*) '*ERROR in cloads: time delay must be' - write(*,*) ' preceded by the amplitude parameter' - stop - endif - namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) - iamplitude=nam - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) '*ERROR cloads: increase namtot_' - stop - endif - namta(1,nam)=namtot - namta(2,nam)=namtot - read(textpart(i)(11:30),'(f20.0)',iostat=istat) - & amta(1,namtot) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:9).eq.'LOADCASE=') then - read(textpart(i)(10:19),'(i10)',iostat=istat) lc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(nmethod.ne.5) then - write(*,*) '*ERROR in cloads: the parameter LOAD CASE' - write(*,*) ' is only allowed in STEADY STATE' - write(*,*) ' DYNAMICS calculations' - stop - endif - elseif(textpart(i)(1:7).eq.'SECTOR=') then - read(textpart(i)(8:17),'(i10)',iostat=istat) isector - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if((nmethod.le.3).or.(iperturb.gt.1)) then - write(*,*) '*ERROR in cloads: the parameter SECTOR' - write(*,*) ' is only allowed in MODAL DYNAMICS or' - write(*,*) ' STEADY STATE DYNAMICS calculations' - stop - endif - if(isector.gt.maxsectors) then - write(*,*) '*ERROR in cloads: sector ',isector - write(*,*) ' exceeds number of sectors' - stop - endif - isector=isector-1 - endif - enddo -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return -! - read(textpart(2)(1:10),'(i10)',iostat=istat) iforcdir - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if((iforcdir.lt.1).or.(iforcdir.gt.6)) then - write(*,*) '*ERROR in cloads: nonexistent degree of freedom' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - if(iforcdir.gt.3) iforcdir=iforcdir+1 -! - if(textpart(3)(1:1).eq.' ') then - forcval=0.d0 - else - read(textpart(3)(1:20),'(f20.0)',iostat=istat) forcval - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(iaxial.ne.0) forcval=forcval/iaxial - endif -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - if(l.gt.nk) then - write(*,*) '*ERROR in cloads: node ',l - write(*,*) ' is not defined' - stop - endif - if(lc.ne.1) then - jsector=isector+maxsectors - else - jsector=isector - endif - call forcadd(l,iforcdir,forcval,nodeforc,ndirforc,xforc, - & nforc,nforc_,iamforc,iamplitude,nam,ntrans,trab,inotr,co, - & ikforc,ilforc,jsector,add) - else - read(textpart(1)(1:80),'(a80)',iostat=istat) noset - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - do i=1,nset - if(set(i).eq.noset) exit - enddo - if(i.gt.nset) then - noset(ipos:ipos)=' ' - write(*,*) '*ERROR in cloads: node set ',noset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - k=ialset(j) - if(lc.ne.1) then - jsector=isector+maxsectors - else - jsector=isector - endif - call forcadd(k,iforcdir,forcval, - & nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, - & iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc, - & jsector,add) - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - if(lc.ne.1) then - jsector=isector+maxsectors - else - jsector=isector - endif - call forcadd(k,iforcdir,forcval, - & nodeforc,ndirforc,xforc,nforc,nforc_, - & iamforc,iamplitude,nam,ntrans,trab,inotr,co, - & ikforc,ilforc,jsector,add) - enddo - endif - enddo - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/closefile.f calculix-ccx-2.3/ccx_2.1/src/closefile.f --- calculix-ccx-2.1/ccx_2.1/src/closefile.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/closefile.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine closefile() - implicit none -! -! closes files at the end of the calculation -! - logical frd,rout -! - character*5 p9999 -! -! closing the .inp file -! - close(1) -! -! closing the .dat file -! - close(5) -! - inquire(7,opened=frd) - if(frd) then -! -! closing the .frd file -! - p9999=' 9999' - write(7,'(a5)') p9999 - close(7) - else -! -! closing the .onf file -! - close(11) - endif -! -! closing the .sta file -! - close(11) -! -! closing the .rout file -! - inquire(15,opened=rout) - if(rout) close(15) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/compdt.f calculix-ccx-2.3/ccx_2.1/src/compdt.f --- calculix-ccx-2.1/ccx_2.1/src/compdt.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/compdt.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine compdt(nk,dt,nshcon,shcon,nrhcon,rhcon,vold,ntmat_, - & iponoel,inoel,dtimef,iexplicit,ielmat,physcon,dh,cocon, - & ncocon,ithermal,mi) -! -! - determine the time step for each node (stored in field dt -! and the minimum value across all nodes (dtimef) -! - implicit none -! - logical iexplicit -! - integer nk,i,iponoel(*),inoel(3,*),index,nelem,ithermal, - & nshcon(*),nrhcon(*),ntmat_,ielmat(*),imat,ncocon(2,*),mi(2) -! - real*8 dtimef,dt(*),dvi,r,cp,rho,shcon(0:3,ntmat_,*), - & rhcon(0:1,ntmat_,*),vold(0:mi(2),*),temp,vel,dtu,dtnu, - & physcon(*),dh(*),cocon(0:6,ntmat_,*),dtal,cond -! -! -! determining the time increment dt for each node. -! -! edge nodes (fields iponoel and inoel are determined in precfd.f) -! - do i=1,nk - index=iponoel(i) - if(index.le.0) cycle -! -! look at an element belonging to the edge node -! - nelem=inoel(1,index) -! -! determining the time increment -! - imat=ielmat(nelem) - temp=vold(0,i) -c call materialdata_tg(imat,ntmat_,temp,shcon,nshcon,cp,r,dvi, -c & rhcon,nrhcon,rho) -! -! density for gases -! - vel=dsqrt(vold(1,i)**2+vold(2,i)**2+vold(3,i)**2) - if(iexplicit) then - call materialdata_cp(imat,ntmat_,temp,shcon,nshcon,cp) - r=shcon(3,1,imat) - dt(i)=dh(i)/(dsqrt(cp*r*temp/(cp-r))+vel) - else - call materialdata_dvi(imat,ntmat_,temp,shcon,nshcon,dvi) - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) - if(vel.lt.1.d-10) vel=1.d-10 - dtu=dh(i)/vel - if(dvi.lt.1.d-10) dvi=1.d-10 - dtnu=dh(i)*dh(i)*rho/(2.d0*dvi) - dt(i)=dtu*dtnu/(dtu+dtnu) - if(ithermal.gt.1) then - call materialdata_cond(imat,ntmat_,temp,cocon,ncocon, - & cond) - call materialdata_cp(imat,ntmat_,temp,shcon,nshcon,cp) - if(cond.lt.1.d-10) cond=1.d-10 - dtal=dh(i)*dh(i)*rho*cp/(2.d0*cond) - dt(i)=(dt(i)*dtal)/(dt(i)+dtal) - endif -c write(*,*) 'compdt ',i,dtu,dtnu,dt(i),dh(i),rho,dvi,vel - endif -! - enddo -! -! middle nodes (interpolation between neighboring end nodes; -! still to be done) -! -! -! determining the minimum height across the complete fluid mesh -! - dtimef=1.d30 - do i=1,nk - if(dt(i).gt.0.d0) dtimef=min(dt(i),dtimef) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/compfluid.c calculix-ccx-2.3/ccx_2.1/src/compfluid.c --- calculix-ccx-2.1/ccx_2.1/src/compfluid.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/compfluid.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1086 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES -#include "spooles.h" -#endif -#ifdef SGI -#include "sgi.h" -#endif -#ifdef TAUCS -#include "tau.h" -#endif -#ifdef PARDISO -#include "pardiso.h" -#endif - -char *lakon1,*sideload1, *matname1, *sideface1; - -int *nk1,*kon1,*ipkon1,*ne1,*nodeboun1,*ndirboun1,*nboun1,*ipompc1, - *nodempc1,*nmpc1,*nodeforc1,*ndirforc1,*nforc1,*nelemload1,*nload1, - *ipobody1,*nbody1,*nactdoh1,*icolv1,*jqv1,*irowv1,neqv1,nzlv1,*nmethod1, - *ikmpc1,*ilmpc1,*ikboun1,*ilboun1,*nrhcon1,*ielmat1,*ntmat_1,*ithermal1, - nzsv1,*mi1,*ncmat_1,*nshcon1,*istep1,*iinc1,*ibody1,*turbulent1, - *nelemface1,*nface1,compressible1,num_cpus,*icolp1,*jqp1,*irowp1, - neqp1,nzlp1,nzsp1,iexplicit1,*ncocon1,neqt1,nzst1; - -double *co1,*xboun1,*coefmpc1,*xforc1,*xload1,*xbody1,*rhcon1,*t01, - *vold1,*voldaux1,dtimef1,*physcon1,*shcon1,*ttime1,timef1,*xloadold1, - *voldtu1,*yy1,*b=NULL,*xbounact1,theta11,*v1,theta21,*cocon1, - reltimef1; - -void compfluid(double *co, int *nk, int *ipkon, int *kon, char *lakon, - int *ne, int *ipoface, char *sideface, int *ifreestream, - int *nfreestream, int *isolidsurf, int *neighsolidsurf, - int *nsolidsurf, int *iponoel, int *inoel, int *nshcon, double *shcon, - int *nrhcon, double *rhcon, double *vold, int *ntmat_,int *nodeboun, - int *ndirboun, int *nboun, int *ipompc,int *nodempc, int *nmpc, - int *ikmpc, int *ilmpc, int *ithermal, int *ikboun, int *ilboun, - int *turbulent, int *isolver, int *iexpl, double *voldtu, double *ttime, - double *time, double *dtime, int *nodeforc,int *ndirforc,double *xforc, - int *nforc, int *nelemload, char *sideload, double *xload,int *nload, - double *xbody,int *ipobody,int *nbody, int *ielmat, char *matname, - int *mi, int *ncmat_, double *physcon, int *istep, int *iinc, - int *ibody, double *xloadold, double *xboun, - double *coefmpc, int *nmethod, double *xforcold, double *xforcact, - int *iamforc,int *iamload, double *xbodyold, double *xbodyact, - double *t1old, double *t1, double *t1act, int *iamt1, double *amta, - int *namta, int *nam, double *ampli, double *xbounold, double *xbounact, - int *iamboun, int *itg, int *ntg, char *amname, double *t0, int *nelemface, - int *nface, double *cocon, int *ncocon, double *xloadact, double *tper, - int *jmax, int *jout, char *set, int *nset, int *istartset, - int *iendset, int *ialset, char *prset, char *prlab, int *nprint, - double *trab, int *inotr, int *ntrans, char *filab, char *labmpc){ - - /* main computational fluid dynamics routine */ - - /* References: - - Zienkiewicz, O.C., Taylor, R.L. and Nithiarasu, P., "The Finite - Element Method for Fluid Dynamics", 6th Edition, Elsevier (2006) - - Menter, F.R., "Two-Equation Eddy-Viscosity Turbulence Models - for Engineering Applications", AIAA Journal(1994), 32(8), - 1598-1605 */ - - int *ipointer=NULL, *mast1=NULL, *irowt=NULL, *irowv=NULL, *irowp=NULL, - *irowk=NULL, *icolt=NULL, *icolv=NULL, *icolp=NULL, *icolk=NULL, - *jqt=NULL, *jqv=NULL, *jqp=NULL, *jqk=NULL, *nactdoh=NULL,i,j, - *nactdok=NULL, *nx=NULL, *ny=NULL, *nz=NULL,nzs,neqt,neqv,neqp, - neqk,nzst,nzsv,nzsp,nzsk,iexplicit,nzlt,nzlv,nzlp,nzlk,kode,nnstep, - convergence,iout,iit,symmetryflag=0,inputformat=0,compressible, - nmethodd,nstate_,*ielorien=NULL,norien,*inum=NULL,ismooth=0, - *inomat=NULL,ikin=0,mt=mi[1]+1; - - double *yy=NULL, *xsolidsurf=NULL, *dt=NULL, *voldaux=NULL, *x=NULL, - *y=NULL, *z=NULL, *xo=NULL, *yo=NULL, *zo=NULL, *adbt=NULL, - *aubt=NULL, *adbv=NULL, *aubv=NULL, *adbp=NULL, *aubp=NULL, - *adbk=NULL, *aubk=NULL,*v=NULL, *vtu=NULL,timef,ttimef, - dtimef,*addiv=NULL,*sol=NULL, *aux=NULL,shockscale, - *bk=NULL,*bt=NULL,*solk=NULL,*solt=NULL,theta1,theta2,*adb=NULL, - *aub=NULL,sigma=0.,*dh=NULL,reltimef,*fn=NULL,*stx=NULL, - *eme=NULL,*qfx=NULL,*orab=NULL,*xstate=NULL,*ener=NULL, - csmooth=0.,shockcoefref=2.,*sa=NULL,*sav=NULL,shockcoef=2., - *adlt=NULL,*adlv=NULL,*adlp=NULL,*adlk=NULL; - - /* standard: shockcoef=2 */ - -#ifdef SGI - int token; -#endif - - /* variables for multithreading procedure */ - - int sys_cpus; - char *env; - - num_cpus = 0; -#ifdef _SC_NPROCESSORS_CONF - sys_cpus = sysconf(_SC_NPROCESSORS_CONF); - if (sys_cpus <= 0) - sys_cpus = 1; -#else - sys_cpus = 1; -#endif - env = getenv("CCX_NPROC"); - if (env) - num_cpus = atoi(env); - if (num_cpus > 0) { -// if (num_cpus > sys_cpus) -// num_cpus = sys_cpus; - } else if (num_cpus == -1) { - num_cpus = sys_cpus; - } else { - num_cpus = 1; - } - printf("Using up to %d cpu(s) for spooles.\n", num_cpus); - - pthread_t tid[num_cpus]; - - kode=0; - - /* *iexpl==0: structure:implicit, fluid:semi-implicit - *iexpl==1: structure:implicit, fluid:explicit - *iexpl==2: structure:explicit, fluid:semi-implicit - *iexpl==3: structure:explicit, fluid:explicit */ - - if((*iexpl==1)||(*iexpl==3)){ - iexplicit=1;theta1=0.5;theta2=0.;compressible=1; - }else{ - iexplicit=0; - theta1=1.0;theta2=1.0;compressible=0; - } - - /* if initial conditions are specified for the temperature, - it is assumed that the temperature is an unknown */ - - if(*ithermal==1) *ithermal=2; - - /* determining the matrix structure */ - - nzs=1000000; - - ipointer=NNEW(int,3**nk); - mast1=NNEW(int,nzs); - irowv=NNEW(int,nzs); - irowp=NNEW(int,nzs); - icolv=NNEW(int,3**nk); - icolp=NNEW(int,*nk); - jqv=NNEW(int,3**nk+1); - jqp=NNEW(int,*nk+1); - nactdoh=NNEW(int,mt**nk); - inomat=NNEW(int,*nk); - - if(*ithermal>1){ - irowt=NNEW(int,nzs); - icolt=NNEW(int,*nk); - jqt=NNEW(int,*nk+1); - } - - if(*turbulent!=0){ - irowk=NNEW(int,nzs); - icolk=NNEW(int,*nk); - jqk=NNEW(int,*nk+1); - nactdok=NNEW(int,*nk); - } - - mastructf(nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,nboun,ipompc, - nodempc,nmpc,nactdoh,icolt,icolv,icolp,icolk,jqt,jqv,jqp, - jqk,&mast1,&irowt,&irowv,&irowp,&irowk,isolver,&neqt,&neqv, - &neqp,&neqk,ikmpc,ilmpc,ipointer,&nzst,&nzsv,&nzsp,&nzsk, - ithermal,ikboun,ilboun,turbulent,nactdok,ifreestream,nfreestream, - isolidsurf,nsolidsurf,&nzs,&iexplicit,ielmat,inomat,labmpc); - - free(ipointer);free(mast1); - - /* initialization */ - - yy=NNEW(double,*nk); - xsolidsurf=NNEW(double,*nsolidsurf); - dh=NNEW(double,*nk); - voldaux=NNEW(double,mt**nk); - x=NNEW(double,*nsolidsurf); - y=NNEW(double,*nsolidsurf); - z=NNEW(double,*nsolidsurf); - xo=NNEW(double,*nsolidsurf); - yo=NNEW(double,*nsolidsurf); - zo=NNEW(double,*nsolidsurf); - nx=NNEW(int,*nsolidsurf); - ny=NNEW(int,*nsolidsurf); - nz=NNEW(int,*nsolidsurf); - - FORTRAN(initialcfd,(yy,nk,co,ne,ipkon,kon,lakon,x,y,z,xo,yo,zo, - nx,ny,nz,isolidsurf,neighsolidsurf,xsolidsurf,dh,nshcon,shcon, - nrhcon,rhcon,vold,voldaux,ntmat_,iponoel,inoel, - &iexplicit,ielmat,nsolidsurf,turbulent,physcon,&compressible, - matname,inomat,voldtu,mi)); - - free(x);free(y);free(z);free(xo);free(yo);free(zo);free(nx);free(ny); - free(nz); - - /* composing those left hand sides which do not depend on the increment */ - - /* lhs for the energy */ - - if(*ithermal>1){ - adbt=NNEW(double,neqt); - aubt=NNEW(double,nzst); - - FORTRAN(mafilltlhs,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - xboun,nboun,ipompc,nodempc,coefmpc,nmpc, - nactdoh,icolt,jqt,irowt,&neqt,&nzlt, - ikmpc,ilmpc,ikboun,ilboun,&nzst,adbt,aubt)); - - adlt=NNEW(double,neqt); - FORTRAN(lump,(adbt,aubt,adlt,irowt,jqt,&neqt)); - } - - /* lhs for the velocity */ - - adbv=NNEW(double,neqv); - aubv=NNEW(double,nzsv); - - FORTRAN(mafillvlhs,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - xboun,nboun,ipompc,nodempc,coefmpc,nmpc, - nactdoh,icolv,jqv,irowv,&neqv,&nzlv, - ikmpc,ilmpc,ikboun,ilboun,&nzsv,adbv,aubv)); - - adlv=NNEW(double,neqv); - FORTRAN(lump,(adbv,aubv,adlv,irowv,jqv,&neqv)); - - /* lhs for the pressure */ - - adbp=NNEW(double,neqp); - aubp=NNEW(double,nzsp); - - FORTRAN(mafillplhs,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nactdoh,icolp,jqp, - irowp,&neqp,&nzlp,ikmpc,ilmpc,ikboun,ilboun,&nzsp,adbp,aubp, - nmethod,&iexplicit)); - - if(iexplicit==1){ - adlp=NNEW(double,neqp); - FORTRAN(lump,(adbp,aubp,adlp,irowp,jqp,&neqp)); - } - - if((iexplicit!=1)&&(neqp>0)){ - - /* LU decomposition of the left hand matrix */ - - if(*isolver==0){ -#ifdef SPOOLES - spooles_factor(adbp,aubp,adb,aub,&sigma,icolp,irowp,&neqp,&nzsp, - &symmetryflag,&inputformat); -#else - printf("*ERROR in compfluid: the SPOOLES library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==4){ -#ifdef SGI - token=1; - sgi_factor(adbp,aubp,adb,aub,&sigma,icolp,irowp,&neqp,&nzsp,token); -#else - printf("*ERROR in compfluid: the SGI library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau_factor(adbp,&aubp,adb,aub,&sigma,icolp,&irowp,&neqp,&nzsp); -#else - printf("*ERROR in compfluid: the TAUCS library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_factor(adbp,aubp,adb,aub,&sigma,icolp,irowp,&neqp,&nzsp); -#else - printf("*ERROR in compfluid: the PARDISO library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - - } - - /* lhs for the turbulent */ - - if(*turbulent!=0){ - adbk=NNEW(double,neqk); - aubk=NNEW(double,nzsk); - FORTRAN(mafillklhs,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - xboun,nboun,ipompc,nodempc,coefmpc,nmpc, - nactdok,icolk,jqk,irowk,&neqk,&nzlk, - ikmpc,ilmpc,ikboun,ilboun,&nzsk,adbk,aubk)); - - adlk=NNEW(double,neqk); - FORTRAN(lump,(adbk,aubk,adlk,irowk,jqk,&neqk)); - } - - /* starting the main loop */ - - v=NNEW(double,mt**nk); - vtu=NNEW(double,2**nk); - - /* ttimef is the total time up to the start of the present increment - timef is the step time up to the end of the present increment - dtimef is the present increment size */ - - ttimef=*ttime; - timef=*time-*dtime; - dt=NNEW(double,*nk); - - iit=0; - - do{ - - iit++; - - /* determining a new time increment */ - - FORTRAN(compdt,(nk,dt,nshcon,shcon,nrhcon,rhcon,vold,ntmat_,iponoel, - inoel,&dtimef,&iexplicit,ielmat,physcon,dh,cocon,ncocon,ithermal, - mi)); - - /* fixed time */ - - /*if(iexplicit==1) dtimef=1.e-4;*/ - /*if(iexplicit==1) dtimef/=3.;*/ - - timef+=dtimef; - if((*dtime1.) reltimef=1.; - /*printf("timef=%e,dtimef=%e\n",timef,dtimef);*/ - - /* determining the instantaneous load */ - - if(*nmethod==1){ - nmethodd=4; - FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc, - xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, - xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, - namta,nam,ampli,time,&reltimef,ttime,dtime,ithermal,&nmethodd, - xbounold,xboun,xbounact,iamboun,nboun, - nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, - co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload,mi)); -/* FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc, - xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, - xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, - namta,nam,ampli,&timef,&reltimef,&ttimef,&dtimef,ithermal,nmethod, - xbounold,xboun,xbounact,iamboun,nboun, - nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, - co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload));*/ - }else if(*nmethod==4){ - FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc, - xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, - xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, - namta,nam,ampli,&timef,&reltimef,&ttimef,&dtimef,ithermal,nmethod, - xbounold,xboun,xbounact,iamboun,nboun, - nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, - co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload,mi)); - } - - /* if((iit/jout[1])*jout[1]==iit){ - nnstep=6; - FORTRAN(frddummy,(co,nk,kon,ipkon,lakon,ne,v,vold, - &kode,&timef,ielmat,matname,&nnstep,vtu,voldtu,voldaux)); - }*/ - - /* STEP 1: velocity correction */ - -/* printf("STEP1: velocity correction\n\n");*/ - - b=NNEW(double,num_cpus*neqv); - - co1=co;nk1=nk;kon1=kon;ipkon1=ipkon;lakon1=lakon;ne1=ne; - nodeboun1=nodeboun;ndirboun1=ndirboun;xboun1=xboun;nboun1=nboun; - ipompc1=ipompc;nodempc1=nodempc,coefmpc1=coefmpc;nmpc1=nmpc; - nodeforc1=nodeforc;ndirforc1=ndirforc;xforc1=xforc;nforc1=nforc; - nelemload1=nelemload;sideload1=sideload;xload1=xload;nload1=nload; - xbody1=xbody;ipobody1=ipobody;nbody1=nbody;nactdoh1=nactdoh; - icolv1=icolv;jqv1=jqv;irowv1=irowv;neqv1=neqv;nzlv1=nzlv; - nmethod1=nmethod;ikmpc1=ikmpc;ilmpc1=ilmpc;ikboun1=ikboun; - ilboun1=ilboun;rhcon1=rhcon;nrhcon1=nrhcon;ielmat1=ielmat; - ntmat_1=ntmat_;t01=t0;ithermal1=ithermal;vold1=vold;voldaux1=voldaux; - nzsv1=nzsv;dtimef1=dtimef;matname1=matname;mi1=mi;ncmat_1=ncmat_; - physcon1=physcon;shcon1=shcon;nshcon1=nshcon;ttime1=ttime; - timef1=timef;istep1=istep;iinc1=iinc;ibody1=ibody;xloadold1=xloadold; - turbulent1=turbulent;voldtu1=voldtu;yy1=yy;nelemface1=nelemface; - sideface1=sideface;nface1=nface;compressible1=compressible; - - /* create threads and wait */ - - for(i=0; i0)){ - aux=NNEW(double,neqp); - FORTRAN(solveeq,(adbp,aubp,adlp,addiv,b,sol,aux,icolp,irowp,jqp, - &neqp,&nzsp,&nzlp)); - free(b);free(aux); - }else if(neqp>0){ - - /* solving the system of equations (only for liquids) */ - - if(*isolver==0){ -#ifdef SPOOLES - spooles_solve(b,&neqp); -#endif - } - else if(*isolver==4){ -#ifdef SGI - sgi_solve(b,token); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau_solve(b,&neqp); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_solve(b,&neqp); -#endif - } - - /* copying the solution into field sol */ - - for(i=0;i1){ - -/* b=NNEW(double,neqt); - int nea=1; - int neb=*ne; - - FORTRAN(mafilltrhs,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody, - b,nactdoh,&neqt,nmethod,ikmpc,ilmpc,ikboun, - ilboun,rhcon,nrhcon,ielmat,ntmat_,t0,ithermal,vold,voldaux,&nzst, - &dtimef,matname,mi,ncmat_,physcon,shcon,nshcon,ttime,&timef, - istep,iinc,ibody,xloadold,&reltimef,cocon,ncocon,nelemface, - sideface,nface,&compressible,v,voldtu,yy,turbulent,&nea,&neb));*/ - - b=NNEW(double,num_cpus*neqt); - - co1=co;nk1=nk;kon1=kon;ipkon1=ipkon;lakon1=lakon;ne1=ne; - nodeboun1=nodeboun;ndirboun1=ndirboun;xboun1=xboun;nboun1=nboun; - ipompc1=ipompc;nodempc1=nodempc,coefmpc1=coefmpc;nmpc1=nmpc; - nodeforc1=nodeforc;ndirforc1=ndirforc;xforc1=xforc;nforc1=nforc; - nelemload1=nelemload;sideload1=sideload;xload1=xload;nload1=nload; - xbody1=xbody;ipobody1=ipobody;nbody1=nbody;nactdoh1=nactdoh; - neqt1=neqt; - nmethod1=nmethod;ikmpc1=ikmpc;ilmpc1=ilmpc;ikboun1=ikboun; - ilboun1=ilboun;rhcon1=rhcon;nrhcon1=nrhcon;ielmat1=ielmat; - ntmat_1=ntmat_;t01=t0;ithermal1=ithermal;vold1=vold;voldaux1=voldaux; - nzst1=nzst;dtimef1=dtimef;matname1=matname;mi1=mi;ncmat_1=ncmat_; - physcon1=physcon;shcon1=shcon;nshcon1=nshcon;ttime1=ttime; - timef1=timef;istep1=istep;iinc1=iinc;ibody1=ibody;xloadold1=xloadold; - reltimef1=reltimef;cocon1=cocon;ncocon1=ncocon;nelemface1=nelemface; - sideface1=sideface;nface1=nface;compressible1=compressible;v1=v; - voldtu1=voldtu;yy1=yy;turbulent1=turbulent; - - for(i=0; i1){ - free(irowt);free(icolt);free(jqt);free(adbt);free(aubt);free(adlt); - } - - if(*turbulent!=0){ - free(irowk);free(icolk);free(jqk);free(nactdok); - free(adbk);free(aubk);free(adlk); - } - - free(v);free(vtu); - - return; - -} - -/* subroutine for multithreading of mafillv1rhs */ - -void *mafillv1rhsmt(void *i){ - - int index,nea,neb,nedelta; - - index=((int)i)*neqv1; - - nedelta=(int)ceil(*ne1/(double)num_cpus); - nea=((int)i)*nedelta+1; - neb=(((int)i)+1)*nedelta; - if(neb>*ne1) neb=*ne1; - - FORTRAN(mafillv1rhs,(co1,nk1,kon1,ipkon1,lakon1,ne1,nodeboun1,ndirboun1, - xboun1,nboun1,ipompc1,nodempc1,coefmpc1,nmpc1,nodeforc1,ndirforc1,xforc1, - nforc1,nelemload1,sideload1,xload1,nload1,xbody1,ipobody1,nbody1, - &b[index],nactdoh1,icolv1,jqv1,irowv1,&neqv1,&nzlv1,nmethod1,ikmpc1,ilmpc1,ikboun1, - ilboun1,rhcon1,nrhcon1,ielmat1,ntmat_1,t01,ithermal1,vold1,voldaux1,&nzsv1, - &dtimef1,matname1,mi1,ncmat_1,physcon1,shcon1,nshcon1,ttime1,&timef1, - istep1,iinc1,ibody1,xloadold1,turbulent1,voldtu1,yy1, - nelemface1,sideface1,nface1,&compressible1,&nea,&neb)); - - return NULL; -} - -/* subroutine for multithreading of mafillprhs */ - -void *mafillprhsmt(void *i){ - - int index,nea,neb,nedelta; - - index=((int)i)*neqp1; - - nedelta=(int)ceil(*ne1/(double)num_cpus); - nea=((int)i)*nedelta+1; - neb=(((int)i)+1)*nedelta; - if(neb>*ne1) neb=*ne1; - - FORTRAN(mafillprhs,(co1,nk1,kon1,ipkon1,lakon1,ne1,nodeboun1,ndirboun1, - xbounact1,nboun1,ipompc1,nodempc1,coefmpc1,nmpc1,nelemface1,sideface1, - nface1,&b[index],nactdoh1,icolp1,jqp1,irowp1,&neqp1,&nzlp1,nmethod1,ikmpc1,ilmpc1, - ikboun1,ilboun1,rhcon1,nrhcon1,ielmat1,ntmat_1,vold1,voldaux1,&nzsp1, - &dtimef1,matname1,mi1,ncmat_1,shcon1,nshcon1,v1,&theta11, - &iexplicit1,physcon1,&nea,&neb)); - - return NULL; -} - -/* subroutine for multithreading of mafillv2rhs */ - -void *mafillv2rhsmt(void *i){ - - int index,nea,neb,nedelta; - - index=((int)i)*neqv1; - - nedelta=(int)ceil(*ne1/(double)num_cpus); - nea=((int)i)*nedelta+1; - neb=(((int)i)+1)*nedelta; - if(neb>*ne1) neb=*ne1; - - FORTRAN(mafillv2rhs,(co1,nk1,kon1,ipkon1,lakon1,ne1,nodeboun1,ndirboun1, - xboun1,nboun1,ipompc1,nodempc1,coefmpc1,nmpc1, - &b[index],nactdoh1,icolv1,jqv1,irowv1,&neqv1,&nzlv1,nmethod1,ikmpc1,ilmpc1,ikboun1, - ilboun1,vold1,&nzsv1,&dtimef1,v1,&theta21,&iexplicit1,&nea,&neb,mi1)); - - return NULL; -} - -/* subroutine for multithreading of mafilltrhs */ - -void *mafilltrhsmt(void *i){ - - int index,nea,neb,nedelta; - - index=((int)i)*neqt1; - - nedelta=(int)ceil(*ne1/(double)num_cpus); - nea=((int)i)*nedelta+1; - neb=(((int)i)+1)*nedelta; - if(neb>*ne1) neb=*ne1; - - FORTRAN(mafilltrhs,(co1,nk1,kon1,ipkon1,lakon1,ne1,nodeboun1,ndirboun1, - xboun1,nboun1,ipompc1,nodempc1,coefmpc1,nmpc1,nodeforc1,ndirforc1,xforc1, - nforc1,nelemload1,sideload1,xload1,nload1,xbody1,ipobody1,nbody1, - &b[index],nactdoh1,&neqt1,nmethod1,ikmpc1,ilmpc1,ikboun1, - ilboun1,rhcon1,nrhcon1,ielmat1,ntmat_1,t01,ithermal1,vold1,voldaux1,&nzst1, - &dtimef1,matname1,mi1,ncmat_1,physcon1,shcon1,nshcon1,ttime1,&timef1, - istep1,iinc1,ibody1,xloadold1,&reltimef1,cocon1,ncocon1,nelemface1, - sideface1,nface1,&compressible1,v1,voldtu1,yy1,turbulent1,&nea,&neb)); - - return NULL; -} - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/conductivities.f calculix-ccx-2.3/ccx_2.1/src/conductivities.f --- calculix-ccx-2.1/ccx_2.1/src/conductivities.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/conductivities.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,129 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine conductivities(inpc,textpart,cocon,ncocon, - & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & ipoinpc) -! -! reading the input deck: *CONDUCTIVITY -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer ncocon(2,*),nmat,ntmat,ntmat_,istep,istat,n,ipoinpc(0:*), - & i,ityp,key,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - real*8 cocon(0:6,ntmat_,*) -! - ntmat=0 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in conductivities: *CONDUCTIVITY should be' - write(*,*) ' placed before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*)'*ERROR in conductivities: *CONDUCTIVITY should be' - write(*,*) ' preceded by a *MATERIAL card' - stop - endif -! - ityp=1 -! - do i=2,n - if(textpart(i)(1:5).eq.'TYPE=') then - if(textpart(i)(6:8).eq.'ISO') then - ityp=1 - elseif(textpart(i)(6:10).eq.'ORTHO') then - ityp=3 - elseif(textpart(i)(6:10).eq.'ANISO') then - ityp=6 - endif - endif - enddo -! - ncocon(1,nmat)=ityp -! - if(ityp.eq.1) then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - ncocon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in conductivities: increase ntmat_' - stop - endif - do i=1,1 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & cocon(i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - read(textpart(2)(1:20),'(f20.0)',iostat=istat) - & cocon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - elseif(ityp.eq.3) then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - ncocon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in conductivities: increase ntmat_' - stop - endif - do i=1,3 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & cocon(i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - read(textpart(4)(1:20),'(f20.0)',iostat=istat) - & cocon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - elseif(ityp.eq.6) then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - ncocon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in conductivities: increase ntmat_' - stop - endif - do i=1,6 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & cocon(i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - read(textpart(7)(1:20),'(f20.0)',iostat=istat) - & cocon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/contact.c calculix-ccx-2.3/ccx_2.1/src/contact.c --- calculix-ccx-2.1/ccx_2.1/src/contact.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/contact.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" - -void contact(int *ncont, int *ntie, char *tieset, int *nset, char *set, - int *istartset, int *iendset, int *ialset, int *itietri, - char *lakon, int *ipkon, int *kon, int *koncont, int *ne, - double *cg, double *straight, int *ifree, double *co, - double *vold, int *ielmat, double *cs, double *elcon, - int *istep,int *iinc,int *iit,int *ncmat_,int *ntmat_, - int *ifcont1, int *ifcont2, int *ne0, double *vini, - int *nmethod, int *nmpc, int *mpcfree, int *memmpc_, - int **ipompcp, char **labmpcp, int **ikmpcp, int **ilmpcp, - double **fmpcp, int **nodempcp, double **coefmpcp, - int *iperturb, int *ikboun, int *nboun, int *mi, - int *imastop){ - - char *labmpc=NULL; - - int i,ntrimax,*nx=NULL,*ny=NULL,*nz=NULL,*ipompc=NULL,*ikmpc=NULL, - *ilmpc=NULL,*nodempc=NULL,nmpc_; - - double *xo=NULL,*yo=NULL,*zo=NULL,*x=NULL,*y=NULL,*z=NULL, - *fmpc=NULL, *coefmpc=NULL; - - ipompc=*ipompcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; - fmpc=*fmpcp;nodempc=*nodempcp;coefmpc=*coefmpcp; - nmpc_=*nmpc; - - FORTRAN(updatecont,(koncont,ncont,co,vold, - cg,straight,mi)); - -/* printf("before remcontmpc mpcnew=%d\n",*nmpc); - for(i=0;i<*nmpc;i++){ - j=i+1; - FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); - }*/ - - /* deleting contact MPC's (not for modal dynamics calculations) */ - - if(*iperturb>1){ - remcontmpc(nmpc,labmpc,mpcfree,nodempc,ikmpc,ilmpc,coefmpc,ipompc); - } - - /* determining the size of the auxiliary fields */ - - ntrimax=0; - for(i=0;i<*ntie;i++){ - if(itietri[2*i+1]-itietri[2*i]+1>ntrimax) - ntrimax=itietri[2*i+1]-itietri[2*i]+1; - } - xo=NNEW(double,ntrimax); - yo=NNEW(double,ntrimax); - zo=NNEW(double,ntrimax); - x=NNEW(double,ntrimax); - y=NNEW(double,ntrimax); - z=NNEW(double,ntrimax); - nx=NNEW(int,ntrimax); - ny=NNEW(int,ntrimax); - nz=NNEW(int,ntrimax); - - FORTRAN(gencontelem,(tieset,ntie,itietri,ne,ipkon,kon,lakon,set, - istartset,iendset,ialset,cg,straight,ifree,koncont, - co,vold,xo,yo,zo,x,y,z,nx,ny,nz,nset,ielmat,cs,elcon,istep, - iinc,iit,ncmat_,ntmat_,ifcont1,ifcont2,ne0,vini,nmethod,mi, - imastop)); - - free(xo);free(yo);free(zo);free(x);free(y);free(z);free(nx); - free(ny);free(nz); - - /* generate MPC's for the middle nodes of the dependent contact - surface; they are connected to their endnode neighbors - (not for modal dynamic calculations) */ - -// printf("mpcold=%d\n",*nmpc); - if(*iperturb>1){ - gencontmpc(ne,ne0,lakon,ipkon,kon,nmpc,&ikmpc,&ilmpc,&ipompc,mpcfree, - &fmpc,&labmpc,&nodempc,memmpc_,&coefmpc,&nmpc_,ikboun, - nboun); - } -// printf("mpcnew=%d\n",*nmpc); - - /* for(i=0;i<*nmpc;i++){ - j=i+1; - FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); - }*/ - - *ipompcp=ipompc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; - *fmpcp=fmpc;*nodempcp=nodempc;*coefmpcp=coefmpc; - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/contactdampings.f calculix-ccx-2.3/ccx_2.1/src/contactdampings.f --- calculix-ccx-2.1/ccx_2.1/src/contactdampings.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/contactdampings.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine contactdampings(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, - & inp,ipoinpc) -! -! reading the input deck: *CONTACT DAMPING -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nelcon(2,*),nmat,ntmat_,istep,istat,ipoinpc(0:*), - & n,key,i,ncmat_,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - real*8 elcon(0:ncmat_,ntmat_,*) -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in contactdampings:' - write(*,*) ' *CONTACT DAMPING should be placed' - write(*,*) ' before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in contactdampings:' - write(*,*) ' *CONTACT DAMPING should be preceded' - write(*,*) ' by a *SURFACE INTERACTION card' - stop - endif -! - nelcon(1,nmat)=5 - nelcon(2,nmat)=1 -! -! no temperature dependence allowed; last line is decisive -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - do i=1,3 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(2+i,1,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - elcon(0,1,nmat)=0.d0 - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/contactmortar.c calculix-ccx-2.3/ccx_2.1/src/contactmortar.c --- calculix-ccx-2.1/ccx_2.1/src/contactmortar.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/contactmortar.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,558 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" - -void contactmortar(int *ncont, int *ntie, char *tieset, int *nset, char *set, - int *istartset, int *iendset, int *ialset, int *itietri, - char *lakon, int *ipkon, int *kon, int *koncont, int *ne, - double *cg, double *straight, double *co, - double *vold, int *ielmat, double *cs, double *elcon, - int *istep,int *iinc,int *iit,int *ncmat_,int *ntmat_, - int *ifcont1, int *ifcont2, int *ne0, double *vini, - int *nmethod,int *neq, int *nzs, int *nactdof, int *itiefac, - int *islavsurf, int *islavnode, int *imastnode, - int *nslavnode, int *nmastnode, int *ncone, double *ad, - double **aup, double *b, int **irowp, int *icol, int *jq, int *imastop, - int *iponoels, int *inoels, int *nzsc, double **aucp, - double *adc, int **irowcp, int *jqc, int *islavact, - double *gap, double *bdd, double **auqdtp, int **irowqdtp, - int *jqqdt, int *nzsqdt, int *nzlc,double *slavnor,double *bhat, - int *icolc, double **aubdp, int **irowbdp, int *jqbd, int *mi, - int *ipe, int *ime){ - - int i,j,k,l,m,numb,ntrimax,*nx=NULL,*ny=NULL,*nz=NULL,ifree=0,kflag, - nzsbd,*mast1=NULL,*ipointer=NULL,*irowbd=NULL, - *irowc=NULL,*imastsurf=NULL,jrow,jcol,islavnodeentry, - *islavactdof=NULL,*irow=NULL,*irowqdt=NULL,* jqctemp=NULL, - * irowctemp=NULL,jslavnodeentry; - - double *xo=NULL,*yo=NULL,*zo=NULL,*x=NULL,*y=NULL,*z=NULL,*aubd=NULL, - *auc=NULL, *pmastsurf=NULL,*auqdt=NULL,*gapmints=NULL,*pslavdual=NULL, - *slavtan=NULL,t1,t2,t3,e1,e2,e3,*au=NULL,* auctemp=NULL,*pslavsurf=NULL; - - - irow = *irowp; au=*aup; auc=*aucp; irowc=*irowcp; auqdt=*auqdtp; - irowqdt=*irowqdtp; aubd=*aubdp; irowbd=*irowbdp; - - FORTRAN(updatecont,(koncont,ncont,co,vold, - cg,straight,mi)); - - /* determining the size of the auxiliary fields */ - - ntrimax=0; - for(i=0;i<*ntie;i++){ - if(itietri[2*i+1]-itietri[2*i]+1>ntrimax) - ntrimax=itietri[2*i+1]-itietri[2*i]+1; - } - - xo=NNEW(double,ntrimax); - yo=NNEW(double,ntrimax); - zo=NNEW(double,ntrimax); - x=NNEW(double,ntrimax); - y=NNEW(double,ntrimax); - z=NNEW(double,ntrimax); - nx=NNEW(int,ntrimax); - ny=NNEW(int,ntrimax); - nz=NNEW(int,ntrimax); - -// imastsurf=NNEW(int,50**ncone); -// pmastsurf=NNEW(double,100**ncone); -// pslavsurf=NNEW(double,150**ncone); - imastsurf=NNEW(int,500**ncone); - pmastsurf=NNEW(double,1000**ncone); - pslavsurf=NNEW(double,1500**ncone); - slavtan=NNEW(double,6*nslavnode[*ntie]); - gapmints=NNEW(double,9**ncone); - pslavdual=NNEW(double,16*itiefac[2**ntie-1]); - //printf("taille=%d\n",itiefac[2**ntie-1]); - - FORTRAN(gencontrel,(tieset,ntie,itietri,ipkon,kon, - lakon,set,cg,straight,&ifree, - koncont,co,vold,xo,yo,zo,x,y,z,nx,ny,nz,nset,cs, - elcon,istep,iinc,iit,ncmat_,ntmat_, - vini,nmethod,islavsurf,imastsurf,pmastsurf,itiefac, - islavnode,nslavnode,slavnor,slavtan,imastop,gapmints, - islavact,mi,ncont,ipe,ime,pslavsurf,pslavdual)); - - free(xo);free(yo);free(zo);free(x);free(y);free(z);free(nx); - free(ny);free(nz); - - RENEW(imastsurf,int,ifree); - RENEW(pmastsurf,double,2*ifree); - RENEW(pslavsurf,double,3*ifree); - - /* coupling the active slave degrees of freedom with the corresponding slave - node */ - - islavactdof=NNEW(int,neq[1]); - - FORTRAN(genislavactdof,(ntie,neq,nactdof,nslavnode,islavact,islavactdof, - islavnode,mi)); - - /* - for (i=0;i0){ - numb=(jqc[j+1]-jqc[j]); - FORTRAN(isortid,(&irowc[jqc[j]-1],&auc[jqc[j]-1],&numb,&kflag)); - } - } - - /* copying auc,adc,irowc, jqc and bhat into - au,ad,irow,jq and b */ - - RENEW(au,double,*nzsc); - RENEW(irow,int,*nzsc); - for(i=0;i0){ //risk Actif-Actif - islavnodeentry = floor(islavactdof[j]/10.); - jrow= islavactdof[j]-10*islavnodeentry; - - k=irow[i]-1; - if(islavactdof[k]>0){ - switch(jrow){ - - case 1 : - if(k==j+1){ - - e1=adc[j]; - e2=auc[i]; - e3=auc[i+1]; - jslavnodeentry=floor(islavactdof[j]/10.); - - ad[j]=slavnor[3*(jslavnodeentry-1)+jrow-1]; - t1=slavtan[6*(islavnodeentry-1)]; - t2=slavtan[6*(islavnodeentry-1)+1]; - t3=slavtan[6*(islavnodeentry-1)+2]; - - au[i]=t1*e1+t2*e2+t3*e3; - - t1=slavtan[6*(islavnodeentry-1)+3]; - t2=slavtan[6*(islavnodeentry-1)+4]; - t3=slavtan[6*(islavnodeentry-1)+5]; - - au[++i]=t1*e1+t2*e2+t3*e3; - - } - else{ //normal scheme - islavnodeentry = floor(islavactdof[k]/10.); - jrow= islavactdof[k]-10*islavnodeentry; - - if (jrow==1){ - e1=auc[i]; - jslavnodeentry=floor(islavactdof[j]/10.); - if (islavnodeentry!=jslavnodeentry){ - au[i]=0; - }else{ - jcol=islavactdof[j]-10*jslavnodeentry; - au[i]=slavnor[3*(islavnodeentry-1)+jcol-1]; - } - } - else if (jrow==2){ - t1=slavtan[6*(islavnodeentry-1)]; - t2=slavtan[6*(islavnodeentry-1)+1]; - t3=slavtan[6*(islavnodeentry-1)+2]; - e2=auc[i]; - if((k+1)==j){e3=adc[j];}else{e3=auc[i+1];} - au[i]=t1*e1+t2*e2+t3*e3; - - } - else{ - t1=slavtan[6*(islavnodeentry-1)+3]; - t2=slavtan[6*(islavnodeentry-1)+4]; - t3=slavtan[6*(islavnodeentry-1)+5]; - - au[i]=t1*e1+t2*e2+t3*e3; - - } - } - break; - - case 2 : if(k==j-1){ - - e1=auc[i]; - e2=ad[j]; - e3=auc[i+1]; - - - - au[i]=slavnor[3*(jslavnodeentry-1)+jrow-1]; - - t1=slavtan[6*(islavnodeentry-1)]; - t2=slavtan[6*(islavnodeentry-1)+1]; - t3=slavtan[6*(islavnodeentry-1)+2]; - - ad[j]=t1*e1+t2*e2+t3*e3; - t1=slavtan[6*(islavnodeentry-1)+3]; - t2=slavtan[6*(islavnodeentry-1)+4]; - t3=slavtan[6*(islavnodeentry-1)+5]; - - au[++i]=t1*e1+t2*e2+t3*e3; - - - - - }else{ //normal scheme - islavnodeentry = floor(islavactdof[k]/10.); - jrow= islavactdof[k]-10*islavnodeentry; - - if (jrow==1){ - e1=auc[i]; - jslavnodeentry=floor(islavactdof[j]/10.); - if (islavnodeentry!=jslavnodeentry){ - au[i]=0; - }else{ - jcol=islavactdof[j]-10*jslavnodeentry; - au[i]=slavnor[3*(islavnodeentry-1)+jcol-1]; - - } - } - else if (jrow==2){ - t1=slavtan[6*(islavnodeentry-1)]; - t2=slavtan[6*(islavnodeentry-1)+1]; - t3=slavtan[6*(islavnodeentry-1)+2]; - e2=auc[i]; - if((k+1)==j){e3=adc[j];}else{e3=auc[i+1];} - au[i]=t1*e1+t2*e2+t3*e3; - - } - else{ - t1=slavtan[6*(islavnodeentry-1)+3]; - t2=slavtan[6*(islavnodeentry-1)+4]; - t3=slavtan[6*(islavnodeentry-1)+5]; - - au[i]=t1*e1+t2*e2+t3*e3; - - } - } - break; - - case 3 : if (k==j-2){ - - e1=auc[i]; - e2=auc[i+1]; - e3=adc[j]; - - au[i]=slavnor[3*(jslavnodeentry-1)+jrow-1]; - - t1=slavtan[6*(islavnodeentry-1)]; - t2=slavtan[6*(islavnodeentry-1)+1]; - t3=slavtan[6*(islavnodeentry-1)+2]; - - au[++i]=t1*e1+t2*e2+t3*e3; - - t1=slavtan[6*(islavnodeentry-1)+3]; - t2=slavtan[6*(islavnodeentry-1)+4]; - t3=slavtan[6*(islavnodeentry-1)+5]; - - ad[j]=t1*e1+t2*e2+t3*e3; - } - else{ //normal scheme - islavnodeentry = floor(islavactdof[k]/10.); - jrow= islavactdof[k]-10*islavnodeentry; - - if (jrow==1){ - e1=auc[i]; - jslavnodeentry=floor(islavactdof[j]/10.); - if (islavnodeentry!=jslavnodeentry){ - au[i]=0; - }else{ - jcol=islavactdof[j]-10*jslavnodeentry; - au[i]=slavnor[3*(islavnodeentry-1)+jcol-1]; - - } - } - else if (jrow==2){ - t1=slavtan[6*(islavnodeentry-1)]; - t2=slavtan[6*(islavnodeentry-1)+1]; - t3=slavtan[6*(islavnodeentry-1)+2]; - e2=auc[i]; - if((k+1)==j){e3=adc[j];}else{e3=auc[i+1];} - au[i]=t1*e1+t2*e2+t3*e3; - - } - else{ - t1=slavtan[6*(islavnodeentry-1)+3]; - t2=slavtan[6*(islavnodeentry-1)+4]; - t3=slavtan[6*(islavnodeentry-1)+5]; - - au[i]=t1*e1+t2*e2+t3*e3; - - } - } - break; - - default : printf("Problem of active set"); - break; - - - } - } - i++; - - }else{ //Actif-Else - - k=irow[i]-1; - // printf("contactmortar 397 k=%d,i=%d\n",k,i); - /* k is the row number, j is the column number */ - - if(islavactdof[k]>0){ - islavnodeentry = floor(islavactdof[k]/10.); - jrow= islavactdof[k]-10*islavnodeentry; - - if (jrow==1){ - e1=auc[i]; - jslavnodeentry=floor(islavactdof[j]/10.); - if (islavnodeentry!=jslavnodeentry){ - au[i]=0; - }else{ - jcol=islavactdof[j]-10*jslavnodeentry; - au[i]=slavnor[3*(islavnodeentry-1)+jcol-1]; - - } - } - else if (jrow==2){ - t1=slavtan[6*(islavnodeentry-1)]; - t2=slavtan[6*(islavnodeentry-1)+1]; - t3=slavtan[6*(islavnodeentry-1)+2]; - e2=auc[i]; - if((k+1)==j){e3=adc[j];}else{e3=auc[i+1];} - au[i]=t1*e1+t2*e2+t3*e3; - - } - else{ - t1=slavtan[6*(islavnodeentry-1)+3]; - t2=slavtan[6*(islavnodeentry-1)+4]; - t3=slavtan[6*(islavnodeentry-1)+5]; - - au[i]=t1*e1+t2*e2+t3*e3; - - } - - } - - i++; - - } - - } - } - - - /* changing b due to N and T (normal and tangential - direction at the slave surface */ - - for(k=0;k0){ - islavnodeentry = floor(islavactdof[k]/10.); - jrow= islavactdof[k]-10*islavnodeentry; - if (jrow==1){ - e1=bhat[k]; - b[k]=gap[islavnodeentry-1]; -// printf("jrow=1 %d %e\n",k,b[k]); - //printf("b,%d,%d,%f\n",k+1,jrow,ad[j]); - } - else if (jrow==2){ - t1=slavtan[6*(islavnodeentry-1)]; - t2=slavtan[6*(islavnodeentry-1)+1]; - t3=slavtan[6*(islavnodeentry-1)+2]; - e2=bhat[k]; - e3=bhat[k+1]; - b[k]=t1*e1+t2*e2+t3*e3; -// printf("jrow=2 %d %e\n",k,b[k]); - //printf("b,%d,%d,%f,%f,%f,%f,%f,%f,%f\n",k+1,jrow,t1,t2,t3,e1,e2,e3,au[i]); - } - else{ - t1=slavtan[6*(islavnodeentry-1)+3]; - t2=slavtan[6*(islavnodeentry-1)+4]; - t3=slavtan[6*(islavnodeentry-1)+5]; - // e3=b[k]; - b[k]=t1*e1+t2*e2+t3*e3; -// printf("jrow=3 %d %e\n",k,b[k]); - //printf("b,%d,%d,%f,%f,%f,%f,%f,%f,%f\n",k+1,jrow,t1,t2,t3,e1,e2,e3,au[i]); - } - } - } - - int number=10; - -// FORTRAN(writematrix,(auc,adc,irowc,jqc,&neq[1],&number)); - - number=7; - -// FORTRAN(writematrix,(au,ad,irow,jq,&neq[1],&number)); - - printf("\n"); - number=8; - -// FORTRAN(writematrix,(au,bhat,irow,jq,&neq[1],&number)); - - - number=9; - -// FORTRAN(writematrix,(au,b,irow,jq,&neq[1],&number)); - - - free(islavactdof); - - free(slavtan); - - /* So far every nonzero in Auc was stored; however, - Auc is symmetric. To reduce the computational effort - in subroutine contactstress Auc is now stored in - a symmetrical form, i.e. only half of the matrix - is stored */ - - auctemp=NNEW(double, *nzsc); - jqctemp=NNEW(int,neq[1]+1); - irowctemp=NNEW(int,*nzsc); - - k=0; - jqctemp[0]=1; - for (i=0;ii+1){ - auctemp[k]=auc[j]; - irowctemp[k++]=irowc[j]; - - } - } - jqctemp[i+1]=k+1; - - } - jqctemp[neq[1]]=k+1; - - *nzsc=k; - for(i=0;i<*nzsc;i++){ - auc[i]=auctemp[i]; - irowc[i]=irowctemp[i]; - } - - for(i=0;i-1;i--){ - if(icolc[i]>0){ - *nzlc=i+1; - break; - } - } - - *irowp = irow; *aup=au; *aucp=auc; *irowcp=irowc; *auqdtp=auqdt; - *irowqdtp=irowqdt; *aubdp=aubd; *irowbdp=irowbd; - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/contactpairs.f calculix-ccx-2.3/ccx_2.1/src/contactpairs.f --- calculix-ccx-2.1/ccx_2.1/src/contactpairs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/contactpairs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,124 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine contactpairs(inpc,textpart,tieset,cs,istep, - & istat,n,iline,ipol,inl,ipoinp,inp,ntie,ntie_, - & iperturb,matname,nmat,ipoinpc,tietol) -! -! reading the input deck: *CONTACT PAIR -! - implicit none -! - logical surftosurf -! - character*1 inpc(*) - character*81 tieset(3,*) - character*132 textpart(16) -! - integer istep,istat,n,i,key,ipos,iline,ipol,inl,ipoinp(2,*), - & inp(3,*),ntie,ntie_,iperturb(2),nmat,ipoinpc(0:*) -! - real*8 cs(17,*),tietol(*) - character*80 matname(*),material -! - if(istep.gt.0) then - write(*,*) '*ERROR in contactpairs: *CONTACT PAIR should' - write(*,*) ' be placed before all step definitions' - stop - endif -! - surftosurf=.false. -! - ntie=ntie+1 - if(ntie.gt.ntie_) then - write(*,*) '*ERROR in contactpairs: increase ntie_' - stop - endif - tietol(ntie)=0.d0 -! - do i=2,n - if(textpart(i)(1:12).eq.'INTERACTION=') then - material=textpart(i)(13:92) - elseif(textpart(i)(1:12).eq.'SMALLSLIDING') then - tietol(ntie)=-1.d0 - elseif(textpart(i)(1:14).eq.'IN-FACESLIDING') then - tietol(ntie)=-2.d0 - elseif(textpart(i)(1:21).eq.'TYPE=SURFACETOSURFACE') then - surftosurf=.true. - endif - enddo -! -! check for the existence of the surface interaction -! - do i=1,nmat - if(matname(i).eq.material) exit - enddo - if(i.gt.nmat) then - write(*,*) '*ERROR in contactpairs: nonexistent surface' - write(*,*) ' interaction; ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - cs(1,ntie)=i+0.5d0 -! - tieset(1,ntie)(81:81)='C' -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*)'*ERROR in contactpairs: definition of the ' - write(*,*) ' contact pair is not complete.' - stop - endif -! -! -! storing the slave surface -! - if(surftosurf) then - tieset(2,ntie)(1:80)=textpart(1)(1:80) - tieset(2,ntie)(81:81)=' ' - ipos=index(tieset(2,ntie),' ') - tieset(2,ntie)(ipos:ipos)='T' - else - tieset(2,ntie)(1:80)=textpart(1)(1:80) - tieset(2,ntie)(81:81)=' ' - ipos=index(tieset(2,ntie),' ') - tieset(2,ntie)(ipos:ipos)='S' - endif -! - tieset(3,ntie)(1:80)=textpart(2)(1:80) - tieset(3,ntie)(81:81)=' ' - ipos=index(tieset(3,ntie),' ') - tieset(3,ntie)(ipos:ipos)='T' -! -! the definition of a contact pair triggers a geometrically -! nonlinear calculation -! - if(iperturb(1).eq.0) then - iperturb(1)=2 - endif - iperturb(2)=1 -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/contactprints.f calculix-ccx-2.3/ccx_2.1/src/contactprints.f --- calculix-ccx-2.1/ccx_2.1/src/contactprints.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/contactprints.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,150 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine contactprints(inpc,textpart, - & nprint,nprint_,jout,prlab,prset, - & contactprint_flag,ithermal,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,amname,nam,itpamp,idrct,ipoinpc,nener) -! -! reading the *CONTACT PRINT cards in the input deck -! - implicit none -! - logical contactprint_flag -! - character*1 total,nodesys,inpc(*) - character*6 prlab(*) - character*80 amname(*),timepointsname - character*81 prset(*),noset - character*132 textpart(16) -! - integer ii,i,nam,itpamp, - & jout(2),joutl,ithermal,nprint,nprint_,istep, - & istat,n,key,ipos,iline,ipol,inl,ipoinp(2,*),inp(3,*),idrct, - & ipoinpc(0:*),nener -! - if(istep.lt.1) then - write(*,*) '*ERROR in contactprints: *CONTACT PRINT - & should only be' - write(*,*) ' used within a *STEP definition' - stop - endif -! - nodesys='L' -! -! reset the nodal print requests (element print requests, if any, -! are kept) -! - if(.not.contactprint_flag) then - ii=0 - do i=1,nprint - if((prlab(i)(1:4).eq.'CSTR').or. - & (prlab(i)(1:4).eq.'CDIS').or. - & (prlab(i)(1:4).eq.'CELS')) cycle - ii=ii+1 - prlab(ii)=prlab(i) - prset(ii)=prset(i) - enddo - nprint=ii - endif -! -c jout=max(jout,1) - do ii=1,81 - noset(ii:ii)=' ' - enddo - total=' ' -! - do ii=2,n - if(textpart(ii)(1:10).eq.'FREQUENCY=') then - read(textpart(ii)(11:20),'(i10)',iostat=istat) joutl - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(joutl.eq.0) then - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((key.eq.1).or.(istat.lt.0)) return - enddo - endif - if(joutl.gt.0) then - jout(1)=joutl - itpamp=0 - endif - elseif(textpart(ii)(1:10).eq.'TOTALS=YES') then - total='T' - elseif(textpart(ii)(1:11).eq.'TOTALS=ONLY') then - total='O' - elseif(textpart(ii)(1:11).eq.'TIMEPOINTS=') then - timepointsname=textpart(ii)(12:91) - do i=1,nam - if(amname(i).eq.timepointsname) then - itpamp=i - exit - endif - enddo - if(i.gt.nam) then - ipos=index(timepointsname,' ') - write(*,*) '*ERROR in contactprints: time points - & definition ' - & ,timepointsname(1:ipos-1),' is unknown or empty' - stop - endif - if(idrct.eq.1) then - write(*,*) '*ERROR in contactprints: the DIRECT option' - write(*,*) ' collides with a TIME POINTS ' - write(*,*) ' specification' - stop - endif - jout(1)=1 - jout(2)=1 - endif - enddo - - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if(key.eq.1) exit - do ii=1,n - if((textpart(ii)(1:4).ne.'CSTR').and. - & (textpart(ii)(1:4).ne.'CELS').and. - & (textpart(ii)(1:4).ne.'CDIS')) then - write(*,*) '*WARNING in contactprints: label not - & applicable' - write(*,*) ' or unknown; ' - call inputwarning(inpc,ipoinpc,iline) - cycle - endif -! -! -! - if(textpart(ii)(1:4).eq.'CELS') nener=1 -! - nprint=nprint+1 - if(nprint.gt.nprint_) then - write(*,*) '*ERROR in contatcprints: increase nprint_' - stop - endif - prset(nprint)=noset - prlab(nprint)(1:4)=textpart(ii)(1:4) - prlab(nprint)(5:5)=total - prlab(nprint)(6:6)=nodesys - enddo - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/contactstress.c calculix-ccx-2.3/ccx_2.1/src/contactstress.c --- calculix-ccx-2.1/ccx_2.1/src/contactstress.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/contactstress.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,132 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" - -void contactstress(double *bhat, double *adc, double *auc,int *jqc, - int *irowc, int *neq, double *gap, double *bdd, double *b, int *islavact, - double *auqdt, int *irowqdt, int *jqqdt, int *ntie, int *nslavnode, - int *islavnode, double *slavnor, int *icolc, int *nzlc, int *nactdof, - int* iflagact,double* cstress, int *mi, double *lambda){ - - int i,j,idof1,idof2,idof3,nodes,mt=mi[1]+1; - - double aux,stressnormal,stressnormal2,dispnormal,*unitmatrix=NULL, - constant=1.E1; - - /* determining the contact stress vectors and updating the active - and inactive sets */ - - int number=11; - *iflagact=0; - - // FORTRAN(writematrix,(auc,b,irowc,jqc,&neq[1],&number)); - -/* for(j=0;j1E-10){ - if (islavact[j]!=1) {*iflagact = 1; - // printf("1 node %d, value = %f\n", j,stressnormal+constant*(dispnormal-gap[j])); - } - islavact[j]=1; - }else{ - if (islavact[j]!=0){ *iflagact = 1; - // printf("2 node %d, value = %f\n", j,stressnormal+constant*(dispnormal-gap[j])); - } - islavact[j]=0.; - lambda[idof1]=0.; - lambda[idof2]=0.; - lambda[idof3]=0.; - cstress[idof1]=0.; - cstress[idof2]=0.; - cstress[idof3]=0.; - } -// printf("node %d, status :%d\n",j,islavact[j]); - } - } - - /* transforming the constrained displacements into the standard displacements */ - - unitmatrix=NNEW(double,neq[1]); - for(j=0;j){ - s/You are using an executable made on.*/You are using an executable made on $date\\n");/g; - print; -} - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/datest.f calculix-ccx-2.3/ccx_2.1/src/datest.f --- calculix-ccx-2.1/ccx_2.1/src/datest.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/datest.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine datest(au,jh,daval) - implicit real*8 (a-h,o-z) - real*8 au(jh) -c....test for rank - daval = 0.0d0 - do 100 j = 1,jh - daval=daval+abs(au(j)) - 100 continue - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/ddeabm.f calculix-ccx-2.3/ccx_2.1/src/ddeabm.f --- calculix-ccx-2.1/ccx_2.1/src/ddeabm.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ddeabm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,4635 +0,0 @@ -*DECK DDEABM - SUBROUTINE DDEABM (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + RWORK, LRW, IWORK, LIW, RPAR, IPAR) -C***BEGIN PROLOGUE DDEABM -C***PURPOSE Solve an initial value problem in ordinary differential -C equations using an Adams-Bashforth method. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1B -C***TYPE DOUBLE PRECISION (DEABM-S, DDEABM-D) -C***KEYWORDS ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS, -C ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR -C***AUTHOR Shampine, L. F., (SNLA) -C Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This is the Adams code in the package of differential equation -C solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. -C Design of the package was by L. F. Shampine and H. A. Watts. -C It is documented in -C SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE -C Solvers. -C DDEABM is a driver for a modification of the code ODE written by -C L. F. Shampine and M. K. Gordon -C Sandia Laboratories -C Albuquerque, New Mexico 87185 -C -C ********************************************************************** -C * ABSTRACT * -C ************ -C -C Subroutine DDEABM uses the Adams-Bashforth-Moulton -C Predictor-Corrector formulas of orders one through twelve to -C integrate a system of NEQ first order ordinary differential -C equations of the form -C DU/DX = DF(X,U) -C when the vector Y(*) of initial values for U(*) at X=T is given. -C The subroutine integrates from T to TOUT. It is easy to continue the -C integration to get results at additional TOUT. This is the interval -C mode of operation. It is also easy for the routine to return with -C the solution at each intermediate step on the way to TOUT. This is -C the intermediate-output mode of operation. -C -C DDEABM uses subprograms DDES, DSTEPS, DINTP, DHSTRT, DHVNRM, -C D1MACH, and the error handling routine XERMSG. The only machine -C dependent parameters to be assigned appear in D1MACH. -C -C ********************************************************************** -C * Description of The Arguments To DDEABM (An Overview) * -C ********************************************************************** -C -C The Parameters are -C -C DF -- This is the name of a subroutine which you provide to -C define the differential equations. -C -C NEQ -- This is the number of (first order) differential -C equations to be integrated. -C -C T -- This is a DOUBLE PRECISION value of the independent -C variable. -C -C Y(*) -- This DOUBLE PRECISION array contains the solution -C components at T. -C -C TOUT -- This is a DOUBLE PRECISION point at which a solution is -C desired. -C -C INFO(*) -- The basic task of the code is to integrate the -C differential equations from T to TOUT and return an -C answer at TOUT. INFO(*) is an INTEGER array which is used -C to communicate exactly how you want this task to be -C carried out. -C -C RTOL, ATOL -- These DOUBLE PRECISION quantities represent -C relative and absolute error tolerances which you -C provide to indicate how accurately you wish the -C solution to be computed. You may choose them to be -C both scalars or else both vectors. -C -C IDID -- This scalar quantity is an indicator reporting what -C the code did. You must monitor this INTEGER variable to -C decide what action to take next. -C -C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of -C length LRW which provides the code with needed storage -C space. -C -C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW -C which provides the code with needed storage space and an -C across call flag. -C -C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and the DF subroutine. -C -C Quantities which are used as input items are -C NEQ, T, Y(*), TOUT, INFO(*), -C RTOL, ATOL, RWORK(1), LRW and LIW. -C -C Quantities which may be altered by the code are -C T, Y(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) and IWORK(*). -C -C ********************************************************************** -C * INPUT -- What To Do On The First Call To DDEABM * -C ********************************************************************** -C -C The first call of the code is defined to be the start of each new -C problem. Read through the descriptions of all the following items, -C provide sufficient storage space for designated arrays, set -C appropriate variables for the initialization of the problem, and -C give information about how you want the problem to be solved. -C -C -C DF -- Provide a subroutine of the form -C DF(X,U,UPRIME,RPAR,IPAR) -C to define the system of first order differential equations -C which is to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=DF(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine DF must NOT alter X or U(*). You must declare -C the name df in an external statement in your program that -C calls DDEABM. You must dimension U and UPRIME in DF. -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and subroutine DF. They are not used or -C altered by DDEABM. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them in -C your calling program and in DF as arrays of appropriate -C length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C You must use a program variable for T because the code -C changes its value. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y at -C least NEQ in your calling program. -C -C TOUT -- Set it to the first point at which a solution -C is desired. You can take TOUT = T, in which case the code -C will evaluate the derivative of the solution at T and -C return. Integration either forward in T (TOUT .GT. T) or -C backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative following -C each intermediate step (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not step -C past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -C -C For some problems it may not be permissible to integrate -C past a point TSTOP because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP. When you have declared a TSTOP point (see INFO(4) -C and RWORK(1)), you have told the code not to integrate -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C input. -C -C INFO(*) -- Use the INFO array to give the code more details about -C how you want your problem solved. This array should be -C dimensioned of length 15 to accommodate other members of -C DEPAC or possible future extensions, though DDEABM uses -C only the first four entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as YES ,i.e. setting ALL entries of INFO to 0. -C -C INFO(1) -- This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new problem. -C -C **** Is this the first call for this problem ... -C YES -- set INFO(1) = 0 -C NO -- not applicable here. -C See below for continuation calls. **** -C -C INFO(2) -- How much accuracy you want of your solution -C is specified by the error tolerances RTOL and ATOL. -C The simplest use is to take them both to be scalars. -C To obtain more flexibility, they can both be vectors. -C The code must be told your choice. -C -C **** Are both error tolerances RTOL, ATOL scalars ... -C YES -- set INFO(2) = 0 -C and input scalars for both RTOL and ATOL -C NO -- set INFO(2) = 1 -C and input arrays for both RTOL and ATOL **** -C -C INFO(3) -- The code integrates from T in the direction -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this code will compute them efficiently. -C -C **** Do you want the solution only at -C TOUT (and not at the next intermediate step) ... -C YES -- set INFO(3) = 0 -C NO -- set INFO(3) = 1 **** -C -C INFO(4) -- To handle solutions at a great many specific -C values TOUT efficiently, this code may integrate past -C TOUT and interpolate to obtain the result at TOUT. -C Sometimes it is not possible to integrate beyond some -C point TSTOP because the equation changes there or it is -C not defined past TSTOP. Then you must tell the code -C not to go past. -C -C **** Can the integration be carried out without any -C Restrictions on the independent variable T ... -C YES -- set INFO(4)=0 -C NO -- set INFO(4)=1 -C and define the stopping point TSTOP by -C setting RWORK(1)=TSTOP **** -C -C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you want -C the solution to be computed. They must be defined as -C program variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -C Both RTOL and ATOL are vectors. (INFO(2)=1) -C In either case all components must be non-negative. -C -C The tolerances are used by the code in a local error test -C at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C for each vector component. -C (More specifically, a Euclidean norm is used to measure -C the size of vectors, and the error test uses the magnitude -C of the solution at the beginning of the step.) -C -C The true (global) error is the difference between the true -C solution of the initial value problem and the computed -C approximation. Practically all present day codes, -C including this one, control the local error at each step -C and do not even attempt to control the global error -C directly. Roughly speaking, they produce a solution Y(T) -C which satisfies the differential equations with a -C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , -C and, almost always, R(T) is bounded by the error -C tolerances. Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more accurate -C solution if you reduce the tolerances and integrate again. -C By comparing two such solutions you can get a fairly -C reliable idea of the true error in the solution at the -C bigger tolerances. -C -C Setting ATOL=0.D0 results in a pure relative error test on -C that component. Setting RTOL=0. results in a pure absolute -C error test on that component. A mixed test with non-zero -C RTOL and ATOL corresponds roughly to a relative error -C test when the solution component is much bigger than ATOL -C and to an absolute error test when the solution component -C is smaller than the threshold ATOL. -C -C Proper selection of the absolute error control parameters -C ATOL requires you to have some idea of the scale of the -C solution components. To acquire this information may mean -C that you will have to solve the problem more than once. In -C the absence of scale information, you should ask for some -C relative accuracy in all the components (by setting RTOL -C values non-zero) and perhaps impose extremely small -C absolute error tolerances to protect against the danger of -C a solution component becoming zero. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C -C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length -C LRW in your calling program. -C -C RWORK(1) -- If you have set INFO(4)=0, you can ignore this -C optional input parameter. Otherwise you must define a -C stopping point TSTOP by setting RWORK(1) = TSTOP. -C (for some problems it may not be permissible to integrate -C past a point TSTOP because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP.) -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have LRW .GE. 130+21*NEQ -C -C IWORK(*) -- Dimension this INTEGER work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 51 -C -C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and -C INTEGER type, respectively. You can use them for -C communication between your program that calls DDEABM and -C the DF subroutine. They are not used or altered by -C DDEABM. If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. If you do -C choose to use them, dimension them in your calling program -C and in DF as arrays of appropriate length. -C -C ********************************************************************** -C * OUTPUT -- After Any Return From DDEABM * -C ********************************************************************** -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C You may also be interested in the approximate derivative -C of the solution at T. It is contained in -C RWORK(21),...,RWORK(20+NEQ). -C -C IDID -- Reports what the code did -C -C *** Task Completed *** -C Reported by positive values of IDID -C -C IDID = 1 -- A step was successfully taken in the -C intermediate-output mode. The code has not -C yet reached TOUT. -C -C IDID = 2 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping exactly to TOUT. -C -C IDID = 3 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping past TOUT. -C Y(*) is obtained by interpolation. -C -C *** Task Interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (500 steps attempted) -C -C IDID = -2 -- The error tolerances are too stringent. -C -C IDID = -3 -- The local error test cannot be satisfied -C because you specified a zero component in ATOL -C and the corresponding computed solution -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -4 -- The problem appears to be stiff. -C -C IDID = -5,-6,-7,..,-32 -- Not applicable for this code -C but used by other members of DEPAC or possible -C future extensions. -C -C *** Task Terminated *** -C Reported by the value of IDID=-33 -C -C IDID = -33 -- The code has encountered trouble from which -C it cannot recover. A message is printed -C explaining the trouble and control is returned -C to the calling program. For example, this occurs -C when invalid input is detected. -C -C RTOL, ATOL -- These quantities remain unchanged except when -C IDID = -2. In this case, the error tolerances have been -C increased by the code to values which are estimated to be -C appropriate for continuing the integration. However, the -C reported solution at T was obtained using the input values -C of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(11)--which contains the step size H to be -C attempted on the next step. -C -C RWORK(12)--if the tolerances have been increased by the -C code (IDID = -2) , they were multiplied by the -C value in RWORK(12). -C -C RWORK(13)--Which contains the current value of the -C independent variable, i.e. the farthest point -C integration has reached. This will be different -C from T only when interpolation has been -C performed (IDID=3). -C -C RWORK(20+I)--Which contains the approximate derivative -C of the solution component Y(I). In DDEABM, it -C is obtained by calling subroutine DF to -C evaluate the differential equation using T and -C Y(*) when IDID=1 or 2, and by interpolation -C when IDID=3. -C -C ********************************************************************** -C * INPUT -- What To Do To Continue The Integration * -C * (calls after the first) * -C ********************************************************************** -C -C This code is organized so that subsequent calls to continue the -C integration involve little (if any) additional effort on your -C part. You must monitor the IDID parameter in order to determine -C what to do next. -C -C Recalling that the principal task of the code is to integrate -C from T to TOUT (the interval mode), usually all you will need -C to do is specify a new TOUT upon reaching the current TOUT. -C -C Do not alter any quantity not specifically permitted below, -C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or -C the differential equation in subroutine DF. Any such alteration -C constitutes a new problem and must be treated as such, i.e. -C you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)) but you can change the size of the entries of -C RTOL, ATOL. Increasing a tolerance makes the equation easier -C to integrate. Decreasing a tolerance will make the equation -C harder to integrate and should generally be avoided. -C -C You can switch from the intermediate-output mode to the -C interval mode (INFO(3)) or vice versa at any time. -C -C If it has been necessary to prevent the integration from going -C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the -C code will not integrate to any TOUT beyond the currently -C specified TSTOP. Once TSTOP has been reached you must change -C the value of TSTOP or set INFO(4)=0. You may change INFO(4) -C or TSTOP at any time but you must supply the value of TSTOP in -C RWORK(1) whenever you set INFO(4)=1. -C -C The parameter INFO(1) is used by the code to indicate the -C beginning of a new problem and to indicate whether integration -C is to be continued. You must input the value INFO(1) = 0 -C when starting a new problem. You must input the value -C INFO(1) = 1 if you wish to continue after an interrupted task. -C Do not set INFO(1) = 0 on a continuation call unless you -C want the code to restart at the current T. -C -C *** Following A Completed Task *** -C If -C IDID = 1, call the code again to continue the integration -C another step in the direction of TOUT. -C -C IDID = 2 or 3, define a new TOUT and call the code again. -C TOUT must be different from T. You cannot change -C the direction of integration without restarting. -C -C *** Following An Interrupted Task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and reset INFO(1) = 1 -C If -C IDID = -1, the code has attempted 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, the error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code again. -C -C IDID = -3, a solution component is zero and you set the -C corresponding component of ATOL to zero. If you -C are sure you want to continue, you must first -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4, the problem appears to be stiff. It is very -C inefficient to solve such problems with DDEABM. -C The code DDEBDF in DEPAC handles this task -C efficiently. If you are absolutely sure you want -C to continue with DDEABM, set INFO(1)=1 and call -C the code again. -C -C IDID = -5,-6,-7,..,-32 --- cannot occur with this code -C but used by other members of DEPAC or possible -C future extensions. -C -C *** Following A Terminated Task *** -C If -C IDID = -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C ********************************************************************** -C *Long Description: -C -C ********************************************************************** -C * DEPAC Package Overview * -C ********************************************************************** -C -C .... You have a choice of three differential equation solvers from -C .... DEPAC. The following brief descriptions are meant to aid you in -C .... choosing the most appropriate code for your problem. -C -C .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of -C .... the three choices, both algorithmically and in the use of the -C .... code. DDERKF is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are not expensive. It should generally not be used to get high -C .... accuracy results nor answers at a great many specific points. -C .... Because DDERKF has very low overhead costs, it will usually -C .... result in the least expensive integration when solving -C .... problems requiring a modest amount of accuracy and having -C .... equations that are not costly to evaluate. DDERKF attempts to -C .... discover when it is not suitable for the task posed. -C -C .... DDEABM is a variable order (one through twelve) Adams code. -C .... Its complexity lies somewhere between that of DDERKF and -C .... DDEBDF. DDEABM is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are expensive, high accuracy results are needed or answers at -C .... many specific points are required. DDEABM attempts to discover -C .... when it is not suitable for the task posed. -C -C .... DDEBDF is a variable order (one through five) backward -C .... differentiation formula code. it is the most complicated of -C .... the three choices. DDEBDF is primarily designed to solve stiff -C .... differential equations at crude to moderate tolerances. -C .... If the problem is very stiff at all, DDERKF and DDEABM will be -C .... quite inefficient compared to DDEBDF. However, DDEBDF will be -C .... inefficient compared to DDERKF and DDEABM on non-stiff problems -C .... because it uses much more storage, has a much larger overhead, -C .... and the low order formulas will not give high accuracies -C .... efficiently. -C -C .... The concept of stiffness cannot be described in a few words. -C .... If you do not know the problem to be stiff, try either DDERKF -C .... or DDEABM. Both of these codes will inform you of stiffness -C .... when the cost of solving such problems becomes important. -C -C ********************************************************************* -C -C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user -C oriented package of ODE solvers, Report SAND79-2374, -C Sandia Laboratories, 1979. -C***ROUTINES CALLED DDES, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DDEABM -C - INTEGER IALPHA, IBETA, IDELSN, IDID, IFOURU, IG, IHOLD, - 1 INFO, IP, IPAR, IPHI, IPSI, ISIG, ITOLD, ITSTAR, ITWOU, - 2 IV, IW, IWORK, IWT, IYP, IYPOUT, IYY, LIW, LRW, NEQ - DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y - LOGICAL START,PHASE1,NORND,STIFF,INTOUT -C - DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), - 1 RPAR(*),IPAR(*) -C - CHARACTER*8 XERN1 - CHARACTER*16 XERN3 -C - EXTERNAL DF -C -C CHECK FOR AN APPARENT INFINITE LOOP -C -C***FIRST EXECUTABLE STATEMENT DDEABM - IF ( INFO(1) .EQ. 0 ) IWORK(LIW) = 0 - IF (IWORK(LIW) .GE. 5) THEN - IF (T .EQ. RWORK(21 + NEQ)) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDEABM', - * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // - * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // - * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // - * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // - * 'CODE, PARTICULARLY INFO(1).', 13, 2) - RETURN - ENDIF - ENDIF -C -C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION -C - IDID=0 - IF (LRW .LT. 130+21*NEQ) THEN - WRITE (XERN1, '(I8)') LRW - CALL XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE RWORK ' // - * 'ARRAY MUST BE AT LEAST 130 + 21*NEQ.$$' // - * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) - IDID=-33 - ENDIF -C - IF (LIW .LT. 51) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE IWORK ' // - * 'ARRAY MUST BE AT LEAST 51.$$YOU HAVE CALLED THE CODE ' // - * 'WITH LIW = ' // XERN1, 2, 1) - IDID=-33 - ENDIF -C -C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY -C - IYPOUT = 21 - ITSTAR = NEQ + 21 - IYP = 1 + ITSTAR - IYY = NEQ + IYP - IWT = NEQ + IYY - IP = NEQ + IWT - IPHI = NEQ + IP - IALPHA = (NEQ*16) + IPHI - IBETA = 12 + IALPHA - IPSI = 12 + IBETA - IV = 12 + IPSI - IW = 12 + IV - ISIG = 12 + IW - IG = 13 + ISIG - IGI = 13 + IG - IXOLD = 11 + IGI - IHOLD = 1 + IXOLD - ITOLD = 1 + IHOLD - IDELSN = 1 + ITOLD - ITWOU = 1 + IDELSN - IFOURU = 1 + ITWOU -C - RWORK(ITSTAR) = T - IF (INFO(1) .EQ. 0) GO TO 50 - START = IWORK(21) .NE. (-1) - PHASE1 = IWORK(22) .NE. (-1) - NORND = IWORK(23) .NE. (-1) - STIFF = IWORK(24) .NE. (-1) - INTOUT = IWORK(25) .NE. (-1) -C - 50 CALL DDES(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(IYPOUT), - 1 RWORK(IYP),RWORK(IYY),RWORK(IWT),RWORK(IP),RWORK(IPHI), - 2 RWORK(IALPHA),RWORK(IBETA),RWORK(IPSI),RWORK(IV), - 3 RWORK(IW),RWORK(ISIG),RWORK(IG),RWORK(IGI),RWORK(11), - 4 RWORK(12),RWORK(13),RWORK(IXOLD),RWORK(IHOLD), - 5 RWORK(ITOLD),RWORK(IDELSN),RWORK(1),RWORK(ITWOU), - 5 RWORK(IFOURU),START,PHASE1,NORND,STIFF,INTOUT,IWORK(26), - 6 IWORK(27),IWORK(28),IWORK(29),IWORK(30),IWORK(31), - 7 IWORK(32),IWORK(33),IWORK(34),IWORK(35),IWORK(45), - 8 RPAR,IPAR) -C - IWORK(21) = -1 - IF (START) IWORK(21) = 1 - IWORK(22) = -1 - IF (PHASE1) IWORK(22) = 1 - IWORK(23) = -1 - IF (NORND) IWORK(23) = 1 - IWORK(24) = -1 - IF (STIFF) IWORK(24) = 1 - IWORK(25) = -1 - IF (INTOUT) IWORK(25) = 1 -C - IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 - IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 -C - RETURN - END -*DECK DDES - SUBROUTINE DDES (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + YPOUT, YP, YY, WT, P, PHI, ALPHA, BETA, PSI, V, W, SIG, G, GI, - + H, EPS, X, XOLD, HOLD, TOLD, DELSGN, TSTOP, TWOU, FOURU, START, - + PHASE1, NORND, STIFF, INTOUT, NS, KORD, KOLD, INIT, KSTEPS, - + KLE4, IQUIT, KPREV, IVC, IV, KGI, RPAR, IPAR) -C***BEGIN PROLOGUE DDES -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEABM -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (DES-S, DDES-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DDEABM merely allocates storage for DDES to relieve the user of the -C inconvenience of a long call list. Consequently DDES is used as -C described in the comments for DDEABM . -C -C***SEE ALSO DDEABM -C***ROUTINES CALLED D1MACH, DINTP, DSTEPS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTOs to -C IF-THEN-ELSE. (RWC) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DDES -C - INTEGER IDID, INFO, INIT, IPAR, IQUIT, IV, IVC, K, KGI, KLE4, - 1 KOLD, KORD, KPREV, KSTEPS, L, LTOL, MAXNUM, NATOLP, NEQ, - 2 NRTOLP, NS - DOUBLE PRECISION A, ABSDEL, ALPHA, ATOL, BETA, D1MACH, - 1 DEL, DELSGN, DT, EPS, FOURU, G, GI, H, - 2 HA, HOLD, P, PHI, PSI, RPAR, RTOL, SIG, T, TOLD, TOUT, - 3 TSTOP, TWOU, U, V, W, WT, X, XOLD, Y, YP, YPOUT, YY - LOGICAL STIFF,CRASH,START,PHASE1,NORND,INTOUT -C - DIMENSION Y(*),YY(*),WT(*),PHI(NEQ,16),P(*),YP(*), - 1 YPOUT(*),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13), - 2 GI(11),IV(10),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 -C - EXTERNAL DF -C -C....................................................................... -C -C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE -C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER -C IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE -C WORK. -C - SAVE MAXNUM - DATA MAXNUM/500/ -C -C....................................................................... -C -C***FIRST EXECUTABLE STATEMENT DDES - IF (INFO(1) .EQ. 0) THEN -C -C ON THE FIRST CALL , PERFORM INITIALIZATION -- -C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE -C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE -C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. -C - U=D1MACH(4) -C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS - TWOU=2.D0*U - FOURU=4.D0*U -C -- SET TERMINATION FLAG - IQUIT=0 -C -- SET INITIALIZATION INDICATOR - INIT=0 -C -- SET COUNTER FOR ATTEMPTED STEPS - KSTEPS=0 -C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT - INTOUT= .FALSE. -C -- SET INDICATOR FOR STIFFNESS DETECTION - STIFF= .FALSE. -C -- SET STEP COUNTER FOR STIFFNESS DETECTION - KLE4=0 -C -- SET INDICATORS FOR STEPS CODE - START= .TRUE. - PHASE1= .TRUE. - NORND= .TRUE. -C -- RESET INFO(1) FOR SUBSEQUENT CALLS - INFO(1)=1 - ENDIF -C -C....................................................................... -C -C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY -C - IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(1) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(1) MUST BE ' // - * 'SET TO 0 FOR THE START OF A NEW PROBLEM, AND MUST BE ' // - * 'SET TO 1 FOLLOWING AN INTERRUPTED TASK. YOU ARE ' // - * 'ATTEMPTING TO CONTINUE THE INTEGRATION ILLEGALLY BY ' // - * 'CALLING THE CODE WITH INFO(1) = ' // XERN1, 3, 1) - IDID=-33 - ENDIF -C - IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(2) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(2) MUST BE ' // - * '0 OR 1 INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // - * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // - * XERN1, 4, 1) - IDID=-33 - ENDIF -C - IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(3) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(3) MUST BE ' // - * '0 OR 1 INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT ' // - * 'MODE OF INTEGRATION, RESPECTIVELY. YOU HAVE CALLED ' // - * 'THE CODE WITH INFO(3) = ' // XERN1, 5, 1) - IDID=-33 - ENDIF -C - IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(4) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(4) MUST BE ' // - * '0 OR 1 INDICATING WHETHER OR NOT THE INTEGRATION ' // - * 'INTERVAL IS TO BE RESTRICTED BY A POINT TSTOP. YOU ' // - * 'HAVE CALLED THE CODE WITH INFO(4) = ' // XERN1, 14, 1) - IDID=-33 - ENDIF -C - IF (NEQ .LT. 1) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE NUMBER OF ' // - * 'EQUATIONS NEQ MUST BE A POSITIVE INTEGER. YOU HAVE ' // - * 'CALLED THE CODE WITH NEQ = ' // XERN1, 6, 1) - IDID=-33 - ENDIF -C - NRTOLP = 0 - NATOLP = 0 - DO 90 K=1,NEQ - IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') RTOL(K) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE RELATIVE ' // - * 'ERROR TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU ' // - * 'HAVE CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) - IDID = -33 - NRTOLP = 1 - ENDIF -C - IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') ATOL(K) - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE ABSOLUTE ' // - * 'ERROR TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU ' // - * 'HAVE CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) - IDID = -33 - NATOLP = 1 - ENDIF -C - IF (INFO(2) .EQ. 0) GO TO 100 - IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 100 - 90 CONTINUE -C - 100 IF (INFO(4) .EQ. 1) THEN - IF (SIGN(1.D0,TOUT-T) .NE. SIGN(1.D0,TSTOP-T) - 1 .OR. ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - WRITE (XERN4, '(1PE15.6)') TSTOP - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // - * 'CALLED THE CODE WITH TOUT = ' // XERN3 // ' BUT ' // - * 'YOU HAVE ALSO TOLD THE CODE (INFO(4) = 1) NOT TO ' // - * 'INTEGRATE PAST THE POINT TSTOP = ' // XERN4 // - * ' THESE INSTRUCTIONS CONFLICT.', 14, 1) - IDID=-33 - ENDIF - ENDIF -C -C CHECK SOME CONTINUATION POSSIBILITIES -C - IF (INIT .NE. 0) THEN - IF (T .EQ. TOUT) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // - * 'CALLED THE CODE WITH T = TOUT = ' // XERN3 // - * '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 9, 1) - IDID=-33 - ENDIF -C - IF (T .NE. TOLD) THEN - WRITE (XERN3, '(1PE15.6)') TOLD - WRITE (XERN4, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // - * 'CHANGED THE VALUE OF T FROM ' // XERN3 // ' TO ' // - * XERN4 //' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', - * 10, 1) - IDID=-33 - ENDIF -C - IF (INIT .NE. 1) THEN - IF (DELSGN*(TOUT-T) .LT. 0.D0) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, BY ' // - * 'CALLING THE CODE WITH TOUT = ' // XERN3 // - * ' YOU ARE ATTEMPTING TO CHANGE THE DIRECTION OF ' // - * 'INTEGRATION.$$THIS IS NOT ALLOWED WITHOUT ' // - * 'RESTARTING.', 11, 1) - IDID=-33 - ENDIF - ENDIF - ENDIF -C -C INVALID INPUT DETECTED -C - IF (IDID .EQ. (-33)) THEN - IF (IQUIT .NE. (-33)) THEN - IQUIT = -33 - INFO(1) = -1 - ELSE - CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INVALID ' // - * 'INPUT WAS DETECTED ON SUCCESSIVE ENTRIES. IT IS ' // - * 'IMPOSSIBLE TO PROCEED BECAUSE YOU HAVE NOT ' // - * 'CORRECTED THE PROBLEM, SO EXECUTION IS BEING ' // - * 'TERMINATED.', 12, 2) - ENDIF - RETURN - ENDIF -C -C....................................................................... -C -C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS -C ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, -C THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE -C FOURU WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE -C - DO 180 K=1,NEQ - IF (RTOL(K)+ATOL(K) .GT. 0.D0) GO TO 170 - RTOL(K)=FOURU - IDID=-2 - 170 IF (INFO(2) .EQ. 0) GO TO 190 - 180 CONTINUE -C - 190 IF (IDID .NE. (-2)) GO TO 200 -C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A -C SMALL POSITIVE VALUE - INFO(1)=-1 - RETURN -C -C BRANCH ON STATUS OF INITIALIZATION INDICATOR -C INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE -C AND DIRECTION NOT YET SET -C INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET -C INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED -C - 200 IF (INIT .EQ. 0) GO TO 210 - IF (INIT .EQ. 1) GO TO 220 - GO TO 240 -C -C....................................................................... -C -C MORE INITIALIZATION -- -C -- EVALUATE INITIAL DERIVATIVES -C - 210 INIT=1 - A=T - CALL DF(A,Y,YP,RPAR,IPAR) - IF (T .NE. TOUT) GO TO 220 - IDID=2 - DO 215 L = 1,NEQ - 215 YPOUT(L) = YP(L) - TOLD=T - RETURN -C -C -- SET INDEPENDENT AND DEPENDENT VARIABLES -C X AND YY(*) FOR STEPS -C -- SET SIGN OF INTEGRATION DIRECTION -C -- INITIALIZE THE STEP SIZE -C - 220 INIT = 2 - X = T - DO 230 L = 1,NEQ - 230 YY(L) = Y(L) - DELSGN = SIGN(1.0D0,TOUT-T) - H = SIGN(MAX(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X) -C -C....................................................................... -C -C ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL -C OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT -C - 240 DEL = TOUT - T - ABSDEL = ABS(DEL) -C -C....................................................................... -C -C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN -C - 250 IF(ABS(X-T) .LT. ABSDEL) GO TO 260 - CALL DINTP(X,YY,TOUT,Y,YPOUT,NEQ,KOLD,PHI,IVC,IV,KGI,GI, - 1 ALPHA,G,W,XOLD,P) - IDID = 3 - IF (X .NE. TOUT) GO TO 255 - IDID = 2 - INTOUT = .FALSE. - 255 T = TOUT - TOLD = T - RETURN -C -C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, -C EXTRAPOLATE AND RETURN -C - 260 IF (INFO(4) .NE. 1) GO TO 280 - IF (ABS(TSTOP-X) .GE. FOURU*ABS(X)) GO TO 280 - DT = TOUT - X - DO 270 L = 1,NEQ - 270 Y(L) = YY(L) + DT*YP(L) - CALL DF(TOUT,Y,YPOUT,RPAR,IPAR) - IDID = 3 - T = TOUT - TOLD = T - RETURN -C - 280 IF (INFO(3) .EQ. 0 .OR. .NOT.INTOUT) GO TO 300 -C -C INTERMEDIATE-OUTPUT MODE -C - IDID = 1 - DO 290 L = 1,NEQ - Y(L)=YY(L) - 290 YPOUT(L) = YP(L) - T = X - TOLD = T - INTOUT = .FALSE. - RETURN -C -C....................................................................... -C -C MONITOR NUMBER OF STEPS ATTEMPTED -C - 300 IF (KSTEPS .LE. MAXNUM) GO TO 330 -C -C A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED - IDID=-1 - KSTEPS=0 - IF (.NOT. STIFF) GO TO 310 -C -C PROBLEM APPEARS TO BE STIFF - IDID=-4 - STIFF= .FALSE. - KLE4=0 -C - 310 DO 320 L = 1,NEQ - Y(L) = YY(L) - 320 YPOUT(L) = YP(L) - T = X - TOLD = T - INFO(1) = -1 - INTOUT = .FALSE. - RETURN -C -C....................................................................... -C -C LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP -C - 330 HA = ABS(H) - IF (INFO(4) .NE. 1) GO TO 340 - HA = MIN(HA,ABS(TSTOP-X)) - 340 H = SIGN(HA,H) - EPS = 1.0D0 - LTOL = 1 - DO 350 L = 1,NEQ - IF (INFO(2) .EQ. 1) LTOL = L - WT(L) = RTOL(LTOL)*ABS(YY(L)) + ATOL(LTOL) - IF (WT(L) .LE. 0.0D0) GO TO 360 - 350 CONTINUE - GO TO 380 -C -C RELATIVE ERROR CRITERION INAPPROPRIATE - 360 IDID = -3 - DO 370 L = 1,NEQ - Y(L) = YY(L) - 370 YPOUT(L) = YP(L) - T = X - TOLD = T - INFO(1) = -1 - INTOUT = .FALSE. - RETURN -C - 380 CALL DSTEPS(DF,NEQ,YY,X,H,EPS,WT,START,HOLD,KORD,KOLD,CRASH,PHI,P, - 1 YP,PSI,ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND,KSTEPS, - 2 TWOU,FOURU,XOLD,KPREV,IVC,IV,KGI,GI,RPAR,IPAR) -C -C....................................................................... -C - IF(.NOT.CRASH) GO TO 420 -C -C TOLERANCES TOO SMALL - IDID = -2 - RTOL(1) = EPS*RTOL(1) - ATOL(1) = EPS*ATOL(1) - IF (INFO(2) .EQ. 0) GO TO 400 - DO 390 L = 2,NEQ - RTOL(L) = EPS*RTOL(L) - 390 ATOL(L) = EPS*ATOL(L) - 400 DO 410 L = 1,NEQ - Y(L) = YY(L) - 410 YPOUT(L) = YP(L) - T = X - TOLD = T - INFO(1) = -1 - INTOUT = .FALSE. - RETURN -C -C (STIFFNESS TEST) COUNT NUMBER OF CONSECUTIVE STEPS TAKEN WITH THE -C ORDER OF THE METHOD BEING LESS OR EQUAL TO FOUR -C - 420 KLE4 = KLE4 + 1 - IF(KOLD .GT. 4) KLE4 = 0 - IF(KLE4 .GE. 50) STIFF = .TRUE. - INTOUT = .TRUE. - GO TO 250 - END -*DECK DINTP - SUBROUTINE DINTP (X, Y, XOUT, YOUT, YPOUT, NEQN, KOLD, PHI, IVC, - + IV, KGI, GI, ALPHA, OG, OW, OX, OY) -C***BEGIN PROLOGUE DINTP -C***PURPOSE Approximate the solution at XOUT by evaluating the -C polynomial computed in DSTEPS at XOUT. Must be used in -C conjunction with DSTEPS. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1B -C***TYPE DOUBLE PRECISION (SINTRP-S, DINTP-D) -C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR, -C SMOOTH INTERPOLANT -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C The methods in subroutine DSTEPS approximate the solution near X -C by a polynomial. Subroutine DINTP approximates the solution at -C XOUT by evaluating the polynomial there. Information defining this -C polynomial is passed from DSTEPS so DINTP cannot be used alone. -C -C Subroutine DSTEPS is completely explained and documented in the text -C "Computer Solution of Ordinary Differential Equations, the Initial -C Value Problem" by L. F. Shampine and M. K. Gordon. -C -C Input to DINTP -- -C -C The user provides storage in the calling program for the arrays in -C the call list -C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),OY(NEQN) -C AND ALPHA(12),OG(13),OW(12),GI(11),IV(10) -C and defines -C XOUT -- point at which solution is desired. -C The remaining parameters are defined in DSTEPS and passed to -C DINTP from that subroutine -C -C Output from DINTP -- -C -C YOUT(*) -- solution at XOUT -C YPOUT(*) -- derivative of solution at XOUT -C The remaining parameters are returned unaltered from their input -C values. Integration with DSTEPS may be continued. -C -C***REFERENCES H. A. Watts, A smoother interpolant for DE/STEP, INTRP -C II, Report SAND84-0293, Sandia Laboratories, 1984. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 840201 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DINTP -C - INTEGER I, IQ, IV, IVC, IW, J, JQ, KGI, KOLD, KP1, KP2, - 1 L, M, NEQN - DOUBLE PRECISION ALP, ALPHA, C, G, GDI, GDIF, GI, GAMMA, H, HI, - 1 HMU, OG, OW, OX, OY, PHI, RMU, SIGMA, TEMP1, TEMP2, TEMP3, - 2 W, X, XI, XIM1, XIQ, XOUT, Y, YOUT, YPOUT -C - DIMENSION Y(*),YOUT(*),YPOUT(*),PHI(NEQN,16),OY(*) - DIMENSION G(13),C(13),W(13),OG(13),OW(12),ALPHA(12),GI(11),IV(10) -C -C***FIRST EXECUTABLE STATEMENT DINTP - KP1 = KOLD + 1 - KP2 = KOLD + 2 -C - HI = XOUT - OX - H = X - OX - XI = HI/H - XIM1 = XI - 1.D0 -C -C INITIALIZE W(*) FOR COMPUTING G(*) -C - XIQ = XI - DO 10 IQ = 1,KP1 - XIQ = XI*XIQ - TEMP1 = IQ*(IQ+1) - 10 W(IQ) = XIQ/TEMP1 -C -C COMPUTE THE DOUBLE INTEGRAL TERM GDI -C - IF (KOLD .LE. KGI) GO TO 50 - IF (IVC .GT. 0) GO TO 20 - GDI = 1.0D0/TEMP1 - M = 2 - GO TO 30 - 20 IW = IV(IVC) - GDI = OW(IW) - M = KOLD - IW + 3 - 30 IF (M .GT. KOLD) GO TO 60 - DO 40 I = M,KOLD - 40 GDI = OW(KP2-I) - ALPHA(I)*GDI - GO TO 60 - 50 GDI = GI(KOLD) -C -C COMPUTE G(*) AND C(*) -C - 60 G(1) = XI - G(2) = 0.5D0*XI*XI - C(1) = 1.0D0 - C(2) = XI - IF (KOLD .LT. 2) GO TO 90 - DO 80 I = 2,KOLD - ALP = ALPHA(I) - GAMMA = 1.0D0 + XIM1*ALP - L = KP2 - I - DO 70 JQ = 1,L - 70 W(JQ) = GAMMA*W(JQ) - ALP*W(JQ+1) - G(I+1) = W(1) - 80 C(I+1) = GAMMA*C(I) -C -C DEFINE INTERPOLATION PARAMETERS -C - 90 SIGMA = (W(2) - XIM1*W(1))/GDI - RMU = XIM1*C(KP1)/GDI - HMU = RMU/H -C -C INTERPOLATE FOR THE SOLUTION -- YOUT -C AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT -C - DO 100 L = 1,NEQN - YOUT(L) = 0.0D0 - 100 YPOUT(L) = 0.0D0 - DO 120 J = 1,KOLD - I = KP2 - J - GDIF = OG(I) - OG(I-1) - TEMP2 = (G(I) - G(I-1)) - SIGMA*GDIF - TEMP3 = (C(I) - C(I-1)) + RMU*GDIF - DO 110 L = 1,NEQN - YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) - 110 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) - 120 CONTINUE - DO 130 L = 1,NEQN - YOUT(L) = ((1.0D0 - SIGMA)*OY(L) + SIGMA*Y(L)) + - 1 H*(YOUT(L) + (G(1) - SIGMA*OG(1))*PHI(L,1)) - 130 YPOUT(L) = HMU*(OY(L) - Y(L)) + - 1 (YPOUT(L) + (C(1) + RMU*OG(1))*PHI(L,1)) -C - RETURN - END -*DECK XERMSG - SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) -C***BEGIN PROLOGUE XERMSG -C***PURPOSE Process error messages for SLATEC and other libraries. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERMSG-A) -C***KEYWORDS ERROR MESSAGE, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C XERMSG processes a diagnostic message in a manner determined by the -C value of LEVEL and the current value of the library error control -C flag, KONTRL. See subroutine XSETF for details. -C -C LIBRAR A character constant (or character variable) with the name -C of the library. This will be 'SLATEC' for the SLATEC -C Common Math Library. The error handling package is -C general enough to be used by many libraries -C simultaneously, so it is desirable for the routine that -C detects and reports an error to identify the library name -C as well as the routine name. -C -C SUBROU A character constant (or character variable) with the name -C of the routine that detected the error. Usually it is the -C name of the routine that is calling XERMSG. There are -C some instances where a user callable library routine calls -C lower level subsidiary routines where the error is -C detected. In such cases it may be more informative to -C supply the name of the routine the user called rather than -C the name of the subsidiary routine that detected the -C error. -C -C MESSG A character constant (or character variable) with the text -C of the error or warning message. In the example below, -C the message is a character constant that contains a -C generic message. -C -C CALL XERMSG ('SLATEC', 'MMPY', -C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', -C *3, 1) -C -C It is possible (and is sometimes desirable) to generate a -C specific message--e.g., one that contains actual numeric -C values. Specific numeric values can be converted into -C character strings using formatted WRITE statements into -C character variables. This is called standard Fortran -C internal file I/O and is exemplified in the first three -C lines of the following example. You can also catenate -C substrings of characters to construct the error message. -C Here is an example showing the use of both writing to -C an internal file and catenating character strings. -C -C CHARACTER*5 CHARN, CHARL -C WRITE (CHARN,10) N -C WRITE (CHARL,10) LDA -C 10 FORMAT(I5) -C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// -C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// -C * CHARL, 3, 1) -C -C There are two subtleties worth mentioning. One is that -C the // for character catenation is used to construct the -C error message so that no single character constant is -C continued to the next line. This avoids confusion as to -C whether there are trailing blanks at the end of the line. -C The second is that by catenating the parts of the message -C as an actual argument rather than encoding the entire -C message into one large character variable, we avoid -C having to know how long the message will be in order to -C declare an adequate length for that large character -C variable. XERMSG calls XERPRN to print the message using -C multiple lines if necessary. If the message is very long, -C XERPRN will break it into pieces of 72 characters (as -C requested by XERMSG) for printing on multiple lines. -C Also, XERMSG asks XERPRN to prefix each line with ' * ' -C so that the total line length could be 76 characters. -C Note also that XERPRN scans the error message backwards -C to ignore trailing blanks. Another feature is that -C the substring '$$' is treated as a new line sentinel -C by XERPRN. If you want to construct a multiline -C message without having to count out multiples of 72 -C characters, just use '$$' as a separator. '$$' -C obviously must occur within 72 characters of the -C start of each line to have its intended effect since -C XERPRN is asked to wrap around at 72 characters in -C addition to looking for '$$'. -C -C NERR An integer value that is chosen by the library routine's -C author. It must be in the range -99 to 999 (three -C printable digits). Each distinct error should have its -C own error number. These error numbers should be described -C in the machine readable documentation for the routine. -C The error numbers need be unique only within each routine, -C so it is reasonable for each routine to start enumerating -C errors from 1 and proceeding to the next integer. -C -C LEVEL An integer value in the range 0 to 2 that indicates the -C level (severity) of the error. Their meanings are -C -C -1 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. An attempt is made to only print this -C message once. -C -C 0 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. -C -C 1 A recoverable error. This is used even if the error is -C so serious that the routine cannot return any useful -C answer. If the user has told the error package to -C return after recoverable errors, then XERMSG will -C return to the Library routine which can then return to -C the user's routine. The user may also permit the error -C package to terminate the program upon encountering a -C recoverable error. -C -C 2 A fatal error. XERMSG will not return to its caller -C after it receives a fatal error. This level should -C hardly ever be used; it is much better to allow the -C user a chance to recover. An example of one of the few -C cases in which it is permissible to declare a level 2 -C error is a reverse communication Library routine that -C is likely to be called repeatedly until it integrates -C across some interval. If there is a serious error in -C the input such that another step cannot be taken and -C the Library routine is called again without the input -C error having been corrected by the caller, the Library -C routine will probably be called forever with improper -C input. In this case, it is reasonable to declare the -C error to be fatal. -C -C Each of the arguments to XERMSG is input; none will be modified by -C XERMSG. A routine may make multiple calls to XERMSG with warning -C level messages; however, after a call to XERMSG with a recoverable -C error, the routine should return to the user. Do not try to call -C XERMSG with a second recoverable error after the first recoverable -C error because the error package saves the error number. The user -C can retrieve this error number by calling another entry point in -C the error handling package and then clear the error number when -C recovering from the error. Calling XERMSG in succession causes the -C old error number to be overwritten by the latest error number. -C This is considered harmless for error numbers associated with -C warning messages but must not be done for error numbers of serious -C errors. After a call to XERMSG with a recoverable error, the user -C must be given a chance to call NUMXER or XERCLR to retrieve or -C clear the error number. -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE -C***REVISION HISTORY (YYMMDD) -C 880101 DATE WRITTEN -C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. -C THERE ARE TWO BASIC CHANGES. -C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO -C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES -C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS -C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE -C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER -C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY -C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE -C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. -C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE -C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE -C OF LOWER CASE. -C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. -C THE PRINCIPAL CHANGES ARE -C 1. CLARIFY COMMENTS IN THE PROLOGUES -C 2. RENAME XRPRNT TO XERPRN -C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES -C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / -C CHARACTER FOR NEW RECORDS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C CLEAN UP THE CODING. -C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN -C PREFIX. -C 891013 REVISED TO CORRECT COMMENTS. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but -C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added -C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and -C XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERMSG - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 XLIBR, XSUBR - CHARACTER*72 TEMP - CHARACTER*20 LFIRST -C***FIRST EXECUTABLE STATEMENT XERMSG - LKNTRL = J4SAVE (2, 0, .FALSE.) - MAXMES = J4SAVE (4, 0, .FALSE.) -C -C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. -C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE -C SHOULD BE PRINTED. -C -C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN -C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, -C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. -C - IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. - * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN - CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // - * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// - * 'JOB ABORT DUE TO FATAL ERROR.', 72) - CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) - CALL XERHLT (' ***XERMSG -- INVALID INPUT') - RETURN - ENDIF -C -C RECORD THE MESSAGE. -C - I = J4SAVE (1, NERR, .TRUE.) - CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) -C -C HANDLE PRINT-ONCE WARNING MESSAGES. -C - IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN -C -C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. -C - XLIBR = LIBRAR - XSUBR = SUBROU - LFIRST = MESSG - LERR = NERR - LLEVEL = LEVEL - CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) -C - LKNTRL = MAX(-2, MIN(2,LKNTRL)) - MKNTRL = ABS(LKNTRL) -C -C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS -C ZERO AND THE ERROR IS NOT FATAL. -C - IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 - IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 - IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 - IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 -C -C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A -C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) -C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG -C IS NOT ZERO. -C - IF (LKNTRL .NE. 0) THEN - TEMP(1:21) = 'MESSAGE FROM ROUTINE ' - I = MIN(LEN(SUBROU), 16) - TEMP(22:21+I) = SUBROU(1:I) - TEMP(22+I:33+I) = ' IN LIBRARY ' - LTEMP = 33 + I - I = MIN(LEN(LIBRAR), 16) - TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) - TEMP(LTEMP+I+1:LTEMP+I+1) = '.' - LTEMP = LTEMP + I + 1 - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE -C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE -C FROM EACH OF THE FOLLOWING THREE OPTIONS. -C 1. LEVEL OF THE MESSAGE -C 'INFORMATIVE MESSAGE' -C 'POTENTIALLY RECOVERABLE ERROR' -C 'FATAL ERROR' -C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE -C 'PROG CONTINUES' -C 'PROG ABORTED' -C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK -C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS -C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) -C 'TRACEBACK REQUESTED' -C 'TRACEBACK NOT REQUESTED' -C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT -C EXCEED 74 CHARACTERS. -C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. -C - IF (LKNTRL .GT. 0) THEN -C -C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. -C - IF (LEVEL .LE. 0) THEN - TEMP(1:20) = 'INFORMATIVE MESSAGE,' - LTEMP = 20 - ELSEIF (LEVEL .EQ. 1) THEN - TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' - LTEMP = 30 - ELSE - TEMP(1:12) = 'FATAL ERROR,' - LTEMP = 12 - ENDIF -C -C THEN WHETHER THE PROGRAM WILL CONTINUE. -C - IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. - * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN - TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' - LTEMP = LTEMP + 14 - ELSE - TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' - LTEMP = LTEMP + 16 - ENDIF -C -C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' - LTEMP = LTEMP + 20 - ELSE - TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' - LTEMP = LTEMP + 24 - ENDIF - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C NOW SEND OUT THE MESSAGE. -C - CALL XERPRN (' * ', -1, MESSG, 72) -C -C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A -C TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR - DO 10 I=16,22 - IF (TEMP(I:I) .NE. ' ') GO TO 20 - 10 CONTINUE -C - 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) - CALL FDUMP - ENDIF -C -C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. -C - IF (LKNTRL .NE. 0) THEN - CALL XERPRN (' * ', -1, ' ', 72) - CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) - CALL XERPRN (' ', 0, ' ', 72) - ENDIF -C -C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE -C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. -C - 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN -C -C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A -C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR -C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. -C - IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN - IF (LEVEL .EQ. 1) THEN - CALL XERPRN - * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) - ELSE - CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) - ENDIF - CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) - CALL XERHLT (' ') - ELSE - CALL XERHLT (MESSG) - ENDIF - RETURN - END -*DECK XERPRN - SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) -C***BEGIN PROLOGUE XERPRN -C***SUBSIDIARY -C***PURPOSE Print error messages processed by XERMSG. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERPRN-A) -C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C This routine sends one or more lines to each of the (up to five) -C logical units to which error messages are to be sent. This routine -C is called several times by XERMSG, sometimes with a single line to -C print and sometimes with a (potentially very long) message that may -C wrap around into multiple lines. -C -C PREFIX Input argument of type CHARACTER. This argument contains -C characters to be put at the beginning of each line before -C the body of the message. No more than 16 characters of -C PREFIX will be used. -C -C NPREF Input argument of type INTEGER. This argument is the number -C of characters to use from PREFIX. If it is negative, the -C intrinsic function LEN is used to determine its length. If -C it is zero, PREFIX is not used. If it exceeds 16 or if -C LEN(PREFIX) exceeds 16, only the first 16 characters will be -C used. If NPREF is positive and the length of PREFIX is less -C than NPREF, a copy of PREFIX extended with blanks to length -C NPREF will be used. -C -C MESSG Input argument of type CHARACTER. This is the text of a -C message to be printed. If it is a long message, it will be -C broken into pieces for printing on multiple lines. Each line -C will start with the appropriate prefix and be followed by a -C piece of the message. NWRAP is the number of characters per -C piece; that is, after each NWRAP characters, we break and -C start a new line. In addition the characters '$$' embedded -C in MESSG are a sentinel for a new line. The counting of -C characters up to NWRAP starts over for each new line. The -C value of NWRAP typically used by XERMSG is 72 since many -C older error messages in the SLATEC Library are laid out to -C rely on wrap-around every 72 characters. -C -C NWRAP Input argument of type INTEGER. This gives the maximum size -C piece into which to break MESSG for printing on multiple -C lines. An embedded '$$' ends a line, and the count restarts -C at the following character. If a line break does not occur -C on a blank (it would split a word) that word is moved to the -C next line. Values of NWRAP less than 16 will be treated as -C 16. Values of NWRAP greater than 132 will be treated as 132. -C The actual line length will be NPREF + NWRAP after NPREF has -C been adjusted to fall between 0 and 16 and NWRAP has been -C adjusted to fall between 16 and 132. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 880621 DATE WRITTEN -C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF -C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK -C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE -C SLASH CHARACTER IN FORMAT STATEMENTS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK -C LINES TO BE PRINTED. -C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF -C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. -C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Added code to break messages between words. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERPRN - CHARACTER*(*) PREFIX, MESSG - INTEGER NPREF, NWRAP - CHARACTER*148 CBUFF - INTEGER IU(5), NUNIT - CHARACTER*2 NEWLIN - PARAMETER (NEWLIN = '$$') -C***FIRST EXECUTABLE STATEMENT XERPRN - CALL XGETUA(IU,NUNIT) -C -C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD -C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD -C ERROR MESSAGE UNIT. -C - N = I1MACH(4) - DO 10 I=1,NUNIT - IF (IU(I) .EQ. 0) IU(I) = N - 10 CONTINUE -C -C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE -C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING -C THE REST OF THIS ROUTINE. -C - IF ( NPREF .LT. 0 ) THEN - LPREF = LEN(PREFIX) - ELSE - LPREF = NPREF - ENDIF - LPREF = MIN(16, LPREF) - IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX -C -C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE -C TIME FROM MESSG TO PRINT ON ONE LINE. -C - LWRAP = MAX(16, MIN(132, NWRAP)) -C -C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. -C - LENMSG = LEN(MESSG) - N = LENMSG - DO 20 I=1,N - IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 - LENMSG = LENMSG - 1 - 20 CONTINUE - 30 CONTINUE -C -C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. -C - IF (LENMSG .EQ. 0) THEN - CBUFF(LPREF+1:LPREF+1) = ' ' - DO 40 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) - 40 CONTINUE - RETURN - ENDIF -C -C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING -C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. -C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. -C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. -C -C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE -C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE -C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH -C OF THE SECOND ARGUMENT. -C -C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE -C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER -C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT -C POSITION NEXTC. -C -C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE -C REMAINDER OF THE CHARACTER STRING. LPIECE -C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, -C WHICHEVER IS LESS. -C -C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: -C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE -C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY -C BLANK LINES. THIS TAKES CARE OF THE SITUATION -C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF -C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE -C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC -C SHOULD BE INCREMENTED BY 2. -C -C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. -C -C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 -C RESET LPIECE = LPIECE-1. NOTE THAT THIS -C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. -C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY -C AT THE END OF A LINE. -C - NEXTC = 1 - 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) - IF (LPIECE .EQ. 0) THEN -C -C THERE WAS NO NEW LINE SENTINEL FOUND. -C - IDELTA = 0 - LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) - IF (LPIECE .LT. LENMSG+1-NEXTC) THEN - DO 52 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 54 - ENDIF - 52 CONTINUE - ENDIF - 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSEIF (LPIECE .EQ. 1) THEN -C -C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). -C DON'T PRINT A BLANK LINE. -C - NEXTC = NEXTC + 2 - GO TO 50 - ELSEIF (LPIECE .GT. LWRAP+1) THEN -C -C LPIECE SHOULD BE SET DOWN TO LWRAP. -C - IDELTA = 0 - LPIECE = LWRAP - DO 56 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 58 - ENDIF - 56 CONTINUE - 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSE -C -C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. -C WE SHOULD DECREMENT LPIECE BY ONE. -C - LPIECE = LPIECE - 1 - CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + 2 - ENDIF -C -C PRINT -C - DO 60 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) - 60 CONTINUE -C - IF (NEXTC .LE. LENMSG) GO TO 50 - RETURN - END -*DECK XERSVE - SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, - + ICOUNT) -C***BEGIN PROLOGUE XERSVE -C***SUBSIDIARY -C***PURPOSE Record that an error has occurred. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3 -C***TYPE ALL (XERSVE-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C *Usage: -C -C INTEGER KFLAG, NERR, LEVEL, ICOUNT -C CHARACTER * (len) LIBRAR, SUBROU, MESSG -C -C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) -C -C *Arguments: -C -C LIBRAR :IN is the library that the message is from. -C SUBROU :IN is the subroutine that the message is from. -C MESSG :IN is the message to be saved. -C KFLAG :IN indicates the action to be performed. -C when KFLAG > 0, the message in MESSG is saved. -C when KFLAG=0 the tables will be dumped and -C cleared. -C when KFLAG < 0, the tables will be dumped and -C not cleared. -C NERR :IN is the error number. -C LEVEL :IN is the error severity. -C ICOUNT :OUT the number of times this message has been seen, -C or zero if the table has overflowed and does not -C contain this message specifically. When KFLAG=0, -C ICOUNT will not be altered. -C -C *Description: -C -C Record that this error occurred and possibly dump and clear the -C tables. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 800319 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900413 Routine modified to remove reference to KFLAG. (WRB) -C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling -C sequence, use IF-THEN-ELSE, make number of saved entries -C easily changeable, changed routine name from XERSAV to -C XERSVE. (RWC) -C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERSVE - PARAMETER (LENTAB=10) - INTEGER LUN(5) - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB - CHARACTER*20 MESTAB(LENTAB), MES - DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) - SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG - DATA KOUNTX/0/, NMSG/0/ -C***FIRST EXECUTABLE STATEMENT XERSVE -C - IF (KFLAG.LE.0) THEN -C -C Dump the table. -C - IF (NMSG.EQ.0) RETURN -C -C Print to each unit. -C - CALL XGETUA (LUN, NUNIT) - DO 20 KUNIT = 1,NUNIT - IUNIT = LUN(KUNIT) - IF (IUNIT.EQ.0) IUNIT = I1MACH(4) -C -C Print the table header. -C - WRITE (IUNIT,9000) -C -C Print body of table. -C - DO 10 I = 1,NMSG - WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), - * NERTAB(I),LEVTAB(I),KOUNT(I) - 10 CONTINUE -C -C Print number of other errors. -C - IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX - WRITE (IUNIT,9030) - 20 CONTINUE -C -C Clear the error tables. -C - IF (KFLAG.EQ.0) THEN - NMSG = 0 - KOUNTX = 0 - ENDIF - ELSE -C -C PROCESS A MESSAGE... -C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, -C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. -C - LIB = LIBRAR - SUB = SUBROU - MES = MESSG - DO 30 I = 1,NMSG - IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. - * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. - * LEVEL.EQ.LEVTAB(I)) THEN - KOUNT(I) = KOUNT(I) + 1 - ICOUNT = KOUNT(I) - RETURN - ENDIF - 30 CONTINUE -C - IF (NMSG.LT.LENTAB) THEN -C -C Empty slot found for new message. -C - NMSG = NMSG + 1 - LIBTAB(I) = LIB - SUBTAB(I) = SUB - MESTAB(I) = MES - NERTAB(I) = NERR - LEVTAB(I) = LEVEL - KOUNT (I) = 1 - ICOUNT = 1 - ELSE -C -C Table is full. -C - KOUNTX = KOUNTX+1 - ICOUNT = 0 - ENDIF - ENDIF - RETURN -C -C Formats. -C - 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / - + ' LIBRARY SUBROUTINE MESSAGE START NERR', - + ' LEVEL COUNT') - 9010 FORMAT (1X,A,3X,A,3X,A,3I10) - 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) - 9030 FORMAT (1X) - END -*DECK D1MACH - DOUBLE PRECISION FUNCTION D1MACH (I) -C***BEGIN PROLOGUE D1MACH -C***PURPOSE Return floating point machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C D1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument, and can be referenced as follows: -C -C D = D1MACH(I) -C -C where I=1,...,5. The (output) value of D above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. -C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. -C D1MACH( 3) = B**(-T), the smallest relative spacing. -C D1MACH( 4) = B**(1-T), the largest relative spacing. -C D1MACH( 5) = LOG10(B) -C -C Assume double precision numbers are represented in the T-digit, -C base-B form -C -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and -C EMIN .LE. E .LE. EMAX. -C -C The values of B, T, EMIN and EMAX are provided in I1MACH as -C follows: -C I1MACH(10) = B, the base. -C I1MACH(14) = T, the number of base-B digits. -C I1MACH(15) = EMIN, the smallest exponent E. -C I1MACH(16) = EMAX, the largest exponent E. -C -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890213 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 900911 Added SUN 386i constants. (WRB) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added CONVEX -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE D1MACH -C - INTEGER SMALL(4) - INTEGER LARGE(4) - INTEGER RIGHT(4) - INTEGER DIVER(4) - INTEGER LOG10(4) -C -C Initial data here correspond to the IEEE standard. The values for -C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value -C for DMACH(2) is a slight lower bound. The value for DMACH(5) is -C a 20-digit approximation. If one of the sets of initial data below -C is preferred, do the necessary commenting and uncommenting. (DWL) - DOUBLE PRECISION DMACH(5) - DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, - 1 0.30102999566398119521D0 / - SAVE DMACH -C -cc EQUIVALENCE (DMACH(1),SMALL(1)) -cc EQUIVALENCE (DMACH(2),LARGE(1)) -cc EQUIVALENCE (DMACH(3),RIGHT(1)) -cc EQUIVALENCE (DMACH(4),DIVER(1)) -cc EQUIVALENCE (DMACH(5),LOG10(1)) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / -C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / -C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / -C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA SMALL(1) / ZC00800000 / -C DATA SMALL(2) / Z000000000 / -C DATA LARGE(1) / ZDFFFFFFFF / -C DATA LARGE(2) / ZFFFFFFFFF / -C DATA RIGHT(1) / ZCC5800000 / -C DATA RIGHT(2) / Z000000000 / -C DATA DIVER(1) / ZCC6800000 / -C DATA DIVER(2) / Z000000000 / -C DATA LOG10(1) / ZD00E730E7 / -C DATA LOG10(2) / ZC77800DC0 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O0000000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O0007777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O7770000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O7777777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA SMALL(1) / Z"3001800000000000" / -C DATA SMALL(2) / Z"3001000000000000" / -C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / -C DATA LARGE(2) / Z"4FFE000000000000" / -C DATA RIGHT(1) / Z"3FD2800000000000" / -C DATA RIGHT(2) / Z"3FD2000000000000" / -C DATA DIVER(1) / Z"3FD3800000000000" / -C DATA DIVER(2) / Z"3FD3000000000000" / -C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / -C DATA LOG10(2) / Z"3FFFF7988F8959AC" / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA SMALL(1) / 00564000000000000000B / -C DATA SMALL(2) / 00000000000000000000B / -C DATA LARGE(1) / 37757777777777777777B / -C DATA LARGE(2) / 37157777777777777777B / -C DATA RIGHT(1) / 15624000000000000000B / -C DATA RIGHT(2) / 00000000000000000000B / -C DATA DIVER(1) / 15634000000000000000B / -C DATA DIVER(2) / 00000000000000000000B / -C DATA LOG10(1) / 17164642023241175717B / -C DATA LOG10(2) / 16367571421742254654B / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn OR -pd8 COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CC0000000000000' / -C DATA DMACH(4) / Z'3CD0000000000000' / -C DATA DMACH(5) / Z'3FF34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F900000000000000000000000000000' / -C DATA DMACH(4) / Z'3F910000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE CRAY -C -C DATA SMALL(1) / 201354000000000000000B / -C DATA SMALL(2) / 000000000000000000000B / -C DATA LARGE(1) / 577767777777777777777B / -C DATA LARGE(2) / 000007777777777777774B / -C DATA RIGHT(1) / 376434000000000000000B / -C DATA RIGHT(2) / 000000000000000000000B / -C DATA DIVER(1) / 376444000000000000000B / -C DATA DIVER(2) / 000000000000000000000B / -C DATA LOG10(1) / 377774642023241175717B / -C DATA LOG10(2) / 000007571421742254654B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC DMACH(5) -C -C DATA SMALL / 20K, 3*0 / -C DATA LARGE / 77777K, 3*177777K / -C DATA RIGHT / 31420K, 3*0 / -C DATA DIVER / 32020K, 3*0 / -C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA DMACH(1) / '0000000000000010'X / -C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / -C DATA DMACH(3) / '0000000000003CC0'X / -C DATA DMACH(4) / '0000000000003CD0'X / -C DATA DMACH(5) / '79FF509F44133FF3'X / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FORMAT -C -C DATA DMACH(1) / '0010000000000000'X / -C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / -C DATA DMACH(3) / '3CA0000000000000'X / -C DATA DMACH(4) / '3CB0000000000000'X / -C DATA DMACH(5) / '3FD34413509F79FF'X / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ -C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ -C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ -C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ -C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / -C -C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 16, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 15552, 0 / -C DATA DIVER(1), DIVER(2) / 15568, 0 / -C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / -C -C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) -C -C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / -C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / -C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / -C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / -C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / -C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / -C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / -C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -C DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / -C DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / -C DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / -C DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / -C DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / -C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / -C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / -C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2) / 40000B, 0 / -C DATA SMALL(3), SMALL(4) / 0, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177777B / -C DATA LARGE(3), LARGE(4) / 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 225B / -C DATA DIVER(1), DIVER(2) / 40000B, 0 / -C DATA DIVER(3), DIVER(4) / 0, 227B / -C DATA LOG10(1), LOG10(2) / 46420B, 46502B / -C DATA LOG10(3), LOG10(4) / 76747B, 176377B / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / -C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / -C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / -C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / -C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / -C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / -C -C MACHINE CONSTANTS FOR THE IBM PC -C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION -C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. -C -C DATA SMALL(1) / 2.23D-308 / -C DATA LARGE(1) / 1.79D+308 / -C DATA RIGHT(1) / 1.11D-16 / -C DATA DIVER(1) / 2.22D-16 / -C DATA LOG10(1) / 0.301029995663981195D0 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / -C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / -C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 8388608, 0 / -C DATA LARGE(1), LARGE(2) / 2147483647, -1 / -C DATA RIGHT(1), RIGHT(2) / 612368384, 0 / -C DATA DIVER(1), DIVER(2) / 620756992, 0 / -C DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / -C -C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / -C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / -C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / -C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / -C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA SMALL(3), SMALL(4) / 0, 0 / -C DATA LARGE(1), LARGE(2) / 32767, -1 / -C DATA LARGE(3), LARGE(4) / -1, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA DIVER(3), DIVER(4) / 0, 0 / -C DATA LOG10(1), LOG10(2) / 16282, 8346 / -C DATA LOG10(3), LOG10(4) / -31493, -12296 / -C -C DATA SMALL(1), SMALL(2) / O000200, O000000 / -C DATA SMALL(3), SMALL(4) / O000000, O000000 / -C DATA LARGE(1), LARGE(2) / O077777, O177777 / -C DATA LARGE(3), LARGE(4) / O177777, O177777 / -C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / -C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / -C DATA DIVER(1), DIVER(2) / O022400, O000000 / -C DATA DIVER(3), DIVER(4) / O000000, O000000 / -C DATA LOG10(1), LOG10(2) / O037632, O020232 / -C DATA LOG10(3), LOG10(4) / O102373, O147770 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / -C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE SUN 386i -C -C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / -C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / -C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' -C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / -C DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / -C DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / -C DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / -C DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / -C -C***FIRST EXECUTABLE STATEMENT D1MACH - IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', - + 'I OUT OF BOUNDS', 1, 2) -C - D1MACH = DMACH(I) - RETURN -C - END -*DECK XGETUA - SUBROUTINE XGETUA (IUNITA, N) -C***BEGIN PROLOGUE XGETUA -C***PURPOSE Return unit number(s) to which error messages are being -C sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XGETUA-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XGETUA may be called to determine the unit number or numbers -C to which error messages are being sent. -C These unit numbers may have been set by a call to XSETUN, -C or a call to XSETUA, or may be a default value. -C -C Description of Parameters -C --Output-- -C IUNIT - an array of one to five unit numbers, depending -C on the value of N. A value of zero refers to the -C default unit, as defined by the I1MACH machine -C constant routine. Only IUNIT(1),...,IUNIT(N) are -C defined by XGETUA. The values of IUNIT(N+1),..., -C IUNIT(5) are not defined (for N .LT. 5) or altered -C in any way by XGETUA. -C N - the number of units to which copies of the -C error messages are being sent. N will be in the -C range from 1 to 5. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED J4SAVE -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XGETUA - DIMENSION IUNITA(5) -C***FIRST EXECUTABLE STATEMENT XGETUA - N = J4SAVE(5,0,.FALSE.) - DO 30 I=1,N - INDEX = I+4 - IF (I.EQ.1) INDEX = 3 - IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) - 30 CONTINUE - RETURN - END -*DECK DSTEPS - SUBROUTINE DSTEPS (DF, NEQN, Y, X, H, EPS, WT, START, HOLD, K, - + KOLD, CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G, - + PHASE1, NS, NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV, - + KGI, GI, RPAR, IPAR) -C***BEGIN PROLOGUE DSTEPS -C***PURPOSE Integrate a system of first order ordinary differential -C equations one step. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1B -C***TYPE DOUBLE PRECISION (STEPS-S, DSTEPS-D) -C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR -C***AUTHOR Shampine, L. F., (SNLA) -C Gordon, M. K., (SNLA) -C MODIFIED BY H.A. WATTS -C***DESCRIPTION -C -C Written by L. F. Shampine and M. K. Gordon -C -C Abstract -C -C Subroutine DSTEPS is normally used indirectly through subroutine -C DDEABM . Because DDEABM suffices for most problems and is much -C easier to use, using it should be considered before using DSTEPS -C alone. -C -C Subroutine DSTEPS integrates a system of NEQN first order ordinary -C differential equations one step, normally from X to X+H, using a -C modified divided difference form of the Adams Pece formulas. Local -C extrapolation is used to improve absolute stability and accuracy. -C The code adjusts its order and step size to control the local error -C per unit step in a generalized sense. Special devices are included -C to control roundoff error and to detect when the user is requesting -C too much accuracy. -C -C This code is completely explained and documented in the text, -C Computer Solution of Ordinary Differential Equations, The Initial -C Value Problem by L. F. Shampine and M. K. Gordon. -C Further details on use of this code are available in "Solving -C Ordinary Differential Equations with ODE, STEP, and INTRP", -C by L. F. Shampine and M. K. Gordon, SLA-73-1060. -C -C -C The parameters represent -- -C DF -- subroutine to evaluate derivatives -C NEQN -- number of equations to be integrated -C Y(*) -- solution vector at X -C X -- independent variable -C H -- appropriate step size for next step. Normally determined by -C code -C EPS -- local error tolerance -C WT(*) -- vector of weights for error criterion -C START -- logical variable set .TRUE. for first step, .FALSE. -C otherwise -C HOLD -- step size used for last successful step -C K -- appropriate order for next step (determined by code) -C KOLD -- order used for last successful step -C CRASH -- logical variable set .TRUE. when no step can be taken, -C .FALSE. otherwise. -C YP(*) -- derivative of solution vector at X after successful -C step -C KSTEPS -- counter on attempted steps -C TWOU -- 2.*U where U is machine unit roundoff quantity -C FOURU -- 4.*U where U is machine unit roundoff quantity -C RPAR,IPAR -- parameter arrays which you may choose to use -C for communication between your program and subroutine F. -C They are not altered or used by DSTEPS. -C The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G, -C W,P,IV and GI are required for the interpolation subroutine SINTRP. -C The remaining variables and arrays are included in the call list -C only to eliminate local retention of variables between calls. -C -C Input to DSTEPS -C -C First call -- -C -C The user must provide storage in his calling program for all arrays -C in the call list, namely -C -C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), -C 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), -C 2 RPAR(*),IPAR(*) -C -C **Note** -C -C The user must also declare START , CRASH , PHASE1 and NORND -C logical variables and DF an EXTERNAL subroutine, supply the -C subroutine DF(X,Y,YP) to evaluate -C DY(I)/DX = YP(I) = DF(X,Y(1),Y(2),...,Y(NEQN)) -C and initialize only the following parameters. -C NEQN -- number of equations to be integrated -C Y(*) -- vector of initial values of dependent variables -C X -- initial value of the independent variable -C H -- nominal step size indicating direction of integration -C and maximum size of step. Must be variable -C EPS -- local error tolerance per step. Must be variable -C WT(*) -- vector of non-zero weights for error criterion -C START -- .TRUE. -C YP(*) -- vector of initial derivative values -C KSTEPS -- set KSTEPS to zero -C TWOU -- 2.*U where U is machine unit roundoff quantity -C FOURU -- 4.*U where U is machine unit roundoff quantity -C Define U to be the machine unit roundoff quantity by calling -C the function routine D1MACH, U = D1MACH(4), or by -C computing U so that U is the smallest positive number such -C that 1.0+U .GT. 1.0. -C -C DSTEPS requires that the L2 norm of the vector with components -C LOCAL ERROR(L)/WT(L) be less than EPS for a successful step. The -C array WT allows the user to specify an error test appropriate -C for his problem. For example, -C WT(L) = 1.0 specifies absolute error, -C = ABS(Y(L)) error relative to the most recent value of the -C L-th component of the solution, -C = ABS(YP(L)) error relative to the most recent value of -C the L-th component of the derivative, -C = MAX(WT(L),ABS(Y(L))) error relative to the largest -C magnitude of L-th component obtained so far, -C = ABS(Y(L))*RELERR/EPS + ABSERR/EPS specifies a mixed -C relative-absolute test where RELERR is relative -C error, ABSERR is absolute error and EPS = -C MAX(RELERR,ABSERR) . -C -C Subsequent calls -- -C -C Subroutine DSTEPS is designed so that all information needed to -C continue the integration, including the step size H and the order -C K , is returned with each step. With the exception of the step -C size, the error tolerance, and the weights, none of the parameters -C should be altered. The array WT must be updated after each step -C to maintain relative error tests like those above. Normally the -C integration is continued just beyond the desired endpoint and the -C solution interpolated there with subroutine SINTRP . If it is -C impossible to integrate beyond the endpoint, the step size may be -C reduced to hit the endpoint since the code will not take a step -C larger than the H input. Changing the direction of integration, -C i.e., the sign of H , requires the user set START = .TRUE. before -C calling DSTEPS again. This is the only situation in which START -C should be altered. -C -C Output from DSTEPS -C -C Successful Step -- -C -C The subroutine returns after each successful step with START and -C CRASH set .FALSE. . X represents the independent variable -C advanced one step of length HOLD from its value on input and Y -C the solution vector at the new value of X . All other parameters -C represent information corresponding to the new X needed to -C continue the integration. -C -C Unsuccessful Step -- -C -C When the error tolerance is too small for the machine precision, -C the subroutine returns without taking a step and CRASH = .TRUE. . -C An appropriate step size and error tolerance for continuing are -C estimated and all other information is restored as upon input -C before returning. To continue with the larger tolerance, the user -C just calls the code again. A restart is neither required nor -C desirable. -C -C***REFERENCES L. F. Shampine and M. K. Gordon, Solving ordinary -C differential equations with ODE, STEP, and INTRP, -C Report SLA-73-1060, Sandia Laboratories, 1973. -C***ROUTINES CALLED D1MACH, DHSTRT -C***REVISION HISTORY (YYMMDD) -C 740101 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSTEPS -C - INTEGER I, IFAIL, IM1, IP1, IPAR, IQ, J, K, KM1, KM2, KNEW, - 1 KOLD, KP1, KP2, KSTEPS, L, LIMIT1, LIMIT2, NEQN, NS, NSM2, - 2 NSP1, NSP2 - DOUBLE PRECISION ABSH, ALPHA, BETA, BIG, D1MACH, - 1 EPS, ERK, ERKM1, ERKM2, ERKP1, ERR, - 2 FOURU, G, GI, GSTR, H, HNEW, HOLD, P, P5EPS, PHI, PSI, R, - 3 REALI, REALNS, RHO, ROUND, RPAR, SIG, TAU, TEMP1, - 4 TEMP2, TEMP3, TEMP4, TEMP5, TEMP6, TWO, TWOU, U, V, W, WT, - 5 X, XOLD, Y, YP - LOGICAL START,CRASH,PHASE1,NORND - DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12), - 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), - 2 RPAR(*),IPAR(*) - DIMENSION TWO(13),GSTR(13) - EXTERNAL DF - SAVE TWO, GSTR -C - DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8), - 1 TWO(9),TWO(10),TWO(11),TWO(12),TWO(13) - 2 /2.0D0,4.0D0,8.0D0,16.0D0,32.0D0,64.0D0,128.0D0,256.0D0, - 3 512.0D0,1024.0D0,2048.0D0,4096.0D0,8192.0D0/ - DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7), - 1 GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13) - 2 /0.5D0,0.0833D0,0.0417D0,0.0264D0,0.0188D0,0.0143D0,0.0114D0, - 3 0.00936D0,0.00789D0,0.00679D0,0.00592D0,0.00524D0,0.00468D0/ -C -C *** BEGIN BLOCK 0 *** -C CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE -C PRECISION. IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A -C STARTING STEP SIZE. -C *** -C -C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE -C -C***FIRST EXECUTABLE STATEMENT DSTEPS - CRASH = .TRUE. - IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5 - H = SIGN(FOURU*ABS(X),H) - RETURN - 5 P5EPS = 0.5D0*EPS -C -C IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE -C - ROUND = 0.0D0 - DO 10 L = 1,NEQN - 10 ROUND = ROUND + (Y(L)/WT(L))**2 - ROUND = TWOU*SQRT(ROUND) - IF(P5EPS .GE. ROUND) GO TO 15 - EPS = 2.0D0*ROUND*(1.0D0 + FOURU) - RETURN - 15 CRASH = .FALSE. - G(1) = 1.0D0 - G(2) = 0.5D0 - SIG(1) = 1.0D0 - IF(.NOT.START) GO TO 99 -C -C INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP -C -C CALL DF(X,Y,YP,RPAR,IPAR) -C SUM = 0.0 - DO 20 L = 1,NEQN - PHI(L,1) = YP(L) - 20 PHI(L,2) = 0.0D0 -C20 SUM = SUM + (YP(L)/WT(L))**2 -C SUM = SQRT(SUM) -C ABSH = ABS(H) -C IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) -C H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) -C - U = D1MACH(4) - BIG = SQRT(D1MACH(2)) - CALL DHSTRT(DF,NEQN,X,X+H,Y,YP,WT,1,U,BIG, - 1 PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) -C - HOLD = 0.0D0 - K = 1 - KOLD = 0 - KPREV = 0 - START = .FALSE. - PHASE1 = .TRUE. - NORND = .TRUE. - IF(P5EPS .GT. 100.0D0*ROUND) GO TO 99 - NORND = .FALSE. - DO 25 L = 1,NEQN - 25 PHI(L,15) = 0.0D0 - 99 IFAIL = 0 -C *** END BLOCK 0 *** -C -C *** BEGIN BLOCK 1 *** -C COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING -C THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. -C *** -C - 100 KP1 = K+1 - KP2 = K+2 - KM1 = K-1 - KM2 = K-2 -C -C NS IS THE NUMBER OF DSTEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT -C ONE. WHEN K.LT.NS, NO COEFFICIENTS CHANGE -C - IF(H .NE. HOLD) NS = 0 - IF (NS.LE.KOLD) NS = NS+1 - NSP1 = NS+1 - IF (K .LT. NS) GO TO 199 -C -C COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH -C ARE CHANGED -C - BETA(NS) = 1.0D0 - REALNS = NS - ALPHA(NS) = 1.0D0/REALNS - TEMP1 = H*REALNS - SIG(NSP1) = 1.0D0 - IF(K .LT. NSP1) GO TO 110 - DO 105 I = NSP1,K - IM1 = I-1 - TEMP2 = PSI(IM1) - PSI(IM1) = TEMP1 - BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2 - TEMP1 = TEMP2 + H - ALPHA(I) = H/TEMP1 - REALI = I - 105 SIG(I+1) = REALI*ALPHA(I)*SIG(I) - 110 PSI(K) = TEMP1 -C -C COMPUTE COEFFICIENTS G(*) -C -C INITIALIZE V(*) AND SET W(*). -C - IF(NS .GT. 1) GO TO 120 - DO 115 IQ = 1,K - TEMP3 = IQ*(IQ+1) - V(IQ) = 1.0D0/TEMP3 - 115 W(IQ) = V(IQ) - IVC = 0 - KGI = 0 - IF (K .EQ. 1) GO TO 140 - KGI = 1 - GI(1) = W(2) - GO TO 140 -C -C IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) -C - 120 IF(K .LE. KPREV) GO TO 130 - IF (IVC .EQ. 0) GO TO 122 - JV = KP1 - IV(IVC) - IVC = IVC - 1 - GO TO 123 - 122 JV = 1 - TEMP4 = K*KP1 - V(K) = 1.0D0/TEMP4 - W(K) = V(K) - IF (K .NE. 2) GO TO 123 - KGI = 1 - GI(1) = W(2) - 123 NSM2 = NS-2 - IF(NSM2 .LT. JV) GO TO 130 - DO 125 J = JV,NSM2 - I = K-J - V(I) = V(I) - ALPHA(J+1)*V(I+1) - 125 W(I) = V(I) - IF (I .NE. 2) GO TO 130 - KGI = NS - 1 - GI(KGI) = W(2) -C -C UPDATE V(*) AND SET W(*) -C - 130 LIMIT1 = KP1 - NS - TEMP5 = ALPHA(NS) - DO 135 IQ = 1,LIMIT1 - V(IQ) = V(IQ) - TEMP5*V(IQ+1) - 135 W(IQ) = V(IQ) - G(NSP1) = W(1) - IF (LIMIT1 .EQ. 1) GO TO 137 - KGI = NS - GI(KGI) = W(2) - 137 W(LIMIT1+1) = V(LIMIT1+1) - IF (K .GE. KOLD) GO TO 140 - IVC = IVC + 1 - IV(IVC) = LIMIT1 + 2 -C -C COMPUTE THE G(*) IN THE WORK VECTOR W(*) -C - 140 NSP2 = NS + 2 - KPREV = K - IF(KP1 .LT. NSP2) GO TO 199 - DO 150 I = NSP2,KP1 - LIMIT2 = KP2 - I - TEMP6 = ALPHA(I-1) - DO 145 IQ = 1,LIMIT2 - 145 W(IQ) = W(IQ) - TEMP6*W(IQ+1) - 150 G(I) = W(1) - 199 CONTINUE -C *** END BLOCK 1 *** -C -C *** BEGIN BLOCK 2 *** -C PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED -C SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, -C K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED. -C *** -C -C INCREMENT COUNTER ON ATTEMPTED DSTEPS -C - KSTEPS = KSTEPS + 1 -C -C CHANGE PHI TO PHI STAR -C - IF(K .LT. NSP1) GO TO 215 - DO 210 I = NSP1,K - TEMP1 = BETA(I) - DO 205 L = 1,NEQN - 205 PHI(L,I) = TEMP1*PHI(L,I) - 210 CONTINUE -C -C PREDICT SOLUTION AND DIFFERENCES -C - 215 DO 220 L = 1,NEQN - PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP1) = 0.0D0 - 220 P(L) = 0.0D0 - DO 230 J = 1,K - I = KP1 - J - IP1 = I+1 - TEMP2 = G(I) - DO 225 L = 1,NEQN - P(L) = P(L) + TEMP2*PHI(L,I) - 225 PHI(L,I) = PHI(L,I) + PHI(L,IP1) - 230 CONTINUE - IF(NORND) GO TO 240 - DO 235 L = 1,NEQN - TAU = H*P(L) - PHI(L,15) - P(L) = Y(L) + TAU - 235 PHI(L,16) = (P(L) - Y(L)) - TAU - GO TO 250 - 240 DO 245 L = 1,NEQN - 245 P(L) = Y(L) + H*P(L) - 250 XOLD = X - X = X + H - ABSH = ABS(H) - CALL DF(X,P,YP,RPAR,IPAR) -C -C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 -C - ERKM2 = 0.0D0 - ERKM1 = 0.0D0 - ERK = 0.0D0 - DO 265 L = 1,NEQN - TEMP3 = 1.0D0/WT(L) - TEMP4 = YP(L) - PHI(L,1) - IF(KM2)265,260,255 - 255 ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 - 260 ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 - 265 ERK = ERK + (TEMP4*TEMP3)**2 - IF(KM2)280,275,270 - 270 ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) - 275 ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) - 280 TEMP5 = ABSH*SQRT(ERK) - ERR = TEMP5*(G(K)-G(KP1)) - ERK = TEMP5*SIG(KP1)*GSTR(K) - KNEW = K -C -C TEST IF ORDER SHOULD BE LOWERED -C - IF(KM2)299,290,285 - 285 IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1 - GO TO 299 - 290 IF(ERKM1 .LE. 0.5D0*ERK) KNEW = KM1 -C -C TEST IF STEP SUCCESSFUL -C - 299 IF(ERR .LE. EPS) GO TO 400 -C *** END BLOCK 2 *** -C -C *** BEGIN BLOCK 3 *** -C THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . -C IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE -C THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR -C TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE -C PRECISION. -C *** -C -C RESTORE X, PHI(*,*) AND PSI(*) -C - PHASE1 = .FALSE. - X = XOLD - DO 310 I = 1,K - TEMP1 = 1.0D0/BETA(I) - IP1 = I+1 - DO 305 L = 1,NEQN - 305 PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1)) - 310 CONTINUE - IF(K .LT. 2) GO TO 320 - DO 315 I = 2,K - 315 PSI(I-1) = PSI(I) - H -C -C ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP -C SIZE -C - 320 IFAIL = IFAIL + 1 - TEMP2 = 0.5D0 - IF(IFAIL - 3) 335,330,325 - 325 IF(P5EPS .LT. 0.25D0*ERK) TEMP2 = SQRT(P5EPS/ERK) - 330 KNEW = 1 - 335 H = TEMP2*H - K = KNEW - NS = 0 - IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340 - CRASH = .TRUE. - H = SIGN(FOURU*ABS(X),H) - EPS = EPS + EPS - RETURN - 340 GO TO 100 -C *** END BLOCK 3 *** -C -C *** BEGIN BLOCK 4 *** -C THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE -C THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE -C DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. -C *** - 400 KOLD = K - HOLD = H -C -C CORRECT AND EVALUATE -C - TEMP1 = H*G(KP1) - IF(NORND) GO TO 410 - DO 405 L = 1,NEQN - TEMP3 = Y(L) - RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) - Y(L) = P(L) + RHO - PHI(L,15) = (Y(L) - P(L)) - RHO - 405 P(L) = TEMP3 - GO TO 420 - 410 DO 415 L = 1,NEQN - TEMP3 = Y(L) - Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) - 415 P(L) = TEMP3 - 420 CALL DF(X,Y,YP,RPAR,IPAR) -C -C UPDATE DIFFERENCES FOR NEXT STEP -C - DO 425 L = 1,NEQN - PHI(L,KP1) = YP(L) - PHI(L,1) - 425 PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2) - DO 435 I = 1,K - DO 430 L = 1,NEQN - 430 PHI(L,I) = PHI(L,I) + PHI(L,KP1) - 435 CONTINUE -C -C ESTIMATE ERROR AT ORDER K+1 UNLESS: -C IN FIRST PHASE WHEN ALWAYS RAISE ORDER, -C ALREADY DECIDED TO LOWER ORDER, -C STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE -C - ERKP1 = 0.0D0 - IF(KNEW .EQ. KM1 .OR. K .EQ. 12) PHASE1 = .FALSE. - IF(PHASE1) GO TO 450 - IF(KNEW .EQ. KM1) GO TO 455 - IF(KP1 .GT. NS) GO TO 460 - DO 440 L = 1,NEQN - 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 - ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) -C -C USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER -C FOR NEXT STEP -C - IF(K .GT. 1) GO TO 445 - IF(ERKP1 .GE. 0.5D0*ERK) GO TO 460 - GO TO 450 - 445 IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455 - IF(ERKP1 .GE. ERK .OR. K .EQ. 12) GO TO 460 -C -C HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE -C BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED -C -C RAISE ORDER -C - 450 K = KP1 - ERK = ERKP1 - GO TO 460 -C -C LOWER ORDER -C - 455 K = KM1 - ERK = ERKM1 -C -C WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP -C - 460 HNEW = H + H - IF(PHASE1) GO TO 465 - IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465 - HNEW = H - IF(P5EPS .GE. ERK) GO TO 465 - TEMP2 = K+1 - R = (P5EPS/ERK)**(1.0D0/TEMP2) - HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R)) - HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) - 465 H = HNEW - RETURN -C *** END BLOCK 4 *** - END -*DECK FDUMP - SUBROUTINE FDUMP -C***BEGIN PROLOGUE FDUMP -C***PURPOSE Symbolic dump (should be locally written). -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3 -C***TYPE ALL (FDUMP-A) -C***KEYWORDS ERROR, XERMSG -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C ***Note*** Machine Dependent Routine -C FDUMP is intended to be replaced by a locally written -C version which produces a symbolic dump. Failing this, -C it should be replaced by a version which prints the -C subprogram nesting list. Note that this dump must be -C printed on each of up to five files, as indicated by the -C XGETUA routine. See XSETUA and XGETUA for details. -C -C Written by Ron Jones, with SLATEC Common Math Library Subcommittee -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE FDUMP -C***FIRST EXECUTABLE STATEMENT FDUMP - RETURN - END -*DECK I1MACH - INTEGER FUNCTION I1MACH (I) -C***BEGIN PROLOGUE I1MACH -C***PURPOSE Return integer machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE INTEGER (I1MACH-I) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C I1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument and can be referenced as follows: -C -C K = I1MACH(I) -C -C where I=1,...,16. The (output) value of K above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C I/O unit numbers: -C I1MACH( 1) = the standard input unit. -C I1MACH( 2) = the standard output unit. -C I1MACH( 3) = the standard punch unit. -C I1MACH( 4) = the standard error message unit. -C -C Words: -C I1MACH( 5) = the number of bits per integer storage unit. -C I1MACH( 6) = the number of characters per integer storage unit. -C -C Integers: -C assume integers are represented in the S-digit, base-A form -C -C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) -C -C where 0 .LE. X(I) .LT. A for I=0,...,S-1. -C I1MACH( 7) = A, the base. -C I1MACH( 8) = S, the number of base-A digits. -C I1MACH( 9) = A**S - 1, the largest magnitude. -C -C Floating-Point Numbers: -C Assume floating-point numbers are represented in the T-digit, -C base-B form -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, -C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. -C I1MACH(10) = B, the base. -C -C Single-Precision: -C I1MACH(11) = T, the number of base-B digits. -C I1MACH(12) = EMIN, the smallest exponent E. -C I1MACH(13) = EMAX, the largest exponent E. -C -C Double-Precision: -C I1MACH(14) = T, the number of base-B digits. -C I1MACH(15) = EMIN, the smallest exponent E. -C I1MACH(16) = EMAX, the largest exponent E. -C -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 891012 Added VAX G-floating constants. (WRB) -C 891012 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. -C (RWC) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added Convex -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler -C options. (DWL, RWC and WRB). -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE I1MACH -C -C Initial data here correspond to the IEEE standard. If one of the -C sets of initial data below is preferred, do the necessary commenting -C and uncommenting. (DWL) - INTEGER IMACH(16),OUTPUT - DATA IMACH( 1) / 5 / - DATA IMACH( 2) / 6 / - DATA IMACH( 3) / 6 / - DATA IMACH( 4) / 6 / - DATA IMACH( 5) / 32 / - DATA IMACH( 6) / 4 / - DATA IMACH( 7) / 2 / - DATA IMACH( 8) / 31 / - DATA IMACH( 9) / 2147483647 / - DATA IMACH(10) / 2 / - DATA IMACH(11) / 24 / - DATA IMACH(12) / -126 / - DATA IMACH(13) / 127 / - DATA IMACH(14) / 53 / - DATA IMACH(15) / -1022 / - DATA IMACH(16) / 1023 / - SAVE IMACH -cc EQUIVALENCE (IMACH(4),OUTPUT) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 129 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1025 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA IMACH( 1) / 7 / -C DATA IMACH( 2) / 2 / -C DATA IMACH( 3) / 2 / -C DATA IMACH( 4) / 2 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 33 / -C DATA IMACH( 9) / Z1FFFFFFFF / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -256 / -C DATA IMACH(13) / 255 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -256 / -C DATA IMACH(16) / 255 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -50 / -C DATA IMACH(16) / 76 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -32754 / -C DATA IMACH(16) / 32780 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -4095 / -C DATA IMACH(13) / 4094 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -4095 / -C DATA IMACH(16) / 4094 / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6LOUTPUT/ -C DATA IMACH( 5) / 60 / -C DATA IMACH( 6) / 10 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 48 / -C DATA IMACH( 9) / 00007777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -929 / -C DATA IMACH(13) / 1070 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -929 / -C DATA IMACH(16) / 1069 / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z'7FFFFFFF' / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16383 / -C DATA IMACH(16) / 16383 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -pd8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 46 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 46 / -C DATA IMACH( 9) / 1777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 64 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 777777777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C DATA IMACH( 1) / 11 / -C DATA IMACH( 2) / 12 / -C DATA IMACH( 3) / 8 / -C DATA IMACH( 4) / 10 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 24 / -C DATA IMACH( 6) / 3 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 23 / -C DATA IMACH( 9) / 8388607 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 38 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 43 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / O377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 63 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 39 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 55 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 7 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1015 / -C DATA IMACH(16) / 1017 / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z7FFFFFFF / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE IBM PC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 54 / -C DATA IMACH(15) / -101 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 62 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1021 / -C DATA IMACH(13) / 1024 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16381 / -C DATA IMACH(16) / 16384 / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 1 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / O377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -1024 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR -C -C DATA IMACH( 1) / 1 / -C DATA IMACH( 2) / 1 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C***FIRST EXECUTABLE STATEMENT I1MACH - IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 -C - I1MACH = IMACH(I) - RETURN -C - 10 CONTINUE - WRITE (UNIT = OUTPUT, FMT = 9000) - 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') -C -C CALL FDUMP -C - STOP - END -*DECK DHSTRT - SUBROUTINE DHSTRT (DF, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, - + BIG, SPY, PV, YP, SF, RPAR, IPAR, H) -C***BEGIN PROLOGUE DHSTRT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (HSTART-S, DHSTRT-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DHSTRT computes a starting step size to be used in solving initial -C value problems in ordinary differential equations. -C -C ********************************************************************** -C ABSTRACT -C -C Subroutine DHSTRT computes a starting step size to be used by an -C initial value method in solving ordinary differential equations. -C It is based on an estimate of the local Lipschitz constant for the -C differential equation (lower bound on a norm of the Jacobian) , -C a bound on the differential equation (first derivative) , and -C a bound on the partial derivative of the equation with respect to -C the independent variable. -C (all approximated near the initial point A) -C -C Subroutine DHSTRT uses a function subprogram DHVNRM for computing -C a vector norm. The maximum norm is presently utilized though it -C can easily be replaced by any other vector norm. It is presumed -C that any replacement norm routine would be carefully coded to -C prevent unnecessary underflows or overflows from occurring, and -C also, would not alter the vector or number of components. -C -C ********************************************************************** -C On input you must provide the following -C -C DF -- This is a subroutine of the form -C DF(X,U,UPRIME,RPAR,IPAR) -C which defines the system of first order differential -C equations to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=DF(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine DF must not alter X or U(*). You must declare -C the name DF in an external statement in your program that -C calls DHSTRT. You must dimension U and UPRIME in DF. -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C program and subroutine DF. They are not used or altered by -C DHSTRT. If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. If you do -C choose to use them, dimension them in your program and in -C DF as arrays of appropriate length. -C -C NEQ -- This is the number of (first order) differential equations -C to be integrated. -C -C A -- This is the initial point of integration. -C -C B -- This is a value of the independent variable used to define -C the direction of integration. A reasonable choice is to -C set B to the first point at which a solution is desired. -C You can also use B, if necessary, to restrict the length -C of the first integration step because the algorithm will -C not compute a starting step length which is bigger than -C ABS(B-A), unless B has been chosen too close to A. -C (it is presumed that DHSTRT has been called with B -C different from A on the machine being used. Also see the -C discussion about the parameter SMALL.) -C -C Y(*) -- This is the vector of initial values of the NEQ solution -C components at the initial point A. -C -C YPRIME(*) -- This is the vector of derivatives of the NEQ -C solution components at the initial point A. -C (defined by the differential equations in subroutine DF) -C -C ETOL -- This is the vector of error tolerances corresponding to -C the NEQ solution components. It is assumed that all -C elements are positive. Following the first integration -C step, the tolerances are expected to be used by the -C integrator in an error test which roughly requires that -C ABS(LOCAL ERROR) .LE. ETOL -C for each vector component. -C -C MORDER -- This is the order of the formula which will be used by -C the initial value method for taking the first integration -C step. -C -C SMALL -- This is a small positive machine dependent constant -C which is used for protecting against computations with -C numbers which are too small relative to the precision of -C floating point arithmetic. SMALL should be set to -C (approximately) the smallest positive DOUBLE PRECISION -C number such that (1.+SMALL) .GT. 1. on the machine being -C used. The quantity SMALL**(3/8) is used in computing -C increments of variables for approximating derivatives by -C differences. Also the algorithm will not compute a -C starting step length which is smaller than -C 100*SMALL*ABS(A). -C -C BIG -- This is a large positive machine dependent constant which -C is used for preventing machine overflows. A reasonable -C choice is to set big to (approximately) the square root of -C the largest DOUBLE PRECISION number which can be held in -C the machine. -C -C SPY(*),PV(*),YP(*),SF(*) -- These are DOUBLE PRECISION work -C arrays of length NEQ which provide the routine with needed -C storage space. -C -C RPAR,IPAR -- These are parameter arrays, of DOUBLE PRECISION and -C INTEGER type, respectively, which can be used for -C communication between your program and the DF subroutine. -C They are not used or altered by DHSTRT. -C -C ********************************************************************** -C On Output (after the return from DHSTRT), -C -C H -- is an appropriate starting step size to be attempted by the -C differential equation method. -C -C All parameters in the call list remain unchanged except for -C the working arrays SPY(*),PV(*),YP(*), and SF(*). -C -C ********************************************************************** -C -C***SEE ALSO DDEABM, DDEBDF, DDERKF -C***ROUTINES CALLED DHVNRM -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DHSTRT -C - INTEGER IPAR, J, K, LK, MORDER, NEQ - DOUBLE PRECISION A, ABSDX, B, BIG, DA, DELF, DELY, - 1 DFDUB, DFDXB, DHVNRM, - 2 DX, DY, ETOL, FBND, H, PV, RELPER, RPAR, SF, SMALL, SPY, - 3 SRYDPB, TOLEXP, TOLMIN, TOLP, TOLSUM, Y, YDPB, YP, YPRIME - DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*), - 1 SF(*),RPAR(*),IPAR(*) - EXTERNAL DF -C -C .................................................................. -C -C BEGIN BLOCK PERMITTING ...EXITS TO 160 -C***FIRST EXECUTABLE STATEMENT DHSTRT - DX = B - A - ABSDX = ABS(DX) - RELPER = SMALL**0.375D0 -C -C ............................................................... -C -C COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL -C DERIVATIVE OF THE EQUATION WITH RESPECT TO THE -C INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. -C ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE -C LOCALLY. -C - DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX), - 1 100.0D0*SMALL*ABS(A)),DX) - IF (DA .EQ. 0.0D0) DA = RELPER*DX - CALL DF(A+DA,Y,SF,RPAR,IPAR) - DO 10 J = 1, NEQ - YP(J) = SF(J) - YPRIME(J) - 10 CONTINUE - DELF = DHVNRM(YP,NEQ) - DFDXB = BIG - IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA) - FBND = DHVNRM(SF,NEQ) -C -C ............................................................... -C -C COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ -C CONSTANT FOR THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS -C ALSO REPRESENTS AN ESTIMATE OF THE NORM OF THE JACOBIAN -C LOCALLY. THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO -C ESTIMATE THE LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. -C THE FIRST PERTURBATION VECTOR IS BASED ON THE INITIAL -C DERIVATIVES AND DIRECTION OF INTEGRATION. THE SECOND -C PERTURBATION VECTOR IS FORMED USING ANOTHER EVALUATION OF -C THE DIFFERENTIAL EQUATION. THE THIRD PERTURBATION VECTOR -C IS FORMED USING PERTURBATIONS BASED ONLY ON THE INITIAL -C VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS CHANGED TO -C NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN -C INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT -C COMPONENTS OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE -C CONSISTENT WITH THE SLOPES OF LOCAL SOLUTION CURVES. -C ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST -C DERIVATIVE. -C -C PERTURBATION VECTOR SIZE IS HELD -C CONSTANT FOR ALL ITERATIONS. COMPUTE -C THIS CHANGE FROM THE -C SIZE OF THE VECTOR OF INITIAL -C VALUES. - DELY = RELPER*DHVNRM(Y,NEQ) - IF (DELY .EQ. 0.0D0) DELY = RELPER - DELY = SIGN(DELY,DX) - DELF = DHVNRM(YPRIME,NEQ) - FBND = MAX(FBND,DELF) - IF (DELF .EQ. 0.0D0) GO TO 30 -C USE INITIAL DERIVATIVES FOR FIRST PERTURBATION - DO 20 J = 1, NEQ - SPY(J) = YPRIME(J) - YP(J) = YPRIME(J) - 20 CONTINUE - GO TO 50 - 30 CONTINUE -C CANNOT HAVE A NULL PERTURBATION VECTOR - DO 40 J = 1, NEQ - SPY(J) = 0.0D0 - YP(J) = 1.0D0 - 40 CONTINUE - DELF = DHVNRM(YP,NEQ) - 50 CONTINUE -C - DFDUB = 0.0D0 - LK = MIN(NEQ+1,3) - DO 140 K = 1, LK -C DEFINE PERTURBED VECTOR OF INITIAL VALUES - DO 60 J = 1, NEQ - PV(J) = Y(J) + DELY*(YP(J)/DELF) - 60 CONTINUE - IF (K .EQ. 2) GO TO 80 -C EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED -C VECTOR AND COMPUTE CORRESPONDING DIFFERENCES - CALL DF(A,PV,YP,RPAR,IPAR) - DO 70 J = 1, NEQ - PV(J) = YP(J) - YPRIME(J) - 70 CONTINUE - GO TO 100 - 80 CONTINUE -C USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE -C IN COMPUTING ONE ESTIMATE - CALL DF(A+DA,PV,YP,RPAR,IPAR) - DO 90 J = 1, NEQ - PV(J) = YP(J) - SF(J) - 90 CONTINUE - 100 CONTINUE -C CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE -C AND A LOCAL LIPSCHITZ CONSTANT - FBND = MAX(FBND,DHVNRM(YP,NEQ)) - DELF = DHVNRM(PV,NEQ) -C ...EXIT - IF (DELF .GE. BIG*ABS(DELY)) GO TO 150 - DFDUB = MAX(DFDUB,DELF/ABS(DELY)) -C ......EXIT - IF (K .EQ. LK) GO TO 160 -C CHOOSE NEXT PERTURBATION VECTOR - IF (DELF .EQ. 0.0D0) DELF = 1.0D0 - DO 130 J = 1, NEQ - IF (K .EQ. 2) GO TO 110 - DY = ABS(PV(J)) - IF (DY .EQ. 0.0D0) DY = DELF - GO TO 120 - 110 CONTINUE - DY = Y(J) - IF (DY .EQ. 0.0D0) DY = DELY/RELPER - 120 CONTINUE - IF (SPY(J) .EQ. 0.0D0) SPY(J) = YP(J) - IF (SPY(J) .NE. 0.0D0) DY = SIGN(DY,SPY(J)) - YP(J) = DY - 130 CONTINUE - DELF = DHVNRM(YP,NEQ) - 140 CONTINUE - 150 CONTINUE -C -C PROTECT AGAINST AN OVERFLOW - DFDUB = BIG - 160 CONTINUE -C -C .................................................................. -C -C COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE -C - YDPB = DFDXB + DFDUB*FBND -C -C .................................................................. -C -C DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP -C SIZE IS TO BE BASED. A VALUE IN THE MIDDLE OF THE ERROR -C TOLERANCE RANGE IS SELECTED. -C - TOLMIN = BIG - TOLSUM = 0.0D0 - DO 170 K = 1, NEQ - TOLEXP = LOG10(ETOL(K)) - TOLMIN = MIN(TOLMIN,TOLEXP) - TOLSUM = TOLSUM + TOLEXP - 170 CONTINUE - TOLP = 10.0D0**(0.5D0*(TOLSUM/NEQ + TOLMIN)/(MORDER+1)) -C -C .................................................................. -C -C COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND -C SECOND DERIVATIVE INFORMATION -C -C RESTRICT THE STEP LENGTH TO BE NOT BIGGER -C THAN ABS(B-A). (UNLESS B IS TOO CLOSE -C TO A) - H = ABSDX -C - IF (YDPB .NE. 0.0D0 .OR. FBND .NE. 0.0D0) GO TO 180 -C -C BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND -C DERIVATIVE TERM (YDPB) ARE ZERO - IF (TOLP .LT. 1.0D0) H = ABSDX*TOLP - GO TO 200 - 180 CONTINUE -C - IF (YDPB .NE. 0.0D0) GO TO 190 -C -C ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO - IF (TOLP .LT. FBND*ABSDX) H = TOLP/FBND - GO TO 200 - 190 CONTINUE -C -C SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO - SRYDPB = SQRT(0.5D0*YDPB) - IF (TOLP .LT. SRYDPB*ABSDX) H = TOLP/SRYDPB - 200 CONTINUE -C -C FURTHER RESTRICT THE STEP LENGTH TO BE NOT -C BIGGER THAN 1/DFDUB - IF (H*DFDUB .GT. 1.0D0) H = 1.0D0/DFDUB -C -C FINALLY, RESTRICT THE STEP LENGTH TO BE NOT -C SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF -C A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, -C THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE -C STEP LENGTH. - H = MAX(H,100.0D0*SMALL*ABS(A)) - IF (H .EQ. 0.0D0) H = SMALL*ABS(B) -C -C NOW SET DIRECTION OF INTEGRATION - H = SIGN(H,DX) -C - RETURN - END -*DECK DHVNRM - DOUBLE PRECISION FUNCTION DHVNRM (V, NCOMP) -C***BEGIN PROLOGUE DHVNRM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (HVNRM-S, DHVNRM-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Compute the maximum norm of the vector V(*) of length NCOMP and -C return the result as DHVNRM -C -C***SEE ALSO DDEABM, DDEBDF, DDERKF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891024 Changed routine name from DVNORM to DHVNRM. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DHVNRM -C - INTEGER K, NCOMP - DOUBLE PRECISION V - DIMENSION V(*) -C***FIRST EXECUTABLE STATEMENT DHVNRM - DHVNRM = 0.0D0 - DO 10 K = 1, NCOMP - DHVNRM = MAX(DHVNRM,ABS(V(K))) - 10 CONTINUE - RETURN - END -*DECK J4SAVE - FUNCTION J4SAVE (IWHICH, IVALUE, ISET) -C***BEGIN PROLOGUE J4SAVE -C***SUBSIDIARY -C***PURPOSE Save or recall global variables needed by error -C handling routines. -C***LIBRARY SLATEC (XERROR) -C***TYPE INTEGER (J4SAVE-I) -C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C J4SAVE saves and recalls several global variables needed -C by the library error handling routines. -C -C Description of Parameters -C --Input-- -C IWHICH - Index of item desired. -C = 1 Refers to current error number. -C = 2 Refers to current error control flag. -C = 3 Refers to current unit number to which error -C messages are to be sent. (0 means use standard.) -C = 4 Refers to the maximum number of times any -C message is to be printed (as set by XERMAX). -C = 5 Refers to the total number of units to which -C each error message is to be written. -C = 6 Refers to the 2nd unit for error messages -C = 7 Refers to the 3rd unit for error messages -C = 8 Refers to the 4th unit for error messages -C = 9 Refers to the 5th unit for error messages -C IVALUE - The value to be set for the IWHICH-th parameter, -C if ISET is .TRUE. . -C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE -C given the value, IVALUE. If ISET=.FALSE., the -C IWHICH-th parameter will be unchanged, and IVALUE -C is a dummy parameter. -C --Output-- -C The (old) value of the IWHICH-th parameter will be returned -C in the function value, J4SAVE. -C -C***SEE ALSO XERMSG -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900205 Minor modifications to prologue. (WRB) -C 900402 Added TYPE section. (WRB) -C 910411 Added KEYWORDS section. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE J4SAVE - LOGICAL ISET - INTEGER IPARAM(9) - SAVE IPARAM - DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ - DATA IPARAM(5)/1/ - DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ -C***FIRST EXECUTABLE STATEMENT J4SAVE - J4SAVE = IPARAM(IWHICH) - IF (ISET) IPARAM(IWHICH) = IVALUE - RETURN - END -*DECK XERCNT - SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) -C***BEGIN PROLOGUE XERCNT -C***SUBSIDIARY -C***PURPOSE Allow user control over handling of errors. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERCNT-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C Allows user control over handling of individual errors. -C Just after each message is recorded, but before it is -C processed any further (i.e., before it is printed or -C a decision to abort is made), a call is made to XERCNT. -C If the user has provided his own version of XERCNT, he -C can then override the value of KONTROL used in processing -C this message by redefining its value. -C KONTRL may be set to any value from -2 to 2. -C The meanings for KONTRL are the same as in XSETF, except -C that the value of KONTRL changes only for this message. -C If KONTRL is set to a value outside the range from -2 to 2, -C it will be moved back into that range. -C -C Description of Parameters -C -C --Input-- -C LIBRAR - the library that the routine is in. -C SUBROU - the subroutine that XERMSG is being called from -C MESSG - the first 20 characters of the error message. -C NERR - same as in the call to XERMSG. -C LEVEL - same as in the call to XERMSG. -C KONTRL - the current value of the control flag as set -C by a call to XSETF. -C -C --Output-- -C KONTRL - the new value of KONTRL. If KONTRL is not -C defined, it will remain at its original value. -C This changed value of control affects only -C the current occurrence of the current message. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE -C names, changed routine name from XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERCNT - CHARACTER*(*) LIBRAR, SUBROU, MESSG -C***FIRST EXECUTABLE STATEMENT XERCNT - RETURN - END -*DECK XERHLT - SUBROUTINE XERHLT (MESSG) -C***BEGIN PROLOGUE XERHLT -C***SUBSIDIARY -C***PURPOSE Abort program execution and print error message. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERHLT-A) -C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C ***Note*** machine dependent routine -C XERHLT aborts the execution of the program. -C The error message causing the abort is given in the calling -C sequence, in case one needs it for printing on a dayfile, -C for example. -C -C Description of Parameters -C MESSG is as in XERMSG. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to delete length of character -C and changed routine name from XERABT to XERHLT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERHLT - CHARACTER*(*) MESSG -C***FIRST EXECUTABLE STATEMENT XERHLT - STOP - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/ddebdf.f calculix-ccx-2.3/ccx_2.1/src/ddebdf.f --- calculix-ccx-2.1/ccx_2.1/src/ddebdf.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ddebdf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,3308 +0,0 @@ -*DECK DDEBDF - SUBROUTINE DDEBDF (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + RWORK, LRW, IWORK, LIW, RPAR, IPAR, DJAC) -C***BEGIN PROLOGUE DDEBDF -C***PURPOSE Solve an initial value problem in ordinary differential -C equations using backward differentiation formulas. It is -C intended primarily for stiff problems. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A2 -C***TYPE DOUBLE PRECISION (DEBDF-S, DDEBDF-D) -C***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DEPAC, -C INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, STIFF -C***AUTHOR Shampine, L. F., (SNLA) -C Watts, H. A., (SNLA) -C***DESCRIPTION -C -C This is the backward differentiation code in the package of -C differential equation solvers DEPAC, consisting of the codes -C DDERKF, DDEABM, and DDEBDF. Design of the package was by -C L. F. Shampine and H. A. Watts. It is documented in -C SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE -C Solvers. -C DDEBDF is a driver for a modification of the code LSODE written by -C A. C. Hindmarsh -C Lawrence Livermore Laboratory -C Livermore, California 94550 -C -C ********************************************************************** -C ** DEPAC PACKAGE OVERVIEW ** -C ********************************************************************** -C -C You have a choice of three differential equation solvers from -C DEPAC. The following brief descriptions are meant to aid you -C in choosing the most appropriate code for your problem. -C -C DDERKF is a fifth order Runge-Kutta code. It is the simplest of -C the three choices, both algorithmically and in the use of the -C code. DDERKF is primarily designed to solve non-stiff and mild- -C ly stiff differential equations when derivative evaluations are -C not expensive. It should generally not be used to get high -C accuracy results nor answers at a great many specific points. -C Because DDERKF has very low overhead costs, it will usually -C result in the least expensive integration when solving -C problems requiring a modest amount of accuracy and having -C equations that are not costly to evaluate. DDERKF attempts to -C discover when it is not suitable for the task posed. -C -C DDEABM is a variable order (one through twelve) Adams code. Its -C complexity lies somewhere between that of DDERKF and DDEBDF. -C DDEABM is primarily designed to solve non-stiff and mildly -C stiff differential equations when derivative evaluations are -C expensive, high accuracy results are needed or answers at -C many specific points are required. DDEABM attempts to discover -C when it is not suitable for the task posed. -C -C DDEBDF is a variable order (one through five) backward -C differentiation formula code. It is the most complicated of -C the three choices. DDEBDF is primarily designed to solve stiff -C differential equations at crude to moderate tolerances. -C If the problem is very stiff at all, DDERKF and DDEABM will be -C quite inefficient compared to DDEBDF. However, DDEBDF will be -C inefficient compared to DDERKF and DDEABM on non-stiff problems -C because it uses much more storage, has a much larger overhead, -C and the low order formulas will not give high accuracies -C efficiently. -C -C The concept of stiffness cannot be described in a few words. -C If you do not know the problem to be stiff, try either DDERKF -C or DDEABM. Both of these codes will inform you of stiffness -C when the cost of solving such problems becomes important. -C -C ********************************************************************** -C ** ABSTRACT ** -C ********************************************************************** -C -C Subroutine DDEBDF uses the backward differentiation formulas of -C orders one through five to integrate a system of NEQ first order -C ordinary differential equations of the form -C DU/DX = DF(X,U) -C when the vector Y(*) of initial values for U(*) at X=T is given. -C The subroutine integrates from T to TOUT. It is easy to continue the -C integration to get results at additional TOUT. This is the interval -C mode of operation. It is also easy for the routine to return with -C the solution at each intermediate step on the way to TOUT. This is -C the intermediate-output mode of operation. -C -C ********************************************************************** -C * Description of The Arguments To DDEBDF (An Overview) * -C ********************************************************************** -C -C The Parameters are: -C -C DF -- This is the name of a subroutine which you provide to -C define the differential equations. -C -C NEQ -- This is the number of (first order) differential -C equations to be integrated. -C -C T -- This is a DOUBLE PRECISION value of the independent -C variable. -C -C Y(*) -- This DOUBLE PRECISION array contains the solution -C components at T. -C -C TOUT -- This is a DOUBLE PRECISION point at which a solution is -C desired. -C -C INFO(*) -- The basic task of the code is to integrate the -C differential equations from T to TOUT and return an -C answer at TOUT. INFO(*) is an INTEGER array which is used -C to communicate exactly how you want this task to be -C carried out. -C -C RTOL, ATOL -- These DOUBLE PRECISION quantities -C represent relative and absolute error tolerances which you -C provide to indicate how accurately you wish the solution -C to be computed. You may choose them to be both scalars -C or else both vectors. -C -C IDID -- This scalar quantity is an indicator reporting what -C the code did. You must monitor this INTEGER variable to -C decide what action to take next. -C -C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of -C length LRW which provides the code with needed storage -C space. -C -C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW -C which provides the code with needed storage space and an -C across call flag. -C -C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and the DF subroutine (and the DJAC -C subroutine). -C -C DJAC -- This is the name of a subroutine which you may choose to -C provide for defining the Jacobian matrix of partial -C derivatives DF/DU. -C -C Quantities which are used as input items are -C NEQ, T, Y(*), TOUT, INFO(*), -C RTOL, ATOL, RWORK(1), LRW, -C IWORK(1), IWORK(2), and LIW. -C -C Quantities which may be altered by the code are -C T, Y(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) and IWORK(*). -C -C ********************************************************************** -C * INPUT -- What To Do On The First Call To DDEBDF * -C ********************************************************************** -C -C The first call of the code is defined to be the start of each new -C problem. Read through the descriptions of all the following items, -C provide sufficient storage space for designated arrays, set -C appropriate variables for the initialization of the problem, and -C give information about how you want the problem to be solved. -C -C -C DF -- Provide a subroutine of the form -C DF(X,U,UPRIME,RPAR,IPAR) -C to define the system of first order differential equations -C which is to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=DF(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine DF must not alter X or U(*). You must declare -C the name DF in an external statement in your program that -C calls DDEBDF. You must dimension U and UPRIME in DF. -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and subroutine DF. They are not used or -C altered by DDEBDF. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them in -C your calling program and in DF as arrays of appropriate -C length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C You must use a program variable for T because the code -C changes its value. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y at -C least NEQ in your calling program. -C -C TOUT -- Set it to the first point at which a solution is desired. -C You can take TOUT = T, in which case the code -C will evaluate the derivative of the solution at T and -C return. Integration either forward in T (TOUT .GT. T) -C or backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative following -C each intermediate step (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not -C step past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -C -C For some problems it may not be permissible to integrate -C past a point TSTOP because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP. When you have declared a TSTOP point (see INFO(4) -C and RWORK(1)), you have told the code not to integrate -C past TSTOP. In this case any TOUT beyond TSTOP is invalid -C input. -C -C INFO(*) -- Use the INFO array to give the code more details about -C how you want your problem solved. This array should be -C dimensioned of length 15 to accommodate other members of -C DEPAC or possible future extensions, though DDEBDF uses -C only the first six entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as YES ,i.e. setting all entries of INFO to 0. -C -C INFO(1) -- This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new problem. -C -C **** Is this the first call for this problem ... -C YES -- Set INFO(1) = 0 -C NO -- Not applicable here. -C See below for continuation calls. **** -C -C INFO(2) -- How much accuracy you want of your solution -C is specified by the error tolerances RTOL and ATOL. -C The simplest use is to take them both to be scalars. -C To obtain more flexibility, they can both be vectors. -C The code must be told your choice. -C -C **** Are both error tolerances RTOL, ATOL scalars ... -C YES -- Set INFO(2) = 0 -C and input scalars for both RTOL and ATOL -C NO -- Set INFO(2) = 1 -C and input arrays for both RTOL and ATOL **** -C -C INFO(3) -- The code integrates from T in the direction -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode) or -C TOUT, whichever comes first. This is a good way to -C proceed if you want to see the behavior of the solution. -C If you must have solutions at a great many specific -C TOUT points, this code will compute them efficiently. -C -C **** Do you want the solution only at -C TOUT (and NOT at the next intermediate step) ... -C YES -- Set INFO(3) = 0 -C NO -- Set INFO(3) = 1 **** -C -C INFO(4) -- To handle solutions at a great many specific -C values TOUT efficiently, this code may integrate past -C TOUT and interpolate to obtain the result at TOUT. -C Sometimes it is not possible to integrate beyond some -C point TSTOP because the equation changes there or it is -C not defined past TSTOP. Then you must tell the code -C not to go past. -C -C **** Can the integration be carried out without any -C restrictions on the independent variable T ... -C YES -- Set INFO(4)=0 -C NO -- Set INFO(4)=1 -C and define the stopping point TSTOP by -C setting RWORK(1)=TSTOP **** -C -C INFO(5) -- To solve stiff problems it is necessary to use the -C Jacobian matrix of partial derivatives of the system -C of differential equations. If you do not provide a -C subroutine to evaluate it analytically (see the -C description of the item DJAC in the call list), it will -C be approximated by numerical differencing in this code. -C Although it is less trouble for you to have the code -C compute partial derivatives by numerical differencing, -C the solution will be more reliable if you provide the -C derivatives via DJAC. Sometimes numerical differencing -C is cheaper than evaluating derivatives in DJAC and -C sometimes it is not - this depends on your problem. -C -C If your problem is linear, i.e. has the form -C DU/DX = DF(X,U) = J(X)*U + G(X) for some matrix J(X) -C and vector G(X), the Jacobian matrix DF/DU = J(X). -C Since you must provide a subroutine to evaluate DF(X,U) -C analytically, it is little extra trouble to provide -C subroutine DJAC for evaluating J(X) analytically. -C Furthermore, in such cases, numerical differencing is -C much more expensive than analytic evaluation. -C -C **** Do you want the code to evaluate the partial -C derivatives automatically by numerical differences ... -C YES -- Set INFO(5)=0 -C NO -- Set INFO(5)=1 -C and provide subroutine DJAC for evaluating the -C Jacobian matrix **** -C -C INFO(6) -- DDEBDF will perform much better if the Jacobian -C matrix is banded and the code is told this. In this -C case, the storage needed will be greatly reduced, -C numerical differencing will be performed more cheaply, -C and a number of important algorithms will execute much -C faster. The differential equation is said to have -C half-bandwidths ML (lower) and MU (upper) if equation I -C involves only unknowns Y(J) with -C I-ML .LE. J .LE. I+MU -C for all I=1,2,...,NEQ. Thus, ML and MU are the widths -C of the lower and upper parts of the band, respectively, -C with the main diagonal being excluded. If you do not -C indicate that the equation has a banded Jacobian, -C the code works with a full matrix of NEQ**2 elements -C (stored in the conventional way). Computations with -C banded matrices cost less time and storage than with -C full matrices if 2*ML+MU .LT. NEQ. If you tell the -C code that the Jacobian matrix has a banded structure and -C you want to provide subroutine DJAC to compute the -C partial derivatives, then you must be careful to store -C the elements of the Jacobian matrix in the special form -C indicated in the description of DJAC. -C -C **** Do you want to solve the problem using a full -C (dense) Jacobian matrix (and not a special banded -C structure) ... -C YES -- Set INFO(6)=0 -C NO -- Set INFO(6)=1 -C and provide the lower (ML) and upper (MU) -C bandwidths by setting -C IWORK(1)=ML -C IWORK(2)=MU **** -C -C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you want -C the solution to be computed. They must be defined as -C program variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -C Both RTOL and ATOL are vectors. (INFO(2)=1) -C In either case all components must be non-negative. -C -C The tolerances are used by the code in a local error test -C at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C for each vector component. -C (More specifically, a root-mean-square norm is used to -C measure the size of vectors, and the error test uses the -C magnitude of the solution at the beginning of the step.) -C -C The true (global) error is the difference between the true -C solution of the initial value problem and the computed -C approximation. Practically all present day codes, -C including this one, control the local error at each step -C and do not even attempt to control the global error -C directly. Roughly speaking, they produce a solution Y(T) -C which satisfies the differential equations with a -C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , -C and, almost always, R(T) is bounded by the error -C tolerances. Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more accurate -C solution if you reduce the tolerances and integrate again. -C By comparing two such solutions you can get a fairly -C reliable idea of the true error in the solution at the -C bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C that component. Setting RTOL=0. results in a pure abso- -C lute error test on that component. A mixed test with non- -C zero RTOL and ATOL corresponds roughly to a relative error -C test when the solution component is much bigger than ATOL -C and to an absolute error test when the solution component -C is smaller than the threshold ATOL. -C -C Proper selection of the absolute error control parameters -C ATOL requires you to have some idea of the scale of the -C solution components. To acquire this information may mean -C that you will have to solve the problem more than once. In -C the absence of scale information, you should ask for some -C relative accuracy in all the components (by setting RTOL -C values non-zero) and perhaps impose extremely small -C absolute error tolerances to protect against the danger of -C a solution component becoming zero. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C -C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length -C LRW in your calling program. -C -C RWORK(1) -- If you have set INFO(4)=0, you can ignore this -C optional input parameter. Otherwise you must define a -C stopping point TSTOP by setting RWORK(1) = TSTOP. -C (For some problems it may not be permissible to integrate -C past a point TSTOP because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP.) -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have -C LRW .GE. 250+10*NEQ+NEQ**2 -C for the full (dense) Jacobian case (when INFO(6)=0), or -C LRW .GE. 250+10*NEQ+(2*ML+MU+1)*NEQ -C for the banded Jacobian case (when INFO(6)=1). -C -C IWORK(*) -- Dimension this INTEGER work array of length LIW in -C your calling program. -C -C IWORK(1), IWORK(2) -- If you have set INFO(6)=0, you can ignore -C these optional input parameters. Otherwise you must define -C the half-bandwidths ML (lower) and MU (upper) of the -C Jacobian matrix by setting IWORK(1) = ML and -C IWORK(2) = MU. (The code will work with a full matrix -C of NEQ**2 elements unless it is told that the problem has -C a banded Jacobian, in which case the code will work with -C a matrix containing at most (2*ML+MU+1)*NEQ elements.) -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 56+NEQ. -C -C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and -C INTEGER type, respectively. You can use them for -C communication between your program that calls DDEBDF and -C the DF subroutine (and the DJAC subroutine). They are not -C used or altered by DDEBDF. If you do not need RPAR or -C IPAR, ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them in -C your calling program and in DF (and in DJAC) as arrays of -C appropriate length. -C -C DJAC -- If you have set INFO(5)=0, you can ignore this parameter -C by treating it as a dummy argument. (For some compilers -C you may have to write a dummy subroutine named DJAC in -C order to avoid problems associated with missing external -C routine names.) Otherwise, you must provide a subroutine -C of the form -C DJAC(X,U,PD,NROWPD,RPAR,IPAR) -C to define the Jacobian matrix of partial derivatives DF/DU -C of the system of differential equations DU/DX = DF(X,U). -C For the given values of X and the vector -C U(*)=(U(1),U(2),...,U(NEQ)), the subroutine must evaluate -C the non-zero partial derivatives DF(I)/DU(J) for each -C differential equation I=1,...,NEQ and each solution -C component J=1,...,NEQ , and store these values in the -C matrix PD. The elements of PD are set to zero before each -C call to DJAC so only non-zero elements need to be defined. -C -C Subroutine DJAC must not alter X, U(*), or NROWPD. You -C must declare the name DJAC in an external statement in -C your program that calls DDEBDF. NROWPD is the row -C dimension of the PD matrix and is assigned by the code. -C Therefore you must dimension PD in DJAC according to -C DIMENSION PD(NROWPD,1) -C You must also dimension U in DJAC. -C -C The way you must store the elements into the PD matrix -C depends on the structure of the Jacobian which you -C indicated by INFO(6). -C *** INFO(6)=0 -- Full (Dense) Jacobian *** -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C PD(I,J) = * DF(I)/DU(J) * -C *** INFO(6)=1 -- Banded Jacobian with ML Lower and MU -C Upper Diagonal Bands (refer to INFO(6) description of -C ML and MU) *** -C When you evaluate the (non-zero) partial derivative -C of equation I with respect to variable J, you must -C store it in PD according to -C IROW = I - J + ML + MU + 1 -C PD(IROW,J) = * DF(I)/DU(J) * -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and your Jacobian subroutine DJAC. They -C are not altered by DDEBDF. If you do not need RPAR or -C IPAR, ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them -C in your calling program and in DJAC as arrays of -C appropriate length. -C -C ********************************************************************** -C * OUTPUT -- After any return from DDEBDF * -C ********************************************************************** -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C You may also be interested in the approximate derivative -C of the solution at T. It is contained in -C RWORK(21),...,RWORK(20+NEQ). -C -C IDID -- Reports what the code did -C -C *** Task Completed *** -C Reported by positive values of IDID -C -C IDID = 1 -- A step was successfully taken in the -C intermediate-output mode. The code has not -C yet reached TOUT. -C -C IDID = 2 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping exactly to TOUT. -C -C IDID = 3 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping past TOUT. -C Y(*) is obtained by interpolation. -C -C *** Task Interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (500 steps attempted) -C -C IDID = -2 -- The error tolerances are too stringent. -C -C IDID = -3 -- The local error test cannot be satisfied -C because you specified a zero component in ATOL -C and the corresponding computed solution -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -4,-5 -- Not applicable for this code but used -C by other members of DEPAC. -C -C IDID = -6 -- DDEBDF had repeated convergence test failures -C on the last attempted step. -C -C IDID = -7 -- DDEBDF had repeated error test failures on -C the last attempted step. -C -C IDID = -8,..,-32 -- Not applicable for this code but -C used by other members of DEPAC or possible -C future extensions. -C -C *** Task Terminated *** -C Reported by the value of IDID=-33 -C -C IDID = -33 -- The code has encountered trouble from which -C it cannot recover. A message is printed -C explaining the trouble and control is returned -C to the calling program. For example, this -C occurs when invalid input is detected. -C -C RTOL, ATOL -- These quantities remain unchanged except when -C IDID = -2. In this case, the error tolerances have been -C increased by the code to values which are estimated to be -C appropriate for continuing the integration. However, the -C reported solution at T was obtained using the input values -C of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(11)--which contains the step size H to be -C attempted on the next step. -C -C RWORK(12)--If the tolerances have been increased by the -C code (IDID = -2) , they were multiplied by the -C value in RWORK(12). -C -C RWORK(13)--which contains the current value of the -C independent variable, i.e. the farthest point -C integration has reached. This will be -C different from T only when interpolation has -C been performed (IDID=3). -C -C RWORK(20+I)--which contains the approximate derivative -C of the solution component Y(I). In DDEBDF, it -C is never obtained by calling subroutine DF to -C evaluate the differential equation using T and -C Y(*), except at the initial point of -C integration. -C -C ********************************************************************** -C ** INPUT -- What To Do To Continue The Integration ** -C ** (calls after the first) ** -C ********************************************************************** -C -C This code is organized so that subsequent calls to continue the -C integration involve little (if any) additional effort on your -C part. You must monitor the IDID parameter in order to determine -C what to do next. -C -C Recalling that the principal task of the code is to integrate -C from T to TOUT (the interval mode), usually all you will need -C to do is specify a new TOUT upon reaching the current TOUT. -C -C Do not alter any quantity not specifically permitted below, -C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or -C the differential equation in subroutine DF. Any such alteration -C constitutes a new problem and must be treated as such, i.e. -C you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)) but you can change the size of the entries of -C RTOL, ATOL. Increasing a tolerance makes the equation easier -C to integrate. Decreasing a tolerance will make the equation -C harder to integrate and should generally be avoided. -C -C You can switch from the intermediate-output mode to the -C interval mode (INFO(3)) or vice versa at any time. -C -C If it has been necessary to prevent the integration from going -C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the -C code will not integrate to any TOUT beyond the currently -C specified TSTOP. Once TSTOP has been reached you must change -C the value of TSTOP or set INFO(4)=0. You may change INFO(4) -C or TSTOP at any time but you must supply the value of TSTOP in -C RWORK(1) whenever you set INFO(4)=1. -C -C Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) -C unless you are going to restart the code. -C -C The parameter INFO(1) is used by the code to indicate the -C beginning of a new problem and to indicate whether integration -C is to be continued. You must input the value INFO(1) = 0 -C when starting a new problem. You must input the value -C INFO(1) = 1 if you wish to continue after an interrupted task. -C Do not set INFO(1) = 0 on a continuation call unless you -C want the code to restart at the current T. -C -C *** Following a Completed Task *** -C If -C IDID = 1, call the code again to continue the integration -C another step in the direction of TOUT. -C -C IDID = 2 or 3, define a new TOUT and call the code again. -C TOUT must be different from T. You cannot change -C the direction of integration without restarting. -C -C *** Following an Interrupted Task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and reset INFO(1) = 1 -C If -C IDID = -1, the code has attempted 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, the error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code again. -C -C IDID = -3, a solution component is zero and you set the -C corresponding component of ATOL to zero. If you -C are sure you want to continue, you must first -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4,-5 --- cannot occur with this code but used -C by other members of DEPAC. -C -C IDID = -6, repeated convergence test failures occurred -C on the last attempted step in DDEBDF. An inaccu- -C rate Jacobian may be the problem. If you are -C absolutely certain you want to continue, restart -C the integration at the current T by setting -C INFO(1)=0 and call the code again. -C -C IDID = -7, repeated error test failures occurred on the -C last attempted step in DDEBDF. A singularity in -C the solution may be present. You should re- -C examine the problem being solved. If you are -C absolutely certain you want to continue, restart -C the integration at the current T by setting -C INFO(1)=0 and call the code again. -C -C IDID = -8,..,-32 --- cannot occur with this code but -C used by other members of DDEPAC or possible future -C extensions. -C -C *** Following a Terminated Task *** -C If -C IDID = -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C ********************************************************************** -C -C ***** Warning ***** -C -C If DDEBDF is to be used in an overlay situation, you must save and -C restore certain items used internally by DDEBDF (values in the -C common block DDEBD1). This can be accomplished as follows. -C -C To save the necessary values upon return from DDEBDF, simply call -C DSVCO(RWORK(22+NEQ),IWORK(21+NEQ)). -C -C To restore the necessary values before the next call to DDEBDF, -C simply call DRSCO(RWORK(22+NEQ),IWORK(21+NEQ)). -C -C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user -C oriented package of ODE solvers, Report SAND79-2374, -C Sandia Laboratories, 1979. -C***ROUTINES CALLED DLSOD, XERMSG -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, make Prologue comments -C consistent with DEBDF. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DDEBDF - INTEGER IACOR, IBAND, IBEGIN, ICOMI, ICOMR, IDELSN, IDID, IER, - 1 IEWT, IINOUT, IINTEG, IJAC, ILRW, INFO, INIT, - 2 IOWNS, IPAR, IQUIT, ISAVF, ITOL, ITSTAR, ITSTOP, IWM, - 3 IWORK, IYH, IYPOUT, JSTART, KFLAG, KSTEPS, L, LIW, LRW, - 4 MAXORD, METH, MITER, ML, MU, N, NEQ, NFE, NJE, NQ, NQU, - 5 NST - DOUBLE PRECISION ATOL, EL0, H, HMIN, HMXI, HU, ROWNS, RPAR, - 1 RTOL, RWORK, T, TN, TOLD, TOUT, UROUND, Y - LOGICAL INTOUT - CHARACTER*8 XERN1, XERN2 - CHARACTER*16 XERN3 -C - DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), - 1 RPAR(*),IPAR(*) -C - COMMON /DDEBD1/ TOLD,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, - 1 IQUIT,INIT,IYH,IEWT,IACOR,ISAVF,IWM,KSTEPS,IBEGIN, - 2 ITOL,IINTEG,ITSTOP,IJAC,IBAND,IOWNS(6),IER,JSTART, - 3 KFLAG,L,METH,MITER,MAXORD,N,NQ,NST,NFE,NJE,NQU -C - EXTERNAL DF, DJAC -C -C CHECK FOR AN APPARENT INFINITE LOOP -C -C***FIRST EXECUTABLE STATEMENT DDEBDF - IF (INFO(1) .EQ. 0) IWORK(LIW) = 0 -C - IF (IWORK(LIW).GE. 5) THEN - IF (T .EQ. RWORK(21+NEQ)) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDEBDF', - * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // - * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // - * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // - * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // - * 'CODE, PARTICULARLY INFO(1).', 13, 2) - RETURN - ENDIF - ENDIF -C - IDID = 0 -C -C CHECK VALIDITY OF INFO PARAMETERS -C - IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(1) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(1) MUST BE SET TO 0 ' // - * 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // - * 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // - * 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE ' // - * 'CODE WITH INFO(1) = ' // XERN1, 3, 1) - IDID = -33 - ENDIF -C - IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(2) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(2) MUST BE 0 OR 1 ' // - * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // - * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // - * XERN1, 4, 1) - IDID = -33 - ENDIF -C - IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(3) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(3) MUST BE 0 OR 1 ' // - * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // - * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(3) = ' // XERN1, 5, 1) - IDID = -33 - ENDIF -C - IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(4) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(4) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER OR NOT THE INTEGRATION INTERVAL IS ' // - * 'TO BE RESTRICTED BY A POINT TSTOP. YOU HAVE CALLED ' // - * 'THE CODE WITH INFO(4) = ' // XERN1, 14, 1) - IDID = -33 - ENDIF -C - IF (INFO(5) .NE. 0 .AND. INFO(5) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(5) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(5) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER THE CODE IS TOLD TO FORM THE ' // - * 'JACOBIAN MATRIX BY NUMERICAL DIFFERENCING OR YOU ' // - * 'PROVIDE A SUBROUTINE TO EVALUATE IT ANALYTICALLY. ' // - * 'YOU HAVE CALLED THE CODE WITH INFO(5) = ' // XERN1, 15, 1) - IDID = -33 - ENDIF -C - IF (INFO(6) .NE. 0 .AND. INFO(6) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(6) - CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(6) MUST BE 0 OR 1 ' // - * 'INDICATING WHETHER THE CODE IS TOLD TO TREAT THE ' // - * 'JACOBIAN AS A FULL (DENSE) MATRIX OR AS HAVING A ' // - * 'SPECIAL BANDED STRUCTURE. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(6) = ' // XERN1, 16, 1) - IDID = -33 - ENDIF -C - ILRW = NEQ - IF (INFO(6) .NE. 0) THEN -C -C CHECK BANDWIDTH PARAMETERS -C - ML = IWORK(1) - MU = IWORK(2) - ILRW = 2*ML + MU + 1 -C - IF (ML.LT.0 .OR. ML.GE.NEQ .OR. MU.LT.0 .OR. MU.GE.NEQ) THEN - WRITE (XERN1, '(I8)') ML - WRITE (XERN2, '(I8)') MU - CALL XERMSG ('SLATEC', 'DDEBDF', 'YOU HAVE SET INFO(6) ' // - * '= 1, TELLING THE CODE THAT THE JACOBIAN MATRIX HAS ' // - * 'A SPECIAL BANDED STRUCTURE. HOWEVER, THE LOWER ' // - * '(UPPER) BANDWIDTHS ML (MU) VIOLATE THE CONSTRAINTS ' // - * 'ML,MU .GE. 0 AND ML,MU .LT. NEQ. YOU HAVE CALLED ' // - * 'THE CODE WITH ML = ' // XERN1 // ' AND MU = ' // XERN2, - * 17, 1) - IDID = -33 - ENDIF - ENDIF -C -C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION -C - IF (LRW .LT. 250 + (10 + ILRW)*NEQ) THEN - WRITE (XERN1, '(I8)') LRW - IF (INFO(6) .EQ. 0) THEN - CALL XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY RWORK ' // - * 'MUST BE AT LEAST 250 + 10*NEQ + NEQ*NEQ.$$' // - * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) - ELSE - CALL XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY RWORK ' // - * 'MUST BE AT LEAST 250 + 10*NEQ + (2*ML+MU+1)*NEQ.$$' // - * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 18, 1) - ENDIF - IDID = -33 - ENDIF -C - IF (LIW .LT. 56 + NEQ) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY IWORK ' // - * 'BE AT LEAST 56 + NEQ. YOU HAVE CALLED THE CODE WITH ' // - * 'LIW = ' // XERN1, 2, 1) - IDID = -33 - ENDIF -C -C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK -C ARRAY AND RESTORE COMMON BLOCK DATA -C - ICOMI = 21 + NEQ - IINOUT = ICOMI + 33 -C - IYPOUT = 21 - ITSTAR = 21 + NEQ - ICOMR = 22 + NEQ -C - IF (INFO(1) .NE. 0) INTOUT = IWORK(IINOUT) .NE. (-1) -C CALL DRSCO(RWORK(ICOMR),IWORK(ICOMI)) -C - IYH = ICOMR + 218 - IEWT = IYH + 6*NEQ - ISAVF = IEWT + NEQ - IACOR = ISAVF + NEQ - IWM = IACOR + NEQ - IDELSN = IWM + 2 + ILRW*NEQ -C - IBEGIN = INFO(1) - ITOL = INFO(2) - IINTEG = INFO(3) - ITSTOP = INFO(4) - IJAC = INFO(5) - IBAND = INFO(6) - RWORK(ITSTAR) = T -C - CALL DLSOD(DF,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,RWORK(IYPOUT), - 1 RWORK(IYH),RWORK(IYH),RWORK(IEWT),RWORK(ISAVF), - 2 RWORK(IACOR),RWORK(IWM),IWORK(1),DJAC,INTOUT, - 3 RWORK(1),RWORK(12),RWORK(IDELSN),RPAR,IPAR) -C - IWORK(IINOUT) = -1 - IF (INTOUT) IWORK(IINOUT) = 1 -C - IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 - IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 -C CALL DSVCO(RWORK(ICOMR),IWORK(ICOMI)) - RWORK(11) = H - RWORK(13) = TN - INFO(1) = IBEGIN -C - RETURN - END -*DECK DLSOD - SUBROUTINE DLSOD (DF, NEQ, T, Y, TOUT, RTOL, ATOL, IDID, YPOUT, - + YH, YH1, EWT, SAVF, ACOR, WM, IWM, DJAC, INTOUT, TSTOP, TOLFAC, - + DELSGN, RPAR, IPAR) -C***BEGIN PROLOGUE DLSOD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (LSOD-S, DLSOD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DDEBDF merely allocates storage for DLSOD to relieve the user of -C the inconvenience of a long call list. Consequently DLSOD is used -C as described in the comments for DDEBDF . -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED D1MACH, DHSTRT, DINTYD, DSTOD, DVNRMS, XERMSG -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C***END PROLOGUE DLSOD -C - INTEGER IBAND, IBEGIN, IDID, IER, IINTEG, IJAC, INIT, INTFLG, - 1 IOWNS, IPAR, IQUIT, ITOL, ITSTOP, IWM, JSTART, K, KFLAG, - 2 KSTEPS, L, LACOR, LDUM, LEWT, LSAVF, LTOL, LWM, LYH, MAXNUM, - 3 MAXORD, METH, MITER, N, NATOLP, NEQ, NFE, NJE, NQ, NQU, - 4 NRTOLP, NST - DOUBLE PRECISION ABSDEL, ACOR, ATOL, BIG, D1MACH, DEL, - 1 DELSGN, DT, DVNRMS, EL0, EWT, - 2 H, HA, HMIN, HMXI, HU, ROWNS, RPAR, RTOL, SAVF, T, TOL, - 3 TOLD, TOLFAC, TOUT, TSTOP, U, WM, X, Y, YH, YH1, YPOUT - LOGICAL INTOUT - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 -C - DIMENSION Y(*),YPOUT(*),YH(NEQ,6),YH1(*),EWT(*),SAVF(*), - 1 ACOR(*),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*) -C -C - COMMON /DDEBD1/ TOLD,ROWNS(210),EL0,H,HMIN,HMXI,HU,X,U,IQUIT,INIT, - 1 LYH,LEWT,LACOR,LSAVF,LWM,KSTEPS,IBEGIN,ITOL, - 2 IINTEG,ITSTOP,IJAC,IBAND,IOWNS(6),IER,JSTART, - 3 KFLAG,LDUM,METH,MITER,MAXORD,N,NQ,NST,NFE,NJE,NQU -C - EXTERNAL DF, DJAC -C -C .................................................................. -C -C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE -C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE -C COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE -C EXCESSIVE WORK. - SAVE MAXNUM -C - DATA MAXNUM /500/ -C -C .................................................................. -C -C***FIRST EXECUTABLE STATEMENT DLSOD - IF (IBEGIN .EQ. 0) THEN -C -C ON THE FIRST CALL , PERFORM INITIALIZATION -- -C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE -C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE -C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. -C - U = D1MACH(4) -C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER - WM(1) = SQRT(U) -C -- SET TERMINATION FLAG - IQUIT = 0 -C -- SET INITIALIZATION INDICATOR - INIT = 0 -C -- SET COUNTER FOR ATTEMPTED STEPS - KSTEPS = 0 -C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT - INTOUT = .FALSE. -C -- SET START INDICATOR FOR DSTOD CODE - JSTART = 0 -C -- SET BDF METHOD INDICATOR - METH = 2 -C -- SET MAXIMUM ORDER FOR BDF METHOD - MAXORD = 5 -C -- SET ITERATION MATRIX INDICATOR -C - IF (IJAC .EQ. 0 .AND. IBAND .EQ. 0) MITER = 2 - IF (IJAC .EQ. 1 .AND. IBAND .EQ. 0) MITER = 1 - IF (IJAC .EQ. 0 .AND. IBAND .EQ. 1) MITER = 5 - IF (IJAC .EQ. 1 .AND. IBAND .EQ. 1) MITER = 4 -C -C -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK - N = NEQ - NST = 0 - NJE = 0 - HMXI = 0.0D0 - NQ = 1 - H = 1.0D0 -C -- RESET IBEGIN FOR SUBSEQUENT CALLS - IBEGIN = 1 - ENDIF -C -C .................................................................. -C -C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY -C - IF (NEQ .LT. 1) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, THE NUMBER OF EQUATIONS MUST BE A ' // - * 'POSITIVE INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ' // - * XERN1, 6, 1) - IDID=-33 - ENDIF -C - NRTOLP = 0 - NATOLP = 0 - DO 60 K = 1, NEQ - IF (NRTOLP .LE. 0) THEN - IF (RTOL(K) .LT. 0.) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') RTOL(K) - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, THE RELATIVE ERROR TOLERANCES MUST ' // - * 'BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH ' // - * 'RTOL(' // XERN1 // ') = ' // XERN3 // '$$IN THE ' // - * 'CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' // - * 'CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) - IDID = -33 - IF (NATOLP .GT. 0) GO TO 70 - NRTOLP = 1 - ELSEIF (NATOLP .GT. 0) THEN - GO TO 50 - ENDIF - ENDIF -C - IF (ATOL(K) .LT. 0.) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') ATOL(K) - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, THE ABSOLUTE ERROR ' // - * 'TOLERANCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED ' // - * 'THE CODE WITH ATOL(' // XERN1 // ') = ' // XERN3 // - * '$$IN THE CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' - * // 'CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) - IDID=-33 - IF (NRTOLP .GT. 0) GO TO 70 - NATOLP=1 - ENDIF - 50 IF (ITOL .EQ. 0) GO TO 70 - 60 CONTINUE -C - 70 IF (ITSTOP .EQ. 1) THEN - IF (SIGN(1.0D0,TOUT-T) .NE. SIGN(1.0D0,TSTOP-T) .OR. - 1 ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - WRITE (XERN4, '(1PE15.6)') TSTOP - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, YOU HAVE CALLED THE ' // - * 'CODE WITH TOUT = ' // XERN3 // '$$BUT YOU HAVE ' // - * 'ALSO TOLD THE CODE NOT TO INTEGRATE PAST THE POINT ' // - * 'TSTOP = ' // XERN4 // ' BY SETTING INFO(4) = 1.$$' // - * 'THESE INSTRUCTIONS CONFLICT.', 14, 1) - IDID=-33 - ENDIF - ENDIF -C -C CHECK SOME CONTINUATION POSSIBILITIES -C - IF (INIT .NE. 0) THEN - IF (T .EQ. TOUT) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, YOU HAVE CALLED THE CODE WITH T = TOUT = ' // - * XERN3 // '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', - * 9, 1) - IDID=-33 - ENDIF -C - IF (T .NE. TOLD) THEN - WRITE (XERN3, '(1PE15.6)') TOLD - WRITE (XERN4, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, YOU HAVE CHANGED THE VALUE OF T FROM ' // - * XERN3 // ' TO ' // XERN4 // - * ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) - IDID=-33 - ENDIF -C - IF (INIT .NE. 1) THEN - IF (DELSGN*(TOUT-T) .LT. 0.0D0) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, BY CALLING THE CODE WITH TOUT = ' // - * XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // - * 'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' // - * 'WITHOUT RESTARTING.', 11, 1) - IDID=-33 - ENDIF - ENDIF - ENDIF -C - IF (IDID .EQ. (-33)) THEN - IF (IQUIT .NE. (-33)) THEN -C INVALID INPUT DETECTED - IQUIT=-33 - IBEGIN=-1 - ELSE - CALL XERMSG ('SLATEC', 'DLSOD', - * 'IN DDEBDF, INVALID INPUT WAS DETECTED ON ' // - * 'SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE TO PROCEED ' // - * 'BECAUSE YOU HAVE NOT CORRECTED THE PROBLEM, ' // - * 'SO EXECUTION IS BEING TERMINATED.', 12, 2) - ENDIF - RETURN - ENDIF -C -C ............................................................... -C -C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED -C AS ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS -C CASE, THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE -C SMALLEST VALUE 100*U WHICH IS LIKELY TO BE REASONABLE FOR -C THIS METHOD AND MACHINE -C - DO 180 K = 1, NEQ - IF (RTOL(K) + ATOL(K) .GT. 0.0D0) GO TO 170 - RTOL(K) = 100.0D0*U - IDID = -2 - 170 CONTINUE -C ...EXIT - IF (ITOL .EQ. 0) GO TO 190 - 180 CONTINUE - 190 CONTINUE -C - IF (IDID .NE. (-2)) GO TO 200 -C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A -C SMALL POSITIVE VALUE - IBEGIN = -1 - GO TO 460 - 200 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 450 -C BEGIN BLOCK PERMITTING ...EXITS TO 430 -C BEGIN BLOCK PERMITTING ...EXITS TO 260 -C BEGIN BLOCK PERMITTING ...EXITS TO 230 -C -C BRANCH ON STATUS OF INITIALIZATION INDICATOR -C INIT=0 MEANS INITIAL DERIVATIVES AND -C NOMINAL STEP SIZE -C AND DIRECTION NOT YET SET -C INIT=1 MEANS NOMINAL STEP SIZE AND -C DIRECTION NOT YET SET INIT=2 MEANS NO -C FURTHER INITIALIZATION REQUIRED -C - IF (INIT .EQ. 0) GO TO 210 -C ......EXIT - IF (INIT .EQ. 1) GO TO 230 -C .........EXIT - GO TO 260 - 210 CONTINUE -C -C ................................................ -C -C MORE INITIALIZATION -- -C -- EVALUATE INITIAL -C DERIVATIVES -C - INIT = 1 - CALL DF(T,Y,YH(1,2),RPAR,IPAR) - NFE = 1 -C ...EXIT - IF (T .NE. TOUT) GO TO 230 - IDID = 2 - DO 220 L = 1, NEQ - YPOUT(L) = YH(L,2) - 220 CONTINUE - TOLD = T -C ............EXIT - GO TO 450 - 230 CONTINUE -C -C -- COMPUTE INITIAL STEP SIZE -C -- SAVE SIGN OF INTEGRATION DIRECTION -C -- SET INDEPENDENT AND DEPENDENT VARIABLES -C X AND YH(*) FOR DSTOD -C - LTOL = 1 - DO 240 L = 1, NEQ - IF (ITOL .EQ. 1) LTOL = L - TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL) - IF (TOL .EQ. 0.0D0) GO TO 390 - EWT(L) = TOL - 240 CONTINUE -C - BIG = SQRT(D1MACH(2)) - CALL DHSTRT(DF,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG, - 1 YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR, - 2 IPAR,H) -C - DELSGN = SIGN(1.0D0,TOUT-T) - X = T - DO 250 L = 1, NEQ - YH(L,1) = Y(L) - YH(L,2) = H*YH(L,2) - 250 CONTINUE - INIT = 2 - 260 CONTINUE -C -C ...................................................... -C -C ON EACH CALL SET INFORMATION WHICH DETERMINES THE -C ALLOWED INTERVAL OF INTEGRATION BEFORE RETURNING -C WITH AN ANSWER AT TOUT -C - DEL = TOUT - T - ABSDEL = ABS(DEL) -C -C ...................................................... -C -C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND -C RETURN -C - 270 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 400 -C BEGIN BLOCK PERMITTING ...EXITS TO 380 - IF (ABS(X-T) .LT. ABSDEL) GO TO 290 - CALL DINTYD(TOUT,0,YH,NEQ,Y,INTFLG) - CALL DINTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG) - IDID = 3 - IF (X .NE. TOUT) GO TO 280 - IDID = 2 - INTOUT = .FALSE. - 280 CONTINUE - T = TOUT - TOLD = T -C ..................EXIT - GO TO 450 - 290 CONTINUE -C -C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY -C CLOSE, EXTRAPOLATE AND RETURN -C - IF (ITSTOP .NE. 1) GO TO 310 - IF (ABS(TSTOP-X) .GE. 100.0D0*U*ABS(X)) - 1 GO TO 310 - DT = TOUT - X - DO 300 L = 1, NEQ - Y(L) = YH(L,1) + (DT/H)*YH(L,2) - 300 CONTINUE - CALL DF(TOUT,Y,YPOUT,RPAR,IPAR) - NFE = NFE + 1 - IDID = 3 - T = TOUT - TOLD = T -C ..................EXIT - GO TO 450 - 310 CONTINUE -C - IF (IINTEG .EQ. 0 .OR. .NOT.INTOUT) GO TO 320 -C -C INTERMEDIATE-OUTPUT MODE -C - IDID = 1 - GO TO 370 - 320 CONTINUE -C -C ............................................. -C -C MONITOR NUMBER OF STEPS ATTEMPTED -C - IF (KSTEPS .LE. MAXNUM) GO TO 330 -C -C A SIGNIFICANT AMOUNT OF WORK HAS BEEN -C EXPENDED - IDID = -1 - KSTEPS = 0 - IBEGIN = -1 - GO TO 370 - 330 CONTINUE -C -C .......................................... -C -C LIMIT STEP SIZE AND SET WEIGHT VECTOR -C - HMIN = 100.0D0*U*ABS(X) - HA = MAX(ABS(H),HMIN) - IF (ITSTOP .EQ. 1) - 1 HA = MIN(HA,ABS(TSTOP-X)) - H = SIGN(HA,H) - LTOL = 1 - DO 340 L = 1, NEQ - IF (ITOL .EQ. 1) LTOL = L - EWT(L) = RTOL(LTOL)*ABS(YH(L,1)) - 1 + ATOL(LTOL) -C .........EXIT - IF (EWT(L) .LE. 0.0D0) GO TO 380 - 340 CONTINUE - TOLFAC = U*DVNRMS(NEQ,YH,EWT) -C .........EXIT - IF (TOLFAC .LE. 1.0D0) GO TO 400 -C -C TOLERANCES TOO SMALL - IDID = -2 - TOLFAC = 2.0D0*TOLFAC - RTOL(1) = TOLFAC*RTOL(1) - ATOL(1) = TOLFAC*ATOL(1) - IF (ITOL .EQ. 0) GO TO 360 - DO 350 L = 2, NEQ - RTOL(L) = TOLFAC*RTOL(L) - ATOL(L) = TOLFAC*ATOL(L) - 350 CONTINUE - 360 CONTINUE - IBEGIN = -1 - 370 CONTINUE -C ............EXIT - GO TO 430 - 380 CONTINUE -C -C RELATIVE ERROR CRITERION INAPPROPRIATE - 390 CONTINUE - IDID = -3 - IBEGIN = -1 -C .........EXIT - GO TO 430 - 400 CONTINUE -C -C ................................................... -C -C TAKE A STEP -C - CALL DSTOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM, - 1 DF,DJAC,RPAR,IPAR) -C - JSTART = -2 - INTOUT = .TRUE. - IF (KFLAG .EQ. 0) GO TO 270 -C -C ...................................................... -C - IF (KFLAG .EQ. -1) GO TO 410 -C -C REPEATED CORRECTOR CONVERGENCE FAILURES - IDID = -6 - IBEGIN = -1 - GO TO 420 - 410 CONTINUE -C -C REPEATED ERROR TEST FAILURES - IDID = -7 - IBEGIN = -1 - 420 CONTINUE - 430 CONTINUE -C -C ......................................................... -C -C STORE VALUES BEFORE RETURNING TO -C DDEBDF - DO 440 L = 1, NEQ - Y(L) = YH(L,1) - YPOUT(L) = YH(L,2)/H - 440 CONTINUE - T = X - TOLD = T - INTOUT = .FALSE. - 450 CONTINUE - 460 CONTINUE - RETURN - END -*DECK DSTOD - SUBROUTINE DSTOD (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, WM, IWM, - + DF, DJAC, RPAR, IPAR) -C***BEGIN PROLOGUE DSTOD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (STOD-S, DSTOD-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DSTOD integrates a system of first order odes over one step in the -C integrator package DDEBDF. -C ---------------------------------------------------------------------- -C DSTOD performs one step of the integration of an initial value -C problem for a system of ordinary differential equations. -C Note.. DSTOD is independent of the value of the iteration method -C indicator MITER, when this is .NE. 0, and hence is independent -C of the type of chord method used, or the Jacobian structure. -C Communication with DSTOD is done with the following variables.. -C -C Y = An array of length .GE. N used as the Y argument in -C all calls to DF and DJAC. -C NEQ = Integer array containing problem size in NEQ(1), and -C passed as the NEQ argument in all calls to DF and DJAC. -C YH = An NYH by LMAX array containing the dependent variables -C and their approximate scaled derivatives, where -C LMAX = MAXORD + 1. YH(I,J+1) contains the approximate -C J-th derivative of Y(I), scaled by H**J/FACTORIAL(J) -C (J = 0,1,...,NQ). On entry for the first step, the first -C two columns of YH must be set from the initial values. -C NYH = A constant integer .GE. N, the first dimension of YH. -C YH1 = A one-dimensional array occupying the same space as YH. -C EWT = An array of N elements with which the estimated local -C errors in YH are compared. -C SAVF = An array of working storage, of length N. -C ACOR = A work array of length N, used for the accumulated -C corrections. On a successful return, ACOR(I) contains -C the estimated one-step local error in Y(I). -C WM,IWM = DOUBLE PRECISION and INTEGER work arrays associated with -C matrix operations in chord iteration (MITER .NE. 0). -C DPJAC = Name of routine to evaluate and preprocess Jacobian matrix -C if a chord method is being used. -C DSLVS = Name of routine to solve linear system in chord iteration. -C H = The step size to be attempted on the next step. -C H is altered by the error control algorithm during the -C problem. H can be either positive or negative, but its -C sign must remain constant throughout the problem. -C HMIN = The minimum absolute value of the step size H to be used. -C HMXI = Inverse of the maximum absolute value of H to be used. -C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. -C HMIN and HMXI may be changed at any time, but will not -C take effect until the next change of H is considered. -C TN = The independent variable. TN is updated on each step taken. -C JSTART = An integer used for input only, with the following -C values and meanings.. -C 0 Perform the first step. -C .GT.0 Take a new step continuing from the last. -C -1 Take the next step with a new value of H, MAXORD, -C N, METH, MITER, and/or matrix parameters. -C -2 Take the next step with a new value of H, -C but with other inputs unchanged. -C On return, JSTART is set to 1 to facilitate continuation. -C KFLAG = a completion code with the following meanings.. -C 0 The step was successful. -C -1 The requested error could not be achieved. -C -2 Corrector convergence could not be achieved. -C A return with KFLAG = -1 or -2 means either -C ABS(H) = HMIN or 10 consecutive failures occurred. -C On a return with KFLAG negative, the values of TN and -C the YH array are as of the beginning of the last -C step, and H is the last step size attempted. -C MAXORD = The maximum order of integration method to be allowed. -C METH/MITER = The method flags. See description in driver. -C N = The number of first-order differential equations. -C ---------------------------------------------------------------------- -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED DCFOD, DPJAC, DSLVS, DVNRMS -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920422 Changed DIMENSION statement. (WRB) -C***END PROLOGUE DSTOD -C - INTEGER I, I1, IALTH, IER, IOD, IOWND, IPAR, IPUP, IREDO, IRET, - 1 IWM, J, JB, JSTART, KFLAG, KSTEPS, L, LMAX, M, MAXORD, - 2 MEO, METH, MITER, N, NCF, NEQ, NEWQ, NFE, NJE, NQ, NQNYH, - 3 NQU, NST, NSTEPJ, NYH - DOUBLE PRECISION ACOR, CONIT, CRATE, DCON, DDN, - 1 DEL, DELP, DSM, DUP, DVNRMS, EL, EL0, ELCO, - 2 EWT, EXDN, EXSM, EXUP, H, HMIN, HMXI, HOLD, HU, R, RC, - 3 RH, RHDN, RHSM, RHUP, RMAX, ROWND, RPAR, SAVF, TESCO, - 4 TN, TOLD, UROUND, WM, Y, YH, YH1 - EXTERNAL DF, DJAC -C - DIMENSION Y(*),YH(NYH,*),YH1(*),EWT(*),SAVF(*),ACOR(*),WM(*), - 1 IWM(*),RPAR(*),IPAR(*) - COMMON /DDEBD1/ ROWND,CONIT,CRATE,EL(13),ELCO(13,12),HOLD,RC,RMAX, - 1 TESCO(3,12),EL0,H,HMIN,HMXI,HU,TN,UROUND,IOWND(7), - 2 KSTEPS,IOD(6),IALTH,IPUP,LMAX,MEO,NQNYH,NSTEPJ, - 3 IER,JSTART,KFLAG,L,METH,MITER,MAXORD,N,NQ,NST,NFE, - 4 NJE,NQU -C -C -C BEGIN BLOCK PERMITTING ...EXITS TO 690 -C BEGIN BLOCK PERMITTING ...EXITS TO 60 -C***FIRST EXECUTABLE STATEMENT DSTOD - KFLAG = 0 - TOLD = TN - NCF = 0 - IF (JSTART .GT. 0) GO TO 160 - IF (JSTART .EQ. -1) GO TO 10 - IF (JSTART .EQ. -2) GO TO 90 -C --------------------------------------------------------- -C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER -C VARIABLES ARE INITIALIZED. RMAX IS THE MAXIMUM RATIO BY -C WHICH H CAN BE INCREASED IN A SINGLE STEP. IT IS -C INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL INITIAL H, -C BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE OCCURS -C (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT -C 2 FOR THE NEXT INCREASE. -C --------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - IALTH = 2 - RMAX = 10000.0D0 - RC = 0.0D0 - EL0 = 1.0D0 - CRATE = 0.7D0 - DELP = 0.0D0 - HOLD = H - MEO = METH - NSTEPJ = 0 - IRET = 3 - GO TO 50 - 10 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 30 -C ------------------------------------------------------ -C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN -C JSTART = -1. IPUP IS SET TO MITER TO FORCE A MATRIX -C UPDATE. IF AN ORDER INCREASE IS ABOUT TO BE -C CONSIDERED (IALTH = 1), IALTH IS RESET TO 2 TO -C POSTPONE CONSIDERATION ONE MORE STEP. IF THE CALLER -C HAS CHANGED METH, DCFOD IS CALLED TO RESET THE -C COEFFICIENTS OF THE METHOD. IF THE CALLER HAS -C CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT -C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN -C ACCORDINGLY. IF H IS TO BE CHANGED, YH MUST BE -C RESCALED. IF H OR METH IS BEING CHANGED, IALTH IS -C RESET TO L = NQ + 1 TO PREVENT FURTHER CHANGES IN H -C FOR THAT MANY STEPS. -C ------------------------------------------------------ - IPUP = MITER - LMAX = MAXORD + 1 - IF (IALTH .EQ. 1) IALTH = 2 - IF (METH .EQ. MEO) GO TO 20 - CALL DCFOD(METH,ELCO,TESCO) - MEO = METH -C ......EXIT - IF (NQ .GT. MAXORD) GO TO 30 - IALTH = L - IRET = 1 -C ............EXIT - GO TO 60 - 20 CONTINUE - IF (NQ .LE. MAXORD) GO TO 90 - 30 CONTINUE - NQ = MAXORD - L = LMAX - DO 40 I = 1, L - EL(I) = ELCO(I,NQ) - 40 CONTINUE - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/(NQ+2) - DDN = DVNRMS(N,SAVF,EWT)/TESCO(1,L) - EXDN = 1.0D0/L - RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) - RH = MIN(RHDN,1.0D0) - IREDO = 3 - IF (H .EQ. HOLD) GO TO 660 - RH = MIN(RH,ABS(H/HOLD)) - H = HOLD - GO TO 100 - 50 CONTINUE -C ------------------------------------------------------------ -C DCFOD IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS -C FOR THE CURRENT METH. THEN THE EL VECTOR AND RELATED -C CONSTANTS ARE RESET WHENEVER THE ORDER NQ IS CHANGED, OR AT -C THE START OF THE PROBLEM. -C ------------------------------------------------------------ - CALL DCFOD(METH,ELCO,TESCO) - 60 CONTINUE - 70 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 680 - DO 80 I = 1, L - EL(I) = ELCO(I,NQ) - 80 CONTINUE - NQNYH = NQ*NYH - RC = RC*EL(1)/EL0 - EL0 = EL(1) - CONIT = 0.5D0/(NQ+2) - GO TO (90,660,160), IRET -C --------------------------------------------------------- -C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST -C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH -C IS SET TO L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT -C MANY STEPS, UNLESS FORCED BY A CONVERGENCE OR ERROR TEST -C FAILURE. -C --------------------------------------------------------- - 90 CONTINUE - IF (H .EQ. HOLD) GO TO 160 - RH = H/HOLD - H = HOLD - IREDO = 3 - 100 CONTINUE - 110 CONTINUE - RH = MIN(RH,RMAX) - RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) - R = 1.0D0 - DO 130 J = 2, L - R = R*RH - DO 120 I = 1, N - YH(I,J) = YH(I,J)*R - 120 CONTINUE - 130 CONTINUE - H = H*RH - RC = RC*RH - IALTH = L - IF (IREDO .NE. 0) GO TO 150 - RMAX = 10.0D0 - R = 1.0D0/TESCO(2,NQU) - DO 140 I = 1, N - ACOR(I) = ACOR(I)*R - 140 CONTINUE -C ...............EXIT - GO TO 690 - 150 CONTINUE -C ------------------------------------------------------ -C THIS SECTION COMPUTES THE PREDICTED VALUES BY -C EFFECTIVELY MULTIPLYING THE YH ARRAY BY THE PASCAL -C TRIANGLE MATRIX. RC IS THE RATIO OF NEW TO OLD -C VALUES OF THE COEFFICIENT H*EL(1). WHEN RC DIFFERS -C FROM 1 BY MORE THAN 30 PERCENT, IPUP IS SET TO MITER -C TO FORCE DPJAC TO BE CALLED, IF A JACOBIAN IS -C INVOLVED. IN ANY CASE, DPJAC IS CALLED AT LEAST -C EVERY 20-TH STEP. -C ------------------------------------------------------ - 160 CONTINUE - 170 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 610 -C BEGIN BLOCK PERMITTING ...EXITS TO 490 - IF (ABS(RC-1.0D0) .GT. 0.3D0) IPUP = MITER - IF (NST .GE. NSTEPJ + 20) IPUP = MITER - TN = TN + H - I1 = NQNYH + 1 - DO 190 JB = 1, NQ - I1 = I1 - NYH - DO 180 I = I1, NQNYH - YH1(I) = YH1(I) + YH1(I+NYH) - 180 CONTINUE - 190 CONTINUE - KSTEPS = KSTEPS + 1 -C --------------------------------------------- -C UP TO 3 CORRECTOR ITERATIONS ARE TAKEN. A -C CONVERGENCE TEST IS MADE ON THE R.M.S. NORM -C OF EACH CORRECTION, WEIGHTED BY THE ERROR -C WEIGHT VECTOR EWT. THE SUM OF THE -C CORRECTIONS IS ACCUMULATED IN THE VECTOR -C ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE -C CORRECTOR LOOP. -C --------------------------------------------- - 200 CONTINUE - M = 0 - DO 210 I = 1, N - Y(I) = YH(I,1) - 210 CONTINUE - CALL DF(TN,Y,SAVF,RPAR,IPAR) - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 220 -C --------------------------------------- -C IF INDICATED, THE MATRIX P = I - -C H*EL(1)*J IS REEVALUATED AND -C PREPROCESSED BEFORE STARTING THE -C CORRECTOR ITERATION. IPUP IS SET TO 0 -C AS AN INDICATOR THAT THIS HAS BEEN -C DONE. -C --------------------------------------- - IPUP = 0 - RC = 1.0D0 - NSTEPJ = NST - CRATE = 0.7D0 - CALL DPJAC(NEQ,Y,YH,NYH,EWT,ACOR,SAVF, - 1 WM,IWM,DF,DJAC,RPAR,IPAR) -C ......EXIT - IF (IER .NE. 0) GO TO 440 - 220 CONTINUE - DO 230 I = 1, N - ACOR(I) = 0.0D0 - 230 CONTINUE - 240 CONTINUE - IF (MITER .NE. 0) GO TO 270 -C ------------------------------------ -C IN THE CASE OF FUNCTIONAL -C ITERATION, UPDATE Y DIRECTLY FROM -C THE RESULT OF THE LAST FUNCTION -C EVALUATION. -C ------------------------------------ - DO 250 I = 1, N - SAVF(I) = H*SAVF(I) - YH(I,2) - Y(I) = SAVF(I) - ACOR(I) - 250 CONTINUE - DEL = DVNRMS(N,Y,EWT) - DO 260 I = 1, N - Y(I) = YH(I,1) + EL(1)*SAVF(I) - ACOR(I) = SAVF(I) - 260 CONTINUE - GO TO 300 - 270 CONTINUE -C ------------------------------------ -C IN THE CASE OF THE CHORD METHOD, -C COMPUTE THE CORRECTOR ERROR, AND -C SOLVE THE LINEAR SYSTEM WITH THAT -C AS RIGHT-HAND SIDE AND P AS -C COEFFICIENT MATRIX. -C ------------------------------------ - DO 280 I = 1, N - Y(I) = H*SAVF(I) - 1 - (YH(I,2) + ACOR(I)) - 280 CONTINUE - CALL DSLVS(WM,IWM,Y,SAVF) -C ......EXIT - IF (IER .NE. 0) GO TO 430 - DEL = DVNRMS(N,Y,EWT) - DO 290 I = 1, N - ACOR(I) = ACOR(I) + Y(I) - Y(I) = YH(I,1) + EL(1)*ACOR(I) - 290 CONTINUE - 300 CONTINUE -C --------------------------------------- -C TEST FOR CONVERGENCE. IF M.GT.0, AN -C ESTIMATE OF THE CONVERGENCE RATE -C CONSTANT IS STORED IN CRATE, AND THIS -C IS USED IN THE TEST. -C --------------------------------------- - IF (M .NE. 0) - 1 CRATE = MAX(0.2D0*CRATE,DEL/DELP) - DCON = DEL*MIN(1.0D0,1.5D0*CRATE) - 1 /(TESCO(2,NQ)*CONIT) - IF (DCON .GT. 1.0D0) GO TO 420 -C ------------------------------------ -C THE CORRECTOR HAS CONVERGED. IPUP -C IS SET TO -1 IF MITER .NE. 0, TO -C SIGNAL THAT THE JACOBIAN INVOLVED -C MAY NEED UPDATING LATER. THE LOCAL -C ERROR TEST IS MADE AND CONTROL -C PASSES TO STATEMENT 500 IF IT -C FAILS. -C ------------------------------------ - IF (MITER .NE. 0) IPUP = -1 - IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) - IF (M .GT. 0) - 1 DSM = DVNRMS(N,ACOR,EWT) - 2 /TESCO(2,NQ) - IF (DSM .GT. 1.0D0) GO TO 380 -C BEGIN BLOCK -C PERMITTING ...EXITS TO 360 -C ------------------------------ -C AFTER A SUCCESSFUL STEP, -C UPDATE THE YH ARRAY. -C CONSIDER CHANGING H IF IALTH -C = 1. OTHERWISE DECREASE -C IALTH BY 1. IF IALTH IS THEN -C 1 AND NQ .LT. MAXORD, THEN -C ACOR IS SAVED FOR USE IN A -C POSSIBLE ORDER INCREASE ON -C THE NEXT STEP. IF A CHANGE -C IN H IS CONSIDERED, AN -C INCREASE OR DECREASE IN ORDER -C BY ONE IS CONSIDERED ALSO. A -C CHANGE IN H IS MADE ONLY IF -C IT IS BY A FACTOR OF AT LEAST -C 1.1. IF NOT, IALTH IS SET TO -C 3 TO PREVENT TESTING FOR THAT -C MANY STEPS. -C ------------------------------ - KFLAG = 0 - IREDO = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 320 J = 1, L - DO 310 I = 1, N - YH(I,J) = YH(I,J) - 1 + EL(J) - 2 *ACOR(I) - 310 CONTINUE - 320 CONTINUE - IALTH = IALTH - 1 - IF (IALTH .NE. 0) GO TO 340 -C --------------------------- -C REGARDLESS OF THE SUCCESS -C OR FAILURE OF THE STEP, -C FACTORS RHDN, RHSM, AND -C RHUP ARE COMPUTED, BY -C WHICH H COULD BE -C MULTIPLIED AT ORDER NQ - -C 1, ORDER NQ, OR ORDER NQ + -C 1, RESPECTIVELY. IN THE -C CASE OF FAILURE, RHUP = -C 0.0 TO AVOID AN ORDER -C INCREASE. THE LARGEST OF -C THESE IS DETERMINED AND -C THE NEW ORDER CHOSEN -C ACCORDINGLY. IF THE ORDER -C IS TO BE INCREASED, WE -C COMPUTE ONE ADDITIONAL -C SCALED DERIVATIVE. -C --------------------------- - RHUP = 0.0D0 -C .....................EXIT - IF (L .EQ. LMAX) GO TO 490 - DO 330 I = 1, N - SAVF(I) = ACOR(I) - 1 - YH(I,LMAX) - 330 CONTINUE - DUP = DVNRMS(N,SAVF,EWT) - 1 /TESCO(3,NQ) - EXUP = 1.0D0/(L+1) - RHUP = 1.0D0 - 1 /(1.4D0*DUP**EXUP - 2 + 0.0000014D0) -C .....................EXIT - GO TO 490 - 340 CONTINUE -C ...EXIT - IF (IALTH .GT. 1) GO TO 360 -C ...EXIT - IF (L .EQ. LMAX) GO TO 360 - DO 350 I = 1, N - YH(I,LMAX) = ACOR(I) - 350 CONTINUE - 360 CONTINUE - R = 1.0D0/TESCO(2,NQU) - DO 370 I = 1, N - ACOR(I) = ACOR(I)*R - 370 CONTINUE -C .................................EXIT - GO TO 690 - 380 CONTINUE -C ------------------------------------ -C THE ERROR TEST FAILED. KFLAG KEEPS -C TRACK OF MULTIPLE FAILURES. -C RESTORE TN AND THE YH ARRAY TO -C THEIR PREVIOUS VALUES, AND PREPARE -C TO TRY THE STEP AGAIN. COMPUTE THE -C OPTIMUM STEP SIZE FOR THIS OR ONE -C LOWER ORDER. AFTER 2 OR MORE -C FAILURES, H IS FORCED TO DECREASE -C BY A FACTOR OF 0.2 OR LESS. -C ------------------------------------ - KFLAG = KFLAG - 1 - TN = TOLD - I1 = NQNYH + 1 - DO 400 JB = 1, NQ - I1 = I1 - NYH - DO 390 I = I1, NQNYH - YH1(I) = YH1(I) - YH1(I+NYH) - 390 CONTINUE - 400 CONTINUE - RMAX = 2.0D0 - IF (ABS(H) .GT. HMIN*1.00001D0) - 1 GO TO 410 -C --------------------------------- -C ALL RETURNS ARE MADE THROUGH -C THIS SECTION. H IS SAVED IN -C HOLD TO ALLOW THE CALLER TO -C CHANGE H ON THE NEXT STEP. -C --------------------------------- - KFLAG = -1 -C .................................EXIT - GO TO 690 - 410 CONTINUE -C ...............EXIT - IF (KFLAG .LE. -3) GO TO 610 - IREDO = 2 - RHUP = 0.0D0 -C ............EXIT - GO TO 490 - 420 CONTINUE - M = M + 1 -C ...EXIT - IF (M .EQ. 3) GO TO 430 -C ...EXIT - IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) - 1 GO TO 430 - DELP = DEL - CALL DF(TN,Y,SAVF,RPAR,IPAR) - NFE = NFE + 1 - GO TO 240 - 430 CONTINUE -C ------------------------------------------ -C THE CORRECTOR ITERATION FAILED TO -C CONVERGE IN 3 TRIES. IF MITER .NE. 0 AND -C THE JACOBIAN IS OUT OF DATE, DPJAC IS -C CALLED FOR THE NEXT TRY. OTHERWISE THE -C YH ARRAY IS RETRACTED TO ITS VALUES -C BEFORE PREDICTION, AND H IS REDUCED, IF -C POSSIBLE. IF H CANNOT BE REDUCED OR 10 -C FAILURES HAVE OCCURRED, EXIT WITH KFLAG = -C -2. -C ------------------------------------------ -C ...EXIT - IF (IPUP .EQ. 0) GO TO 440 - IPUP = MITER - GO TO 200 - 440 CONTINUE - TN = TOLD - NCF = NCF + 1 - RMAX = 2.0D0 - I1 = NQNYH + 1 - DO 460 JB = 1, NQ - I1 = I1 - NYH - DO 450 I = I1, NQNYH - YH1(I) = YH1(I) - YH1(I+NYH) - 450 CONTINUE - 460 CONTINUE - IF (ABS(H) .GT. HMIN*1.00001D0) GO TO 470 - KFLAG = -2 -C ........................EXIT - GO TO 690 - 470 CONTINUE - IF (NCF .NE. 10) GO TO 480 - KFLAG = -2 -C ........................EXIT - GO TO 690 - 480 CONTINUE - RH = 0.25D0 - IPUP = MITER - IREDO = 1 -C .........EXIT - GO TO 650 - 490 CONTINUE - EXSM = 1.0D0/L - RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) - RHDN = 0.0D0 - IF (NQ .EQ. 1) GO TO 500 - DDN = DVNRMS(N,YH(1,L),EWT)/TESCO(1,NQ) - EXDN = 1.0D0/NQ - RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) - 500 CONTINUE - IF (RHSM .GE. RHUP) GO TO 550 - IF (RHUP .LE. RHDN) GO TO 540 - NEWQ = L - RH = RHUP - IF (RH .GE. 1.1D0) GO TO 520 - IALTH = 3 - R = 1.0D0/TESCO(2,NQU) - DO 510 I = 1, N - ACOR(I) = ACOR(I)*R - 510 CONTINUE -C ...........................EXIT - GO TO 690 - 520 CONTINUE - R = EL(L)/L - DO 530 I = 1, N - YH(I,NEWQ+1) = ACOR(I)*R - 530 CONTINUE - NQ = NEWQ - L = NQ + 1 - IRET = 2 -C ..................EXIT - GO TO 680 - 540 CONTINUE - GO TO 580 - 550 CONTINUE - IF (RHSM .LT. RHDN) GO TO 580 - NEWQ = NQ - RH = RHSM - IF (KFLAG .EQ. 0 .AND. RH .LT. 1.1D0) - 1 GO TO 560 - IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) -C ------------------------------------------ -C IF THERE IS A CHANGE OF ORDER, RESET NQ, -C L, AND THE COEFFICIENTS. IN ANY CASE H -C IS RESET ACCORDING TO RH AND THE YH ARRAY -C IS RESCALED. THEN EXIT FROM 680 IF THE -C STEP WAS OK, OR REDO THE STEP OTHERWISE. -C ------------------------------------------ -C ............EXIT - IF (NEWQ .EQ. NQ) GO TO 650 - NQ = NEWQ - L = NQ + 1 - IRET = 2 -C ..................EXIT - GO TO 680 - 560 CONTINUE - IALTH = 3 - R = 1.0D0/TESCO(2,NQU) - DO 570 I = 1, N - ACOR(I) = ACOR(I)*R - 570 CONTINUE -C .....................EXIT - GO TO 690 - 580 CONTINUE - NEWQ = NQ - 1 - RH = RHDN - IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 - IF (KFLAG .EQ. 0 .AND. RH .LT. 1.1D0) GO TO 590 - IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) -C --------------------------------------------- -C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, -C AND THE COEFFICIENTS. IN ANY CASE H IS -C RESET ACCORDING TO RH AND THE YH ARRAY IS -C RESCALED. THEN EXIT FROM 680 IF THE STEP -C WAS OK, OR REDO THE STEP OTHERWISE. -C --------------------------------------------- -C .........EXIT - IF (NEWQ .EQ. NQ) GO TO 650 - NQ = NEWQ - L = NQ + 1 - IRET = 2 -C ...............EXIT - GO TO 680 - 590 CONTINUE - IALTH = 3 - R = 1.0D0/TESCO(2,NQU) - DO 600 I = 1, N - ACOR(I) = ACOR(I)*R - 600 CONTINUE -C ..................EXIT - GO TO 690 - 610 CONTINUE -C --------------------------------------------------- -C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES -C HAVE OCCURRED. IF 10 FAILURES HAVE OCCURRED, EXIT -C WITH KFLAG = -1. IT IS ASSUMED THAT THE -C DERIVATIVES THAT HAVE ACCUMULATED IN THE YH ARRAY -C HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST -C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO -C 1. THEN H IS REDUCED BY A FACTOR OF 10, AND THE -C STEP IS RETRIED, UNTIL IT SUCCEEDS OR H REACHES -C HMIN. -C --------------------------------------------------- - IF (KFLAG .NE. -10) GO TO 620 -C ------------------------------------------------ -C ALL RETURNS ARE MADE THROUGH THIS SECTION. H -C IS SAVED IN HOLD TO ALLOW THE CALLER TO CHANGE -C H ON THE NEXT STEP. -C ------------------------------------------------ - KFLAG = -1 -C ..................EXIT - GO TO 690 - 620 CONTINUE - RH = 0.1D0 - RH = MAX(HMIN/ABS(H),RH) - H = H*RH - DO 630 I = 1, N - Y(I) = YH(I,1) - 630 CONTINUE - CALL DF(TN,Y,SAVF,RPAR,IPAR) - NFE = NFE + 1 - DO 640 I = 1, N - YH(I,2) = H*SAVF(I) - 640 CONTINUE - IPUP = MITER - IALTH = 5 -C ......EXIT - IF (NQ .NE. 1) GO TO 670 - GO TO 170 - 650 CONTINUE - 660 CONTINUE - RH = MAX(RH,HMIN/ABS(H)) - GO TO 110 - 670 CONTINUE - NQ = 1 - L = 2 - IRET = 3 - 680 CONTINUE - GO TO 70 - 690 CONTINUE - HOLD = H - JSTART = 1 - RETURN -C ----------------------- END OF SUBROUTINE DSTOD -C ----------------------- - END -*DECK DCFOD - SUBROUTINE DCFOD (METH, ELCO, TESCO) -C***BEGIN PROLOGUE DCFOD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (CFOD-S, DCFOD-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DCFOD defines coefficients needed in the integrator package DDEBDF -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DCFOD -C -C - INTEGER I, IB, METH, NQ, NQM1, NQP1 - DOUBLE PRECISION AGAMQ, ELCO, FNQ, FNQM1, PC, PINT, RAGQ, - 1 RQ1FAC, RQFAC, TESCO, TSIGN, XPIN - DIMENSION ELCO(13,12),TESCO(3,12) -C ------------------------------------------------------------------ -C DCFOD IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS -C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS -C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. -C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = -C 2. (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) -C DCFOD IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, -C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. -C -C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. -C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF -C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A -C GENERATING POLYNOMIAL, I.E., -C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. -C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY -C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = -C 0. FOR THE BDF METHODS, L(X) IS GIVEN BY -C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, -C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). -C -C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE -C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. -C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP -C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER -C NQ + 1 IF K = 3. -C ------------------------------------------------------------------ - DIMENSION PC(12) -C -C***FIRST EXECUTABLE STATEMENT DCFOD - GO TO (10,60), METH -C - 10 CONTINUE - ELCO(1,1) = 1.0D0 - ELCO(2,1) = 1.0D0 - TESCO(1,1) = 0.0D0 - TESCO(2,1) = 2.0D0 - TESCO(1,2) = 1.0D0 - TESCO(3,12) = 0.0D0 - PC(1) = 1.0D0 - RQFAC = 1.0D0 - DO 50 NQ = 2, 12 -C ------------------------------------------------------------ -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE -C POLYNOMIAL P(X) = (X+1)*(X+2)*...*(X+NQ-1). -C INITIALLY, P(X) = 1. -C ------------------------------------------------------------ - RQ1FAC = RQFAC - RQFAC = RQFAC/NQ - NQM1 = NQ - 1 - FNQM1 = NQM1 - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ-1). -C ---------------------------------- - PC(NQ) = 0.0D0 - DO 20 IB = 1, NQM1 - I = NQP1 - IB - PC(I) = PC(I-1) + FNQM1*PC(I) - 20 CONTINUE - PC(1) = FNQM1*PC(1) -C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). -C ----------------------- - PINT = PC(1) - XPIN = PC(1)/2.0D0 - TSIGN = 1.0D0 - DO 30 I = 2, NQ - TSIGN = -TSIGN - PINT = PINT + TSIGN*PC(I)/I - XPIN = XPIN + TSIGN*PC(I)/(I+1) - 30 CONTINUE -C STORE COEFFICIENTS IN ELCO AND TESCO. -C -------------------------------- - ELCO(1,NQ) = PINT*RQ1FAC - ELCO(2,NQ) = 1.0D0 - DO 40 I = 2, NQ - ELCO(I+1,NQ) = RQ1FAC*PC(I)/I - 40 CONTINUE - AGAMQ = RQFAC*XPIN - RAGQ = 1.0D0/AGAMQ - TESCO(2,NQ) = RAGQ - IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 - TESCO(3,NQM1) = RAGQ - 50 CONTINUE - GO TO 100 -C - 60 CONTINUE - PC(1) = 1.0D0 - RQ1FAC = 1.0D0 - DO 90 NQ = 1, 5 -C ------------------------------------------------------------ -C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE -C POLYNOMIAL P(X) = (X+1)*(X+2)*...*(X+NQ). -C INITIALLY, P(X) = 1. -C ------------------------------------------------------------ - FNQ = NQ - NQP1 = NQ + 1 -C FORM COEFFICIENTS OF P(X)*(X+NQ). -C ------------------------------------ - PC(NQP1) = 0.0D0 - DO 70 IB = 1, NQ - I = NQ + 2 - IB - PC(I) = PC(I-1) + FNQ*PC(I) - 70 CONTINUE - PC(1) = FNQ*PC(1) -C STORE COEFFICIENTS IN ELCO AND TESCO. -C -------------------------------- - DO 80 I = 1, NQP1 - ELCO(I,NQ) = PC(I)/PC(2) - 80 CONTINUE - ELCO(2,NQ) = 1.0D0 - TESCO(1,NQ) = RQ1FAC - TESCO(2,NQ) = NQP1/ELCO(1,NQ) - TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) - RQ1FAC = RQ1FAC/FNQ - 90 CONTINUE - 100 CONTINUE - RETURN -C ----------------------- END OF SUBROUTINE DCFOD -C ----------------------- - END -*DECK DVNRMS - DOUBLE PRECISION FUNCTION DVNRMS (N, V, W) -C***BEGIN PROLOGUE DVNRMS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (VNWRMS-S, DVNRMS-D) -C***AUTHOR (UNKNOWN) -C***DESCRIPTION -C -C DVNRMS computes a weighted root-mean-square vector norm for the -C integrator package DDEBDF. -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C***END PROLOGUE DVNRMS - INTEGER I, N - DOUBLE PRECISION SUM, V, W - DIMENSION V(*),W(*) -C***FIRST EXECUTABLE STATEMENT DVNRMS - SUM = 0.0D0 - DO 10 I = 1, N - SUM = SUM + (V(I)/W(I))**2 - 10 CONTINUE - DVNRMS = SQRT(SUM/N) - RETURN -C ----------------------- END OF FUNCTION DVNRMS -C ------------------------ - END -*DECK DINTYD - SUBROUTINE DINTYD (T, K, YH, NYH, DKY, IFLAG) -C***BEGIN PROLOGUE DINTYD -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (INTYD-S, DINTYD-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DINTYD approximates the solution and derivatives at T by polynomial -C interpolation. Must be used in conjunction with the integrator -C package DDEBDF. -C ---------------------------------------------------------------------- -C DINTYD computes interpolated values of the K-th derivative of the -C dependent variable vector Y, and stores it in DKY. -C This routine is called by DDEBDF with K = 0,1 and T = TOUT, but may -C also be called by the user for any K up to the current order. -C (see detailed instructions in LSODE usage documentation.) -C ---------------------------------------------------------------------- -C The computed values in DKY are gotten by interpolation using the -C Nordsieck history array YH. This array corresponds uniquely to a -C vector-valued polynomial of degree NQCUR or less, and DKY is set -C to the K-th derivative of this polynomial at T. -C The formula for DKY is.. -C Q -C DKY(I) = Sum C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) -C J=K -C where C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. -C The quantities NQ = NQCUR, L = NQ+1, N = NEQ, TN, and H are -C communicated by common. The above sum is done in reverse order. -C IFLAG is returned negative if either K or T is out of bounds. -C ---------------------------------------------------------------------- -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED (NONE) -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DINTYD -C - INTEGER I, IC, IER, IFLAG, IOWND, IOWNS, J, JB, JB2, JJ, JJ1, - 1 JP1, JSTART, K, KFLAG, L, MAXORD, METH, MITER, N, NFE, - 2 NJE, NQ, NQU, NST, NYH - DOUBLE PRECISION C, DKY, EL0, H, HMIN, HMXI, HU, R, ROWND, - 1 ROWNS, S, T, TN, TP, UROUND, YH - DIMENSION YH(NYH,*),DKY(*) - COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, - 1 IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, - 2 MAXORD,N,NQ,NST,NFE,NJE,NQU -C -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C***FIRST EXECUTABLE STATEMENT DINTYD - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 110 - TP = TN - HU*(1.0D0 + 100.0D0*UROUND) - IF ((T - TP)*(T - TN) .LE. 0.0D0) GO TO 10 - IFLAG = -2 -C .........EXIT - GO TO 130 - 10 CONTINUE -C - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 30 - JJ1 = L - K - DO 20 JJ = JJ1, NQ - IC = IC*JJ - 20 CONTINUE - 30 CONTINUE - C = IC - DO 40 I = 1, N - DKY(I) = C*YH(I,L) - 40 CONTINUE - IF (K .EQ. NQ) GO TO 90 - JB2 = NQ - K - DO 80 JB = 1, JB2 - J = NQ - JB - JP1 = J + 1 - IC = 1 - IF (K .EQ. 0) GO TO 60 - JJ1 = JP1 - K - DO 50 JJ = JJ1, J - IC = IC*JJ - 50 CONTINUE - 60 CONTINUE - C = IC - DO 70 I = 1, N - DKY(I) = C*YH(I,JP1) + S*DKY(I) - 70 CONTINUE - 80 CONTINUE -C .........EXIT - IF (K .EQ. 0) GO TO 130 - 90 CONTINUE - R = H**(-K) - DO 100 I = 1, N - DKY(I) = R*DKY(I) - 100 CONTINUE - GO TO 120 - 110 CONTINUE -C - IFLAG = -1 - 120 CONTINUE - 130 CONTINUE - RETURN -C ----------------------- END OF SUBROUTINE DINTYD -C ----------------------- - END -*DECK DPJAC - SUBROUTINE DPJAC (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, DF, - + DJAC, RPAR, IPAR) -C***BEGIN PROLOGUE DPJAC -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (PJAC-S, DPJAC-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DPJAC sets up the iteration matrix (involving the Jacobian) for the -C integration package DDEBDF. -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED DGBFA, DGEFA, DVNRMS -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920422 Changed DIMENSION statement. (WRB) -C***END PROLOGUE DPJAC -C - INTEGER I, I1, I2, IER, II, IOWND, IOWNS, IPAR, IWM, J, J1, - 1 JJ, JSTART, KFLAG, L, LENP, MAXORD, MBA, MBAND, - 2 MEB1, MEBAND, METH, MITER, ML, ML3, MU, N, NEQ, - 3 NFE, NJE, NQ, NQU, NST, NYH - DOUBLE PRECISION CON, DI, DVNRMS, EL0, EWT, - 1 FAC, FTEM, H, HL0, HMIN, HMXI, HU, R, R0, ROWND, ROWNS, - 2 RPAR, SAVF, SRUR, TN, UROUND, WM, Y, YH, YI, YJ, YJJ - EXTERNAL DF, DJAC - DIMENSION Y(*),YH(NYH,*),EWT(*),FTEM(*),SAVF(*),WM(*),IWM(*), - 1 RPAR(*),IPAR(*) - COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, - 1 IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, - 2 MAXORD,N,NQ,NST,NFE,NJE,NQU -C ------------------------------------------------------------------ -C DPJAC IS CALLED BY DSTOD TO COMPUTE AND PROCESS THE MATRIX -C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. -C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE DJAC IF -C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. -C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. -C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN -C SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION -C OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE -C BY DGEFA IF MITER = 1 OR 2, AND BY DGBFA IF MITER = 4 OR 5. -C -C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION -C WITH DPJAC USES THE FOLLOWING.. -C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. -C FTEM = WORK ARRAY OF LENGTH N (ACOR IN DSTOD ). -C SAVF = ARRAY CONTAINING DF EVALUATED AT PREDICTED Y. -C WM = DOUBLE PRECISION WORK SPACE FOR MATRICES. ON OUTPUT IT -C CONTAINS THE -C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU -C DECOMPOSITION OF P IF MITER IS 1, 2 , 4, OR 5. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN -C INCREMENTS. WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = -C 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING -C AT IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS -C THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER -C IS 4 OR 5. -C EL0 = EL(1) (INPUT). -C IER = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .NE. 0 IF -C P MATRIX FOUND TO BE SINGULAR. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, -C MITER, N, NFE, AND NJE. -C----------------------------------------------------------------------- -C BEGIN BLOCK PERMITTING ...EXITS TO 240 -C BEGIN BLOCK PERMITTING ...EXITS TO 220 -C BEGIN BLOCK PERMITTING ...EXITS TO 130 -C BEGIN BLOCK PERMITTING ...EXITS TO 70 -C***FIRST EXECUTABLE STATEMENT DPJAC - NJE = NJE + 1 - HL0 = H*EL0 - GO TO (10,40,90,140,170), MITER -C IF MITER = 1, CALL DJAC AND MULTIPLY BY SCALAR. -C ----------------------- - 10 CONTINUE - LENP = N*N - DO 20 I = 1, LENP - WM(I+2) = 0.0D0 - 20 CONTINUE - CALL DJAC(TN,Y,WM(3),N,RPAR,IPAR) - CON = -HL0 - DO 30 I = 1, LENP - WM(I+2) = WM(I+2)*CON - 30 CONTINUE -C ...EXIT - GO TO 70 -C IF MITER = 2, MAKE N CALLS TO DF TO APPROXIMATE J. -C -------------------- - 40 CONTINUE - FAC = DVNRMS(N,SAVF,EWT) - R0 = 1000.0D0*ABS(H)*UROUND*N*FAC - IF (R0 .EQ. 0.0D0) R0 = 1.0D0 - SRUR = WM(1) - J1 = 2 - DO 60 J = 1, N - YJ = Y(J) - R = MAX(SRUR*ABS(YJ),R0*EWT(J)) - Y(J) = Y(J) + R - FAC = -HL0/R - CALL DF(TN,Y,FTEM,RPAR,IPAR) - DO 50 I = 1, N - WM(I+J1) = (FTEM(I) - SAVF(I))*FAC - 50 CONTINUE - Y(J) = YJ - J1 = J1 + N - 60 CONTINUE - NFE = NFE + N - 70 CONTINUE -C ADD IDENTITY MATRIX. -C ------------------------------------------------- - J = 3 - DO 80 I = 1, N - WM(J) = WM(J) + 1.0D0 - J = J + (N + 1) - 80 CONTINUE -C DO LU DECOMPOSITION ON P. -C -------------------------------------------- - CALL DGEFA(WM(3),N,N,IWM(21),IER) -C .........EXIT - GO TO 240 -C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND -C P. --------- - 90 CONTINUE - WM(2) = HL0 - IER = 0 - R = EL0*0.1D0 - DO 100 I = 1, N - Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) - 100 CONTINUE - CALL DF(TN,Y,WM(3),RPAR,IPAR) - NFE = NFE + 1 - DO 120 I = 1, N - R0 = H*SAVF(I) - YH(I,2) - DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) - WM(I+2) = 1.0D0 - IF (ABS(R0) .LT. UROUND*EWT(I)) GO TO 110 -C .........EXIT - IF (ABS(DI) .EQ. 0.0D0) GO TO 130 - WM(I+2) = 0.1D0*R0/DI - 110 CONTINUE - 120 CONTINUE -C .........EXIT - GO TO 240 - 130 CONTINUE - IER = -1 -C ......EXIT - GO TO 240 -C IF MITER = 4, CALL DJAC AND MULTIPLY BY SCALAR. -C ----------------------- - 140 CONTINUE - ML = IWM(1) - MU = IWM(2) - ML3 = 3 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - LENP = MEBAND*N - DO 150 I = 1, LENP - WM(I+2) = 0.0D0 - 150 CONTINUE - CALL DJAC(TN,Y,WM(ML3),MEBAND,RPAR,IPAR) - CON = -HL0 - DO 160 I = 1, LENP - WM(I+2) = WM(I+2)*CON - 160 CONTINUE -C ...EXIT - GO TO 220 -C IF MITER = 5, MAKE MBAND CALLS TO DF TO APPROXIMATE J. -C ---------------- - 170 CONTINUE - ML = IWM(1) - MU = IWM(2) - MBAND = ML + MU + 1 - MBA = MIN(MBAND,N) - MEBAND = MBAND + ML - MEB1 = MEBAND - 1 - SRUR = WM(1) - FAC = DVNRMS(N,SAVF,EWT) - R0 = 1000.0D0*ABS(H)*UROUND*N*FAC - IF (R0 .EQ. 0.0D0) R0 = 1.0D0 - DO 210 J = 1, MBA - DO 180 I = J, N, MBAND - YI = Y(I) - R = MAX(SRUR*ABS(YI),R0*EWT(I)) - Y(I) = Y(I) + R - 180 CONTINUE - CALL DF(TN,Y,FTEM,RPAR,IPAR) - DO 200 JJ = J, N, MBAND - Y(JJ) = YH(JJ,1) - YJJ = Y(JJ) - R = MAX(SRUR*ABS(YJJ),R0*EWT(JJ)) - FAC = -HL0/R - I1 = MAX(JJ-MU,1) - I2 = MIN(JJ+ML,N) - II = JJ*MEB1 - ML + 2 - DO 190 I = I1, I2 - WM(II+I) = (FTEM(I) - SAVF(I))*FAC - 190 CONTINUE - 200 CONTINUE - 210 CONTINUE - NFE = NFE + MBA - 220 CONTINUE -C ADD IDENTITY MATRIX. -C ------------------------------------------------- - II = MBAND + 2 - DO 230 I = 1, N - WM(II) = WM(II) + 1.0D0 - II = II + MEBAND - 230 CONTINUE -C DO LU DECOMPOSITION OF P. -C -------------------------------------------- - CALL DGBFA(WM(3),MEBAND,N,ML,MU,IWM(21),IER) - 240 CONTINUE - RETURN -C ----------------------- END OF SUBROUTINE DPJAC -C ----------------------- - END -*DECK DSLVS - SUBROUTINE DSLVS (WM, IWM, X, TEM) -C***BEGIN PROLOGUE DSLVS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEBDF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (SLVS-S, DSLVS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DSLVS solves the linear system in the iteration scheme for the -C integrator package DDEBDF. -C -C***SEE ALSO DDEBDF -C***ROUTINES CALLED DGBSL, DGESL -C***COMMON BLOCKS DDEBD1 -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C 920422 Changed DIMENSION statement. (WRB) -C***END PROLOGUE DSLVS -C - INTEGER I, IER, IOWND, IOWNS, IWM, JSTART, KFLAG, L, MAXORD, - 1 MEBAND, METH, MITER, ML, MU, N, NFE, NJE, NQ, NQU, NST - DOUBLE PRECISION DI, EL0, H, HL0, HMIN, HMXI, HU, PHL0, - 1 R, ROWND, ROWNS, TEM, TN, UROUND, WM, X - DIMENSION WM(*), IWM(*), X(*), TEM(*) - COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, - 1 IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, - 2 MAXORD,N,NQ,NST,NFE,NJE,NQU -C ------------------------------------------------------------------ -C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING -C FROM A CHORD ITERATION. IT IS CALLED BY DSTOD IF MITER .NE. 0. -C IF MITER IS 1 OR 2, IT CALLS DGESL TO ACCOMPLISH THIS. -C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL -C MATRIX, AND THEN COMPUTES THE SOLUTION. -C IF MITER IS 4 OR 5, IT CALLS DGBSL. -C COMMUNICATION WITH DSLVS USES THE FOLLOWING VARIABLES.. -C WM = DOUBLE PRECISION WORK SPACE CONTAINING THE INVERSE DIAGONAL -C MATRIX IF MITER -C IS 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. -C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). -C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. -C WM(1) = SQRT(UROUND) (NOT USED HERE), -C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = -C 3. -C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING -C AT IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS -C THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS -C 4 OR 5. -C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION -C VECTOR ON OUTPUT, OF LENGTH N. -C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. -C IER = OUTPUT FLAG (IN COMMON). IER = 0 IF NO TROUBLE OCCURRED. -C IER = -1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. -C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. -C----------------------------------------------------------------------- -C BEGIN BLOCK PERMITTING ...EXITS TO 80 -C BEGIN BLOCK PERMITTING ...EXITS TO 60 -C***FIRST EXECUTABLE STATEMENT DSLVS - IER = 0 - GO TO (10,10,20,70,70), MITER - 10 CONTINUE - CALL DGESL(WM(3),N,N,IWM(21),X,0) -C ......EXIT - GO TO 80 -C - 20 CONTINUE - PHL0 = WM(2) - HL0 = H*EL0 - WM(2) = HL0 - IF (HL0 .EQ. PHL0) GO TO 40 - R = HL0/PHL0 - DO 30 I = 1, N - DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2)) -C .........EXIT - IF (ABS(DI) .EQ. 0.0D0) GO TO 60 - WM(I+2) = 1.0D0/DI - 30 CONTINUE - 40 CONTINUE - DO 50 I = 1, N - X(I) = WM(I+2)*X(I) - 50 CONTINUE -C ......EXIT - GO TO 80 - 60 CONTINUE - IER = -1 -C ...EXIT - GO TO 80 -C - 70 CONTINUE - ML = IWM(1) - MU = IWM(2) - MEBAND = 2*ML + MU + 1 - CALL DGBSL(WM(3),MEBAND,N,ML,MU,IWM(21),X,0) - 80 CONTINUE - RETURN -C ----------------------- END OF SUBROUTINE DSLVS -C ----------------------- - END -*DECK DGBFA - SUBROUTINE DGBFA (ABD, LDA, N, ML, MU, IPVT, INFO) -C***BEGIN PROLOGUE DGBFA -C***PURPOSE Factor a band matrix using Gaussian elimination. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2 -C***TYPE DOUBLE PRECISION (SGBFA-S, DGBFA-D, CGBFA-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DGBFA factors a double precision band matrix by elimination. -C -C DGBFA is usually called by DGBCO, but it can be called -C directly with a saving in time if RCOND is not needed. -C -C On Entry -C -C ABD DOUBLE PRECISION(LDA, N) -C contains the matrix in band storage. The columns -C of the matrix are stored in the columns of ABD and -C the diagonals of the matrix are stored in rows -C ML+1 through 2*ML+MU+1 of ABD . -C See the comments below for details. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C LDA must be .GE. 2*ML + MU + 1 . -C -C N INTEGER -C the order of the original matrix. -C -C ML INTEGER -C number of diagonals below the main diagonal. -C 0 .LE. ML .LT. N . -C -C MU INTEGER -C number of diagonals above the main diagonal. -C 0 .LE. MU .LT. N . -C More efficient if ML .LE. MU . -C On Return -C -C ABD an upper triangular matrix in band storage and -C the multipliers which were used to obtain it. -C The factorization can be written A = L*U where -C L is a product of permutation and unit lower -C triangular matrices and U is upper triangular. -C -C IPVT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if U(K,K) .EQ. 0.0 . This is not an error -C condition for this subroutine, but it does -C indicate that DGBSL will divide by zero if -C called. Use RCOND in DGBCO for a reliable -C indication of singularity. -C -C Band Storage -C -C If A is a band matrix, the following program segment -C will set up the input. -C -C ML = (band width below the diagonal) -C MU = (band width above the diagonal) -C M = ML + MU + 1 -C DO 20 J = 1, N -C I1 = MAX(1, J-MU) -C I2 = MIN(N, J+ML) -C DO 10 I = I1, I2 -C K = I - J + M -C ABD(K,J) = A(I,J) -C 10 CONTINUE -C 20 CONTINUE -C -C This uses rows ML+1 through 2*ML+MU+1 of ABD . -C In addition, the first ML rows in ABD are used for -C elements generated during the triangularization. -C The total number of rows needed in ABD is 2*ML+MU+1 . -C The ML+MU by ML+MU upper left triangle and the -C ML by ML lower right triangle are not referenced. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGBFA - INTEGER LDA,N,ML,MU,IPVT(*),INFO - DOUBLE PRECISION ABD(LDA,*) -C - DOUBLE PRECISION T - INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 -C -C***FIRST EXECUTABLE STATEMENT DGBFA - M = ML + MU + 1 - INFO = 0 -C -C ZERO INITIAL FILL-IN COLUMNS -C - J0 = MU + 2 - J1 = MIN(N,M) - 1 - IF (J1 .LT. J0) GO TO 30 - DO 20 JZ = J0, J1 - I0 = M + 1 - JZ - DO 10 I = I0, ML - ABD(I,JZ) = 0.0D0 - 10 CONTINUE - 20 CONTINUE - 30 CONTINUE - JZ = J1 - JU = 0 -C -C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -C - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 130 - DO 120 K = 1, NM1 - KP1 = K + 1 -C -C ZERO NEXT FILL-IN COLUMN -C - JZ = JZ + 1 - IF (JZ .GT. N) GO TO 50 - IF (ML .LT. 1) GO TO 50 - DO 40 I = 1, ML - ABD(I,JZ) = 0.0D0 - 40 CONTINUE - 50 CONTINUE -C -C FIND L = PIVOT INDEX -C - LM = MIN(ML,N-K) - L = IDAMAX(LM+1,ABD(M,K),1) + M - 1 - IPVT(K) = L + K - M -C -C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -C - IF (ABD(L,K) .EQ. 0.0D0) GO TO 100 -C -C INTERCHANGE IF NECESSARY -C - IF (L .EQ. M) GO TO 60 - T = ABD(L,K) - ABD(L,K) = ABD(M,K) - ABD(M,K) = T - 60 CONTINUE -C -C COMPUTE MULTIPLIERS -C - T = -1.0D0/ABD(M,K) - CALL DSCAL(LM,T,ABD(M+1,K),1) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - JU = MIN(MAX(JU,MU+IPVT(K)),N) - MM = M - IF (JU .LT. KP1) GO TO 90 - DO 80 J = KP1, JU - L = L - 1 - MM = MM - 1 - T = ABD(L,J) - IF (L .EQ. MM) GO TO 70 - ABD(L,J) = ABD(MM,J) - ABD(MM,J) = T - 70 CONTINUE - CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) - 80 CONTINUE - 90 CONTINUE - GO TO 110 - 100 CONTINUE - INFO = K - 110 CONTINUE - 120 CONTINUE - 130 CONTINUE - IPVT(N) = N - IF (ABD(M,N) .EQ. 0.0D0) INFO = N - RETURN - END -*DECK DGBSL - SUBROUTINE DGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB) -C***BEGIN PROLOGUE DGBSL -C***PURPOSE Solve the real band system A*X=B or TRANS(A)*X=B using -C the factors computed by DGBCO or DGBFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A2 -C***TYPE DOUBLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C) -C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DGBSL solves the double precision band system -C A * X = B or TRANS(A) * X = B -C using the factors computed by DGBCO or DGBFA. -C -C On Entry -C -C ABD DOUBLE PRECISION(LDA, N) -C the output from DGBCO or DGBFA. -C -C LDA INTEGER -C the leading dimension of the array ABD . -C -C N INTEGER -C the order of the original matrix. -C -C ML INTEGER -C number of diagonals below the main diagonal. -C -C MU INTEGER -C number of diagonals above the main diagonal. -C -C IPVT INTEGER(N) -C the pivot vector from DGBCO or DGBFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C JOB INTEGER -C = 0 to solve A*X = B , -C = nonzero to solve TRANS(A)*X = B , where -C TRANS(A) is the transpose. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero will occur if the input factor contains a -C zero on the diagonal. Technically this indicates singularity -C but it is often caused by improper arguments or improper -C setting of LDA . It will not occur if the subroutines are -C called correctly and if DGBCO has set RCOND .GT. 0.0 -C or DGBFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGBSL - INTEGER LDA,N,ML,MU,IPVT(*),JOB - DOUBLE PRECISION ABD(LDA,*),B(*) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,LA,LB,LM,M,NM1 -C***FIRST EXECUTABLE STATEMENT DGBSL - M = MU + ML + 1 - NM1 = N - 1 - IF (JOB .NE. 0) GO TO 50 -C -C JOB = 0 , SOLVE A * X = B -C FIRST SOLVE L*Y = B -C - IF (ML .EQ. 0) GO TO 30 - IF (NM1 .LT. 1) GO TO 30 - DO 20 K = 1, NM1 - LM = MIN(ML,N-K) - L = IPVT(K) - T = B(L) - IF (L .EQ. K) GO TO 10 - B(L) = B(K) - B(K) = T - 10 CONTINUE - CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) - 20 CONTINUE - 30 CONTINUE -C -C NOW SOLVE U*X = Y -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/ABD(M,K) - LM = MIN(K,M) - 1 - LA = M - LM - LB = K - LM - T = -B(K) - CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, SOLVE TRANS(A) * X = B -C FIRST SOLVE TRANS(U)*Y = B -C - DO 60 K = 1, N - LM = MIN(K,M) - 1 - LA = M - LM - LB = K - LM - T = DDOT(LM,ABD(LA,K),1,B(LB),1) - B(K) = (B(K) - T)/ABD(M,K) - 60 CONTINUE -C -C NOW SOLVE TRANS(L)*X = Y -C - IF (ML .EQ. 0) GO TO 90 - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - LM = MIN(ML,N-K) - B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1) - L = IPVT(K) - IF (L .EQ. K) GO TO 70 - T = B(L) - B(L) = B(K) - B(K) = T - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RETURN - END -*DECK DGEFA - SUBROUTINE DGEFA (A, LDA, N, IPVT, INFO) -C***BEGIN PROLOGUE DGEFA -C***PURPOSE Factor a matrix using Gaussian elimination. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A1 -C***TYPE DOUBLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) -C***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, -C MATRIX FACTORIZATION -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DGEFA factors a double precision matrix by Gaussian elimination. -C -C DGEFA is usually called by DGECO, but it can be called -C directly with a saving in time if RCOND is not needed. -C (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the matrix to be factored. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C On Return -C -C A an upper triangular matrix and the multipliers -C which were used to obtain it. -C The factorization can be written A = L*U where -C L is a product of permutation and unit lower -C triangular matrices and U is upper triangular. -C -C IPVT INTEGER(N) -C an integer vector of pivot indices. -C -C INFO INTEGER -C = 0 normal value. -C = K if U(K,K) .EQ. 0.0 . This is not an error -C condition for this subroutine, but it does -C indicate that DGESL or DGEDI will divide by zero -C if called. Use RCOND in DGECO for a reliable -C indication of singularity. -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGEFA - INTEGER LDA,N,IPVT(*),INFO - DOUBLE PRECISION A(LDA,*) -C - DOUBLE PRECISION T - INTEGER IDAMAX,J,K,KP1,L,NM1 -C -C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING -C -C***FIRST EXECUTABLE STATEMENT DGEFA - INFO = 0 - NM1 = N - 1 - IF (NM1 .LT. 1) GO TO 70 - DO 60 K = 1, NM1 - KP1 = K + 1 -C -C FIND L = PIVOT INDEX -C - L = IDAMAX(N-K+1,A(K,K),1) + K - 1 - IPVT(K) = L -C -C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED -C - IF (A(L,K) .EQ. 0.0D0) GO TO 40 -C -C INTERCHANGE IF NECESSARY -C - IF (L .EQ. K) GO TO 10 - T = A(L,K) - A(L,K) = A(K,K) - A(K,K) = T - 10 CONTINUE -C -C COMPUTE MULTIPLIERS -C - T = -1.0D0/A(K,K) - CALL DSCAL(N-K,T,A(K+1,K),1) -C -C ROW ELIMINATION WITH COLUMN INDEXING -C - DO 30 J = KP1, N - T = A(L,J) - IF (L .EQ. K) GO TO 20 - A(L,J) = A(K,J) - A(K,J) = T - 20 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) - 30 CONTINUE - GO TO 50 - 40 CONTINUE - INFO = K - 50 CONTINUE - 60 CONTINUE - 70 CONTINUE - IPVT(N) = N - IF (A(N,N) .EQ. 0.0D0) INFO = N - RETURN - END -*DECK DGESL - SUBROUTINE DGESL (A, LDA, N, IPVT, B, JOB) -C***BEGIN PROLOGUE DGESL -C***PURPOSE Solve the real system A*X=B or TRANS(A)*X=B using the -C factors computed by DGECO or DGEFA. -C***LIBRARY SLATEC (LINPACK) -C***CATEGORY D2A1 -C***TYPE DOUBLE PRECISION (SGESL-S, DGESL-D, CGESL-C) -C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE -C***AUTHOR Moler, C. B., (U. of New Mexico) -C***DESCRIPTION -C -C DGESL solves the double precision system -C A * X = B or TRANS(A) * X = B -C using the factors computed by DGECO or DGEFA. -C -C On Entry -C -C A DOUBLE PRECISION(LDA, N) -C the output from DGECO or DGEFA. -C -C LDA INTEGER -C the leading dimension of the array A . -C -C N INTEGER -C the order of the matrix A . -C -C IPVT INTEGER(N) -C the pivot vector from DGECO or DGEFA. -C -C B DOUBLE PRECISION(N) -C the right hand side vector. -C -C JOB INTEGER -C = 0 to solve A*X = B , -C = nonzero to solve TRANS(A)*X = B where -C TRANS(A) is the transpose. -C -C On Return -C -C B the solution vector X . -C -C Error Condition -C -C A division by zero will occur if the input factor contains a -C zero on the diagonal. Technically this indicates singularity -C but it is often caused by improper arguments or improper -C setting of LDA . It will not occur if the subroutines are -C called correctly and if DGECO has set RCOND .GT. 0.0 -C or DGEFA has set INFO .EQ. 0 . -C -C To compute INVERSE(A) * C where C is a matrix -C with P columns -C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) -C IF (RCOND is too small) GO TO ... -C DO 10 J = 1, P -C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) -C 10 CONTINUE -C -C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. -C Stewart, LINPACK Users' Guide, SIAM, 1979. -C***ROUTINES CALLED DAXPY, DDOT -C***REVISION HISTORY (YYMMDD) -C 780814 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900326 Removed duplicate information from DESCRIPTION section. -C (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DGESL - INTEGER LDA,N,IPVT(*),JOB - DOUBLE PRECISION A(LDA,*),B(*) -C - DOUBLE PRECISION DDOT,T - INTEGER K,KB,L,NM1 -C***FIRST EXECUTABLE STATEMENT DGESL - NM1 = N - 1 - IF (JOB .NE. 0) GO TO 50 -C -C JOB = 0 , SOLVE A * X = B -C FIRST SOLVE L*Y = B -C - IF (NM1 .LT. 1) GO TO 30 - DO 20 K = 1, NM1 - L = IPVT(K) - T = B(L) - IF (L .EQ. K) GO TO 10 - B(L) = B(K) - B(K) = T - 10 CONTINUE - CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) - 20 CONTINUE - 30 CONTINUE -C -C NOW SOLVE U*X = Y -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL DAXPY(K-1,T,A(1,K),1,B(1),1) - 40 CONTINUE - GO TO 100 - 50 CONTINUE -C -C JOB = NONZERO, SOLVE TRANS(A) * X = B -C FIRST SOLVE TRANS(U)*Y = B -C - DO 60 K = 1, N - T = DDOT(K-1,A(1,K),1,B(1),1) - B(K) = (B(K) - T)/A(K,K) - 60 CONTINUE -C -C NOW SOLVE TRANS(L)*X = Y -C - IF (NM1 .LT. 1) GO TO 90 - DO 80 KB = 1, NM1 - K = N - KB - B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) - L = IPVT(K) - IF (L .EQ. K) GO TO 70 - T = B(L) - B(L) = B(K) - B(K) = T - 70 CONTINUE - 80 CONTINUE - 90 CONTINUE - 100 CONTINUE - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/dderkf.f calculix-ccx-2.3/ccx_2.1/src/dderkf.f --- calculix-ccx-2.1/ccx_2.1/src/dderkf.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dderkf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,4332 +0,0 @@ -*DECK DDERKF - SUBROUTINE DDERKF (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, - + RWORK, LRW, IWORK, LIW, RPAR, IPAR) -C***BEGIN PROLOGUE DDERKF -C***PURPOSE Solve an initial value problem in ordinary differential -C equations using a Runge-Kutta-Fehlberg scheme. -C***LIBRARY SLATEC (DEPAC) -C***CATEGORY I1A1A -C***TYPE DOUBLE PRECISION (DERKF-S, DDERKF-D) -C***KEYWORDS DEPAC, INITIAL VALUE PROBLEMS, ODE, -C ORDINARY DIFFERENTIAL EQUATIONS, RKF, -C RUNGE-KUTTA-FEHLBERG METHODS -C***AUTHOR Watts, H. A., (SNLA) -C Shampine, L. F., (SNLA) -C***DESCRIPTION -C -C This is the Runge-Kutta code in the package of differential equation -C solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. -C Design of the package was by L. F. Shampine and H. A. Watts. -C It is documented in -C SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE -C Solvers. -C DDERKF is a driver for a modification of the code RKF45 written by -C H. A. Watts and L. F. Shampine -C Sandia Laboratories -C Albuquerque, New Mexico 87185 -C -C ********************************************************************** -C ** DDEPAC PACKAGE OVERVIEW ** -C ********************************************************************** -C -C You have a choice of three differential equation solvers from -C DDEPAC. The following brief descriptions are meant to aid you -C in choosing the most appropriate code for your problem. -C -C DDERKF is a fifth order Runge-Kutta code. It is the simplest of -C the three choices, both algorithmically and in the use of the -C code. DDERKF is primarily designed to solve non-stiff and mild- -C ly stiff differential equations when derivative evaluations are -C not expensive. It should generally not be used to get high -C accuracy results nor answers at a great many specific points. -C Because DDERKF has very low overhead costs, it will usually -C result in the least expensive integration when solving -C problems requiring a modest amount of accuracy and having -C equations that are not costly to evaluate. DDERKF attempts to -C discover when it is not suitable for the task posed. -C -C DDEABM is a variable order (one through twelve) Adams code. Its -C complexity lies somewhere between that of DDERKF and DDEBDF. -C DDEABM is primarily designed to solve non-stiff and mildly -C stiff differential equations when derivative evaluations are -C expensive, high accuracy results are needed or answers at -C many specific points are required. DDEABM attempts to discover -C when it is not suitable for the task posed. -C -C DDEBDF is a variable order (one through five) backward -C differentiation formula code. It is the most complicated of -C the three choices. DDEBDF is primarily designed to solve stiff -C differential equations at crude to moderate tolerances. -C If the problem is very stiff at all, DDERKF and DDEABM will be -C quite inefficient compared to DDEBDF. However, DDEBDF will be -C inefficient compared to DDERKF and DDEABM on non-stiff problems -C because it uses much more storage, has a much larger overhead, -C and the low order formulas will not give high accuracies -C efficiently. -C -C The concept of stiffness cannot be described in a few words. -C If you do not know the problem to be stiff, try either DDERKF -C or DDEABM. Both of these codes will inform you of stiffness -C when the cost of solving such problems becomes important. -C -C ********************************************************************** -C ** ABSTRACT ** -C ********************************************************************** -C -C Subroutine DDERKF uses a Runge-Kutta-Fehlberg (4,5) method to -C integrate a system of NEQ first order ordinary differential -C equations of the form -C DU/DX = DF(X,U) -C when the vector Y(*) of initial values for U(*) at X=T is given. -C The subroutine integrates from T to TOUT. It is easy to continue the -C integration to get results at additional TOUT. This is the interval -C mode of operation. It is also easy for the routine to return with -C the solution at each intermediate step on the way to TOUT. This is -C the intermediate-output mode of operation. -C -C DDERKF uses subprograms DRKFS, DFEHL, DHSTRT, DHVNRM, D1MACH, and -C the error handling routine XERMSG. The only machine dependent -C parameters to be assigned appear in D1MACH. -C -C ********************************************************************** -C ** DESCRIPTION OF THE ARGUMENTS TO DDERKF (AN OVERVIEW) ** -C ********************************************************************** -C -C The Parameters are: -C -C DF -- This is the name of a subroutine which you provide to -C define the differential equations. -C -C NEQ -- This is the number of (first order) differential -C equations to be integrated. -C -C T -- This is a DOUBLE PRECISION value of the independent -C variable. -C -C Y(*) -- This DOUBLE PRECISION array contains the solution -C components at T. -C -C TOUT -- This is a DOUBLE PRECISION point at which a solution is -C desired. -C -C INFO(*) -- The basic task of the code is to integrate the -C differential equations from T to TOUT and return an -C answer at TOUT. INFO(*) is an INTEGER array which is used -C to communicate exactly how you want this task to be -C carried out. -C -C RTOL, ATOL -- These DOUBLE PRECISION quantities represent -C relative and absolute error tolerances which you provide -C to indicate how accurately you wish the solution to be -C computed. You may choose them to be both scalars or else -C both vectors. -C -C IDID -- This scalar quantity is an indicator reporting what -C the code did. You must monitor this INTEGER variable to -C decide what action to take next. -C -C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of -C length LRW which provides the code with needed storage -C space. -C -C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW -C which provides the code with needed storage space and an -C across call flag. -C -C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and the DF subroutine. -C -C Quantities which are used as input items are -C NEQ, T, Y(*), TOUT, INFO(*), -C RTOL, ATOL, LRW and LIW. -C -C Quantities which may be altered by the code are -C T, Y(*), INFO(1), RTOL, ATOL, -C IDID, RWORK(*) and IWORK(*). -C -C ********************************************************************** -C ** INPUT -- What to do On The First Call To DDERKF ** -C ********************************************************************** -C -C The first call of the code is defined to be the start of each new -C problem. Read through the descriptions of all the following items, -C provide sufficient storage space for designated arrays, set -C appropriate variables for the initialization of the problem, and -C give information about how you want the problem to be solved. -C -C -C DF -- Provide a subroutine of the form -C DF(X,U,UPRIME,RPAR,IPAR) -C to define the system of first order differential equations -C which is to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=DF(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine DF must not alter X or U(*). You must declare -C the name DF in an external statement in your program that -C calls DDERKF. You must dimension U and UPRIME in DF. -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C calling program and subroutine DF. They are not used or -C altered by DDERKF. If you do not need RPAR or IPAR, -C ignore these parameters by treating them as dummy -C arguments. If you do choose to use them, dimension them in -C your calling program and in DF as arrays of appropriate -C length. -C -C NEQ -- Set it to the number of differential equations. -C (NEQ .GE. 1) -C -C T -- Set it to the initial point of the integration. -C You must use a program variable for T because the code -C changes its value. -C -C Y(*) -- Set this vector to the initial values of the NEQ solution -C components at the initial point. You must dimension Y at -C least NEQ in your calling program. -C -C TOUT -- Set it to the first point at which a solution -C is desired. You can take TOUT = T, in which case the code -C will evaluate the derivative of the solution at T and -C return. Integration either forward in T (TOUT .GT. T) or -C backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using -C step sizes which are automatically selected so as to -C achieve the desired accuracy. If you wish, the code will -C return with the solution and its derivative following -C each intermediate step (intermediate-output mode) so that -C you can monitor them, but you still must provide TOUT in -C accord with the basic aim of the code. -C -C The first step taken by the code is a critical one -C because it must reflect how fast the solution changes near -C the initial point. The code automatically selects an -C initial step size which is practically always suitable for -C the problem. By using the fact that the code will not -C step past TOUT in the first step, you could, if necessary, -C restrict the length of the initial step size. -C -C For some problems it may not be permissible to integrate -C past a point TSTOP because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP. Since DDERKF will never step past a TOUT point, -C you need only make sure that no TOUT lies beyond TSTOP. -C -C INFO(*) -- Use the INFO array to give the code more details about -C how you want your problem solved. This array should be -C dimensioned of length 15 to accommodate other members of -C DEPAC or possible future extensions, though DDERKF uses -C only the first three entries. You must respond to all of -C the following items which are arranged as questions. The -C simplest use of the code corresponds to answering all -C questions as YES ,i.e. setting all entries of INFO to 0. -C -C INFO(1) -- This parameter enables the code to initialize -C itself. You must set it to indicate the start of every -C new problem. -C -C **** Is this the first call for this problem ... -C YES -- Set INFO(1) = 0 -C NO -- Not applicable here. -C See below for continuation calls. **** -C -C INFO(2) -- How much accuracy you want of your solution -C is specified by the error tolerances RTOL and ATOL. -C The simplest use is to take them both to be scalars. -C To obtain more flexibility, they can both be vectors. -C The code must be told your choice. -C -C **** Are both error tolerances RTOL, ATOL scalars ... -C YES -- Set INFO(2) = 0 -C and input scalars for both RTOL and ATOL -C NO -- Set INFO(2) = 1 -C and input arrays for both RTOL and ATOL **** -C -C INFO(3) -- The code integrates from T in the direction -C of TOUT by steps. If you wish, it will return the -C computed solution and derivative at the next -C intermediate step (the intermediate-output mode). -C This is a good way to proceed if you want to see the -C behavior of the solution. If you must have solutions at -C a great many specific TOUT points, this code is -C INEFFICIENT. The code DDEABM in DEPAC handles this task -C more efficiently. -C -C **** Do you want the solution only at -C TOUT (and not at the next intermediate step) ... -C YES -- Set INFO(3) = 0 -C NO -- Set INFO(3) = 1 **** -C -C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you want -C the solution to be computed. They must be defined as -C program variables because the code may change them. You -C have two choices -- -C Both RTOL and ATOL are scalars. (INFO(2)=0) -C Both RTOL and ATOL are vectors. (INFO(2)=1) -C In either case all components must be non-negative. -C -C The tolerances are used by the code in a local error test -C at each step which requires roughly that -C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL -C for each vector component. -C (More specifically, a maximum norm is used to measure -C the size of vectors, and the error test uses the average -C of the magnitude of the solution at the beginning and end -C of the step.) -C -C The true (global) error is the difference between the true -C solution of the initial value problem and the computed -C approximation. Practically all present day codes, -C including this one, control the local error at each step -C and do not even attempt to control the global error -C directly. Roughly speaking, they produce a solution Y(T) -C which satisfies the differential equations with a -C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , -C and, almost always, R(T) is bounded by the error -C tolerances. Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. This -C code will usually, but not always, deliver a more accurate -C solution if you reduce the tolerances and integrate again. -C By comparing two such solutions you can get a fairly -C reliable idea of the true error in the solution at the -C bigger tolerances. -C -C Setting ATOL=0. results in a pure relative error test on -C that component. Setting RTOL=0. yields a pure absolute -C error test on that component. A mixed test with non-zero -C RTOL and ATOL corresponds roughly to a relative error -C test when the solution component is much bigger than ATOL -C and to an absolute error test when the solution component -C is smaller than the threshold ATOL. -C -C Proper selection of the absolute error control parameters -C ATOL requires you to have some idea of the scale of the -C solution components. To acquire this information may mean -C that you will have to solve the problem more than once. In -C the absence of scale information, you should ask for some -C relative accuracy in all the components (by setting RTOL -C values non-zero) and perhaps impose extremely small -C absolute error tolerances to protect against the danger of -C a solution component becoming zero. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It will -C advise you if you ask for too much accuracy and inform -C you as to the maximum accuracy it believes possible. -C If you want relative accuracies smaller than about -C 10**(-8), you should not ordinarily use DDERKF. The code -C DDEABM in DEPAC obtains stringent accuracies more -C efficiently. -C -C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length -C LRW in your calling program. -C -C LRW -- Set it to the declared length of the RWORK array. -C You must have LRW .GE. 33+7*NEQ -C -C IWORK(*) -- Dimension this INTEGER work array of length LIW in -C your calling program. -C -C LIW -- Set it to the declared length of the IWORK array. -C You must have LIW .GE. 34 -C -C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and -C INTEGER type, respectively. You can use them for -C communication between your program that calls DDERKF and -C the DF subroutine. They are not used or altered by -C DDERKF. If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. If you do -C choose to use them, dimension them in your calling program -C and in DF as arrays of appropriate length. -C -C ********************************************************************** -C ** OUTPUT -- After any return from DDERKF ** -C ********************************************************************** -C -C The principal aim of the code is to return a computed solution at -C TOUT, although it is also possible to obtain intermediate results -C along the way. To find out whether the code achieved its goal -C or if the integration process was interrupted before the task was -C completed, you must check the IDID parameter. -C -C -C T -- The solution was successfully advanced to the -C output value of T. -C -C Y(*) -- Contains the computed solution approximation at T. -C You may also be interested in the approximate derivative -C of the solution at T. It is contained in -C RWORK(21),...,RWORK(20+NEQ). -C -C IDID -- Reports what the code did -C -C *** Task Completed *** -C Reported by positive values of IDID -C -C IDID = 1 -- A step was successfully taken in the -C intermediate-output mode. The code has not -C yet reached TOUT. -C -C IDID = 2 -- The integration to TOUT was successfully -C completed (T=TOUT) by stepping exactly to TOUT. -C -C *** Task Interrupted *** -C Reported by negative values of IDID -C -C IDID = -1 -- A large amount of work has been expended. -C (500 steps attempted) -C -C IDID = -2 -- The error tolerances are too stringent. -C -C IDID = -3 -- The local error test cannot be satisfied -C because you specified a zero component in ATOL -C and the corresponding computed solution -C component is zero. Thus, a pure relative error -C test is impossible for this component. -C -C IDID = -4 -- The problem appears to be stiff. -C -C IDID = -5 -- DDERKF is being used very inefficiently -C because the natural step size is being -C restricted by too frequent output. -C -C IDID = -6,-7,..,-32 -- Not applicable for this code but -C used by other members of DEPAC or possible -C future extensions. -C -C *** Task Terminated *** -C Reported by the value of IDID=-33 -C -C IDID = -33 -- The code has encountered trouble from which -C it cannot recover. A message is printed -C explaining the trouble and control is returned -C to the calling program. For example, this -C occurs when invalid input is detected. -C -C RTOL, ATOL -- These quantities remain unchanged except when -C IDID = -2. In this case, the error tolerances have been -C increased by the code to values which are estimated to be -C appropriate for continuing the integration. However, the -C reported solution at T was obtained using the input values -C of RTOL and ATOL. -C -C RWORK, IWORK -- Contain information which is usually of no -C interest to the user but necessary for subsequent calls. -C However, you may find use for -C -C RWORK(11)--which contains the step size H to be -C attempted on the next step. -C -C RWORK(12)--If the tolerances have been increased by the -C code (IDID = -2) , they were multiplied by the -C value in RWORK(12). -C -C RWORK(20+I)--which contains the approximate derivative -C of the solution component Y(I). In DDERKF, it -C is always obtained by calling subroutine DF to -C evaluate the differential equation using T and -C Y(*). -C -C ********************************************************************** -C ** INPUT -- What To Do To Continue The Integration ** -C ** (calls after the first) ** -C ********************************************************************** -C -C This code is organized so that subsequent calls to continue the -C integration involve little (if any) additional effort on your -C part. You must monitor the IDID parameter to determine -C what to do next. -C -C Recalling that the principal task of the code is to integrate -C from T to TOUT (the interval mode), usually all you will need -C to do is specify a new TOUT upon reaching the current TOUT. -C -C Do not alter any quantity not specifically permitted below, -C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or -C the differential equation in subroutine DF. Any such alteration -C constitutes a new problem and must be treated as such, i.e. -C you must start afresh. -C -C You cannot change from vector to scalar error control or vice -C versa (INFO(2)) but you can change the size of the entries of -C RTOL, ATOL. Increasing a tolerance makes the equation easier -C to integrate. Decreasing a tolerance will make the equation -C harder to integrate and should generally be avoided. -C -C You can switch from the intermediate-output mode to the -C interval mode (INFO(3)) or vice versa at any time. -C -C The parameter INFO(1) is used by the code to indicate the -C beginning of a new problem and to indicate whether integration -C is to be continued. You must input the value INFO(1) = 0 -C when starting a new problem. You must input the value -C INFO(1) = 1 if you wish to continue after an interrupted task. -C Do not set INFO(1) = 0 on a continuation call unless you -C want the code to restart at the current T. -C -C *** Following a Completed Task *** -C If -C IDID = 1, call the code again to continue the integration -C another step in the direction of TOUT. -C -C IDID = 2, define a new TOUT and call the code again. -C TOUT must be different from T. You cannot change -C the direction of integration without restarting. -C -C *** Following an Interrupted Task *** -C To show the code that you realize the task was -C interrupted and that you want to continue, you -C must take appropriate action and reset INFO(1) = 1 -C If -C IDID = -1, the code has attempted 500 steps. -C If you want to continue, set INFO(1) = 1 and -C call the code again. An additional 500 steps -C will be allowed. -C -C IDID = -2, the error tolerances RTOL, ATOL have been -C increased to values the code estimates appropriate -C for continuing. You may want to change them -C yourself. If you are sure you want to continue -C with relaxed error tolerances, set INFO(1)=1 and -C call the code again. -C -C IDID = -3, a solution component is zero and you set the -C corresponding component of ATOL to zero. If you -C are sure you want to continue, you must first -C alter the error criterion to use positive values -C for those components of ATOL corresponding to zero -C solution components, then set INFO(1)=1 and call -C the code again. -C -C IDID = -4, the problem appears to be stiff. It is very -C inefficient to solve such problems with DDERKF. -C The code DDEBDF in DEPAC handles this task -C efficiently. If you are absolutely sure you want -C to continue with DDERKF, set INFO(1)=1 and call -C the code again. -C -C IDID = -5, you are using DDERKF very inefficiently by -C choosing output points TOUT so close together that -C the step size is repeatedly forced to be rather -C smaller than necessary. If you are willing to -C accept solutions at the steps chosen by the code, -C a good way to proceed is to use the intermediate -C output mode (setting INFO(3)=1). If you must have -C solutions at so many specific TOUT points, the -C code DDEABM in DEPAC handles this task -C efficiently. If you want to continue with DDERKF, -C set INFO(1)=1 and call the code again. -C -C IDID = -6,-7,..,-32 --- cannot occur with this code but -C used by other members of DEPAC or possible future -C extensions. -C -C *** Following a Terminated Task *** -C If -C IDID = -33, you cannot continue the solution of this -C problem. An attempt to do so will result in your -C run being terminated. -C -C ********************************************************************** -C *Long Description: -C -C ********************************************************************** -C ** DEPAC Package Overview ** -C ********************************************************************** -C -C .... You have a choice of three differential equation solvers from -C .... DEPAC. The following brief descriptions are meant to aid you in -C .... choosing the most appropriate code for your problem. -C -C .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of -C .... the three choices, both algorithmically and in the use of the -C .... code. DDERKF is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are not expensive. It should generally not be used to get high -C .... accuracy results nor answers at a great many specific points. -C .... Because DDERKF has very low overhead costs, it will usually -C .... result in the least expensive integration when solving -C .... problems requiring a modest amount of accuracy and having -C .... equations that are not costly to evaluate. DDERKF attempts to -C .... discover when it is not suitable for the task posed. -C -C .... DDEABM is a variable order (one through twelve) Adams code. -C .... Its complexity lies somewhere between that of DDERKF and -C .... DDEBDF. DDEABM is primarily designed to solve non-stiff and -C .... mildly stiff differential equations when derivative evaluations -C .... are expensive, high accuracy results are needed or answers at -C .... many specific points are required. DDEABM attempts to discover -C .... when it is not suitable for the task posed. -C -C .... DDEBDF is a variable order (one through five) backward -C .... differentiation formula code. it is the most complicated of -C .... the three choices. DDEBDF is primarily designed to solve stiff -C .... differential equations at crude to moderate tolerances. -C .... If the problem is very stiff at all, DDERKF and DDEABM will be -C .... quite inefficient compared to DDEBDF. However, DDEBDF will be -C .... inefficient compared to DDERKF and DDEABM on non-stiff problems -C .... because it uses much more storage, has a much larger overhead, -C .... and the low order formulas will not give high accuracies -C .... efficiently. -C -C .... The concept of stiffness cannot be described in a few words. -C .... If you do not know the problem to be stiff, try either DDERKF -C .... or DDEABM. Both of these codes will inform you of stiffness -C .... when the cost of solving such problems becomes important. -C -C ********************************************************************* -C -C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user -C oriented package of ODE solvers, Report SAND79-2374, -C Sandia Laboratories, 1979. -C L. F. Shampine and H. A. Watts, Practical solution of -C ordinary differential equations by Runge-Kutta -C methods, Report SAND76-0585, Sandia Laboratories, -C 1976. -C***ROUTINES CALLED DRKFS, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900510 Convert XERRWV calls to XERMSG calls, make Prologue comments -C consistent with DERKF. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DDERKF -C - INTEGER IDID, INFO, IPAR, IWORK, KDI, KF1, KF2, KF3, KF4, KF5, - 1 KH, KRER, KTF, KTO, KTSTAR, KU, KYP, KYS, LIW, LRW, NEQ - DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y - LOGICAL STIFF,NONSTF -C - DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), - 1 RPAR(*),IPAR(*) - CHARACTER*8 XERN1 - CHARACTER*16 XERN3 -C - EXTERNAL DF -C -C CHECK FOR AN APPARENT INFINITE LOOP -C -C***FIRST EXECUTABLE STATEMENT DDERKF - IF (INFO(1) .EQ. 0) IWORK(LIW) = 0 - IF (IWORK(LIW) .GE. 5) THEN - IF (T .EQ. RWORK(21+NEQ)) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DDERKF', - * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // - * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // - * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // - * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // - * 'CODE, PARTICULARLY INFO(1).', 13, 2) - RETURN - ENDIF - ENDIF -C -C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION -C - IDID = 0 - IF (LRW .LT. 30 + 7*NEQ) THEN - WRITE (XERN1, '(I8)') LRW - CALL XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF RWORK ARRAY ' // - * 'MUST BE AT LEAST 30 + 7*NEQ. YOU HAVE CALLED THE ' // - * 'CODE WITH LRW = ' // XERN1, 1, 1) - IDID = -33 - ENDIF -C - IF (LIW .LT. 34) THEN - WRITE (XERN1, '(I8)') LIW - CALL XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF IWORK ARRAY ' // - * 'MUST BE AT LEAST 34. YOU HAVE CALLED THE CODE WITH ' // - * 'LIW = ' // XERN1, 2, 1) - IDID = -33 - ENDIF -C -C COMPUTE INDICES FOR THE SPLITTING OF THE RWORK ARRAY -C - KH = 11 - KTF = 12 - KYP = 21 - KTSTAR = KYP + NEQ - KF1 = KTSTAR + 1 - KF2 = KF1 + NEQ - KF3 = KF2 + NEQ - KF4 = KF3 + NEQ - KF5 = KF4 + NEQ - KYS = KF5 + NEQ - KTO = KYS + NEQ - KDI = KTO + 1 - KU = KDI + 1 - KRER = KU + 1 -C -C ********************************************************************** -C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG -C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE -C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, -C S/HE MUST USE DRKFS DIRECTLY. -C ********************************************************************** -C - RWORK(KTSTAR) = T - IF (INFO(1) .NE. 0) THEN - STIFF = (IWORK(25) .EQ. 0) - NONSTF = (IWORK(26) .EQ. 0) - ENDIF -C - CALL DRKFS(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(KH), - 1 RWORK(KTF),RWORK(KYP),RWORK(KF1),RWORK(KF2),RWORK(KF3), - 2 RWORK(KF4),RWORK(KF5),RWORK(KYS),RWORK(KTO),RWORK(KDI), - 3 RWORK(KU),RWORK(KRER),IWORK(21),IWORK(22),IWORK(23), - 4 IWORK(24),STIFF,NONSTF,IWORK(27),IWORK(28),RPAR,IPAR) -C - IWORK(25) = 1 - IF (STIFF) IWORK(25) = 0 - IWORK(26) = 1 - IF (NONSTF) IWORK(26) = 0 -C - IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 - IF (T .NE. RWORK(KTSTAR)) IWORK(LIW) = 0 -C - RETURN - END -*DECK DRKFS - SUBROUTINE DRKFS (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, H, - + TOLFAC, YP, F1, F2, F3, F4, F5, YS, TOLD, DTSIGN, U26, RER, - + INIT, KSTEPS, KOP, IQUIT, STIFF, NONSTF, NTSTEP, NSTIFS, RPAR, - + IPAR) -C***BEGIN PROLOGUE DRKFS -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (DERKFS-S, DRKFS-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Fehlberg Fourth-Fifth Order Runge-Kutta Method -C ********************************************************************** -C -C DRKFS integrates a system of first order ordinary differential -C equations as described in the comments for DDERKF . -C -C The arrays YP,F1,F2,F3,F4,F5,and YS (of length at least NEQ) -C appear in the call list for variable dimensioning purposes. -C -C The variables H,TOLFAC,TOLD,DTSIGN,U26,RER,INIT,KSTEPS,KOP,IQUIT, -C STIFF,NONSTF,NTSTEP, and NSTIFS are used internally by the code -C and appear in the call list to eliminate local retention of -C variables between calls. Accordingly, these variables and the -C array YP should not be altered. -C Items of possible interest are -C H - An appropriate step size to be used for the next step -C TOLFAC - Factor of change in the tolerances -C YP - Derivative of solution vector at T -C KSTEPS - Counter on the number of steps attempted -C -C ********************************************************************** -C -C***SEE ALSO DDERKF -C***ROUTINES CALLED D1MACH, DFEHL, DHSTRT, DHVNRM, XERMSG -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 900510 Convert XERRWV calls to XERMSG calls, change GOTOs to -C IF-THEN-ELSEs. (RWC) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DRKFS -C - INTEGER IDID, INFO, INIT, IPAR, IQUIT, K, KOP, KSTEPS, KTOL, - 1 MXKOP, MXSTEP, NATOLP, NEQ, NRTOLP, NSTIFS, NTSTEP - DOUBLE PRECISION A, ATOL, BIG, D1MACH, - 1 DT, DTSIGN, DHVNRM, DY, EE, EEOET, ES, ESTIFF, - 2 ESTTOL, ET, F1, F2, F3, F4, F5, H, HMIN, REMIN, RER, RPAR, - 3 RTOL, S, T, TOL, TOLD, TOLFAC, TOUT, U, U26, UTE, Y, YAVG, - 4 YP, YS - LOGICAL HFAILD,OUTPUT,STIFF,NONSTF - CHARACTER*8 XERN1 - CHARACTER*16 XERN3, XERN4 -C - DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), - 1 YS(*),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) -C - EXTERNAL DF -C -C .................................................................. -C -C A FIFTH ORDER METHOD WILL GENERALLY NOT BE CAPABLE OF DELIVERING -C ACCURACIES NEAR LIMITING PRECISION ON COMPUTERS WITH LONG -C WORDLENGTHS. TO PROTECT AGAINST LIMITING PRECISION DIFFICULTIES -C ARISING FROM UNREASONABLE ACCURACY REQUESTS, AN APPROPRIATE -C TOLERANCE THRESHOLD REMIN IS ASSIGNED FOR THIS METHOD. THIS -C VALUE SHOULD NOT BE CHANGED ACROSS DIFFERENT MACHINES. -C - SAVE REMIN, MXSTEP, MXKOP - DATA REMIN /1.0D-12/ -C -C .................................................................. -C -C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE -C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MXSTEP, THE -C COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE -C EXCESSIVE WORK. -C - DATA MXSTEP /500/ -C -C .................................................................. -C -C INEFFICIENCY CAUSED BY TOO FREQUENT OUTPUT IS MONITORED BY -C COUNTING THE NUMBER OF STEP SIZES WHICH ARE SEVERELY SHORTENED -C DUE SOLELY TO THE CHOICE OF OUTPUT POINTS. WHEN THE NUMBER OF -C ABUSES EXCEED MXKOP, THE COUNTER IS RESET TO ZERO AND THE USER -C IS INFORMED ABOUT POSSIBLE MISUSE OF THE CODE. -C - DATA MXKOP /100/ -C -C .................................................................. -C -C***FIRST EXECUTABLE STATEMENT DRKFS - IF (INFO(1) .EQ. 0) THEN -C -C ON THE FIRST CALL , PERFORM INITIALIZATION -- -C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE -C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE -C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. -C - U = D1MACH(4) -C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS - U26 = 26.0D0*U - RER = 2.0D0*U + REMIN -C -- SET TERMINATION FLAG - IQUIT = 0 -C -- SET INITIALIZATION INDICATOR - INIT = 0 -C -- SET COUNTER FOR IMPACT OF OUTPUT POINTS - KOP = 0 -C -- SET COUNTER FOR ATTEMPTED STEPS - KSTEPS = 0 -C -- SET INDICATORS FOR STIFFNESS DETECTION - STIFF = .FALSE. - NONSTF = .FALSE. -C -- SET STEP COUNTERS FOR STIFFNESS DETECTION - NTSTEP = 0 - NSTIFS = 0 -C -- RESET INFO(1) FOR SUBSEQUENT CALLS - INFO(1) = 1 - ENDIF -C -C....................................................................... -C -C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY -C - IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(1) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, INFO(1) MUST BE SET TO 0 ' // - * 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // - * 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // - * 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE CODE ' // - * 'WITH INFO(1) = ' // XERN1, 3, 1) - IDID = -33 - ENDIF -C - IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(2) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, INFO(2) MUST BE 0 OR 1 ' // - * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // - * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // - * XERN1, 4, 1) - IDID = -33 - ENDIF -C - IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN - WRITE (XERN1, '(I8)') INFO(3) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, INFO(3) MUST BE 0 OR 1 ' // - * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // - * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // - * 'WITH INFO(3) = ' // XERN1, 5, 1) - IDID = -33 - ENDIF -C - IF (NEQ .LT. 1) THEN - WRITE (XERN1, '(I8)') NEQ - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, THE NUMBER OF EQUATIONS ' // - * 'NEQ MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // - * 'CODE WITH NEQ = ' // XERN1, 6, 1) - IDID = -33 - ENDIF -C - NRTOLP = 0 - NATOLP = 0 - DO 10 K=1,NEQ - IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') RTOL(K) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, THE RELATIVE ERROR ' // - * 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) - IDID = -33 - NRTOLP = 1 - ENDIF -C - IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN - WRITE (XERN1, '(I8)') K - WRITE (XERN3, '(1PE15.6)') ATOL(K) - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, THE ABSOLUTE ERROR ' // - * 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // - * 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // - * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // - * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) - IDID = -33 - NATOLP = 1 - ENDIF -C - IF (INFO(2) .EQ. 0) GO TO 20 - IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 20 - 10 CONTINUE -C -C -C CHECK SOME CONTINUATION POSSIBILITIES -C - 20 IF (INIT .NE. 0) THEN - IF (T .EQ. TOUT) THEN - WRITE (XERN3, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, YOU HAVE CALLED THE ' // - * 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // - * 'ALLOWED ON CONTINUATION CALLS.', 9, 1) - IDID=-33 - ENDIF -C - IF (T .NE. TOLD) THEN - WRITE (XERN3, '(1PE15.6)') TOLD - WRITE (XERN4, '(1PE15.6)') T - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, YOU HAVE CHANGED THE ' // - * 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // - * '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) - IDID=-33 - ENDIF -C - IF (INIT .NE. 1) THEN - IF (DTSIGN*(TOUT-T) .LT. 0.D0) THEN - WRITE (XERN3, '(1PE15.6)') TOUT - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, BY CALLING THE CODE WITH TOUT = ' // - * XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // - * 'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' // - * 'WITHOUT RESTARTING.', 11, 1) - IDID=-33 - ENDIF - ENDIF - ENDIF -C -C INVALID INPUT DETECTED -C - IF (IDID .EQ. (-33)) THEN - IF (IQUIT .NE. (-33)) THEN - IQUIT = -33 - GOTO 540 - ELSE - CALL XERMSG ('SLATEC', 'DRKFS', - * 'IN DDERKF, INVALID INPUT WAS ' // - * 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // - * 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // - * 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) - RETURN - ENDIF - ENDIF -C -C ............................................................ -C -C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND -C INTERPRETED AS ASKING FOR THE MOST ACCURATE SOLUTION -C POSSIBLE. IN THIS CASE, THE RELATIVE ERROR TOLERANCE -C RTOL IS RESET TO THE SMALLEST VALUE RER WHICH IS LIKELY -C TO BE REASONABLE FOR THIS METHOD AND MACHINE. -C - DO 190 K = 1, NEQ - IF (RTOL(K) + ATOL(K) .GT. 0.0D0) GO TO 180 - RTOL(K) = RER - IDID = -2 - 180 CONTINUE -C ...EXIT - IF (INFO(2) .EQ. 0) GO TO 200 - 190 CONTINUE - 200 CONTINUE -C - IF (IDID .NE. (-2)) GO TO 210 -C -C RTOL=ATOL=0 ON INPUT, SO RTOL WAS CHANGED TO A -C SMALL POSITIVE VALUE - TOLFAC = 1.0D0 - GO TO 530 - 210 CONTINUE -C -C BRANCH ON STATUS OF INITIALIZATION INDICATOR -C INIT=0 MEANS INITIAL DERIVATIVES AND -C STARTING STEP SIZE -C NOT YET COMPUTED -C INIT=1 MEANS STARTING STEP SIZE NOT YET -C COMPUTED INIT=2 MEANS NO FURTHER -C INITIALIZATION REQUIRED -C - IF (INIT .EQ. 0) GO TO 220 -C ......EXIT - IF (INIT .EQ. 1) GO TO 240 -C .........EXIT - GO TO 260 - 220 CONTINUE -C -C ................................................ -C -C MORE INITIALIZATION -- -C -- EVALUATE INITIAL -C DERIVATIVES -C - INIT = 1 - A = T - CALL DF(A,Y,YP,RPAR,IPAR) - IF (T .NE. TOUT) GO TO 230 -C -C INTERVAL MODE - IDID = 2 - T = TOUT - TOLD = T -C .....................EXIT - GO TO 560 - 230 CONTINUE - 240 CONTINUE -C -C -- SET SIGN OF INTEGRATION DIRECTION AND -C -- ESTIMATE STARTING STEP SIZE -C - INIT = 2 - DTSIGN = SIGN(1.0D0,TOUT-T) - U = D1MACH(4) - BIG = SQRT(D1MACH(2)) - UTE = U**0.375D0 - DY = UTE*DHVNRM(Y,NEQ) - IF (DY .EQ. 0.0D0) DY = UTE - KTOL = 1 - DO 250 K = 1, NEQ - IF (INFO(2) .EQ. 1) KTOL = K - TOL = RTOL(KTOL)*ABS(Y(K)) + ATOL(KTOL) - IF (TOL .EQ. 0.0D0) TOL = DY*RTOL(KTOL) - F1(K) = TOL - 250 CONTINUE -C - CALL DHSTRT(DF,NEQ,T,TOUT,Y,YP,F1,4,U,BIG,F2,F3,F4, - 1 F5,RPAR,IPAR,H) - 260 CONTINUE -C -C ...................................................... -C -C SET STEP SIZE FOR INTEGRATION IN THE DIRECTION -C FROM T TO TOUT AND SET OUTPUT POINT INDICATOR -C - DT = TOUT - T - H = SIGN(H,DT) - OUTPUT = .FALSE. -C -C TEST TO SEE IF DDERKF IS BEING SEVERELY IMPACTED BY -C TOO MANY OUTPUT POINTS -C - IF (ABS(H) .GE. 2.0D0*ABS(DT)) KOP = KOP + 1 - IF (KOP .LE. MXKOP) GO TO 270 -C -C UNNECESSARY FREQUENCY OF OUTPUT IS RESTRICTING -C THE STEP SIZE CHOICE - IDID = -5 - KOP = 0 - GO TO 510 - 270 CONTINUE -C - IF (ABS(DT) .GT. U26*ABS(T)) GO TO 290 -C -C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND -C RETURN -C - DO 280 K = 1, NEQ - Y(K) = Y(K) + DT*YP(K) - 280 CONTINUE - A = TOUT - CALL DF(A,Y,YP,RPAR,IPAR) - KSTEPS = KSTEPS + 1 - GO TO 500 - 290 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 490 -C -C ********************************************* -C ********************************************* -C STEP BY STEP INTEGRATION -C - 300 CONTINUE -C BEGIN BLOCK PERMITTING ...EXITS TO 480 - HFAILD = .FALSE. -C -C TO PROTECT AGAINST IMPOSSIBLE ACCURACY -C REQUESTS, COMPUTE A TOLERANCE FACTOR -C BASED ON THE REQUESTED ERROR TOLERANCE -C AND A LEVEL OF ACCURACY ACHIEVABLE AT -C LIMITING PRECISION -C - TOLFAC = 0.0D0 - KTOL = 1 - DO 330 K = 1, NEQ - IF (INFO(2) .EQ. 1) KTOL = K - ET = RTOL(KTOL)*ABS(Y(K)) - 1 + ATOL(KTOL) - IF (ET .GT. 0.0D0) GO TO 310 - TOLFAC = MAX(TOLFAC, - 1 RER/RTOL(KTOL)) - GO TO 320 - 310 CONTINUE - TOLFAC = MAX(TOLFAC, - 1 ABS(Y(K)) - 2 *(RER/ET)) - 320 CONTINUE - 330 CONTINUE - IF (TOLFAC .LE. 1.0D0) GO TO 340 -C -C REQUESTED ERROR UNATTAINABLE DUE TO LIMITED -C PRECISION AVAILABLE - TOLFAC = 2.0D0*TOLFAC - IDID = -2 -C .....................EXIT - GO TO 520 - 340 CONTINUE -C -C SET SMALLEST ALLOWABLE STEP SIZE -C - HMIN = U26*ABS(T) -C -C ADJUST STEP SIZE IF NECESSARY TO HIT -C THE OUTPUT POINT -- LOOK AHEAD TWO -C STEPS TO AVOID DRASTIC CHANGES IN THE -C STEP SIZE AND THUS LESSEN THE IMPACT OF -C OUTPUT POINTS ON THE CODE. STRETCH THE -C STEP SIZE BY, AT MOST, AN AMOUNT EQUAL -C TO THE SAFETY FACTOR OF 9/10. -C - DT = TOUT - T - IF (ABS(DT) .GE. 2.0D0*ABS(H)) - 1 GO TO 370 - IF (ABS(DT) .GT. ABS(H)/0.9D0) - 1 GO TO 350 -C -C THE NEXT STEP, IF SUCCESSFUL, -C WILL COMPLETE THE INTEGRATION TO -C THE OUTPUT POINT -C - OUTPUT = .TRUE. - H = DT - GO TO 360 - 350 CONTINUE -C - H = 0.5D0*DT - 360 CONTINUE - 370 CONTINUE -C -C -C *************************************** -C CORE INTEGRATOR FOR TAKING A -C SINGLE STEP -C *************************************** -C TO AVOID PROBLEMS WITH ZERO -C CROSSINGS, RELATIVE ERROR IS -C MEASURED USING THE AVERAGE OF THE -C MAGNITUDES OF THE SOLUTION AT THE -C BEGINNING AND END OF A STEP. -C THE ERROR ESTIMATE FORMULA HAS -C BEEN GROUPED TO CONTROL LOSS OF -C SIGNIFICANCE. -C LOCAL ERROR ESTIMATES FOR A FIRST -C ORDER METHOD USING THE SAME -C STEP SIZE AS THE FEHLBERG METHOD -C ARE CALCULATED AS PART OF THE -C TEST FOR STIFFNESS. -C TO DISTINGUISH THE VARIOUS -C ARGUMENTS, H IS NOT PERMITTED -C TO BECOME SMALLER THAN 26 UNITS OF -C ROUNDOFF IN T. PRACTICAL LIMITS -C ON THE CHANGE IN THE STEP SIZE ARE -C ENFORCED TO SMOOTH THE STEP SIZE -C SELECTION PROCESS AND TO AVOID -C EXCESSIVE CHATTERING ON PROBLEMS -C HAVING DISCONTINUITIES. TO -C PREVENT UNNECESSARY FAILURES, THE -C CODE USES 9/10 THE STEP SIZE -C IT ESTIMATES WILL SUCCEED. -C AFTER A STEP FAILURE, THE STEP -C SIZE IS NOT ALLOWED TO INCREASE -C FOR THE NEXT ATTEMPTED STEP. THIS -C MAKES THE CODE MORE EFFICIENT ON -C PROBLEMS HAVING DISCONTINUITIES -C AND MORE EFFECTIVE IN GENERAL -C SINCE LOCAL EXTRAPOLATION IS BEING -C USED AND EXTRA CAUTION SEEMS -C WARRANTED. -C ....................................... -C -C MONITOR NUMBER OF STEPS ATTEMPTED -C - 380 CONTINUE - IF (KSTEPS .LE. MXSTEP) GO TO 390 -C -C A SIGNIFICANT AMOUNT OF WORK HAS -C BEEN EXPENDED - IDID = -1 - KSTEPS = 0 -C ........................EXIT - IF (.NOT.STIFF) GO TO 520 -C -C PROBLEM APPEARS TO BE STIFF - IDID = -4 - STIFF = .FALSE. - NONSTF = .FALSE. - NTSTEP = 0 - NSTIFS = 0 -C ........................EXIT - GO TO 520 - 390 CONTINUE -C -C ADVANCE AN APPROXIMATE SOLUTION OVER -C ONE STEP OF LENGTH H -C - CALL DFEHL(DF,NEQ,T,Y,H,YP,F1,F2,F3, - 1 F4,F5,YS,RPAR,IPAR) - KSTEPS = KSTEPS + 1 -C -C .................................... -C -C COMPUTE AND TEST ALLOWABLE -C TOLERANCES VERSUS LOCAL ERROR -C ESTIMATES. NOTE THAT RELATIVE -C ERROR IS MEASURED WITH RESPECT -C TO THE AVERAGE OF THE -C MAGNITUDES OF THE SOLUTION AT -C THE BEGINNING AND END OF THE -C STEP. LOCAL ERROR ESTIMATES -C FOR A SPECIAL FIRST ORDER -C METHOD ARE CALCULATED ONLY WHEN -C THE STIFFNESS DETECTION IS -C TURNED ON. -C - EEOET = 0.0D0 - ESTIFF = 0.0D0 - KTOL = 1 - DO 420 K = 1, NEQ - YAVG = 0.5D0 - 1 *(ABS(Y(K)) - 2 + ABS(YS(K))) - IF (INFO(2) .EQ. 1) KTOL = K - ET = RTOL(KTOL)*YAVG + ATOL(KTOL) - IF (ET .GT. 0.0D0) GO TO 400 -C -C PURE RELATIVE ERROR INAPPROPRIATE WHEN SOLUTION -C VANISHES - IDID = -3 -C ...........................EXIT - GO TO 520 - 400 CONTINUE -C - EE = ABS((-2090.0D0*YP(K) - 1 +(21970.0D0*F3(K) - 2 -15048.0D0*F4(K))) - 3 +(22528.0D0*F2(K) - 4 -27360.0D0*F5(K))) - IF (STIFF .OR. NONSTF) GO TO 410 - ES = ABS(H - 1 *(0.055455D0*YP(K) - 2 -0.035493D0*F1(K) - 3 -0.036571D0*F2(K) - 4 +0.023107D0*F3(K) - 5 -0.009515D0*F4(K) - 6 +0.003017D0*F5(K)) - 7 ) - ESTIFF = MAX(ESTIFF,ES/ET) - 410 CONTINUE - EEOET = MAX(EEOET,EE/ET) - 420 CONTINUE -C - ESTTOL = ABS(H)*EEOET/752400.0D0 -C -C ...EXIT - IF (ESTTOL .LE. 1.0D0) GO TO 440 -C -C .................................... -C -C UNSUCCESSFUL STEP -C - IF (ABS(H) .GT. HMIN) GO TO 430 -C -C REQUESTED ERROR UNATTAINABLE AT SMALLEST -C ALLOWABLE STEP SIZE - TOLFAC = 1.69D0*ESTTOL - IDID = -2 -C ........................EXIT - GO TO 520 - 430 CONTINUE -C -C REDUCE THE STEP SIZE , TRY AGAIN -C THE DECREASE IS LIMITED TO A FACTOR -C OF 1/10 -C - HFAILD = .TRUE. - OUTPUT = .FALSE. - S = 0.1D0 - IF (ESTTOL .LT. 59049.0D0) - 1 S = 0.9D0/ESTTOL**0.2D0 - H = SIGN(MAX(S*ABS(H),HMIN),H) - GO TO 380 - 440 CONTINUE -C -C ....................................... -C -C SUCCESSFUL STEP -C STORE SOLUTION AT T+H -C AND EVALUATE -C DERIVATIVES THERE -C - T = T + H - DO 450 K = 1, NEQ - Y(K) = YS(K) - 450 CONTINUE - A = T - CALL DF(A,Y,YP,RPAR,IPAR) -C -C CHOOSE NEXT STEP SIZE -C THE INCREASE IS LIMITED TO A FACTOR OF -C 5 IF STEP FAILURE HAS JUST OCCURRED, -C NEXT -C STEP SIZE IS NOT ALLOWED TO INCREASE -C - S = 5.0D0 - IF (ESTTOL .GT. 1.889568D-4) - 1 S = 0.9D0/ESTTOL**0.2D0 - IF (HFAILD) S = MIN(S,1.0D0) - H = SIGN(MAX(S*ABS(H),HMIN),H) -C -C ....................................... -C -C CHECK FOR STIFFNESS (IF NOT -C ALREADY DETECTED) -C -C IN A SEQUENCE OF 50 SUCCESSFUL -C STEPS BY THE FEHLBERG METHOD, 25 -C SUCCESSFUL STEPS BY THE FIRST -C ORDER METHOD INDICATES STIFFNESS -C AND TURNS THE TEST OFF. IF 26 -C FAILURES BY THE FIRST ORDER METHOD -C OCCUR, THE TEST IS TURNED OFF -C UNTIL THIS SEQUENCE OF 50 STEPS BY -C THE FEHLBERG METHOD IS COMPLETED. -C -C ...EXIT - IF (STIFF) GO TO 480 - NTSTEP = MOD(NTSTEP+1,50) - IF (NTSTEP .EQ. 1) NONSTF = .FALSE. -C ...EXIT - IF (NONSTF) GO TO 480 - IF (ESTIFF .GT. 1.0D0) GO TO 460 -C -C SUCCESSFUL STEP WITH FIRST ORDER -C METHOD - NSTIFS = NSTIFS + 1 -C TURN TEST OFF AFTER 25 INDICATIONS -C OF STIFFNESS - IF (NSTIFS .EQ. 25) STIFF = .TRUE. - GO TO 470 - 460 CONTINUE -C -C UNSUCCESSFUL STEP WITH FIRST ORDER -C METHOD - IF (NTSTEP - NSTIFS .LE. 25) GO TO 470 -C TURN STIFFNESS DETECTION OFF FOR THIS BLOCK OF -C FIFTY STEPS - NONSTF = .TRUE. -C RESET STIFF STEP COUNTER - NSTIFS = 0 - 470 CONTINUE - 480 CONTINUE -C -C ****************************************** -C END OF CORE INTEGRATOR -C ****************************************** -C -C -C SHOULD WE TAKE ANOTHER STEP -C -C ......EXIT - IF (OUTPUT) GO TO 490 - IF (INFO(3) .EQ. 0) GO TO 300 -C -C ********************************************* -C ********************************************* -C -C INTEGRATION SUCCESSFULLY COMPLETED -C -C ONE-STEP MODE - IDID = 1 - TOLD = T -C .....................EXIT - GO TO 560 - 490 CONTINUE - 500 CONTINUE -C -C INTERVAL MODE - IDID = 2 - T = TOUT - TOLD = T -C ...............EXIT - GO TO 560 - 510 CONTINUE - 520 CONTINUE - 530 CONTINUE - 540 CONTINUE -C -C INTEGRATION TASK INTERRUPTED -C - INFO(1) = -1 - TOLD = T -C ...EXIT - IF (IDID .NE. (-2)) GO TO 560 -C -C THE ERROR TOLERANCES ARE INCREASED TO VALUES -C WHICH ARE APPROPRIATE FOR CONTINUING - RTOL(1) = TOLFAC*RTOL(1) - ATOL(1) = TOLFAC*ATOL(1) -C ...EXIT - IF (INFO(2) .EQ. 0) GO TO 560 - DO 550 K = 2, NEQ - RTOL(K) = TOLFAC*RTOL(K) - ATOL(K) = TOLFAC*ATOL(K) - 550 CONTINUE - 560 CONTINUE - RETURN - END -*DECK XERMSG - SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) -C***BEGIN PROLOGUE XERMSG -C***PURPOSE Process error messages for SLATEC and other libraries. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERMSG-A) -C***KEYWORDS ERROR MESSAGE, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C XERMSG processes a diagnostic message in a manner determined by the -C value of LEVEL and the current value of the library error control -C flag, KONTRL. See subroutine XSETF for details. -C -C LIBRAR A character constant (or character variable) with the name -C of the library. This will be 'SLATEC' for the SLATEC -C Common Math Library. The error handling package is -C general enough to be used by many libraries -C simultaneously, so it is desirable for the routine that -C detects and reports an error to identify the library name -C as well as the routine name. -C -C SUBROU A character constant (or character variable) with the name -C of the routine that detected the error. Usually it is the -C name of the routine that is calling XERMSG. There are -C some instances where a user callable library routine calls -C lower level subsidiary routines where the error is -C detected. In such cases it may be more informative to -C supply the name of the routine the user called rather than -C the name of the subsidiary routine that detected the -C error. -C -C MESSG A character constant (or character variable) with the text -C of the error or warning message. In the example below, -C the message is a character constant that contains a -C generic message. -C -C CALL XERMSG ('SLATEC', 'MMPY', -C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', -C *3, 1) -C -C It is possible (and is sometimes desirable) to generate a -C specific message--e.g., one that contains actual numeric -C values. Specific numeric values can be converted into -C character strings using formatted WRITE statements into -C character variables. This is called standard Fortran -C internal file I/O and is exemplified in the first three -C lines of the following example. You can also catenate -C substrings of characters to construct the error message. -C Here is an example showing the use of both writing to -C an internal file and catenating character strings. -C -C CHARACTER*5 CHARN, CHARL -C WRITE (CHARN,10) N -C WRITE (CHARL,10) LDA -C 10 FORMAT(I5) -C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// -C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// -C * CHARL, 3, 1) -C -C There are two subtleties worth mentioning. One is that -C the // for character catenation is used to construct the -C error message so that no single character constant is -C continued to the next line. This avoids confusion as to -C whether there are trailing blanks at the end of the line. -C The second is that by catenating the parts of the message -C as an actual argument rather than encoding the entire -C message into one large character variable, we avoid -C having to know how long the message will be in order to -C declare an adequate length for that large character -C variable. XERMSG calls XERPRN to print the message using -C multiple lines if necessary. If the message is very long, -C XERPRN will break it into pieces of 72 characters (as -C requested by XERMSG) for printing on multiple lines. -C Also, XERMSG asks XERPRN to prefix each line with ' * ' -C so that the total line length could be 76 characters. -C Note also that XERPRN scans the error message backwards -C to ignore trailing blanks. Another feature is that -C the substring '$$' is treated as a new line sentinel -C by XERPRN. If you want to construct a multiline -C message without having to count out multiples of 72 -C characters, just use '$$' as a separator. '$$' -C obviously must occur within 72 characters of the -C start of each line to have its intended effect since -C XERPRN is asked to wrap around at 72 characters in -C addition to looking for '$$'. -C -C NERR An integer value that is chosen by the library routine's -C author. It must be in the range -99 to 999 (three -C printable digits). Each distinct error should have its -C own error number. These error numbers should be described -C in the machine readable documentation for the routine. -C The error numbers need be unique only within each routine, -C so it is reasonable for each routine to start enumerating -C errors from 1 and proceeding to the next integer. -C -C LEVEL An integer value in the range 0 to 2 that indicates the -C level (severity) of the error. Their meanings are -C -C -1 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. An attempt is made to only print this -C message once. -C -C 0 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. -C -C 1 A recoverable error. This is used even if the error is -C so serious that the routine cannot return any useful -C answer. If the user has told the error package to -C return after recoverable errors, then XERMSG will -C return to the Library routine which can then return to -C the user's routine. The user may also permit the error -C package to terminate the program upon encountering a -C recoverable error. -C -C 2 A fatal error. XERMSG will not return to its caller -C after it receives a fatal error. This level should -C hardly ever be used; it is much better to allow the -C user a chance to recover. An example of one of the few -C cases in which it is permissible to declare a level 2 -C error is a reverse communication Library routine that -C is likely to be called repeatedly until it integrates -C across some interval. If there is a serious error in -C the input such that another step cannot be taken and -C the Library routine is called again without the input -C error having been corrected by the caller, the Library -C routine will probably be called forever with improper -C input. In this case, it is reasonable to declare the -C error to be fatal. -C -C Each of the arguments to XERMSG is input; none will be modified by -C XERMSG. A routine may make multiple calls to XERMSG with warning -C level messages; however, after a call to XERMSG with a recoverable -C error, the routine should return to the user. Do not try to call -C XERMSG with a second recoverable error after the first recoverable -C error because the error package saves the error number. The user -C can retrieve this error number by calling another entry point in -C the error handling package and then clear the error number when -C recovering from the error. Calling XERMSG in succession causes the -C old error number to be overwritten by the latest error number. -C This is considered harmless for error numbers associated with -C warning messages but must not be done for error numbers of serious -C errors. After a call to XERMSG with a recoverable error, the user -C must be given a chance to call NUMXER or XERCLR to retrieve or -C clear the error number. -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE -C***REVISION HISTORY (YYMMDD) -C 880101 DATE WRITTEN -C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. -C THERE ARE TWO BASIC CHANGES. -C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO -C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES -C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS -C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE -C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER -C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY -C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE -C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. -C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE -C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE -C OF LOWER CASE. -C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. -C THE PRINCIPAL CHANGES ARE -C 1. CLARIFY COMMENTS IN THE PROLOGUES -C 2. RENAME XRPRNT TO XERPRN -C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES -C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / -C CHARACTER FOR NEW RECORDS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C CLEAN UP THE CODING. -C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN -C PREFIX. -C 891013 REVISED TO CORRECT COMMENTS. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but -C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added -C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and -C XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERMSG - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 XLIBR, XSUBR - CHARACTER*72 TEMP - CHARACTER*20 LFIRST -C***FIRST EXECUTABLE STATEMENT XERMSG - LKNTRL = J4SAVE (2, 0, .FALSE.) - MAXMES = J4SAVE (4, 0, .FALSE.) -C -C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. -C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE -C SHOULD BE PRINTED. -C -C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN -C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, -C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. -C - IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. - * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN - CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // - * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// - * 'JOB ABORT DUE TO FATAL ERROR.', 72) - CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) - CALL XERHLT (' ***XERMSG -- INVALID INPUT') - RETURN - ENDIF -C -C RECORD THE MESSAGE. -C - I = J4SAVE (1, NERR, .TRUE.) - CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) -C -C HANDLE PRINT-ONCE WARNING MESSAGES. -C - IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN -C -C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. -C - XLIBR = LIBRAR - XSUBR = SUBROU - LFIRST = MESSG - LERR = NERR - LLEVEL = LEVEL - CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) -C - LKNTRL = MAX(-2, MIN(2,LKNTRL)) - MKNTRL = ABS(LKNTRL) -C -C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS -C ZERO AND THE ERROR IS NOT FATAL. -C - IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 - IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 - IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 - IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 -C -C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A -C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) -C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG -C IS NOT ZERO. -C - IF (LKNTRL .NE. 0) THEN - TEMP(1:21) = 'MESSAGE FROM ROUTINE ' - I = MIN(LEN(SUBROU), 16) - TEMP(22:21+I) = SUBROU(1:I) - TEMP(22+I:33+I) = ' IN LIBRARY ' - LTEMP = 33 + I - I = MIN(LEN(LIBRAR), 16) - TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) - TEMP(LTEMP+I+1:LTEMP+I+1) = '.' - LTEMP = LTEMP + I + 1 - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE -C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE -C FROM EACH OF THE FOLLOWING THREE OPTIONS. -C 1. LEVEL OF THE MESSAGE -C 'INFORMATIVE MESSAGE' -C 'POTENTIALLY RECOVERABLE ERROR' -C 'FATAL ERROR' -C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE -C 'PROG CONTINUES' -C 'PROG ABORTED' -C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK -C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS -C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) -C 'TRACEBACK REQUESTED' -C 'TRACEBACK NOT REQUESTED' -C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT -C EXCEED 74 CHARACTERS. -C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. -C - IF (LKNTRL .GT. 0) THEN -C -C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. -C - IF (LEVEL .LE. 0) THEN - TEMP(1:20) = 'INFORMATIVE MESSAGE,' - LTEMP = 20 - ELSEIF (LEVEL .EQ. 1) THEN - TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' - LTEMP = 30 - ELSE - TEMP(1:12) = 'FATAL ERROR,' - LTEMP = 12 - ENDIF -C -C THEN WHETHER THE PROGRAM WILL CONTINUE. -C - IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. - * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN - TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' - LTEMP = LTEMP + 14 - ELSE - TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' - LTEMP = LTEMP + 16 - ENDIF -C -C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' - LTEMP = LTEMP + 20 - ELSE - TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' - LTEMP = LTEMP + 24 - ENDIF - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C NOW SEND OUT THE MESSAGE. -C - CALL XERPRN (' * ', -1, MESSG, 72) -C -C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A -C TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR - DO 10 I=16,22 - IF (TEMP(I:I) .NE. ' ') GO TO 20 - 10 CONTINUE -C - 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) - CALL FDUMP - ENDIF -C -C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. -C - IF (LKNTRL .NE. 0) THEN - CALL XERPRN (' * ', -1, ' ', 72) - CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) - CALL XERPRN (' ', 0, ' ', 72) - ENDIF -C -C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE -C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. -C - 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN -C -C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A -C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR -C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. -C - IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN - IF (LEVEL .EQ. 1) THEN - CALL XERPRN - * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) - ELSE - CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) - ENDIF - CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) - CALL XERHLT (' ') - ELSE - CALL XERHLT (MESSG) - ENDIF - RETURN - END -*DECK XERPRN - SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) -C***BEGIN PROLOGUE XERPRN -C***SUBSIDIARY -C***PURPOSE Print error messages processed by XERMSG. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERPRN-A) -C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C This routine sends one or more lines to each of the (up to five) -C logical units to which error messages are to be sent. This routine -C is called several times by XERMSG, sometimes with a single line to -C print and sometimes with a (potentially very long) message that may -C wrap around into multiple lines. -C -C PREFIX Input argument of type CHARACTER. This argument contains -C characters to be put at the beginning of each line before -C the body of the message. No more than 16 characters of -C PREFIX will be used. -C -C NPREF Input argument of type INTEGER. This argument is the number -C of characters to use from PREFIX. If it is negative, the -C intrinsic function LEN is used to determine its length. If -C it is zero, PREFIX is not used. If it exceeds 16 or if -C LEN(PREFIX) exceeds 16, only the first 16 characters will be -C used. If NPREF is positive and the length of PREFIX is less -C than NPREF, a copy of PREFIX extended with blanks to length -C NPREF will be used. -C -C MESSG Input argument of type CHARACTER. This is the text of a -C message to be printed. If it is a long message, it will be -C broken into pieces for printing on multiple lines. Each line -C will start with the appropriate prefix and be followed by a -C piece of the message. NWRAP is the number of characters per -C piece; that is, after each NWRAP characters, we break and -C start a new line. In addition the characters '$$' embedded -C in MESSG are a sentinel for a new line. The counting of -C characters up to NWRAP starts over for each new line. The -C value of NWRAP typically used by XERMSG is 72 since many -C older error messages in the SLATEC Library are laid out to -C rely on wrap-around every 72 characters. -C -C NWRAP Input argument of type INTEGER. This gives the maximum size -C piece into which to break MESSG for printing on multiple -C lines. An embedded '$$' ends a line, and the count restarts -C at the following character. If a line break does not occur -C on a blank (it would split a word) that word is moved to the -C next line. Values of NWRAP less than 16 will be treated as -C 16. Values of NWRAP greater than 132 will be treated as 132. -C The actual line length will be NPREF + NWRAP after NPREF has -C been adjusted to fall between 0 and 16 and NWRAP has been -C adjusted to fall between 16 and 132. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 880621 DATE WRITTEN -C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF -C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK -C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE -C SLASH CHARACTER IN FORMAT STATEMENTS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK -C LINES TO BE PRINTED. -C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF -C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. -C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Added code to break messages between words. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERPRN - CHARACTER*(*) PREFIX, MESSG - INTEGER NPREF, NWRAP - CHARACTER*148 CBUFF - INTEGER IU(5), NUNIT - CHARACTER*2 NEWLIN - PARAMETER (NEWLIN = '$$') -C***FIRST EXECUTABLE STATEMENT XERPRN - CALL XGETUA(IU,NUNIT) -C -C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD -C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD -C ERROR MESSAGE UNIT. -C - N = I1MACH(4) - DO 10 I=1,NUNIT - IF (IU(I) .EQ. 0) IU(I) = N - 10 CONTINUE -C -C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE -C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING -C THE REST OF THIS ROUTINE. -C - IF ( NPREF .LT. 0 ) THEN - LPREF = LEN(PREFIX) - ELSE - LPREF = NPREF - ENDIF - LPREF = MIN(16, LPREF) - IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX -C -C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE -C TIME FROM MESSG TO PRINT ON ONE LINE. -C - LWRAP = MAX(16, MIN(132, NWRAP)) -C -C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. -C - LENMSG = LEN(MESSG) - N = LENMSG - DO 20 I=1,N - IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 - LENMSG = LENMSG - 1 - 20 CONTINUE - 30 CONTINUE -C -C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. -C - IF (LENMSG .EQ. 0) THEN - CBUFF(LPREF+1:LPREF+1) = ' ' - DO 40 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) - 40 CONTINUE - RETURN - ENDIF -C -C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING -C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. -C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. -C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. -C -C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE -C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE -C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH -C OF THE SECOND ARGUMENT. -C -C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE -C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER -C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT -C POSITION NEXTC. -C -C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE -C REMAINDER OF THE CHARACTER STRING. LPIECE -C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, -C WHICHEVER IS LESS. -C -C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: -C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE -C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY -C BLANK LINES. THIS TAKES CARE OF THE SITUATION -C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF -C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE -C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC -C SHOULD BE INCREMENTED BY 2. -C -C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. -C -C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 -C RESET LPIECE = LPIECE-1. NOTE THAT THIS -C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. -C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY -C AT THE END OF A LINE. -C - NEXTC = 1 - 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) - IF (LPIECE .EQ. 0) THEN -C -C THERE WAS NO NEW LINE SENTINEL FOUND. -C - IDELTA = 0 - LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) - IF (LPIECE .LT. LENMSG+1-NEXTC) THEN - DO 52 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 54 - ENDIF - 52 CONTINUE - ENDIF - 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSEIF (LPIECE .EQ. 1) THEN -C -C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). -C DON'T PRINT A BLANK LINE. -C - NEXTC = NEXTC + 2 - GO TO 50 - ELSEIF (LPIECE .GT. LWRAP+1) THEN -C -C LPIECE SHOULD BE SET DOWN TO LWRAP. -C - IDELTA = 0 - LPIECE = LWRAP - DO 56 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 58 - ENDIF - 56 CONTINUE - 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSE -C -C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. -C WE SHOULD DECREMENT LPIECE BY ONE. -C - LPIECE = LPIECE - 1 - CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + 2 - ENDIF -C -C PRINT -C - DO 60 I=1,NUNIT - WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) - 60 CONTINUE -C - IF (NEXTC .LE. LENMSG) GO TO 50 - RETURN - END -*DECK XERSVE - SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, - + ICOUNT) -C***BEGIN PROLOGUE XERSVE -C***SUBSIDIARY -C***PURPOSE Record that an error has occurred. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3 -C***TYPE ALL (XERSVE-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C *Usage: -C -C INTEGER KFLAG, NERR, LEVEL, ICOUNT -C CHARACTER * (len) LIBRAR, SUBROU, MESSG -C -C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) -C -C *Arguments: -C -C LIBRAR :IN is the library that the message is from. -C SUBROU :IN is the subroutine that the message is from. -C MESSG :IN is the message to be saved. -C KFLAG :IN indicates the action to be performed. -C when KFLAG > 0, the message in MESSG is saved. -C when KFLAG=0 the tables will be dumped and -C cleared. -C when KFLAG < 0, the tables will be dumped and -C not cleared. -C NERR :IN is the error number. -C LEVEL :IN is the error severity. -C ICOUNT :OUT the number of times this message has been seen, -C or zero if the table has overflowed and does not -C contain this message specifically. When KFLAG=0, -C ICOUNT will not be altered. -C -C *Description: -C -C Record that this error occurred and possibly dump and clear the -C tables. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 800319 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900413 Routine modified to remove reference to KFLAG. (WRB) -C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling -C sequence, use IF-THEN-ELSE, make number of saved entries -C easily changeable, changed routine name from XERSAV to -C XERSVE. (RWC) -C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERSVE - PARAMETER (LENTAB=10) - INTEGER LUN(5) - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB - CHARACTER*20 MESTAB(LENTAB), MES - DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) - SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG - DATA KOUNTX/0/, NMSG/0/ -C***FIRST EXECUTABLE STATEMENT XERSVE -C - IF (KFLAG.LE.0) THEN -C -C Dump the table. -C - IF (NMSG.EQ.0) RETURN -C -C Print to each unit. -C - CALL XGETUA (LUN, NUNIT) - DO 20 KUNIT = 1,NUNIT - IUNIT = LUN(KUNIT) - IF (IUNIT.EQ.0) IUNIT = I1MACH(4) -C -C Print the table header. -C - WRITE (IUNIT,9000) -C -C Print body of table. -C - DO 10 I = 1,NMSG - WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), - * NERTAB(I),LEVTAB(I),KOUNT(I) - 10 CONTINUE -C -C Print number of other errors. -C - IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX - WRITE (IUNIT,9030) - 20 CONTINUE -C -C Clear the error tables. -C - IF (KFLAG.EQ.0) THEN - NMSG = 0 - KOUNTX = 0 - ENDIF - ELSE -C -C PROCESS A MESSAGE... -C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, -C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. -C - LIB = LIBRAR - SUB = SUBROU - MES = MESSG - DO 30 I = 1,NMSG - IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. - * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. - * LEVEL.EQ.LEVTAB(I)) THEN - KOUNT(I) = KOUNT(I) + 1 - ICOUNT = KOUNT(I) - RETURN - ENDIF - 30 CONTINUE -C - IF (NMSG.LT.LENTAB) THEN -C -C Empty slot found for new message. -C - NMSG = NMSG + 1 - LIBTAB(I) = LIB - SUBTAB(I) = SUB - MESTAB(I) = MES - NERTAB(I) = NERR - LEVTAB(I) = LEVEL - KOUNT (I) = 1 - ICOUNT = 1 - ELSE -C -C Table is full. -C - KOUNTX = KOUNTX+1 - ICOUNT = 0 - ENDIF - ENDIF - RETURN -C -C Formats. -C - 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / - + ' LIBRARY SUBROUTINE MESSAGE START NERR', - + ' LEVEL COUNT') - 9010 FORMAT (1X,A,3X,A,3X,A,3I10) - 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) - 9030 FORMAT (1X) - END -*DECK D1MACH - DOUBLE PRECISION FUNCTION D1MACH (I) -C***BEGIN PROLOGUE D1MACH -C***PURPOSE Return floating point machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C D1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument, and can be referenced as follows: -C -C D = D1MACH(I) -C -C where I=1,...,5. The (output) value of D above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. -C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. -C D1MACH( 3) = B**(-T), the smallest relative spacing. -C D1MACH( 4) = B**(1-T), the largest relative spacing. -C D1MACH( 5) = LOG10(B) -C -C Assume double precision numbers are represented in the T-digit, -C base-B form -C -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and -C EMIN .LE. E .LE. EMAX. -C -C The values of B, T, EMIN and EMAX are provided in I1MACH as -C follows: -C I1MACH(10) = B, the base. -C I1MACH(14) = T, the number of base-B digits. -C I1MACH(15) = EMIN, the smallest exponent E. -C I1MACH(16) = EMAX, the largest exponent E. -C -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 890213 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 900911 Added SUN 386i constants. (WRB) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added CONVEX -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE D1MACH -C -cc INTEGER SMALL(4) -cc INTEGER LARGE(4) -cc INTEGER RIGHT(4) -cc INTEGER DIVER(4) -cc INTEGER LOG10(4) -C -C Initial data here correspond to the IEEE standard. The values for -C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value -C for DMACH(2) is a slight lower bound. The value for DMACH(5) is -C a 20-digit approximation. If one of the sets of initial data below -C is preferred, do the necessary commenting and uncommenting. (DWL) - DOUBLE PRECISION DMACH(5) - DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, - 1 0.30102999566398119521D0 / - SAVE DMACH -C -cc EQUIVALENCE (DMACH(1),SMALL(1)) -cc EQUIVALENCE (DMACH(2),LARGE(1)) -cc EQUIVALENCE (DMACH(3),RIGHT(1)) -cc EQUIVALENCE (DMACH(4),DIVER(1)) -cc EQUIVALENCE (DMACH(5),LOG10(1)) -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / -C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / -C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / -C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA SMALL(1) / ZC00800000 / -C DATA SMALL(2) / Z000000000 / -C DATA LARGE(1) / ZDFFFFFFFF / -C DATA LARGE(2) / ZFFFFFFFFF / -C DATA RIGHT(1) / ZCC5800000 / -C DATA RIGHT(2) / Z000000000 / -C DATA DIVER(1) / ZCC6800000 / -C DATA DIVER(2) / Z000000000 / -C DATA LOG10(1) / ZD00E730E7 / -C DATA LOG10(2) / ZC77800DC0 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O0000000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O0007777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA SMALL(1) / O1771000000000000 / -C DATA SMALL(2) / O7770000000000000 / -C DATA LARGE(1) / O0777777777777777 / -C DATA LARGE(2) / O7777777777777777 / -C DATA RIGHT(1) / O1461000000000000 / -C DATA RIGHT(2) / O0000000000000000 / -C DATA DIVER(1) / O1451000000000000 / -C DATA DIVER(2) / O0000000000000000 / -C DATA LOG10(1) / O1157163034761674 / -C DATA LOG10(2) / O0006677466732724 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA SMALL(1) / Z"3001800000000000" / -C DATA SMALL(2) / Z"3001000000000000" / -C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / -C DATA LARGE(2) / Z"4FFE000000000000" / -C DATA RIGHT(1) / Z"3FD2800000000000" / -C DATA RIGHT(2) / Z"3FD2000000000000" / -C DATA DIVER(1) / Z"3FD3800000000000" / -C DATA DIVER(2) / Z"3FD3000000000000" / -C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / -C DATA LOG10(2) / Z"3FFFF7988F8959AC" / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA SMALL(1) / 00564000000000000000B / -C DATA SMALL(2) / 00000000000000000000B / -C DATA LARGE(1) / 37757777777777777777B / -C DATA LARGE(2) / 37157777777777777777B / -C DATA RIGHT(1) / 15624000000000000000B / -C DATA RIGHT(2) / 00000000000000000000B / -C DATA DIVER(1) / 15634000000000000000B / -C DATA DIVER(2) / 00000000000000000000B / -C DATA LOG10(1) / 17164642023241175717B / -C DATA LOG10(2) / 16367571421742254654B / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn OR -pd8 COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CC0000000000000' / -C DATA DMACH(4) / Z'3CD0000000000000' / -C DATA DMACH(5) / Z'3FF34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F900000000000000000000000000000' / -C DATA DMACH(4) / Z'3F910000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE CRAY -C -C DATA SMALL(1) / 201354000000000000000B / -C DATA SMALL(2) / 000000000000000000000B / -C DATA LARGE(1) / 577767777777777777777B / -C DATA LARGE(2) / 000007777777777777774B / -C DATA RIGHT(1) / 376434000000000000000B / -C DATA RIGHT(2) / 000000000000000000000B / -C DATA DIVER(1) / 376444000000000000000B / -C DATA DIVER(2) / 000000000000000000000B / -C DATA LOG10(1) / 377774642023241175717B / -C DATA LOG10(2) / 000007571421742254654B / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - -C STATIC DMACH(5) -C -C DATA SMALL / 20K, 3*0 / -C DATA LARGE / 77777K, 3*177777K / -C DATA RIGHT / 31420K, 3*0 / -C DATA DIVER / 32020K, 3*0 / -C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA DMACH(1) / '0000000000000010'X / -C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / -C DATA DMACH(3) / '0000000000003CC0'X / -C DATA DMACH(4) / '0000000000003CD0'X / -C DATA DMACH(5) / '79FF509F44133FF3'X / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FORMAT -C -C DATA DMACH(1) / '0010000000000000'X / -C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / -C DATA DMACH(3) / '3CA0000000000000'X / -C DATA DMACH(4) / '3CB0000000000000'X / -C DATA DMACH(5) / '3FD34413509F79FF'X / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ -C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ -C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ -C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ -C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / -C -C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C (EXPRESSED IN INTEGER AND HEXADECIMAL) -C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS -C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS -C -C DATA SMALL(1), SMALL(2) / 16, 0 / -C DATA LARGE(1), LARGE(2) / -32769, -1 / -C DATA RIGHT(1), RIGHT(2) / 15552, 0 / -C DATA DIVER(1), DIVER(2) / 15568, 0 / -C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / -C -C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / -C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) -C -C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / -C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / -C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / -C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / -C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / -C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / -C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / -C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / -C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -C DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / -C DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / -C DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / -C DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / -C DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / -C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / -C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / -C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA SMALL(1), SMALL(2) / 40000B, 0 / -C DATA SMALL(3), SMALL(4) / 0, 1 / -C DATA LARGE(1), LARGE(2) / 77777B, 177777B / -C DATA LARGE(3), LARGE(4) / 177777B, 177776B / -C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 225B / -C DATA DIVER(1), DIVER(2) / 40000B, 0 / -C DATA DIVER(3), DIVER(4) / 0, 227B / -C DATA LOG10(1), LOG10(2) / 46420B, 46502B / -C DATA LOG10(3), LOG10(4) / 76747B, 176377B / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / -C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / -C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / -C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / -C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / -C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / -C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / -C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / -C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / -C -C MACHINE CONSTANTS FOR THE IBM PC -C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION -C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. -C -C DATA SMALL(1) / 2.23D-308 / -C DATA LARGE(1) / 1.79D+308 / -C DATA RIGHT(1) / 1.11D-16 / -C DATA DIVER(1) / 2.22D-16 / -C DATA LOG10(1) / 0.301029995663981195D0 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / -C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / -C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / -C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / -C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / -C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 8388608, 0 / -C DATA LARGE(1), LARGE(2) / 2147483647, -1 / -C DATA RIGHT(1), RIGHT(2) / 612368384, 0 / -C DATA DIVER(1), DIVER(2) / 620756992, 0 / -C DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / -C -C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / -C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / -C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / -C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / -C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). -C -C DATA SMALL(1), SMALL(2) / 128, 0 / -C DATA SMALL(3), SMALL(4) / 0, 0 / -C DATA LARGE(1), LARGE(2) / 32767, -1 / -C DATA LARGE(3), LARGE(4) / -1, -1 / -C DATA RIGHT(1), RIGHT(2) / 9344, 0 / -C DATA RIGHT(3), RIGHT(4) / 0, 0 / -C DATA DIVER(1), DIVER(2) / 9472, 0 / -C DATA DIVER(3), DIVER(4) / 0, 0 / -C DATA LOG10(1), LOG10(2) / 16282, 8346 / -C DATA LOG10(3), LOG10(4) / -31493, -12296 / -C -C DATA SMALL(1), SMALL(2) / O000200, O000000 / -C DATA SMALL(3), SMALL(4) / O000000, O000000 / -C DATA LARGE(1), LARGE(2) / O077777, O177777 / -C DATA LARGE(3), LARGE(4) / O177777, O177777 / -C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / -C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / -C DATA DIVER(1), DIVER(2) / O022400, O000000 / -C DATA DIVER(3), DIVER(4) / O000000, O000000 / -C DATA LOG10(1), LOG10(2) / O037632, O020232 / -C DATA LOG10(3), LOG10(4) / O102373, O147770 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / -C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / -C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / -C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA DMACH(1) / Z'0010000000000000' / -C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3CA0000000000000' / -C DATA DMACH(4) / Z'3CB0000000000000' / -C DATA DMACH(5) / Z'3FD34413509F79FF' / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA DMACH(1) / Z'00010000000000000000000000000000' / -C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / -C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / -C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / -C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / -C -C MACHINE CONSTANTS FOR THE SUN 386i -C -C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / -C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / -C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / -C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' -C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / -C DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / -C DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / -C DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / -C DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / -C -C***FIRST EXECUTABLE STATEMENT D1MACH - IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', - + 'I OUT OF BOUNDS', 1, 2) -C - D1MACH = DMACH(I) - RETURN -C - END -*DECK XGETUA - SUBROUTINE XGETUA (IUNITA, N) -C***BEGIN PROLOGUE XGETUA -C***PURPOSE Return unit number(s) to which error messages are being -C sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XGETUA-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XGETUA may be called to determine the unit number or numbers -C to which error messages are being sent. -C These unit numbers may have been set by a call to XSETUN, -C or a call to XSETUA, or may be a default value. -C -C Description of Parameters -C --Output-- -C IUNIT - an array of one to five unit numbers, depending -C on the value of N. A value of zero refers to the -C default unit, as defined by the I1MACH machine -C constant routine. Only IUNIT(1),...,IUNIT(N) are -C defined by XGETUA. The values of IUNIT(N+1),..., -C IUNIT(5) are not defined (for N .LT. 5) or altered -C in any way by XGETUA. -C N - the number of units to which copies of the -C error messages are being sent. N will be in the -C range from 1 to 5. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED J4SAVE -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XGETUA - DIMENSION IUNITA(5) -C***FIRST EXECUTABLE STATEMENT XGETUA - N = J4SAVE(5,0,.FALSE.) - DO 30 I=1,N - INDEX = I+4 - IF (I.EQ.1) INDEX = 3 - IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) - 30 CONTINUE - RETURN - END -*DECK FDUMP - SUBROUTINE FDUMP -C***BEGIN PROLOGUE FDUMP -C***PURPOSE Symbolic dump (should be locally written). -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3 -C***TYPE ALL (FDUMP-A) -C***KEYWORDS ERROR, XERMSG -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C ***Note*** Machine Dependent Routine -C FDUMP is intended to be replaced by a locally written -C version which produces a symbolic dump. Failing this, -C it should be replaced by a version which prints the -C subprogram nesting list. Note that this dump must be -C printed on each of up to five files, as indicated by the -C XGETUA routine. See XSETUA and XGETUA for details. -C -C Written by Ron Jones, with SLATEC Common Math Library Subcommittee -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE FDUMP -C***FIRST EXECUTABLE STATEMENT FDUMP - RETURN - END -*DECK DFEHL - SUBROUTINE DFEHL (DF, NEQ, T, Y, H, YP, F1, F2, F3, F4, F5, YS, - + RPAR, IPAR) -C***BEGIN PROLOGUE DFEHL -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (DEFEHL-S, DFEHL-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Fehlberg Fourth-Fifth Order Runge-Kutta Method -C ********************************************************************** -C -C DFEHL integrates a system of NEQ first order -C ordinary differential equations of the form -C DU/DX = DF(X,U) -C over one step when the vector Y(*) of initial values for U(*) and -C the vector YP(*) of initial derivatives, satisfying YP = DF(T,Y), -C are given at the starting point X=T. -C -C DFEHL advances the solution over the fixed step H and returns -C the fifth order (sixth order accurate locally) solution -C approximation at T+H in the array YS(*). -C F1,---,F5 are arrays of dimension NEQ which are needed -C for internal storage. -C The formulas have been grouped to control loss of significance. -C DFEHL should be called with an H not smaller than 13 units of -C roundoff in T so that the various independent arguments can be -C distinguished. -C -C This subroutine has been written with all variables and statement -C numbers entirely compatible with DRKFS. For greater efficiency, -C the call to DFEHL can be replaced by the module beginning with -C line 222 and extending to the last line just before the return -C statement. -C -C ********************************************************************** -C -C***SEE ALSO DDERKF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DFEHL -C - INTEGER IPAR, K, NEQ - DOUBLE PRECISION CH, F1, F2, F3, F4, F5, H, RPAR, T, Y, YP, YS - DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), - 1 YS(*),RPAR(*),IPAR(*) -C -C***FIRST EXECUTABLE STATEMENT DFEHL - CH = H/4.0D0 - DO 10 K = 1, NEQ - YS(K) = Y(K) + CH*YP(K) - 10 CONTINUE - CALL DF(T+CH,YS,F1,RPAR,IPAR) -C - CH = 3.0D0*H/32.0D0 - DO 20 K = 1, NEQ - YS(K) = Y(K) + CH*(YP(K) + 3.0D0*F1(K)) - 20 CONTINUE - CALL DF(T+3.0D0*H/8.0D0,YS,F2,RPAR,IPAR) -C - CH = H/2197.0D0 - DO 30 K = 1, NEQ - YS(K) = Y(K) - 1 + CH - 2 *(1932.0D0*YP(K) + (7296.0D0*F2(K) - 7200.0D0*F1(K))) - 30 CONTINUE - CALL DF(T+12.0D0*H/13.0D0,YS,F3,RPAR,IPAR) -C - CH = H/4104.0D0 - DO 40 K = 1, NEQ - YS(K) = Y(K) - 1 + CH - 2 *((8341.0D0*YP(K) - 845.0D0*F3(K)) - 3 + (29440.0D0*F2(K) - 32832.0D0*F1(K))) - 40 CONTINUE - CALL DF(T+H,YS,F4,RPAR,IPAR) -C - CH = H/20520.0D0 - DO 50 K = 1, NEQ - YS(K) = Y(K) - 1 + CH - 2 *((-6080.0D0*YP(K) - 3 + (9295.0D0*F3(K) - 5643.0D0*F4(K))) - 4 + (41040.0D0*F1(K) - 28352.0D0*F2(K))) - 50 CONTINUE - CALL DF(T+H/2.0D0,YS,F5,RPAR,IPAR) -C -C COMPUTE APPROXIMATE SOLUTION AT T+H -C - CH = H/7618050.0D0 - DO 60 K = 1, NEQ - YS(K) = Y(K) - 1 + CH - 2 *((902880.0D0*YP(K) - 3 + (3855735.0D0*F3(K) - 1371249.0D0*F4(K))) - 4 + (3953664.0D0*F2(K) + 277020.0D0*F5(K))) - 60 CONTINUE -C - RETURN - END -*DECK I1MACH - INTEGER FUNCTION I1MACH (I) -C***BEGIN PROLOGUE I1MACH -C***PURPOSE Return integer machine dependent constants. -C***LIBRARY SLATEC -C***CATEGORY R1 -C***TYPE INTEGER (I1MACH-I) -C***KEYWORDS MACHINE CONSTANTS -C***AUTHOR Fox, P. A., (Bell Labs) -C Hall, A. D., (Bell Labs) -C Schryer, N. L., (Bell Labs) -C***DESCRIPTION -C -C I1MACH can be used to obtain machine-dependent parameters for the -C local machine environment. It is a function subprogram with one -C (input) argument and can be referenced as follows: -C -C K = I1MACH(I) -C -C where I=1,...,16. The (output) value of K above is determined by -C the (input) value of I. The results for various values of I are -C discussed below. -C -C I/O unit numbers: -C I1MACH( 1) = the standard input unit. -C I1MACH( 2) = the standard output unit. -C I1MACH( 3) = the standard punch unit. -C I1MACH( 4) = the standard error message unit. -C -C Words: -C I1MACH( 5) = the number of bits per integer storage unit. -C I1MACH( 6) = the number of characters per integer storage unit. -C -C Integers: -C assume integers are represented in the S-digit, base-A form -C -C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) -C -C where 0 .LE. X(I) .LT. A for I=0,...,S-1. -C I1MACH( 7) = A, the base. -C I1MACH( 8) = S, the number of base-A digits. -C I1MACH( 9) = A**S - 1, the largest magnitude. -C -C Floating-Point Numbers: -C Assume floating-point numbers are represented in the T-digit, -C base-B form -C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) -C -C where 0 .LE. X(I) .LT. B for I=1,...,T, -C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. -C I1MACH(10) = B, the base. -C -C Single-Precision: -C I1MACH(11) = T, the number of base-B digits. -C I1MACH(12) = EMIN, the smallest exponent E. -C I1MACH(13) = EMAX, the largest exponent E. -C -C Double-Precision: -C I1MACH(14) = T, the number of base-B digits. -C I1MACH(15) = EMIN, the smallest exponent E. -C I1MACH(16) = EMAX, the largest exponent E. -C -C To alter this function for a particular environment, the desired -C set of DATA statements should be activated by removing the C from -C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be -C checked for consistency with the local operating system. -C -C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for -C a portable library, ACM Transactions on Mathematical -C Software 4, 2 (June 1978), pp. 177-188. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 750101 DATE WRITTEN -C 891012 Added VAX G-floating constants. (WRB) -C 891012 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900618 Added DEC RISC constants. (WRB) -C 900723 Added IBM RS 6000 constants. (WRB) -C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. -C (RWC) -C 910710 Added HP 730 constants. (SMR) -C 911114 Added Convex IEEE constants. (WRB) -C 920121 Added SUN -r8 compiler option constants. (WRB) -C 920229 Added Touchstone Delta i860 constants. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920625 Added Convex -p8 and -pd8 compiler option constants. -C (BKS, WRB) -C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) -C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler -C options. (DWL, RWC and WRB). -C 010817 Elevated IEEE to highest importance; see next set of -C comments below. (DWL) -C***END PROLOGUE I1MACH -C -C Initial data here correspond to the IEEE standard. If one of the -C sets of initial data below is preferred, do the necessary commenting -C and uncommenting. (DWL) - INTEGER IMACH(16),OUTPUT - DATA IMACH( 1) / 5 / - DATA IMACH( 2) / 6 / - DATA IMACH( 3) / 6 / - DATA IMACH( 4) / 6 / - DATA IMACH( 5) / 32 / - DATA IMACH( 6) / 4 / - DATA IMACH( 7) / 2 / - DATA IMACH( 8) / 31 / - DATA IMACH( 9) / 2147483647 / - DATA IMACH(10) / 2 / - DATA IMACH(11) / 24 / - DATA IMACH(12) / -126 / - DATA IMACH(13) / 127 / - DATA IMACH(14) / 53 / - DATA IMACH(15) / -1022 / - DATA IMACH(16) / 1023 / - SAVE IMACH -cc EQUIVALENCE (IMACH(4),OUTPUT) - output=imach(4) -cc -C -C MACHINE CONSTANTS FOR THE AMIGA -C ABSOFT COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE APOLLO -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 129 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1025 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM -C -C DATA IMACH( 1) / 7 / -C DATA IMACH( 2) / 2 / -C DATA IMACH( 3) / 2 / -C DATA IMACH( 4) / 2 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 33 / -C DATA IMACH( 9) / Z1FFFFFFFF / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -256 / -C DATA IMACH(13) / 255 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -256 / -C DATA IMACH(16) / 255 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -50 / -C DATA IMACH(16) / 76 / -C -C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 48 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 39 / -C DATA IMACH( 9) / O0007777777777777 / -C DATA IMACH(10) / 8 / -C DATA IMACH(11) / 13 / -C DATA IMACH(12) / -50 / -C DATA IMACH(13) / 76 / -C DATA IMACH(14) / 26 / -C DATA IMACH(15) / -32754 / -C DATA IMACH(16) / 32780 / -C -C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -4095 / -C DATA IMACH(13) / 4094 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -4095 / -C DATA IMACH(16) / 4094 / -C -C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6LOUTPUT/ -C DATA IMACH( 5) / 60 / -C DATA IMACH( 6) / 10 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 48 / -C DATA IMACH( 9) / 00007777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -929 / -C DATA IMACH(13) / 1070 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -929 / -C DATA IMACH(16) / 1069 / -C -C MACHINE CONSTANTS FOR THE CELERITY C1260 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z'7FFFFFFF' / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fn COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -fi COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -p8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16383 / -C DATA IMACH(16) / 16383 / -C -C MACHINE CONSTANTS FOR THE CONVEX -C USING THE -pd8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 9223372036854775807 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1023 / -C DATA IMACH(13) / 1023 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 46 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 46 / -C DATA IMACH( 9) / 1777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE CRAY -C USING THE 64 BIT INTEGER COMPILER OPTION -C -C DATA IMACH( 1) / 100 / -C DATA IMACH( 2) / 101 / -C DATA IMACH( 3) / 102 / -C DATA IMACH( 4) / 101 / -C DATA IMACH( 5) / 64 / -C DATA IMACH( 6) / 8 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 63 / -C DATA IMACH( 9) / 777777777777777777777B / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 47 / -C DATA IMACH(12) / -8189 / -C DATA IMACH(13) / 8190 / -C DATA IMACH(14) / 94 / -C DATA IMACH(15) / -8099 / -C DATA IMACH(16) / 8190 / -C -C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 -C -C DATA IMACH( 1) / 11 / -C DATA IMACH( 2) / 12 / -C DATA IMACH( 3) / 8 / -C DATA IMACH( 4) / 10 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING G_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE DEC ALPHA -C USING IEEE_FLOAT -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC RISC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING D_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE DEC VAX -C USING G_FLOATING -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1023 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE ELXSI 6400 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1022 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE HARRIS 220 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 24 / -C DATA IMACH( 6) / 3 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 23 / -C DATA IMACH( 9) / 8388607 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 38 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 43 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 6 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / O377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 63 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 730 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 39 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 2100 -C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 4 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 23 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 55 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE HP 9000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 7 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 32 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -126 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1015 / -C DATA IMACH(16) / 1017 / -C -C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, -C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND -C THE PERKIN ELMER (INTERDATA) 7/32. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 7 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / Z7FFFFFFF / -C DATA IMACH(10) / 16 / -C DATA IMACH(11) / 6 / -C DATA IMACH(12) / -64 / -C DATA IMACH(13) / 63 / -C DATA IMACH(14) / 14 / -C DATA IMACH(15) / -64 / -C DATA IMACH(16) / 63 / -C -C MACHINE CONSTANTS FOR THE IBM PC -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE IBM RS 6000 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 0 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE INTEL i860 -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 54 / -C DATA IMACH(15) / -101 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 5 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / "377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 62 / -C DATA IMACH(15) / -128 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 32-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING -C 16-BIT INTEGER ARITHMETIC. -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 5 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C MACHINE CONSTANTS FOR THE SILICON GRAPHICS -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -125 / -C DATA IMACH(13) / 128 / -C DATA IMACH(14) / 53 / -C DATA IMACH(15) / -1021 / -C DATA IMACH(16) / 1024 / -C -C MACHINE CONSTANTS FOR THE SUN -C USING THE -r8 COMPILER OPTION -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 6 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 32 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 31 / -C DATA IMACH( 9) / 2147483647 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 53 / -C DATA IMACH(12) / -1021 / -C DATA IMACH(13) / 1024 / -C DATA IMACH(14) / 113 / -C DATA IMACH(15) / -16381 / -C DATA IMACH(16) / 16384 / -C -C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER -C -C DATA IMACH( 1) / 5 / -C DATA IMACH( 2) / 6 / -C DATA IMACH( 3) / 1 / -C DATA IMACH( 4) / 6 / -C DATA IMACH( 5) / 36 / -C DATA IMACH( 6) / 4 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 35 / -C DATA IMACH( 9) / O377777777777 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 27 / -C DATA IMACH(12) / -128 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 60 / -C DATA IMACH(15) / -1024 / -C DATA IMACH(16) / 1023 / -C -C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR -C -C DATA IMACH( 1) / 1 / -C DATA IMACH( 2) / 1 / -C DATA IMACH( 3) / 0 / -C DATA IMACH( 4) / 1 / -C DATA IMACH( 5) / 16 / -C DATA IMACH( 6) / 2 / -C DATA IMACH( 7) / 2 / -C DATA IMACH( 8) / 15 / -C DATA IMACH( 9) / 32767 / -C DATA IMACH(10) / 2 / -C DATA IMACH(11) / 24 / -C DATA IMACH(12) / -127 / -C DATA IMACH(13) / 127 / -C DATA IMACH(14) / 56 / -C DATA IMACH(15) / -127 / -C DATA IMACH(16) / 127 / -C -C***FIRST EXECUTABLE STATEMENT I1MACH - IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 -C - I1MACH = IMACH(I) - RETURN -C - 10 CONTINUE - WRITE (UNIT = OUTPUT, FMT = 9000) - 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') -C -C CALL FDUMP -C - STOP - END -*DECK DHSTRT - SUBROUTINE DHSTRT (DF, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, - + BIG, SPY, PV, YP, SF, RPAR, IPAR, H) -C***BEGIN PROLOGUE DHSTRT -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (HSTART-S, DHSTRT-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C DHSTRT computes a starting step size to be used in solving initial -C value problems in ordinary differential equations. -C -C ********************************************************************** -C ABSTRACT -C -C Subroutine DHSTRT computes a starting step size to be used by an -C initial value method in solving ordinary differential equations. -C It is based on an estimate of the local Lipschitz constant for the -C differential equation (lower bound on a norm of the Jacobian) , -C a bound on the differential equation (first derivative) , and -C a bound on the partial derivative of the equation with respect to -C the independent variable. -C (all approximated near the initial point A) -C -C Subroutine DHSTRT uses a function subprogram DHVNRM for computing -C a vector norm. The maximum norm is presently utilized though it -C can easily be replaced by any other vector norm. It is presumed -C that any replacement norm routine would be carefully coded to -C prevent unnecessary underflows or overflows from occurring, and -C also, would not alter the vector or number of components. -C -C ********************************************************************** -C On input you must provide the following -C -C DF -- This is a subroutine of the form -C DF(X,U,UPRIME,RPAR,IPAR) -C which defines the system of first order differential -C equations to be solved. For the given values of X and the -C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must -C evaluate the NEQ components of the system of differential -C equations DU/DX=DF(X,U) and store the derivatives in the -C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for -C equations I=1,...,NEQ. -C -C Subroutine DF must not alter X or U(*). You must declare -C the name DF in an external statement in your program that -C calls DHSTRT. You must dimension U and UPRIME in DF. -C -C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter -C arrays which you can use for communication between your -C program and subroutine DF. They are not used or altered by -C DHSTRT. If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. If you do -C choose to use them, dimension them in your program and in -C DF as arrays of appropriate length. -C -C NEQ -- This is the number of (first order) differential equations -C to be integrated. -C -C A -- This is the initial point of integration. -C -C B -- This is a value of the independent variable used to define -C the direction of integration. A reasonable choice is to -C set B to the first point at which a solution is desired. -C You can also use B, if necessary, to restrict the length -C of the first integration step because the algorithm will -C not compute a starting step length which is bigger than -C ABS(B-A), unless B has been chosen too close to A. -C (it is presumed that DHSTRT has been called with B -C different from A on the machine being used. Also see the -C discussion about the parameter SMALL.) -C -C Y(*) -- This is the vector of initial values of the NEQ solution -C components at the initial point A. -C -C YPRIME(*) -- This is the vector of derivatives of the NEQ -C solution components at the initial point A. -C (defined by the differential equations in subroutine DF) -C -C ETOL -- This is the vector of error tolerances corresponding to -C the NEQ solution components. It is assumed that all -C elements are positive. Following the first integration -C step, the tolerances are expected to be used by the -C integrator in an error test which roughly requires that -C ABS(LOCAL ERROR) .LE. ETOL -C for each vector component. -C -C MORDER -- This is the order of the formula which will be used by -C the initial value method for taking the first integration -C step. -C -C SMALL -- This is a small positive machine dependent constant -C which is used for protecting against computations with -C numbers which are too small relative to the precision of -C floating point arithmetic. SMALL should be set to -C (approximately) the smallest positive DOUBLE PRECISION -C number such that (1.+SMALL) .GT. 1. on the machine being -C used. The quantity SMALL**(3/8) is used in computing -C increments of variables for approximating derivatives by -C differences. Also the algorithm will not compute a -C starting step length which is smaller than -C 100*SMALL*ABS(A). -C -C BIG -- This is a large positive machine dependent constant which -C is used for preventing machine overflows. A reasonable -C choice is to set big to (approximately) the square root of -C the largest DOUBLE PRECISION number which can be held in -C the machine. -C -C SPY(*),PV(*),YP(*),SF(*) -- These are DOUBLE PRECISION work -C arrays of length NEQ which provide the routine with needed -C storage space. -C -C RPAR,IPAR -- These are parameter arrays, of DOUBLE PRECISION and -C INTEGER type, respectively, which can be used for -C communication between your program and the DF subroutine. -C They are not used or altered by DHSTRT. -C -C ********************************************************************** -C On Output (after the return from DHSTRT), -C -C H -- is an appropriate starting step size to be attempted by the -C differential equation method. -C -C All parameters in the call list remain unchanged except for -C the working arrays SPY(*),PV(*),YP(*), and SF(*). -C -C ********************************************************************** -C -C***SEE ALSO DDEABM, DDEBDF, DDERKF -C***ROUTINES CALLED DHVNRM -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DHSTRT -C - INTEGER IPAR, J, K, LK, MORDER, NEQ - DOUBLE PRECISION A, ABSDX, B, BIG, DA, DELF, DELY, - 1 DFDUB, DFDXB, DHVNRM, - 2 DX, DY, ETOL, FBND, H, PV, RELPER, RPAR, SF, SMALL, SPY, - 3 SRYDPB, TOLEXP, TOLMIN, TOLP, TOLSUM, Y, YDPB, YP, YPRIME - DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*), - 1 SF(*),RPAR(*),IPAR(*) - EXTERNAL DF -C -C .................................................................. -C -C BEGIN BLOCK PERMITTING ...EXITS TO 160 -C***FIRST EXECUTABLE STATEMENT DHSTRT - DX = B - A - ABSDX = ABS(DX) - RELPER = SMALL**0.375D0 -C -C ............................................................... -C -C COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL -C DERIVATIVE OF THE EQUATION WITH RESPECT TO THE -C INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. -C ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE -C LOCALLY. -C - DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX), - 1 100.0D0*SMALL*ABS(A)),DX) - IF (DA .EQ. 0.0D0) DA = RELPER*DX - CALL DF(A+DA,Y,SF,RPAR,IPAR) - DO 10 J = 1, NEQ - YP(J) = SF(J) - YPRIME(J) - 10 CONTINUE - DELF = DHVNRM(YP,NEQ) - DFDXB = BIG - IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA) - FBND = DHVNRM(SF,NEQ) -C -C ............................................................... -C -C COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ -C CONSTANT FOR THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS -C ALSO REPRESENTS AN ESTIMATE OF THE NORM OF THE JACOBIAN -C LOCALLY. THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO -C ESTIMATE THE LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. -C THE FIRST PERTURBATION VECTOR IS BASED ON THE INITIAL -C DERIVATIVES AND DIRECTION OF INTEGRATION. THE SECOND -C PERTURBATION VECTOR IS FORMED USING ANOTHER EVALUATION OF -C THE DIFFERENTIAL EQUATION. THE THIRD PERTURBATION VECTOR -C IS FORMED USING PERTURBATIONS BASED ONLY ON THE INITIAL -C VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS CHANGED TO -C NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN -C INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT -C COMPONENTS OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE -C CONSISTENT WITH THE SLOPES OF LOCAL SOLUTION CURVES. -C ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST -C DERIVATIVE. -C -C PERTURBATION VECTOR SIZE IS HELD -C CONSTANT FOR ALL ITERATIONS. COMPUTE -C THIS CHANGE FROM THE -C SIZE OF THE VECTOR OF INITIAL -C VALUES. - DELY = RELPER*DHVNRM(Y,NEQ) - IF (DELY .EQ. 0.0D0) DELY = RELPER - DELY = SIGN(DELY,DX) - DELF = DHVNRM(YPRIME,NEQ) - FBND = MAX(FBND,DELF) - IF (DELF .EQ. 0.0D0) GO TO 30 -C USE INITIAL DERIVATIVES FOR FIRST PERTURBATION - DO 20 J = 1, NEQ - SPY(J) = YPRIME(J) - YP(J) = YPRIME(J) - 20 CONTINUE - GO TO 50 - 30 CONTINUE -C CANNOT HAVE A NULL PERTURBATION VECTOR - DO 40 J = 1, NEQ - SPY(J) = 0.0D0 - YP(J) = 1.0D0 - 40 CONTINUE - DELF = DHVNRM(YP,NEQ) - 50 CONTINUE -C - DFDUB = 0.0D0 - LK = MIN(NEQ+1,3) - DO 140 K = 1, LK -C DEFINE PERTURBED VECTOR OF INITIAL VALUES - DO 60 J = 1, NEQ - PV(J) = Y(J) + DELY*(YP(J)/DELF) - 60 CONTINUE - IF (K .EQ. 2) GO TO 80 -C EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED -C VECTOR AND COMPUTE CORRESPONDING DIFFERENCES - CALL DF(A,PV,YP,RPAR,IPAR) - DO 70 J = 1, NEQ - PV(J) = YP(J) - YPRIME(J) - 70 CONTINUE - GO TO 100 - 80 CONTINUE -C USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE -C IN COMPUTING ONE ESTIMATE - CALL DF(A+DA,PV,YP,RPAR,IPAR) - DO 90 J = 1, NEQ - PV(J) = YP(J) - SF(J) - 90 CONTINUE - 100 CONTINUE -C CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE -C AND A LOCAL LIPSCHITZ CONSTANT - FBND = MAX(FBND,DHVNRM(YP,NEQ)) - DELF = DHVNRM(PV,NEQ) -C ...EXIT - IF (DELF .GE. BIG*ABS(DELY)) GO TO 150 - DFDUB = MAX(DFDUB,DELF/ABS(DELY)) -C ......EXIT - IF (K .EQ. LK) GO TO 160 -C CHOOSE NEXT PERTURBATION VECTOR - IF (DELF .EQ. 0.0D0) DELF = 1.0D0 - DO 130 J = 1, NEQ - IF (K .EQ. 2) GO TO 110 - DY = ABS(PV(J)) - IF (DY .EQ. 0.0D0) DY = DELF - GO TO 120 - 110 CONTINUE - DY = Y(J) - IF (DY .EQ. 0.0D0) DY = DELY/RELPER - 120 CONTINUE - IF (SPY(J) .EQ. 0.0D0) SPY(J) = YP(J) - IF (SPY(J) .NE. 0.0D0) DY = SIGN(DY,SPY(J)) - YP(J) = DY - 130 CONTINUE - DELF = DHVNRM(YP,NEQ) - 140 CONTINUE - 150 CONTINUE -C -C PROTECT AGAINST AN OVERFLOW - DFDUB = BIG - 160 CONTINUE -C -C .................................................................. -C -C COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE -C - YDPB = DFDXB + DFDUB*FBND -C -C .................................................................. -C -C DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP -C SIZE IS TO BE BASED. A VALUE IN THE MIDDLE OF THE ERROR -C TOLERANCE RANGE IS SELECTED. -C - TOLMIN = BIG - TOLSUM = 0.0D0 - DO 170 K = 1, NEQ - TOLEXP = LOG10(ETOL(K)) - TOLMIN = MIN(TOLMIN,TOLEXP) - TOLSUM = TOLSUM + TOLEXP - 170 CONTINUE - TOLP = 10.0D0**(0.5D0*(TOLSUM/NEQ + TOLMIN)/(MORDER+1)) -C -C .................................................................. -C -C COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND -C SECOND DERIVATIVE INFORMATION -C -C RESTRICT THE STEP LENGTH TO BE NOT BIGGER -C THAN ABS(B-A). (UNLESS B IS TOO CLOSE -C TO A) - H = ABSDX -C - IF (YDPB .NE. 0.0D0 .OR. FBND .NE. 0.0D0) GO TO 180 -C -C BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND -C DERIVATIVE TERM (YDPB) ARE ZERO - IF (TOLP .LT. 1.0D0) H = ABSDX*TOLP - GO TO 200 - 180 CONTINUE -C - IF (YDPB .NE. 0.0D0) GO TO 190 -C -C ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO - IF (TOLP .LT. FBND*ABSDX) H = TOLP/FBND - GO TO 200 - 190 CONTINUE -C -C SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO - SRYDPB = SQRT(0.5D0*YDPB) - IF (TOLP .LT. SRYDPB*ABSDX) H = TOLP/SRYDPB - 200 CONTINUE -C -C FURTHER RESTRICT THE STEP LENGTH TO BE NOT -C BIGGER THAN 1/DFDUB - IF (H*DFDUB .GT. 1.0D0) H = 1.0D0/DFDUB -C -C FINALLY, RESTRICT THE STEP LENGTH TO BE NOT -C SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF -C A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, -C THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE -C STEP LENGTH. - H = MAX(H,100.0D0*SMALL*ABS(A)) - IF (H .EQ. 0.0D0) H = SMALL*ABS(B) -C -C NOW SET DIRECTION OF INTEGRATION - H = SIGN(H,DX) -C - RETURN - END -*DECK DHVNRM - DOUBLE PRECISION FUNCTION DHVNRM (V, NCOMP) -C***BEGIN PROLOGUE DHVNRM -C***SUBSIDIARY -C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF -C***LIBRARY SLATEC -C***TYPE DOUBLE PRECISION (HVNRM-S, DHVNRM-D) -C***AUTHOR Watts, H. A., (SNLA) -C***DESCRIPTION -C -C Compute the maximum norm of the vector V(*) of length NCOMP and -C return the result as DHVNRM -C -C***SEE ALSO DDEABM, DDEBDF, DDERKF -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 820301 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891024 Changed references from DVNORM to DHVNRM. (WRB) -C 891024 Changed routine name from DVNORM to DHVNRM. (WRB) -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900328 Added TYPE section. (WRB) -C 910722 Updated AUTHOR section. (ALS) -C***END PROLOGUE DHVNRM -C - INTEGER K, NCOMP - DOUBLE PRECISION V - DIMENSION V(*) -C***FIRST EXECUTABLE STATEMENT DHVNRM - DHVNRM = 0.0D0 - DO 10 K = 1, NCOMP - DHVNRM = MAX(DHVNRM,ABS(V(K))) - 10 CONTINUE - RETURN - END -*DECK J4SAVE - FUNCTION J4SAVE (IWHICH, IVALUE, ISET) -C***BEGIN PROLOGUE J4SAVE -C***SUBSIDIARY -C***PURPOSE Save or recall global variables needed by error -C handling routines. -C***LIBRARY SLATEC (XERROR) -C***TYPE INTEGER (J4SAVE-I) -C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C J4SAVE saves and recalls several global variables needed -C by the library error handling routines. -C -C Description of Parameters -C --Input-- -C IWHICH - Index of item desired. -C = 1 Refers to current error number. -C = 2 Refers to current error control flag. -C = 3 Refers to current unit number to which error -C messages are to be sent. (0 means use standard.) -C = 4 Refers to the maximum number of times any -C message is to be printed (as set by XERMAX). -C = 5 Refers to the total number of units to which -C each error message is to be written. -C = 6 Refers to the 2nd unit for error messages -C = 7 Refers to the 3rd unit for error messages -C = 8 Refers to the 4th unit for error messages -C = 9 Refers to the 5th unit for error messages -C IVALUE - The value to be set for the IWHICH-th parameter, -C if ISET is .TRUE. . -C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE -C given the value, IVALUE. If ISET=.FALSE., the -C IWHICH-th parameter will be unchanged, and IVALUE -C is a dummy parameter. -C --Output-- -C The (old) value of the IWHICH-th parameter will be returned -C in the function value, J4SAVE. -C -C***SEE ALSO XERMSG -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900205 Minor modifications to prologue. (WRB) -C 900402 Added TYPE section. (WRB) -C 910411 Added KEYWORDS section. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE J4SAVE - LOGICAL ISET - INTEGER IPARAM(9) - SAVE IPARAM - DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ - DATA IPARAM(5)/1/ - DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ -C***FIRST EXECUTABLE STATEMENT J4SAVE - J4SAVE = IPARAM(IWHICH) - IF (ISET) IPARAM(IWHICH) = IVALUE - RETURN - END -*DECK XERCNT - SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) -C***BEGIN PROLOGUE XERCNT -C***SUBSIDIARY -C***PURPOSE Allow user control over handling of errors. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERCNT-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C Allows user control over handling of individual errors. -C Just after each message is recorded, but before it is -C processed any further (i.e., before it is printed or -C a decision to abort is made), a call is made to XERCNT. -C If the user has provided his own version of XERCNT, he -C can then override the value of KONTROL used in processing -C this message by redefining its value. -C KONTRL may be set to any value from -2 to 2. -C The meanings for KONTRL are the same as in XSETF, except -C that the value of KONTRL changes only for this message. -C If KONTRL is set to a value outside the range from -2 to 2, -C it will be moved back into that range. -C -C Description of Parameters -C -C --Input-- -C LIBRAR - the library that the routine is in. -C SUBROU - the subroutine that XERMSG is being called from -C MESSG - the first 20 characters of the error message. -C NERR - same as in the call to XERMSG. -C LEVEL - same as in the call to XERMSG. -C KONTRL - the current value of the control flag as set -C by a call to XSETF. -C -C --Output-- -C KONTRL - the new value of KONTRL. If KONTRL is not -C defined, it will remain at its original value. -C This changed value of control affects only -C the current occurrence of the current message. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE -C names, changed routine name from XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERCNT - CHARACTER*(*) LIBRAR, SUBROU, MESSG -C***FIRST EXECUTABLE STATEMENT XERCNT - RETURN - END -*DECK XERHLT - SUBROUTINE XERHLT (MESSG) -C***BEGIN PROLOGUE XERHLT -C***SUBSIDIARY -C***PURPOSE Abort program execution and print error message. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERHLT-A) -C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C ***Note*** machine dependent routine -C XERHLT aborts the execution of the program. -C The error message causing the abort is given in the calling -C sequence, in case one needs it for printing on a dayfile, -C for example. -C -C Description of Parameters -C MESSG is as in XERMSG. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to delete length of character -C and changed routine name from XERABT to XERHLT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERHLT - CHARACTER*(*) MESSG -C***FIRST EXECUTABLE STATEMENT XERHLT - STOP - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/defplas.f calculix-ccx-2.3/ccx_2.1/src/defplas.f --- calculix-ccx-2.1/ccx_2.1/src/defplas.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/defplas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,179 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine defplas(elconloc,elas,emec,emec0,ithermal,icmd, - & beta,stre,ckl,vj) -! -! calculates stiffness and stresses for the deformation plasticity -! material law -! -! icmd=3: calcutates stress at mechanical strain -! else: calcutates stress and stiffness matrix at mechanical strain -! - implicit none -! - logical cauchy -! - integer ithermal,icmd,i,j,k,l,m,n,ii,istart,iend,nt,kk(84) -! - real*8 elconloc(*),elas(*),emec(*),emec0(*),beta(*),s(6),al, - & ee,un,s0,xn,stre(*),eq,c0,c1,c2,c3,dkl(3,3),ekl(3,3), - & q,dq,pp,el(6),ckl(3,3),vj -! - data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, - & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, - & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, - & 2,3,2,3/ -! - cauchy=.true. -! - istart=1 - iend=1 -! -! determining linear elastic material constants -! - ee=elconloc(1) - un=elconloc(2) - s0=elconloc(3) - xn=elconloc(4) - al=elconloc(5) -! - do i=1,6 - el(i)=emec(i) - enddo -! -! major loop -! - do ii=istart,iend -! - c0=(el(1)+el(2)+el(3))/3.d0 -! - el(1)=el(1)-c0 - el(2)=el(2)-c0 - el(3)=el(3)-c0 -! -! equivalent deviatoric strain -! - eq=dsqrt(2.d0/3.d0*(el(1)*el(1)+el(2)*el(2)+ - & el(3)*el(3)+2.d0*(el(4)*el(4)+ - & el(5)*el(5)+el(6)*el(6)))) -! -! initial value of the Mises equivalent stress (q) -! - c1=3.d0*ee*eq/(2.d0*(1.d0+un)) -! - if(c1.le.s0) then - q=c1 - else - q=(s0**(xn-1)*ee*eq/al)**(1.d0/xn) - endif -! -! determining the Mises equivalent stress q -! - c1=2.d0*(1.d0+un)/3.d0 - do - c2=al*(q/s0)**(xn-1.d0) - dq=(ee*eq-(c1+c2)*q)/(c1+xn*c2) - if((dabs(dq).lt.q*1.d-4).or.(dabs(dq).lt.1.d-10)) exit - q=q+dq - enddo -! - if(icmd.ne.3) then -! -! calculating the tangent stiffness matrix -! -! initialization of the Delta Dirac function -! - do i=1,3 - do j=1,3 - dkl(i,j)=0.d0 - enddo - enddo - do i=1,3 - dkl(i,i)=1.d0 - enddo -! - ekl(1,1)=el(1) - ekl(2,2)=el(2) - ekl(3,3)=el(3) - ekl(1,2)=el(4) - ekl(1,3)=el(5) - ekl(2,3)=el(6) - ekl(2,1)=ekl(1,2) - ekl(3,1)=ekl(1,3) - ekl(3,2)=ekl(2,3) -! - if(eq.lt.1.d-10) then - c1=ee/(1.d0+un) - c2=0.d0 - else - c1=2.d0/(3.d0*eq) - c2=c1*(1.d0/eq-1.d0/(eq+(xn-1.d0)*c2*q/ee)) - c1=c1*q - endif - c3=(ee/(1.d0-2.d0*un)-c1)/3.d0 -! - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - elas(i)=c1*((dkl(k,m)*dkl(l,n)+dkl(k,n)*dkl(l,m))/2.d0 - & -c2*ekl(k,l)*ekl(m,n)) - & +c3*dkl(k,l)*dkl(m,n) - enddo -! -! conversion of the stiffness matrix from spatial coordinates -! coordinates into material coordinates -! - call stiff2mat(elas,ckl,vj,cauchy) -! - endif -! -! calculating the stress -! - pp=-ee*c0/(1.d0-2.d0*un) -! - if(eq.lt.1.d-10) then - c1=0.d0 - else - c1=2.d0*q/(3.d0*eq) - endif -! - do i=1,6 - s(i)=el(i)*c1 - enddo - do i=1,3 - s(i)=s(i)-pp - enddo -! - do i=1,6 - stre(i)=s(i) - enddo -! -! converting the stress into the material frame of -! reference -! - call str2mat(stre,ckl,vj,cauchy) -! - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/defplasticities.f calculix-ccx-2.3/ccx_2.1/src/defplasticities.f --- calculix-ccx-2.1/ccx_2.1/src/defplasticities.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/defplasticities.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine defplasticities(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb,iline,ipol, - & inl,ipoinp,inp,ipoinpc) -! -! reading the input deck: *DEFORMATION PLASTICITY -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nelcon(2,*),nmat,ntmat,ntmat_,istep,istat, - & n,key,i,iperturb(2),iend,ncmat_,irstrt,iline,ipol,inl, - & ipoinp(2,*),inp(3,*),ipoinpc(0:*) -! - real*8 elcon(0:ncmat_,ntmat_,*) -! - ntmat=0 - iperturb(1)=3 - iperturb(2)=1 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in defplasticities: *DEFORMATION PLASTICITY' - write(*,*) ' should be placed before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in defplasticities: *DEFORMATION PLASTICITY' - write(*,*) ' should bepreceded by a *MATERIAL card' - stop - endif -! - nelcon(1,nmat)=-50 -! - iend=5 - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - nelcon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in defplasticities: increase ntmat_' - stop - endif - do i=1,iend - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - read(textpart(6)(1:20),'(f20.0)',iostat=istat) - & elcon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/densities.f calculix-ccx-2.3/ccx_2.1/src/densities.f --- calculix-ccx-2.1/ccx_2.1/src/densities.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/densities.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine densities(inpc,textpart,rhcon,nrhcon, - & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & ipoinpc) -! -! reading the input deck: *DENSITY -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nrhcon(*),nmat,ntmat,ntmat_,istep,istat,n,ipoinpc(0:*), - & key,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - real*8 rhcon(0:1,ntmat_,*) -! - ntmat=0 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in densities: *DENSITY should be placed' - write(*,*) ' before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in densities: *DENSITY should be preceded' - write(*,*) ' by a *MATERIAL card' - stop - endif -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - nrhcon(nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in densities: increase ntmat_' - stop - endif - read(textpart(1)(1:20),'(f20.0)',iostat=istat) - & rhcon(1,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) - & rhcon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/depvars.f calculix-ccx-2.3/ccx_2.1/src/depvars.f --- calculix-ccx-2.1/ccx_2.1/src/depvars.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/depvars.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine depvars(inpc,textpart,nelcon,nmat, - & nstate_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & ncocon,ipoinpc) -! -! reading the input deck: *DEPVAR -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nelcon(2,*),nmat,istep,nstate_,ncocon(2,*),ipoinpc(0:*), - & n,key,istat,nstate,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in depvars: *DEPVAR should be placed' - write(*,*) ' before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in depvars: *DEPVAR should be preceded' - write(*,*) ' by a *MATERIAL card' - stop - endif -! - if((nelcon(1,nmat).gt.-100).and.(ncocon(1,nmat).gt.-100)) then - write(*,*) '*ERROR in depvars: *DEPVAR should be preceded' - write(*,*) ' by an *USER MATERIAL card' - stop - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*) '*ERROR in depvars: incomplete definition' - stop - endif - read(textpart(1)(1:10),'(i10)',iostat=istat) nstate - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - nstate_=max(nstate_,nstate) -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/deuldlag.f calculix-ccx-2.3/ccx_2.1/src/deuldlag.f --- calculix-ccx-2.1/ccx_2.1/src/deuldlag.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/deuldlag.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,162 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine deuldlag(xi,et,ze,xlag,xeul,xj,xs) -! -! calculation of the coefficients of the linearization -! of J:=det(dx/dX)=1 at (xi,et,ze) for a 20-node quadratic -! isoparametric brick element, -1<=xi,et,ze<=1 -! xlag are Lagrangian coordinates, xeul are Eulerian coordinates -! - implicit none -! - integer i,j,k -! - real*8 xs(3,3),xlag(3,20),shpe(4,20),dd1,dd2,dd3,xeul(3,20) -! - real*8 xi,et,ze,xj,omg,omh,omr,opg,oph,opr, - & tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr, - & omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr -! -! shape functions and their glocal derivatives -! - omg=1.d0-xi - omh=1.d0-et - omr=1.d0-ze - opg=1.d0+xi - oph=1.d0+et - opr=1.d0+ze - tpgphpr=opg+oph+ze - tmgphpr=omg+oph+ze - tmgmhpr=omg+omh+ze - tpgmhpr=opg+omh+ze - tpgphmr=opg+oph-ze - tmgphmr=omg+oph-ze - tmgmhmr=omg+omh-ze - tpgmhmr=opg+omh-ze - omgopg=omg*opg/4.d0 - omhoph=omh*oph/4.d0 - omropr=omr*opr/4.d0 - omgmopg=(omg-opg)/4.d0 - omhmoph=(omh-oph)/4.d0 - omrmopr=(omr-opr)/4.d0 -! -! local derivatives of the shape functions: xi-derivative -! - shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0 - shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0 - shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0 - shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0 - shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0 - shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0 - shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0 - shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0 - shpe(1, 9)=omgmopg*omh*omr - shpe(1,10)=omhoph*omr - shpe(1,11)=omgmopg*oph*omr - shpe(1,12)=-omhoph*omr - shpe(1,13)=omgmopg*omh*opr - shpe(1,14)=omhoph*opr - shpe(1,15)=omgmopg*oph*opr - shpe(1,16)=-omhoph*opr - shpe(1,17)=-omropr*omh - shpe(1,18)=omropr*omh - shpe(1,19)=omropr*oph - shpe(1,20)=-omropr*oph -! -! local derivatives of the shape functions: eta-derivative -! - shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0 - shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0 - shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0 - shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0 - shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0 - shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0 - shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0 - shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0 - shpe(2, 9)=-omgopg*omr - shpe(2,10)=omhmoph*opg*omr - shpe(2,11)=omgopg*omr - shpe(2,12)=omhmoph*omg*omr - shpe(2,13)=-omgopg*opr - shpe(2,14)=omhmoph*opg*opr - shpe(2,15)=omgopg*opr - shpe(2,16)=omhmoph*omg*opr - shpe(2,17)=-omropr*omg - shpe(2,18)=-omropr*opg - shpe(2,19)=omropr*opg - shpe(2,20)=omropr*omg -! -! local derivatives of the shape functions: zeta-derivative -! - shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0 - shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0 - shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0 - shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0 - shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0 - shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0 - shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0 - shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0 - shpe(3, 9)=-omgopg*omh - shpe(3,10)=-omhoph*opg - shpe(3,11)=-omgopg*oph - shpe(3,12)=-omhoph*omg - shpe(3,13)=omgopg*omh - shpe(3,14)=omhoph*opg - shpe(3,15)=omgopg*oph - shpe(3,16)=omhoph*omg - shpe(3,17)=omrmopr*omg*omh - shpe(3,18)=omrmopr*opg*omh - shpe(3,19)=omrmopr*opg*oph - shpe(3,20)=omrmopr*omg*oph -! -! computation of the derivative of the global -! material coordinates w.r.t. the local coordinates -! - do i=1,3 - do j=1,3 - xs(i,j)=0.d0 - do k=1,20 - xs(i,j)=xs(i,j)+xlag(i,k)*shpe(j,k) - enddo - enddo - enddo -! -! computation of the jacobian determinant of the local -! coordinates w.r.t. the global material coordinates -! - dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2) - dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3) - dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1) - xj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3 - xj=1.d0/xj -! -! computation of the derivative of the global -! spatial coordinates w.r.t. the local coordinates -! - do i=1,3 - do j=1,3 - xs(i,j)=0.d0 - do k=1,20 - xs(i,j)=xs(i,j)+xeul(i,k)*shpe(j,k) - enddo - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/dfdbj.c calculix-ccx-2.3/ccx_2.1/src/dfdbj.c --- calculix-ccx-2.1/ccx_2.1/src/dfdbj.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dfdbj.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,407 +0,0 @@ -/* - CalculiX - A 3-dimensional finite element program - Copyright (C) 1998-2007 Guido Dhondt - - This program is free software; you can redistribute it and/or - modify it under the terms of the GNU General Public License as - published by the Free Software Foundation(version 2); - - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -*/ - -#include -#include -#include -#include -#include "CalculiX.h" - -void dfdbj(double *bcont,double **dbcontp,int *neq,int *nope,int *konl, - int* nactdof,double *s,double *z,int *ikmpc,int *ilmpc, - int *ipompc,int *nodempc,int *nmpc,double *coefmpc, - double *fnl,int *nev,int **ikactcontp,int **ilactcontp, - int *nactcont,int *nactcont_,int *mi){ - - int j,j1,jdof,kdof,k,k1,l,id,index,ist,id1,ist1,index1,id2,ist2,index2, - jdbcontcol,i1,i3,i4,mt=mi[1]+1; - double d1,sl; - - double *dbcont=*dbcontp; - int *ikactcont=*ikactcontp,*ilactcont=*ilactcontp; - - for(j=0; j<*nope; j++){ - i1=mt*(konl[j]-1)+1; - for(j1=0; j1<3; j1++){ - jdof=nactdof[i1+j1]; - if(jdof!=0){ - jdof--; - FORTRAN(nident,(ikactcont,&jdof,nactcont,&id)); - do{ - if(id>0){ - if(ikactcont[id-1]==jdof){ - jdbcontcol=ilactcont[id-1]; - break; - } - } - (*nactcont)++; - if(*nactcont>*nactcont_){ - *nactcont_=(int)(1.1**nactcont_); - RENEW(ikactcont,int,*nactcont_); - RENEW(ilactcont,int,*nactcont_); - RENEW(dbcont,double,*nev**nactcont_); - } - k=*nactcont-1; - l=k-1; - while(k>id){ - ikactcont[k]=ikactcont[l]; - ilactcont[k--]=ilactcont[l--]; - } - jdbcontcol=*nactcont; - ikactcont[id]=jdof; - ilactcont[id]=*nactcont; - memset(&dbcont[(*nactcont-1)**nev],0,sizeof(double)**nev); - break; - }while(1); - bcont[jdof]-=fnl[j*3+j1]; - i4=(jdbcontcol-1)**nev; - i3=(3*j+j1); - for(k=0; k<*nope; k++){ - for(k1=0; k1<3; k1++){ - sl=s[(3*k+k1)*60+i3]; - kdof=nactdof[mt*(konl[k]-1)+k1+1]; - if(kdof!=0){ - for(l=0; l<*nev; l++){ - dbcont[i4+l]-=sl*z[(long long)l**neq+kdof-1]; - } - } - else{ - kdof=8*(konl[k]-1)+k1+1; - FORTRAN(nident,(ikmpc,&kdof,nmpc,&id)); - if(id>0){ - id--; - if(ikmpc[id]==kdof){ - id=ilmpc[id]; - ist=ipompc[id-1]; - ist--; - index=nodempc[ist*3+2]; - if(index==0) continue; - index--; - do{ - kdof=nactdof[mt*(nodempc[index*3])+nodempc[index*3+1]]; - d1=sl*coefmpc[index]/coefmpc[ist]; - if(kdof!=0){ - for(l=0; l<*nev; l++){ - dbcont[i4+l]+=d1*z[(long long)l**neq+kdof-1]; - } - } - index=nodempc[index*3+2]; - if(index==0) break; - index--; - }while(1); - } - } - } - } - } - } - else{ - jdof=8*(konl[j]-1)+j1+1; - FORTRAN(nident,(ikmpc,&jdof,nmpc,&id1)); - if(id1>0){ - id1--; - if(ikmpc[id1]==jdof){ - id1=ilmpc[id1]; - ist1=ipompc[id1-1]; - ist1--; - index1=nodempc[ist1*3+2]; - if(index1==0) continue; - index1--; - do{ - jdof=nactdof[mt*(nodempc[index1*3])+nodempc[index1*3+1]]; - if(jdof!=0){ - jdof--; - FORTRAN(nident,(ikactcont,&jdof,nactcont,&id)); - do{ - if(id>0){ - if(ikactcont[id-1]==jdof){ - jdbcontcol=ilactcont[id-1]; - } - } - (*nactcont)++; - if(*nactcont>*nactcont_){ - *nactcont_=(int)(1.1**nactcont_); - RENEW(ikactcont,int,*nactcont_); - RENEW(ilactcont,int,*nactcont_); - RENEW(dbcont,double,*nev**nactcont_); - } - k=*nactcont-1; - l=k-1; - do{ - ikactcont[k]=ikactcont[l]; - ilactcont[k--]=ilactcont[l--]; - }while(k>id); - jdbcontcol=*nactcont; - ikactcont[id]=jdof; - ilactcont[id]=*nactcont; - memset(&dbcont[(*nactcont-1)**nev],0,sizeof(double)**nev); - break; - }while(1); - bcont[jdof]+=coefmpc[index1]*fnl[j*3+j1]/coefmpc[ist1]; - i4=(jdbcontcol-1)**nev; - i3=(3*j+j1); - for(k=0; k<*nope; k++){ - for(k1=0; k1<3; k1++){ - sl=s[(3*k+k1)*60+i3]; - kdof=nactdof[mt*(konl[k]-1)+k1+1]; - if(kdof!=0){ - d1=sl*coefmpc[index1]/coefmpc[ist1]; - for(l=0; l<*nev; l++){ - dbcont[i4+l]+=d1*z[(long long)l**neq+kdof-1]; - } - } - else{ - kdof=8*(konl[k]-1)+k1+1; - FORTRAN(nident,(ikmpc,&kdof,nmpc,&id2)); - if(id2>0){ - id2--; - if(ikmpc[id2]==kdof){ - id2=ilmpc[id2]; - ist2=ipompc[id2-1]; - ist2--; - index2=nodempc[ist2*3+2]; - if(index2==0) continue; - index2--; - do{ - kdof=nactdof[mt*(nodempc[index2*3])+nodempc[index2*3+1]]; - if(kdof!=0){ - d1=sl*coefmpc[index1]*coefmpc[index2]/(coefmpc[ist1]*coefmpc[ist2]); - for(l=0; l<*nev; l++){ - dbcont[i4+l]-=d1*z[(long long)l**neq+kdof-1]; - } - } - index2=nodempc[index2*3+2]; - if(index2==0) break; - index2--; - }while(1); - } - } - } - } - } - } - index1=nodempc[index1*3+2]; - if(index1==0) break; - index1--; - }while(1); - } - } - } - } - } - *dbcontp=dbcont; - *ikactcontp=ikactcont; - *ilactcontp=ilactcont; -} - -/*! - ! CalculiX - A 3-dimensional finite element program - ! Copyright (C) 1998-2007 Guido Dhondt - ! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dfdbj(bcont,dbcont,neq,nope,konl,nactdof,s,z, - & ikmpc,ilmpc,ipompc,nodempc,nmpc,coefmpc,fnl,nev,iactcont, - & nactcont) -! -! calculates the derivative of the contact forces with respect -! to the modal variables -! - implicit none -! - integer j,j1,neq,nope,konl(*),nactdof(0:3,*),jdof,kdof, - & k,k1,l,id,ikmpc(*),ilmpc(*),ipompc(*),nodempc(3,*),nmpc, - & index,ist,id1,ist1,index1,id2,ist2,index2,nev ,iactcont(*), - & nactcont,jdofcont -! - real*8 bcont(*),dbcont(nev,*),s(60,60),z(neq,*),coefmpc(*), - & fnl(3,9) -! - do j=1,nope - do j1=1,3 - jdof=nactdof(j1,konl(j)) - if(jdof.ne.0) then - call nident(iactcont,jdof,nactcont,id) - jdofcont=0 - if(id.gt.0)then - if(iactcont(id).eq.jdof) then - jdofcont=id - endif - endif - if(jdofcont.eq.0) then - nactcont=nactcont+1 - do k=nactcont,id+2,-1 - iactcont(k)=iactcont(k-1) - do l=1,nev - dbcont(l,k)=dbcont(l,k-1) - enddo - enddo - jdofcont=id+1 - iactcont(jdofcont)=jdof - do l=1,nev - dbcont(l,jdofcont)=0.d0 - enddo - endif - bcont(jdof)=bcont(jdof)-fnl(j1,j) - do k=1,nope - do k1=1,3 - kdof=nactdof(k1,konl(k)) - if(kdof.ne.0) then - do l=1,nev - dbcont(l,jdofcont)=dbcont(l,jdofcont)- - & s(3*(j-1)+j1,3*(k-1)+k1)*z(kdof,l) - enddo - else - kdof=8*(konl(k)-1)+k1 - call nident(ikmpc,kdof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.kdof) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - kdof=nactdof(nodempc(2,index), - & nodempc(1,index)) - if(kdof.ne.0) then - do l=1,nev - dbcont(l,jdofcont)= - & dbcont(l,jdofcont)+ - & s(3*(j-1)+j1,3*(k-1)+k1)* - & coefmpc(index)*z(kdof,l)/ - & coefmpc(ist) - enddo - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - endif - enddo - enddo - else - jdof=8*(konl(j)-1)+j1 - call nident(ikmpc,jdof,nmpc,id1) - if(id1.gt.0) then - if(ikmpc(id1).eq.jdof) then - id1=ilmpc(id1) - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - jdof=nactdof(nodempc(2,index1), - & nodempc(1,index1)) - if(jdof.ne.0) then - call nident(iactcont,jdof,nactcont,id) - jdofcont=0 - if(id.gt.0)then - if(iactcont(id).eq.jdof) then - jdofcont=id - endif - endif - if(jdofcont.eq.0) then - nactcont=nactcont+1 - do k=nactcont,id+2,-1 - iactcont(k)=iactcont(k-1) - do l=1,nev - dbcont(l,k)=dbcont(l,k-1) - enddo - enddo - jdofcont=id+1 - iactcont(jdofcont)=jdof - do l=1,nev - dbcont(l,jdofcont)=0.d0 - enddo - endif - bcont(jdofcont)=bcont(jdofcont)+ - & coefmpc(index1)* - & fnl(j1,j)/coefmpc(ist1) - do k=1,nope - do k1=1,3 - kdof=nactdof(k1,konl(k)) - if(kdof.ne.0) then - do l=1,nev - dbcont(l,jdofcont)= - & dbcont(l,jdofcont) - & +s(3*(j-1)+j1,3*(k-1)+k1) - & *coefmpc(index1)*z(kdof,l)/ - & coefmpc(ist1) - enddo - else - kdof=8*(konl(k)-1)+k1 - call nident(ikmpc,kdof,nmpc,id2) - if(id2.gt.0) then - if(ikmpc(id2).eq.kdof) then - id2=ilmpc(id2) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) cycle - do -! -! translated to the left to avoid exceedance -! of 72 columns -! - kdof=nactdof(nodempc(2,index2), - & nodempc(1,index2)) - if(kdof.ne.0) then - do l=1,nev - dbcont(l,jdofcont)=dbcont(l,jdofcont) - & -s(3*(j-1)+j1,3*(k-1)+k1) - & *coefmpc(index1) - & *coefmpc(index2)*z(kdof,l)/ - & (coefmpc(ist1)*coefmpc(ist2)) - enddo - endif - index2=nodempc(3,index2) - if(index2.eq.0) exit -! -! end of translation -! - enddo - endif - endif - endif - enddo - enddo - endif - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif - endif - endif - enddo - enddo -! - return - end - */ diff -Nru calculix-ccx-2.1/ccx_2.1/src/dfluxes.f calculix-ccx-2.3/ccx_2.1/src/dfluxes.f --- calculix-ccx-2.1/ccx_2.1/src/dfluxes.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dfluxes.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,241 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dfluxes(inpc,textpart,set,istartset,iendset, - & ialset,nset,nelemload,sideload,xload,nload,nload_, - & ielmat,ntmat_,iamload, - & amname,nam,lakon,ne,dflux_flag,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,nam_,namtot_,namta,amta,ipoinpc) -! -! reading the input deck: *DFLUX -! - implicit none -! - logical dflux_flag -! - character*1 inpc(*) - character*8 lakon(*) - character*20 sideload(*),label - character*80 amname(*),amplitude - character*81 set(*),elset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),nelemload(2,*), - & ielmat(*),nset,nload,nload_,ntmat_,istep,istat,n,i,j,l,key, - & iamload(2,*),nam,iamplitude,ipos,ne,iline,ipol,inl,ipoinp(2,*), - & inp(3,*),nam_,namtot,namtot_,namta(3,*),idelay,isector, - & ipoinpc(0:*) -! - real*8 xload(2,*),xmagnitude,amta(2,*) -! - iamplitude=0 - idelay=0 - isector=0 -! - if(istep.lt.1) then - write(*,*) '*ERROR in dfluxes: *DFLUX should only be used' - write(*,*) ' within a STEP' - stop - endif -! - do i=2,n - if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.dflux_flag)) then - do j=1,nload - if((sideload(j)(1:1).eq.'S').or. - & (sideload(j)(1:2).eq.'BF')) then - xload(1,j)=0.d0 - endif - enddo - elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then - read(textpart(i)(11:90),'(a80)') amplitude - do j=nam,1,-1 - if(amname(j).eq.amplitude) then - iamplitude=j - exit - endif - enddo - if(j.gt.nam) then - write(*,*)'*ERROR in dfluxes: nonexistent amplitude' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iamplitude=j - elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN - if(idelay.ne.0) then - write(*,*) '*ERROR in dfluxes: the parameter TIME DELAY' - write(*,*) ' is used twice in the same keyword' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - else - idelay=1 - endif - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in dfluxes: increase nam_' - stop - endif - amname(nam)=' - & ' - if(iamplitude.eq.0) then - write(*,*) '*ERROR in dfluxes: time delay must be' - write(*,*) ' preceded by the amplitude parameter' - stop - endif - namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) - iamplitude=nam - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) '*ERROR dfluxes: increase namtot_' - stop - endif - namta(1,nam)=namtot - namta(2,nam)=namtot - read(textpart(i)(11:30),'(f20.0)',iostat=istat) - & amta(1,namtot) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - enddo -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return -! - read(textpart(2)(1:20),'(a20)',iostat=istat) label -! -! compatibility with ABAQUS for shells -! - if(label(2:4).eq.'NEG') label(2:4)='1 ' - if(label(2:4).eq.'POS') label(2:4)='2 ' - if(label(2:2).eq.'N') label(2:2)='5' - if(label(2:2).eq.'P') label(2:2)='6' -! - read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagnitude -! - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(((label(1:2).ne.'S1').and.(label(1:2).ne.'S2').and. - & (label(1:2).ne.'S3').and.(label(1:2).ne.'S4').and. - & (label(1:2).ne.'S5').and.(label(1:2).ne.'S6').and. - & (label(1:2).ne.'BF').and.(label(1:2).ne.'S ')).or. - & ((label(3:4).ne.' ').and.(label(3:4).ne.'NU'))) then - call inputerror(inpc,ipoinpc,iline) - endif -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - if(l.gt.ne) then - write(*,*) '*ERROR in dfluxes: element ',l - write(*,*) ' is not defined' - stop - endif -! - if((lakon(l)(1:2).eq.'CP').or. - & (lakon(l)(2:2).eq.'A').or. - & (lakon(l)(7:7).eq.'E').or. - & (lakon(l)(7:7).eq.'S').or. - & (lakon(l)(7:7).eq.'A')) then - if(label(1:2).eq.'S1') then - label(1:2)='S3' - elseif(label(1:2).eq.'S2') then - label(1:2)='S4' - elseif(label(1:2).eq.'S3') then - label(1:2)='S5' - elseif(label(1:2).eq.'S4') then - label(1:2)='S6' - elseif(label(1:2).eq.'S5') then - label(1:2)='S1' - elseif(label(1:2).eq.'S6') then - label(1:2)='S2' - endif - elseif((lakon(l)(1:1).eq.'B').or. - & (lakon(l)(7:7).eq.'B')) then - elseif((lakon(l)(1:1).eq.'S').or. - & (lakon(l)(7:7).eq.'L')) then - endif - call loadadd(l,label,xmagnitude,nelemload,sideload, - & xload,nload,nload_,iamload,iamplitude, - & nam,isector) - else - read(textpart(1)(1:80),'(a80)',iostat=istat) elset - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - do i=1,nset - if(set(i).eq.elset) exit - enddo - if(i.gt.nset) then - elset(ipos:ipos)=' ' - write(*,*) '*ERROR in dfluxes: element set ',elset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! - l=ialset(istartset(i)) - if((lakon(l)(1:2).eq.'CP').or. - & (lakon(l)(2:2).eq.'A').or. - & (lakon(l)(7:7).eq.'E').or. - & (lakon(l)(7:7).eq.'S').or. - & (lakon(l)(7:7).eq.'A')) then - if(label(1:2).eq.'S1') then - label(1:2)='S3' - elseif(label(1:2).eq.'S2') then - label(1:2)='S4' - elseif(label(1:2).eq.'S3') then - label(1:2)='S5' - elseif(label(1:2).eq.'S4') then - label(1:2)='S6' - endif - elseif((lakon(l)(1:1).eq.'B').or. - & (lakon(l)(7:7).eq.'B')) then - if(label(1:2).eq.'S2') label(1:2)='S5' - elseif((lakon(l)(1:1).eq.'S').or. - & (lakon(l)(7:7).eq.'L')) then - label(1:2)='S1' - endif -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - l=ialset(j) - call loadadd(l,label,xmagnitude,nelemload,sideload, - & xload,nload,nload_,iamload,iamplitude, - & nam,isector) - else - l=ialset(j-2) - do - l=l-ialset(j) - if(l.ge.ialset(j-1)) exit - call loadadd(l,label,xmagnitude,nelemload, - & sideload,xload,nload,nload_, - & iamload,iamplitude,nam,isector) - enddo - endif - enddo - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/dflux.f calculix-ccx-2.3/ccx_2.1/src/dflux.f --- calculix-ccx-2.1/ccx_2.1/src/dflux.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dflux.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,361 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dflux(flux,sol,kstep,kinc,time,noel,npt,coords, - & jltyp,temp,press,loadtype,area,vold,co,lakonl,konl, - & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,iscale,mi) -! -! user subroutine dflux -! -! -! INPUT: -! -! sol current temperature value -! kstep step number -! kinc increment number -! time(1) current step time -! time(2) current total time -! noel element number -! npt integration point number -! coords(1..3) global coordinates of the integration point -! jltyp loading face kode: -! 1 = body flux -! 11 = face 1 -! 12 = face 2 -! 13 = face 3 -! 14 = face 4 -! 15 = face 5 -! 16 = face 6 -! temp currently not used -! press currently not used -! loadtype load type label -! area for surface flux: area covered by the -! integration point -! for body flux: volume covered by the -! integration point -! vold(0..4,1..nk) solution field in all nodes -! 0: temperature -! 1: displacement in global x-direction -! 2: displacement in global y-direction -! 3: displacement in global z-direction -! 4: static pressure -! co(3,1..nk) coordinates of all nodes -! 1: coordinate in global x-direction -! 2: coordinate in global y-direction -! 3: coordinate in global z-direction -! lakonl element label -! konl(1..20) nodes belonging to the element -! ipompc(1..nmpc)) ipompc(i) points to the first term of -! MPC i in field nodempc -! nodempc(1,*) node number of a MPC term -! nodempc(2,*) coordinate direction of a MPC term -! nodempc(3,*) if not 0: points towards the next term -! of the MPC in field nodempc -! if 0: MPC definition is finished -! coefmpc(*) coefficient of a MPC term -! nmpc number of MPC's -! ikmpc(1..nmpc) ordered global degrees of freedom of the MPC's -! the global degree of freedom is -! 8*(node-1)+direction of the dependent term of -! the MPC (direction = 0: temperature; -! 1-3: displacements; 4: static pressure; -! 5-7: rotations) -! ilmpc(1..nmpc) ilmpc(i) is the MPC number corresponding -! to the reference number in ikmpc(i) -! mi(1) max # of integration points per element (max -! over all elements) -! mi(2) max degree of freedomm per node (max over all -! nodes) in fields like v(0:mi(2))... -! -! OUTPUT: -! -! flux(1) magnitude of the flux -! flux(2) not used; please do NOT assign any value -! iscale determines whether the flux has to be -! scaled for increments smaller than the -! step time in static calculations -! 0: no scaling -! 1: scaling (default) -! - implicit none -! - character*8 lakonl - character*20 loadtype -! - integer kstep,kinc,noel,npt,jltyp,konl(20),ipompc(*), - & nodempc(3,*),nmpc,ikmpc(*),ilmpc(*),node,idof,id,iscale,mi(2) -! - real*8 flux(2),time(2),coords(3),sol,temp,press,vold(0:mi(2),*), - & area,co(3,*),coefmpc(*) -! -! the code starting here up to the end of the file serves as -! an example for combined mechanical-lubrication problems. -! Please replace it by your own code for your concrete application. -! - include "gauss.f" -! - integer ifaceq(8,6),ifacet(6,4),ifacew(8,5),ig,nelem,nopes, - & iflag,i,j,k,nope -! - real*8 xl21(3,8),xi,et,al,rho,um,h,pnode1(3),pnode2(3), - & ratio(8),dist,xl22(3,8),dpnode1(3,3),dpnode2(3,3),v1(3), - & v2(3),dh(3),xsj2(3),xs2(3,7),shp2(7,8) -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ - data ifacew /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ - data iflag /3/ -! - nelem=noel -! - if(lakonl(4:4).eq.'2') then - nope=20 - nopes=8 - elseif(lakonl(4:4).eq.'8') then - nope=8 - nopes=4 - elseif(lakonl(4:5).eq.'10') then - nope=10 - nopes=6 - elseif(lakonl(4:4).eq.'4') then - nope=4 - nopes=3 - elseif(lakonl(4:5).eq.'15') then - nope=15 - elseif(lakonl(4:4).eq.'6') then - nope=6 - endif -! -! treatment of wedge faces -! - if(lakonl(4:4).eq.'6') then - if(ig.le.2) then - nopes=3 - else - nopes=4 - endif - endif - if(lakonl(4:5).eq.'15') then - if(ig.le.2) then - nopes=6 - else - nopes=8 - endif - endif -! -! first side of the oil film -! - ig=1 -! - if((nope.eq.20).or.(nope.eq.8)) then - do i=1,nopes - node=konl(ifaceq(i,ig)) - idof=8*(node-1)+4 - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in dflux: node ',node - write(*,*) ' is not connected to the structure' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - do j=1,3 - xl21(j,i)=co(j,node)+ - & vold(j,node) - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - write(*,*) '*ERROR in dload: tetrahedral elements' - write(*,*) ' are not allowed' - stop - else - do i=1,nopes - node=konl(ifacew(i,ig)) - idof=8*(node-1)+4 - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in dflux: node ',node - write(*,*) ' is not connected to the structure' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - do j=1,3 - xl21(j,i)=co(j,node)+ - & vold(j,node) - enddo - enddo - endif -! -! projecting the integration point on the first side of the -! oil film -! - do j=1,3 - pnode1(j)=coords(j) - enddo -! - call attach(xl21,pnode1,nopes,ratio,dist,xi,et) -! -! derivative of the shape functions in (xi,et) -! - if(nopes.eq.8) then - call shape8q(xi,et,xl21,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.4) then - call shape4q(xi,et,xl21,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.6) then - call shape6tri(xi,et,xl21,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,xl21,xsj2,xs2,shp2,iflag) - endif -! -! the gradient of pnode1 -! dpnode1(j,k)=dpnode1(j)/dx(k) -! - do i=1,3 - do j=1,3 - dpnode1(i,j)=0.d0 - do k=1,nopes - dpnode1(i,j)=dpnode1(i,j)+shp2(j,k)*xl21(i,k) - enddo - enddo - enddo -! -! second side of the oil film -! - ig=2 -! - if((nope.eq.20).or.(nope.eq.8)) then - do i=1,nopes - node=konl(ifaceq(i,ig)) - idof=8*(node-1)+4 - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in dflux: node ',node - write(*,*) ' is not connected to the structure' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - do j=1,3 - xl22(j,i)=co(j,node)+ - & vold(j,node) - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - write(*,*) '*ERROR in dload: tetrahedral elements' - write(*,*) ' are not allowed' - stop - else - do i=1,nopes - node=konl(ifacew(i,ig)) - idof=8*(node-1)+4 - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in dflux: node ',node - write(*,*) ' is not connected to the structure' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - do j=1,3 - xl22(j,i)=co(j,node)+ - & vold(j,node) - enddo - enddo - endif -! -! projecting the integration point on the second side of the -! oil film -! - do j=1,3 - pnode2(j)=coords(j) - enddo -! - call attach(xl22,pnode2,nopes,ratio,dist,xi,et) -! -! derivative of the shape functions in (xi,et) -! - if(nopes.eq.8) then - call shape8q(xi,et,xl22,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.4) then - call shape4q(xi,et,xl22,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.6) then - call shape6tri(xi,et,xl22,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,xl22,xsj2,xs2,shp2,iflag) - endif -! -! the gradient of pnode1 -! dpnode2(j,k)=dpnode2(j)/dx(k) -! - do i=1,3 - do j=1,3 - dpnode2(i,j)=0.d0 - do k=1,nopes - dpnode2(i,j)=dpnode2(i,j)+shp2(j,k)*xl22(i,k) - enddo - enddo - enddo -! -! calculating the thickness of the oil film -! - h=dsqrt((pnode1(1)-pnode2(1))**2+ - & (pnode1(2)-pnode2(2))**2+ - & (pnode1(3)-pnode2(3))**2) -! -! calculating the gradient of the oil film thickness -! - do i=1,3 - dh(i)=((pnode1(1)-pnode2(1))*(dpnode1(1,i)-dpnode2(1,i)) - & +(pnode1(2)-pnode2(2))*(dpnode1(2,i)-dpnode2(2,i)) - & +(pnode1(3)-pnode2(3))*(dpnode1(3,i)-dpnode2(3,i)))/h - enddo -! -! velocity of the parts adjoining the film -! the axis or rotation is assumed to be the x-axis -! - do i=1,3 - v1(i)=0.d0 - enddo - v2(1)=0.d0 - v2(2)=-26000.d0*coords(3)/dsqrt(coords(2)**2+coords(3)**2) - v2(3)=26000.d0*coords(2)/dsqrt(coords(2)**2+coords(3)**2) -! -! density (oil, N-mm-s-K system) -! - rho=890.d-9 -! -! body flux -! - flux(1)=-rho*((v1(1)+v2(1))*dh(1)+ - & (v1(2)+v2(2))*dh(2)+ - & (v1(3)+v2(3))*dh(3))/2.d0 -! - iscale=0 -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/dgesv.f calculix-ccx-2.3/ccx_2.1/src/dgesv.f --- calculix-ccx-2.1/ccx_2.1/src/dgesv.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dgesv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,2429 +0,0 @@ -! -! subroutines to solve a set of linear equations with -! a general real matrix -! -! - SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGESV computes the solution to a real system of linear equations -* A * X = B, -* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as -* A = P * L * U, -* where P is a permutation matrix, L is unit lower triangular, and U is -* upper triangular. The factored form of A is then used to solve the -* system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the N-by-N coefficient matrix A. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (output) INTEGER array, dimension (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS matrix of right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, so the solution could not be computed. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL DGETRF, DGETRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGESV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of A. -* - CALL DGETRF( N, N, A, LDA, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, - $ INFO ) - END IF - RETURN -* -* End of DGESV -* - END - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER IDAMAX - EXTERNAL IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A' * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A'* X = B (Transpose) -* = 'C': A'* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A' * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1998 -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* Purpose -* ======= -* -* IEEECK is called from the ILAENV to verify that Infinity and -* possibly NaN arithmetic is safe (i.e. will not trap). -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies whether to test just for inifinity arithmetic -* or whether to test for infinity and NaN arithmetic. -* = 0: Verify infinity arithmetic only. -* = 1: Verify infinity and NaN arithmetic. -* -* ZERO (input) REAL -* Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* ONE (input) REAL -* Must contain the value 1.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* RETURN VALUE: INTEGER -* = 0: Arithmetic failed to produce the correct answers -* = 1: Arithmetic produced the correct answers -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*0.0 -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, - $ N4 ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* This version provides a set of parameters which should give good, -* but not optimal, performance on many of the currently available -* computers. Users are encouraged to modify this subroutine to set -* the tuning parameters for their particular machine using the option -* and problem size information in the arguments. -* -* This routine will not function correctly if it is converted to all -* lower case. Converting it to all upper case is allowed. -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies the parameter to be returned as the value of -* ILAENV. -* = 1: the optimal blocksize; if this value is 1, an unblocked -* algorithm will give the best performance. -* = 2: the minimum block size for which the block routine -* should be used; if the usable block size is less than -* this value, an unblocked routine should be used. -* = 3: the crossover point (in a block routine, for N less -* than this value, an unblocked routine should be used) -* = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines -* = 5: the minimum column dimension for blocking to be used; -* rectangular blocks must have dimension at least k by m, -* where k is given by ILAENV(2,...) and m by ILAENV(5,...) -* = 6: the crossover point for the SVD (when reducing an m by n -* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -* this value, a QR factorization is used first to reduce -* the matrix to a triangular form.) -* = 7: the number of processors -* = 8: the crossover point for the multishift QR and QZ methods -* for nonsymmetric eigenvalue problems. -* = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* =10: ieee NaN arithmetic can be trusted not to trap -* =11: infinity arithmetic can be trusted not to trap -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) CHARACTER*(*) -* The character options to the subroutine NAME, concatenated -* into a single character string. For example, UPLO = 'U', -* TRANS = 'T', and DIAG = 'N' for a triangular routine would -* be specified as OPTS = 'UTN'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* (ILAENV) (output) INTEGER -* >= 0: the value of the parameter specified by ISPEC -* < 0: if ILAENV = -k, the k-th argument had an illegal value. -* -* Further Details -* =============== -* -* The following conventions have been used when calling ILAENV from the -* LAPACK routines: -* 1) OPTS is a concatenation of all of the character options to -* subroutine NAME, in the same order that they appear in the -* argument list for NAME, even if they are not used in determining -* the value of the parameter specified by ISPEC. -* 2) The problem dimensions N1, N2, N3, N4 are specified in the order -* that they appear in the argument list for NAME. N1 is used -* first, N2 second, and so on, and unused problem dimensions are -* passed a value of -1. -* 3) The parameter value returned by ILAENV is checked for validity in -* the calling subroutine. For example, ILAENV is used to retrieve -* the optimal blocksize for STRTRI as follows: -* -* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -* IF( NB.LE.1 ) NB = MAX( 1, N ) -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL CNAME, SNAME - CHARACTER*1 C1 - CHARACTER*2 C2, C4 - CHARACTER*3 C3 - CHARACTER*6 SUBNAM - INTEGER I, IC, IZ, NB, NBMIN, NX -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. External Functions .. - INTEGER IEEECK - EXTERNAL IEEECK -* .. -* .. Executable Statements .. -* -C GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, -C $ 1100 ) ISPEC -C CHANGED COMPUTED GOTO: OBSOLETE -C - IF((ISPEC.EQ.1).OR.(ISPEC.EQ.2).OR.(ISPEC.EQ.3)) THEN - GO TO 100 - ELSEIF(ISPEC.EQ.4) THEN - GO TO 400 - ELSEIF(ISPEC.EQ.5) THEN - GO TO 500 - ELSEIF(ISPEC.EQ.6) THEN - GO TO 600 - ELSEIF(ISPEC.EQ.7) THEN - GO TO 700 - ELSEIF(ISPEC.EQ.8) THEN - GO TO 800 - ELSEIF(ISPEC.EQ.9) THEN - GO TO 900 - ELSEIF(ISPEC.EQ.10) THEN - GO TO 1000 - ELSEIF(ISPEC.EQ.11) THEN - GO TO 1100 - ENDIF -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 100 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1:1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 10 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 10 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1:1 ) = CHAR( IC+64 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) - $ SUBNAM( I:I ) = CHAR( IC+64 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 30 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1:1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2:3 ) - C3 = SUBNAM( 4:6 ) - C4 = C3( 2:3 ) -* - GO TO ( 110, 200, 300 ) ISPEC -* - 110 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - NB = 64 - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 32 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 200 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - END IF - ILAENV = NBMIN - RETURN -* - 300 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 32 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - END IF - ILAENV = NX - RETURN -* - 400 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 500 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 600 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 700 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 800 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* - 900 CONTINUE -* -* ISPEC = 9: maximum size of the subproblems at the bottom of the -* computation tree in the divide-and-conquer algorithm -* (used by xGELSD and xGESDD) -* - ILAENV = 25 - RETURN -* - 1000 CONTINUE -* -* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap -* -c ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 0, 0.0, 1.0 ) - END IF - RETURN -* - 1100 CONTINUE -* -* ISPEC = 11: infinity arithmetic can be trusted not to trap -* -c ILAENV = 0 - ILAENV = 1 - IF( ILAENV.EQ.1 ) THEN - ILAENV = IEEECK( 1, 0.0, 1.0 ) - END IF - RETURN -* -* End of ILAENV -* - END -cc - integer function idamax(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dmax - integer i,incx,ix,n -c - idamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - idamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).le.dmax) go to 5 - idamax = i - dmax = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).le.dmax) go to 30 - idamax = i - dmax = dabs(dx(i)) - 30 continue - return - end -cc - SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGER performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END -c SUBROUTINE XERBLA( SRNAME, INFO ) -c* -c* -- LAPACK auxiliary routine (preliminary version) -- -c* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -c* Courant Institute, Argonne National Lab, and Rice University -c* February 29, 1992 -c* -c* .. Scalar Arguments .. -c CHARACTER*6 SRNAME -c INTEGER INFO -c* .. -c* -c* Purpose -c* ======= -c* -c* XERBLA is an error handler for the LAPACK routines. -c* It is called by an LAPACK routine if an input parameter has an -c* invalid value. A message is printed and execution stops. -c* -c* Installers may consider modifying the STOP statement in order to -c* call system-specific exception-handling facilities. -cc* -c* Arguments -c* ========= -c* -c* SRNAME (input) CHARACTER*6 -c* The name of the routine which called XERBLA. -c* -c* INFO (input) INTEGER -c* The position of the invalid parameter in the parameter list -c* of the calling routine. -c* -c* -c WRITE( *, FMT = 9999 )SRNAME, INFO -c* -c STOP -c* -c 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', -c $ 'an illegal value' ) -c* -c* End of XERBLA -c* -c END -cc - subroutine dswap (n,dx,incx,dy,incy) -c -c interchanges two vectors. -c uses unrolled loops for increments equal one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dx(ix) - dx(ix) = dy(iy) - dy(iy) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,3) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - 30 continue - if( n .lt. 3 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,3 - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - dtemp = dx(i + 1) - dx(i + 1) = dy(i + 1) - dy(i + 1) = dtemp - dtemp = dx(i + 2) - dx(i + 2) = dy(i + 2) - dy(i + 2) = dtemp - 50 continue - return - end -cc - subroutine dscal(n,da,dx,incx) -c -c scales a vector by a constant. -c uses unrolled loops for increment equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision da,dx(*) - integer i,incx,m,mp1,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dx(i) = da*dx(i) - 10 continue - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dx(i) = da*dx(i) - 30 continue - if( n .lt. 5 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dx(i) = da*dx(i) - dx(i + 1) = da*dx(i + 1) - dx(i + 2) = da*dx(i + 2) - dx(i + 3) = da*dx(i + 3) - dx(i + 4) = da*dx(i + 4) - 50 continue - return - end -cc - SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B. -* - IF( UPPER )THEN - DO 130, J = 1, N - DO 120, I = 1, M - TEMP = ALPHA*B( I, J ) - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - DO 140, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 140 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 210, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 170, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 170 CONTINUE - END IF - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 180, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 200, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 220, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 220 CONTINUE - END IF - DO 240, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 230, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 250, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ). -* - IF( UPPER )THEN - DO 310, K = N, 1, -1 - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - DO 290, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 280, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 280 CONTINUE - END IF - 290 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 300, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360, K = 1, N - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 320, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 320 CONTINUE - END IF - DO 340, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 330, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 330 CONTINUE - END IF - 340 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 350, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END -cc - SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DGEMM performs one of the matrix-matrix operations -* -* C := alpha*op( A )*op( B ) + beta*C, -* -* where op( X ) is one of -* -* op( X ) = X or op( X ) = X', -* -* alpha and beta are scalars, and A, B and C are matrices, with op( A ) -* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -* -* Parameters -* ========== -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n', op( A ) = A. -* -* TRANSA = 'T' or 't', op( A ) = A'. -* -* TRANSA = 'C' or 'c', op( A ) = A'. -* -* Unchanged on exit. -* -* TRANSB - CHARACTER*1. -* On entry, TRANSB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANSB = 'N' or 'n', op( B ) = B. -* -* TRANSB = 'T' or 't', op( B ) = B'. -* -* TRANSB = 'C' or 'c', op( B ) = B'. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix -* op( A ) and of the matrix C. M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix -* op( B ) and the number of columns of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of columns of the matrix -* op( A ) and the number of rows of the matrix op( B ). K must -* be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANSA = 'N' or 'n', and is m otherwise. -* Before entry with TRANSA = 'N' or 'n', the leading m by k -* part of the array A must contain the matrix A, otherwise -* the leading k by m part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANSA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -* n when TRANSB = 'N' or 'n', and is k otherwise. -* Before entry with TRANSB = 'N' or 'n', the leading k by n -* part of the array B must contain the matrix B, otherwise -* the leading n by k part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANSB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n matrix -* ( alpha*op( A )*op( B ) + beta*C ). -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* transposed and set NROWA, NCOLA and NROWB as the number of rows -* and columns of A and the number of rows of B respectively. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And if alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K - IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF( NOTA )THEN -* -* Form C := alpha*A*B' + beta*C -* - DO 170, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 130, I = 1, M - C( I, J ) = ZERO - 130 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 140, I = 1, M - C( I, J ) = BETA*C( I, J ) - 140 CONTINUE - END IF - DO 160, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 200, J = 1, N - DO 190, I = 1, M - TEMP = ZERO - DO 180, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 180 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/diamtr.f calculix-ccx-2.3/ccx_2.1/src/diamtr.f --- calculix-ccx-2.1/ccx_2.1/src/diamtr.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/diamtr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,99 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine diamtr(n,e2,adj,xadj,mask,ls,xls,hlevel,snode,nc) -! -! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) -! - integer nc,j,snode,degree,mindeg,istrt,istop,hsize,node,jstrt, - & jstop,ewidth,i,width,depth,enode,n,sdepth,e2,xadj(n+1),adj(e2), - & xls(n+1),ls(n),mask(n),hlevel(n) -! - mindeg=n - do 10 i=1,n - if(mask(i).eq.0) then - degree=xadj(i+1)-xadj(i) - if(degree.lt.mindeg) then - snode=i - mindeg=degree - endif - endif - 10 continue -! - call rootls(n,snode,n+1,e2,adj,xadj,mask,ls,xls,sdepth,width) -! - nc=xls(sdepth+1)-1 -! - 15 continue -! - hsize=0 - istrt=xls(sdepth) - istop=xls(sdepth+1)-1 - do 20 i=istrt,istop - node=ls(i) - hsize=hsize+1 - hlevel(hsize)=node - xls(node)=xadj(node+1)-xadj(node) - 20 continue -! - if(hsize.gt.1) call isorti(hsize,hlevel,n,xls) -! - istop=hsize - hsize=1 - degree=xls(hlevel(1)) - do 25 i=2,istop - node=hlevel(i) - if(xls(node).ne.degree) then - degree=xls(node) - hsize=hsize+1 - hlevel(hsize)=node - endif - 25 continue -! - ewidth=nc+1 - do 30 i=1,hsize - node=hlevel(i) -! - call rootls(n,node,ewidth,e2,adj,xadj,mask,ls,xls,depth,width) - if(width.lt.ewidth) then -! - if(depth.gt.sdepth) then -! - snode=node - sdepth=depth - go to 15 - endif -! - enode=node - ewidth=width - endif - 30 continue -! - if(node.ne.enode) then - call rootls(n,enode,nc+1,e2,adj,xadj,mask,ls,xls,depth,width) - endif -! - do 50 i=1,depth - jstrt=xls(i) - jstop=xls(i+1)-1 - do 40 j=jstrt,jstop - mask(ls(j))=i-1 - 40 continue - 50 continue - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/distattach.f calculix-ccx-2.3/ccx_2.1/src/distattach.f --- calculix-ccx-2.1/ccx_2.1/src/distattach.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/distattach.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine distattach(xig,etg,pneigh,pnode,a,p,ratio,nterms) -! -! calculates the distance between the node with coordinates -! in "pnode" and the node with local coordinates xig and etg -! in a face described by "nterms" nodes with coordinates -! in pneigh -! - implicit none -! - integer nterms,i,j -! - real*8 ratio(8),pneigh(3,*),pnode(3),a,xi,et,xig,etg,p(3), - & dummy -! - if(nterms.eq.3) then - xi=(xig+1.d0)/2.d0 - et=(etg+1.d0)/2.d0 - if(xi+et.gt.1.d0) then - dummy=xi - xi=1.d0-et - et=1.d0-dummy - endif - ratio(1)=1.d0-xi-et - ratio(2)=xi - ratio(3)=et - elseif(nterms.eq.4) then - xi=xig - et=etg - ratio(1)=(1.d0-xi)*(1.d0-et)/4.d0 - ratio(2)=(1.d0+xi)*(1.d0-et)/4.d0 - ratio(3)=(1.d0+xi)*(1.d0+et)/4.d0 - ratio(4)=(1.d0-xi)*(1.d0+et)/4.d0 - elseif(nterms.eq.6) then - xi=(xig+1.d0)/2.d0 - et=(etg+1.d0)/2.d0 - if(xi+et.gt.1.d0) then - dummy=xi - xi=1.d0-et - et=1.d0-dummy - endif - ratio(1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et) - ratio(2)=xi*(2.d0*xi-1.d0) - ratio(3)=et*(2.d0*et-1.d0) - ratio(4)=4.d0*xi*(1.d0-xi-et) - ratio(5)=4.d0*xi*et - ratio(6)=4.d0*et*(1.d0-xi-et) - elseif(nterms.eq.8) then - xi=xig - et=etg - ratio(1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0 - ratio(2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0 - ratio(3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0 - ratio(4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0 - ratio(5)=(1.d0-xi*xi)*(1.d0-et)/2.d0 - ratio(6)=(1.d0+xi)*(1.d0-et*et)/2.d0 - ratio(7)=(1.d0-xi*xi)*(1.d0+et)/2.d0 - ratio(8)=(1.d0-xi)*(1.d0-et*et)/2.d0 - else - write(*,*) '*ERROR in distattach: case with ',nterms - write(*,*) ' terms is not covered' - stop - endif -! -! calculating the position in the face -! - do i=1,3 - p(i)=0.d0 - do j=1,nterms - p(i)=p(i)+ratio(j)*pneigh(i,j) - enddo - enddo -! -! calculating the distance -! - a=(pnode(1)-p(1))**2+(pnode(2)-p(2))**2+(pnode(3)-p(3))**2 -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/distributedcouplings.f calculix-ccx-2.3/ccx_2.1/src/distributedcouplings.f --- calculix-ccx-2.1/ccx_2.1/src/distributedcouplings.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/distributedcouplings.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,390 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine distrubutedcouplings(inpc,textpart,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,nk,ikmpc,ilmpc, - & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc,lakon, - & kon,ipkon,set,nset,istartset,iendset,ialset,co) -! -! reading the input deck: *DISTRIBUTED COUPLING -! - implicit none -! - logical twod -! - character*1 inpc(*) - character*8 lakon(*) - character*20 labmpc(*) - character*81 surface,set(*) - character*132 textpart(16) -! - integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,istep,istat, - & n,i,j,key,nk,node,ifacequad(3,4),ifacetria(3,3),nmpcorig, - & mpcfreeold,ikmpc(*),ilmpc(*),id,idof,iline,ipol,inl, - & ipoinp(2,*),inp(3,*),ipoinpc(0:*),irefnode,lathyp(3,6),inum, - & jn,jt,iside,nelem,jface,nnodelem,nface,nodef(8),nodel(8), - & ifaceq(8,6),ifacet(6,4),ifacew1(4,5),ifacew2(8,5),indexpret, - & k,ipos,nope,m,kon(*),ipkon(*),indexe,iset,nset,idir, - & istartset(*),iendset(*),ialset(*),indexm,number -! - real*8 coefmpc(*),xn(3),dd,co(3,*),coef -! -! latin hypercube positions in a 3 x 3 matrix -! - data lathyp /1,2,3,1,3,2,2,1,3,2,3,1,3,1,2,3,2,1/ -! -! nodes per face for hex elements -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ -! -! nodes per face for tet elements -! - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ -! -! nodes per face for linear wedge elements -! - data ifacew1 /1,3,2,0, - & 4,5,6,0, - & 1,2,5,4, - & 2,3,6,5, - & 4,6,3,1/ -! -! nodes per face for quadratic wedge elements -! - data ifacew2 /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! -! nodes per face for quad elements -! - data ifacequad /1,2,5, - & 2,3,6, - & 3,4,7, - & 4,1,8/ -! -! nodes per face for tria elements -! - data ifacetria /1,2,4, - & 2,3,5, - & 3,1,6/ -! - if(istep.gt.0) then - write(*,*) '*ERROR in distributedcouplings.f: *EQUATION should' - write(*,*) ' be placed before all step definitions' - stop - endif -! - do i=2,n - if(textpart(i)(1:8).eq.'SURFACE=') then - surface=textpart(i)(9:88) - ipos=index(surface,' ') - surface(ipos:ipos)='T' - elseif(textpart(i)(1:5).eq.'NODE=') then - read(textpart(i)(6:15),'(i10)',iostat=istat) irefnode - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if((irefnode.gt.nk).or.(irefnode.le.0)) then - write(*,*) '*ERROR in distributedcouplings.f:' - write(*,*) ' node ',irefnode,' is not defined' - stop - endif - endif - enddo -! -! checking whether the surface exists and is an element face -! surface -! - iset=0 - do i=1,nset - if(set(i).eq.surface) then - iset=i - exit - endif - enddo - if(iset.eq.0) then - write(*,*) '*ERROR in distributedcouplings: nonexistent' - write(*,*) ' surface or surface consists of nodes' - call inputerror(inpc,ipoinpc,iline) - endif -! -! reading the normal vector and normalizing -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - do i=1,3 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) xn(i) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) - do i=1,3 - xn(i)=xn(i)/dd - enddo -! -! generating a Latin hypercube -! checking which DOF's of xn, xt and xd are nonzero -! - do inum=1,6 - if(dabs(xn(lathyp(1,inum))).gt.1.d-3) exit - enddo - jn=lathyp(1,inum) -! -! generating the MPCs -! - indexpret=0 - m=iendset(iset)-istartset(iset)+1 -! -! loop over all element faces belonging to the surface -! - number=1 - do k=1,m - twod=.false. - iside=ialset(istartset(iset)+k-1) - nelem=int(iside/10.d0) - indexe=ipkon(nelem) - jface=iside-10*nelem -! -! nnodelem: #nodes in the face -! the nodes are stored in nodef(*) -! - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(3:4).eq.'D8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - nope=10 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - nope=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(3:4).eq.'D6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - elseif((lakon(nelem)(2:2).eq.'8').or. - & (lakon(nelem)(4:4).eq.'8')) then - nnodelem=3 - nface=4 - nope=8 - if(lakon(nelem)(4:4).eq.'8') then - twod=.true. - jface=jface-2 - endif - elseif((lakon(nelem)(2:2).eq.'6').or. - & (lakon(nelem)(4:4).eq.'6')) then - nnodelem=3 - nface=3 - if(lakon(nelem)(4:4).eq.'6') then - twod=.true. - jface=jface-2 - endif - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.3) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacetria(i,jface)) - nodel(i)=ifacetria(i,jface) - enddo - elseif(nface.eq.4) then - if(nope.eq.8) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacequad(i,jface)) - nodel(i)=ifacequad(i,jface) - enddo - else - do i=1,nnodelem - nodef(i)=kon(indexe+ifacet(i,jface)) - nodel(i)=ifacet(i,jface) - enddo - endif - elseif(nface.eq.5) then - if(nope.eq.6) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacew1(i,jface)) - nodel(i)=ifacew1(i,jface) - enddo - elseif(nope.eq.15) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacew2(i,jface)) - nodel(i)=ifacew2(i,jface) - enddo - endif - elseif(nface.eq.6) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifaceq(i,jface)) - nodel(i)=ifaceq(i,jface) - enddo - endif -! -! loop over the nodes belonging to the face -! - loop: do i=1,nnodelem - node=nodef(i) -! -! MPC in the specified direction -! -! check whether initialized -! - if(indexpret.eq.0) then -! - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in distributedcouplings:' - write(*,*) ' increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - else -! -! check whether node was already treated -! - indexm=ipompc(nmpc) - do - if(node.eq.nodempc(1,indexm)) cycle loop - indexm=nodempc(3,indexm) - if(indexm.eq.0) exit - enddo - nodempc(3,indexpret)=mpcfree - number=number+1 - endif -! - idir=jn - if(dabs(xn(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xn(idir) - indexpret=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xn(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xn(idir) - indexpret=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xn(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xn(idir) - indexpret=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - enddo loop - enddo -! - nodempc(3,indexpret)=mpcfree - nodempc(1,mpcfree)=irefnode - nodempc(2,mpcfree)=1 - coefmpc(mpcfree)=-1.d0*number - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 -! -! choose a dependent node -! - indexm=ipompc(nmpc) - do - node=nodempc(1,indexm) - idir=nodempc(2,indexm) - idof=8*(node-1)+idir - nmpcorig=nmpc-1 - call nident(ikmpc,idof,nmpcorig,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - indexm=nodempc(3,indexm) - if(indexm.eq.0) then - write(*,*) '*ERROR in distributedcouplings:' - write(*,*) ' all DOFS have already' - write(*,*) ' been used' - stop - endif - cycle - endif - endif - if(indexm.ne.ipompc(nmpc)) then - coef=coefmpc(indexm) - nodempc(1,indexm)=nodempc(1,ipompc(nmpc)) - nodempc(2,indexm)=nodempc(2,ipompc(nmpc)) - coefmpc(indexm)=coefmpc(ipompc(nmpc)) - nodempc(1,ipompc(nmpc))=node - nodempc(2,ipompc(nmpc))=idir - coefmpc(ipompc(nmpc))=coef - endif - exit - enddo -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! -c do i=1,nmpc -c call writempc(ipompc,nodempc,coefmpc,labmpc,i) -c enddo -c do i=1,nmpc -c write(*,*) i,ikmpc(i),ilmpc(i) -c enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/dKdm.f calculix-ccx-2.3/ccx_2.1/src/dKdm.f --- calculix-ccx-2.1/ccx_2.1/src/dKdm.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dKdm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -! -! d{K(X)}/dxflow -! - subroutine dKdm(x,u,uprime,rpar,ipar) -! - implicit none - integer ipar - real*8 x,u(1),uprime(1),rpar(*),zk0,phi,Tup, - & xflow,Pup,f1_x,K_x,lambda1,df1dk,Rurd,f_k,kup -! - external f_k -! -! defining the parameters - phi=rpar(1) - lambda1=rpar(2) - zk0=rpar(3) - Pup=rpar(4) - Tup=rpar(5) - rurd=rpar(6) - xflow=rpar(7) - kup=rpar(8) -! -! find K(X) for the given x - - k_x=f_k(x,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) -! - k_x=dsqrt(K_x/x) -! -! f1_x - f1_x= (zk0*K_x)**(7.d0/4.d0) - & -(1-K_x)/dabs(1-K_x)*dabs(1-K_x)**(7d0*4d0) -! -! df1dK - df1dK=7d0/4d0*zk0**(7d0/4d0)*K_x**(3.d0/4.d0) - & +7d0/4d0*dabs(1-K_x)**(3.d0/4.d0) -! -! - uprime(1)=-x**1.6d0*lambda1*Pup**(0.8d0) - & /(xflow**2*Tup**0.8d0)*f1_x+u(1) - & *(lambda1*x**1.6d0*Pup**0.8d0/(xflow*Tup**0.8d0) - & *df1dK-2/x) -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/dKdp.f calculix-ccx-2.3/ccx_2.1/src/dKdp.f --- calculix-ccx-2.1/ccx_2.1/src/dKdp.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dKdp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -! -! d{K(X)}/dPeint -! - subroutine dKdp(x,u,uprime,rpar,ipar) -! - implicit none - integer ipar - real*8 x,u(1),uprime(1),rpar(*),zk0,phi,Tup, - & xflow,Pup,f1_x,k_x,lambda1,df1dk,Rurd,f_k,kup -! - external f_k -! -! defining the parameters - phi=rpar(1) - lambda1=rpar(2) - zk0=rpar(3) - Pup=rpar(4) - Tup=rpar(5) - rurd=rpar(6) - xflow=rpar(7) - kup=rpar(8) -! -! find K(X) for the given x - k_x=f_k(x,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) -! - k_x=dsqrt(K_x/x) -! -! f1_x - f1_x= (zk0*K_x)**(7.d0/4.d0) - & -(1-K_x)/dabs(1-K_x)*dabs(1-K_x)**(7d0*4d0) -! -! df1dK - df1dK=7d0/4d0*zk0**(7d0/4d0)*K_x**(3.d0/4.d0) - & +7d0/4d0*dabs(1-K_x)**(3.d0/4.d0) -! - uprime(1)=0.8d0*x**1.6d0*lambda1*Pup**(-0.2) - & /(xflow*Tup**0.8d0)*f1_x+u(1) - & *(lambda1*x**1.6d0*Pup**0.8d0/(xflow*Tup**0.8d0) - & *df1dK-2/x) -! write(*,*) 'uprime',x,uprime(1) -! - return -! - end -! diff -Nru calculix-ccx-2.1/ccx_2.1/src/dKdt.f calculix-ccx-2.3/ccx_2.1/src/dKdt.f --- calculix-ccx-2.1/ccx_2.1/src/dKdt.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dKdt.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -! -! d{K(X)}/dTeint -! - subroutine dKdt(x,u,uprime,rpar,ipar) -! - implicit none - integer ipar - real*8 x,u(1),uprime(1),rpar(*),zk0,phi,Tup, - & xflow,Pup,f1_x,K_x,lambda1,df1dk,Rurd,f_k,kup -! - external f_k -! -! defining the parameters - phi=rpar(1) - lambda1=rpar(2) - zk0=rpar(3) - Pup=rpar(4) - Tup=rpar(5) - rurd=rpar(6) - xflow=rpar(7) - kup=rpar(8) -! -! find K(X) for the given x - - k_x=f_k(x,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) -! - k_x=dsqrt(K_x/x) -! -! f1_x - f1_x= (zk0*K_x)**(7.d0/4.d0) - & -(1-K_x)/dabs(1-K_x)*dabs(1-K_x)**(7d0*4d0) -! -! df1dK - df1dK=7d0/4d0*zk0**(7d0/4d0)*K_x**(3.d0/4.d0) - & +7d0/4d0*dabs(1-K_x)**(3.d0/4.d0) -! -! - uprime(1)=-0.8d0*x**1.6d0*lambda1*Pup**(0.8d0) - & /(xflow*Tup**1.8d0)*f1_x+u(1) - & *(lambda1*x**1.6d0*Pup**0.8d0/(xflow*Tup**0.8d0) - & *df1dK-2/x) -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/dKdX.f calculix-ccx-2.3/ccx_2.1/src/dKdX.f --- calculix-ccx-2.1/ccx_2.1/src/dKdX.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dKdX.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -! -! d{K(X)}/dX -! - subroutine dKdX(x,u,uprime,rpar,ipar) -! - implicit none - integer ipar - real*8 x,u(1),uprime(1),rpar(*),zk0,phi -! -! defining the parameters - phi=rpar(1) - zk0=rpar(3) - - uprime(1)=datan(1.d0)*0.315/(phi)*x**1.6* - & ((zk0*u(1))**1.75d0- - & (dabs(1.d0-u(1)))**1.75d0*(1.d0-u(1))/dabs(1.d0-u(1))) - & -2.d0*u(1)/x -! - return -! - end -! diff -Nru calculix-ccx-2.1/ccx_2.1/src/dload.f calculix-ccx-2.3/ccx_2.1/src/dload.f --- calculix-ccx-2.1/ccx_2.1/src/dload.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dload.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,269 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dload(f,kstep,kinc,time,noel,npt,layer,kspt, - & coords,jltyp,loadtype,vold,co,lakonl,konl, - & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,iscale,veold, - & rho,amat,mi) -! -! user subroutine dload -! -! -! INPUT: -! -! kstep step number -! kinc increment number -! time(1) current step time -! time(2) current total time -! noel element number -! npt integration point number -! layer currently not used -! kspt currently not used -! coords(1..3) global coordinates of the integration point -! jltyp loading face kode: -! 21 = face 1 -! 22 = face 2 -! 23 = face 3 -! 24 = face 4 -! 25 = face 5 -! 26 = face 6 -! loadtype load type label -! vold(0..4,1..nk) solution field in all nodes -! 0: temperature -! 1: displacement in global x-direction -! 2: displacement in global y-direction -! 3: displacement in global z-direction -! 4: static pressure -! veold(0..3,1..nk) derivative of the solution field w.r.t. -! time in all nodes -! 0: temperature rate -! 1: velocity in global x-direction -! 2: velocity in global y-direction -! 3: velocity in global z-direction -! co(3,1..nk) coordinates of all nodes -! 1: coordinate in global x-direction -! 2: coordinate in global y-direction -! 3: coordinate in global z-direction -! lakonl element label -! konl(1..20) nodes belonging to the element -! ipompc(1..nmpc)) ipompc(i) points to the first term of -! MPC i in field nodempc -! nodempc(1,*) node number of a MPC term -! nodempc(2,*) coordinate direction of a MPC term -! nodempc(3,*) if not 0: points towards the next term -! of the MPC in field nodempc -! if 0: MPC definition is finished -! coefmpc(*) coefficient of a MPC term -! nmpc number of MPC's -! ikmpc(1..nmpc) ordered global degrees of freedom of the MPC's -! the global degree of freedom is -! 8*(node-1)+direction of the dependent term of -! the MPC (direction = 0: temperature; -! 1-3: displacements; 4: static pressure; -! 5-7: rotations) -! ilmpc(1..nmpc) ilmpc(i) is the MPC number corresponding -! to the reference number in ikmpc(i) -! rho local density -! amat material name -! mi(1) max # of integration points per element (max -! over all elements) -! mi(2) max degree of freedomm per node (max over all -! nodes) in fields like v(0:mi(2))... -! -! OUTPUT: -! -! f magnitude of the distributed load -! iscale determines whether the flux has to be -! scaled for increments smaller than the -! step time in static calculations -! 0: no scaling -! 1: scaling (default) -! - implicit none -! - character*8 lakonl - character*20 loadtype - character*80 amat -! - integer kstep,kinc,noel,npt,jltyp,layer,kspt,konl(20),iscale,mi(2) -! - real*8 f,time(2),coords(3),vold(0:mi(2),*),co(3,*),rho -! -! the code starting here up to the end of the file serves as -! an example for combined mechanical-lubrication problems. -! Please replace it by your own code for your concrete application. -! - include "gauss.f" -! - integer ifaceq(8,6),ifacet(6,4),ifacew(8,5),ig,nelem,nopes, - & iflag,i,j,nope,ipompc(*),nodempc(3,*),nmpc,ikmpc(*),ilmpc(*), - & node,idof,id -! - real*8 xl2(3,8),pres(8),xi,et,xsj2(3),xs2(3,7),shp2(7,8), - & coefmpc(*),veold(0:mi(2),*) -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ - data ifacew /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ - data iflag /2/ -! - nelem=noel - ig=jltyp-20 -! - if(lakonl(4:4).eq.'2') then - nope=20 - nopes=8 - elseif(lakonl(4:4).eq.'8') then - nope=8 - nopes=4 - elseif(lakonl(4:5).eq.'10') then - nope=10 - nopes=6 - elseif(lakonl(4:4).eq.'4') then - nope=4 - nopes=3 - elseif(lakonl(4:5).eq.'15') then - nope=15 - elseif(lakonl(4:4).eq.'6') then - nope=6 - endif -! -! treatment of wedge faces -! - if(lakonl(4:4).eq.'6') then - if(ig.le.2) then - nopes=3 - else - nopes=4 - endif - endif - if(lakonl(4:5).eq.'15') then - if(ig.le.2) then - nopes=6 - else - nopes=8 - endif - endif -! - do i=1,nopes - do j=1,3 - xl2(j,i)=0.d0 - enddo - enddo -! - if((nope.eq.20).or.(nope.eq.8)) then - do i=1,nopes - node=konl(ifaceq(i,ig)) - idof=8*(node-1) - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in dload: node ',node - write(*,*) ' is not connected to the oil film' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - pres(i)=vold(0,node) - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - do i=1,nopes - node=konl(ifacet(i,ig)) - node=konl(ifaceq(i,ig)) - idof=8*(node-1) - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in dload: node ',node - write(*,*) ' is not connected to the oil film' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - pres(i)=vold(0,node) - enddo - else - do i=1,nopes - node=konl(ifacew(i,ig)) - node=konl(ifaceq(i,ig)) - idof=8*(node-1) - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in dload: node ',node - write(*,*) ' is not connected to the oil film' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - pres(i)=vold(0,node) - enddo - endif -! - i=npt -! - if((lakonl(4:5).eq.'8R').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then - xi=gauss2d1(1,i) - et=gauss2d1(2,i) - elseif((lakonl(4:4).eq.'8').or. - & (lakonl(4:6).eq.'20R').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then - xi=gauss2d2(1,i) - et=gauss2d2(2,i) - elseif(lakonl(4:4).eq.'2') then - xi=gauss2d3(1,i) - et=gauss2d3(2,i) - elseif((lakonl(4:5).eq.'10').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then - xi=gauss2d5(1,i) - et=gauss2d5(2,i) - elseif((lakonl(4:4).eq.'4').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then - xi=gauss2d4(1,i) - et=gauss2d4(2,i) - endif -! - if(nopes.eq.8) then - call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.4) then - call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.6) then - call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - endif -! -! determining the pressure -! - f=0.d0 - do j=1,nopes - f=f+pres(j)*shp2(4,j) - enddo -! - iscale=0 -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/dloads.f calculix-ccx-2.3/ccx_2.1/src/dloads.f --- calculix-ccx-2.1/ccx_2.1/src/dloads.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dloads.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,373 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dloads(inpc,textpart,set,istartset,iendset, - & ialset,nset,nelemload,sideload,xload,nload,nload_, - & ielmat,iamload,amname,nam,lakon,ne,dload_flag,istep, - & istat,n,iline,ipol,inl,ipoinp,inp,cbody,ibody,xbody,nbody, - & nbody_,xbodyold,iperturb,physcon,nam_,namtot_,namta,amta, - & nmethod,ipoinpc,maxsectors) -! -! reading the input deck: *DLOAD -! - implicit none -! - logical dload_flag -! - character*1 inpc(*) - character*8 lakon(*) - character*20 sideload(*),label - character*80 amname(*),amplitude - character*81 set(*),elset,cbody(*) - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),nelemload(2,*), - & ielmat(*),nset,nload,nload_,istep,istat,n,i,j,l,key, - & iamload(2,*),nam,iamplitude,ipos,ne,iline,ipol,iperturb, - & inl,ipoinp(2,*),inp(3,*),ibody(3,*),nbody,nbody_,nam_,namtot, - & namtot_,namta(3,*),idelay,nmethod,lc,isector,node,ipoinpc(0:*), - & maxsectors,jsector -! - real*8 xload(2,*),xbody(7,*),xmagnitude,dd,p1(3),p2(3),bodyf(3), - & xbodyold(7,*),physcon(*),amta(2,*) -! - iamplitude=0 - idelay=0 - lc=1 - isector=0 -! - if(istep.lt.1) then - write(*,*) '*ERROR in dloads: *DLOAD should only be used' - write(*,*) ' within a STEP' - stop - endif -! - do i=2,n - if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.dload_flag)) then - do j=1,nload - if(sideload(j)(1:1).eq.'P') then - xload(1,j)=0.d0 - endif - enddo - do j=1,nbody - xbody(1,j)=0.d0 - enddo - elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then - read(textpart(i)(11:90),'(a80)') amplitude - do j=1,nam - if(amname(j).eq.amplitude) then - iamplitude=j - exit - endif - enddo - if(j.gt.nam) then - write(*,*)'*ERROR in dloads: nonexistent amplitude' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iamplitude=j - elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN - if(idelay.ne.0) then - write(*,*) '*ERROR in dloads: the parameter TIME DELAY' - write(*,*) ' is used twice in the same keyword' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - else - idelay=1 - endif - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in dloads: increase nam_' - stop - endif - amname(nam)=' - & ' - if(iamplitude.eq.0) then - write(*,*) '*ERROR in dloads: time delay must be' - write(*,*) ' preceded by the amplitude parameter' - stop - endif - namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) - iamplitude=nam - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) '*ERROR dloads: increase namtot_' - stop - endif - namta(1,nam)=namtot - namta(2,nam)=namtot - read(textpart(i)(11:30),'(f20.0)',iostat=istat) - & amta(1,namtot) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:9).eq.'LOADCASE=') then - read(textpart(i)(10:19),'(i10)',iostat=istat) lc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(nmethod.ne.5) then - write(*,*) '*ERROR in dloads: the parameter LOAD CASE' - write(*,*) ' is only allowed in STEADY STATE' - write(*,*) ' DYNAMICS calculations' - stop - endif - elseif(textpart(i)(1:7).eq.'SECTOR=') then - read(textpart(i)(8:17),'(i10)',iostat=istat) isector - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if((nmethod.le.3).or.(iperturb.gt.1)) then - write(*,*) '*ERROR in dloads: the parameter SECTOR' - write(*,*) ' is only allowed in MODAL DYNAMICS or' - write(*,*) ' STEADY STATE DYNAMICS calculations' - stop - endif - if(isector.gt.maxsectors) then - write(*,*) '*ERROR in dloads: sector ',isector - write(*,*) ' exceeds number of sectors' - stop - endif - isector=isector-1 - endif - enddo -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return -! - read(textpart(2)(1:20),'(a20)',iostat=istat) label - if(label(3:4).ne.'NP') then - read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagnitude - else - read(textpart(3)(1:10),'(i10)',iostat=istat) node - endif - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(label(1:7).eq.'CENTRIF') then - do i=1,3 - read(textpart(i+3)(1:20),'(f20.0)',iostat=istat) p1(i) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - do i=1,3 - read(textpart(i+6)(1:20),'(f20.0)',iostat=istat) p2(i) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - dd=dsqrt(p2(1)**2+p2(2)**2+p2(3)**2) - do i=1,3 - p2(i)=p2(i)/dd - enddo - elseif(label(1:4).eq.'GRAV') then - do i=1,3 - read(textpart(i+3)(1:20),'(f20.0)',iostat=istat) bodyf(i) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - elseif(label(1:6).eq.'NEWTON') then - if(iperturb.le.1) then - write(*,*) '*ERROR in dloads: NEWTON gravity force' - write(*,*) ' can only be used in a nonlinear' - write(*,*) ' procedure' - stop - endif - if(physcon(3).le.0.d0) then - write(*,*) '*ERROR in dloads: NEWTON gravity force' - write(*,*) ' requires the definition of a' - write(*,*) ' positive gravity constant with' - write(*,*) ' a *PHYSICAL CONSTANTS card' - stop - endif - elseif(((label(1:2).ne.'P1').and.(label(1:2).ne.'P2').and. - & (label(1:2).ne.'P3').and.(label(1:2).ne.'P4').and. - & (label(1:2).ne.'P5').and.(label(1:2).ne.'P6').and. - & (label(1:2).ne.'P ').and.(label(1:2).ne.'BX').and. - & (label(1:2).ne.'BY').and.(label(1:2).ne.'BZ').and. -cBernhardiStart - & (label(1:2).ne.'ED')).or. - & ((label(3:6).ne.'NOR1').and.(label(3:6).ne.'NOR2').and. - & (label(3:6).ne.'NOR3').and.(label(3:6).ne.'NOR4')).and. -cBernhardiEnd - & ((label(3:4).ne.' ').and.(label(3:4).ne.'NU').and. - & (label(3:4).ne.'NP'))) then - call inputerror(inpc,ipoinpc,iline) - endif -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - if(l.gt.ne) then - write(*,*) '*ERROR in dloads: element ',l - write(*,*) ' is not defined' - stop - endif - if((label(1:7).eq.'CENTRIF').or.(label(1:4).eq.'GRAV').or. - & (label(1:6).eq.'NEWTON')) then - elset(1:80)=textpart(1)(1:80) - elset(81:81)=' ' - call bodyadd(cbody,ibody,xbody,nbody,nbody_,elset,label, - & iamplitude,xmagnitude,p1,p2,bodyf,xbodyold,lc) - else - if((lakon(l)(1:2).eq.'CP').or. - & (lakon(l)(2:2).eq.'A').or. - & (lakon(l)(7:7).eq.'E').or. - & (lakon(l)(7:7).eq.'S').or. - & (lakon(l)(7:7).eq.'A')) then - if(label(1:2).eq.'P1') then - label(1:2)='P3' - elseif(label(1:2).eq.'P2') then - label(1:2)='P4' - elseif(label(1:2).eq.'P3') then - label(1:2)='P5' - elseif(label(1:2).eq.'P4') then - label(1:2)='P6' - endif - elseif((lakon(l)(1:1).eq.'B').or. - & (lakon(l)(7:7).eq.'B')) then - if(label(1:2).eq.'P2') label(1:2)='P5' - elseif((lakon(l)(1:1).eq.'S').or. - & (lakon(l)(7:7).eq.'L')) then -cBernhardiStart - if(label(1:6).eq.'EDNOR1') then - label(1:2)='P3' - elseif(label(1:6).eq.'EDNOR2') then - label(1:2)='P4' - elseif(label(1:6).eq.'EDNOR3') then - label(1:2)='P5' - elseif(label(1:6).eq.'EDNOR4') then - label(1:2)='P6' - else - label(1:2)='P1' - endif -cBernhardiEnd - endif - if(lc.ne.1) then - jsector=isector+maxsectors - else - jsector=isector - endif - if(label(3:4).ne.'NP') then - call loadadd(l,label,xmagnitude,nelemload,sideload, - & xload,nload,nload_,iamload,iamplitude, - & nam,jsector) - else - call loadaddp(l,label,nelemload,sideload, - & xload,nload,nload_,iamload,iamplitude, - & nam,node) - endif - endif - else - read(textpart(1)(1:80),'(a80)',iostat=istat) elset - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - do i=1,nset - if(set(i).eq.elset) exit - enddo - if(i.gt.nset) then - elset(ipos:ipos)=' ' - write(*,*) '*ERROR in dloads: element set ',elset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! - if((label(1:7).eq.'CENTRIF').or.(label(1:4).eq.'GRAV').or. - & (label(1:6).eq.'NEWTON')) then - call bodyadd(cbody,ibody,xbody,nbody,nbody_,elset,label, - & iamplitude,xmagnitude,p1,p2,bodyf,xbodyold,lc) - else - l=ialset(istartset(i)) - if((lakon(l)(1:2).eq.'CP').or. - & (lakon(l)(2:2).eq.'A').or. - & (lakon(l)(7:7).eq.'E').or. - & (lakon(l)(7:7).eq.'S').or. - & (lakon(l)(7:7).eq.'A')) then - if(label(1:2).eq.'P1') then - label(1:2)='P3' - elseif(label(1:2).eq.'P2') then - label(1:2)='P4' - elseif(label(1:2).eq.'P3') then - label(1:2)='P5' - elseif(label(1:2).eq.'P4') then - label(1:2)='P6' - endif - elseif((lakon(l)(1:1).eq.'B').or. - & (lakon(l)(7:7).eq.'B')) then - if(label(1:2).eq.'P2') label(1:2)='P5' - elseif((lakon(l)(1:1).eq.'S').or. - & (lakon(l)(7:7).eq.'L')) then -cBernhardiStart - if(label(1:6).eq.'EDNOR1') then - label(1:2)='P3' - elseif(label(1:6).eq.'EDNOR2') then - label(1:2)='P4' - elseif(label(1:6).eq.'EDNOR3') then - label(1:2)='P5' - elseif(label(1:6).eq.'EDNOR4') then - label(1:2)='P6' - else - label(1:2)='P1' - endif -cBernhardiEnd - endif -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - l=ialset(j) - if(lc.ne.1) then - jsector=isector+maxsectors - else - jsector=isector - endif - if(label(3:4).ne.'NP') then - call loadadd(l,label,xmagnitude,nelemload, - & sideload,xload,nload,nload_,iamload, - & iamplitude,nam,jsector) - else - call loadaddp(l,label,nelemload, - & sideload,xload,nload,nload_,iamload, - & iamplitude,nam,node) - endif - else - l=ialset(j-2) - do - l=l-ialset(j) - if(l.ge.ialset(j-1)) exit - if(lc.ne.1) then - jsector=isector+maxsectors - else - jsector=isector - endif - if(label(3:4).ne.'NP') then - call loadadd(l,label,xmagnitude,nelemload, - & sideload,xload,nload,nload_, - & iamload,iamplitude,nam,jsector) - else - call loadaddp(l,label,nelemload, - & sideload,xload,nload,nload_, - & iamload,iamplitude,nam,node) - endif - enddo - endif - enddo - endif - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/dot.f calculix-ccx-2.3/ccx_2.1/src/dot.f --- calculix-ccx-2.1/ccx_2.1/src/dot.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dot.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - double precision function dot(a,b,n) - implicit none - integer k,n - real*8 a(*),b(*) -c....dot product function - dot = 0.0d0 - do 10 k = 1,n - dot = dot + a(k)*b(k) - 10 continue - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/dqag.f calculix-ccx-2.3/ccx_2.1/src/dqag.f --- calculix-ccx-2.1/ccx_2.1/src/dqag.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dqag.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1933 +0,0 @@ - subroutine dqag(f,a,b,epsabs,epsrel,key,result,abserr,neval,ier, - * limit,lenw,last,iwork,work,phi,lambda1,zk0,Pup,Tup,rurd,xflow, - * kup) -c***begin prologue dqag -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a1 -c***keywords automatic integrator, general-purpose, -c integrand examinator, globally adaptive, -c gauss-kronrod -c***author piessens,robert,appl. math. & progr. div - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), -c hopefully satisfying following claim for accuracy -c abs(i-result)le.max(epsabs,epsrel*abs(i)). -c***description -c -c computation of a definite integral -c standard fortran subroutine -c double precision version -c -c f - double precision -c function subprogam defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c epsabs - double precision -c absolute accoracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c key - integer -c key for choice of local integration rule -c a gauss-kronrod pair is used with -c 7 - 15 points if key.lt.2, -c 10 - 21 points if key = 2, -c 15 - 31 points if key = 3, -c 20 - 41 points if key = 4, -c 25 - 51 points if key = 5, -c 30 - 61 points if key.gt.5. -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine -c the estimates for result and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value of -c limit (and taking the according dimension -c adjustments into account). however, if -c this yield no improvement it is advised -c to analyze the integrand in order to -c determine the integration difficulaties. -c if the position of a local difficulty can -c be determined (i.e.singularity, -c discontinuity within the interval) one -c will probably gain from splitting up the -c interval at this point and calling the -c integrator on the subranges. if possible, -c an appropriate special-purpose integrator -c should be used which is designed for -c handling the type of difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) -c or limit.lt.1 or lenw.lt.limit*4. -c result, abserr, neval, last are set -c to zero. -c except when lenw is invalid, iwork(1), -c work(limit*2+1) and work(limit*3+1) are -c set to zero, work(1) is set to a and -c work(limit+1) to b. -c -c dimensioning parameters -c limit - integer -c dimensioning parameter for iwork -c limit determines the maximum number of subintervals -c in the partition of the given integration interval -c (a,b), limit.ge.1. -c if limit.lt.1, the routine will end with ier = 6. -c -c lenw - integer -c dimensioning parameter for work -c lenw must be at least limit*4. -c if lenw.lt.limit*4, the routine will end with -c ier = 6. -c -c last - integer -c on return, last equals the number of subintervals -c produced in the subdiviosion process, which -c determines the number of significant elements -c actually in the work arrays. -c -c work arrays -c iwork - integer -c vector of dimension at least limit, the first k -c elements of which contain pointers to the error -c estimates over the subintervals, such that -c work(limit*3+iwork(1)),... , work(limit*3+iwork(k)) -c form a decreasing sequence with k = last if -c last.le.(limit/2+2), and k = limit+1-last otherwise -c -c work - double precision -c vector of dimension at least lenw -c on return -c work(1), ..., work(last) contain the left end -c points of the subintervals in the partition of -c (a,b), -c work(limit+1), ..., work(limit+last) contain the -c right end points, -c work(limit*2+1), ..., work(limit*2+last) contain -c the integral approximations over the subintervals, -c work(limit*3+1), ..., work(limit*3+last) contain -c the error estimates. -c -c***references (none) -c***routines called dqage,xerror -c***end prologue dqag - real*8 a,abserr,b,epsabs,epsrel,f,result,work,d1mach(4), - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup - integer ier,iwork,key,last,lenw,limit,lvl,l1,l2,l3,neval -c - dimension iwork(limit),work(lenw) -c - external f -c -c check validity of lenw. -c - d1mach(1)=1E21 - d1mach(2)=0d0 - d1mach(3)=0d0 - d1mach(4)=1E-21 -c -c***first executable statement dqag - ier = 6 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - if(limit.lt.1.or.lenw.lt.limit*4) go to 10 -c -c prepare call for dqage. -c - l1 = limit+1 - l2 = limit+l1 - l3 = limit+l2 -c - call dqage(f,a,b,epsabs,epsrel,key,limit,result,abserr,neval, - * ier,work(1),work(l1),work(l2),work(l3),iwork,last,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup) -c -c call error handler if necessary. -c - lvl = 0 -10 if(ier.eq.6) lvl = 1 -! if(ier.ne.0) call xerror(26habnormal return from dqag ,26,ier,lvl) - return - end - subroutine dqage(f,a,b,epsabs,epsrel,key,limit,result,abserr, - * neval,ier,alist,blist,rlist,elist,iord,last,phi,lambda1,zk0, - * Pup,Tup,rurd,xflow,kup) -c***begin prologue dqage -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a1 -c***keywords automatic integrator, general-purpose, -c integrand examinator, globally adaptive, -c gauss-kronrod -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose the routine calculates an approximation result to a given -c definite integral i = integral of f over (a,b), -c hopefully satisfying following claim for accuracy -c abs(i-reslt).le.max(epsabs,epsrel*abs(i)). -c***description -c -c computation of a definite integral -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c epsabs - double precision -c absolute accuracy requested -c epsrel - double precision -c relative accuracy requested -c if epsabs.le.0 -c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c the routine will end with ier = 6. -c -c key - integer -c key for choice of local integration rule -c a gauss-kronrod pair is used with -c 7 - 15 points if key.lt.2, -c 10 - 21 points if key = 2, -c 15 - 31 points if key = 3, -c 20 - 41 points if key = 4, -c 25 - 51 points if key = 5, -c 30 - 61 points if key.gt.5. -c -c limit - integer -c gives an upperbound on the number of subintervals -c in the partition of (a,b), limit.ge.1. -c -c on return -c result - double precision -c approximation to the integral -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed abs(i-result) -c -c neval - integer -c number of integrand evaluations -c -c ier - integer -c ier = 0 normal and reliable termination of the -c routine. it is assumed that the requested -c accuracy has been achieved. -c ier.gt.0 abnormal termination of the routine -c the estimates for result and error are -c less reliable. it is assumed that the -c requested accuracy has not been achieved. -c error messages -c ier = 1 maximum number of subdivisions allowed -c has been achieved. one can allow more -c subdivisions by increasing the value -c of limit. -c however, if this yields no improvement it -c is rather advised to analyze the integrand -c in order to determine the integration -c difficulties. if the position of a local -c difficulty can be determined(e.g. -c singularity, discontinuity within the -c interval) one will probably gain from -c splitting up the interval at this point -c and calling the integrator on the -c subranges. if possible, an appropriate -c special-purpose integrator should be used -c which is designed for handling the type of -c difficulty involved. -c = 2 the occurrence of roundoff error is -c detected, which prevents the requested -c tolerance from being achieved. -c = 3 extremely bad integrand behaviour occurs -c at some points of the integration -c interval. -c = 6 the input is invalid, because -c (epsabs.le.0 and -c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), -c result, abserr, neval, last, rlist(1) , -c elist(1) and iord(1) are set to zero. -c alist(1) and blist(1) are set to a and b -c respectively. -c -c alist - double precision -c vector of dimension at least limit, the first -c last elements of which are the left -c end points of the subintervals in the partition -c of the given integration range (a,b) -c -c blist - double precision -c vector of dimension at least limit, the first -c last elements of which are the right -c end points of the subintervals in the partition -c of the given integration range (a,b) -c -c rlist - double precision -c vector of dimension at least limit, the first -c last elements of which are the -c integral approximations on the subintervals -c -c elist - double precision -c vector of dimension at least limit, the first -c last elements of which are the moduli of the -c absolute error estimates on the subintervals -c -c iord - integer -c vector of dimension at least limit, the first k -c elements of which are pointers to the -c error estimates over the subintervals, -c such that elist(iord(1)), ..., -c elist(iord(k)) form a decreasing sequence, -c with k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c -c last - integer -c number of subintervals actually produced in the -c subdivision process -c -c***references (none) -c***routines called d1mach,dqk15,dqk21,dqk31, -c dqk41,dqk51,dqk61,dqpsrt -c***end prologue dqage -c - double precision a,abserr,alist,area,area1,area12,area2,a1,a2,b, - * blist,b1,b2,dabs,defabs,defab1,defab2,d1mach(4),elist, - * epmach,epsabs,epsrel,errbnd,errmax,error1,error2,erro12,errsum,f, - * resabs,result,rlist,uflow,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup - integer ier,iord,iroff1,iroff2,k,key,keyf,last,limit,maxerr,neval, - * nrmax -c - dimension alist(limit),blist(limit),elist(limit),iord(limit), - * rlist(limit) -c - external f - - - d1mach(1)=1E21 - d1mach(2)=0d0 - d1mach(3)=0d0 - d1mach(4)=1E-21 -c -c list of major variables -c ----------------------- -c -c alist - list of left end points of all subintervals -c considered up to now -c blist - list of right end points of all subintervals -c considered up to now -c rlist(i) - approximation to the integral over -c (alist(i),blist(i)) -c elist(i) - error estimate applying to rlist(i) -c maxerr - pointer to the interval with largest -c error estimate -c errmax - elist(maxerr) -c area - sum of the integrals over the subintervals -c errsum - sum of the errors over the subintervals -c errbnd - requested accuracy max(epsabs,epsrel* -c abs(result)) -c *****1 - variable for the left subinterval -c *****2 - variable for the right subinterval -c last - index for subdivision -c -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqage - epmach = d1mach(4) - uflow = d1mach(1) -c -c test on validity of parameters -c ------------------------------ -c - ier = 0 - neval = 0 - last = 0 - result = 0.0d+00 - abserr = 0.0d+00 - alist(1) = a - blist(1) = b - rlist(1) = 0.0d+00 - elist(1) = 0.0d+00 - iord(1) = 0 - if(epsabs.le.0.0d+00.and. - * epsrel.lt.max(0.5d+02*epmach,0.5d-28)) ier = 6 - if(ier.eq.6) go to 999 -c -c first approximation to the integral -c ----------------------------------- -c - keyf = key - if(key.le.0) keyf = 1 - if(key.ge.7) keyf = 6 - neval = 0 - if(keyf.eq.1) call dqk15(f,a,b,result,abserr,defabs,resabs, - & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - if(keyf.eq.2) call dqk21(f,a,b,result,abserr,defabs,resabs, - & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - if(keyf.eq.3) call dqk31(f,a,b,result,abserr,defabs,resabs, - & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - if(keyf.eq.4) call dqk41(f,a,b,result,abserr,defabs,resabs, - & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - if(keyf.eq.5) call dqk51(f,a,b,result,abserr,defabs,resabs, - & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - if(keyf.eq.6) call dqk61(f,a,b,result,abserr,defabs,resabs, - & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - last = 1 - rlist(1) = result - elist(1) = abserr - iord(1) = 1 -c -c test on accuracy. -c - errbnd = max(epsabs,epsrel*dabs(result)) - if(abserr.le.0.5d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 - if(limit.eq.1) ier = 1 - if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs) - * .or.abserr.eq.0.0d+00) go to 60 -c -c initialization -c -------------- -c -c - errmax = abserr - maxerr = 1 - area = result - errsum = abserr - nrmax = 1 - iroff1 = 0 - iroff2 = 0 -c -c main do-loop -c ------------ -c - do 30 last = 2,limit -c -c bisect the subinterval with the largest error estimate. -c - a1 = alist(maxerr) - b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) - a2 = b1 - b2 = blist(maxerr) - if(keyf.eq.1) call dqk15(f,a1,b1,area1,error1,resabs,defab1, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.2) call dqk21(f,a1,b1,area1,error1,resabs,defab1, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.3) call dqk31(f,a1,b1,area1,error1,resabs,defab1, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.4) call dqk41(f,a1,b1,area1,error1,resabs,defab1, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.5) call dqk51(f,a1,b1,area1,error1,resabs,defab1, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.6) call dqk61(f,a1,b1,area1,error1,resabs,defab1, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.1) call dqk15(f,a2,b2,area2,error2,resabs,defab2, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.2) call dqk21(f,a2,b2,area2,error2,resabs,defab2, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.3) call dqk31(f,a2,b2,area2,error2,resabs,defab2, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.4) call dqk41(f,a2,b2,area2,error2,resabs,defab2, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.5) call dqk51(f,a2,b2,area2,error2,resabs,defab2, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) - if(keyf.eq.6) call dqk61(f,a2,b2,area2,error2,resabs,defab2, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) -c -c improve previous approximations to integral -c and error and test for accuracy. -c - neval = neval+1 - area12 = area1+area2 - erro12 = error1+error2 - errsum = errsum+erro12-errmax - area = area+area12-rlist(maxerr) - if(defab1.eq.error1.or.defab2.eq.error2) go to 5 - if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12) - * .and.erro12.ge.0.99d+00*errmax) iroff1 = iroff1+1 - if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1 - 5 rlist(maxerr) = area1 - rlist(last) = area2 - errbnd = max(epsabs,epsrel*dabs(area)) - if(errsum.le.errbnd) go to 8 -c -c test for roundoff error and eventually set error flag. -c - if(iroff1.ge.6.or.iroff2.ge.20) ier = 2 -c -c set error flag in the case that the number of subintervals -c equals limit. -c - if(last.eq.limit) ier = 1 -c -c set error flag in the case of bad integrand behaviour -c at a point of the integration range. -c - if(max(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03* - * epmach)*(dabs(a2)+0.1d+04*uflow)) ier = 3 -c -c append the newly-created intervals to the list. -c - 8 if(error2.gt.error1) go to 10 - alist(last) = a2 - blist(maxerr) = b1 - blist(last) = b2 - elist(maxerr) = error1 - elist(last) = error2 - go to 20 - 10 alist(maxerr) = a2 - alist(last) = a1 - blist(last) = b1 - rlist(maxerr) = area2 - rlist(last) = area1 - elist(maxerr) = error2 - elist(last) = error1 -c -c call subroutine dqpsrt to maintain the descending ordering -c in the list of error estimates and select the subinterval -c with the largest error estimate (to be bisected next). -c - 20 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax,phi, - * lambda1,zk0,Pup,Tup,rurd,xflow,kup) -c ***jump out of do-loop - if(ier.ne.0.or.errsum.le.errbnd) go to 40 - 30 continue -c -c compute final result. -c --------------------- -c - 40 result = 0.0d+00 - do 50 k=1,last - result = result+rlist(k) - 50 continue - abserr = errsum - 60 if(keyf.ne.1) neval = (10*keyf+1)*(2*neval+1) - if(keyf.eq.1) neval = 30*neval+15 - 999 return - end - subroutine dqk15(f,a,b,result,abserr,resabs,resasc,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup) -c***begin prologue dqk15 -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a2 -c***keywords 15-point gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div - k.u.leuven -c***purpose to compute i = integral of f over (a,b), with error -c estimate -c j = integral of abs(f) over (a,b) -c***description -c -c integration rules -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the calling program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 15-point -c kronrod rule (resk) obtained by optimal addition -c of abscissae to the7-point gauss rule(resg). -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should not exceed abs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integral of abs(f-i/(b-a)) -c over (a,b) -c -c***references (none) -c***routines called d1mach -c***end prologue dqk15 -c - double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, - * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, - * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup - integer j,jtw,jtwm1 - external f -c - dimension fv1(7),fv2(7),wg(4),wgk(8),xgk(8) - - d1mach(1)=1E21 - d1mach(2)=0d0 - d1mach(3)=0d0 - d1mach(4)=1E-21 - - -c -c the abscissae and weights are given for the interval (-1,1). -c because of symmetry only the positive abscissae and their -c corresponding weights are given. -c -c xgk - abscissae of the 15-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 7-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 7-point gauss rule -c -c wgk - weights of the 15-point kronrod rule -c -c wg - weights of the 7-point gauss rule -c -c -c gauss quadrature weights and kronron quadrature abscissae and weights -c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, -c bell labs, nov. 1981. -c - data wg ( 1) / 0.1294849661 6886969327 0611432679 082 d0 / - data wg ( 2) / 0.2797053914 8927666790 1467771423 780 d0 / - data wg ( 3) / 0.3818300505 0511894495 0369775488 975 d0 / - data wg ( 4) / 0.4179591836 7346938775 5102040816 327 d0 / -c - data xgk ( 1) / 0.9914553711 2081263920 6854697526 329 d0 / - data xgk ( 2) / 0.9491079123 4275852452 6189684047 851 d0 / - data xgk ( 3) / 0.8648644233 5976907278 9712788640 926 d0 / - data xgk ( 4) / 0.7415311855 9939443986 3864773280 788 d0 / - data xgk ( 5) / 0.5860872354 6769113029 4144838258 730 d0 / - data xgk ( 6) / 0.4058451513 7739716690 6606412076 961 d0 / - data xgk ( 7) / 0.2077849550 0789846760 0689403773 245 d0 / - data xgk ( 8) / 0.0000000000 0000000000 0000000000 000 d0 / -c - data wgk ( 1) / 0.0229353220 1052922496 3732008058 970 d0 / - data wgk ( 2) / 0.0630920926 2997855329 0700663189 204 d0 / - data wgk ( 3) / 0.1047900103 2225018383 9876322541 518 d0 / - data wgk ( 4) / 0.1406532597 1552591874 5189590510 238 d0 / - data wgk ( 5) / 0.1690047266 3926790282 6583426598 550 d0 / - data wgk ( 6) / 0.1903505780 6478540991 3256402421 014 d0 / - data wgk ( 7) / 0.2044329400 7529889241 4161999234 649 d0 / - data wgk ( 8) / 0.2094821410 8472782801 2999174891 714 d0 / -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc - abscissa -c fval* - function value -c resg - result of the 7-point gauss formula -c resk - result of the 15-point kronrod formula -c reskh - approximation to the mean value of f over (a,b), -c i.e. to i/(b-a) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqk15 - epmach = d1mach(4) - uflow = d1mach(1) -c - centr = 0.5d+00*(a+b) - hlgth = 0.5d+00*(b-a) - dhlgth = dabs(hlgth) -c -c compute the 15-point kronrod approximation to -c the integral, and estimate the absolute error. -c - fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - resg = fc*wg(4) - resk = fc*wgk(8) - resabs = dabs(resk) - do 10 j=1,3 - jtw = j*2 - absc = hlgth*xgk(jtw) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtw) = fval1 - fv2(jtw) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(jtw)*fsum - resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) - 10 continue - do 15 j = 1,4 - jtwm1 = j*2-1 - absc = hlgth*xgk(jtwm1) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtwm1) = fval1 - fv2(jtwm1) = fval2 - fsum = fval1+fval2 - resk = resk+wgk(jtwm1)*fsum - resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) - 15 continue - reskh = resk*0.5d+00 - resasc = wgk(8)*dabs(fc-reskh) - do 20 j=1,7 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resabs = resabs*dhlgth - resasc = resasc*dhlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) - * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end - subroutine dqk21(f,a,b,result,abserr,resabs,resasc,phi,lambda1, - & zk0,Pup,Tup,rurd,xflow,kup) -c***begin prologue dqk21 -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a2 -c***keywords 21-point gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose to compute i = integral of f over (a,b), with error -c estimate -c j = integral of abs(f) over (a,b) -c***description -c -c integration rules -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the driver program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 21-point -c kronrod rule (resk) obtained by optimal addition -c of abscissae to the 10-point gauss rule (resg). -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should not exceed abs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integral of abs(f-i/(b-a)) -c over (a,b) -c -c***references (none) -c***routines called d1mach -c***end prologue dqk21 -c - double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, - * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, - * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup - integer j,jtw,jtwm1 - external f -c - dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11) - - d1mach(1)=1E21 - d1mach(2)=0d0 - d1mach(3)=0d0 - d1mach(4)=1E-21 -c -c the abscissae and weights are given for the interval (-1,1). -c because of symmetry only the positive abscissae and their -c corresponding weights are given. -c -c xgk - abscissae of the 21-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 10-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 10-point gauss rule -c -c wgk - weights of the 21-point kronrod rule -c -c wg - weights of the 10-point gauss rule -c -c -c gauss quadrature weights and kronron quadrature abscissae and weights -c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, -c bell labs, nov. 1981. -c - data wg ( 1) / 0.0666713443 0868813759 3568809893 332 d0 / - data wg ( 2) / 0.1494513491 5058059314 5776339657 697 d0 / - data wg ( 3) / 0.2190863625 1598204399 5534934228 163 d0 / - data wg ( 4) / 0.2692667193 0999635509 1226921569 469 d0 / - data wg ( 5) / 0.2955242247 1475287017 3892994651 338 d0 / -c - data xgk ( 1) / 0.9956571630 2580808073 5527280689 003 d0 / - data xgk ( 2) / 0.9739065285 1717172007 7964012084 452 d0 / - data xgk ( 3) / 0.9301574913 5570822600 1207180059 508 d0 / - data xgk ( 4) / 0.8650633666 8898451073 2096688423 493 d0 / - data xgk ( 5) / 0.7808177265 8641689706 3717578345 042 d0 / - data xgk ( 6) / 0.6794095682 9902440623 4327365114 874 d0 / - data xgk ( 7) / 0.5627571346 6860468333 9000099272 694 d0 / - data xgk ( 8) / 0.4333953941 2924719079 9265943165 784 d0 / - data xgk ( 9) / 0.2943928627 0146019813 1126603103 866 d0 / - data xgk ( 10) / 0.1488743389 8163121088 4826001129 720 d0 / - data xgk ( 11) / 0.0000000000 0000000000 0000000000 000 d0 / -c - data wgk ( 1) / 0.0116946388 6737187427 8064396062 192 d0 / - data wgk ( 2) / 0.0325581623 0796472747 8818972459 390 d0 / - data wgk ( 3) / 0.0547558965 7435199603 1381300244 580 d0 / - data wgk ( 4) / 0.0750396748 1091995276 7043140916 190 d0 / - data wgk ( 5) / 0.0931254545 8369760553 5065465083 366 d0 / - data wgk ( 6) / 0.1093871588 0229764189 9210590325 805 d0 / - data wgk ( 7) / 0.1234919762 6206585107 7958109831 074 d0 / - data wgk ( 8) / 0.1347092173 1147332592 8054001771 707 d0 / - data wgk ( 9) / 0.1427759385 7706008079 7094273138 717 d0 / - data wgk ( 10) / 0.1477391049 0133849137 4841515972 068 d0 / - data wgk ( 11) / 0.1494455540 0291690566 4936468389 821 d0 / -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc - abscissa -c fval* - function value -c resg - result of the 10-point gauss formula -c resk - result of the 21-point kronrod formula -c reskh - approximation to the mean value of f over (a,b), -c i.e. to i/(b-a) -c -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqk21 - epmach = d1mach(4) - uflow = d1mach(1) -c - centr = 0.5d+00*(a+b) - hlgth = 0.5d+00*(b-a) - dhlgth = dabs(hlgth) -c -c compute the 21-point kronrod approximation to -c the integral, and estimate the absolute error. -c - resg = 0.0d+00 - fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - resk = wgk(11)*fc - resabs = dabs(resk) - do 10 j=1,5 - jtw = 2*j - absc = hlgth*xgk(jtw) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtw) = fval1 - fv2(jtw) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(jtw)*fsum - resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) - 10 continue - do 15 j = 1,5 - jtwm1 = 2*j-1 - absc = hlgth*xgk(jtwm1) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtwm1) = fval1 - fv2(jtwm1) = fval2 - fsum = fval1+fval2 - resk = resk+wgk(jtwm1)*fsum - resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) - 15 continue - reskh = resk*0.5d+00 - resasc = wgk(11)*dabs(fc-reskh) - do 20 j=1,10 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resabs = resabs*dhlgth - resasc = resasc*dhlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) - * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end - subroutine dqk31(f,a,b,result,abserr,resabs,resasc,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup) -c***begin prologue dqk31 -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a2 -c***keywords 31-point gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose to compute i = integral of f over (a,b) with error -c estimate -c j = integral of abs(f) over (a,b) -c***description -c -c integration rules -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the calling program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 31-point -c gauss-kronrod rule (resk), obtained by optimal -c addition of abscissae to the 15-point gauss -c rule (resg). -c -c abserr - double precison -c estimate of the modulus of the modulus, -c which should not exceed abs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integral of abs(f-i/(b-a)) -c over (a,b) -c -c***references (none) -c***routines called d1mach -c***end prologue dqk31 - double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, - * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, - * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup - integer j,jtw,jtwm1 - external f -c - dimension fv1(15),fv2(15),xgk(16),wgk(16),wg(8) - - d1mach(1)=1E21 - d1mach(2)=0d0 - d1mach(3)=0d0 - d1mach(4)=1E-21 -c -c the abscissae and weights are given for the interval (-1,1). -c because of symmetry only the positive abscissae and their -c corresponding weights are given. -c -c xgk - abscissae of the 31-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 15-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 15-point gauss rule -c -c wgk - weights of the 31-point kronrod rule -c -c wg - weights of the 15-point gauss rule -c -c -c gauss quadrature weights and kronron quadrature abscissae and weights -c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, -c bell labs, nov. 1981. -c - data wg ( 1) / 0.0307532419 9611726835 4628393577 204 d0 / - data wg ( 2) / 0.0703660474 8810812470 9267416450 667 d0 / - data wg ( 3) / 0.1071592204 6717193501 1869546685 869 d0 / - data wg ( 4) / 0.1395706779 2615431444 7804794511 028 d0 / - data wg ( 5) / 0.1662692058 1699393355 3200860481 209 d0 / - data wg ( 6) / 0.1861610000 1556221102 6800561866 423 d0 / - data wg ( 7) / 0.1984314853 2711157645 6118326443 839 d0 / - data wg ( 8) / 0.2025782419 2556127288 0620199967 519 d0 / -c - data xgk ( 1) / 0.9980022986 9339706028 5172840152 271 d0 / - data xgk ( 2) / 0.9879925180 2048542848 9565718586 613 d0 / - data xgk ( 3) / 0.9677390756 7913913425 7347978784 337 d0 / - data xgk ( 4) / 0.9372733924 0070590430 7758947710 209 d0 / - data xgk ( 5) / 0.8972645323 4408190088 2509656454 496 d0 / - data xgk ( 6) / 0.8482065834 1042721620 0648320774 217 d0 / - data xgk ( 7) / 0.7904185014 4246593296 7649294817 947 d0 / - data xgk ( 8) / 0.7244177313 6017004741 6186054613 938 d0 / - data xgk ( 9) / 0.6509967412 9741697053 3735895313 275 d0 / - data xgk ( 10) / 0.5709721726 0853884753 7226737253 911 d0 / - data xgk ( 11) / 0.4850818636 4023968069 3655740232 351 d0 / - data xgk ( 12) / 0.3941513470 7756336989 7207370981 045 d0 / - data xgk ( 13) / 0.2991800071 5316881216 6780024266 389 d0 / - data xgk ( 14) / 0.2011940939 9743452230 0628303394 596 d0 / - data xgk ( 15) / 0.1011420669 1871749902 7074231447 392 d0 / - data xgk ( 16) / 0.0000000000 0000000000 0000000000 000 d0 / -c - data wgk ( 1) / 0.0053774798 7292334898 7792051430 128 d0 / - data wgk ( 2) / 0.0150079473 2931612253 8374763075 807 d0 / - data wgk ( 3) / 0.0254608473 2671532018 6874001019 653 d0 / - data wgk ( 4) / 0.0353463607 9137584622 2037948478 360 d0 / - data wgk ( 5) / 0.0445897513 2476487660 8227299373 280 d0 / - data wgk ( 6) / 0.0534815246 9092808726 5343147239 430 d0 / - data wgk ( 7) / 0.0620095678 0067064028 5139230960 803 d0 / - data wgk ( 8) / 0.0698541213 1872825870 9520077099 147 d0 / - data wgk ( 9) / 0.0768496807 5772037889 4432777482 659 d0 / - data wgk ( 10) / 0.0830805028 2313302103 8289247286 104 d0 / - data wgk ( 11) / 0.0885644430 5621177064 7275443693 774 d0 / - data wgk ( 12) / 0.0931265981 7082532122 5486872747 346 d0 / - data wgk ( 13) / 0.0966427269 8362367850 5179907627 589 d0 / - data wgk ( 14) / 0.0991735987 2179195933 2393173484 603 d0 / - data wgk ( 15) / 0.1007698455 2387559504 4946662617 570 d0 / - data wgk ( 16) / 0.1013300070 1479154901 7374792767 493 d0 / -c -c -c list of major variables -c ----------------------- -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc - abscissa -c fval* - function value -c resg - result of the 15-point gauss formula -c resk - result of the 31-point kronrod formula -c reskh - approximation to the mean value of f over (a,b), -c i.e. to i/(b-a) -c -c machine dependent constants -c --------------------------- -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c***first executable statement dqk31 - epmach = d1mach(4) - uflow = d1mach(1) -c - centr = 0.5d+00*(a+b) - hlgth = 0.5d+00*(b-a) - dhlgth = dabs(hlgth) -c -c compute the 31-point kronrod approximation to -c the integral, and estimate the absolute error. -c - fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - resg = wg(8)*fc - resk = wgk(16)*fc - resabs = dabs(resk) - do 10 j=1,7 - jtw = j*2 - absc = hlgth*xgk(jtw) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtw) = fval1 - fv2(jtw) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(jtw)*fsum - resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) - 10 continue - do 15 j = 1,8 - jtwm1 = j*2-1 - absc = hlgth*xgk(jtwm1) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtwm1) = fval1 - fv2(jtwm1) = fval2 - fsum = fval1+fval2 - resk = resk+wgk(jtwm1)*fsum - resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) - 15 continue - reskh = resk*0.5d+00 - resasc = wgk(16)*dabs(fc-reskh) - do 20 j=1,15 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resabs = resabs*dhlgth - resasc = resasc*dhlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) - * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end - subroutine dqk41(f,a,b,result,abserr,resabs,resasc,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup) -c***begin prologue dqk41 -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a2 -c***keywords 41-point gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose to compute i = integral of f over (a,b), with error -c estimate -c j = integral of abs(f) over (a,b) -c***description -c -c integration rules -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the calling program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 41-point -c gauss-kronrod rule (resk) obtained by optimal -c addition of abscissae to the 20-point gauss -c rule (resg). -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should not exceed abs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integal of abs(f-i/(b-a)) -c over (a,b) -c -c***references (none) -c***routines called d1mach -c***end prologue dqk41 -c - double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, - * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, - * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup - integer j,jtw,jtwm1 - external f -c - dimension fv1(20),fv2(20),xgk(21),wgk(21),wg(10) - d1mach(1)=1E21 - d1mach(2)=0d0 - d1mach(3)=0d0 - d1mach(4)=1E-21 -c -c the abscissae and weights are given for the interval (-1,1). -c because of symmetry only the positive abscissae and their -c corresponding weights are given. -c -c xgk - abscissae of the 41-point gauss-kronrod rule -c xgk(2), xgk(4), ... abscissae of the 20-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 20-point gauss rule -c -c wgk - weights of the 41-point gauss-kronrod rule -c -c wg - weights of the 20-point gauss rule -c -c -c gauss quadrature weights and kronron quadrature abscissae and weights -c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, -c bell labs, nov. 1981. -c - data wg ( 1) / 0.0176140071 3915211831 1861962351 853 d0 / - data wg ( 2) / 0.0406014298 0038694133 1039952274 932 d0 / - data wg ( 3) / 0.0626720483 3410906356 9506535187 042 d0 / - data wg ( 4) / 0.0832767415 7670474872 4758143222 046 d0 / - data wg ( 5) / 0.1019301198 1724043503 6750135480 350 d0 / - data wg ( 6) / 0.1181945319 6151841731 2377377711 382 d0 / - data wg ( 7) / 0.1316886384 4917662689 8494499748 163 d0 / - data wg ( 8) / 0.1420961093 1838205132 9298325067 165 d0 / - data wg ( 9) / 0.1491729864 7260374678 7828737001 969 d0 / - data wg ( 10) / 0.1527533871 3072585069 8084331955 098 d0 / -c - data xgk ( 1) / 0.9988590315 8827766383 8315576545 863 d0 / - data xgk ( 2) / 0.9931285991 8509492478 6122388471 320 d0 / - data xgk ( 3) / 0.9815078774 5025025919 3342994720 217 d0 / - data xgk ( 4) / 0.9639719272 7791379126 7666131197 277 d0 / - data xgk ( 5) / 0.9408226338 3175475351 9982722212 443 d0 / - data xgk ( 6) / 0.9122344282 5132590586 7752441203 298 d0 / - data xgk ( 7) / 0.8782768112 5228197607 7442995113 078 d0 / - data xgk ( 8) / 0.8391169718 2221882339 4529061701 521 d0 / - data xgk ( 9) / 0.7950414288 3755119835 0638833272 788 d0 / - data xgk ( 10) / 0.7463319064 6015079261 4305070355 642 d0 / - data xgk ( 11) / 0.6932376563 3475138480 5490711845 932 d0 / - data xgk ( 12) / 0.6360536807 2651502545 2836696226 286 d0 / - data xgk ( 13) / 0.5751404468 1971031534 2946036586 425 d0 / - data xgk ( 14) / 0.5108670019 5082709800 4364050955 251 d0 / - data xgk ( 15) / 0.4435931752 3872510319 9992213492 640 d0 / - data xgk ( 16) / 0.3737060887 1541956067 2548177024 927 d0 / - data xgk ( 17) / 0.3016278681 1491300432 0555356858 592 d0 / - data xgk ( 18) / 0.2277858511 4164507808 0496195368 575 d0 / - data xgk ( 19) / 0.1526054652 4092267550 5220241022 678 d0 / - data xgk ( 20) / 0.0765265211 3349733375 4640409398 838 d0 / - data xgk ( 21) / 0.0000000000 0000000000 0000000000 000 d0 / -c - data wgk ( 1) / 0.0030735837 1852053150 1218293246 031 d0 / - data wgk ( 2) / 0.0086002698 5564294219 8661787950 102 d0 / - data wgk ( 3) / 0.0146261692 5697125298 3787960308 868 d0 / - data wgk ( 4) / 0.0203883734 6126652359 8010231432 755 d0 / - data wgk ( 5) / 0.0258821336 0495115883 4505067096 153 d0 / - data wgk ( 6) / 0.0312873067 7703279895 8543119323 801 d0 / - data wgk ( 7) / 0.0366001697 5820079803 0557240707 211 d0 / - data wgk ( 8) / 0.0416688733 2797368626 3788305936 895 d0 / - data wgk ( 9) / 0.0464348218 6749767472 0231880926 108 d0 / - data wgk ( 10) / 0.0509445739 2372869193 2707670050 345 d0 / - data wgk ( 11) / 0.0551951053 4828599474 4832372419 777 d0 / - data wgk ( 12) / 0.0591114008 8063957237 4967220648 594 d0 / - data wgk ( 13) / 0.0626532375 5478116802 5870122174 255 d0 / - data wgk ( 14) / 0.0658345971 3361842211 1563556969 398 d0 / - data wgk ( 15) / 0.0686486729 2852161934 5623411885 368 d0 / - data wgk ( 16) / 0.0710544235 5344406830 5790361723 210 d0 / - data wgk ( 17) / 0.0730306903 3278666749 5189417658 913 d0 / - data wgk ( 18) / 0.0745828754 0049918898 6581418362 488 d0 / - data wgk ( 19) / 0.0757044976 8455667465 9542775376 617 d0 / - data wgk ( 20) / 0.0763778676 7208073670 5502835038 061 d0 / - data wgk ( 21) / 0.0766007119 1799965644 5049901530 102 d0 / -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc - abscissa -c fval* - function value -c resg - result of the 20-point gauss formula -c resk - result of the 41-point kronrod formula -c reskh - approximation to mean value of f over (a,b), i.e. -c to i/(b-a) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqk41 - epmach = d1mach(4) - uflow = d1mach(1) -c - centr = 0.5d+00*(a+b) - hlgth = 0.5d+00*(b-a) - dhlgth = dabs(hlgth) -c -c compute the 41-point gauss-kronrod approximation to -c the integral, and estimate the absolute error. -c - resg = 0.0d+00 - fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - resk = wgk(21)*fc - resabs = dabs(resk) - do 10 j=1,10 - jtw = j*2 - absc = hlgth*xgk(jtw) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtw) = fval1 - fv2(jtw) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(jtw)*fsum - resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) - 10 continue - do 15 j = 1,10 - jtwm1 = j*2-1 - absc = hlgth*xgk(jtwm1) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtwm1) = fval1 - fv2(jtwm1) = fval2 - fsum = fval1+fval2 - resk = resk+wgk(jtwm1)*fsum - resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) - 15 continue - reskh = resk*0.5d+00 - resasc = wgk(21)*dabs(fc-reskh) - do 20 j=1,20 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resabs = resabs*dhlgth - resasc = resasc*dhlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.d+00) - * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end - subroutine dqk51(f,a,b,result,abserr,resabs,resasc,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup) -c***begin prologue dqk51 -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a2 -c***keywords 51-point gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math & progr. div. - k.u.leuven -c***purpose to compute i = integral of f over (a,b) with error -c estimate -c j = integral of abs(f) over (a,b) -c***description -c -c integration rules -c standard fortran subroutine -c double precision version -c -c parameters -c on entry -c f - double precision -c function subroutine defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the calling program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 51-point -c kronrod rule (resk) obtained by optimal addition -c of abscissae to the 25-point gauss rule (resg). -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should not exceed abs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integral of abs(f-i/(b-a)) -c over (a,b) -c -c***references (none) -c***routines called d1mach -c***end prologue dqk51 -c - double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, - * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, - * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup - integer j,jtw,jtwm1 - external f -c - dimension fv1(25),fv2(25),xgk(26),wgk(26),wg(13) - d1mach(1)=1E21 - d1mach(2)=0d0 - d1mach(3)=0d0 - d1mach(4)=1E-21 -c -c the abscissae and weights are given for the interval (-1,1). -c because of symmetry only the positive abscissae and their -c corresponding weights are given. -c -c xgk - abscissae of the 51-point kronrod rule -c xgk(2), xgk(4), ... abscissae of the 25-point -c gauss rule -c xgk(1), xgk(3), ... abscissae which are optimally -c added to the 25-point gauss rule -c -c wgk - weights of the 51-point kronrod rule -c -c wg - weights of the 25-point gauss rule -c -c -c gauss quadrature weights and kronron quadrature abscissae and weights -c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, -c bell labs, nov. 1981. -c - data wg ( 1) / 0.0113937985 0102628794 7902964113 235 d0 / - data wg ( 2) / 0.0263549866 1503213726 1901815295 299 d0 / - data wg ( 3) / 0.0409391567 0130631265 5623487711 646 d0 / - data wg ( 4) / 0.0549046959 7583519192 5936891540 473 d0 / - data wg ( 5) / 0.0680383338 1235691720 7187185656 708 d0 / - data wg ( 6) / 0.0801407003 3500101801 3234959669 111 d0 / - data wg ( 7) / 0.0910282619 8296364981 1497220702 892 d0 / - data wg ( 8) / 0.1005359490 6705064420 2206890392 686 d0 / - data wg ( 9) / 0.1085196244 7426365311 6093957050 117 d0 / - data wg ( 10) / 0.1148582591 4571164833 9325545869 556 d0 / - data wg ( 11) / 0.1194557635 3578477222 8178126512 901 d0 / - data wg ( 12) / 0.1222424429 9031004168 8959518945 852 d0 / - data wg ( 13) / 0.1231760537 2671545120 3902873079 050 d0 / -c - data xgk ( 1) / 0.9992621049 9260983419 3457486540 341 d0 / - data xgk ( 2) / 0.9955569697 9049809790 8784946893 902 d0 / - data xgk ( 3) / 0.9880357945 3407724763 7331014577 406 d0 / - data xgk ( 4) / 0.9766639214 5951751149 8315386479 594 d0 / - data xgk ( 5) / 0.9616149864 2584251241 8130033660 167 d0 / - data xgk ( 6) / 0.9429745712 2897433941 4011169658 471 d0 / - data xgk ( 7) / 0.9207471152 8170156174 6346084546 331 d0 / - data xgk ( 8) / 0.8949919978 7827536885 1042006782 805 d0 / - data xgk ( 9) / 0.8658470652 9327559544 8996969588 340 d0 / - data xgk ( 10) / 0.8334426287 6083400142 1021108693 570 d0 / - data xgk ( 11) / 0.7978737979 9850005941 0410904994 307 d0 / - data xgk ( 12) / 0.7592592630 3735763057 7282865204 361 d0 / - data xgk ( 13) / 0.7177664068 1308438818 6654079773 298 d0 / - data xgk ( 14) / 0.6735663684 7346836448 5120633247 622 d0 / - data xgk ( 15) / 0.6268100990 1031741278 8122681624 518 d0 / - data xgk ( 16) / 0.5776629302 4122296772 3689841612 654 d0 / - data xgk ( 17) / 0.5263252843 3471918259 9623778158 010 d0 / - data xgk ( 18) / 0.4730027314 4571496052 2182115009 192 d0 / - data xgk ( 19) / 0.4178853821 9303774885 1814394594 572 d0 / - data xgk ( 20) / 0.3611723058 0938783773 5821730127 641 d0 / - data xgk ( 21) / 0.3030895389 3110783016 7478909980 339 d0 / - data xgk ( 22) / 0.2438668837 2098843204 5190362797 452 d0 / - data xgk ( 23) / 0.1837189394 2104889201 5969888759 528 d0 / - data xgk ( 24) / 0.1228646926 1071039638 7359818808 037 d0 / - data xgk ( 25) / 0.0615444830 0568507888 6546392366 797 d0 / - data xgk ( 26) / 0.0000000000 0000000000 0000000000 000 d0 / -c - data wgk ( 1) / 0.0019873838 9233031592 6507851882 843 d0 / - data wgk ( 2) / 0.0055619321 3535671375 8040236901 066 d0 / - data wgk ( 3) / 0.0094739733 8617415160 7207710523 655 d0 / - data wgk ( 4) / 0.0132362291 9557167481 3656405846 976 d0 / - data wgk ( 5) / 0.0168478177 0912829823 1516667536 336 d0 / - data wgk ( 6) / 0.0204353711 4588283545 6568292235 939 d0 / - data wgk ( 7) / 0.0240099456 0695321622 0092489164 881 d0 / - data wgk ( 8) / 0.0274753175 8785173780 2948455517 811 d0 / - data wgk ( 9) / 0.0307923001 6738748889 1109020215 229 d0 / - data wgk ( 10) / 0.0340021302 7432933783 6748795229 551 d0 / - data wgk ( 11) / 0.0371162714 8341554356 0330625367 620 d0 / - data wgk ( 12) / 0.0400838255 0403238207 4839284467 076 d0 / - data wgk ( 13) / 0.0428728450 2017004947 6895792439 495 d0 / - data wgk ( 14) / 0.0455029130 4992178890 9870584752 660 d0 / - data wgk ( 15) / 0.0479825371 3883671390 6392255756 915 d0 / - data wgk ( 16) / 0.0502776790 8071567196 3325259433 440 d0 / - data wgk ( 17) / 0.0523628858 0640747586 4366712137 873 d0 / - data wgk ( 18) / 0.0542511298 8854549014 4543370459 876 d0 / - data wgk ( 19) / 0.0559508112 2041231730 8240686382 747 d0 / - data wgk ( 20) / 0.0574371163 6156783285 3582693939 506 d0 / - data wgk ( 21) / 0.0586896800 2239420796 1974175856 788 d0 / - data wgk ( 22) / 0.0597203403 2417405997 9099291932 562 d0 / - data wgk ( 23) / 0.0605394553 7604586294 5360267517 565 d0 / - data wgk ( 24) / 0.0611285097 1705304830 5859030416 293 d0 / - data wgk ( 25) / 0.0614711898 7142531666 1544131965 264 d0 / -c note: wgk (26) was calculated from the values of wgk(1..25) - data wgk ( 26) / 0.0615808180 6783293507 8759824240 066 d0 / -c -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c absc - abscissa -c fval* - function value -c resg - result of the 25-point gauss formula -c resk - result of the 51-point kronrod formula -c reskh - approximation to the mean value of f over (a,b), -c i.e. to i/(b-a) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c -c***first executable statement dqk51 - epmach = d1mach(4) - uflow = d1mach(1) -c - centr = 0.5d+00*(a+b) - hlgth = 0.5d+00*(b-a) - dhlgth = dabs(hlgth) -c -c compute the 51-point kronrod approximation to -c the integral, and estimate the absolute error. -c - fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - resg = wg(13)*fc - resk = wgk(26)*fc - resabs = dabs(resk) - do 10 j=1,12 - jtw = j*2 - absc = hlgth*xgk(jtw) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtw) = fval1 - fv2(jtw) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(jtw)*fsum - resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) - 10 continue - do 15 j = 1,13 - jtwm1 = j*2-1 - absc = hlgth*xgk(jtwm1) - fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtwm1) = fval1 - fv2(jtwm1) = fval2 - fsum = fval1+fval2 - resk = resk+wgk(jtwm1)*fsum - resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) - 15 continue - reskh = resk*0.5d+00 - resasc = wgk(26)*dabs(fc-reskh) - do 20 j=1,25 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resabs = resabs*dhlgth - resasc = resasc*dhlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) - * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end - subroutine dqk61(f,a,b,result,abserr,resabs,resasc,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup) -c***begin prologue dqk61 -c***date written 800101 (yymmdd) -c***revision date 830518 (yymmdd) -c***category no. h2a1a2 -c***keywords 61-point gauss-kronrod rules -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose to compute i = integral of f over (a,b) with error -c estimate -c j = integral of dabs(f) over (a,b) -c***description -c -c integration rule -c standard fortran subroutine -c double precision version -c -c -c parameters -c on entry -c f - double precision -c function subprogram defining the integrand -c function f(x). the actual name for f needs to be -c declared e x t e r n a l in the calling program. -c -c a - double precision -c lower limit of integration -c -c b - double precision -c upper limit of integration -c -c on return -c result - double precision -c approximation to the integral i -c result is computed by applying the 61-point -c kronrod rule (resk) obtained by optimal addition of -c abscissae to the 30-point gauss rule (resg). -c -c abserr - double precision -c estimate of the modulus of the absolute error, -c which should equal or exceed dabs(i-result) -c -c resabs - double precision -c approximation to the integral j -c -c resasc - double precision -c approximation to the integral of dabs(f-i/(b-a)) -c -c -c***references (none) -c***routines called d1mach -c***end prologue dqk61 -c - double precision a,dabsc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, - * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, - * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, - * zk0,Pup,Tup,rurd,xflow,kup - integer j,jtw,jtwm1 - external f -c - dimension fv1(30),fv2(30),xgk(31),wgk(31),wg(15) - d1mach(1)=1E21 - d1mach(2)=0 - d1mach(3)=0 - d1mach(4)=1E-21 -c -c the abscissae and weights are given for the -c interval (-1,1). because of symmetry only the positive -c abscissae and their corresponding weights are given. -c -c xgk - abscissae of the 61-point kronrod rule -c xgk(2), xgk(4) ... abscissae of the 30-point -c gauss rule -c xgk(1), xgk(3) ... optimally added abscissae -c to the 30-point gauss rule -c -c wgk - weights of the 61-point kronrod rule -c -c wg - weigths of the 30-point gauss rule -c -c -c gauss quadrature weights and kronron quadrature abscissae and weights -c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, -c bell labs, nov. 1981. -c - data wg ( 1) / 0.0079681924 9616660561 5465883474 674 d0 / - data wg ( 2) / 0.0184664683 1109095914 2302131912 047 d0 / - data wg ( 3) / 0.0287847078 8332336934 9719179611 292 d0 / - data wg ( 4) / 0.0387991925 6962704959 6801936446 348 d0 / - data wg ( 5) / 0.0484026728 3059405290 2938140422 808 d0 / - data wg ( 6) / 0.0574931562 1761906648 1721689402 056 d0 / - data wg ( 7) / 0.0659742298 8218049512 8128515115 962 d0 / - data wg ( 8) / 0.0737559747 3770520626 8243850022 191 d0 / - data wg ( 9) / 0.0807558952 2942021535 4694938460 530 d0 / - data wg ( 10) / 0.0868997872 0108297980 2387530715 126 d0 / - data wg ( 11) / 0.0921225222 3778612871 7632707087 619 d0 / - data wg ( 12) / 0.0963687371 7464425963 9468626351 810 d0 / - data wg ( 13) / 0.0995934205 8679526706 2780282103 569 d0 / - data wg ( 14) / 0.1017623897 4840550459 6428952168 554 d0 / - data wg ( 15) / 0.1028526528 9355884034 1285636705 415 d0 / -c - data xgk ( 1) / 0.9994844100 5049063757 1325895705 811 d0 / - data xgk ( 2) / 0.9968934840 7464954027 1630050918 695 d0 / - data xgk ( 3) / 0.9916309968 7040459485 8628366109 486 d0 / - data xgk ( 4) / 0.9836681232 7974720997 0032581605 663 d0 / - data xgk ( 5) / 0.9731163225 0112626837 4693868423 707 d0 / - data xgk ( 6) / 0.9600218649 6830751221 6871025581 798 d0 / - data xgk ( 7) / 0.9443744447 4855997941 5831324037 439 d0 / - data xgk ( 8) / 0.9262000474 2927432587 9324277080 474 d0 / - data xgk ( 9) / 0.9055733076 9990779854 6522558925 958 d0 / - data xgk ( 10) / 0.8825605357 9205268154 3116462530 226 d0 / - data xgk ( 11) / 0.8572052335 4606109895 8658510658 944 d0 / - data xgk ( 12) / 0.8295657623 8276839744 2898119732 502 d0 / - data xgk ( 13) / 0.7997278358 2183908301 3668942322 683 d0 / - data xgk ( 14) / 0.7677774321 0482619491 7977340974 503 d0 / - data xgk ( 15) / 0.7337900624 5322680472 6171131369 528 d0 / - data xgk ( 16) / 0.6978504947 9331579693 2292388026 640 d0 / - data xgk ( 17) / 0.6600610641 2662696137 0053668149 271 d0 / - data xgk ( 18) / 0.6205261829 8924286114 0477556431 189 d0 / - data xgk ( 19) / 0.5793452358 2636169175 6024932172 540 d0 / - data xgk ( 20) / 0.5366241481 4201989926 4169793311 073 d0 / - data xgk ( 21) / 0.4924804678 6177857499 3693061207 709 d0 / - data xgk ( 22) / 0.4470337695 3808917678 0609900322 854 d0 / - data xgk ( 23) / 0.4004012548 3039439253 5476211542 661 d0 / - data xgk ( 24) / 0.3527047255 3087811347 1037207089 374 d0 / - data xgk ( 25) / 0.3040732022 7362507737 2677107199 257 d0 / - data xgk ( 26) / 0.2546369261 6788984643 9805129817 805 d0 / - data xgk ( 27) / 0.2045251166 8230989143 8957671002 025 d0 / - data xgk ( 28) / 0.1538699136 0858354696 3794672743 256 d0 / - data xgk ( 29) / 0.1028069379 6673703014 7096751318 001 d0 / - data xgk ( 30) / 0.0514718425 5531769583 3025213166 723 d0 / - data xgk ( 31) / 0.0000000000 0000000000 0000000000 000 d0 / -c - data wgk ( 1) / 0.0013890136 9867700762 4551591226 760 d0 / - data wgk ( 2) / 0.0038904611 2709988405 1267201844 516 d0 / - data wgk ( 3) / 0.0066307039 1593129217 3319826369 750 d0 / - data wgk ( 4) / 0.0092732796 5951776342 8441146892 024 d0 / - data wgk ( 5) / 0.0118230152 5349634174 2232898853 251 d0 / - data wgk ( 6) / 0.0143697295 0704580481 2451432443 580 d0 / - data wgk ( 7) / 0.0169208891 8905327262 7572289420 322 d0 / - data wgk ( 8) / 0.0194141411 9394238117 3408951050 128 d0 / - data wgk ( 9) / 0.0218280358 2160919229 7167485738 339 d0 / - data wgk ( 10) / 0.0241911620 7808060136 5686370725 232 d0 / - data wgk ( 11) / 0.0265099548 8233310161 0601709335 075 d0 / - data wgk ( 12) / 0.0287540487 6504129284 3978785354 334 d0 / - data wgk ( 13) / 0.0309072575 6238776247 2884252943 092 d0 / - data wgk ( 14) / 0.0329814470 5748372603 1814191016 854 d0 / - data wgk ( 15) / 0.0349793380 2806002413 7499670731 468 d0 / - data wgk ( 16) / 0.0368823646 5182122922 3911065617 136 d0 / - data wgk ( 17) / 0.0386789456 2472759295 0348651532 281 d0 / - data wgk ( 18) / 0.0403745389 5153595911 1995279752 468 d0 / - data wgk ( 19) / 0.0419698102 1516424614 7147541285 970 d0 / - data wgk ( 20) / 0.0434525397 0135606931 6831728117 073 d0 / - data wgk ( 21) / 0.0448148001 3316266319 2355551616 723 d0 / - data wgk ( 22) / 0.0460592382 7100698811 6271735559 374 d0 / - data wgk ( 23) / 0.0471855465 6929915394 5261478181 099 d0 / - data wgk ( 24) / 0.0481858617 5708712914 0779492298 305 d0 / - data wgk ( 25) / 0.0490554345 5502977888 7528165367 238 d0 / - data wgk ( 26) / 0.0497956834 2707420635 7811569379 942 d0 / - data wgk ( 27) / 0.0504059214 0278234684 0893085653 585 d0 / - data wgk ( 28) / 0.0508817958 9874960649 2297473049 805 d0 / - data wgk ( 29) / 0.0512215478 4925877217 0656282604 944 d0 / - data wgk ( 30) / 0.0514261285 3745902593 3862879215 781 d0 / - data wgk ( 31) / 0.0514947294 2945156755 8340433647 099 d0 / -c -c list of major variables -c ----------------------- -c -c centr - mid point of the interval -c hlgth - half-length of the interval -c dabsc - abscissa -c fval* - function value -c resg - result of the 30-point gauss rule -c resk - result of the 61-point kronrod rule -c reskh - approximation to the mean value of f -c over (a,b), i.e. to i/(b-a) -c -c machine dependent constants -c --------------------------- -c -c epmach is the largest relative spacing. -c uflow is the smallest positive magnitude. -c - epmach = d1mach(4) - uflow = d1mach(1) -c - centr = 0.5d+00*(b+a) - hlgth = 0.5d+00*(b-a) - dhlgth = dabs(hlgth) -c -c compute the 61-point kronrod approximation to the -c integral, and estimate the absolute error. -c -c***first executable statement dqk61 - resg = 0.0d+00 - fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - resk = wgk(31)*fc - resabs = dabs(resk) - do 10 j=1,15 - jtw = j*2 - dabsc = hlgth*xgk(jtw) - fval1 = f(centr-dabsc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+dabsc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtw) = fval1 - fv2(jtw) = fval2 - fsum = fval1+fval2 - resg = resg+wg(j)*fsum - resk = resk+wgk(jtw)*fsum - resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) - 10 continue - do 15 j=1,15 - jtwm1 = j*2-1 - dabsc = hlgth*xgk(jtwm1) - fval1 = f(centr-dabsc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fval2 = f(centr+dabsc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) - fv1(jtwm1) = fval1 - fv2(jtwm1) = fval2 - fsum = fval1+fval2 - resk = resk+wgk(jtwm1)*fsum - resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) - 15 continue - reskh = resk*0.5d+00 - resasc = wgk(31)*dabs(fc-reskh) - do 20 j=1,30 - resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) - 20 continue - result = resk*hlgth - resabs = resabs*dhlgth - resasc = resasc*dhlgth - abserr = dabs((resk-resg)*hlgth) - if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) - * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) - if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 - * ((epmach*0.5d+02)*resabs,abserr) - return - end - subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax, - * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) -c***begin prologue dqpsrt -c***refer to dqage,dqagie,dqagpe,dqawse -c***routines called (none) -c***revision date 810101 (yymmdd) -c***keywords sequential sorting -c***author piessens,robert,appl. math. & progr. div. - k.u.leuven -c de doncker,elise,appl. math. & progr. div. - k.u.leuven -c***purpose this routine maintains the descending ordering in the -c list of the local error estimated resulting from the -c interval subdivision process. at each call two error -c estimates are inserted using the sequential search -c method, top-down for the largest error estimate and -c bottom-up for the smallest error estimate. -c***description -c -c ordering routine -c standard fortran subroutine -c double precision version -c -c parameters (meaning at output) -c limit - integer -c maximum number of error estimates the list -c can contain -c -c last - integer -c number of error estimates currently in the list -c -c maxerr - integer -c maxerr points to the nrmax-th largest error -c estimate currently in the list -c -c ermax - double precision -c nrmax-th largest error estimate -c ermax = elist(maxerr) -c -c elist - double precision -c vector of dimension last containing -c the error estimates -c -c iord - integer -c vector of dimension last, the first k elements -c of which contain pointers to the error -c estimates, such that -c elist(iord(1)),..., elist(iord(k)) -c form a decreasing sequence, with -c k = last if last.le.(limit/2+2), and -c k = limit+1-last otherwise -c -c nrmax - integer -c maxerr = iord(nrmax) -c -c***end prologue dqpsrt -c - double precision elist,ermax,errmax,errmin,phi,lambda1,zk0, - * Pup,Tup,rurd,xflow,kup - integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr, - * nrmax - dimension elist(last),iord(last) -c -c check whether the list contains more than -c two error estimates. -c -c***first executable statement dqpsrt - if(last.gt.2) go to 10 - iord(1) = 1 - iord(2) = 2 - go to 90 -c -c this part of the routine is only executed if, due to a -c difficult integrand, subdivision increased the error -c estimate. in the normal case the insert procedure should -c start after the nrmax-th largest error estimate. -c - 10 errmax = elist(maxerr) - if(nrmax.eq.1) go to 30 - ido = nrmax-1 - do 20 i = 1,ido - isucc = iord(nrmax-1) -c ***jump out of do-loop - if(errmax.le.elist(isucc)) go to 30 - iord(nrmax) = isucc - nrmax = nrmax-1 - 20 continue -c -c compute the number of elements in the list to be maintained -c in descending order. this number depends on the number of -c subdivisions still allowed. -c - 30 jupbn = last - if(last.gt.(limit/2+2)) jupbn = limit+3-last - errmin = elist(last) -c -c insert errmax by traversing the list top-down, -c starting comparison from the element elist(iord(nrmax+1)). -c - jbnd = jupbn-1 - ibeg = nrmax+1 - if(ibeg.gt.jbnd) go to 50 - do 40 i=ibeg,jbnd - isucc = iord(i) -c ***jump out of do-loop - if(errmax.ge.elist(isucc)) go to 60 - iord(i-1) = isucc - 40 continue - 50 iord(jbnd) = maxerr - iord(jupbn) = last - go to 90 -c -c insert errmin by traversing the list bottom-up. -c - 60 iord(i-1) = maxerr - k = jbnd - do 70 j=i,jbnd - isucc = iord(k) -c ***jump out of do-loop - if(errmin.lt.elist(isucc)) go to 80 - iord(k+1) = isucc - k = k-1 - 70 continue - iord(i) = last - go to 90 - 80 iord(k+1) = last -c -c set maxerr and ermax. -c - 90 maxerr = iord(nrmax) - ermax = elist(maxerr) - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/dredu.f calculix-ccx-2.3/ccx_2.1/src/dredu.f --- calculix-ccx-2.1/ccx_2.1/src/dredu.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dredu.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dredu(al,au,ad,jh,flg ,dj) - implicit real*8 (a-h,o-z) -c....reduce diagonal element in triangular decomposition - logical flg - real*8 al(jh),au(jh),ad(jh) - do 100 j = 1,jh - ud = au(j)*ad(j) - dj = dj - al(j)*ud - au(j) = ud - 100 continue -c....finish computation of column of al for unsymmetric matrices - if(flg) then - do 200 j = 1,jh - al(j) = al(j)*ad(j) - 200 continue - endif - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/drfftf.f calculix-ccx-2.3/ccx_2.1/src/drfftf.f --- calculix-ccx-2.1/ccx_2.1/src/drfftf.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/drfftf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,596 +0,0 @@ -! -! -! FFTPACK -! -!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! version 4 april 1985 -! -! a package of fortran subprograms for the fast fourier -! transform of periodic and other symmetric sequences -! -! by -! -! paul n swarztrauber -! -! national center for atmospheric research boulder,colorado 80307 -! -! which is sponsored by the national science foundation -! -! CHANGED ON 11 May 2005 by Guido Dhondt: -! 1. introduced array isave (compatibility with ifac in drfftf1) -! 2. changed real to double -! -!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * -! -! -!this package consists of programs which perform fast fourier -!transforms for both complex and real periodic sequences and -!certain other symmetric sequences that are listed below. -! -!1. drffti initialize drfftf and rfftb -!2. drfftf forward transform of a real periodic sequence -! -! -!****************************************************************** -! -!subroutine drffti(n,wsave,isave) -! -! **************************************************************** -! -!subroutine drffti initializes the array wsave which is used in -!both drfftf and rfftb. the prime factorization of n together with -!a tabulation of the trigonometric functions are computed and -!stored in wsave. -! -!input parameter -! -!n the length of the sequence to be transformed. -! -!output parameter -! -!wsave a work array which must be dimensioned at least 2*n. -! the same work array can be used for both drfftf and rfftb -! as long as n remains unchanged. different wsave arrays -! are required for different values of n. the contents of -! wsave must not be changed between calls of drfftf or rfftb. -!isave a work array which must be dimensioned at least 15. -! -!****************************************************************** -! -!subroutine drfftf(n,r,wsave,isave) -! -!****************************************************************** -! -!subroutine drfftf computes the fourier coefficients of a real -!perodic sequence (fourier analysis). the transform is defined -!below at output parameter r. -! -!input parameters -! -!n the length of the array r to be transformed. the method -! is most efficient when n is a product of small primes. -! n may change so long as different work arrays are provided -! -!r a real array of length n which contains the sequence -! to be transformed -! -!wsave a work array which must be dimensioned at least 2*n. -! in the program that calls drfftf. the wsave array must be -! initialized by calling subroutine drffti(n,wsave) and a -! different wsave array must be used for each different -! value of n. this initialization does not have to be -! repeated so long as n remains unchanged thus subsequent -! transforms can be obtained faster than the first. -! the same wsave array can be used by drfftf and rfftb. -!isave a work array which must be dimensioned at least 15. -! -! -!output parameters -! -!r r(1) = the sum from i=1 to i=n of r(i) -! -! if n is even set l =n/2 , if n is odd set l = (n+1)/2 -! -! then for k = 2,...,l -! -! r(2*k-2) = the sum from i = 1 to i = n of -! -! r(i)*cos((k-1)*(i-1)*2*pi/n) -! -! r(2*k-1) = the sum from i = 1 to i = n of -! -! -r(i)*sin((k-1)*(i-1)*2*pi/n) -! -! if n is even -! -! r(n) = the sum from i = 1 to i = n of -! -! (-1)**(i-1)*r(i) -! -! ***** note -! this transform is unnormalized since a call of drfftf -! followed by a call of rfftb will multiply the input -! sequence by n. -! -!wsave contains results which must not be destroyed between -! calls of drfftf or rfftb. -! -! - SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) - implicit real*8(a-h,o-z) - DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , - 1 WA1(1) - DO 101 K=1,L1 - CH(1,1,K) = CC(1,K,1)+CC(1,K,2) - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CH(I,1,K) = CC(I,K,1)+TI2 - CH(IC,2,K) = TI2-CC(I,K,1) - CH(I-1,1,K) = CC(I-1,K,1)+TR2 - CH(IC-1,2,K) = CC(I-1,K,1)-TR2 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 DO 106 K=1,L1 - CH(1,2,K) = -CC(IDO,K,2) - CH(IDO,1,K) = CC(IDO,K,1) - 106 CONTINUE - 107 RETURN - END - SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) - implicit real*8(a-h,o-z) - DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , - 1 WA1(1) ,WA2(1) - DATA TAUR,TAUI /-.5,.866025403784439/ - DO 101 K=1,L1 - CR2 = CC(1,K,2)+CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2 - CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) - CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR2 = DR2+DR3 - CI2 = DI2+DI3 - CH(I-1,1,K) = CC(I-1,K,1)+CR2 - CH(I,1,K) = CC(I,K,1)+CI2 - TR2 = CC(I-1,K,1)+TAUR*CR2 - TI2 = CC(I,K,1)+TAUR*CI2 - TR3 = TAUI*(DI2-DI3) - TI3 = TAUI*(DR3-DR2) - CH(I-1,3,K) = TR2+TR3 - CH(IC-1,2,K) = TR2-TR3 - CH(I,3,K) = TI2+TI3 - CH(IC,2,K) = TI3-TI2 - 102 CONTINUE - 103 CONTINUE - RETURN - END - SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) - implicit real*8(a-h,o-z) - DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) - DATA HSQT2 /.7071067811865475/ - DO 101 K=1,L1 - TR1 = CC(1,K,2)+CC(1,K,4) - TR2 = CC(1,K,1)+CC(1,K,3) - CH(1,1,K) = TR1+TR2 - CH(IDO,4,K) = TR2-TR1 - CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) - CH(1,3,K) = CC(1,K,4)-CC(1,K,2) - 101 CONTINUE - IF (IDO-2) 107,105,102 - 102 IDP2 = IDO+2 - DO 104 K=1,L1 - DO 103 I=3,IDO,2 - IC = IDP2-I - CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - TR1 = CR2+CR4 - TR4 = CR4-CR2 - TI1 = CI2+CI4 - TI4 = CI2-CI4 - TI2 = CC(I,K,1)+CI3 - TI3 = CC(I,K,1)-CI3 - TR2 = CC(I-1,K,1)+CR3 - TR3 = CC(I-1,K,1)-CR3 - CH(I-1,1,K) = TR1+TR2 - CH(IC-1,4,K) = TR2-TR1 - CH(I,1,K) = TI1+TI2 - CH(IC,4,K) = TI1-TI2 - CH(I-1,3,K) = TI4+TR3 - CH(IC-1,2,K) = TR3-TI4 - CH(I,3,K) = TR4+TI3 - CH(IC,2,K) = TR4-TI3 - 103 CONTINUE - 104 CONTINUE - IF (MOD(IDO,2) .EQ. 1) RETURN - 105 CONTINUE - DO 106 K=1,L1 - TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) - TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) - CH(IDO,1,K) = TR1+CC(IDO,K,1) - CH(IDO,3,K) = CC(IDO,K,1)-TR1 - CH(1,2,K) = TI1-CC(IDO,K,3) - CH(1,4,K) = TI1+CC(IDO,K,3) - 106 CONTINUE - 107 RETURN - END - SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) - implicit real*8(a-h,o-z) - DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , - 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) - DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, - 1-.809016994374947,.587785252292473/ - DO 101 K=1,L1 - CR2 = CC(1,K,5)+CC(1,K,2) - CI5 = CC(1,K,5)-CC(1,K,2) - CR3 = CC(1,K,4)+CC(1,K,3) - CI4 = CC(1,K,4)-CC(1,K,3) - CH(1,1,K) = CC(1,K,1)+CR2+CR3 - CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 - CH(1,3,K) = TI11*CI5+TI12*CI4 - CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 - CH(1,5,K) = TI12*CI5-TI11*CI4 - 101 CONTINUE - IF (IDO .EQ. 1) RETURN - IDP2 = IDO+2 - DO 103 K=1,L1 - DO 102 I=3,IDO,2 - IC = IDP2-I - DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) - DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) - DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) - DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) - DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) - DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) - DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) - DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) - CR2 = DR2+DR5 - CI5 = DR5-DR2 - CR5 = DI2-DI5 - CI2 = DI2+DI5 - CR3 = DR3+DR4 - CI4 = DR4-DR3 - CR4 = DI3-DI4 - CI3 = DI3+DI4 - CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 - CH(I,1,K) = CC(I,K,1)+CI2+CI3 - TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 - TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 - TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 - TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 - TR5 = TI11*CR5+TI12*CR4 - TI5 = TI11*CI5+TI12*CI4 - TR4 = TI12*CR5-TI11*CR4 - TI4 = TI12*CI5-TI11*CI4 - CH(I-1,3,K) = TR2+TR5 - CH(IC-1,2,K) = TR2-TR5 - CH(I,3,K) = TI2+TI5 - CH(IC,2,K) = TI5-TI2 - CH(I-1,5,K) = TR3+TR4 - CH(IC-1,4,K) = TR3-TR4 - CH(I,5,K) = TI3+TI4 - CH(IC,4,K) = TI4-TI3 - 102 CONTINUE - 103 CONTINUE - RETURN - END - SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) - implicit real*8(a-h,o-z) - DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , - 1 C1(IDO,L1,IP) ,C2(IDL1,IP), - 2 CH2(IDL1,IP) ,WA(1) - DATA TPI/6.28318530717959/ - ARG = TPI/FLOAT(IP) - DCP = COS(ARG) - DSP = SIN(ARG) - IPPH = (IP+1)/2 - IPP2 = IP+2 - IDP2 = IDO+2 - NBD = (IDO-1)/2 - IF (IDO .EQ. 1) GO TO 119 - DO 101 IK=1,IDL1 - CH2(IK,1) = C2(IK,1) - 101 CONTINUE - DO 103 J=2,IP - DO 102 K=1,L1 - CH(1,K,J) = C1(1,K,J) - 102 CONTINUE - 103 CONTINUE - IF (NBD .GT. L1) GO TO 107 - IS = -IDO - DO 106 J=2,IP - IS = IS+IDO - IDIJ = IS - DO 105 I=3,IDO,2 - IDIJ = IDIJ+2 - DO 104 K=1,L1 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 104 CONTINUE - 105 CONTINUE - 106 CONTINUE - GO TO 111 - 107 IS = -IDO - DO 110 J=2,IP - IS = IS+IDO - DO 109 K=1,L1 - IDIJ = IS - DO 108 I=3,IDO,2 - IDIJ = IDIJ+2 - CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) - CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) - 108 CONTINUE - 109 CONTINUE - 110 CONTINUE - 111 IF (NBD .LT. L1) GO TO 115 - DO 114 J=2,IPPH - JC = IPP2-J - DO 113 K=1,L1 - DO 112 I=3,IDO,2 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 112 CONTINUE - 113 CONTINUE - 114 CONTINUE - GO TO 121 - 115 DO 118 J=2,IPPH - JC = IPP2-J - DO 117 I=3,IDO,2 - DO 116 K=1,L1 - C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) - C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) - C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) - C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) - 116 CONTINUE - 117 CONTINUE - 118 CONTINUE - GO TO 121 - 119 DO 120 IK=1,IDL1 - C2(IK,1) = CH2(IK,1) - 120 CONTINUE - 121 DO 123 J=2,IPPH - JC = IPP2-J - DO 122 K=1,L1 - C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) - C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) - 122 CONTINUE - 123 CONTINUE -C - AR1 = 1. - AI1 = 0. - DO 127 L=2,IPPH - LC = IPP2-L - AR1H = DCP*AR1-DSP*AI1 - AI1 = DCP*AI1+DSP*AR1 - AR1 = AR1H - DO 124 IK=1,IDL1 - CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) - CH2(IK,LC) = AI1*C2(IK,IP) - 124 CONTINUE - DC2 = AR1 - DS2 = AI1 - AR2 = AR1 - AI2 = AI1 - DO 126 J=3,IPPH - JC = IPP2-J - AR2H = DC2*AR2-DS2*AI2 - AI2 = DC2*AI2+DS2*AR2 - AR2 = AR2H - DO 125 IK=1,IDL1 - CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) - CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) - 125 CONTINUE - 126 CONTINUE - 127 CONTINUE - DO 129 J=2,IPPH - DO 128 IK=1,IDL1 - CH2(IK,1) = CH2(IK,1)+C2(IK,J) - 128 CONTINUE - 129 CONTINUE -C - IF (IDO .LT. L1) GO TO 132 - DO 131 K=1,L1 - DO 130 I=1,IDO - CC(I,1,K) = CH(I,K,1) - 130 CONTINUE - 131 CONTINUE - GO TO 135 - 132 DO 134 I=1,IDO - DO 133 K=1,L1 - CC(I,1,K) = CH(I,K,1) - 133 CONTINUE - 134 CONTINUE - 135 DO 137 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 136 K=1,L1 - CC(IDO,J2-2,K) = CH(1,K,J) - CC(1,J2-1,K) = CH(1,K,JC) - 136 CONTINUE - 137 CONTINUE - IF (IDO .EQ. 1) RETURN - IF (NBD .LT. L1) GO TO 141 - DO 140 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 139 K=1,L1 - DO 138 I=3,IDO,2 - IC = IDP2-I - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 138 CONTINUE - 139 CONTINUE - 140 CONTINUE - RETURN - 141 DO 144 J=2,IPPH - JC = IPP2-J - J2 = J+J - DO 143 I=3,IDO,2 - IC = IDP2-I - DO 142 K=1,L1 - CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) - CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) - CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) - CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) - 142 CONTINUE - 143 CONTINUE - 144 CONTINUE - RETURN - END - SUBROUTINE dRFFTF (N,R,WSAVE,isave) - implicit real*8(a-h,o-z) - DIMENSION R(1) ,WSAVE(*),isave(*) - IF (N .EQ. 1) RETURN - CALL DRFFTF1 (N,R,WSAVE,WSAVE(N+1),isave) - RETURN - END - SUBROUTINE DRFFTF1 (N,C,CH,WA,IFAC) - implicit real*8(a-h,o-z) - DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(*) - NF = IFAC(2) - NA = 1 - L2 = N - IW = N - DO 111 K1=1,NF - KH = NF-K1 - IP = IFAC(KH+3) - L1 = L2/IP - IDO = N/L2 - IDL1 = IDO*L1 - IW = IW-(IP-1)*IDO - NA = 1-NA - IF (IP .NE. 4) GO TO 102 - IX2 = IW+IDO - IX3 = IX2+IDO - IF (NA .NE. 0) GO TO 101 - CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) - GO TO 110 - 102 IF (IP .NE. 2) GO TO 104 - IF (NA .NE. 0) GO TO 103 - CALL RADF2 (IDO,L1,C,CH,WA(IW)) - GO TO 110 - 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) - GO TO 110 - 104 IF (IP .NE. 3) GO TO 106 - IX2 = IW+IDO - IF (NA .NE. 0) GO TO 105 - CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) - GO TO 110 - 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) - GO TO 110 - 106 IF (IP .NE. 5) GO TO 108 - IX2 = IW+IDO - IX3 = IX2+IDO - IX4 = IX3+IDO - IF (NA .NE. 0) GO TO 107 - CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) - GO TO 110 - 108 IF (IDO .EQ. 1) NA = 1-NA - IF (NA .NE. 0) GO TO 109 - CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) - NA = 1 - GO TO 110 - 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) - NA = 0 - 110 L2 = L1 - 111 CONTINUE - IF (NA .EQ. 1) RETURN - DO 112 I=1,N - C(I) = CH(I) - 112 CONTINUE - RETURN - END - SUBROUTINE dRFFTI (N,WSAVE,isave) - implicit real*8(a-h,o-z) - DIMENSION WSAVE(*),isave(*) - IF (N .EQ. 1) RETURN - CALL DRFFTI1 (N,WSAVE(N+1),isave) - RETURN - END - SUBROUTINE DRFFTI1 (N,WA,IFAC) - implicit real*8(a-h,o-z) - DIMENSION WA(1) ,IFAC(*) ,NTRYH(4) - DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ - NL = N - NF = 0 - J = 0 - 101 J = J+1 - IF (J-4) 102,102,103 - 102 NTRY = NTRYH(J) - GO TO 104 - 103 NTRY = NTRY+2 - 104 NQ = NL/NTRY - NR = NL-NTRY*NQ - IF (NR) 101,105,101 - 105 NF = NF+1 - IFAC(NF+2) = NTRY - NL = NQ - IF (NTRY .NE. 2) GO TO 107 - IF (NF .EQ. 1) GO TO 107 - DO 106 I=2,NF - IB = NF-I+2 - IFAC(IB+2) = IFAC(IB+1) - 106 CONTINUE - IFAC(3) = 2 - 107 IF (NL .NE. 1) GO TO 104 - IFAC(1) = N - IFAC(2) = NF - TPI = 6.28318530717959 - ARGH = TPI/FLOAT(N) - IS = 0 - NFM1 = NF-1 - L1 = 1 - IF (NFM1 .EQ. 0) RETURN - DO 110 K1=1,NFM1 - IP = IFAC(K1+2) - LD = 0 - L2 = L1*IP - IDO = N/L2 - IPM = IP-1 - DO 109 J=1,IPM - LD = LD+L1 - I = IS - ARGLD = FLOAT(LD)*ARGH - FI = 0. - DO 108 II=3,IDO,2 - I = I+2 - FI = FI+1. - ARG = FI*ARGLD - WA(I-1) = COS(ARG) - WA(I) = SIN(ARG) - 108 CONTINUE - IS = IS+IDO - 109 CONTINUE - L1 = L2 - 110 CONTINUE - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/dsort.f calculix-ccx-2.3/ccx_2.1/src/dsort.f --- calculix-ccx-2.1/ccx_2.1/src/dsort.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dsort.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,327 +0,0 @@ -*DECK DSORT - SUBROUTINE DSORT (DX, IY, N, KFLAG) -c -c slight change: XERMSG was removed; error messages are -c led to the screen -c -C***BEGIN PROLOGUE DSORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2B -C***TYPE DOUBLE PRECISION (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Wisniewski, J. A., (SNLA) -C***ROUTINES CALLED XERMSG -C***DESCRIPTION -C -C DSORT sorts array DX and optionally makes the same interchanges in -C array IY. The array DX may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C DX - array of values to be sorted (usually abscissas) -C IY - array to be (optionally) carried along -C N - number of values in array DX to be sorted -C KFLAG - control parameter -C = 2 means sort DX in increasing order and carry IY along. -C = 1 means sort DX in increasing order (ignoring IY) -C = -1 means sort DX in decreasing order (ignoring IY) -C = -2 means sort DX in decreasing order and carry IY along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***REVISION HISTORY (YYMMDD) -C 761101 DATE WRITTEN -C 761118 Modified to use the Singleton quicksort algorithm. (JAW) -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891024 Changed category. (WRB) -C 891024 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901012 Declared all variables; changed X,Y to DX,IY; changed -C code to parallel SSORT. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE DSORT -C .. Scalar Arguments .. - INTEGER KFLAG, N,IY(*),TY,TTY -C .. Array Arguments .. - DOUBLE PRECISION DX(*) -C .. Local Scalars .. - DOUBLE PRECISION R, T, TT - INTEGER I, IJ, J, K, KK, L, M, NN -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. -c EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT DSORT - NN = N - IF (NN .LT. 1) THEN - write(*,*) '*ERROR in dsort: the number of values to be' - write(*,*) ' sorted is not positive' - stop - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN - write(*,*) '*ERROR in dsort: the sort control parameter is' - write(*,*) ' not 2, 1, -1 or -2' - stop - ENDIF -C -C Alter array DX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - DX(I) = -DX(I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort DX only -C - M = 1 - I = 1 - J = NN - R = 0.375D0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437D0) THEN - R = R+3.90625D-2 - ELSE - R = R-0.21875D0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = DX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (DX(I) .GT. T) THEN - DX(IJ) = DX(I) - DX(I) = T - T = DX(IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (DX(J) .LT. T) THEN - DX(IJ) = DX(J) - DX(J) = T - T = DX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (DX(I) .GT. T) THEN - DX(IJ) = DX(I) - DX(I) = T - T = DX(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (DX(L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (DX(K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = DX(L) - DX(L) = DX(K) - DX(K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = DX(I+1) - IF (DX(I) .LE. T) GO TO 80 - K = I -C - 90 DX(K+1) = DX(K) - K = K-1 - IF (T .LT. DX(K)) GO TO 90 - DX(K+1) = T - GO TO 80 -C -C Sort DX and carry IY along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375D0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437D0) THEN - R = R+3.90625D-2 - ELSE - R = R-0.21875D0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = DX(IJ) - TY = IY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (DX(I) .GT. T) THEN - DX(IJ) = DX(I) - DX(I) = T - T = DX(IJ) - IY(IJ) = IY(I) - IY(I) = TY - TY = IY(IJ) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (DX(J) .LT. T) THEN - DX(IJ) = DX(J) - DX(J) = T - T = DX(IJ) - IY(IJ) = IY(J) - IY(J) = TY - TY = IY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (DX(I) .GT. T) THEN - DX(IJ) = DX(I) - DX(I) = T - T = DX(IJ) - IY(IJ) = IY(I) - IY(I) = TY - TY = IY(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (DX(L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (DX(K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = DX(L) - DX(L) = DX(K) - DX(K) = TT - TTY = IY(L) - IY(L) = IY(K) - IY(K) = TTY - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = DX(I+1) - TY = IY(I+1) - IF (DX(I) .LE. T) GO TO 170 - K = I -C - 180 DX(K+1) = DX(K) - IY(K+1) = IY(K) - K = K-1 - IF (T .LT. DX(K)) GO TO 180 - DX(K+1) = T - IY(K+1) = TY - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - DX(I) = -DX(I) - 200 CONTINUE - ENDIF - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/dsptri.f calculix-ccx-2.3/ccx_2.1/src/dsptri.f --- calculix-ccx-2.1/ccx_2.1/src/dsptri.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dsptri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1454 +0,0 @@ - SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AP( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DSPTRI computes the inverse of a real symmetric indefinite matrix -* A in packed storage using the factorization A = U*D*U**T or -* A = L*D*L**T computed by DSPTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the details of the factorization are stored -* as an upper or lower triangular matrix. -* = 'U': Upper triangular, form is A = U*D*U**T; -* = 'L': Lower triangular, form is A = L*D*L**T. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) -* On entry, the block diagonal matrix D and the multipliers -* used to obtain the factor U or L as computed by DSPTRF, -* stored as a packed triangular matrix. -* -* On exit, if INFO = 0, the (symmetric) inverse of the original -* matrix, stored as a packed triangular matrix. The j-th column -* of inv(A) is stored in the array AP as follows: -* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; -* if UPLO = 'L', -* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. -* -* IPIV (input) INTEGER array, dimension (N) -* Details of the interchanges and the block structure of D -* as determined by DSPTRF. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its -* inverse could not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP - DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DSPMV, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSPTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check that the diagonal matrix D is nonsingular. -* - IF( UPPER ) THEN -* -* Upper triangular storage: examine D from bottom to top -* - KP = N*( N+1 ) / 2 - DO 10 INFO = N, 1, -1 - IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) - $ RETURN - KP = KP - INFO - 10 CONTINUE - ELSE -* -* Lower triangular storage: examine D from top to bottom. -* - KP = 1 - DO 20 INFO = 1, N - IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) - $ RETURN - KP = KP + N - INFO + 1 - 20 CONTINUE - END IF - INFO = 0 -* - IF( UPPER ) THEN -* -* Compute inv(A) from the factorization A = U*D*U'. -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2, depending on the size of the diagonal blocks. -* - K = 1 - KC = 1 - 30 CONTINUE -* -* If K > N, exit from loop. -* - IF( K.GT.N ) - $ GO TO 50 -* - KCNEXT = KC + K - IF( IPIV( K ).GT.0 ) THEN -* -* 1 x 1 diagonal block -* -* Invert the diagonal block. -* - AP( KC+K-1 ) = ONE / AP( KC+K-1 ) -* -* Compute column K of the inverse. -* - IF( K.GT.1 ) THEN - CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 ) - CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), - $ 1 ) - AP( KC+K-1 ) = AP( KC+K-1 ) - - $ DDOT( K-1, WORK, 1, AP( KC ), 1 ) - END IF - KSTEP = 1 - ELSE -* -* 2 x 2 diagonal block -* -* Invert the diagonal block. -* - T = ABS( AP( KCNEXT+K-1 ) ) - AK = AP( KC+K-1 ) / T - AKP1 = AP( KCNEXT+K ) / T - AKKP1 = AP( KCNEXT+K-1 ) / T - D = T*( AK*AKP1-ONE ) - AP( KC+K-1 ) = AKP1 / D - AP( KCNEXT+K ) = AK / D - AP( KCNEXT+K-1 ) = -AKKP1 / D -* -* Compute columns K and K+1 of the inverse. -* - IF( K.GT.1 ) THEN - CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 ) - CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), - $ 1 ) - AP( KC+K-1 ) = AP( KC+K-1 ) - - $ DDOT( K-1, WORK, 1, AP( KC ), 1 ) - AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) - - $ DDOT( K-1, AP( KC ), 1, AP( KCNEXT ), - $ 1 ) - CALL DCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 ) - CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, - $ AP( KCNEXT ), 1 ) - AP( KCNEXT+K ) = AP( KCNEXT+K ) - - $ DDOT( K-1, WORK, 1, AP( KCNEXT ), 1 ) - END IF - KSTEP = 2 - KCNEXT = KCNEXT + K + 1 - END IF -* - KP = ABS( IPIV( K ) ) - IF( KP.NE.K ) THEN -* -* Interchange rows and columns K and KP in the leading -* submatrix A(1:k+1,1:k+1) -* - KPC = ( KP-1 )*KP / 2 + 1 - CALL DSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 ) - KX = KPC + KP - 1 - DO 40 J = KP + 1, K - 1 - KX = KX + J - 1 - TEMP = AP( KC+J-1 ) - AP( KC+J-1 ) = AP( KX ) - AP( KX ) = TEMP - 40 CONTINUE - TEMP = AP( KC+K-1 ) - AP( KC+K-1 ) = AP( KPC+KP-1 ) - AP( KPC+KP-1 ) = TEMP - IF( KSTEP.EQ.2 ) THEN - TEMP = AP( KC+K+K-1 ) - AP( KC+K+K-1 ) = AP( KC+K+KP-1 ) - AP( KC+K+KP-1 ) = TEMP - END IF - END IF -* - K = K + KSTEP - KC = KCNEXT - GO TO 30 - 50 CONTINUE -* - ELSE -* -* Compute inv(A) from the factorization A = L*D*L'. -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2, depending on the size of the diagonal blocks. -* - NPP = N*( N+1 ) / 2 - K = N - KC = NPP - 60 CONTINUE -* -* If K < 1, exit from loop. -* - IF( K.LT.1 ) - $ GO TO 80 -* - KCNEXT = KC - ( N-K+2 ) - IF( IPIV( K ).GT.0 ) THEN -* -* 1 x 1 diagonal block -* -* Invert the diagonal block. -* - AP( KC ) = ONE / AP( KC ) -* -* Compute column K of the inverse. -* - IF( K.LT.N ) THEN - CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 ) - CALL DSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1, - $ ZERO, AP( KC+1 ), 1 ) - AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 ) - END IF - KSTEP = 1 - ELSE -* -* 2 x 2 diagonal block -* -* Invert the diagonal block. -* - T = ABS( AP( KCNEXT+1 ) ) - AK = AP( KCNEXT ) / T - AKP1 = AP( KC ) / T - AKKP1 = AP( KCNEXT+1 ) / T - D = T*( AK*AKP1-ONE ) - AP( KCNEXT ) = AKP1 / D - AP( KC ) = AK / D - AP( KCNEXT+1 ) = -AKKP1 / D -* -* Compute columns K-1 and K of the inverse. -* - IF( K.LT.N ) THEN - CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 ) - CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, - $ ZERO, AP( KC+1 ), 1 ) - AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 ) - AP( KCNEXT+1 ) = AP( KCNEXT+1 ) - - $ DDOT( N-K, AP( KC+1 ), 1, - $ AP( KCNEXT+2 ), 1 ) - CALL DCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 ) - CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, - $ ZERO, AP( KCNEXT+2 ), 1 ) - AP( KCNEXT ) = AP( KCNEXT ) - - $ DDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 ) - END IF - KSTEP = 2 - KCNEXT = KCNEXT - ( N-K+3 ) - END IF -* - KP = ABS( IPIV( K ) ) - IF( KP.NE.K ) THEN -* -* Interchange rows and columns K and KP in the trailing -* submatrix A(k-1:n,k-1:n) -* - KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1 - IF( KP.LT.N ) - $ CALL DSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 ) - KX = KC + KP - K - DO 70 J = K + 1, KP - 1 - KX = KX + N - J + 1 - TEMP = AP( KC+J-K ) - AP( KC+J-K ) = AP( KX ) - AP( KX ) = TEMP - 70 CONTINUE - TEMP = AP( KC ) - AP( KC ) = AP( KPC ) - AP( KPC ) = TEMP - IF( KSTEP.EQ.2 ) THEN - TEMP = AP( KC-N+K-1 ) - AP( KC-N+K-1 ) = AP( KC-N+KP-1 ) - AP( KC-N+KP-1 ) = TEMP - END IF - END IF -* - K = K - KSTEP - KC = KCNEXT - GO TO 60 - 80 CONTINUE - END IF -* - RETURN -* -* End of DSPTRI -* - END - SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) -* -* -- LAPACK routine (version 3.2) -- -* -- LAPACK is a software package provided by Univ. of Tennessee, -- -* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2006 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AP( * ) -* .. -* -* Purpose -* ======= -* -* DSPTRF computes the factorization of a real symmetric matrix A stored -* in packed format using the Bunch-Kaufman diagonal pivoting method: -* -* A = U*D*U**T or A = L*D*L**T -* -* where U (or L) is a product of permutation and unit upper (lower) -* triangular matrices, and D is symmetric and block diagonal with -* 1-by-1 and 2-by-2 diagonal blocks. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) -* On entry, the upper or lower triangle of the symmetric matrix -* A, packed columnwise in a linear array. The j-th column of A -* is stored in the array AP as follows: -* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; -* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. -* -* On exit, the block diagonal matrix D and the multipliers used -* to obtain the factor U or L, stored as a packed triangular -* matrix overwriting A (see below for further details). -* -* IPIV (output) INTEGER array, dimension (N) -* Details of the interchanges and the block structure of D. -* If IPIV(k) > 0, then rows and columns k and IPIV(k) were -* interchanged and D(k,k) is a 1-by-1 diagonal block. -* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and -* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) -* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = -* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were -* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, D(i,i) is exactly zero. The factorization -* has been completed, but the block diagonal matrix D is -* exactly singular, and division by zero will occur if it -* is used to solve a system of equations. -* -* Further Details -* =============== -* -* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services -* Company -* -* If UPLO = 'U', then A = U*D*U', where -* U = P(n)*U(n)* ... *P(k)U(k)* ..., -* i.e., U is a product of terms P(k)*U(k), where k decreases from n to -* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I v 0 ) k-s -* U(k) = ( 0 I 0 ) s -* ( 0 0 I ) n-k -* k-s s n-k -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). -* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), -* and A(k,k), and v overwrites A(1:k-2,k-1:k). -* -* If UPLO = 'L', then A = L*D*L', where -* L = P(1)*L(1)* ... *P(k)*L(k)* ..., -* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to -* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 -* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as -* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such -* that if the diagonal block D(k) is of order s (s = 1 or 2), then -* -* ( I 0 0 ) k-1 -* L(k) = ( 0 I 0 ) s -* ( 0 v I ) n-k-s+1 -* k-1 s n-k-s+1 -* -* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). -* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), -* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - DOUBLE PRECISION EIGHT, SEVTEN - PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, - $ KSTEP, KX, NPP - DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, - $ ROWMAX, T, WK, WKM1, WKP1 -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - EXTERNAL LSAME, IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DSPR, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DSPTRF', -INFO ) - RETURN - END IF -* -* Initialize ALPHA for use in choosing pivot block size. -* - ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT -* - IF( UPPER ) THEN -* -* Factorize A as U*D*U' using the upper triangle of A -* -* K is the main loop index, decreasing from N to 1 in steps of -* 1 or 2 -* - K = N - KC = ( N-1 )*N / 2 + 1 - 10 CONTINUE - KNC = KC -* -* If K < 1, exit from loop -* - IF( K.LT.1 ) - $ GO TO 110 - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( AP( KC+K-1 ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.GT.1 ) THEN - IMAX = IDAMAX( K-1, AP( KC ), 1 ) - COLMAX = ABS( AP( KC+IMAX-1 ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN -* -* Column K is zero: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - ROWMAX = ZERO - JMAX = IMAX - KX = IMAX*( IMAX+1 ) / 2 + IMAX - DO 20 J = IMAX + 1, K - IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN - ROWMAX = ABS( AP( KX ) ) - JMAX = J - END IF - KX = KX + J - 20 CONTINUE - KPC = ( IMAX-1 )*IMAX / 2 + 1 - IF( IMAX.GT.1 ) THEN - JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX - ELSE -* -* interchange rows and columns K-1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K - KSTEP + 1 - IF( KSTEP.EQ.2 ) - $ KNC = KNC - K + 1 - IF( KP.NE.KK ) THEN -* -* Interchange rows and columns KK and KP in the leading -* submatrix A(1:k,1:k) -* - CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) - KX = KPC + KP - 1 - DO 30 J = KP + 1, KK - 1 - KX = KX + J - 1 - T = AP( KNC+J-1 ) - AP( KNC+J-1 ) = AP( KX ) - AP( KX ) = T - 30 CONTINUE - T = AP( KNC+KK-1 ) - AP( KNC+KK-1 ) = AP( KPC+KP-1 ) - AP( KPC+KP-1 ) = T - IF( KSTEP.EQ.2 ) THEN - T = AP( KC+K-2 ) - AP( KC+K-2 ) = AP( KC+KP-1 ) - AP( KC+KP-1 ) = T - END IF - END IF -* -* Update the leading submatrix -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column k now holds -* -* W(k) = U(k)*D(k) -* -* where U(k) is the k-th column of U -* -* Perform a rank-1 update of A(1:k-1,1:k-1) as -* -* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' -* - R1 = ONE / AP( KC+K-1 ) - CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) -* -* Store U(k) in column k -* - CALL DSCAL( K-1, R1, AP( KC ), 1 ) - ELSE -* -* 2-by-2 pivot block D(k): columns k and k-1 now hold -* -* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) -* -* where U(k) and U(k-1) are the k-th and (k-1)-th columns -* of U -* -* Perform a rank-2 update of A(1:k-2,1:k-2) as -* -* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' -* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' -* - IF( K.GT.2 ) THEN -* - D12 = AP( K-1+( K-1 )*K / 2 ) - D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 - D11 = AP( K+( K-1 )*K / 2 ) / D12 - T = ONE / ( D11*D22-ONE ) - D12 = T / D12 -* - DO 50 J = K - 2, 1, -1 - WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- - $ AP( J+( K-1 )*K / 2 ) ) - WK = D12*( D22*AP( J+( K-1 )*K / 2 )- - $ AP( J+( K-2 )*( K-1 ) / 2 ) ) - DO 40 I = J, 1, -1 - AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - - $ AP( I+( K-1 )*K / 2 )*WK - - $ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1 - 40 CONTINUE - AP( J+( K-1 )*K / 2 ) = WK - AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1 - 50 CONTINUE -* - END IF -* - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K-1 ) = -KP - END IF -* -* Decrease K and return to the start of the main loop -* - K = K - KSTEP - KC = KNC - K - GO TO 10 -* - ELSE -* -* Factorize A as L*D*L' using the lower triangle of A -* -* K is the main loop index, increasing from 1 to N in steps of -* 1 or 2 -* - K = 1 - KC = 1 - NPP = N*( N+1 ) / 2 - 60 CONTINUE - KNC = KC -* -* If K > N, exit from loop -* - IF( K.GT.N ) - $ GO TO 110 - KSTEP = 1 -* -* Determine rows and columns to be interchanged and whether -* a 1-by-1 or 2-by-2 pivot block will be used -* - ABSAKK = ABS( AP( KC ) ) -* -* IMAX is the row-index of the largest off-diagonal element in -* column K, and COLMAX is its absolute value -* - IF( K.LT.N ) THEN - IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 ) - COLMAX = ABS( AP( KC+IMAX-K ) ) - ELSE - COLMAX = ZERO - END IF -* - IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN -* -* Column K is zero: set INFO and continue -* - IF( INFO.EQ.0 ) - $ INFO = K - KP = K - ELSE - IF( ABSAKK.GE.ALPHA*COLMAX ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE -* -* JMAX is the column-index of the largest off-diagonal -* element in row IMAX, and ROWMAX is its absolute value -* - ROWMAX = ZERO - KX = KC + IMAX - K - DO 70 J = K, IMAX - 1 - IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN - ROWMAX = ABS( AP( KX ) ) - JMAX = J - END IF - KX = KX + N - J - 70 CONTINUE - KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 - IF( IMAX.LT.N ) THEN - JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 ) - ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) ) - END IF -* - IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN -* -* no interchange, use 1-by-1 pivot block -* - KP = K - ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN -* -* interchange rows and columns K and IMAX, use 1-by-1 -* pivot block -* - KP = IMAX - ELSE -* -* interchange rows and columns K+1 and IMAX, use 2-by-2 -* pivot block -* - KP = IMAX - KSTEP = 2 - END IF - END IF -* - KK = K + KSTEP - 1 - IF( KSTEP.EQ.2 ) - $ KNC = KNC + N - K + 1 - IF( KP.NE.KK ) THEN -* -* Interchange rows and columns KK and KP in the trailing -* submatrix A(k:n,k:n) -* - IF( KP.LT.N ) - $ CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ), - $ 1 ) - KX = KNC + KP - KK - DO 80 J = KK + 1, KP - 1 - KX = KX + N - J + 1 - T = AP( KNC+J-KK ) - AP( KNC+J-KK ) = AP( KX ) - AP( KX ) = T - 80 CONTINUE - T = AP( KNC ) - AP( KNC ) = AP( KPC ) - AP( KPC ) = T - IF( KSTEP.EQ.2 ) THEN - T = AP( KC+1 ) - AP( KC+1 ) = AP( KC+KP-K ) - AP( KC+KP-K ) = T - END IF - END IF -* -* Update the trailing submatrix -* - IF( KSTEP.EQ.1 ) THEN -* -* 1-by-1 pivot block D(k): column k now holds -* -* W(k) = L(k)*D(k) -* -* where L(k) is the k-th column of L -* - IF( K.LT.N ) THEN -* -* Perform a rank-1 update of A(k+1:n,k+1:n) as -* -* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' -* - R1 = ONE / AP( KC ) - CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1, - $ AP( KC+N-K+1 ) ) -* -* Store L(k) in column K -* - CALL DSCAL( N-K, R1, AP( KC+1 ), 1 ) - END IF - ELSE -* -* 2-by-2 pivot block D(k): columns K and K+1 now hold -* -* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) -* -* where L(k) and L(k+1) are the k-th and (k+1)-th columns -* of L -* - IF( K.LT.N-1 ) THEN -* -* Perform a rank-2 update of A(k+2:n,k+2:n) as -* -* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' -* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' -* - D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) - D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 - D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 - T = ONE / ( D11*D22-ONE ) - D21 = T / D21 -* - DO 100 J = K + 2, N - WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- - $ AP( J+K*( 2*N-K-1 ) / 2 ) ) - WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- - $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) -* - DO 90 I = J, N - AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* - $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / - $ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1 - 90 CONTINUE -* - AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK - AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1 -* - 100 CONTINUE - END IF - END IF - END IF -* -* Store details of the interchanges in IPIV -* - IF( KSTEP.EQ.1 ) THEN - IPIV( K ) = KP - ELSE - IPIV( K ) = -KP - IPIV( K+1 ) = -KP - END IF -* -* Increase K and return to the start of the main loop -* - K = K + KSTEP - KC = KNC + N - K + 2 - GO TO 60 -* - END IF -* - 110 CONTINUE - RETURN -* -* End of DSPTRF -* - END - -* BLAS REQUIRED BY LAPACK ROUTINE: dsptri -* ----------------------------------------------------------- -* Note: Link to BLAS optimized for your system, if available. -* ----------------------------------------------------------- - - subroutine dcopy(n,dx,incx,dy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - 50 continue - return - end - double precision function ddot(n,dx,incx,dy,incy) -c -c forms the dot product of two vectors. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - ddot = 0.0d0 - dtemp = 0.0d0 - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dtemp + dx(ix)*dy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - ddot = dtemp - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dx(i)*dy(i) - 30 continue - if( n .lt. 5 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + - * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) - 50 continue - 60 ddot = dtemp - return - end - SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*AP( KK ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*AP( KK ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPMV . -* - END - -* BLAS REQUIRED BY LAPACK ROUTINE: dsptrf -* ----------------------------------------------------------- -* Note: Link to BLAS optimized for your system, if available. -* ----------------------------------------------------------- - - SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DSPR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR . -* - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/dualshape3tri.f calculix-ccx-2.3/ccx_2.1/src/dualshape3tri.f --- calculix-ccx-2.1/ccx_2.1/src/dualshape3tri.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dualshape3tri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,113 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dualshape3tri(xi,et,xl,xsj,xs,shp,iflag) -! -! shape functions and derivatives for a 3-node linear -! isoparametric triangular element. 0<=xi,et<=1,xi+et<=1 -! -! iflag=2: calculate the value of the shape functions, -! their derivatives w.r.t. the local coordinates -! and the Jacobian vector (local normal to the -! surface) -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian vector (local normal -! to the surface) -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(4,3),xs(3,2),xsi(2,3),xl(0:3,3),sh(3),xsj(3) -! - real*8 xi,et -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=-1.d0 - shp(1,2)=1.d0 - shp(1,3)=0.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=-1.d0 - shp(2,2)=0.d0 - shp(2,3)=1.d0 -! -! standard shape functions -! - shp(3,1)=1.d0-xi-et - shp(3,2)=xi - shp(3,3)=et -! -! Dual shape functions -! - shp(4,1)=3.d0*shp(3,1)-shp(3,2)-shp(3,3) - shp(4,2)=3.d0*shp(3,2)-shp(3,1)-shp(3,3) - shp(4,3)=3.d0*shp(3,3)-shp(3,1)-shp(3,2) -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,3 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian vector -! - xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - if(iflag.eq.2) return -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=xs(2,2)/xsj(3) - xsi(2,1)=-xs(2,1)/xsj(3) - xsi(1,2)=-xs(1,2)/xsj(3) - xsi(2,2)=xs(1,1)/xsj(3) - xsi(1,3)=-xs(2,2)/xsj(1) - xsi(2,3)=xs(2,1)/xsj(1) -! -! computation of the global derivatives of the shape functions -! - do k=1,3 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/dualshape4q.f calculix-ccx-2.3/ccx_2.1/src/dualshape4q.f --- calculix-ccx-2.1/ccx_2.1/src/dualshape4q.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dualshape4q.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,122 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dualshape4q(xi,et,xl,xsj,xs,shp,ns,pslavdual,iflag) -! -! iflag=2: calculate the value of the shape functions, -! their derivatives w.r.t. the local coordinates -! and the Jacobian vector (local normal to the -! surface) -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian vector (local normal -! to the surface) -! - implicit none -! - integer i,j,k,iflag,ns -! - real*8 shp(4,8),xs(3,2),xsi(2,3),xl(3,8),sh(3),xsj(3) -! - real*8 xi,et,pslavdual(16,*) -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=-(1.d0-et)/4.d0 - shp(1,2)=(1.d0-et)/4.d0 - shp(1,3)=(1.d0+et)/4.d0 - shp(1,4)=-(1.d0+et)/4.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=-(1.d0-xi)/4.d0 - shp(2,2)=-(1.d0+xi)/4.d0 - shp(2,3)=(1.d0+xi)/4.d0 - shp(2,4)=(1.d0-xi)/4.d0 -! -! standard shape functions -! - shp(3,1)=(1.d0-xi)*(1.d0-et)/4.d0 - shp(3,2)=(1.d0+xi)*(1.d0-et)/4.d0 - shp(3,3)=(1.d0+xi)*(1.d0+et)/4.d0 - shp(3,4)=(1.d0-xi)*(1.d0+et)/4.d0 -! -! Dual shape functions -! -c shp(4,1)=4.d0*shp(3,1)-2.d0*shp(3,2)+shp(3,3)-2.d0*shp(3,4) -c shp(4,2)=4.d0*shp(3,2)-2.d0*shp(3,1)+shp(3,4)-2.d0*shp(3,3) -c shp(4,3)=4.d0*shp(3,3)-2.d0*shp(3,2)+shp(3,1)-2.d0*shp(3,4) -c shp(4,4)=4.d0*shp(3,4)-2.d0*shp(3,1)+shp(3,2)-2.d0*shp(3,3) -! -! with Mass Matrix pslavdual -! - shp(4,1)=pslavdual(1,ns)*shp(3,1)+pslavdual(2,ns)*shp(3,2)+ - & pslavdual(3,ns)*shp(3,3)+pslavdual(4,ns)*shp(3,4) - shp(4,2)=pslavdual(5,ns)*shp(3,1)+pslavdual(6,ns)*shp(3,2)+ - & pslavdual(7,ns)*shp(3,3)+pslavdual(8,ns)*shp(3,4) - shp(4,3)=pslavdual(9,ns)*shp(3,1)+pslavdual(10,ns)*shp(3,2)+ - & pslavdual(11,ns)*shp(3,3)+pslavdual(12,ns)*shp(3,4) - shp(4,4)=pslavdual(13,ns)*shp(3,1)+pslavdual(14,ns)*shp(3,2)+ - & pslavdual(15,ns)*shp(3,3)+pslavdual(16,ns)*shp(3,4) -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,4 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian vector -! - xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - if(iflag.eq.2) return -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=xs(2,2)/xsj(3) - xsi(2,1)=-xs(2,1)/xsj(3) - xsi(1,2)=-xs(1,2)/xsj(3) - xsi(2,2)=xs(1,1)/xsj(3) - xsi(1,3)=-xs(2,2)/xsj(1) - xsi(2,3)=xs(2,1)/xsj(1) -! -! computation of the global derivatives of the shape functions -! - do k=1,4 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/dualshape6tri.f calculix-ccx-2.3/ccx_2.1/src/dualshape6tri.f --- calculix-ccx-2.1/ccx_2.1/src/dualshape6tri.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dualshape6tri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,119 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dualshape6tri(xi,et,xl,xsj,xs,shp,iflag) -! -! iflag=2: calculate the value of the shape functions, -! their derivatives w.r.t. the local coordinates -! and the Jacobian vector (local normal to the -! surface) -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian vector (local normal -! to the surface) -! -! shape functions and derivatives for a 6-node quadratic -! isoparametric triangular element. 0<=xi,et<=1,xi+et<=1 -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(4,6),xs(3,2),xsi(2,3),xl(0:3,6),sh(3),xsj(3) -! - real*8 xi,et -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=4.d0*(xi+et)-3.d0 - shp(1,2)=4.d0*xi-1.d0 - shp(1,3)=0.d0 - shp(1,4)=4.d0*(1.d0-2.d0*xi-et) - shp(1,5)=4.d0*et - shp(1,6)=-4.d0*et -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=4.d0*(xi+et)-3.d0 - shp(2,2)=0.d0 - shp(2,3)=4.d0*et-1.d0 - shp(2,4)=-4.d0*xi - shp(2,5)=4.d0*xi - shp(2,6)=4.d0*(1.d0-xi-2.d0*et) -! -! standard shape functions -! - shp(3,1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et) - shp(3,2)=xi*(2.d0*xi-1.d0) - shp(3,3)=et*(2.d0*et-1.d0) - shp(3,4)=4.d0*xi*(1.d0-xi-et) - shp(3,5)=4.d0*xi*et - shp(3,6)=4.d0*et*(1.d0-xi-et) -! -! Dual shape functions -! - shp(4,1)=shp(3,1)+(shp(3,4)+shp(3,6))/12.d0 - shp(4,2)=shp(3,2)+(shp(3,4)+shp(3,5))/12.d0 - shp(4,3)=shp(3,3)+(shp(3,5)+shp(3,6))/12.d0 -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,6 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian vector -! - xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - if(iflag.eq.2) return -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=xs(2,2)/xsj(3) - xsi(2,1)=-xs(2,1)/xsj(3) - xsi(1,2)=-xs(1,2)/xsj(3) - xsi(2,2)=xs(1,1)/xsj(3) - xsi(1,3)=-xs(2,2)/xsj(1) - xsi(2,3)=xs(2,1)/xsj(1) -! -! computation of the global derivatives of the shape functions -! - do k=1,6 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/dualshape8q.f calculix-ccx-2.3/ccx_2.1/src/dualshape8q.f --- calculix-ccx-2.1/ccx_2.1/src/dualshape8q.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dualshape8q.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,161 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine dualshape8q(xi,et,xl,xsj,xs,shp,iflag) -! -! shape functions and derivatives for a 8-node quadratic -! isoparametric quadrilateral element. -1<=xi,et<=1 -! -! iflag=2: calculate the value of the shape functions, -! their derivatives w.r.t. the local coordinates -! and the Jacobian vector (local normal to the -! surface) -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian vector (local normal -! to the surface) -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(4,8),xs(3,2),xsi(2,3),xl(0:3,8),sh(3),xsj(3) -! - real*8 xi,et -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=(1.d0-et)*(2.d0*xi+et)/4.d0 - shp(1,2)=(1.d0-et)*(2.d0*xi-et)/4.d0 - shp(1,3)=(1.d0+et)*(2.d0*xi+et)/4.d0 - shp(1,4)=(1.d0+et)*(2.d0*xi-et)/4.d0 - shp(1,5)=-xi*(1.d0-et) - shp(1,6)=(1.d0-et*et)/2.d0 - shp(1,7)=-xi*(1.d0+et) - shp(1,8)=-(1.d0-et*et)/2.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=(1.d0-xi)*(2.d0*et+xi)/4.d0 - shp(2,2)=(1.d0+xi)*(2.d0*et-xi)/4.d0 - shp(2,3)=(1.d0+xi)*(2.d0*et+xi)/4.d0 - shp(2,4)=(1.d0-xi)*(2.d0*et-xi)/4.d0 - shp(2,5)=-(1.d0-xi*xi)/2.d0 - shp(2,6)=-et*(1.d0+xi) - shp(2,7)=(1.d0-xi*xi)/2.d0 - shp(2,8)=-et*(1.d0-xi) -! -! standard shape functions -! - shp(3,1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0 - shp(3,2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0 - shp(3,3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0 - shp(3,4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0 - shp(3,5)=(1.d0-xi*xi)*(1.d0-et)/2.d0 - shp(3,6)=(1.d0+xi)*(1.d0-et*et)/2.d0 - shp(3,7)=(1.d0-xi*xi)*(1.d0+et)/2.d0 - shp(3,8)=(1.d0-xi)*(1.d0-et*et)/2.d0 -! -! Dual shape functions -! - shp(4,1)=shp(3,1)+(shp(3,5)+shp(3,8))/5.d0 - shp(4,2)=shp(3,2)+(shp(3,5)+shp(3,6))/5.d0 - shp(4,3)=shp(3,3)+(shp(3,6)+shp(3,7))/5.d0 - shp(4,4)=shp(3,4)+(shp(3,7)+shp(3,8))/5.d0 -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,8 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian vector -! - xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - if(iflag.eq.2) return -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! -c xsi(1,1)=xs(2,2)/xsj(3) -c xsi(2,1)=-xs(2,1)/xsj(3) -c xsi(1,2)=-xs(1,2)/xsj(3) -c xsi(2,2)=xs(1,1)/xsj(3) -c xsi(1,3)=-xs(2,2)/xsj(1) -c xsi(2,3)=xs(2,1)/xsj(1) - if(dabs(xsj(3)).gt.1.d-10) then - xsi(1,1)=xs(2,2)/xsj(3) - xsi(2,2)=xs(1,1)/xsj(3) - xsi(1,2)=-xs(1,2)/xsj(3) - xsi(2,1)=-xs(2,1)/xsj(3) - if(dabs(xsj(2)).gt.1.d-10) then - xsi(2,3)=xs(1,1)/xsj(2) - xsi(1,3)=-xs(1,2)/xsj(2) - elseif(dabs(xsj(1)).gt.1.d-10) then - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - else - xsi(2,3)=0.d0 - xsi(1,3)=0.d0 - endif - elseif(dabs(xsj(2)).gt.1.d-10) then - xsi(1,1)=xs(3,2)/xsj(2) - xsi(2,3)=xs(1,1)/xsj(2) - xsi(1,3)=-xs(1,2)/xsj(2) - xsi(2,1)=-xs(3,1)/xsj(2) - if(dabs(xsj(1)).gt.1.d-10) then - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - else - xsi(1,2)=0.d0 - xsi(2,2)=0.d0 - endif - else - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - xsi(1,1)=0.d0 - xsi(2,1)=0.d0 - endif -! -! computation of the global derivatives of the shape functions -! - do k=1,8 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/dyna.c calculix-ccx-2.3/ccx_2.1/src/dyna.c --- calculix-ccx-2.1/ccx_2.1/src/dyna.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dyna.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1728 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif -#ifdef PARDISO - #include "pardiso.h" -#endif - -void dyna(double **cop, int *nk, int **konp, int **ipkonp, char **lakonp, int *ne, - int **nodebounp, int **ndirbounp, double **xbounp, int *nboun, - int **ipompcp, int **nodempcp, double **coefmpcp, char **labmpcp, - int *nmpc, int *nodeforc,int *ndirforc,double *xforc, - int *nforc,int *nelemload, char *sideload,double *xload, - int *nload, - int **nactdofp,int *neq, int *nzl,int *icol, int *irow, - int *nmethod, int **ikmpcp, int **ilmpcp, int **ikbounp, - int **ilbounp,double *elcon, int *nelcon, double *rhcon, - int *nrhcon,double *cocon, int *ncocon, - double *alcon, int *nalcon, double *alzero, - int **ielmatp,int **ielorienp, int *norien, double *orab, - int *ntmat_,double **t0p, - double **t1p,int *ithermal,double *prestr, int *iprestr, - double **voldp,int *iperturb, double **stip, int *nzs, - double *tinc, double *tper, double *xmodal, - double **veoldp, char *amname, double *amta, - int *namta, int *nam, int *iamforc, int *iamload, - int **iamt1p,int *jout, - int *kode, char *filab,double **emep, double *xforcold, - double *xloadold, - double **t1oldp, int **iambounp, double **xbounoldp, int *iexpl, - double *plicon, int *nplicon, double *plkcon,int *nplkcon, - double *xstate, int *npmat_, char *matname, int *mi, - int *ncmat_, int *nstate_, double **enerp, char *jobnamec, - double *ttime, char *set, int *nset, int *istartset, - int *iendset, int **ialsetp, int *nprint, char *prlab, - char *prset, int *nener, double *trab, - int **inotrp, int *ntrans, double **fmpcp, char *cbody, int *ibody, - double *xbody, int *nbody, double *xbodyold, int *istep, - int *isolver,int *jq, char *output, int *mcs, int *nkon, - int *mpcend, int *ics, double *cs, int *ntie, char *tieset, - int *idrct, int *jmax, double *tmin, double *tmax, - double *ctrl, int *itpamp, double *tietol,int *nalset, - int **nnnp){ - - char fneig[132]="",description[13]=" ",*lakon=NULL,*labmpc=NULL, - *labmpcold=NULL,lakonl[9]=" \0",*tchar1=NULL,*tchar2=NULL,*tchar3; - - int nev,i,j,k,idof,*inum=NULL,*ipobody=NULL,inewton=0, - iinc=0,jprint=0,l,iout,ielas,icmd,iprescribedboundary,init,ifreebody, - mode=-1,noddiam=-1,*kon=NULL,*ipkon=NULL,*ielmat=NULL,*ielorien=NULL, - *inotr=NULL,*nodeboun=NULL,*ndirboun=NULL,*iamboun=NULL,*ikboun=NULL, - *ilboun=NULL,*nactdof=NULL,*ipompc=NULL,*nodempc=NULL,*ikmpc=NULL, - *ilmpc=NULL,nsectors,nmpcold,mpcendold,*ipompcold=NULL,*nodempcold=NULL, - *ikmpcold=NULL,*ilmpcold=NULL,kflag=2,nmd,nevd,*nm=NULL,*iamt1=NULL, - *itg=NULL,ntg=0,symmetryflag=0,inputformat=0,dashpot,lrw,liw,iddebdf=0, - *iwork=NULL,ngraph=1,nkg,neg,ncont,ncone,ne0,nkon0, *itietri=NULL, - *koncont=NULL,konl[20],imat,nope,kodem,indexe,j1,jdof, - *ipneigh=NULL,*neigh=NULL,niter,inext,itp=0,icutb=0, - ismallsliding=0,isteadystate,*ifcont1=NULL,*ifcont2=NULL,mpcfree, - memmpc_,imax,iener=0,*icole=NULL,*irowe=NULL,*jqe=NULL,nzse[3], - nalset_=*nalset,*ialset=*ialsetp,*istartset_=NULL,*iendset_=NULL, - *itiefac=NULL,*islavsurf=NULL,*islavnode=NULL,mt=mi[1]+1, - *imastnode=NULL,*nslavnode=NULL,*nmastnode=NULL,mortar=0,*imastop=NULL, - *iponoels=NULL,*inoels=NULL,*nnn=*nnnp,*imddof=NULL,nmddof,nrset, - *ikactcont=NULL,nactcont,nactcont_=100,*ikactmech=NULL,nactmech, - icorrect=0,*ipe=NULL,*ime=NULL,iprev=1,inonlinmpc=0, - *imdnode=NULL,nmdnode,nksector,*imdboun=NULL,nmdboun,*imdmpc=NULL, - nmdmpc,intpointvar,kmin,kmax,i1,ifricdamp=0; - - long long i2; - - double *d=NULL, *z=NULL, *b=NULL, *zeta=NULL,*stiini=NULL, - *cd=NULL, *cv=NULL, *xforcact=NULL, *xloadact=NULL,*cc=NULL, - *t1act=NULL, *ampli=NULL, *aa=NULL, *bb=NULL, *aanew=NULL, *bj=NULL, - *v=NULL,*aamech=NULL,*aafric=NULL,*bfric=NULL, - *stn=NULL, *stx=NULL, *een=NULL, *adb=NULL,*xstiff=NULL,*bjp=NULL, - *aub=NULL, *temp_array1=NULL, *temp_array2=NULL, *aux=NULL, - *f=NULL, *fn=NULL, *xbounact=NULL,*epn=NULL,*xstateini=NULL, - *enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL,*qfn=NULL, - *qfx=NULL, *xbodyact=NULL, *cgr=NULL, *au=NULL, *vbounact=NULL, - *abounact=NULL,dtime,reltime,*t0=NULL,*t1=NULL,*t1old=NULL, - physcon[1],zetaj,dj,ddj,h1,h2,h3,h4,h5,h6,sum,aai,bbi,tstart,tend, - qa[3],cam[5],accold[1],bet,gam,*ad=NULL,sigma=0.,alpham,betam, - *bact=NULL,*bmin=NULL,*co=NULL,*xboun=NULL,*xbounold=NULL,*vold=NULL, - *eme=NULL,*ener=NULL,*coefmpc=NULL,*fmpc=NULL,*coefmpcold,*veold=NULL, - *xini=NULL,*rwork=NULL,*adc=NULL,*auc=NULL,*zc=NULL, *rpar=NULL, - *cg=NULL,*straight=NULL,xl[27],voldl[mt*9],elas[21],fnl[27],t0l,t1l, - elconloc[21],veoldl[mt*9],setnull,deltmx,bbmax,dd,dtheta,dthetaref, - theta,*vini=NULL,dthetaold,*bcont=NULL,*vr=NULL,*vi=NULL,*bcontini=NULL, - *stnr=NULL,*stni=NULL,*vmax=NULL,*stnmax=NULL,precision,resultmaxprev, - resultmax,func,funcp,fexp,fexm,fcos,fsin,sump,*bp=NULL,h14,senergy=0.0, - *bv=NULL,*cstr=NULL,*aube=NULL,*adbe=NULL,*sti=*stip,time0=0.0, - time=0.0,*xforcdiff=NULL,*xloaddiff=NULL,*xbodydiff=NULL,*t1diff=NULL, - *xboundiff=NULL,*bprev=NULL,*bdiff=NULL,damp,um; - - FILE *f1; - - /* dummy variables for nonlinmpc */ - - int *iaux=NULL,maxlenmpc,icascade=0,newstep=0,iit=1,idiscon; - -#ifdef SGI - int token; -#endif - - /* if icorrect=0: aamech is modified by the present incremental - contribution of b - icorrect=1: aamech is modified by the present and the - last incremental contribution of b - icorrect=2: aamech is determined by the present - contribution of b */ - - co=*cop;kon=*konp;ipkon=*ipkonp;lakon=*lakonp;ielmat=*ielmatp; - ielorien=*ielorienp;inotr=*inotrp;nodeboun=*nodebounp; - ndirboun=*ndirbounp;iamboun=*iambounp;xboun=*xbounp; - xbounold=*xbounoldp;ikboun=*ikbounp;ilboun=*ilbounp;nactdof=*nactdofp; - vold=*voldp;eme=*emep;ener=*enerp;ipompc=*ipompcp;nodempc=*nodempcp; - coefmpc=*coefmpcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; - fmpc=*fmpcp;veold=*veoldp;iamt1=*iamt1p;t0=*t0p;t1=*t1p;t1old=*t1oldp; - - if(ithermal[0]<=1){ - kmin=1;kmax=3; - }else if(ithermal[0]==2){ - kmin=0;kmax=mi[1];if(kmax>2)kmax=2; - }else{ - kmin=0;kmax=3; - } - - xstiff=NNEW(double,27*mi[0]**ne); - - dtime=*tinc; - - alpham=xmodal[0]; - betam=xmodal[1]; - - dd=ctrl[16];deltmx=ctrl[26];nrset=(int)xmodal[9]; - - /* determining nzl */ - - *nzl=0; - for(i=neq[1];i>0;i--){ - if(icol[i-1]>0){ - *nzl=i; - break; - } - } - - /* reading the eigenvalue and eigenmode information */ - - strcpy(fneig,jobnamec); - strcat(fneig,".eig"); - - if((f1=fopen(fneig,"rb"))==NULL){ - printf("*ERROR: cannot open eigenvalue file for reading..."); - exit(0); - } - nsectors=1; - - if(*mcs==0){ - - nkg=*nk; - neg=*ne; - - if(fread(&nev,sizeof(int),1,f1)!=1){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - d=NNEW(double,nev); - - if(fread(d,sizeof(double),nev,f1)!=nev){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - ad=NNEW(double,neq[1]); - adb=NNEW(double,neq[1]); - au=NNEW(double,nzs[2]); - aub=NNEW(double,nzs[1]); - - if(fread(ad,sizeof(double),neq[1],f1)!=neq[1]){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - if(fread(au,sizeof(double),nzs[2],f1)!=nzs[2]){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - if(fread(adb,sizeof(double),neq[1],f1)!=neq[1]){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - if(fread(aub,sizeof(double),nzs[1],f1)!=nzs[1]){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - z=NNEW(double,neq[1]*nev); - - if(fread(z,sizeof(double),neq[1]*nev,f1)!=neq[1]*nev){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - } - else{ - nev=0; - do{ - if(fread(&nmd,sizeof(int),1,f1)!=1){ - break; - } - if(fread(&nevd,sizeof(int),1,f1)!=1){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - if(nev==0){ - d=NNEW(double,nevd); - nm=NNEW(int,nevd); - }else{ - RENEW(d,double,nev+nevd); - RENEW(nm,int,nev+nevd); - } - - if(fread(&d[nev],sizeof(double),nevd,f1)!=nevd){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - for(i=nev;insectors) nsectors=cs[17*i]; - } - - /* determining the maximum number of sectors to be plotted */ - - for(j=0;j<*mcs;j++){ - if(cs[17*j+4]>ngraph) ngraph=cs[17*j+4]; - } - nkg=*nk*ngraph; - neg=*ne*ngraph; - /* allocating field for the expanded structure */ - - RENEW(co,double,3**nk*nsectors); - if(*ithermal!=0){ - RENEW(t0,double,*nk*nsectors); - RENEW(t1old,double,*nk*nsectors); - RENEW(t1,double,*nk*nsectors); - if(*nam>0) RENEW(iamt1,int,*nk*nsectors); - } - RENEW(nactdof,int,mt**nk*nsectors); - if(*ntrans>0) RENEW(inotr,int,2**nk*nsectors); - RENEW(kon,int,*nkon*nsectors); - RENEW(ipkon,int,*ne*nsectors); - RENEW(lakon,char,8**ne*nsectors); - RENEW(ielmat,int,*ne*nsectors); - if(*norien>0) RENEW(ielorien,int,*ne*nsectors); - RENEW(z,double,(long long)neq[1]*nev*nsectors/2); - - RENEW(nodeboun,int,*nboun*nsectors); - RENEW(ndirboun,int,*nboun*nsectors); - if(*nam>0) RENEW(iamboun,int,*nboun*nsectors); - RENEW(xboun,double,*nboun*nsectors); - RENEW(xbounold,double,*nboun*nsectors); - RENEW(ikboun,int,*nboun*nsectors); - RENEW(ilboun,int,*nboun*nsectors); - - ipompcold=NNEW(int,*nmpc); - nodempcold=NNEW(int,3**mpcend); - coefmpcold=NNEW(double,*mpcend); - labmpcold=NNEW(char,20**nmpc); - ikmpcold=NNEW(int,*nmpc); - ilmpcold=NNEW(int,*nmpc); - - for(i=0;i<*nmpc;i++){ipompcold[i]=ipompc[i];} - for(i=0;i<3**mpcend;i++){nodempcold[i]=nodempc[i];} - for(i=0;i<*mpcend;i++){coefmpcold[i]=coefmpc[i];} - for(i=0;i<20**nmpc;i++){labmpcold[i]=labmpc[i];} - for(i=0;i<*nmpc;i++){ikmpcold[i]=ikmpc[i];} - for(i=0;i<*nmpc;i++){ilmpcold[i]=ilmpc[i];} - nmpcold=*nmpc; - mpcendold=*mpcend; - - RENEW(ipompc,int,*nmpc*nsectors); - RENEW(nodempc,int,3**mpcend*nsectors); - RENEW(coefmpc,double,*mpcend*nsectors); - RENEW(labmpc,char,20**nmpc*nsectors+1); - RENEW(ikmpc,int,*nmpc*nsectors); - RENEW(ilmpc,int,*nmpc*nsectors); - RENEW(fmpc,double,*nmpc*nsectors); - - /* determining the space needed to expand the - contact surfaces */ - - tchar1=NNEW(char,81); - tchar2=NNEW(char,81); - tchar3=NNEW(char,81); - for(i=0; i<*ntie; i++){ - if(tieset[i*(81*3)+80]=='C'){ - //a contact constrain was found, so increase nalset - memcpy(tchar2,&tieset[i*(81*3)+81],81); - tchar2[80]='\0'; - memcpy(tchar3,&tieset[i*(81*3)+81+81],81); - tchar3[80]='\0'; - for(j=0; j<*nset; j++){ - memcpy(tchar1,&set[j*81],81); - tchar1[80]='\0'; - if(strcmp(tchar1,tchar2)==0){ - //dependent nodal surface was found - (*nalset)+=(iendset[j]-istartset[j]+1)*(nsectors); - } - else if(strcmp(tchar1,tchar3)==0){ - //independent element face surface was found - (*nalset)+=(iendset[j]-istartset[j]+1)*(nsectors); - } - } - } - } - free(tchar1); - free(tchar2); - free(tchar3); - - RENEW(ialset,int,*nalset); - - /* save the information in istarset and isendset */ - istartset_=NNEW(int,*nset); - iendset_=NNEW(int,*nset); - for(j=0; j<*nset; j++){ - istartset_[j]=istartset[j]; - iendset_[j]=iendset[j]; - } - - RENEW(xstiff,double,27*mi[0]**ne*nsectors); - - expand(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, - ipompc,nodempc,coefmpc,labmpc,nmpc,nodeforc,ndirforc,xforc, - nforc,nelemload,sideload,xload,nload,nactdof,neq, - nmethod,ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - t0,ithermal,prestr,iprestr,vold,iperturb,sti,nzs, - adb,aub,filab,eme,plicon,nplicon,plkcon,nplkcon, - xstate,npmat_,matname,mi,ics,cs,mpcend,ncmat_, - nstate_,mcs,nkon,ener,jobnamec,output,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,nener,trab, - inotr,ntrans,ttime,fmpc,&nev,z,iamboun,xbounold, - &nsectors,nm,icol,irow,nzl,nam,ipompcold,nodempcold,coefmpcold, - labmpcold,&nmpcold,xloadold,iamload,t1old,t1,iamt1,xstiff, - &icole,&jqe,&irowe,isolver,nzse,&adbe,&aube,iexpl, - ibody,xbody,nbody,cocon,ncocon,tieset,ntie,&nnn); - - free(vold);vold=NNEW(double,mt**nk); - free(veold);veold=NNEW(double,mt**nk); - RENEW(eme,double,6*mi[0]**ne); - RENEW(sti,double,6*mi[0]**ne); - - if(*nener==1) RENEW(ener,double,mi[0]**ne*2); - } - - fclose(f1); - - /* checking for steadystate calculations */ - - if(*tper<0){ - precision=-*tper; - *tper=1.e10; - isteadystate=1; - }else{ - isteadystate=0; - } - - /* checking for nonlinear MPC's */ - - for(i=0;i<*nmpc;i++){ - if((strcmp1(&labmpc[20*i]," ")!=0)&& - (strcmp1(&labmpc[20*i],"CONTACT")!=0)&& - (strcmp1(&labmpc[20*i],"CYCLIC")!=0)&& - (strcmp1(&labmpc[20*i],"SUBCYCLIC")!=0)){ - inonlinmpc=1; - break; - } - } - - /* creating imddof containing the degrees of freedom - retained by the user and imdnode containing the nodes */ - - nmddof=0;nmdnode=0;nmdboun=0;nmdmpc=0; - if(nrset!=0){ - imddof=NNEW(int,*nk*3); - imdnode=NNEW(int,*nk); - imdboun=NNEW(int,*nboun); - imdmpc=NNEW(int,*nmpc); - nksector=*nk/nsectors; - FORTRAN(createmddof,(imddof,&nmddof,&nrset,istartset,iendset, - ialset,nactdof,ithermal,mi,imdnode,&nmdnode, - ikmpc,ilmpc,ipompc,nodempc,nmpc,&nsectors, - &nksector,imdmpc,&nmdmpc,imdboun,&nmdboun,ikboun, - nboun,nset,ntie,tieset,set,lakon,kon,ipkon,labmpc)); - RENEW(imddof,int,nmddof); - RENEW(imdnode,int,nmdnode); - RENEW(imdboun,int,nmdboun); - RENEW(imdmpc,int,nmdmpc); - } - - - /* normalizing the time */ - - FORTRAN(checktime,(itpamp,namta,tinc,ttime,amta,tmin,&inext,&itp)); - dtheta=(*tinc)/(*tper); - dthetaref=dtheta; - dthetaold=dtheta; - - *tmin=*tmin/(*tper); - *tmax=*tmax/(*tper); - theta=0.; - - /* check for rigid body modes - if there is a jump of 1.e4 in two subsequent eigenvalues - all eigenvalues preceding the jump are considered to - be rigid body modes and their frequency is set to zero */ - - setnull=1.; - for(i=nev-2;i>-1;i--){ - if(fabs(d[i])<0.0001*fabs(d[i+1])) setnull=0.; - d[i]*=setnull; - } - - /* check whether there are dashpot elements */ - - dashpot=0; - for(i=0;i<*ne;i++){ - if(ipkon[i]<0) continue; - if(strcmp1(&lakon[i*8],"ED")==0){ - dashpot=1;break;} - } - - if(dashpot){ - - if(*mcs!=0){ - printf("*ERROR in dyna: dashpots are not allowed in combination with cyclic symmetry\n"); - FORTRAN(stop,()); - } - - liw=51; - iwork=NNEW(int,liw); - lrw=130+42*nev; - rwork=NNEW(double,lrw); - xini=NNEW(double,2*nev); - adc=NNEW(double,neq[1]); - auc=NNEW(double,nzs[1]); - FORTRAN(mafilldm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - adc,auc,nactdof,icol,jq,irow,neq,nzl,nmethod, - ikmpc,ilmpc,ikboun,ilboun, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_, - t0,t0,ithermal,prestr,iprestr,vold,iperturb,sti, - nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, - xstiff,npmat_,&dtime,matname,mi,ncmat_, - ttime,&time0,istep,&iinc,ibody)); - - /* zc = damping matrix * eigenmodes */ - - zc=NNEW(double,neq[1]*nev); - for(i=0;i0){ - RENEW(ielorien,int,*ne+ncone); - for(k=*ne;k<*ne+ncone;k++) ielorien[k]=0; - } - RENEW(ielmat,int,*ne+ncone); - for(k=*ne;k<*ne+ncone;k++) ielmat[k]=1; - cg=NNEW(double,3*ncont); - straight=NNEW(double,16*ncont); - ifcont1=NNEW(int,ncone); - ifcont2=NNEW(int,ncone); - vini=NNEW(double,mt**nk); - bcontini=NNEW(double,neq[1]); - bcont=NNEW(double,neq[1]); - ikactcont=NNEW(int,nactcont_); - } - - /* storing the element and topology information before introducing - contact elements */ - - ne0=*ne;nkon0=*nkon; - - zeta=NNEW(double,nev); - cstr=NNEW(double,6); - - /* calculating the damping coefficients*/ - if(xmodal[10]<0){ - for(i=0;i(1.e-10)){ - zeta[i]=(alpham+betam*d[i]*d[i])/(2.*d[i]); - } - else { - printf("*WARNING in dyna: one of the frequencies is zero\n"); - printf(" no Rayleigh mass damping allowed\n"); - zeta[i]=0.; - } - } - } - else{ - /*copy the damping coefficients for every eigenfrequencie from xmodal[11....] */ - if(nev<(int)xmodal[10]){ - imax=nev; - printf("*WARNING in dyna: too many modal damping coefficients applied\n"); - printf(" damping coefficients corresponding to nonexisting eigenvalues are ignored\n"); - } - else{ - imax=(int)xmodal[10]; - } - for(i=0; i0){ - ifreebody=*ne+1; -/* ipobody=NNEW(int,2*ifreebody**nbody);*/ - ipobody=NNEW(int,2**ne); - for(k=1;k<=*nbody;k++){ - FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, - iendset,ialset,&inewton,nset,&ifreebody,&k)); - RENEW(ipobody,int,2*(*ne+ifreebody)); - } - RENEW(ipobody,int,2*(ifreebody-1)); - } - - b=NNEW(double,neq[1]); /* load rhs vector and displacement solution vector */ - bp=NNEW(double,neq[1]); /* velocity solution vector */ - bj=NNEW(double,nev); /* response modal decomposition */ - bjp=NNEW(double,nev); /* derivative of the response modal decomposition */ - ampli=NNEW(double,*nam); /* instantaneous amplitude */ - - /* constant coefficient of the linear amplitude function */ - aa=NNEW(double,nev); - aanew=NNEW(double,nev); - aamech=NNEW(double,nev); - /* linear coefficient of the linear amplitude function */ - bb=NNEW(double,nev); - - v=NNEW(double,mt**nk); - fn=NNEW(double,mt**nk); - stn=NNEW(double,6**nk); - inum=NNEW(int,*nk); - - if(*ithermal>1) {qfn=NNEW(double,3**nk);qfx=NNEW(double,3*mi[0]**ne);} - - if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); - if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); - - eei=NNEW(double,6*mi[0]**ne); - if(*nener==1){ - stiini=NNEW(double,6*mi[0]**ne); - enerini=NNEW(double,mi[0]**ne);} - -/* calculating the instantaneous loads (forces, surface loading, - centrifugal and gravity loading or temperature) at time 0 */ - - FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc,xloadold, - xload,xloadact,iamload,nload,ibody,xbody,nbody,xbodyold, - xbodyact,t1old,t1,t1act,iamt1,nk, - amta,namta,nam,ampli,&time0,&reltime,ttime,&dtime,ithermal,nmethod, - xbounold,xboun,xbounact,iamboun,nboun, - nodeboun,ndirboun,nodeforc,ndirforc,istep,&iinc, - co,vold,itg,&ntg,amname,ikboun,ilboun,nelemload,sideload,mi)); - - /* calculating the instantaneous loading vector at time 0 */ - - ikactmech=NNEW(int,neq[1]); - nactmech=0; - FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, - nforc,nelemload,sideload,xloadact,nload,xbodyact,ipobody,nbody, - cgr,b,nactdof,&neq[1],nmethod, - ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon,alcon, - nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_,t0,t1act, - ithermal,iprestr,vold,iperturb,iexpl,plicon, - nplicon,plkcon,nplkcon,npmat_,ttime,&time0,istep,&iinc,&dtime, - physcon,ibody,xbodyold,&reltime,veold,matname,mi,ikactmech, - &nactmech)); - - /* check for nonzero SPC's */ - - iprescribedboundary=0; - for(i=0;i<*nboun;i++){ - if(fabs(xboun[i])>1.e-10){ - iprescribedboundary=1; - break; - } - } - - /* correction for nonzero SPC's */ - - if(iprescribedboundary){ - - if(*mcs!=0){ - printf("*ERROR in dyna: prescribed boundaries are not allowed in combination with cyclic symmetry\n"); - FORTRAN(stop,()); - } - - if(*idrct!=1){ - printf("*ERROR in dyna: variable increment length is not allwed in combination with prescribed boundaries\n"); - FORTRAN(stop,()); - } - - /* LU decomposition of the stiffness matrix */ - - if(*isolver==0){ -#ifdef SPOOLES - spooles_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1], - &symmetryflag,&inputformat); -#else - printf("*ERROR in dyna: the SPOOLES library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==4){ -#ifdef SGI - token=1; - sgi_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1],token); -#else - printf("*ERROR in dyna: the SGI library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau_factor(ad,&au,adb,aub,&sigma,icol,&irow,&neq[1],&nzs[1]); -#else - printf("*ERROR in dyna: the TAUCS library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1]); -#else - printf("*ERROR in dyna: the PARDISO library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - - bact=NNEW(double,neq[1]); - bmin=NNEW(double,neq[1]); - bv=NNEW(double,neq[1]); - bprev=NNEW(double,neq[1]); - bdiff=NNEW(double,neq[1]); - - init=1; - dynboun(amta,namta,nam,ampli,&time0,ttime,&dtime,xbounold,xboun, - xbounact,iamboun,nboun,nodeboun,ndirboun,ad,au,adb, - aub,icol,irow,neq,nzs,&sigma,b,isolver, - &alpham,&betam,nzl,&init,bact,bmin,jq,amname,bv, - bprev,bdiff,&nactmech,&icorrect,&iprev); - init=0; - } - -/* creating contact elements and calculating the contact forces - (normal and shear) */ - - if(ncont!=0){ -// for(i=0;i100){nactcont_=nactcont;}else{nactcont_=100;} - RENEW(ikactcont,int,nactcont_); - - /* check for damping/friction in the material definition (to be done) */ - - for(i=0;i<*ntie;i++){ - if(tieset[i*(81*3)+80]=='C'){ - imat=(int)cs[17*i]; - if(*ncmat_<5) continue; - damp=elcon[(imat-1)*(*ncmat_+1)**ntmat_+2]; - if(*ncmat_<7){um=0.;}else{ - um=elcon[(imat-1)*(*ncmat_+1)**ntmat_+5]; - } - if((damp>0.)||(um>0.)){ - ifricdamp=1; - break; - } - } - } - - if(ifricdamp==1){ - aafric=NNEW(double,nev); - bfric=NNEW(double,neq[1]); - } - - } - - for(i=0;i1.e-6){ - - time0=time; - -// printf("\nnew increment\n"); - - if(*nener==1){ -/* for(k=0; k*jmax){ - printf(" *ERROR: max. # of increments reached\n\n"); - FORTRAN(stop,()); - } - - if(iinc>1){ - memcpy(&cd[0],&bj[0],sizeof(double)*nev); - memcpy(&cv[0],&bjp[0],sizeof(double)*nev); -/* for(i=0; ibbmax) bbmax=fabs(b[ikactmech[i]]); - } - }else{ - for(i=0;ibbmax) bbmax=fabs(b[i]); - } - } - - /* check for size of mechanical force */ - - if((bbmax>deltmx)&&(((itp==1)&&(dtheta>*tmin))||(itp==0))){ - - /* force increase too big: increment size is decreased */ - - icorrect=1; - dtheta=dtheta*deltmx/bbmax; - printf("correction of dtheta due to force increase: %e\n",dtheta); - dthetaref=dtheta; - if(itp==1){ - inext--; - itp=0; - } - - /* check whether the new increment size is not too small */ - - if(dtheta<*tmin){ - printf("\n *WARNING: increment size %e smaller than minimum %e\n",dtheta**tper,*tmin**tper); - printf(" minimum is taken\n"); - dtheta=*tmin; - } - - reltime=theta+dtheta; - time=reltime**tper; - dtime=dtheta**tper; - - /* calculating the instantaneous loads (forces, surface loading, - centrifugal and gravity loading or temperature) */ - - FORTRAN(temploaddiff,(xforcold,xforc,xforcact,iamforc,nforc, - xloadold,xload,xloadact,iamload,nload,ibody,xbody, - nbody,xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, - namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal, - nmethod,xbounold,xboun,xbounact,iamboun,nboun,nodeboun, - ndirboun,nodeforc, - ndirforc,istep,&iinc,co,vold,itg,&ntg,amname,ikboun,ilboun, - nelemload,sideload,mi, - xforcdiff,xloaddiff,xbodydiff,t1diff,xboundiff,&icorrect, - &iprescribedboundary)); - - /* calculating the instantaneous loading vector */ - - if(inonlinmpc==0){ - FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcdiff, - nforc,nelemload,sideload,xloaddiff,nload,xbodydiff, - ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, - ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - t0,t1diff,ithermal,iprestr,vold,iperturb,iexpl,plicon, - nplicon,plkcon,nplkcon, - npmat_,ttime,&time,istep,&iinc,&dtime,physcon,ibody, - xbodyold,&reltime,veold,matname,mi,ikactmech,&nactmech)); - }else{ - FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, - nforc,nelemload,sideload,xloadact,nload,xbodyact, - ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, - ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - t0,t1act,ithermal,iprestr,vold,iperturb,iexpl,plicon, - nplicon,plkcon,nplkcon, - npmat_,ttime,&time,istep,&iinc,&dtime,physcon,ibody, - xbodyold,&reltime,veold,matname,mi,ikactmech,&nactmech)); - } - - /* correction for nonzero SPC's */ - - if(iprescribedboundary){ - if(inonlinmpc==1) icorrect=2; - dynboun(amta,namta,nam,ampli,&time,ttime,&dtime, - xbounold,xboun, - xbounact,iamboun,nboun,nodeboun,ndirboun,ad,au,adb, - aub,icol,irow,neq,nzs,&sigma,b,isolver, - &alpham,&betam,nzl,&init,bact,bmin,jq,amname,bv, - bprev,bdiff,&nactmech,&icorrect,&iprev); - } - icorrect=0; - } - - if(ncont!=0){ - for(i=0;i1.+1.e-6){ - ddj=dj*sqrt(zetaj*zetaj-1.); - h1=ddj-zetaj*dj; - h2=ddj+zetaj*dj; - h3=1./h1; - h4=1./h2; - h5=h3*h3; - h6=h4*h4; - tstart=0.; - FORTRAN(fsuper,(&time,&dtime,&aa[l],&bb[l], - &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); - sum=func;sump=funcp; - FORTRAN(fsuper,(&time,&tstart,&aa[l],&bb[l], - &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); - sum-=func;sump-=funcp; - - fexm=exp(h1*dtime); - fexp=exp(-h2*dtime); - h14=zetaj*dj/ddj; - bj[l]=sum/(2.*ddj)+(fexm+fexp)*cd[l]/2.+zetaj*(fexm-fexp)/(2.* - sqrt(zetaj*zetaj-1.))*cd[l]+(fexm-fexp)*cv[l]/(2.*ddj); - bjp[l]=sump/(2.*ddj)+(h1*fexm-h2*fexp)*cd[l]/2. - +(h14*cd[l]+cv[l]/ddj)*(h1*fexm+h2*fexp)/2.; - } - - /* critical damping */ - - else{ - h1=zetaj*dj; - h2=1./h1; - h3=h2*h2; - h4=h2*h3; - tstart=0.; - FORTRAN(fcrit,(&time,&dtime,&aa[l],&bb[l],&zetaj,&dj, - &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); - sum=func;sump=funcp; - FORTRAN(fcrit,(&time,&tstart,&aa[l],&bb[l],&zetaj,&dj, - &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); - sum-=func;sump-=funcp; - fexp=exp(-h1*dtime); - bj[l]=sum+fexp*((1.+h1*dtime)*cd[l]+dtime*cv[l]); - bjp[l]=sump+fexp*(-h1*h1*dtime*cd[l]+ - (1.-h1*dtime)*cv[l]); - } - } - } - - /* composing the response */ - - if(iprescribedboundary){ - if(nmdnode==0){ - memcpy(&b[0],&bmin[0],sizeof(double)*neq[1]); - memcpy(&bp[0],&bv[0],sizeof(double)*neq[1]); - }else{ - for(i=0;i0)&&(*idrct==0)){ - if(itp==1){ - jprint=*jout; - }else{ - jprint=*jout+1; - } - } - - /* check whether output is needed */ - - if((*jout==jprint)||(1.-theta<=1.e-6)){ - iout=2; - jprint=0; - }else if(*nener==1){ - iout=-2; - }else{ - iout=0; - } - - if((iout==2)||(iout==-2)){ - if(intpointvar==1) stx=NNEW(double,6*mi[0]**ne); - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum, - stx,elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero, - ielmat,ielorien,norien,orab,ntmat_,t0,t1, - ithermal,prestr,iprestr,filab,eme,een, - iperturb,f,fn,nactdof,&iout,qa, - vold,b,nodeboun,ndirboun,xbounact,nboun, - ipompc,nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1], - veold,accold,&bet,&gam,&dtime,&time,ttime, - plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, - &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener, - enern,sti,xstaten,eei,enerini,cocon,ncocon, - set,nset,istartset,iendset,ialset,nprint,prlab,prset, - qfx,qfn,trab,inotr,ntrans,fmpc,nelemload,nload,ikmpc, - ilmpc,istep,&iinc)); - - - if((*ithermal!=2)&&(intpointvar==1)){ - for(k=0;k<6*mi[0]*ne0;++k){ - sti[k]=stx[k]; - } - } - } - if(iout==2){ - (*kode)++; - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(co,&nkg,kon,ipkon,lakon,&neg,v,stn,inum,nmethod,kode,filab, - een,t1,fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_, - istep,&iinc, - iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,stx,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - } - - if((intpointvar==1)&&((iout==2)||(iout==-2))){ - free(stx); - } - - - FORTRAN(writesummary,(istep,&iinc,&icutb,&iit,ttime,&time,&dtime)); - - if(isteadystate==1){ - - /* calculate maximum displacement/temperature */ - - resultmax=0.; - if(*ithermal<2){ - for(i=1;iresultmax) resultmax=fabs(v[i]);} - for(i=2;iresultmax) resultmax=fabs(v[i]);} - for(i=3;iresultmax) resultmax=fabs(v[i]);} - }else if(*ithermal==2){ - for(i=0;iresultmax) resultmax=fabs(v[i]);} - }else{ - printf("*ERROR in dyna: coupled temperature-displacement calculations are not allowed\n"); - } - if(fabs((resultmax-resultmaxprev)/resultmax)1) {free(qfn);free(qfx);} - - /* updating the loading at the end of the step; - important in case the amplitude at the end of the step - is not equal to one */ - - for(k=0;k<*nboun;++k){xboun[k]=xbounact[k];} - for(k=0;k<*nforc;++k){xforc[k]=xforcact[k];} - for(k=0;k<2**nload;++k){xload[k]=xloadact[k];} - for(k=0;k<7**nbody;k=k+7){xbody[k]=xbodyact[k];} - if(*ithermal==1){ - for(k=0;k<*nk;++k){t1[k]=t1act[k];} - } - - free(v);free(fn);free(stn);free(inum);free(adb); - free(aub);free(z);free(b);free(zeta);free(bj);free(cd);free(cv); - free(xforcact);free(xloadact);free(xbounact);free(aa);free(bb);free(aanew); - free(ampli);free(xbodyact);free(bjp);free(bp);free(aamech);free(ikactmech); - free(xforcdiff);free(xloaddiff);free(xboundiff),free(xbodydiff); - - if(*ithermal==1) {free(t1act);free(t1diff);} - - if(iprescribedboundary){ - if(*isolver==0){ -#ifdef SPOOLES - spooles_cleanup(); -#endif - } - else if(*isolver==4){ -#ifdef SGI - sgi_cleanup(token); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau_cleanup(); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_cleanup(&neq[1]); -#endif - } - free(bact);free(bmin);free(bv);free(bprev);free(bdiff); - } - - /* deleting the contact information */ - *ne=ne0; *nkon=nkon0; - if(ncont!=0){ - RENEW(ipkon,int,*ne); - RENEW(lakon,char,8**ne); - RENEW(kon,int,*nkon); - if(*nener==1){ - RENEW(ener,double,mi[0]**ne*2); - } - if(*norien>0){ - RENEW(ielorien,int,*ne); - } - RENEW(ielmat,int,*ne); - free(cg);free(straight);free(vini);free(bcont); - free(ifcont1);free(ifcont2);free(ikactcont);free(imastop); - - if(ifricdamp==1){free(aafric);free(bfric);} - - } - - if(*mcs==0){ - free(ad);free(au); - }else{ - free(adbe); free(aube);free(icole); free(irowe); free(jqe); - - *nk/=nsectors; - *ne/=nsectors; - *nkon/=nsectors; - *nboun/=nsectors; - neq[1]=neq[1]*2/nsectors; - - RENEW(nnn,int,*nk); - - RENEW(ialset,int,nalset_); - /* restore the infomration in istartset and iendset */ - for(j=0; j<*nset; j++){ - istartset[j]=istartset_[j]; - iendset[j]=iendset_[j]; - } - free(istartset_); - free(iendset_); - - RENEW(co,double,3**nk); - if((*ithermal!=0)&&(*nam>0)) RENEW(iamt1,int,*nk); - RENEW(nactdof,int,mt**nk); - if(*ntrans>0) RENEW(inotr,int,2**nk); - RENEW(kon,int,*nkon); - RENEW(ipkon,int,*ne); - RENEW(lakon,char,8**ne); - RENEW(ielmat,int,*ne); - if(*norien>0) RENEW(ielorien,int,*ne); - RENEW(nodeboun,int,*nboun); - RENEW(ndirboun,int,*nboun); - if(*nam>0) RENEW(iamboun,int,*nboun); - RENEW(xboun,double,*nboun); - RENEW(xbounold,double,*nboun); - RENEW(ikboun,int,*nboun); - RENEW(ilboun,int,*nboun); - - /* recovering the original multiple point constraints */ - - RENEW(ipompc,int,*nmpc); - RENEW(nodempc,int,3**mpcend); - RENEW(coefmpc,double,*mpcend); - RENEW(labmpc,char,20**nmpc+1); - RENEW(ikmpc,int,*nmpc); - RENEW(ilmpc,int,*nmpc); - RENEW(fmpc,double,*nmpc); - - *nmpc=nmpcold; - *mpcend=mpcendold; - for(i=0;i<*nmpc;i++){ipompc[i]=ipompcold[i];} - for(i=0;i<3**mpcend;i++){nodempc[i]=nodempcold[i];} - for(i=0;i<*mpcend;i++){coefmpc[i]=coefmpcold[i];} - for(i=0;i<20**nmpc;i++){labmpc[i]=labmpcold[i];} - for(i=0;i<*nmpc;i++){ikmpc[i]=ikmpcold[i];} - for(i=0;i<*nmpc;i++){ilmpc[i]=ilmpcold[i];} - free(ipompcold);free(nodempcold);free(coefmpcold); - free(labmpcold);free(ikmpcold);free(ilmpcold); - - RENEW(vold,double,mt**nk); - RENEW(veold,double,mt**nk); - RENEW(eme,double,6*mi[0]**ne); - RENEW(sti,double,6*mi[0]**ne); - if(*nener==1)RENEW(ener,double,mi[0]**ne*2); - -/* distributed loads */ - - for(i=0;i<*nload;i++){ - if(nelemload[2*i]0){ - if(*nam>0){ - FORTRAN(isortiddc2,(nelemload,iamload,xload,xloadold,sideload,nload,&kflag)); - }else{ - FORTRAN(isortiddc1,(nelemload,xload,xloadold,sideload,nload,&kflag)); - } - } - -/* point loads */ - - for(i=0;i<*nforc;i++){ - if(nodeforc[2*i+1]0) free(ipobody); - - if(dashpot){ - free(xini);free(rwork);free(adc);free(auc);free(cc); - free(rpar);free(iwork);} - - free(cstr); - - if(nmdnode>0){free(imddof);free(imdnode);free(imdboun);free(imdmpc);} - - *ialsetp=ialset; - *cop=co;*konp=kon;*ipkonp=ipkon;*lakonp=lakon;*ielmatp=ielmat; - *ielorienp=ielorien;*inotrp=inotr;*nodebounp=nodeboun; - *ndirbounp=ndirboun;*iambounp=iamboun;*xbounp=xboun; - *xbounoldp=xbounold;*ikbounp=ikboun;*ilbounp=ilboun;*nactdofp=nactdof; - *voldp=vold;*emep=eme;*enerp=ener;*ipompcp=ipompc;*nodempcp=nodempc; - *coefmpcp=coefmpc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; - *fmpcp=fmpc;*veoldp=veold;*iamt1p=iamt1;*t0p=t0;*t1oldp=t1old;*t1p=t1; - *nnnp=nnn;*stip=sti; - - return; -} - diff -Nru calculix-ccx-2.1/ccx_2.1/src/dynacont.c calculix-ccx-2.3/ccx_2.1/src/dynacont.c --- calculix-ccx-2.1/ccx_2.1/src/dynacont.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/dynacont.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,908 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include -#include -#include -#include "CalculiX.h" - -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif - -void dynacont(double *co, int *nk, int *kon, int *ipkon, char *lakon, int *ne, - int *nodeboun, int *ndirboun, double *xboun, int *nboun, - int *ipompc, int *nodempc, double *coefmpc, char *labmpc, - int *nmpc, int *nodeforc,int *ndirforc,double *xforc, - int *nforc,int *nelemload, char *sideload,double *xload, - int *nload, - int *nactdof,int *neq, int *nzl,int *icol, int *irow, - int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, - int *ilboun,double *elcon, int *nelcon, double *rhcon, - int *nrhcon,double *cocon, int *ncocon, - double *alcon, int *nalcon, double *alzero, - int *ielmat,int *ielorien, int *norien, double *orab, - int *ntmat_,double *t0, - double *t1,int *ithermal,double *prestr, int *iprestr, - double *vold,int *iperturb, double *sti, int *nzs, - double *tinc, double *tper, double *xmodalsteady, - double *veold, char *amname, double *amta, - int *namta, int *nam, int *iamforc, int *iamload, - int *iamt1,int *jout,char *filab,double *eme, double *xforcold, - double *xloadold, - double *t1old, int *iamboun, double *xbounold, int *iexpl, - double *plicon, int *nplicon, double *plkcon,int *nplkcon, - double *xstate, int *npmat_, char *matname, int *mi, - int *ncmat_, int *nstate_, double *ener, char *jobnamec, - double *ttime, char *set, int *nset, int *istartset, - int *iendset, int *ialset, int *nprint, char *prlab, - char *prset, int *nener, double *trab, - int *inotr, int *ntrans, double *fmpc, char *cbody, int *ibody, - double *xbody, int *nbody, double *xbodyold, int *istep, - int *isolver,int *jq, char *output, int *mcs, int *nkon, - int *mpcend, int *ics, double *cs, int *ntie, char *tieset, - int *idrct, int *jmax, double *tmin, double *tmax, - double *ctrl, int *itpamp, double *tietol,int *iit, - int *ncont,int *ne0, double *reltime, double *dtime, - double *bcontini, double *bj, double *aux, int *iaux, - double *bcont, int *nev, double *v, - int *nkon0, double *deltmx, double *dtheta, double *theta, - int *iprescribedboundary, int *mpcfree, int *memmpc_, - int *itietri, int *koncont, double *cg, double *straight, - int *iinc, int *ifcont1, int *ifcont2, double *vini, - double *aa, double *bb, double *aanew, double *d, - double *z, double *zeta,double *b, double *time0,double *time, - int *ipobody, - double *xforcact, double *xloadact, double *t1act, - double *xbounact, double *xbodyact, double *cd, double *cv, - double *ampli, double *dthetaref, double *bjp, double *bp, - double *cstr,int *imddof, int *nmddof, - int **ikactcontp, int *nactcont,int *nactcont_, - double *aamech, double *bprev, int *iprev, int *inonlinmpc, - int **ikactmechp, int *nactmech,int *imdnode,int *nmdnode, - int *imdboun,int *nmdboun,int *imdmpc,int *nmdmpc, - int *itp, int *inext,int *ifricdamp,double *aafric, - double *bfric, int *imastop){ - - char lakonl[9]=" \0"; - - int i,j,k,l,init,*itg=NULL,ntg=0,maxlenmpc,icascade=0,loop, - konl[20],imat,nope,kodem,indexe,j1,jdof,kmin,kmax, - id,newstep=0,idiscon,*ipiv=NULL,info,nrhs=1,kode,iener=0, - *ikactcont=NULL,*ilactcont=NULL,*ikactcont1=NULL,nactcont1=0, - i1,icutb=0,iconvergence=0,idivergence=0,mt=mi[1]+1, - nactcont1_=100,*ikactmech=NULL,icorrect=0,nactfric_,nactfric, - *ikactfric=NULL; - - long long i2; - - double *adb=NULL,*aub=NULL,*cgr=NULL, *au=NULL,fexp,fcos,fsin,fexm, - physcon[1],zetaj,dj,ddj,h1,h2,h3,h4,h5,h6,sum,aai,bbi,tstart,tend, - *ad=NULL,sigma=0.,alpham,betam,*bact=NULL,*bmin=NULL,*bv=NULL, - xl[27],voldl[mt*9],elas[21],fnl[27],t0l,t1l,elconloc[21],veoldl[mt*9], - bbmax,s[3600],*aaa=NULL,*bbb=NULL,func,funcp,*bjbasp=NULL, - *bjbas=NULL, *bjinc=NULL, *dbj=NULL, *lhs=NULL,dbjmax,bjmax, - *bjincp=NULL,sump,h14,*dbjp=NULL,senergy=0.0,*xforcdiff=NULL, - df,i0,ic,ia,dbjmaxOLD1,dbjmaxOLD2,*xloaddiff=NULL,*dbcont=NULL, - zl=0.0,*xbodydiff=NULL,*t1diff=NULL,*xboundiff=NULL,*bdiff=NULL; - - ikactcont=*ikactcontp;ikactmech=*ikactmechp; - - if(ithermal[0]<=1){ - kmin=1;kmax=3; - }else if(ithermal[0]==2){ - kmin=0;kmax=mi[1];if(kmax>2)kmax=2; - }else{ - kmin=0;kmax=3; - } - - xforcdiff=NNEW(double,*nforc); - xloaddiff=NNEW(double,2**nload); - xbodydiff=NNEW(double,7**nbody); - /* copying the rotation axis and/or acceleration vector */ - for(k=0;k<7**nbody;k++){xbodydiff[k]=xbody[k];} - xboundiff=NNEW(double,*nboun); - if(*ithermal==1) t1diff=NNEW(double,*nk); - - /* load the convergence constants from ctrl*/ - - i0=ctrl[0];ic=ctrl[3];ia=ctrl[7];df=ctrl[10]; - - /* set the convergence parameters*/ - - dbjmaxOLD1=0.0; - dbjmaxOLD2=0.0; - - printf("\nstart dynacont\n"); - - /* calculating the contact forces */ - -// memset(&bcont[0],0,sizeof(double)*neq[1]); - for(j=0;j<*nactcont;j++){bcont[ikactcont[j]]=0.;} - - *ne=*ne0;*nkon=*nkon0; - - contact(ncont,ntie,tieset,nset,set,istartset,iendset, - ialset,itietri,lakon,ipkon,kon,koncont,ne,cg, - straight,nkon,co,vold,ielmat,cs,elcon,istep, - iinc,iit,ncmat_,ntmat_,ifcont1,ifcont2,ne0, - vini,nmethod,nmpc,mpcfree,memmpc_, - &ipompc,&labmpc,&ikmpc,&ilmpc,&fmpc,&nodempc,&coefmpc, - iperturb,ikboun,nboun,mi,imastop); - - ikactcont1=NNEW(int,nactcont1_); - - for(i=*ne0;i<*ne;i++){ - indexe=ipkon[i]; - imat=ielmat[i]; - kodem=nelcon[2*imat-2]; - for(j=0;j<8;j++){lakonl[j]=lakon[8*i+j];} - nope=atoi(&lakonl[7]); - for(j=0;j0){ - if(ikactcont[id-1]==jdof){ - break; - } - } - (*nactcont)++; - if(*nactcont>*nactcont_){ - *nactcont_=(int)(1.1**nactcont_); - RENEW(ikactcont,int,*nactcont_); - } - k=*nactcont-1; - l=k-1; - while(k>id){ - ikactcont[k--]=ikactcont[l--]; - } - ikactcont[id]=jdof; - break; - }while(1); - } -// free(ikactcont1); - - /* calculate the change in contact force */ - - bbmax=0.; - if(icutb==0){ - for(i=0;i<*nactcont;i++){ - jdof=ikactcont[i]; - if(fabs(bcont[jdof]-bcontini[jdof])>bbmax){ - bbmax=fabs(bcont[jdof]-bcontini[jdof]); - } - } - } - - /* removing entires in bcont */ - - for(j=0;j*deltmx || icutb>0)&&(((*itp==1)&&(*dtheta>*tmin))||(*itp==0))){ - - /* force increase too big: increment size is decreased */ - - if(icutb>0){ - *dtheta=*dtheta*df; - printf("*INFORMATION: increment size is decreased to %e\nthe increment is reattempted\n\n",*dtheta**tper); - } - else{ - *dtheta=*dtheta**deltmx/bbmax; - } - printf("correction of dtime due to contact: %e\n",*dtheta**tper); - *dthetaref=*dtheta; - if(*itp==1){ - (*inext)--; - *itp=0; - } - - /* check whether the new increment size is not too small */ - - if(*dtheta<*tmin){ - printf("\n *WARNING: increment size %e smaller than minimum %e\n",*dtheta**tper,*tmin**tper); - printf(" minimum is taken\n"); - *dtheta=*tmin; - *dthetaref=*dtheta; - } - - *reltime=*theta+(*dtheta); - *time=*reltime**tper; - *dtime=*dtheta**tper; - - /* calculating the instantaneous loads (forces, surface loading, - centrifugal and gravity loading or temperature) */ - - FORTRAN(temploaddiff,(xforcold,xforc,xforcact,iamforc,nforc, - xloadold,xload,xloadact,iamload,nload,ibody,xbody, - nbody,xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, - namta,nam,ampli,time,reltime,ttime,dtime,ithermal, - nmethod,xbounold,xboun,xbounact,iamboun,nboun,nodeboun, - ndirboun,nodeforc, - ndirforc,istep,iinc,co,vold,itg,&ntg,amname,ikboun,ilboun, - nelemload,sideload,mi, - xforcdiff,xloaddiff,xbodydiff,t1diff,xboundiff,&icorrect, - iprescribedboundary)); - - /* calculating the instantaneous loading vector */ - - if(*inonlinmpc==0){ - FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcdiff, - nforc,nelemload,sideload,xloaddiff,nload,xbodydiff, - ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, - ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - t0,t1diff,ithermal,iprestr,vold,iperturb,iexpl,plicon, - nplicon,plkcon,nplkcon, - npmat_,ttime,time,istep,iinc,dtime,physcon,ibody, - xbodyold,reltime,veold,matname,mi,ikactmech,nactmech)); - }else{ - FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, - nforc,nelemload,sideload,xloadact,nload,xbodyact, - ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, - ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - t0,t1act,ithermal,iprestr,vold,iperturb,iexpl,plicon, - nplicon,plkcon,nplkcon, - npmat_,ttime,time,istep,iinc,dtime,physcon,ibody, - xbodyold,reltime,veold,matname,mi,ikactmech,nactmech)); - } - - /* correction for nonzero SPC's */ - - if(*iprescribedboundary){ - if(*inonlinmpc==1) icorrect=2; - dynboun(amta,namta,nam,ampli,time,ttime,dtime, - xbounold,xboun, - xbounact,iamboun,nboun,nodeboun,ndirboun,ad,au,adb, - aub,icol,irow,neq,nzs,&sigma,b,isolver, - &alpham,&betam,nzl,&init,bact,bmin,jq,amname,bv, - bprev,bdiff,nactmech,&icorrect,iprev); - } - - /* correcting aamech */ - - for(i=0;i<*nev;i++){ - i2=(long long)i*neq[1]; - - if(*inonlinmpc==1){aamech[i]=0.;} - if(*nactmech1.+1.e-6){ - ddj=dj*sqrt(zetaj*zetaj-1.); - h1=ddj-zetaj*dj; - h2=ddj+zetaj*dj; - h3=1./h1; - h4=1./h2; - h5=h3*h3; - h6=h4*h4; - tstart=0; - FORTRAN(fsuper,(time,dtime,&aa[l],&bb[l], - &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); - sum=func;sump=funcp; - FORTRAN(fsuper,(time,&tstart,&aa[l],&bb[l], - &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); - sum-=func;sump-=funcp; - fexm=exp(h1**dtime); - fexp=exp(-h2**dtime); - h14=zetaj*dj/ddj; - - bjbas[l]=sum/(2.*ddj)+(fexm+fexp)*cd[l]/2.+zetaj*(fexm-fexp)/(2.*sqrt(zetaj*zetaj-1.))*cd[l]+(fexm-fexp)*cv[l]/(2.*ddj); - bjbasp[l]=sump/(2.*ddj)+(h1*fexm-h2*fexp)*cd[l]/2.+(h14*cd[l]+cv[l]/ddj)*(h1*fexm+h2*fexp)/2.; - } - - /* critical damping */ - - else{ - h1=zetaj*dj; - h2=1./h1; - h3=h2*h2; - h4=h2*h3; - tstart=0; - FORTRAN(fcrit,(time,dtime,&aa[l],&bb[l],&zetaj,&dj, - &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); - sum=func;sump=funcp; - FORTRAN(fcrit,(time,&tstart,&aa[l],&bb[l],&zetaj,&dj, - &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); - sum-=func;sump+=funcp; - fexp=exp(-h1**dtime); - bjbas[l]=sum+fexp*((1.+h1**dtime)*cd[l]+*dtime*cv[l]); - bjbasp[l]=sump+fexp*(-h1*h1**dtime*cd[l]+(1.-h1**dtime)*cv[l]); - } - } - - /* calculating the incremental response due to contact */ - - aai=-(*time-*dtime)/(*dtime); - bbi=1./(*dtime); - - bjinc=NNEW(double,*nev); /* incremental response modal decomposition */ - bjincp=NNEW(double,*nev); - for(l=0;l<*nev;l++){ - zetaj=zeta[l]; - dj=d[l]; - - /* zero eigenfrequency: rigid body mode */ - - if(fabs(d[l])<=1.e-10){ - tstart=*time0; - tend=*time; - sum=tend*(aai**time+ - tend*((bbi**time-aai)/2.-bbi*tend/3.))- - tstart*(aai**time+ - tstart*((bbi**time-aai)/2.-bbi*tstart/3.)); - sump=tend*(aai+bbi*tend/2.)-tstart*(aai+bbi*tstart/2.); - - bjinc[l]=sum; - bjincp[l]=sump; - } - - /* subcritical damping */ - - else if(zetaj<1.-1.e-6){ - ddj=dj*sqrt(1.-zetaj*zetaj); - h1=zetaj*dj; - h2=h1*h1+ddj*ddj; - h3=h1*h1-ddj*ddj; - h4=2.*h1*ddj/h2; - tstart=0.; - FORTRAN(fsub,(time,dtime,&aai,&bbi,&ddj, - &h1,&h2,&h3,&h4,&func,&funcp)); - sum=func;sump=funcp; - FORTRAN(fsub,(time,&tstart,&aai,&bbi,&ddj, - &h1,&h2,&h3,&h4,&func,&funcp)); - sum-=func;sump-=funcp; - - bjinc[l]=sum/ddj; - bjincp[l]=sump/ddj; - - } - - /* supercritical damping */ - - else if(zetaj>1.+1.e-6){ - ddj=dj*sqrt(zetaj*zetaj-1.); - h1=ddj-zetaj*dj; - h2=ddj+zetaj*dj; - h3=1./h1; - h4=1./h2; - h5=h3*h3; - h6=h4*h4; - tstart=0.; - FORTRAN(fsuper,(time,dtime,&aai,&bbi, - &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); - sum=func;sump=funcp; - FORTRAN(fsuper,(time,&tstart,&aai,&bbi, - &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); - sum-=func;sump-=funcp; - - bjinc[l]=sum/(2.*ddj); - bjincp[l]=sump/(2.*ddj); - - } - - /* critical damping */ - - else{ - h1=zetaj*dj; - h2=1./h1; - h3=h2*h2; - h4=h2*h3; - tstart=0.; - FORTRAN(fcrit,(time,dtime,&aai,&bbi,&zetaj,&dj, - &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); - sum=func;sump=funcp; - FORTRAN(fcrit,(time,&tstart,&aai,&bbi,&zetaj,&dj, - &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); - sum-=func;sump-=funcp; - - bjinc[l]=sum; - bjincp[l]=sump; - - } - } - - aaa=NNEW(double,*nev); - bbb=NNEW(double,*nev**nev); - lhs=NNEW(double,*nev**nev); - ipiv=NNEW(int,*nev); - dbj=NNEW(double,*nev); /* change in bj */ - dbjp=NNEW(double,*nev); /* change in djp */ - - memcpy(&bj[0],&bjbas[0],sizeof(double)**nev); - memcpy(&bjp[0],&bjbasp[0],sizeof(double)**nev); - - /* major iteration loop for the contact response */ - - loop=0; - printf("Contact-Iteration\n"); - do{ - loop++; - printf("loop=%d\n",loop); - - /* composing the response */ - - if(*iprescribedboundary){ - if(*nmdnode==0){ - memcpy(&b[0],&bmin[0],sizeof(double)*neq[1]); - memcpy(&bp[0],&bv[0],sizeof(double)*neq[1]); - }else{ - for(i=0;i<*nmddof;i++){ - b[imddof[i]]=bmin[imddof[i]]; - bp[imddof[i]]=bv[imddof[i]]; - } - } - } - else{ - if(*nmdnode==0){ - memset(&b[0],0.,sizeof(double)*neq[1]); - memset(&bp[0],0.,sizeof(double)*neq[1]); - }else{ - for(i=0;i<*nmddof;i++){ - b[imddof[i]]=0.; - bp[imddof[i]]=0.; - } - } - } - - if(*nmdnode==0){ - for(i=0;i100){*nactcont_=*nactcont;}else{*nactcont_=100;} - RENEW(ikactcont,int,*nactcont_); - RENEW(ilactcont,int,*nactcont_); - RENEW(dbcont,double,*nactcont_**nev); - - /* aaa(i) is the internal product of the contact force at the end of the - increment with eigenmode i - bbb(i,j) is the internal product of the change of the contact force with - respect to modal coordinate j with the eigenmode i */ - - memset(&bbb[0],0,*nev**nev); - memset(&aaa[0],0,*nev); - - for(k=0; k<*nactcont; k++){ - i1=ikactcont[k]; - i2=(ilactcont[k]-1)**nev; - for(j=0; j<*nev; j++){ - zl=z[(long long)j*neq[1]+i1]; - aaa[j]+=zl*bcont[i1]; - for(l=0; l<*nev; l++){ - bbb[l**nev+j]+=zl*dbcont[i2+l]; - } - } - } - - for(l=0;l<*nev;l++){ - i1=l**nev; - for(j=0;j<*nev;j++){ - if(j==l){lhs[i1+j]=1.;}else{lhs[i1+j]=0.;} - lhs[i1+j]-=bjinc[j]*bbb[i1+j]; - } - dbj[l]=bjbas[l]+bjinc[l]*aaa[l]-bj[l]; - } - - /* solve the system of equations; determine dbj */ - - FORTRAN(dgesv,(nev,&nrhs,lhs,nev,ipiv,dbj,nev,&info)); - - /* check the size of dbj */ - - bjmax=0.; - dbjmax=0.; - dbjmaxOLD1=dbjmax; - dbjmaxOLD2=dbjmaxOLD1; - for(i=0;i<*nev;i++){ - if(fabs(bj[i])>bjmax) bjmax=fabs(bj[i]); - if(fabs(dbj[i])>dbjmax) dbjmax=fabs(dbj[i]); - } - - iconvergence=0; - idivergence=0; - - if(dbjmax<=0.005*bjmax){ - - //calculate bjp: the derivative of bj w.r.t. time - - for(j=0; j<*nev; j++){ - bjp[j]=bjbasp[j]+bjincp[j]*aaa[j]; - } - FORTRAN(dgetrs,("No transpose",nev,&nrhs,lhs,nev,ipiv,bjp,nev,&info)); - iconvergence=1; - } - else{ - if(loop>=i0 && loop<=ic){ - /* check for divergence */ - if((dbjmax>dbjmaxOLD1) && (dbjmax>dbjmaxOLD2)){ - /* divergence --> cutback */ - printf("*INFORMATION: divergence --> cutback\n"); - idivergence=1; - icutb++; - break; - } - } - else{ - if(loop>ic){ - /* cutback after ic iterations*/ - printf("*INFORMATION: to many iterations --> cutback\n"); - idivergence=1; - icutb++; - break; - } - } - } - - /* add dbj to db */ - - for(j=0;j<*nev;j++){ - bj[j]+=dbj[j]; - } - - }while(1); - }while(idivergence==1 && icutb<10); - - printf("Contact-Iteration Done\n"); - - if(icutb>=10){ - //no convergence, stop all - printf("*ERROR: Contact did not converge.\n"); - FORTRAN(stop,()); - } - - /* calculating the damping/friction contribution */ - - if(*ifricdamp==1){ - nactfric_=*nactcont_; - nactfric=0; - ikactfric=NNEW(int,nactfric_); - - memset(&ikactfric[0],0,sizeof(int)*nactfric_); - - *ne=*ne0;*nkon=*nkon0; - contact(ncont,ntie,tieset,nset,set,istartset,iendset, - ialset,itietri,lakon,ipkon,kon,koncont,ne,cg, - straight,nkon,co,vold,ielmat,cs,elcon,istep, - iinc,iit,ncmat_,ntmat_,ifcont1,ifcont2,ne0, - vini,nmethod,nmpc,mpcfree,memmpc_, - &ipompc,&labmpc,&ikmpc,&ilmpc,&fmpc,&nodempc,&coefmpc, - iperturb,ikboun,nboun,mi,imastop); - - printf("number of contact springs = %d\n",*ne-*ne0); - - for(i=*ne0;i<*ne;i++){ - indexe=ipkon[i]; - imat=ielmat[i]; - kodem=nelcon[2*imat-2]; - for(j=0;j<8;j++){lakonl[j]=lakon[8*i+j];} - nope=atoi(&lakonl[7]); - for(j=0;j -#include -#include -#include -#include "CalculiX.h" - -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif -#ifdef PARDISO - #include "pardiso.h" -#endif - -void dynboun(double *amta,int *namta,int *nam,double *ampli, double *time, - double *ttime,double *dtime,double *xbounold,double *xboun, - double *xbounact,int *iamboun,int *nboun,int *nodeboun, - int *ndirboun, double *ad, double *au, double *adb, - double *aub, int *icol, int *irow, int *neq, int *nzs, - double *sigma, double *b, int *isolver, - double *alpham, double *betam, int *nzl, - int *init,double *bact, double *bmin, int *jq, - char *amname,double *bv, double *bprev, double *bdiff, - int *nactmech, int *icorrect, int *iprev){ - - int idiff[3],i,j,ic,ir; - - double *xbounmin=NULL,*xbounplus=NULL,*bplus=NULL, - *ba=NULL,deltatime,deltatime2,deltatimesq,timemin,ttimemin, - timeplus,ttimeplus,*aux=NULL,*b1=NULL,*b2=NULL,*bnew=NULL; - -#ifdef SGI - int token=1; -#endif - - xbounmin=NNEW(double,*nboun); - xbounplus=NNEW(double,*nboun); - - /* time increment for the calculation of the change of the - particular solution (needed to account for nonzero - SPC's) */ - - deltatime=*dtime; - deltatime2=2.*deltatime; - deltatimesq=deltatime*deltatime; - - /* the SPC value at timemin is stored in xbounmin */ - - if(*init==1){ - - /* at the start of a new step it is assumed that the previous step - has reached steady state (at least for the SPC conditions) */ - - for(i=0;i<*nboun;i++){ - xbounmin[i]=xbounold[i]; - xbounact[i]=xbounold[i]; - } - } - else{ - timemin=*time-deltatime; - ttimemin=*ttime-deltatime; - FORTRAN(temploadmodal,(amta,namta,nam,ampli,&timemin,&ttimemin,dtime, - xbounold,xboun,xbounmin,iamboun,nboun,nodeboun,ndirboun, - amname)); - } - - /* the SPC value at timeplus is stored in xbounplus */ - - timeplus=*time+deltatime; - ttimeplus=*ttime+deltatime; - FORTRAN(temploadmodal,(amta,namta,nam,ampli,&timeplus,&ttimeplus,dtime, - xbounold,xboun,xbounplus,iamboun,nboun,nodeboun,ndirboun, - amname)); - - bplus=NNEW(double,neq[1]); - ba=NNEW(double,neq[1]); - b1=NNEW(double,neq[1]); - b2=NNEW(double,neq[1]); - - /* check whether boundary conditions changed - comparision of min with prev */ - - if(*init==1){ - for(i=0;i<*nboun;i++){ - ic=neq[1]+i; - for(j=jq[ic]-1;j1.e-10){ - idiff[1]=1; - break; - } - } - if(*init==1){ - for(i=0;i<*nboun;i++){ - ic=neq[1]+i; - for(j=jq[ic]-1;j1.e-10){ - idiff[2]=1; - break; - } - } - if(idiff[2]==1){ - for(i=0;i<*nboun;i++){ - ic=neq[1]+i; - for(j=jq[ic]-1;j -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif - -void expand(double *co, int *nk, int *kon, int *ipkon, char *lakon, - int *ne, int *nodeboun, int *ndirboun, double *xboun, int *nboun, - int *ipompc, int *nodempc, double *coefmpc, char *labmpc, - int *nmpc, int *nodeforc, int *ndirforc,double *xforc, - int *nforc, int *nelemload, char *sideload, double *xload, - int *nload, int *nactdof, int *neq, - int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, int *ilboun, - double *elcon, int *nelcon, double *rhcon, int *nrhcon, - double *alcon, int *nalcon, double *alzero, int *ielmat, - int *ielorien, int *norien, double *orab, int *ntmat_, - double *t0,int *ithermal,double *prestr, int *iprestr, - double *vold,int *iperturb, double *sti, int *nzs, - double *adb, double *aub,char *filab, double *eme, - double *plicon, int *nplicon, double *plkcon,int *nplkcon, - double *xstate, int *npmat_, char *matname, int *mi, - int *ics, double *cs, int *mpcend, int *ncmat_, - int *nstate_, int *mcs, int *nkon, double *ener, - char *jobnamec, char *output, char *set, int *nset,int *istartset, - int *iendset, int *ialset, int *nprint, char *prlab, - char *prset, int *nener, double *trab, - int *inotr, int *ntrans, double *ttime, double *fmpc, - int *nev, double *z, int *iamboun, double *xbounold, - int *nsectors, int *nm,int *icol,int *irow,int *nzl, int *nam, - int *ipompcold, int *nodempcold, double *coefmpcold, - char *labmpcold, int *nmpcold, double *xloadold, int *iamload, - double *t1old,double *t1,int *iamt1, double *xstiff,int **icolep, - int **jqep,int **irowep,int *isolver, - int *nzse,double **adbep,double **aubep,int *iexpl,int *ibody, - double *xbody,int *nbody,double *cocon,int *ncocon, - char* tieset,int* ntie, int **nnnp){ - - /* calls the Arnoldi Package (ARPACK) for cyclic symmetry calculations */ - - char *filabt,*tchar1=NULL,*tchar2=NULL,*tchar3=NULL; - - int *inum=NULL,k,idir,lfin,j,iout=0,index,inode,id,i,idof, - ielas,icmd,kk,l,nkt,icntrl,imag=1,icomplex,kkv,kk6,iterm, - lprev,ilength,ij,i1,i2,iel,ielset,node,indexe,nope,ml1, - *inocs=NULL,*ielcs=NULL,jj,l1,l2,is,nlabel,*nshcon=NULL, - nodeleft,*noderight=NULL,numnodes,ileft,kflag=2,itr,locdir, - neqh,j1,nodenew,mass[2]={1,1},stiffness=1,buckling=0,mt=mi[1]+1, - rhsi=0,intscheme=0,coriolis=0,istep=1,iinc=1,iperturbmass[2], - *mast1e=NULL,*ipointere=NULL,*irowe=*irowep,*ipobody=NULL,*jqe=*jqep, - *icole=*icolep,tint=-1,tnstart=-1,tnend=-1,tint2=-1,*nnn=*nnnp, - noderight_; - - long long lint; - - double *stn=NULL,*v=NULL,*temp_array=NULL,*vini=NULL, - *een=NULL,cam[5],*f=NULL,*fn=NULL,qa[3],*epn=NULL,*stiini=NULL, - *xstateini=NULL,theta,pi,*coefmpcnew=NULL,t[3],ctl,stl, - *stx=NULL,*enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL, - *qfx=NULL,*qfn=NULL,xreal,ximag,*vt=NULL,sum,*aux=NULL, - *coefright=NULL,*physcon=NULL,coef,a[9],ratio,reltime,*ade=NULL, - *aue=NULL,*adbe=*adbep,*aube=*aubep,*fext=NULL,*cgr=NULL, - *shcon=NULL; - - /* dummy arguments for the results call */ - - double *veold=NULL,*accold=NULL,bet,gam,dtime,time; - - pi=4.*atan(1.); - - noderight_=10; - noderight=NNEW(int,noderight_); - coefright=NNEW(double,noderight_); - -// v=NNEW(double,10**nk); - v=NNEW(double,2*mt**nk); - vt=NNEW(double,mt**nk**nsectors); - - fn=NNEW(double,2*mt**nk); - stn=NNEW(double,12**nk); - inum=NNEW(int,*nk); - stx=NNEW(double,6*mi[0]**ne); - - nlabel=27; - filabt=NNEW(char,87*nlabel); - for(i=1;i<87*nlabel;i++) filabt[i]=' '; - filabt[0]='U'; - - temp_array=NNEW(double,neq[1]); - coefmpcnew=NNEW(double,*mpcend); - - nkt=*nsectors**nk; - - /* assigning nodes and elements to sectors */ - - inocs=NNEW(int,*nk); - ielcs=NNEW(int,*ne); - ielset=cs[12]; - if((*mcs!=1)||(ielset!=0)){ - for(i=0;i<*nk;i++) inocs[i]=-1; - for(i=0;i<*ne;i++) ielcs[i]=-1; - } - - for(i=0;i<*mcs;i++){ - is=cs[17*i]; - if(is==1) continue; - ielset=cs[17*i+12]; - if(ielset==0) continue; - for(i1=istartset[ielset-1]-1;i10){ - iel=ialset[i1]-1; - if(ipkon[iel]<0) continue; - ielcs[iel]=i; - indexe=ipkon[iel]; - if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; - else {nope=6;} - for(i2=0;i2=ialset[i1-1]-1) break; - if(ipkon[iel]<0) continue; - ielcs[iel]=i; - indexe=ipkon[iel]; - if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; - else {nope=6;} - for(i2=0;i20) inotr[2*l+i*2**nk]=inotr[2*l]; - } - } - for(l=0;l<*nkon;l++){kon[l+i**nkon]=kon[l]+i**nk;} - for(l=0;l<*ne;l++){ - if(ielcs[l]==jj){ - if(ipkon[l]>=0){ - ipkon[l+i**ne]=ipkon[l]+i**nkon; - ielmat[l+i**ne]=ielmat[l]; - if(*norien>0) ielorien[l+i**ne]=ielorien[l]; - for(l1=0;l1<8;l1++){ - l2=8*l+l1; - lakon[l2+i*8**ne]=lakon[l2]; - } - }else{ - ipkon[l+i**ne]=ipkon[l]; - } - } - } - } - } - - icntrl=-1; - - FORTRAN(rectcyl,(co,vt,fn,stn,qfn,een,cs,&nkt,&icntrl,t,filabt,&imag,mi)); - -/* copying the boundary conditions - (SPC's must be defined in cylindrical coordinates) */ - - for(i=1;i<*nsectors;i++){ - for(j=0;j<*nboun;j++){ - nodeboun[i**nboun+j]=nodeboun[j]+i**nk; - ndirboun[i**nboun+j]=ndirboun[j]; - xboun[i**nboun+j]=xboun[j]; - xbounold[i**nboun+j]=xbounold[j]; - if(*nam>0) iamboun[i**nboun+j]=iamboun[j]; - ikboun[i**nboun+j]=ikboun[j]+8*i**nk; - ilboun[i**nboun+j]=ilboun[j]+i**nboun; - } - } - -/* distributed loads */ - - for(i=0;i<*nload;i++){ - if(nelemload[2*i+1]<*nsectors){ - nelemload[2*i]+=*ne*nelemload[2*i+1]; - }else{ - nelemload[2*i]+=*ne*(nelemload[2*i+1]-(*nsectors)); - } - } - - /* sorting the elements with distributed loads */ - - if(*nload>0){ - if(*nam>0){ - FORTRAN(isortiddc2,(nelemload,iamload,xload,xloadold,sideload,nload,&kflag)); - }else{ - FORTRAN(isortiddc1,(nelemload,xload,xloadold,sideload,nload,&kflag)); - } - } - -/* point loads */ - - for(i=0;i<*nforc;i++){ - if(nodeforc[2*i+1]<*nsectors){ - nodeforc[2*i]+=*nk*nodeforc[2*i+1]; - }else{ - nodeforc[2*i]+=*nk*(nodeforc[2*i+1]-(*nsectors)); - } - } - - neqh=neq[1]/2; - -/* expand nactdof */ - - for(i=1;i<*nsectors;i++){ - lint=i*mt**nk; - for(j=0;j-1;--j){ - lint=2*j*neqh; - - /* calculating the cosine and sine of the phase angle */ - - for(jj=0;jj<*mcs;jj++){ - theta=nm[j]*2.*pi/cs[17*jj]; - cs[17*jj+14]=cos(theta); - cs[17*jj+15]=sin(theta); - } - - /* generating the cyclic MPC's (needed for nodal diameters - different from 0 */ - - eei=NNEW(double,6*mi[0]**ne); - - memset(&v[0],0.,sizeof(double)*2*mt**nk); - - for(k=0;k<2*neqh;k+=neqh){ - - for(i=0;i<6*mi[0]**ne;i++){eme[i]=0.;} - - if(k==0) {kk=0;kkv=0;kk6=0;} - else {kk=*nk;kkv=mt**nk;kk6=6**nk;} - for(i=0;i<*nmpc;i++){ - index=ipompc[i]-1; - /* check whether thermal mpc */ - if(nodempc[3*index+1]==0) continue; - coefmpcnew[index]=coefmpc[index]; - while(1){ - index=nodempc[3*index+2]; - if(index==0) break; - index--; - - icomplex=0; - inode=nodempc[3*index]; - if(strcmp1(&labmpc[20*i],"CYCLIC")==0){ - icomplex=atoi(&labmpc[20*i+6]);} - else if(strcmp1(&labmpc[20*i],"SUBCYCLIC")==0){ - for(ij=0;ij<*mcs;ij++){ - lprev=cs[ij*17+13]; - ilength=cs[ij*17+3]; - FORTRAN(nident,(&ics[lprev],&inode,&ilength,&id)); - if(id!=0){ - if(ics[lprev+id-1]==inode){icomplex=ij+1;break;} - } - } - } - - if(icomplex!=0){ - idir=nodempc[3*index+1]; - idof=nactdof[mt*(inode-1)+idir]-1; - if(idof==-1){xreal=1.;ximag=1.;} - else{xreal=z[lint+idof];ximag=z[lint+idof+neqh];} - if(k==0) { - if(fabs(xreal)<1.e-30)xreal=1.e-30; - coefmpcnew[index]=coefmpc[index]* - (cs[17*(icomplex-1)+14]+ - ximag/xreal*cs[17*(icomplex-1)+15]);} - else { - if(fabs(ximag)<1.e-30)ximag=1.e-30; - coefmpcnew[index]=coefmpc[index]* - (cs[17*(icomplex-1)+14]- - xreal/ximag*cs[17*(icomplex-1)+15]);} - } - else{coefmpcnew[index]=coefmpc[index];} - } - } - - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,&v[kkv],&stn[kk6],inum, - stx,elcon, - nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, - norien,orab,ntmat_,t0,t0,ithermal, - prestr,iprestr,filab,eme,&een[kk6],iperturb, - f,&fn[kkv],nactdof,&iout,qa,vold,&z[lint+k], - nodeboun,ndirboun,xboun,nboun,ipompc, - nodempc,coefmpcnew,labmpc,nmpc,nmethod,cam,&neqh,veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,&enern[kk],sti, - xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - - } - free(eei); - - sum=0.; - - /* mapping the results to the other sectors */ - - icntrl=2;imag=1; - - FORTRAN(rectcyl,(co,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filabt,&imag,mi)); - - /* basis sector */ - - for(l=0;l10){ - noderight_=10; - RENEW(noderight,int,noderight_); - RENEW(coefright,double,noderight_); - } - ipompc[*nmpc]=*mpcend+1; - ikmpc[*nmpc]=ikmpc[j]+8*i**nk; - ilmpc[*nmpc]=ilmpc[j]+i**nmpcold; - strcpy1(&labmpc[20**nmpc],&labmpcold[20*j],20); - if(strcmp1(&labmpcold[20*j],"CYCLIC")==0){ - index=ipompcold[j]-1; - nodeleft=nodempcold[3*index]; - idir=nodempcold[3*index+1]; - index=nodempcold[3*index+2]-1; - numnodes=0; - do{ - node=nodempcold[3*index]; - if(nodempcold[3*index+1]==idir){ - noderight[numnodes]=node; - coefright[numnodes]=coefmpcold[index]; - numnodes++; - if(numnodes>=noderight_){ - noderight_=(int)(1.5*noderight_); - RENEW(noderight,int,noderight_); - RENEW(coefright,double,noderight_); - } - } - index=nodempcold[3*index+2]-1; - if(index==-1) break; - }while(1); - if(numnodes>0){ - sum=0.; - for(k=0;k1.e-10){ - ratio=coef/a[3*locdir+idir-1]; - }else{ratio=0.;} - FORTRAN(transformatrix,(&trab[7*itr-7], - &co[3*nodenew-3],a)); - coef=ratio*a[3*locdir+idir-1]; - } - } - } - } - - nodempc[3**mpcend]=nodenew; - nodempc[3**mpcend+1]=idir; - coefmpc[*mpcend]=coef; - index=nodempcold[3*index+2]-1; - if(index==-1) break; - nodempc[3**mpcend+2]=*mpcend+2; - (*mpcend)++; - }while(1); - nodempc[3**mpcend+2]=0; - (*mpcend)++; - } - (*nmpc)++; - } - } - - /* copying the temperatures */ - - if(*ithermal!=0){ - for(i=1;i<*nsectors;i++){ - lint=i**nk; - for(j=0;j<*nk;j++){ - t0[lint+j]=t0[j]; - t1old[lint+j]=t1old[j]; - t1[lint+j]=t1[j]; - } - } - if(*nam>0){ - for(i=1;i<*nsectors;i++){ - lint=i**nk; - for(j=0;j<*nk;j++){ - iamt1[lint+j]=iamt1[j]; - } - } - } - } - - /* copying the contact definition */ - - if(*nmethod==4){ - - /* first find the startposition to append the expanded contact fields*/ - - for(j=0; j<*nset; j++){ - if(iendset[j]>tint){ - tint=iendset[j]; - } - } - tint++; - /* now append and expand the contact definitons*/ - tchar1=NNEW(char,81); - tchar2=NNEW(char,81); - tchar3=NNEW(char,81); - for(i=0; i<*ntie; i++){ - if(tieset[i*(81*3)+80]=='C'){ - memcpy(tchar2,&tieset[i*(81*3)+81],81); - tchar2[80]='\0'; - memcpy(tchar3,&tieset[i*(81*3)+81+81],81); - tchar3[80]='\0'; - //a contact constraint was found, so append and expand the information - for(j=0; j<*nset; j++){ - memcpy(tchar1,&set[j*81],81); - tchar1[80]='\0'; - if(strcmp(tchar1,tchar2)==0){ - /* dependent nodal surface was found,copy the original information first */ - tnstart=tint; - for(k=0; k -#include -#include -#include -#include "CalculiX.h" - -void frdcyc(double *co,int *nk,int *kon,int *ipkon,char *lakon,int *ne,double *v, - double *stn,int *inum,int *nmethod,int *kode,char *filab, - double *een,double *t1,double *fn,double *time,double *epn, - int *ielmat,char *matname, double *cs, int *mcs, int *nkon, - double *enern, double *xstaten, int *nstate_, int *istep, - int *iinc, int *iperturb, double *ener, int *mi, char *output, - int *ithermal, double *qfn, int *ialset, int *istartset, - int *iendset, double *trab, int *inotr, int *ntrans, - double *orab, int *ielorien, int *norien, double *sti, - double *veold, int *noddiam,char *set,int *nset){ - - /* duplicates fields for static cyclic symmetric calculations */ - - char *lakont=NULL,description[13]=" "; - - int nkt,icntrl,*kont=NULL,*ipkont=NULL,*inumt=NULL,*ielmatt=NULL,net,i,l, - imag=0,mode=-1,ngraph,*inocs=NULL,*ielcs=NULL,l1,l2,is, - jj,node,i1,i2,nope,iel,indexe,j,ielset,*inotrt=NULL,mt=mi[1]+1, - *ipneigh=NULL,*neigh=NULL; - - double *vt=NULL,*fnt=NULL,*stnt=NULL,*eent=NULL,*cot=NULL,*t1t=NULL, - *epnt=NULL,*enernt=NULL,*xstatent=NULL,theta,pi,t[3],*qfnt=NULL, - *vr=NULL,*vi=NULL,*stnr=NULL,*stni=NULL,*vmax=NULL,*stnmax=NULL; - - pi=4.*atan(1.); - - /* determining the maximum number of sectors to be plotted */ - - ngraph=1; - for(j=0;j<*mcs;j++){ - if(cs[17*j+4]>ngraph) ngraph=cs[17*j+4]; - } - - /* assigning nodes and elements to sectors */ - - inocs=NNEW(int,*nk); - ielcs=NNEW(int,*ne); - ielset=cs[12]; - if((*mcs!=1)||(ielset!=0)){ - for(i=0;i<*nk;i++) inocs[i]=-1; - for(i=0;i<*ne;i++) ielcs[i]=-1; - } - - for(i=0;i<*mcs;i++){ - is=cs[17*i+4]; - if(is==1) continue; - ielset=cs[17*i+12]; - if(ielset==0) continue; - for(i1=istartset[ielset-1]-1;i10){ - iel=ialset[i1]-1; - if(ipkon[iel]<0) continue; - ielcs[iel]=i; - indexe=ipkon[iel]; - if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; - else {nope=6;} - for(i2=0;i2=ialset[i1-1]-1) break; - if(ipkon[iel]<0) continue; - ielcs[iel]=i; - indexe=ipkon[iel]; - if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; - else {nope=6;} - for(i2=0;i20)inotrt=NNEW(int,2**nk*ngraph); - - if((strcmp1(&filab[0],"U ")==0)|| - ((strcmp1(&filab[87],"NT ")==0)&&(*ithermal>=2))) - vt=NNEW(double,mt**nk*ngraph); - if((strcmp1(&filab[87],"NT ")==0)&&(*ithermal<2)) - t1t=NNEW(double,*nk*ngraph); - if(strcmp1(&filab[174],"S ")==0) - stnt=NNEW(double,6**nk*ngraph); - if(strcmp1(&filab[261],"E ")==0) - eent=NNEW(double,6**nk*ngraph); - if((strcmp1(&filab[348],"RF ")==0)||(strcmp1(&filab[783],"RFL ")==0)) - fnt=NNEW(double,mt**nk*ngraph); - if(strcmp1(&filab[435],"PEEQ")==0) - epnt=NNEW(double,*nk*ngraph); - if(strcmp1(&filab[522],"ENER")==0) - enernt=NNEW(double,*nk*ngraph); - if(strcmp1(&filab[609],"SDV ")==0) - xstatent=NNEW(double,*nstate_**nk*ngraph); - if(strcmp1(&filab[696],"HFL ")==0) - qfnt=NNEW(double,3**nk*ngraph); - - /* the topology only needs duplication the first time it is - stored in the frd file (*kode=1) - the above two lines are not true: lakon is needed for - contact information in frd.f */ - -// if(*kode==1){ - kont=NNEW(int,*nkon*ngraph); - ipkont=NNEW(int,*ne*ngraph); - lakont=NNEW(char,8**ne*ngraph); - ielmatt=NNEW(int,*ne*ngraph); -// } - inumt=NNEW(int,*nk*ngraph); - - nkt=ngraph**nk; - net=ngraph**ne; - - /* copying the coordinates of the first sector */ - - for(l=0;l<3**nk;l++){cot[l]=co[l];} - if(*ntrans>0){for(l=0;l<*nk;l++){inotrt[2*l]=inotr[2*l];}} - - /* copying the topology of the first sector */ - -// if(*kode==1){ - for(l=0;l<*nkon;l++){kont[l]=kon[l];} - for(l=0;l<*ne;l++){ipkont[l]=ipkon[l];} - for(l=0;l<8**ne;l++){lakont[l]=lakon[l];} - for(l=0;l<*ne;l++){ielmatt[l]=ielmat[l];} -// } - - /* generating the coordinates for the other sectors */ - - icntrl=1; - - FORTRAN(rectcyl,(cot,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filab,&imag,mi)); - - for(jj=0;jj<*mcs;jj++){ - is=cs[17*jj+4]; - for(i=1;i0){ - for(l=0;l<*nk;l++){ - if(inocs[l]==jj){ - inotrt[2*l+i*2**nk]=inotrt[2*l]; - } - } - } - - // if(*kode==1){ - - for(l=0;l<*nkon;l++){kont[l+i**nkon]=kon[l]+i**nk;} - for(l=0;l<*ne;l++){ - if(ielcs[l]==jj){ - if(ipkon[l]>=0){ - ipkont[l+i**ne]=ipkon[l]+i**nkon; - ielmatt[l+i**ne]=ielmat[l]; - for(l1=0;l1<8;l1++){ - l2=8*l+l1; - lakont[l2+i*8**ne]=lakon[l2]; - } - } - else ipkont[l+i**ne]=-1; - } - } - // } - } - } - - icntrl=-1; - - FORTRAN(rectcyl,(cot,vt,fnt,stnt,qfnt,eent,cs,&nkt,&icntrl,t,filab, - &imag,mi)); - - /* mapping the results to the other sectors */ - - for(l=0;l<*nk;l++){inumt[l]=inum[l];} - - icntrl=2; - - FORTRAN(rectcyl,(co,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filab,&imag,mi)); - - if((strcmp1(&filab[0],"U ")==0)|| - ((strcmp1(&filab[87],"NT ")==0)&&(*ithermal>=2))) - for(l=0;l=2))){ - for(l1=0;l1<*nk;l1++){ - if(inocs[l1]==jj){ - for(l2=0;l2<4;l2++){ - l=mt*l1+l2; - vt[l+mt**nk*i]=v[l]; - } - } - } - } - - if((strcmp1(&filab[87],"NT ")==0)&&(*ithermal<2)){ - for(l=0;l<*nk;l++){ - if(inocs[l]==jj) t1t[l+*nk*i]=t1[l]; - } - } - - if(strcmp1(&filab[174],"S ")==0){ - for(l1=0;l1<*nk;l1++){ - if(inocs[l1]==jj){ - for(l2=0;l2<6;l2++){ - l=6*l1+l2; - stnt[l+6**nk*i]=stn[l]; - } - } - } - } - - if(strcmp1(&filab[261],"E ")==0){ - for(l1=0;l1<*nk;l1++){ - if(inocs[l1]==jj){ - for(l2=0;l2<6;l2++){ - l=6*l1+l2; - eent[l+6**nk*i]=een[l]; - } - } - } - } - - if((strcmp1(&filab[348],"RF ")==0)||(strcmp1(&filab[783],"RFL ")==0)){ - for(l1=0;l1<*nk;l1++){ - if(inocs[l1]==jj){ - for(l2=0;l2<4;l2++){ - l=mt*l1+l2; - fnt[l+mt**nk*i]=fn[l]; - } - } - } - } - - if(strcmp1(&filab[435],"PEEQ")==0){ - for(l=0;l<*nk;l++){ - if(inocs[l]==jj) epnt[l+*nk*i]=epn[l]; - } - } - - if(strcmp1(&filab[522],"ENER")==0){ - for(l=0;l<*nk;l++){ - if(inocs[l]==jj) enernt[l+*nk*i]=enern[l]; - } - } - - if(strcmp1(&filab[609],"SDV ")==0){ - for(l1=0;l1<*nk;l1++){ - if(inocs[l1]==jj){ - for(l2=0;l2<*nstate_;l2++){ - l=*nstate_*l1+l2; - xstatent[l+*nstate_**nk*i]=xstaten[l]; - } - } - } - } - - if(strcmp1(&filab[696],"HFL ")==0){ - for(l1=0;l1<*nk;l1++){ - if(inocs[l1]==jj){ - for(l2=0;l2<3;l2++){ - l=3*l1+l2; - qfnt[l+3**nk*i]=qfn[l]; - } - } - } - } - } - } - - icntrl=-2; - - FORTRAN(rectcyl,(cot,vt,fnt,stnt,qfnt,eent,cs,&nkt,&icntrl,t,filab, - &imag,mi)); - - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(cot,&nkt,kont,ipkont,lakont,&net,vt,stnt,inumt,nmethod,kode, - filab,eent,t1t,fnt,time,epnt,ielmatt,matname,enernt, - xstatent,nstate_,istep,iinc,iperturb,ener,mi,output, - ithermal,qfnt,&mode,noddiam,trab,inotrt,ntrans,orab,ielorien, - norien,description,ipneigh,neigh,sti,vr,vi,stnr,stni, - vmax,stnmax,&ngraph,veold,&net,cs,set,nset,istartset, - iendset,ialset)); - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - - if((strcmp1(&filab[0],"U ")==0)|| - ((strcmp1(&filab[87],"NT ")==0)&&(*ithermal>=2))) free(vt); - if((strcmp1(&filab[87],"NT ")==0)&&(*ithermal<2)) free(t1t); - if(strcmp1(&filab[174],"S ")==0) free(stnt); - if(strcmp1(&filab[261],"E ")==0) free(eent); - if((strcmp1(&filab[348],"RF ")==0)||(strcmp1(&filab[783],"RFL ")==0)) - free(fnt); - if(strcmp1(&filab[435],"PEEQ")==0) free(epnt); - if(strcmp1(&filab[522],"ENER")==0) free(enernt); - if(strcmp1(&filab[609],"SDV ")==0) free(xstatent); - if(strcmp1(&filab[696],"HFL ")==0) free(qfnt); - -// if(*kode==1){ - free(kont);free(ipkont);free(lakont);free(ielmatt); -// } - free(inumt);free(cot);if(*ntrans>0)free(inotrt); - return; -} - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frd.f calculix-ccx-2.3/ccx_2.1/src/frd.f --- calculix-ccx-2.1/ccx_2.1/src/frd.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1250 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frd(co,nk,kon,ipkon,lakon,ne0,v,stn,inum,nmethod, - & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern,xstaten, - & nstate_,istep,iinc,ithermal,qfn,mode,noddiam,trab,inotr, - & ntrans,orab,ielorien,norien,description,ipneigh,neigh, - & mi,stx,vr,vi,stnr,stni,vmax,stnmax,ngraph,veold,ener,ne, - & cs,set,nset,istartset,iendset,ialset) -! -! stores the results in frd format -! -! iselect selects which nodes are to be stored: -! iselect=-1 means only those nodes for which inum negative -! ist, i.e. network nodes -! iselect=+1 means only those nodes for which inum positive -! ist, i.e. structural nodes -! iselect=0 means both of the above -! - implicit none -! - character*1 c - character*3 m1,m2,m3,m4,m5 - character*5 p0,p1,p2,p3,p4,p5,p6,p8,p10,p11,p12 - character*8 lakon(*),date,newclock,fmat - character*10 clock - character*12 description - character*20 newdate - character*80 matname(*) - character*81 set(*) - character*87 filab(*) - character*132 text -! - integer kon(*),inum(*),nk,ne0,nmethod,kode,i,j,ipkon(*),indexe, - & one,ielmat(*),nstate_,l,ithermal,mode,mi(2),norien, - & noddiam,null,icounter,inotr(2,*),ntrans,ipneigh(*),neigh(2,*), - & ielorien(*),iinc,istep,nkcoords,ngraph,k,nodes,nope,ne, - & nout,nset,istartset(*),iendset(*),ialset(*),iset,m, - & noutloc,ncomp,nksegment,iselect,noutplus,noutmin,ncomma -! - real*8 co(3,*),v(0:mi(2),*),stn(6,*),een(6,*),t1(*),fn(0:mi(2),*), - & time,epn(*),enern(*),xstaten(nstate_,*),pi,qfn(3,*),oner, - & trab(7,*),stx(6,mi(1),*),orab(7,*),vr(0:mi(2),*), - & vi(0:mi(2),*),stnr(6,*),stni(6,*),vmax(0:3,*),stnmax(0:6,*), - & veold(0:mi(2),*),ener(mi(1),*),cs(17,*) -! - data icounter /0/ - save icounter,nkcoords,nout,noutmin,noutplus -! - pi=4.d0*datan(1.d0) -! - c='C' -! - m1=' -1' - m2=' -2' - m3=' -3' - m4=' -4' - m5=' -5' -! - p0=' 0' - p1=' 1' - p2=' 2' - p3=' 3' - p4=' 4' - p5=' 5' - p6=' 6' - p8=' 8' - p10=' 10' - p11=' 11' - p12=' 12' -! - if((time.le.0.d0).or.(nmethod.eq.2)) then - fmat(1:8)='(e12.5) ' - elseif((dlog10(time).ge.0.d0).and.(dlog10(time).lt.10.d0)) then - fmat(1:5)='(f12.' - ncomma=10-int(dlog10(time)+1.d0) - write(fmat(6:6),'(i1)') ncomma - fmat(7:8)=') ' - else - fmat(1:8)='(e12.5) ' - endif -! - null=0 - one=1 - oner=1.d0 -! - if(kode.eq.1) then -! - write(7,'(a5,a1)') p1,c - call date_and_time(date,clock) - newdate(1:20)=' ' - newdate(1:2)=date(7:8) - newdate(3:3)='.' - if(date(5:6).eq.'01') then - newdate(4:11)='january.' - newdate(12:15)=date(1:4) - elseif(date(5:6).eq.'02') then - newdate(4:12)='february.' - newdate(13:16)=date(1:4) - elseif(date(5:6).eq.'03') then - newdate(4:9)='march.' - newdate(10:13)=date(1:4) - elseif(date(5:6).eq.'04') then - newdate(4:9)='april.' - newdate(10:13)=date(1:4) - elseif(date(5:6).eq.'05') then - newdate(4:7)='may.' - newdate(8:11)=date(1:4) - elseif(date(5:6).eq.'06') then - newdate(4:8)='june.' - newdate(9:12)=date(1:4) - elseif(date(5:6).eq.'07') then - newdate(4:8)='july.' - newdate(9:12)=date(1:4) - elseif(date(5:6).eq.'08') then - newdate(4:10)='august.' - newdate(11:14)=date(1:4) - elseif(date(5:6).eq.'09') then - newdate(4:13)='september.' - newdate(14:17)=date(1:4) - elseif(date(5:6).eq.'10') then - newdate(4:11)='october.' - newdate(12:15)=date(1:4) - elseif(date(5:6).eq.'11') then - newdate(4:12)='november.' - newdate(13:16)=date(1:4) - elseif(date(5:6).eq.'12') then - newdate(4:12)='december.' - newdate(13:16)=date(1:4) - endif - newclock(1:2)=clock(1:2) - newclock(3:3)=':' - newclock(4:5)=clock(3:4) - newclock(6:6)=':' - newclock(7:8)=clock(5:6) - write(7,'(a5,''UUSER'')') p1 - write(7,'(a5,''UDATE'',14x,a20)') p1,newdate - write(7,'(a5,''UTIME'',14x,a8)') p1,newclock - write(7,'(a5,''UHOST'')') p1 - write(7,'(a5,''UPGM CalculiX'')') p1 - write(7,'(a5,''UDIR'')') p1 - write(7,'(a5,''UDBN'')') p1 -! -! storing the coordinates of the nodes -! - write(7,'(a5,a1,67x,i1)') p2,c,one -! - if(nmethod.ne.0) then - nout=0 - noutplus=0 - noutmin=0 - do i=1,nk - if(inum(i).eq.0) cycle - write(7,101) m1,i,(co(j,i),j=1,3) - nout=nout+1 - if(inum(i).gt.0) noutplus=noutplus+1 - if(inum(i).lt.0) noutmin=noutmin+1 - enddo - else - do i=1,nk - write(7,101) m1,i,(co(j,i),j=1,3) - enddo - nout=nk - endif -! -! nkcoords is the number of nodes at the time when -! the nodal coordinates are stored in the frd file. -! - nkcoords=nk -! - write(7,'(a3)') m3 -! -! storing the element topology -! - write(7,'(a5,a1,67x,i1)') p3,c,one -! - do i=1,ne0 -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - if((lakon(i)(7:7).eq.' ').or.(filab(1)(5:5).eq.'E').or. - & (lakon(i)(7:7).eq.'I')) then - write(7,'(a3,i10,3a5)') m1,i,p4,p0,matname(ielmat(i))(1:5) - write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,10) - write(7,'(a3,10i10)') m2,(kon(indexe+j),j=11,12), - & (kon(indexe+j),j=17,19),kon(indexe+20), - & (kon(indexe+j),j=13,16) - elseif(lakon(i)(7:7).eq.'B') then - write(7,'(a3,i10,3a5)')m1,i,p12,p0,matname(ielmat(i))(1:5) - write(7,'(a3,3i10)') m2,kon(indexe+21),kon(indexe+23), - & kon(indexe+22) - else - write(7,'(a3,i10,3a5)')m1,i,p10,p0,matname(ielmat(i))(1:5) - write(7,'(a3,8i10)') m2,(kon(indexe+20+j),j=1,8) - endif - elseif(lakon(i)(4:4).eq.'8') then - write(7,'(a3,i10,3a5)') m1,i,p1,p0,matname(ielmat(i))(1:5) - write(7,'(a3,8i10)') m2,(kon(indexe+j),j=1,8) - elseif(lakon(i)(4:5).eq.'10') then - write(7,'(a3,i10,3a5)') m1,i,p6,p0,matname(ielmat(i))(1:5) - write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,10) - elseif(lakon(i)(4:4).eq.'4') then - write(7,'(a3,i10,3a5)') m1,i,p3,p0,matname(ielmat(i))(1:5) - write(7,'(a3,4i10)') m2,(kon(indexe+j),j=1,4) - elseif(lakon(i)(4:5).eq.'15') then - if((lakon(i)(7:7).eq.' ').or.(filab(1)(5:5).eq.'E')) then - write(7,'(a3,i10,3a5)') m1,i,p5,p0,matname(ielmat(i))(1:5) - write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,9), - & kon(indexe+13) - write(7,'(a3,5i10)') m2,(kon(indexe+j),j=14,15), - & (kon(indexe+j),j=10,12) - else - write(7,'(a3,i10,3a5)') m1,i,p8,p0,matname(ielmat(i))(1:5) - write(7,'(a3,6i10)') m2,(kon(indexe+15+j),j=1,6) - endif - elseif(lakon(i)(4:4).eq.'6') then - write(7,'(a3,i10,3a5)') m1,i,p2,p0,matname(ielmat(i))(1:5) - write(7,'(a3,6i10)') m2,(kon(indexe+j),j=1,6) - elseif(lakon(i)(1:1).eq.'D') then - if((kon(indexe+1).eq.0).or.(kon(indexe+3).eq.0)) cycle - write(7,'(a3,i10,3a5)')m1,i,p12,p0,matname(ielmat(i))(1:5) - write(7,'(a3,3i10)') m2,kon(indexe+1),kon(indexe+3), - & kon(indexe+2) - elseif((lakon(i)(1:1).eq.'E').and.(lakon(i)(7:7).eq.'A'))then - write(7,'(a3,i10,3a5)')m1,i,p11,p0,matname(ielmat(i))(1:5) - write(7,'(a3,2i10)') m2,(kon(indexe+j),j=1,2) - endif -! - enddo -! - write(7,'(a3)') m3 -! - if(nmethod.eq.0) return - endif -! -! for cyclic symmetry frequency calculations only results -! for even numbers (= odd modes, numbering starts at 0)are stored -! - if(((nmethod.eq.2).or.(nmethod.eq.5)).and.((mode/2)*2.ne.mode) - & .and.(noddiam.ge.0))return -! -! storing the displacements of the nodes -! - if(filab(1)(1:4).eq.'U ') then -! - iselect=1 - call frdset(filab(1),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 DISP 4 1' - write(7,'(a132)') text - text=' -5 D1 1 2 1 0' - write(7,'(a132)') text - text=' -5 D2 1 2 2 0' - write(7,'(a132)') text - text=' -5 D3 1 2 3 0' - write(7,'(a132)') text - text=' -5 ALL 1 2 0 0 1ALL' - write(7,'(a132)') text -! - call frdvector(v,iset,ntrans,filab(1),nkcoords,inum,m1,inotr, - & trab,co,istartset,iendset,ialset,mi,ngraph) -! - write(7,'(a3)') m3 - endif -! -! storing the imaginary part of displacements of the nodes -! for the odd modes of cyclic symmetry calculations -! - if(noddiam.ge.0) then - if(filab(1)(1:4).eq.'U ') then -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 DISP 4 1' - write(7,'(a132)') text - text=' -5 D1 1 2 1 0' - write(7,'(a132)') text - text=' -5 D2 1 2 2 0' - write(7,'(a132)') text - text=' -5 D3 1 2 3 0' - write(7,'(a132)') text - text=' -5 ALL 1 2 0 0 1ALL' - write(7,'(a132)') text -! -c call frdvector(v((mi(2)+1)*nk,1),iset,ntrans,filab,nkcoords, -c & inum,m1,inotr,trab,co,istartset,iendset,ialset,mi,ngraph) - call frdvector(v(0,nk+1),iset,ntrans,filab(1),nkcoords, - & inum,m1,inotr,trab,co,istartset,iendset,ialset,mi,ngraph) -! - write(7,'(a3)') m3 - endif - endif -! -! storing the velocities of the nodes -! - if(filab(21)(1:4).eq.'V ') then -! - iselect=1 - call frdset(filab(21),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 VELO 4 1' - write(7,'(a132)') text - text=' -5 V1 1 2 1 0' - write(7,'(a132)') text - text=' -5 V2 1 2 2 0' - write(7,'(a132)') text - text=' -5 V3 1 2 3 0' - write(7,'(a132)') text - text=' -5 ALL 1 2 0 0 1ALL' - write(7,'(a132)') text -! - call frdvector(veold,iset,ntrans,filab(21),nkcoords,inum,m1, - & inotr,trab,co,istartset,iendset,ialset,mi,ngraph) -! - write(7,'(a3)') m3 - endif -! -! storing the temperatures in the nodes -! - if(filab(2)(1:4).eq.'NT ') then -! - iselect=0 - call frdset(filab(2),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 NDTEMP 1 1' - write(7,'(a132)') text - text=' -5 T 1 1 0 0' - write(7,'(a132)') text -! - if(ithermal.le.1) then - call frdscalar(t1,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ngraph,iselect) - else - ncomp=0 - call frdvectorcomp(v,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) - endif -! - write(7,'(a3)') m3 - endif -! -! storing the stresses in the nodes -! - if(filab(3)(1:4).eq.'S ') then -! - iselect=1 - call frdset(filab(3),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 STRESS 6 1' - write(7,'(a132)') text - text=' -5 SXX 1 4 1 1' - write(7,'(a132)') text - text=' -5 SYY 1 4 2 2' - write(7,'(a132)') text - text=' -5 SZZ 1 4 3 3' - write(7,'(a132)') text - text=' -5 SXY 1 4 1 2' - write(7,'(a132)') text - text=' -5 SYZ 1 4 2 3' - write(7,'(a132)') text - text=' -5 SZX 1 4 3 1' - write(7,'(a132)') text -! - call frdtensor(stn,iset,nkcoords,inum,m1,istartset,iendset, - & ialset,ngraph) -! - write(7,'(a3)') m3 - endif -! -! storing the imaginary part of the stresses in the nodes -! for the odd modes of cyclic symmetry calculations -! - if(noddiam.ge.0) then - if(filab(3)(1:4).eq.'S ') then -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 STRESS 6 1' - write(7,'(a132)') text - text=' -5 SXX 1 4 1 1' - write(7,'(a132)') text - text=' -5 SYY 1 4 2 2' - write(7,'(a132)') text - text=' -5 SZZ 1 4 3 3' - write(7,'(a132)') text - text=' -5 SXY 1 4 1 2' - write(7,'(a132)') text - text=' -5 SYZ 1 4 2 3' - write(7,'(a132)') text - text=' -5 SZX 1 4 3 1' - write(7,'(a132)') text -! - call frdtensor(stn(1,nk+1),iset,nkcoords,inum,m1,istartset, - & iendset,ialset,ngraph,ntrans,filab(3),trab,co,inotr) -! - write(7,'(a3)') m3 - endif - endif -! -! storing the strains in the nodes -! - if(filab(4)(1:4).eq.'E ') then -! - iselect=1 - call frdset(filab(4),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 STRAIN 6 1' - write(7,'(a132)') text - text=' -5 EXX 1 4 1 1' - write(7,'(a132)') text - text=' -5 EYY 1 4 2 2' - write(7,'(a132)') text - text=' -5 EZZ 1 4 3 3' - write(7,'(a132)') text - text=' -5 EXY 1 4 1 2' - write(7,'(a132)') text - text=' -5 EYZ 1 4 2 3' - write(7,'(a132)') text - text=' -5 EZX 1 4 3 1' - write(7,'(a132)') text -! - call frdtensor(een,iset,nkcoords,inum,m1,istartset,iendset, - & ialset,ngraph,ntrans,filab(4),trab,co,inotr) -! - write(7,'(a3)') m3 - endif -! -! storing the forces in the nodes -! - if(filab(5)(1:4).eq.'RF ') then -! - iselect=1 - call frdset(filab(5),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 FORC 4 1' - write(7,'(a132)') text - text=' -5 F1 1 2 1 0' - write(7,'(a132)') text - text=' -5 F2 1 2 2 0' - write(7,'(a132)') text - text=' -5 F3 1 2 3 0' - write(7,'(a132)') text - text=' -5 ALL 1 2 0 0 1ALL' - write(7,'(a132)') text -! - call frdvector(fn,iset,ntrans,filab(5),nkcoords,inum,m1,inotr, - & trab,co,istartset,iendset,ialset,mi,ngraph) -! - write(7,'(a3)') m3 - endif -! -! storing the equivalent plastic strains in the nodes -! - if(filab(6)(1:4).eq.'PEEQ') then -! - iselect=1 - call frdset(filab(6),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 PE 1 1' - write(7,'(a132)') text - text=' -5 PE 1 1 0 0' - write(7,'(a132)') text -! - call frdscalar(epn,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ngraph,iselect) -! - write(7,'(a3)') m3 - endif -! -! storing the energy in the nodes -! - if(filab(7)(1:4).eq.'ENER') then -! - iselect=1 - call frdset(filab(7),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 ENER 1 1' - write(7,'(a132)') text - text=' -5 ENER 1 1 0 0' - write(7,'(a132)') text -! - call frdscalar(enern,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ngraph,iselect) -! - write(7,'(a3)') m3 - endif -! -! storing the contact informations at the nodes -! with CDIS,CSTR -! - if(filab(26)(1:4).eq.'CONT') then -! - do i=ne,1,-1 - if((lakon(i)(2:2).ne.'S').or. - & (lakon(i)(7:7).ne.'C')) exit - enddo - noutloc=ne-i -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 CONTACT 6 1' - write(7,'(a132)') text - text=' -5 CD1 1 4 1 1' - write(7,'(a132)') text - text=' -5 CD2 1 4 2 2' - write(7,'(a132)') text - text=' -5 CD3 1 4 3 3' - write(7,'(a132)') text - text=' -5 CS1 1 4 1 2' - write(7,'(a132)') text - text=' -5 CS2 1 4 2 3' - write(7,'(a132)') text - text=' -5 CS3 1 4 3 1' - write(7,'(a132)') text -! - do i=ne,1,-1 - if((lakon(i)(2:2).ne.'S').or. - & (lakon(i)(7:7).ne.'C')) exit - read(lakon(i)(8:8),'(i1)') nope - nodes=kon(ipkon(i)+nope) - write(7,101) m1,nodes,(stx(j,1,i),j=1,6) - enddo -! - write(7,'(a3)') m3 - endif -! -! storing the contact energy in the nodes -! - if(filab(27)(1:4).eq.'CELS') then -! - do i=ne,1,-1 - if((lakon(i)(2:2).ne.'S').or. - & (lakon(i)(7:7).ne.'C')) exit - enddo - noutloc=ne-i -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 CELS 1 1' - write(7,'(a132)') text - text=' -5 CELS 1 1 0 0' - write(7,'(a132)') text -! - do i=ne,1,-1 - if((lakon(i)(2:2).ne.'S').or. - & (lakon(i)(7:7).ne.'C')) exit - read(lakon(i)(8:8),'(i1)') nope - nodes=kon(ipkon(i)+nope) - write(7,101) m1,nodes,ener(1,i) - enddo -! - write(7,'(a3)') m3 - endif -! -! storing the internal state variables in the nodes -! - if(filab(8)(1:4).eq.'SDV ') then -! - iselect=1 - call frdset(filab(8),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 SDV 6 1' - if(nstate_.le.9) then - write(text(18:18),'(i1)') nstate_ - else - write(text(17:18),'(i2)') nstate_ - endif - write(7,'(a132)') text - do j=1,nstate_ - text=' -5 SDV 1 1 0 0' - if(j.le.9) then - write(text(9:9),'(i1)') j - else - write(text(9:10),'(i2)') j - endif - write(7,'(a132)') text - enddo -! - if(iset.eq.0) then - do i=1,nkcoords - if(inum(i).le.0) cycle - do k=1,int((nstate_+5)/6) - if(k.eq.1) then - write(7,101) m1,i,(xstaten(j,i),j=1,min(6,nstate_)) - else - write(7,102) m2,(xstaten(j,i),j=(k-1)*6+1, - & min(k*6,nstate_)) - endif - enddo - enddo - else - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - i=ialset(k) - if(inum(i).le.0) cycle - do l=1,int((nstate_+5)/6) - if(l.eq.1) then - write(7,101) m1,i, - & (xstaten(j,i),j=1,min(6,nstate_)) - else - write(7,102) m2,(xstaten(j,i),j=(l-1)*6+1, - & min(l*6,nstate_)) - endif - enddo - else - i=ialset(k-2) - do - i=i-ialset(k) - if(i.ge.ialset(k-1)) exit - if(inum(i).le.0) cycle - do l=1,int((nstate_+5)/6) - if(l.eq.1) then - write(7,101) m1,i, - & (xstaten(j,i),j=1,min(6,nstate_)) - else - write(7,102) m2,(xstaten(j,i),j=(l-1)*6+1, - & min(l*6,nstate_)) - endif - enddo - enddo - endif - enddo - endif -! - write(7,'(a3)') m3 - endif -! -! storing the heat flux in the nodes -! - if((filab(9)(1:4).eq.'HFL ').and.(ithermal.gt.1)) then -! - iselect=1 - call frdset(filab(9),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! -c text= -c & ' 100CL .00000E+00 3 1' -c write(text(25:36),'(i12)') nout -c text(37:48)=description -c text(75:75)='1' -c write(text(8:12),'(i5)') 100+kode -c write(text(13:24),fmat) time -c write(text(59:63),'(i5)') kode -c write(7,'(a132)') text - text=' -4 FLUX 4 1' - write(7,'(a132)') text - text=' -5 F1 1 2 1 0' - write(7,'(a132)') text - text=' -5 F2 1 2 2 0' - write(7,'(a132)') text - text=' -5 F3 1 2 3 0' - write(7,'(a132)') text - text=' -5 ALL 1 2 0 0 1ALL' - write(7,'(a132)') text -! - if(iset.eq.0) then - do i=1,nkcoords - if(inum(i).le.0) cycle - write(7,101) m1,i,(qfn(j,i),j=1,3) - enddo - else - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - i=ialset(k) - if(inum(i).le.0) cycle - write(7,101) m1,i,(qfn(j,i),j=1,3) - else - i=ialset(k-2) - do - i=i-ialset(k) - if(i.ge.ialset(k-1)) exit - if(inum(i).le.0) cycle - write(7,101) m1,i,(qfn(j,i),j=1,3) - enddo - endif - enddo - endif -! - write(7,'(a3)') m3 - endif -! -! storing the heat generation in the nodes -! - if((filab(10)(1:4).eq.'RFL ').and.(ithermal.gt.1)) then -! - iselect=1 - call frdset(filab(10),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! -c text= -c & ' 100CL .00000E+00 3 1' -c write(text(25:36),'(i12)') nout -c text(37:48)=description -c text(75:75)='1' -c write(text(8:12),'(i5)') 100+kode -c write(text(13:24),fmat) time -c write(text(59:63),'(i5)') kode -c write(7,'(a132)') text - text=' -4 RFL 1 1' - write(7,'(a132)') text - text=' -5 RFL 1 1 0 0' - write(7,'(a132)') text -! - ncomp=0 - call frdvectorcomp(fn,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) -! - write(7,'(a3)') m3 - endif -! -! storing the stress errors in the nodes -! - if(filab(13)(1:3).eq.'ZZS') then -! - call estimator(co,nk,kon,ipkon,lakon,ne0,stn, - & ipneigh,neigh,stx,mi(1)) -! - iselect=1 - call frdset(filab(13),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 ZZSTR 6 1' - write(7,'(a132)') text - text=' -5 SXX 1 4 1 1' - write(7,'(a132)') text - text=' -5 SYY 1 4 2 2' - write(7,'(a132)') text - text=' -5 SZZ 1 4 3 3' - write(7,'(a132)') text - text=' -5 SXY 1 4 1 2' - write(7,'(a132)') text - text=' -5 SYZ 1 4 2 3' - write(7,'(a132)') text - text=' -5 SZX 1 4 3 1' - write(7,'(a132)') text -! - call frdtensor(stn,iset,nkcoords,inum,m1,istartset,iendset, - & ialset,ngraph,ntrans,filab(13),trab,co,inotr) -! - write(7,'(a3)') m3 - endif -! -! storing the total temperature in the fluid nodes -! - if(filab(14)(1:4).eq.'TT ') then -! - iselect=-1 - call frdset(filab(14),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 TOTEMP 1 1' - write(7,'(a132)') text - text=' -5 TT 1 1 0 0' - write(7,'(a132)') text -! - ncomp=0 - call frdvectorcomp(v,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) -! - write(7,'(a3)') m3 - endif -! -! storing the mass flow in the fluid nodes -! - if(filab(15)(1:4).eq.'MF ') then -! - iselect=-1 - call frdset(filab(15),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 MAFLOW 1 1' - write(7,'(a132)') text - text=' -5 MF 1 1 0 0' - write(7,'(a132)') text -! - ncomp=1 - call frdvectorcomp(v,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) -! - write(7,'(a3)') m3 - endif -! -! storing the total pressure in the fluid nodes -! - if(filab(16)(1:4).eq.'PT ') then -! - iselect=-1 - call frdset(filab(16),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 TOPRES 1 1' - write(7,'(a132)') text - text=' -5 PT 1 1 0 0' - write(7,'(a132)') text -! - ncomp=2 - call frdvectorcomp(v,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) -! - write(7,'(a3)') m3 - endif -! -! storing the static temperature in the fluid nodes -! - if(filab(17)(1:4).eq.'TS ') then -! - iselect=-1 - call frdset(filab(17),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 STTEMP 1 1' - write(7,'(a132)') text - text=' -5 TS 1 1 0 0' - write(7,'(a132)') text -! - ncomp=3 - call frdvectorcomp(v,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) -! - write(7,'(a3)') m3 - endif -! -c if((nmethod.ne.2).and.(nmethod.lt.4)) return -! -! the remaining lines only apply to frequency calculations -! with cyclic symmetry and steady state calculations -! - if((nmethod.ne.2).and.(nmethod.ne.5)) return -! -! storing the displacements of the nodes (magnitude, phase) -! - if(filab(11)(1:4).eq.'PU ') then -! - iselect=1 - call frdset(filab(11),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 PDISP 6 1' - write(7,'(a132)') text - text=' -5 MAG1 1 12 1 0' - write(7,'(a132)') text - text=' -5 MAG2 1 12 2 0' - write(7,'(a132)') text - text=' -5 MAG3 1 12 3 0' - write(7,'(a132)') text - text=' -5 PHA1 1 12 4 0' - write(7,'(a132)') text - text=' -5 PHA2 1 12 5 0' - write(7,'(a132)') text - text=' -5 PHA3 1 12 6 0' - write(7,'(a132)') text -! - if(iset.eq.0) then - do i=1,nkcoords - if(inum(i).eq.0) cycle - write(7,101) m1,i,(vr(j,i),j=1,3),(vi(j,i),j=1,3) - enddo - else - nksegment=nkcoords/ngraph - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - do l=0,ngraph-1 - i=ialset(k)+l*nksegment - if(inum(i).eq.0) cycle - write(7,101) m1,i,(vr(j,i),j=1,3),(vi(j,i),j=1,3) - enddo - else - l=ialset(k-2) - do - l=l-ialset(k) - if(l.ge.ialset(k-1)) exit - do m=0,ngraph-1 - i=l+m*nksegment - if(inum(i).eq.0) cycle - write(7,101) m1,i,(vr(j,i),j=1,3), - & (vi(j,i),j=1,3) - enddo - enddo - endif - enddo - endif -! - write(7,'(a3)') m3 - endif -! -! storing the temperatures of the nodes (magnitude,phase) -! - if(filab(12)(1:4).eq.'PNT ') then -! - iselect=1 - call frdset(filab(12),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 PNDTEMP 2 1' - write(7,'(a132)') text - text=' -5 MAG1 1 1 1 0' - write(7,'(a132)') text - text=' -5 PHA1 1 1 2 0' - write(7,'(a132)') text -! - if(iset.eq.0) then - do i=1,nkcoords - if(inum(i).eq.0) cycle - write(7,101) m1,i,vr(0,i),vi(0,i) - enddo - else - nksegment=nkcoords/ngraph - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - do l=0,ngraph-1 - i=ialset(k)+l*nksegment - if(inum(i).eq.0) cycle - write(7,101) m1,i,vr(0,i),vi(0,i) - enddo - else - l=ialset(k-2) - do - l=l-ialset(k) - if(l.ge.ialset(k-1)) exit - do m=0,ngraph-1 - i=l+m*nksegment - if(inum(i).eq.0) cycle - write(7,101) m1,i,vr(0,i),vi(0,i) - enddo - enddo - endif - enddo - endif -! - write(7,'(a3)') m3 - endif -! - if(nmethod.ne.2) return -! -! storing the stresses in the nodes (magnitude,phase) -! - if(filab(18)(1:4).eq.'PHS ') then -! - iselect=1 - call frdset(filab(18),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 PSTRESS 12 1' - write(7,'(a132)') text - text=' -5 MAGXX 1 4 1 1' - write(7,'(a132)') text - text=' -5 MAGYY 1 4 2 2' - write(7,'(a132)') text - text=' -5 MAGZZ 1 4 3 3' - write(7,'(a132)') text - text=' -5 MAGXY 1 4 1 2' - write(7,'(a132)') text - text=' -5 MAGYZ 1 4 2 3' - write(7,'(a132)') text - text=' -5 MAGZX 1 4 3 1' - write(7,'(a132)') text - text=' -5 PHAXX 1 4 1 1' - write(7,'(a132)') text - text=' -5 PHAYY 1 4 2 2' - write(7,'(a132)') text - text=' -5 PHAZZ 1 4 3 3' - write(7,'(a132)') text - text=' -5 PHAXY 1 4 1 2' - write(7,'(a132)') text - text=' -5 PHAYZ 1 4 2 3' - write(7,'(a132)') text - text=' -5 PHAZX 1 4 3 1' - write(7,'(a132)') text -! - if(iset.eq.0) then - do i=1,nkcoords - if(inum(i).le.0) cycle - write(7,101) m1,i,(stnr(j,i),j=1,4), - & stnr(6,i),stnr(5,i) - write(7,101) m2,i,(stni(j,i),j=1,4), - & stni(6,i),stni(5,i) - enddo - else - nksegment=nkcoords/ngraph - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - do l=0,ngraph-1 - i=ialset(k)+l*nksegment - if(inum(i).le.0) cycle - write(7,101) m1,i,(stnr(j,i),j=1,4), - & stnr(6,i),stnr(5,i) - write(7,101) m2,i,(stni(j,i),j=1,4), - & stni(6,i),stni(5,i) - enddo - else - l=ialset(k-2) - do - l=l-ialset(k) - if(l.ge.ialset(k-1)) exit - do m=0,ngraph-1 - i=l+m*nksegment - if(inum(i).le.0) cycle - write(7,101) m1,i,(stnr(j,i),j=1,4), - & stnr(6,i),stnr(5,i) - write(7,101) m2,i,(stni(j,i),j=1,4), - & stni(6,i),stni(5,i) - enddo - enddo - endif - enddo - endif -! - write(7,'(a3)') m3 - endif -! -! storing the maximum displacements of the nodes -! in the basis sector -! (magnitude, components) -! - if(filab(19)(1:4).eq.'MAXU') then -! - iselect=1 - call frdset(filab(19),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 MDISP 4 1' - write(7,'(a132)') text - text=' -5 DX 1 4 1 0' - write(7,'(a132)') text - text=' -5 DY 1 4 2 0' - write(7,'(a132)') text - text=' -5 DZ 1 4 3 0' - write(7,'(a132)') text - text=' -5 ANG 1 4 4 0' - write(7,'(a132)') text -! - if(iset.eq.0) then - do i=1,nkcoords - if(inum(i).eq.0) cycle - write(7,101) m1,i,(vmax(j,i),j=1,3),vmax(0,i) - enddo - else - nksegment=nkcoords/ngraph - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - do l=0,ngraph-1 - i=ialset(k)+l*nksegment - if(inum(i).eq.0) cycle - write(7,101) m1,i,(vmax(j,i),j=1,3),vmax(0,i) - enddo - else - l=ialset(k-2) - do - l=l-ialset(k) - if(l.ge.ialset(k-1)) exit - do m=0,ngraph-1 - i=l+m*nksegment - if(inum(i).eq.0) cycle - write(7,101) m1,i,(vmax(j,i),j=1,3),vmax(0,i) - enddo - enddo - endif - enddo - endif -! - write(7,'(a3)') m3 - endif -! -! storing the worst principal stress at the nodes -! in the basis sector (components, magnitude) -! -! the worst principal stress is the maximum of the -! absolute value of all principal stresses -! - if(filab(20)(1:4).eq.'MAXS') then -! - iselect=1 - call frdset(filab(20),set,iset,istartset,iendset,ialset, - & inum,noutloc,nout,nset,noutmin,noutplus,iselect) -! - call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! - text=' -4 MSTRESS 7 1' - write(7,'(a132)') text - text=' -5 SXX 1 4 1 1' - write(7,'(a132)') text - text=' -5 SYY 1 4 2 2' - write(7,'(a132)') text - text=' -5 SZZ 1 4 3 3' - write(7,'(a132)') text - text=' -5 SXY 1 4 1 2' - write(7,'(a132)') text - text=' -5 SYZ 1 4 2 3' - write(7,'(a132)') text - text=' -5 SZX 1 4 3 1' - write(7,'(a132)') text - text=' -5 MAG 1 4 0 0' - write(7,'(a132)') text -! - if(iset.eq.0) then - do i=1,nkcoords - if(inum(i).le.0) cycle - write(7,101) m1,i,(stnmax(j,i),j=1,4), - & stnmax(6,i),stnmax(5,i) - write(7,101) m2,i,stnmax(0,i) - enddo - else - nksegment=nkcoords/ngraph - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - do l=0,ngraph-1 - i=ialset(k)+l*nksegment - if(inum(i).le.0) cycle - write(7,101) m1,i,(stnmax(j,i),j=1,4), - & stnmax(6,i),stnmax(5,i) - write(7,101) m2,i,stnmax(0,i) - enddo - else - l=ialset(k-2) - do - l=l-ialset(k) - if(l.ge.ialset(k-1)) exit - do m=0,ngraph-1 - i=l+m*nksegment - if(inum(i).le.0) cycle - write(7,101) m1,i,(stnmax(j,i),j=1,4), - & stnmax(6,i),stnmax(5,i) - write(7,101) m2,i,stnmax(0,i) - enddo - enddo - endif - enddo - endif -! - write(7,'(a3)') m3 - endif - -! - 101 format(a3,i10,1p,6e12.5) - 102 format(a3,10x,1p,6e12.5) -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frdfluid.f calculix-ccx-2.3/ccx_2.1/src/frdfluid.f --- calculix-ccx-2.1/ccx_2.1/src/frdfluid.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frdfluid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,585 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frdfluid(co,nk,kon,ipkon,lakon,ne,v,vold, - & kode,time,ielmat,matname,nnstep,vtu,voldtu,voldaux, - & physcon,filab,inomat,ntrans,inotr,trab,mi) -! -! stores the results in frd format -! - implicit none -! - character*1 c - character*3 m1,m2,m3,m4,m5 - character*5 p0,p1,p2,p3,p4,p5,p6,p8,p10,p11,p12 - character*8 lakon(*),date,newclock,fmat - character*10 clock - character*20 newdate - character*80 matname(*) - character*87 filab(*) - character*132 text -! - integer kon(*),nk,ne,kode,i,j,ipkon(*),indexe,inomat(*), - & one,ielmat(*),null,nnstep,inotr(2,*),ntrans,mi(2) -! - real*8 co(3,*),v(0:mi(2),*),time,vold(0:mi(2),*),vtu(2,*), - & voldtu(2,*), - & pi,oner,voldaux(0:4,*),physcon(*),trab(7,*),a(3,3) -! - kode=kode+1 - pi=4.d0*datan(1.d0) -! - c='C' -! - m1=' -1' - m2=' -2' - m3=' -3' - m4=' -4' - m5=' -5' -! - p0=' 0' - p1=' 1' - p2=' 2' - p3=' 3' - p4=' 4' - p5=' 5' - p6=' 6' - p8=' 8' - p10=' 10' - p11=' 11' - p12=' 12' -! - if(time.le.0.d0) then - fmat(1:8)='(e12.5) ' - elseif((dlog10(time).ge.0.d0).and.(dlog10(time).lt.11.d0)) then - fmat(1:5)='(f12.' - write(fmat(6:7),'(i2)') 11-int(dlog10(time)+1.d0) - fmat(8:8)=')' - else - fmat(1:8)='(e12.5) ' - endif -! - null=0 - one=1 - oner=1.d0 -! - if(kode.eq.1) then -! - write(7,'(a5,a1)') p1,c - call date_and_time(date,clock) - newdate(1:20)=' ' - newdate(1:2)=date(7:8) - newdate(3:3)='.' - if(date(5:6).eq.'01') then - newdate(4:11)='january.' - newdate(12:15)=date(1:4) - elseif(date(5:6).eq.'02') then - newdate(4:12)='february.' - newdate(13:16)=date(1:4) - elseif(date(5:6).eq.'03') then - newdate(4:9)='march.' - newdate(10:13)=date(1:4) - elseif(date(5:6).eq.'04') then - newdate(4:9)='april.' - newdate(10:13)=date(1:4) - elseif(date(5:6).eq.'05') then - newdate(4:7)='may.' - newdate(8:11)=date(1:4) - elseif(date(5:6).eq.'06') then - newdate(4:8)='june.' - newdate(9:12)=date(1:4) - elseif(date(5:6).eq.'07') then - newdate(4:8)='july.' - newdate(9:12)=date(1:4) - elseif(date(5:6).eq.'08') then - newdate(4:10)='august.' - newdate(11:14)=date(1:4) - elseif(date(5:6).eq.'09') then - newdate(4:13)='september.' - newdate(14:17)=date(1:4) - elseif(date(5:6).eq.'10') then - newdate(4:11)='october.' - newdate(12:15)=date(1:4) - elseif(date(5:6).eq.'11') then - newdate(4:12)='november.' - newdate(13:16)=date(1:4) - elseif(date(5:6).eq.'12') then - newdate(4:12)='december.' - newdate(13:16)=date(1:4) - endif - newclock(1:2)=clock(1:2) - newclock(3:3)=':' - newclock(4:5)=clock(3:4) - newclock(6:6)=':' - newclock(7:8)=clock(5:6) - write(7,'(a5,''UUSER'')') p1 - write(7,'(a5,''UDATE'',14x,a20)') p1,newdate - write(7,'(a5,''UTIME'',14x,a8)') p1,newclock - write(7,'(a5,''UHOST'')') p1 - write(7,'(a5,''UPGM CalculiX'')') p1 - write(7,'(a5,''UDIR'')') p1 - write(7,'(a5,''UDBN'')') p1 -! -! storing the coordinates of the nodes -! - write(7,'(a5,a1,67x,i1)') p2,c,one -! - do i=1,nk - write(7,100) m1,i,(co(j,i),j=1,3) - enddo -! - write(7,'(a3)') m3 -! -! storing the element topology -! - write(7,'(a5,a1,67x,i1)') p3,c,one -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - if((lakon(i)(7:7).eq.' ').or. - & (lakon(i)(7:7).eq.'H')) then - write(7,'(a3,i10,3a5)') m1,i,p4,p0,matname(ielmat(i))(1:5) - write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,10) - write(7,'(a3,10i10)') m2,(kon(indexe+j),j=11,12), - & (kon(indexe+j),j=17,19),kon(indexe+20), - & (kon(indexe+j),j=13,16) - elseif(lakon(i)(7:7).eq.'B') then - write(7,'(a3,i10,3a5)')m1,i,p12,p0,matname(ielmat(i))(1:5) - write(7,'(a3,3i10)') m2,kon(indexe+21),kon(indexe+23), - & kon(indexe+22) - else - write(7,'(a3,i10,3a5)')m1,i,p10,p0,matname(ielmat(i))(1:5) - write(7,'(a3,8i10)') m2,(kon(indexe+20+j),j=1,8) - endif - elseif(lakon(i)(4:4).eq.'8') then - write(7,'(a3,i10,3a5)') m1,i,p1,p0,matname(ielmat(i))(1:5) - write(7,'(a3,8i10)') m2,(kon(indexe+j),j=1,8) - elseif(lakon(i)(4:5).eq.'10') then - write(7,'(a3,i10,3a5)') m1,i,p6,p0,matname(ielmat(i))(1:5) - write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,10) - elseif(lakon(i)(4:4).eq.'4') then - write(7,'(a3,i10,3a5)') m1,i,p3,p0,matname(ielmat(i))(1:5) - write(7,'(a3,4i10)') m2,(kon(indexe+j),j=1,4) - elseif(lakon(i)(4:5).eq.'15') then - if((lakon(i)(7:7).eq.' ')) then - write(7,'(a3,i10,3a5)') m1,i,p5,p0,matname(ielmat(i))(1:5) - write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,9), - & kon(indexe+13) - write(7,'(a3,5i10)') m2,(kon(indexe+j),j=14,15), - & (kon(indexe+j),j=10,12) - else - write(7,'(a3,i10,3a5)') m1,i,p8,p0,matname(ielmat(i))(1:5) - write(7,'(a3,6i10)') m2,(kon(indexe+15+j),j=1,6) - endif - elseif(lakon(i)(4:4).eq.'6') then - write(7,'(a3,i10,3a5)') m1,i,p2,p0,matname(ielmat(i))(1:5) - write(7,'(a3,6i10)') m2,(kon(indexe+j),j=1,6) - elseif(lakon(i)(1:1).eq.'D') then - if((kon(indexe+1).eq.0).or.(kon(indexe+3).eq.0)) cycle - write(7,'(a3,i10,3a5)')m1,i,p12,p0,matname(ielmat(i))(1:5) - write(7,'(a3,3i10)') m2,kon(indexe+1),kon(indexe+3), - & kon(indexe+2) - elseif(lakon(i)(1:1).eq.'E') then - write(7,'(a3,i10,3a5)')m1,i,p11,p0,matname(ielmat(i))(1:5) - write(7,'(a3,2i10)') m2,(kon(indexe+j),j=1,2) - endif -! - enddo -! - write(7,'(a3)') m3 -! - endif -! -! storing the velocities in the nodes -! - if((nnstep.eq.1).or.(nnstep.eq.3)) then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 DFVEL 4 1' - write(7,'(a132)') text - text=' -5 V1 1 2 1 0' - write(7,'(a132)') text - text=' -5 V2 1 2 2 0' - write(7,'(a132)') text - text=' -5 V3 1 2 3 0' - write(7,'(a132)') text - text=' -5 ALL 1 2 0 0 1ALL' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,(v(j,i),j=1,3) - enddo -! - write(7,'(a3)') m3 -! -! -! storing the static pressure in the nodes -! - elseif(nnstep.eq.2) then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 DDENSIT 1 1' - write(7,'(a132)') text - text=' -5 DRHO 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,v(4,i) - enddo -! - write(7,'(a3)') m3 -! -! storing the static temperature in the nodes -! - elseif(nnstep.eq.4) then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 DENERGY 1 1' - write(7,'(a132)') text - text=' -5 DRE 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,v(0,i) - enddo -! - write(7,'(a3)') m3 -! -! storing the turbulence parameters in the nodes -! - elseif(nnstep.eq.5) then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 DTURB1 1 1' - write(7,'(a132)') text - text=' -5 K 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,vtu(1,i) - enddo -! - write(7,'(a3)') m3 -! - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 DTURB2 1 1' - write(7,'(a132)') text - text=' -5 OM 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,vtu(2,i) - enddo -! - write(7,'(a3)') m3 -! - elseif(nnstep.eq.6) then -! - if(filab(21)(1:4).eq.'V ') then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 V3DF 4 1' - write(7,'(a132)') text - text=' -5 V1 1 2 1 0' - write(7,'(a132)') text - text=' -5 V2 1 2 2 0' - write(7,'(a132)') text - text=' -5 V3 1 2 3 0' - write(7,'(a132)') text - text=' -5 ALL 1 2 0 0 1ALL' - write(7,'(a132)') text -! - if((ntrans.eq.0).or.(filab(21)(6:6).eq.'G')) then - do i=1,nk - if(inomat(i).le.0) cycle - write(7,100) m1,i,(vold(j,i),j=1,3) - enddo - else - do i=1,nk - if(inomat(i).le.0) cycle - if(inotr(1,i).eq.0) then - write(7,100) m1,i,(vold(j,i),j=1,3) - else - call transformatrix(trab(1,inotr(1,i)),co(1,i),a) - write(7,100) m1,i, - & vold(1,i)*a(1,1)+vold(2,i)*a(2,1)+vold(3,i)*a(3,1), - & vold(1,i)*a(1,2)+vold(2,i)*a(2,2)+vold(3,i)*a(3,2), - & vold(1,i)*a(1,3)+vold(2,i)*a(2,3)+vold(3,i)*a(3,3) - endif - enddo - endif -! - write(7,'(a3)') m3 - endif -! - if(filab(22)(1:4).eq.'PS ') then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 PS3DF 1 1' - write(7,'(a132)') text - text=' -5 PS 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,vold(4,i) - enddo -! - write(7,'(a3)') m3 - endif -! - if(filab(17)(1:4).eq.'TS ') then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 TS3DF 1 1' - write(7,'(a132)') text - text=' -5 TS 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,vold(0,i) - enddo -! - write(7,'(a3)') m3 - endif -! - if(filab(23)(1:4).eq.'MACH') then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 M3DF 1 1' - write(7,'(a132)') text - text=' -5 MACH 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,v(1,i) - enddo -! - write(7,'(a3)') m3 - endif -! - if(filab(14)(1:4).eq.'TT ') then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 TT3DF 1 1' - write(7,'(a132)') text - text=' -5 TT 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,vold(0,i)*(1.d0+(v(0,i)-1.d0)/2*v(1,i)**2) - enddo -! - write(7,'(a3)') m3 - endif -! - if(filab(16)(1:4).eq.'PT ') then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 PT3DF 1 1' - write(7,'(a132)') text - text=' -5 PT 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,vold(4,i)* - & (1.d0+(v(0,i)-1.d0)/2*v(1,i)**2)**(v(0,i)/(v(0,i)-1.d0)) - enddo -! - write(7,'(a3)') m3 - endif -! - if(filab(24)(1:4).eq.'CP ') then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 CP3DF 1 1' - write(7,'(a132)') text - text=' -5 CP 1 1 0 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,(vold(4,i)-physcon(6))*2.d0/ - & (physcon(7)*physcon(5)**2) -c write(7,100) m1,i,(vold(4,i)-11.428571)*2.d0 -c write(7,100) m1,i,(vold(4,i)-1.116071)*2.d0 -c write(7,100) m1,i,(vold(4,i)-0.791452)*2.d0 -c write(7,100) m1,i,(vold(4,i)-0.496032)*2.d0 -c write(7,100) m1,i,(vold(4,i)-0.178571)*2.d0 -c write(7,100) m1,i,(vold(4,i)-0.988631)*2.d0 - enddo -! - write(7,'(a3)') m3 - endif -! - if(filab(25)(1:4).eq.'TURB') then - text=' 1PSTEP' - write(text(25:36),'(i12)') kode - write(7,'(a132)') text -! - text= - & ' 100CL .00000E+00 3 1' - text(75:75)='1' - write(text(25:36),'(i12)') nk - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text - text=' -4 TURB3DF 2 1' - write(7,'(a132)') text - text=' -5 K 1 1 1 0' - write(7,'(a132)') text - text=' -5 OM 1 2 2 0' - write(7,'(a132)') text -! - do i=1,nk - write(7,100) m1,i,voldtu(1,i),voldtu(2,i) - enddo -! - write(7,'(a3)') m3 - endif - endif -! - 100 format(a3,i10,1p,3e12.5) -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frdheader.f calculix-ccx-2.3/ccx_2.1/src/frdheader.f --- calculix-ccx-2.1/ccx_2.1/src/frdheader.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frdheader.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, - & noutloc,description,kode,nmethod,fmat) -! -! stores the results header in frd format -! - implicit none -! - character*8 fmat - character*12 description - character*132 text -! - integer icounter,noddiam,null,mode,noutloc,kode,nmethod -! - real*8 oner,time,pi,cs(17,*) -! - text=' 1PSTEP' - icounter=icounter+1 - write(text(25:36),'(i12)') icounter - write(7,'(a132)') text - if(nmethod.eq.2) then - text=' 1PGM' - write(text(25:36),'(e12.6)') oner - write(7,'(a132)') text - text=' 1PGK' - write(text(25:36),'(e12.6)') (time*2.d0*pi)**2 - write(7,'(a132)') text - text=' 1PHID' - write(text(25:36),'(i12)') noddiam - write(7,'(a132)') text - if(noddiam.ge.0) then - text=' 1PAX' - write(text(25:36),'(1p,e12.5)') cs(6,1) - write(text(37:48),'(1p,e12.5)') cs(7,1) - write(text(49:60),'(1p,e12.5)') cs(8,1) - write(text(61:72),'(1p,e12.5)') cs(9,1) - write(text(73:84),'(1p,e12.5)') cs(10,1) - write(text(85:96),'(1p,e12.5)') cs(11,1) - write(7,'(a132)') text - endif - text=' 1PSUBC' - write(text(25:36),'(i12)') null - write(7,'(a132)') text - text=' 1PMODE' - write(text(25:36),'(i12)') mode+1 - write(7,'(a132)') text - endif -! - text= - & ' 100CL .00000E+00 3 1' - write(text(25:36),'(i12)') noutloc - text(37:48)=description - if(nmethod.eq.2) text(64:68)='MODAL' - text(75:75)='1' - write(text(8:12),'(i5)') 100+kode - write(text(13:24),fmat) time - write(text(59:63),'(i5)') kode - write(7,'(a132)') text -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frdscalar.f calculix-ccx-2.3/ccx_2.1/src/frdscalar.f --- calculix-ccx-2.1/ccx_2.1/src/frdscalar.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frdscalar.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,79 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frdscalar(epn,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ngraph,iselect) -! -! stores a scalar result in frd format -! - implicit none -! - character*3 m1 -! - integer iset,nkcoords,inum(*),nksegment,ngraph, - & istartset(*),iendset(*),ialset(*),i,j,k,l,m,iselect -! - real*8 epn(*) -! - if(iset.eq.0) then - do i=1,nkcoords - if(iselect.eq.1) then - if(inum(i).le.0) cycle - elseif(iselect.eq.0) then - if(inum(i).eq.0) cycle - endif - write(7,101) m1,i,epn(i) - enddo - else - nksegment=nkcoords/ngraph - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - do l=0,ngraph-1 - i=ialset(k)+l*nksegment - if(iselect.eq.1) then - if(inum(i).le.0) cycle - elseif(iselect.eq.0) then - if(inum(i).eq.0) cycle - endif - write(7,101) m1,i,epn(i) - enddo - else - l=ialset(k-2) - do - l=l-ialset(k) - if(l.ge.ialset(k-1)) exit - do m=0,ngraph-1 - i=l+m*nksegment - if(iselect.eq.1) then - if(inum(i).le.0) cycle - elseif(iselect.eq.0) then - if(inum(i).eq.0) cycle - endif - write(7,101) m1,i,epn(i) - enddo - enddo - endif - enddo - endif -! - 101 format(a3,i10,1p,6e12.5) -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frdset.f calculix-ccx-2.3/ccx_2.1/src/frdset.f --- calculix-ccx-2.1/ccx_2.1/src/frdset.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frdset.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,83 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frdset(filabl,set,iset,istartset,iendset, - & ialset,inum,noutloc,nout,nset,noutmin,noutplus,iselect, - & ngraph) -! -! stores the results in frd format -! - implicit none -! - character*81 set(*),noset - character*87 filabl -! - integer iset,istartset(*),iendset(*),ialset(*),inum(*), - & noutloc,j,k,nout,nset,noutmin,noutplus,iselect,ngraph -! -! check for a set, if any -! - noset=filabl(7:87) - do iset=1,nset - if(set(iset).eq.noset) exit - enddo - if(iset.gt.nset) iset=0 -! -! determining the number of nodes in the set -! - if(iset.eq.0) then - if(iselect.eq.1) then - noutloc=noutplus - elseif(iselect.eq.-1) then - noutloc=noutmin - else - noutloc=nout - endif - else - noutloc=0 - do j=istartset(iset),iendset(iset) - if(ialset(j).gt.0) then - if(iselect.eq.-1) then - if(inum(ialset(j)).lt.0) noutloc=noutloc+1 - elseif(iselect.eq.1) then - if(inum(ialset(j)).gt.0) noutloc=noutloc+1 - else - if(inum(ialset(j)).ne.0) noutloc=noutloc+1 - endif - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - if(iselect.eq.-1) then - if(inum(k).lt.0) noutloc=noutloc+1 - elseif(iselect.eq.1) then - if(inum(k).gt.0) noutloc=noutloc+1 - else - if(inum(k).ne.0) noutloc=noutloc+1 - endif - enddo - endif - enddo - if(ngraph.gt.1) noutloc=noutloc*ngraph - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frdtensor.f calculix-ccx-2.3/ccx_2.1/src/frdtensor.f --- calculix-ccx-2.1/ccx_2.1/src/frdtensor.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frdtensor.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frdtensor(stn,iset,nkcoords,inum,m1,istartset,iendset, - & ialset,ngraph) -! -! stores a tensor result (2nd order) in frd format -! - implicit none -! - character*3 m1 -! - integer iset,nkcoords,inum(*),ngraph,nksegment, - & istartset(*),iendset(*),ialset(*),i,j,k,l,m,kal(2,6) -! - real*8 stn(6,*) -! - data kal /1,1,2,2,3,3,1,2,1,3,2,3/ -! - if(iset.eq.0) then - do i=1,nkcoords - if(inum(i).le.0) cycle - write(7,101) m1,i,(stn(j,i),j=1,4), - & stn(6,i),stn(5,i) - enddo - else - nksegment=nkcoords/ngraph - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - do l=0,ngraph-1 - i=ialset(k)+l*nksegment - if(inum(i).le.0) cycle - write(7,101) m1,i,(stn(j,i),j=1,4), - & stn(6,i),stn(5,i) - enddo - else - l=ialset(k-2) - do - l=l-ialset(k) - if(l.ge.ialset(k-1)) exit - do m=0,ngraph-1 - i=l+m*nksegment - if(inum(i).le.0) cycle - write(7,101) m1,i,(stn(j,i),j=1,4), - & stn(6,i),stn(5,i) - enddo - enddo - endif - enddo - endif -! - 101 format(a3,i10,1p,6e12.5) -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frdvectorcomp.f calculix-ccx-2.3/ccx_2.1/src/frdvectorcomp.f --- calculix-ccx-2.1/ccx_2.1/src/frdvectorcomp.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frdvectorcomp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,86 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frdvectorcomp(fn,iset,nkcoords,inum,m1, - & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) -! -! stores a scalar result in frd format -! - implicit none -! - character*3 m1 -! - integer iset,nkcoords,inum(*),mi(2),ngraph,nksegment, - & istartset(*),iendset(*),ialset(*),i,k,l,m,ncomp,iselect -! - real*8 fn(0:mi(2),*) -! - if(iset.eq.0) then - do i=1,nkcoords - if(iselect.eq.1) then - if(inum(i).le.0) cycle - elseif(iselect.eq.-1) then - if(inum(i).ge.0) cycle - else - if(inum(i).eq.0) cycle - endif - write(7,101) m1,i,fn(ncomp,i) - enddo - else - nksegment=nkcoords/ngraph - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - do l=0,ngraph-1 - i=ialset(k)+l*nksegment - i=ialset(k) - if(iselect.eq.1) then - if(inum(i).le.0) cycle - elseif(iselect.eq.-1) then - if(inum(i).ge.0) cycle - else - if(inum(i).eq.0) cycle - endif - write(7,101) m1,i,fn(ncomp,i) - enddo - else - l=ialset(k-2) - do - l=l-ialset(k) - if(l.ge.ialset(k-1)) exit - do m=0,ngraph-1 - i=l+m*nksegment - if(iselect.eq.1) then - if(inum(i).le.0) cycle - elseif(iselect.eq.-1) then - if(inum(i).ge.0) cycle - else - if(inum(i).eq.0) cycle - endif - write(7,101) m1,i,fn(ncomp,i) - enddo - enddo - endif - enddo - endif -! - 101 format(a3,i10,1p,6e12.5) -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frdvector.f calculix-ccx-2.3/ccx_2.1/src/frdvector.f --- calculix-ccx-2.1/ccx_2.1/src/frdvector.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frdvector.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,103 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frdvector(v,iset,ntrans,filabl,nkcoords,inum,m1,inotr, - & trab,co,istartset,iendset,ialset,mi,ngraph) -! -! stores a vector result in frd format -! - implicit none -! - character*3 m1 - character*87 filabl -! - integer mi(2),iset,ntrans,nkcoords,inum(*),inotr(2,*), - & istartset(*),iendset(*),ialset(*),i,j,k,l,m,ngraph, - & nksegment -! - real*8 v(0:mi(2),*),trab(7,*),co(3,*),a(3,3) -! - if(iset.eq.0) then - if((ntrans.eq.0).or.(filabl(6:6).eq.'G')) then - do i=1,nkcoords - if(inum(i).le.0) cycle - write(7,101) m1,i,(v(j,i),j=1,3) - enddo - else - do i=1,nkcoords - if(inum(i).le.0) cycle - if(inotr(1,i).eq.0) then - write(7,101) m1,i,(v(j,i),j=1,3) - else - call transformatrix(trab(1,inotr(1,i)),co(1,i),a) - write(7,101) m1,i, - & v(1,i)*a(1,1)+v(2,i)*a(2,1)+v(3,i)*a(3,1), - & v(1,i)*a(1,2)+v(2,i)*a(2,2)+v(3,i)*a(3,2), - & v(1,i)*a(1,3)+v(2,i)*a(2,3)+v(3,i)*a(3,3) - endif - enddo - endif - else - nksegment=nkcoords/ngraph - do k=istartset(iset),iendset(iset) - if(ialset(k).gt.0) then - do l=0,ngraph-1 - i=ialset(k)+l*nksegment - if(inum(i).le.0) cycle - if((ntrans.eq.0).or.(filabl(6:6).eq.'G').or. - & (inotr(1,i).eq.0)) then - write(7,101) m1,i,(v(j,i),j=1,3) - else - call transformatrix(trab(1,inotr(1,i)),co(1,i),a) - write(7,101) m1,i, - & v(1,i)*a(1,1)+v(2,i)*a(2,1)+v(3,i)*a(3,1), - & v(1,i)*a(1,2)+v(2,i)*a(2,2)+v(3,i)*a(3,2), - & v(1,i)*a(1,3)+v(2,i)*a(2,3)+v(3,i)*a(3,3) - endif - enddo - else - i=ialset(k-2) - do - l=l-ialset(k) - if(l.ge.ialset(k-1)) exit - do m=0,ngraph-1 - i=l+m*nksegment - if(inum(i).le.0) cycle - if((ntrans.eq.0).or.(filabl(6:6).eq.'G').or. - & (inotr(1,i).eq.0)) then - write(7,101) m1,i,(v(j,i),j=1,3) - else - call transformatrix(trab(1,inotr(1,i)), - & co(1,i),a) - write(7,101) m1,i, - & v(1,i)*a(1,1)+v(2,i)*a(2,1)+v(3,i)*a(3,1), - & v(1,i)*a(1,2)+v(2,i)*a(2,2)+v(3,i)*a(3,2), - & v(1,i)*a(1,3)+v(2,i)*a(2,3)+v(3,i)*a(3,3) - endif - enddo - enddo - endif - enddo - endif -! - 101 format(a3,i10,1p,6e12.5) -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frequencies.f calculix-ccx-2.3/ccx_2.1/src/frequencies.f --- calculix-ccx-2.1/ccx_2.1/src/frequencies.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frequencies.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,152 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frequencies(inpc,textpart,nmethod, - & mei,fei,iperturb,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,ithermal,isolver,xboun,nboun,ipoinpc) -! -! reading the input deck: *FREQUENCY -! - implicit none -! - character*1 inpc(*) - character*20 solver - character*132 textpart(16) -! - integer nmethod,mei(4),ncv,mxiter,istep,istat,iperturb(2),i,nboun, - & n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*),nev,ithermal,isolver, - & ipoinpc(0:*) -! - real*8 fei(3),pi,fmin,fmax,tol,xboun(*) -! - pi=4.d0*datan(1.d0) - mei(4)=0 -! - if(istep.lt.1) then - write(*,*) '*ERROR in frequencies: *FREQUENCY can only be used' - write(*,*) ' within a STEP' - stop - endif -! -! no heat transfer analysis -! - if(ithermal.gt.1) then - ithermal=1 - endif -! -! default solver -! - if(isolver.eq.0) then - solver(1:20)='SPOOLES ' - elseif(isolver.eq.2) then - solver(1:16)='ITERATIVESCALING' - elseif(isolver.eq.3) then - solver(1:17)='ITERATIVECHOLESKY' - elseif(isolver.eq.4) then - solver(1:3)='SGI' - elseif(isolver.eq.5) then - solver(1:5)='TAUCS' - elseif(isolver.eq.7) then - solver(1:7)='PARDISO' - endif -! - do i=2,n - if(textpart(i)(1:7).eq.'SOLVER=') then - read(textpart(i)(8:27),'(a20)') solver - elseif(textpart(i)(1:11).eq.'STORAGE=YES') then - mei(4)=1 - endif - enddo -! - if(solver(1:7).eq.'SPOOLES') then - isolver=0 - elseif(solver(1:16).eq.'ITERATIVESCALING') then - write(*,*) '*WARNING in frequencies: the iterative scaling' - write(*,*) ' procedure is not available for frequency' - write(*,*) ' calculations; the default solver is used' - elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then - write(*,*) '*WARNING in frequencies: the iterative scaling' - write(*,*) ' procedure is not available for frequency' - write(*,*) ' calculations; the default solver is used' - elseif(solver(1:3).eq.'SGI') then - isolver=4 - elseif(solver(1:5).eq.'TAUCS') then - isolver=5 - elseif(solver(1:13).eq.'MATRIXSTORAGE') then - isolver=6 - elseif(solver(1:7).eq.'PARDISO') then - isolver=7 - else - write(*,*) '*WARNING in frequencies: unknown solver;' - write(*,*) ' the default solver is used' - endif -! - if((isolver.eq.2).or.(isolver.eq.3)) then - write(*,*) '*ERROR in frequencies: the default solver ', - & solver - write(*,*) ' cannot be used for frequency calculations ' - stop - endif -! - nmethod=2 - if(iperturb(1).gt.1) iperturb(1)=0 - iperturb(2)=0 -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*) '*ERROR in frequencies: definition not complete' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - read(textpart(1)(1:10),'(i10)',iostat=istat) nev - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(nev.le.0) then - write(*,*) '*ERROR in frequencies: less than 1 eigenvalue re - &quested' - stop - endif - tol=1.d-2 - ncv=4*nev - ncv=ncv+nev - mxiter=1000 - read(textpart(2)(1:20),'(f20.0)',iostat=istat) fmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) fmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! - mei(1)=nev - mei(2)=ncv - mei(3)=mxiter - fei(1)=tol - fei(2)=fmin - fei(3)=fmax -! -! removing nonzero boundary conditions -! - do i=1,nboun - xboun(i)=0.d0 - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/friction_coefficient.f calculix-ccx-2.3/ccx_2.1/src/friction_coefficient.f --- calculix-ccx-2.1/ccx_2.1/src/friction_coefficient.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/friction_coefficient.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,116 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! This subroutine enable to compute the friction coefficient of -! the pipe flow for laminar and turbulent coefficient and also -! with an approximationinterpolation for the domain between laminar -! and turbulent flow -! - subroutine friction_coefficient(l,d,ks,reynolds,form_fact,lambda) -! - implicit none -! - real*8 l,d,ks,reynolds,form_fact,lambda,alfa2, - & rey_turb_min,rey_lam_max,lzd,dd,ds,friction,dfriction, - & lambda_kr,lambda_turb,ksd -! - rey_turb_min=4000 - rey_lam_max=2000 - lzd=l/d - ksd=ks/d -! -! transition laminar turbulent domain -! - if((reynolds.gt.rey_lam_max).and.(reynolds.lt.rey_turb_min))then -! - lambda_kr=64.d0/rey_lam_max -! -! Solving the implicit White-Colebrook equation -! 1/dsqrt(friction)=-2*log10(2.51/(Reynolds*dsqrt(friction)+0.27*Ks)) -! -! Using Haaland explicit relationship for the initial friction value -! S.E. Haaland 1983 (Source en.Wikipwedia.org) -! - friction=(-1.8*dlog10(6.9d0/4000.d0+(ksd/3.7d0)**1.11d0))**-2 -! - do - ds=dsqrt(friction) - dd=2.51d0/(4000.d0*ds)+0.27d0*ksd - dfriction=(1.d0/ds+2.d0*dlog10(dd))*2.d0*friction*ds/ - & (1.d0+2.51d0/(4000.d0*dd)) - if(dfriction.le.friction*1.d-3) then - friction=friction+dfriction - exit - endif - friction=friction+dfriction - enddo - lambda_turb=friction - -! -! logarithmic interpolation in the trans laminar turbulent domain -! - lambda=lambda_kr*(lambda_turb/lambda_kr) - & **(log(reynolds/rey_lam_max)/log(rey_turb_min/rey_lam_max)) -! -! laminar flow -! using Couette-Poiseuille formula -! the form factor for non round section can be found in works such as -! Bohl,W -! "Technische Strömungslehre Stoffeigenschaften von Flüssigkeiten und -! Gasen, hydrostatik,aerostatik,incompressible Strömungen, -! Strömungsmesstechnik -! Vogel Würzburg Verlag 1980 -! - elseif(reynolds.lt.rey_lam_max) then - lambda=64.d0/reynolds - lambda=form_fact*lambda -! -! turbulent -! - else -! Solving the implicit White-Colebrook equation -! 1/dsqrt(friction)=-2*log10(2.51/(Reynolds*dsqrt(friction)+0.27*Ks)) -! -! Using Haaland explicit relationship for the initial friction value -! S.E. Haaland 1983 (Source en.Wikipwedia.org) -! - friction=(-1.8*dlog10(6.9d0/reynolds+(ksd/3.7d0) - & **1.11d0))**-2 -! - do - ds=dsqrt(friction) - dd=2.51d0/(reynolds*ds)+0.27d0*ksd - dfriction=(1.d0/ds+2.d0*dlog10(dd))*2.d0*friction*ds/ - & (1.d0+2.51d0/(reynolds*dd)) - if(dfriction.le.friction*1.d-3) then - friction=friction+dfriction - exit - endif - friction=friction+dfriction - enddo - lambda=friction - endif -! - call interpol_alfa2(lzd,reynolds,alfa2) -! - return -! - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/frictions.f calculix-ccx-2.3/ccx_2.1/src/frictions.f --- calculix-ccx-2.1/ccx_2.1/src/frictions.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/frictions.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine frictions(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, - & inp,ipoinpc) -! -! reading the input deck: *FRICTION -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nelcon(2,*),nmat,ntmat_,istep,istat,ipoinpc(0:*), - & n,key,i,ncmat_,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - real*8 elcon(0:ncmat_,ntmat_,*) -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in frictions:' - write(*,*) ' *FRICTION should be placed' - write(*,*) ' before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in frictions:' - write(*,*) ' *FRICTION should be preceded' - write(*,*) ' by a *SURFACE INTERACTION card' - stop - endif -! - nelcon(1,nmat)=7 - nelcon(2,nmat)=1 -! -! no temperature dependence allowed; last line is decisive -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - do i=1,2 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(5+i,1,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - elcon(0,1,nmat)=0.d0 - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/fridaforc.f calculix-ccx-2.3/ccx_2.1/src/fridaforc.f --- calculix-ccx-2.1/ccx_2.1/src/fridaforc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/fridaforc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,324 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine fridaforc(xl,konl,vl,imat,elcon,nelcon, - & elas,fnl,ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc, - & plicon,nplicon,npmat_,veoldl,senergy,iener,cstr,mi) -! -! calculates the force of the spring -! - implicit none -! - character*8 lakonl -! - integer konl(9),i,j,imat,ncmat_,ntmat_,nope,nterms,iflag,mi(2), - & kode,niso,id,nplicon(0:ntmat_,*),npmat_,nelcon(2,*),iener -! - real*8 xl(3,9),elas(21),ratio(9),t0l,t1l,vr(3),vl(0:mi(2),9), - & pl(3,9),xn(3),al,area,alpha,beta,fnl(3,9),veoldl(0:mi(2),9), - & elcon(0:ncmat_,ntmat_,*),pproj(3),xsj2(3),xs2(3,7),dist, - & shp2(7,8),xi,et,elconloc(21),plconloc(82),xk,fk,dd, - & xiso(20),yiso(20),dd0,plicon(0:2*npmat_,ntmat_,*),fn, - & damp,c0,eta,um,eps,fnd(3,9),fnv(3,9),ver(3),dvernor, - & dampforc,vertan(3),dvertan,fricforc,pi,senergy,cstr(6) -! - data iflag /2/ -! -! actual positions of the nodes belonging to the contact spring -! - do i=1,nope - do j=1,3 - pl(j,i)=xl(j,i)+vl(j,i) - enddo - enddo -! - if(lakonl(7:7).eq.'A') then - dd0=dsqrt((xl(1,2)-xl(1,1))**2 - & +(xl(2,2)-xl(2,1))**2 - & +(xl(3,2)-xl(3,1))**2) - dd=dsqrt((pl(1,2)-pl(1,1))**2 - & +(pl(2,2)-pl(2,1))**2 - & +(pl(3,2)-pl(3,1))**2) - do i=1,3 - xn(i)=(pl(i,2)-pl(i,1))/dd - enddo - al=dd-dd0 -! -! interpolating the material data -! - call materialdata_sp(elcon,nelcon,imat,ntmat_,i,t0l,t1l, - & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) -! -! calculating the spring force and the spring constant -! - if(kode.eq.2)then - xk=elconloc(1) - fk=xk*al - if(iener.eq.1) then - senergy=fk*al/2.d0 - endif - else - niso=int(plconloc(81)) - do i=1,niso - xiso(i)=plconloc(2*i-1) - yiso(i)=plconloc(2*i) - enddo - call ident(xiso,al,niso,id) - if(id.eq.0) then - xk=0.d0 - fk=yiso(1) - if(iener.eq.1) then - senergy=fk*al; - endif - elseif(id.eq.niso) then - xk=0.d0 - fk=yiso(niso) - if(iener.eq.1) then - senergy=yiso(1)*xiso(1) - do i=2,niso - senergy=senergy+(xiso(i)-xiso(i-1))*(yiso(i)+yiso( - & i-1))/2.d0 - enddo - senergy=senergy+(al-xiso(niso))*yiso(niso) - endif - else - xk=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) - fk=yiso(id)+xk*(al-xiso(id)) - if(iener.eq.1) then - senergy=yiso(1)*xiso(1) - do i=2, id - senergy=senergy+(xiso(i)-xiso(i-1))* - & (yiso(i)+yiso(i-1))/2.d0 - enddo - senergy=senergy+(al-xiso(id))*(fk+yiso(id))/2.d0 - endif - endif - endif -! - do i=1,3 - fnl(i,1)=-fk*xn(i) - fnl(i,2)=fk*xn(i) - enddo - return - endif -! - nterms=nope-1 -! -! vector vr connects the dependent node with its projection -! on the independent face -! - do i=1,3 - pproj(i)=pl(i,nope) - enddo -c write(*,*) 'springforc ',(pproj(i),i=1,3) - call attach(pl,pproj,nterms,ratio,dist,xi,et) - do i=1,3 - vr(i)=pl(i,nope)-pproj(i) - enddo -! -! determining the jacobian vector on the surface -! - if(nterms.eq.8) then - call shape8q(xi,et,pl,xsj2,xs2,shp2,iflag) - elseif(nterms.eq.4) then - call shape4q(xi,et,pl,xsj2,xs2,shp2,iflag) - elseif(nterms.eq.6) then - call shape6tri(xi,et,pl,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,pl,xsj2,xs2,shp2,iflag) - endif -! -! normal on the surface -! - area=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+xsj2(3)*xsj2(3)) - do i=1,3 - xn(i)=xsj2(i)/area - enddo -! -! distance from surface along normal -! - dist=vr(1)*xn(1)+vr(2)*xn(2)+vr(3)*xn(3) - if(dist.le.0.d0) cstr(1)=-dist -! -! representative area -! - if(elcon(1,1,imat).gt.0.d0) then -! -! exponential overclosure -! - if(dabs(elcon(2,1,imat)).lt.1.d-30) then - elas(1)=0.d0 - elas(2)=0.d0 - else - if((nterms.eq.8).or.(nterms.eq.4)) then - area=area*4.d0 -c area=area*4.d0/konl(nope+1) - else - area=area/2.d0 -c area=area/2.d0/konl(nope+1) - endif -! - alpha=elcon(2,1,imat)*area - beta=elcon(1,1,imat) - if(-beta*dist.gt.23.d0-dlog(alpha)) then - beta=(dlog(alpha)-23.d0)/dist - endif - elas(1)=dexp(-beta*dist+dlog(alpha)) - elas(2)=-beta*elas(1) - endif - else -! -! linear overclosure -! - elas(1)=-area*elcon(2,1,imat)*dist - elas(2)=-area*elcon(2,1,imat) - endif -! -! forces in the nodes of the contact element -! - do i=1,3 - do j=1,nterms -c fnl(i,j)=ratio(j)*elas(1)*xn(i) - fnl(i,j)=0. - enddo -c fnl(i,nope)=-elas(1)*xn(i) - fnl(i,nope)=0. - enddo - if(iener.eq.1) then - senergy=elas(1)/beta; - endif - cstr(4)=elas(1)/area -! -! contact damping -! - if(ncmat_.ge.5) then - damp=elcon(3,1,imat) - if(damp.gt.0.d0) then -! -! calculate the relative velocity -! - do i=1,3 - ver(i)=0.d0 - do j=1,nterms - ver(i)=ver(i)+ratio(j)*veoldl(i,j) - enddo - ver(i)=veoldl(i,nope)-ver(i) - enddo - dvernor=ver(1)*xn(1)+ver(2)*xn(2)+ver(3)*xn(3) -! - c0=elcon(4,1,imat) - eta=elcon(5,1,imat) -! - if(dist.gt.c0) then - dampforc=0.d0 - elseif(dist.gt.eta*c0) then - dampforc=dvernor*(c0-dist)/(c0*(1.d0-eta))*damp*area - else - dampforc=dvernor*damp*area - endif -! - do i=1,3 - do j=1,nterms - fnd(i,j)=ratio(j)*dampforc*xn(i) - enddo - fnd(i,nope)=-dampforc*xn(i) - enddo - endif - endif -! -! friction -! - if(ncmat_.ge.7) then - um=elcon(6,1,imat) - if(um.gt.0.d0) then - if(damp.le.0.d0) then -! -! calculate the relative velocity -! - do i=1,3 - ver(i)=0.d0 - do j=1,nterms - ver(i)=ver(i)+ratio(j)*veoldl(i,j) - enddo - ver(i)=veoldl(i,nope)-ver(i) - enddo - dvernor=ver(1)*xn(1)+ver(2)*xn(2)+ver(3)*xn(3) - endif -! - pi=4.d0*datan(1.d0) -! -! calculate the tangential relative velocity -! - do i=1,3 - vertan(i)=ver(i)-dvernor*xn(i) - enddo - dvertan=dsqrt(vertan(1)**2+vertan(2)**2+vertan(3)**2) -! -! normalizing the tangent vector -! - do i=1,3 - vertan(i)=vertan(i)/dvertan - enddo -! -! friction constants -! - eps=elcon(7,1,imat) -! -! normal force -! - fn=elas(1) -! -! modify the friction force in case of contact damping -! - if(damp.gt.0.d0) fn=fn+dampforc -! - fricforc=2.d0*um*datan(dvertan/eps)*fn/pi -! - do i=1,3 - do j=1,nterms - fnv(i,j)=ratio(j)*fricforc*vertan(i) - enddo - fnv(i,nope)=-fricforc*vertan(i) - enddo - endif - endif -! -! summing all forces -! - if(ncmat_.ge.5) then - if(damp.gt.0.d0) then - do j=1,nope - do i=1,3 - fnl(i,j)=fnl(i,j)+fnd(i,j) - enddo - enddo - endif - endif - if(ncmat_.ge.7) then - if(um.gt.0.d0) then - do j=1,nope - do i=1,3 - fnl(i,j)=fnl(i,j)+fnv(i,j) - enddo - enddo - endif - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/fsub.f calculix-ccx-2.3/ccx_2.1/src/fsub.f --- calculix-ccx-2.1/ccx_2.1/src/fsub.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/fsub.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine fsub(time,t,a,b,dd,h1,h2,h3,h4,func,funcp) -! - implicit none -! - real*8 time,t,a,b,dd,h1,h2,h3,h4,fexp,fsin,fcos,func,funcp, - & h8,h9,h10,h11,h12,h13 -! - fexp=dexp(-h1*t) - fsin=dsin(dd*t) - fcos=dcos(dd*t) - h8=(a+b*time)*fexp/h2 - h9=-b*fexp/h2 - h10=-h8*h1 - h11=h8*dd - h12=h9*(-h1*t-h3/h2) - h13=h9*(dd*t+h4) -! -! function -! -c fsub=(a+b*time)*fexp*(-h1*fsin-dd*fcos)/h2-b*fexp/h2*((-h1*t-h3/h2)* -c & fsin-(dd*t+h4)*fcos) - func=h10*fsin-h11*fcos+h12*fsin-h13*fcos -! -! derivative of the function -! - funcp=-h1*func+dd*(h10*fcos+h11*fsin+h12*fcos+h13*fsin) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/fsuper.f calculix-ccx-2.3/ccx_2.1/src/fsuper.f --- calculix-ccx-2.1/ccx_2.1/src/fsuper.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/fsuper.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine fsuper(time,t,a,b,h1,h2,h3,h4,h5,h6,func,funcp) -! - implicit none -! - real*8 time,t,a,b,h1,h2,h3,h4,h5,h6,fexm,fexp,func,funcp -! - fexm=dexp(h1*t) - fexp=dexp(-h2*t) -! -! function -! - func=(a+b*time)*(fexm*h3+fexp*h4) - & -b*(fexm*(t*h3-h5)+fexp*(t*h4+h6)) -! -! derivative of the function -! - funcp=(a+b*time)*(fexm-fexp)-b*(fexm*(t-h3)-fexp*(t+h4)) - -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/gaps.f calculix-ccx-2.3/ccx_2.1/src/gaps.f --- calculix-ccx-2.1/ccx_2.1/src/gaps.f 2010-03-04 19:53:22.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gaps.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,332 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gaps(inpc,textpart,set,istartset,iendset, - & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon,ipkon,kon,nk,nk_, - & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_,iperturb,ne_, - & co,xboun,ctrl,typeboun,istep,istat,n,iline,ipol,inl,ipoinp, - & inp,iamboun,nam,inotr,trab,ntrans,nmethod,ipoinpc,mi) -! -! reading the input deck: *GAP -! -! a gap between nodes a and b is formulated by a nonlinear MPC -! linking node a and b. To simulate the gap feature an extra node -! c is introduced. The first DOF of this node is fixed to zero by -! a boundary SPC, the second DOF is left free. If the gap is closed -! the first DOF of node c is used in the MPC leading to a linear, -! tied MPC. If the gap is open, the second DOF of node c is used, -! leading to no constraint at all. -! - implicit none -! - logical fixed,calcnormal -! - character*1 typeboun(*),type,inpc(*) - character*8 lakon(*) - character*20 labmpc(*),label - character*81 set(*),elset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),ipompc(*),nodempc(3,*), - & nset,nset_,nalset,nalset_,nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), - & ilmpc(*),ipkon(*),kon(*),i,node,ipos,istep,istat,n,ne_, - & j,k,nodeboun(*),ndirboun(*),ikboun(*),ilboun(*),iamboun(*), - & nboun,nboun_,key,iperturb(2),inode,iline,ipol,inl,ipoinpc(0:*), - & ipoinp(2,*),inp(3,*),l,index1,ibounstart,ibounend,iamplitude, - & nam,inotr(2,*),ntrans,nmethod,idummy,mi(2),node1,node2 -! - real*8 coefmpc(3,*),co(3,*),xboun(*),ctrl(*),xn(3),clearance, - & bounval,trab(7,*),vdummy(0:4),dd -! - fixed=.false. - type='B' - iamplitude=0 -! - if(istep.gt.0) then - write(*,*) - & '*ERROR in gaps: *GAP should be placed' - write(*,*) ' before all step definitions' - stop - endif -! -! reading the element set -! - elset=' - & ' - ipos=0 -! - do i=2,n - if(textpart(i)(1:6).eq.'ELSET=') then - elset=textpart(i)(7:86) - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - endif - enddo -! -! checking whether the element set exists -! - if(ipos.eq.0) then - write(*,*) '*ERROR in gaps: no element set ',elset - write(*,*) ' was been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - do i=1,nset - if(set(i).eq.elset) exit - enddo - if(i.gt.nset) then - elset(ipos:ipos)=' ' - write(*,*) '*ERROR in gaps: element set ',elset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! -! the *GAP option implies a nonlinear geometric -! calculation -! - iperturb(2)=1 - if(iperturb(1).eq.0) then - iperturb(1)=2 - elseif(iperturb(1).eq.1) then - write(*,*) '*ERROR in rigidbodies: the *MPC option' - write(*,*) ' cannot be used in a perturbation step' - stop - endif -! - label='GAP ' -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - read(textpart(1)(1:20),'(f20.0)',iostat=istat) clearance - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) xn(1) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) xn(2) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(4)(1:20),'(f20.0)',iostat=istat) xn(3) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! -! check whether size of gap normal is zero; if so, the -! gap normal is calculated from the coordinates -! - calcnormal=.false. - dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) - if(dabs(dd).eq.0.d0) calcnormal=.true. -! -! generating the gap MPC's -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - if(lakon(ialset(j))(1:1).ne.'G') then - write(*,*) '*ERROR gaps: *GAP can only be used for' - write(*,*) ' GAPUNI elements' - write(*,*) ' Faulty element: ',ialset(j) - stop - endif - index1=ipkon(ialset(j)) -! -! three terms for node 1 -! - node1=kon(index1+1) - inode=0 - do l=1,3 - inode=inode+1 - call usermpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,inode,node1,co,label, - & typeboun,iperturb) - enddo -! -! three terms for node 2 -! - node2=kon(index1+2) - do l=1,3 - inode=inode+1 - call usermpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,inode,node2,co,label, - & typeboun,iperturb) - enddo -! -! extra node for the gap DOF -! - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in gaps: increase nk_' - stop - endif - node=nk - call usermpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,inode,node,co,label,typeboun, - & iperturb) -! -! calculating the gap normal -! - if(calcnormal) then - do l=1,3 - xn(l)=co(l,node2)-co(l,node1) - enddo - dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) - if(dabs(dd).eq.0.d0) then - write(*,*) '*ERROR in gaps: gap normal cannot ' - write(*,*) ' determined' - stop - endif - do l=1,3 - xn(l)=xn(l)/dd - enddo - endif -! - do l=1,3 - co(l,nk)=xn(l) - enddo -! -! restraining the first DOF of the extra node -! - ibounstart=1 - ibounend=1 - bounval=0.d0 - call bounadd(node,ibounstart,ibounend,bounval, - & nodeboun,ndirboun,xboun,nboun,nboun_, - & iamboun,iamplitude,nam,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, - & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vdummy, - & idummy,mi) -! -! nonhomogeneous term for user MPC -! - node=0 - call usermpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,inode,node,co,label,typeboun, - & iperturb) - co(1,nk)=clearance - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - if(lakon(k)(1:1).ne.'G') then - write(*,*) '*ERROR in gaps: *GAP can only be used' - write(*,*) ' for GAPUNI elements' - write(*,*) ' Faulty element: ',k - stop - endif - index1=ipkon(k) -! -! three terms for node 1 -! - node1=kon(index1+1) - inode=0 - do l=1,3 - inode=inode+1 - call usermpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,inode,node1,co,label, - & typeboun,iperturb) - enddo -! -! three terms for node 2 -! - node2=kon(index1+2) - do l=1,3 - inode=inode+1 - call usermpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,inode,node2,co,label, - & typeboun,iperturb) - enddo -! -! extra node for the gap DOF -! - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in gaps: increase nk_' - stop - endif - node=nk - call usermpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,inode,node,co,label,typeboun, - & iperturb) -! -! calculating the gap normal -! - if(calcnormal) then - do l=1,3 - xn(l)=co(l,node2)-co(l,node1) - enddo - dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) - if(dabs(dd).eq.0.d0) then - write(*,*) '*ERROR in gaps: gap normal cannot ' - write(*,*) ' determined' - stop - endif - do l=1,3 - xn(l)=xn(l)/dd - enddo - endif -! - do l=1,3 - co(l,nk)=xn(l) - enddo -! -! restraining the first DOF of the extra node -! - ibounstart=1 - ibounend=1 - bounval=0.d0 - call bounadd(node,ibounstart,ibounend,bounval, - & nodeboun,ndirboun,xboun,nboun,nboun_, - & iamboun,iamplitude,nam,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, - & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vdummy,idummy, - & mi) -! -! nonhomogeneous term for user MPC -! - node=0 - call usermpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,inode,node,co,label,typeboun, - & iperturb) - co(1,nk)=clearance - enddo - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/gasmechbc.f calculix-ccx-2.3/ccx_2.1/src/gasmechbc.f --- calculix-ccx-2.1/ccx_2.1/src/gasmechbc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gasmechbc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gasmechbc(vold,nload,sideload, - & nelemload,xload,mi) -! - implicit none -! - character*20 sideload(*) -! - integer i,nload,node,nelemload(2,*),mi(2) -! - real*8 vold(0:mi(2),*),xload(2,*) -! -! updating the boudary conditions in a mechanical -! calculation coming from a previous thermal calculation -! -! updating the pressure boundary conditions -! - do i=1,nload - if(sideload(i)(3:4).eq.'NP') then - node=nelemload(2,i) - xload(1,i)=vold(2,node) - endif - enddo -! - return - end - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gaspipe.f calculix-ccx-2.3/ccx_2.1/src/gaspipe.f --- calculix-ccx-2.1/ccx_2.1/src/gaspipe.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gaspipe.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,537 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gaspipe(node1,node2,nodem,nelem,lakon,kon,ipkon, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,cp,r,physcon,dvi,numf,set,shcon, - & nshcon,rhcon,nrhcon,ntmat_,mi) -! -! pipe with friction losses -! - implicit none -! - logical identity,crit - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, - & ielprop(*),nodef(5),idirf(5),index,iflag, - & inv,ipkon(*),kon(*),icase,kgas,k_oil,nshcon(*), - & nrhcon(*),ntmat_,mi(2) -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,R,a,d,l, - & p1,p2,T1,T2,Tt1,Tt2,pt1,pt2,cp,physcon(*),p2p1,km1,dvi, - & kp1,kdkm1,reynolds,pi,e,lambda,lld,kdkp1,T2dTt2, - & T1dTt1,X_t1dTt1,X_t2dTt2,X2_den,X1_den, - & X1,X2,B1,B2,C1,C2,t_moy,tdkp1,ln,m2r2d2a2, - & pt2zpt1,ks,form_fact,Tt1dT1,Tt2dT2,M1,M2, - & Pt2zPt1_c,qred_crit,l_neg,Qred,Ts1,qred_max1,phi,xflow_oil, - & shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*) -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - - elseif (iflag.eq.1)then -! - crit=.false. -! - index=ielprop(nelem) - kappa=(cp/(cp-R)) - A=prop(index+1) - d=prop(index+2) - l=prop(index+3) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+4) - if(lakon(nelem)(2:6).eq.'GAPIA') then - icase=0 - elseif(lakon(nelem)(2:6).eq.'GAPII') then - icase=1 - endif - form_fact=prop(index+5) - xflow_oil=prop(index+6) - k_oil=int(prop(index+7)) -! - p1=v(2,node1) - p2=v(2,node2) -! - if(p1.ge.p2) then - inv=1 - T1=v(0,node1)+physcon(1) - T2=v(0,node2)+physcon(1) - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - T1=v(0,node2)+physcon(1) - T2=v(0,node1)+physcon(1) - endif -! - p2p1=p2/p1 - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - tdkp1=2.d0/kp1 - C2=tdkp1**kdkm1 -! - if(p2p1.gt.C2) then - xflow=inv*p1*a*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa) - & *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(T1) - else - xflow=inv*p1*a*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ - & dsqrt(T1) - endif -! -! calculation of the dynamic viscosity -! - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif -! - reynolds=dabs(xflow)*d/(dvi*a) -! - if(reynolds.lt.100) then - reynolds = 100 - endif -! - call friction_coefficient(l_neg,d,ks,reynolds,form_fact,lambda) -! - call pt2zpt1_crit(p2,p1,T1,T2,lambda,kappa,r,l,d,A,iflag, - & inv,Pt2zPt1_c,Qred_crit,crit,qred_max1,icase) -! - v(3,nodem)=Pt2zPt1_c -! - Qred=dabs(xflow)*dsqrt(T1)/(A*P1) - if (crit) then - xflow=0.5*inv*Qred_crit*P1*A/dsqrt(T1) -! - if(lakon(nelem)(2:6).eq.'GAPII') then - call ts_calc(xflow,T1,P1,kappa,r,a,Ts1,icase) - if (inv.eq.1) then - v(3,node1)=Ts1 - v(3,node2)=Ts1 - v(0,node2)=Ts1*(1.d0+km1/(2*kappa)) - else - v(3,node2)=Ts1 - v(3,node1)=Ts1 - v(0,node1)=Ts1*(1.d0+km1/(2*kappa)) - endif - endif - elseif(Qred.gt.Qred_crit) then - xflow=0.5*inv*Qred_crit*P1*A/dsqrt(T1) - else - xflow=inv*Qred*P1*A/dsqrt(T1) - endif -! - elseif (iflag.eq.2)then -! - numf=5 - crit=.false. -! - pi=4.d0*datan(1.d0) - e=2.7182818d0 -! - kappa=(cp/(cp-R)) - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - kdkp1=kappa/kp1 -! - index=ielprop(nelem) - A=prop(index+1) - d=prop(index+2) - l=prop(index+3) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+4) - if(lakon(nelem)(2:6).eq.'GAPIA') then - icase=0 - elseif(lakon(nelem)(2:6).eq.'GAPII') then - icase=1 - endif - form_fact=prop(index+5) - xflow_oil=prop(index+6) - k_oil=int(prop(index+7)) -! - pt1=v(2,node1) - pt2=v(2,node2) - xflow=v(1,nodem) -! - if(xflow.ge.0d0) then - inv=1 - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) -! - call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 - nodef(5)=node2 - else - inv=-1 - pt1=v(2,node2) - pt2=v(2,node1) - xflow=-v(1,nodem) - Tt1=v(0,node2)+physcon(1) - Tt2=v(0,node1)+physcon(1) - call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) -! - call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - nodef(5)=node1 - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 - idirf(5)=0 -! - pt2zpt1=pt2/pt1 -! -! calculation of the dynamic viscosity -! - if(xflow_oil.ne.0d0) then -! - if((k_oil.lt.0).or.(k_oil.gt.12)) then - write(*,*) '*ERROR:in gaspipe.f' - write(*,*) ' using two phase flow' - write(*,*) ' the type of oil is not defined' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Current calculation stops here' - stop - else - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) - lambda=lambda*phi - endif -! -! for pure air -! - else - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif -! - reynolds=dabs(xflow)*d/(dvi*a) -! - phi=1.d0 - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - endif -! - call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, - & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) -! - if(dabs(xflow)*dsqrt(Tt1)/(A*Pt1).gt.qred_max1) then - crit=.true. - endif -! -! definition of the coefficients -! - lld=lambda*l/d -! - if(.not.crit) then -! - T_moy=0.5d0*(T1+T2) - T2dTt2=T2/Tt2 - Tt2dT2=1.d0/T2dTt2 - X_T2dTt2=T2dTt2**(2*kdkm1) - T1dTt1=T1/Tt1 - Tt1dT1=1.d0/T1dTt1 - X_T1dTt1=T1dTt1**(2*kdkm1) -! - X2_den=pt2**2*X_T2dTt2 - X2=t2**2/X2_den - X1_den=pt1**2*X_T1dTt1 - X1=T1**2/X1_den -! - ln=log(Pt2zPt1*(T2dTt2/T1dTt1)**kdkm1) -! - m2r2d2a2=xflow**2*R**2/(2*A**2) -! - C1=2.d0*cp*A**2*X1_den*(1.d0-2.d0*kdkm1*(Tt1dT1-1.d0)) - & +2.d0*xflow**2*R**2*T1 -! - C2=2.d0*cp*A**2*X2_den*(1.d0-2.d0*kdkm1*(Tt2dT2-1.d0)) - & +2.d0*xflow**2*R**2*T2 -! - B1=-2.d0*m2r2d2a2*(1.d0-kdkm1)*T1/X1_den*(1.d0-0.5d0*lld) - & +0.5d0*R*(ln-kdkm1*(T2+T1)/T1) -! - B2=2.d0*m2r2d2a2*(1.d0-kdkm1)*T2/X2_den*(1.d0+0.5d0*lld) - & +0.5d0*R*(ln+kdkm1*(T2+T1)/T2) -! -! residual -! - f=(m2r2d2a2*(X2*(1.d0+0.5d0*lld)-X1*(1.d0-0.5d0*lld)) - & +R*T_moy*ln - & +b2/c2*(2*cp*A**2*(Tt2-T2)*X2_den-xflow**2*R**2*T2**2) - & +b1/c1*(2*cp*A**2*(Tt1-T1)*X1_den-xflow**2*R**2*T1**2)) -! -! pressure node1 -! - df(1)=(2.d0*m2r2d2a2*X1/pt1*(1.d0-0.5d0*lld) - & -R*T_moy/pt1 - & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1)) -! -! temperature node1 -! - df(2)=(-2.d0*m2r2d2a2*(kdkm1/Tt1*X1)*(1.d0-0.5d0*lld) - & +r*kdkm1*T_moy/Tt1 - & +b1/c1*(2*cp*A*A*X1_den*(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1))) -! -! mass flow -! - df(3)=(inv*xflow*R**2/a**2 - & *(X2*(1.d0+0.5d0*lld)-X1*(1.d0-0.5d0*lld)) - & +B2/C2*(-2.d0*inv*xflow*R*R*T2**2.d0) - & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0)) -! -! pressure node2 -! - df(4)=(-2*m2r2d2a2*X2/pt2*(1.d0+0.5d0*lld) - & +R*T_moy/pt2 - & +B2/C2*(4.d0*cp*A*A*(Tt2-T2)*pt2*X_T2dTt2)) -! -! temperature node2 -! - df(5)=(2.d0*m2r2d2a2*(kdkm1/Tt2*X2)*(1.d0+0.5d0*lld) - & -r*kdkm1*T_moy/Tt2 - & +b2/c2*(2*cp*A*A*X2_den*(1.d0-2.d0*kdkm1*(Tt2-T2)/Tt2))) -! - else -! - pt1=pt2/pt2zpt1_c - f=xflow*dsqrt(Tt1)/pt1-A*qred_crit -! -! pressure node1 -! - df(1)=-xflow*dsqrt(Tt1)/pt1**2 -! -! temperature node1 -! - df(2)=0.5d0*xflow/(pt1*dsqrt(Tt1)) -! -! mass flow -! - df(3)=inv*dsqrt(Tt1)/pt1 -! -! pressure node2 -! - df(4)=0.d0 -! -! temperature node2 -! - df(5)=0.d0 -! - endif -! - elseif(iflag.eq.3) then - - pi=4.d0*datan(1.d0) - e=2.7182818d0 -! - kappa=(cp/(cp-R)) - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - kdkp1=kappa/kp1 -! - index=ielprop(nelem) - A=prop(index+1) -! - d=prop(index+2) -! - l=prop(index+3) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+4) - if(lakon(nelem)(2:6).eq.'GAPIA') then - icase=0 - elseif(lakon(nelem)(2:6).eq.'GAPII') then - icase=1 - endif - form_fact=prop(index+5) - xflow_oil=prop(index+6) - k_oil=int(prop(index+7)) -! - pt1=v(2,node1) - pt2=v(2,node2) -! - if(xflow.ge.0d0) then - inv=1 - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) -! - call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) -! - else - inv=-1 - pt1=v(2,node2) - pt2=v(2,node1) - xflow=-v(1,nodem) - Tt1=v(0,node2)+physcon(1) - Tt2=v(0,node1)+physcon(1) -! - call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) - call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - nodef(5)=node1 - endif -! - pt2zpt1=pt2/pt1 -! -! calculation of the dynamic viscosity -! - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif - reynolds=dabs(xflow)*d/(dvi*a) - if(reynolds.lt.100.d0) then - reynolds= 100.d0 - endif -! -! definition of the friction coefficient for 2 phase flows and pure air -! -! Lockhart-Martinelli method -! - if(lakon(nelem)(7:7).eq.'F') then -! - if((k_oil.lt.0).or.(k_oil.gt.12)) then - write(*,*) '*ERROR:in gaspipe.f' - write(*,*) ' using two phase flow' - write(*,*) ' the type of oil is not defined' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Current calculation stops here' - stop - elseif(xflow_oil.eq.0) then - write(*,*) '*WARNING:in gaspipe.f' - write(*,*) ' using two phase flow' - write(*,*) ' the oil mass flow rate is NULL' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Only pure air is considered' - phi=1 - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - else - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) - lambda=lambda*phi - endif -! -! for pure air -! - else - phi=1.d0 - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - endif -! - call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, - & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) -! -! definition of the coefficients -! - M1=dsqrt(2/km1*((Tt1/T1)-1)) - M2=dsqrt(2/km1*((Tt2/T2)-1)) - - write(1,*) '' - write(1,55) 'In line',int(nodem/100),' from node',node1, - &' to node', node2,': air massflow rate= ',xflow,'kg/s', - &', oil massflow rate= ',xflow_oil,'kg/s' - 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) -! - if(inv.eq.1) then - write(1,53)' Inlet node ',node1,': Tt1= ',Tt1, - & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, - & 'Bar, M1= ',M1 - write(1,*)' element W ',set(nelem+numf)(1:20) - write(1,57)' eta=',dvi,'kg/(m*s), Re= ' - & ,reynolds,', Phi= ',phi,', lambda= ',lambda, - & ', lambda*l/d= ',lambda*l/d,', zeta= ',phi*lambda*l/d - write(1,53)' Outlet node ',node2,' Tt2= ',Tt2, - & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1e5, - & 'Bar, M2= ',M2 -! - else if(inv.eq.-1) then - write(1,53)' Inlet node ',node2,': Tt1= ',Tt1, - & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, - & 'Bar, M1= ',M1 - write(1,*)' element W ',set(nelem+numf)(1:20) - write(1,57)' eta= ',dvi,'kg/(m*s), Re= ' - & ,reynolds,' ,Phi= ',phi,', lambda= ',lambda, - & ', lambda*l/d= ',lambda*l/d,', zeta= ',phi*lambda*l/d - write(1,53)' Outlet node ',node1,' Tt2= ',Tt2, - & 'K, Ts2= ',T2,'K, Pt2=',Pt2/1e5, - & 'Bar, M2= ',M2 - endif - endif - - 53 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A,f8.5) - 57 FORMAT(1X,A,G9.4,A,G11.4,A,f8.5,A,f8.5,A,f8.5,A,f8.5) -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gaspipe_fanno.f calculix-ccx-2.3/ccx_2.1/src/gaspipe_fanno.f --- calculix-ccx-2.1/ccx_2.1/src/gaspipe_fanno.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gaspipe_fanno.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,934 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gaspipe_fanno(node1,node2,nodem,nelem,lakon,kon, - & ipkon,nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,cp,r,physcon,dvi,numf,set, - & shcon,nshcon,rhcon,nrhcon,ntmat_,co,vold,mi) -! -! pipe with friction losses (Fanno Formulas) GAPF -! - implicit none -! - logical identity,crit - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, - & ielprop(*),nodef(5),idirf(5),index,iflag, - & inv,ipkon(*),kon(*),icase,kgas,k_oil - & ,nshcon(*),nrhcon(*),ntmat_,i,mi(2),nodea,nodeb, - & nodec,iaxial - -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,R,a,d,l, - & p1,p2,T1,T2,Tt1,Tt2,pt1,pt2,cp,physcon(3),p2p1,km1,dvi, - & kp1,kdkm1,reynolds,pi,e,lambda,lld,kdkp1,T2dTt2, - & T1dTt1,X_t1dTt1,X_t2dTt2,X2_den,X1_den, - & X1,X2,B1,B2,C1,C2,tdkp1, - & pt2zpt1,ks,form_fact,xflow_oil,Tt1dT1,Tt2dT2, - & Pt2zPt1_c,qred_crit,l_neg,Qred, - & expon1,expon2,cte,term1,term2,term3,term4,term5,term6, - & term,phi,M1,M2,qred2,qred1,qred_max1,qred_crit_out,co(3,*), - & shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),vold(0:mi(2),*), - & radius,initial_radius,l_initial -! -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif (iflag.eq.1)then -! - crit=.false. -! - pi=4.d0*datan(1.d0) -! - index=ielprop(nelem) - kappa=(cp/(cp-R)) - A=prop(index+1) - d=prop(index+2) - l=prop(index+3) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+4) - if(lakon(nelem)(2:6).eq.'GAPFA') then - icase=0 - elseif(lakon(nelem)(2:6).eq.'GAPFI') then - icase=1 - endif - form_fact=prop(index+5) - xflow_oil=prop(index+6) - k_oil=int(prop(index+7)) -! - if((lakon(nelem)(2:6).eq.'GAPFF').and. - & (lakon(nelem)(2:7).ne.'GAPFF2')) then -! - icase=0 - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - iaxial=int(prop(index+3)) - radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2) -! - initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2) - - if(iaxial.ne.0) then - A=pi*radius**2/iaxial - else - A=pi*radius**2 - endif - d=2*radius - l=prop(index+4) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+5) - form_fact=prop(index+6) - xflow_oil=prop(index+7) - k_oil=int(prop(index+8)) -! - elseif (lakon(nelem)(2:7).eq.'GAPFF2') then - write(*,*) nelem,lakon(nelem)(1:6) - icase=0 - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - nodec=int(prop(index+3)) - iaxial=int(prop(index+4)) - radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2) - initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2) - d=2*radius - if(iaxial.ne.0) then - A=pi*radius**2/iaxial - else - A=pi*radius**2 - endif - l_initial=dsqrt((co(2,nodec)-co(2,nodeb))**2) - l=dsqrt((co(2,nodec)+vold(2,nodec)- - & co(2,nodeb)-vold(2,nodeb))**2) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+5) - form_fact=prop(index+6) - xflow_oil=prop(index+7) - k_oil=int(prop(index+8)) - endif - - pt1=v(2,node1) - pt2=v(2,node2) - -! - if(pt1.ge.pt2) then - inv=1 - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) - else - inv=-1 - pt1=v(2,node2) - pt2=v(2,node1) - Tt1=v(0,node2)+physcon(1) - Tt2=v(0,node1)+physcon(1) - endif -! - write(*,*) pt1,pt2,Tt1,Tt2 - - p2p1=pt2/pt1 - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - tdkp1=2.d0/kp1 - C2=tdkp1**kdkm1 -! -! incompressible flow - xflow=inv*A*dsqrt(d/l*2*Pt1/(R*Tt1)*(pt1-pt2)) - if(p2p1.gt.C2) then - xflow=inv*pt1*a*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa) - & *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(Tt1) - else - xflow=inv*pt1*a*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ - & dsqrt(Tt1) - endif -! -! calculation of the dynamic viscosity -! - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,Tt1,dvi) - endif -! - reynolds=dabs(xflow)*d/(dvi*a) -! - call friction_coefficient(l_neg,d,ks,reynolds,form_fact,lambda) - xflow=inv*A*dsqrt(d/(lambda*l)*2*Pt1/(R*Tt1)*(pt1-pt2)) -! - call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, - & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) -! - Qred=dabs(xflow)*dsqrt(Tt1)/(A*pt1) -! - if (crit) then - xflow=0.5*inv*Qred_crit*Pt1*A/dsqrt(Tt1) - if(icase.eq.1) then -! - call ts_calc(xflow,Tt1,pt1,kappa,r,a,T1,icase) - if (inv.eq.1) then - v(3,node1)=T1 - v(3,node2)=T1 - if(nactdog(0,node2).eq.1) then - v(0,node2)=T1*(1.d0+km1/(2*kappa)) - endif - else - v(3,node2)=T1 - v(3,node1)=T1 - if(nactdog(0,node1).eq.1) then - v(0,node1)=T1*(1.d0+km1/(2*kappa)) - endif - endif - endif - elseif(Qred.gt.Qred_crit) then - xflow=0.5*inv*Qred_crit*pt1*A/dsqrt(Tt1) - else - xflow=inv*Qred*pt1*A/dsqrt(Tt1) - endif -! xflow=0.5d0*dabs(xflow) -! - elseif (iflag.eq.2)then -! - numf=5 - crit=.false. -! - pi=4.d0*datan(1.d0) - e=2.7182818d0 -! - kappa=(cp/(cp-R)) - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - kdkp1=kappa/kp1 -! - index=ielprop(nelem) - A=prop(index+1) - d=prop(index+2) -! - l=prop(index+3) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+4) - if(lakon(nelem)(2:6).eq.'GAPFA') then - icase=0 - elseif(lakon(nelem)(2:6).eq.'GAPFI') then - icase=1 - endif - form_fact=prop(index+5) - xflow_oil=prop(index+6) - k_oil=int(prop(index+7)) -! - if((lakon(nelem)(2:6).eq.'GAPFF').and. - & (lakon(nelem)(2:7).ne.'GAPFF2')) then - icase=0 - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - iaxial=int(prop(index+3)) - radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2) - initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2) - d=2*radius - if(iaxial.ne.0) then - A=pi*radius**2/iaxial - else - A=pi*radius**2 - endif - l=prop(index+4) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+5) - form_fact=prop(index+6) - xflow_oil=prop(index+7) - k_oil=int(prop(index+8)) -! - elseif (lakon(nelem)(2:7).eq.'GAPFF2') then - icase=0 - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - nodec=int(prop(index+3)) - iaxial=int(prop(index+4)) - radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2) - initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2) - d=2*radius - if(iaxial.ne.0) then - A=pi*radius**2/iaxial - else - A=pi*radius**2 - endif - l_initial=dsqrt((co(2,nodec)-co(2,nodeb))**2) - l=-dsqrt((co(2,nodec)+vold(2,nodec)- - & co(2,nodeb)-vold(2,nodeb))**2) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+5) - form_fact=prop(index+6) - xflow_oil=prop(index+7) - k_oil=int(prop(index+8)) - endif - - pt1=v(2,node1) - pt2=v(2,node2) - xflow=v(1,nodem) -! - if(xflow.ge.0d0) then - inv=1 - Tt1=v(0,node1)+physcon(1) - if(icase.eq.0) then - Tt2=Tt1 - else - Tt2=v(0,node2)+physcon(1) - endif -! - call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) -! - call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 - nodef(5)=node2 - else - inv=-1 - pt1=v(2,node2) - pt2=v(2,node1) - xflow=-v(1,nodem) - Tt1=v(0,node2)+physcon(1) - if(icase.eq.0) then - Tt2=Tt1 - else - Tt2=v(0,node1)+physcon(1) - endif -! - call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) -! - call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - nodef(5)=node1 - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 - idirf(5)=0 -! - pt2zpt1=pt2/pt1 -! -! calculation of the dynamic viscosity -! - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif -! - reynolds=dabs(xflow)*d/(dvi*a) -! -! definition of the friction coefficient for 2 phase flows and pure air -! -! Friedel's Method - if(lakon(nelem)(7:7).eq.'F') then -! - if((k_oil.lt.0).or.(k_oil.gt.12)) then - write(*,*) '*ERROR:in gaspipe.f' - write(*,*) ' using two phase flow' - write(*,*) ' the type of oil is not defined' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Current calculation stops here' - stop - elseif(xflow_oil.eq.0.d0) then - write(*,*) '*WARNING:in gaspipe.f' - write(*,*) ' using two phase flow' - write(*,*) ' the oil mass flow rate is NULL' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Only pure air is considered' - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - else - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) -! - lambda=lambda*phi -! - endif -! -! Alber's Method -! - elseif (lakon(nelem)(7:7).eq.'A') then - if((k_oil.lt.0).or.(k_oil.gt.12)) then - write(*,*) '*ERROR:in gaspipe_fanno.f' - write(*,*) ' using two phase flow' - write(*,*) ' the type of oil is not defined' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Current calculation stops here' - stop - elseif(xflow_oil.eq.0) then - write(*,*) '*WARNING:in gaspipe_fanno.f' - write(*,*) ' using two phase flow' - write(*,*) ' the oil mass flow rate is NULL' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Only pure air is considered' - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - else - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) -! - - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) -! - lambda=lambda*phi -! - endif -! -! for pure air -! - else -! - phi=1.d0 - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - endif -! - call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, - & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) - - Qred1=xflow*dsqrt(Tt1)/(A*Pt1) - - if(dabs(xflow)*dsqrt(Tt1)/(A*Pt1).gt.qred_max1) then - crit=.true. - endif -! - Qred2=xflow*dsqrt(Tt2)/(A*Pt2) - if(icase.eq.0) then - qred_crit_out=dsqrt(kappa/R)*(2/(kappa+1))**(0.5d0* - & (kappa+1)/(kappa-1)) - else - qred_crit_out=R**(-0.5d0)*(2/(kappa+1))**(0.5d0* - & (kappa+1)/(kappa-1)) - endif -! -! definition of the coefficients -! - lld=lambda*l/d -! - M2=dsqrt(2/km1*((Tt2/T2)-1)) - if(icase.eq.0) then - if((M2.lt.1)) then - crit=.false. - if((M2.ge.1.d0).or.(dabs(M2-1).lt.1E-5)) then - pt2=pt1*pt2zpt1_c - endif - endif - elseif (icase.eq.1) then - if(M2.lt.1/dsqrt(kappa)) then - crit=.false. - else - crit=.true. - endif - endif -! -! adiabatic case -! - if(icase.eq.0) then -! - T2dTt2=T2/Tt2 - Tt2dT2=1.d0/T2dTt2 - X_T2dTt2=T2dTt2**(2*kdkm1) - T1dTt1=T1/Tt1 - Tt1dT1=1.d0/T1dTt1 - X_T1dTt1=T1dTt1**(2*kdkm1) -! - X2_den=pt2**2*X_T2dTt2 - X2=t2**2/X2_den - X1_den=pt1**2*X_T1dTt1 - X1=T1**2/X1_den -! - C1=2.d0*cp*A**2*X1_den*(-1.d0+2.d0*kdkm1*T1dTt1) - & -2.d0*xflow**2*R**2*T1 -! - C2=2.d0*cp*A**2*X2_den*(-1.d0+2.d0*kdkm1*T2dTt2) - & -2.d0*xflow**2*R**2*T2 -! - expon1=(kappa+1)/km1 - expon2=2*kappa/(km1) -! - cte=0.5d0*(kappa+1)/kappa -! - term1=pt1**2*T1**expon1*Tt1**(-expon2)*A**2 -! - if(.not.crit) then - term1=pt1**2*T1**expon1*Tt1**(-expon2)*A**2 - term2=pt2**2*T2**expon1*Tt2**(-expon2)*A**2 -! - -! simplified version - term3=Tt2dT2 - term4=Tt1dT1 -! - term5=T1**(expon1)*Tt1**(-expon2)*(pt1**2) - term6=T2**(expon1)*Tt2**(-expon2)*(pt2**2) - - B1=1/(R*xflow**2)*term1*expon1/T1 - & +cte*(-(2/km1)*1/T1) -! - B2=1/(R*xflow**2)*term2*(-expon1/T2) - & +cte*(2/km1*1/T2) -! -! residual -! -! Simplified version -! - f=1/(R*xflow**2)*(term1-term2) - & +cte*(log(term3)-log(term4)-log(term5)+log(term6)) - & -lld - & +b2/c2*(2*cp*A**2*(Tt2-T2) - & *X2_den-xflow**2*R**2*T2**2) - & +b1/c1*(2*cp*A**2*(Tt1-T1) - & *X1_den-xflow**2*R**2*T1**2) -! -! pressure node1 -! - df(1)=1/(R*xflow**2)*(term1*2/pt1) - & +cte*(-2/pt1) - & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1) -! -! temperature node1 -! - df(2)=1/(R*xflow**2)*term1*(-expon2)/Tt1 - & +cte*(expon1*1/Tt1) - & +b1/c1*(2*cp*A**2*X1_den - & *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1)) -! -! mass flow -! - df(3)=-2.d0/(R*(inv*xflow)**3)*(term1-term2) - & +B2/C2*(-2.d0*inv*xflow*R*R*T2**2.d0) - & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0) -! -! pressure node2 -! - df(4)=1/(R*xflow**2)*(-term2*2/pt2) - & +cte*(2/pt2) - & +B2/C2*(4.d0*cp*A**2*(Tt2-T2)*pt2*X_T2dTt2) -! -! temperature node2 -! - df(5)=1/(R*xflow**2)*term2*(expon2/Tt2) - & +cte*(-expon1*1/Tt2) - & +b2/c2*(2*cp*A**2*X2_den - & *(1.d0-2.d0*kdkm1*(Tt2-T2)/Tt2)) - - else -! - term=kappa*term1/(xflow**2*R) - B1=expon1*1/T1*(1/kappa*term-1)+cte*1/T1 - f=1/kappa*(term1-1)+cte*(log(T1dTt1)-log(2/kp1*term)) - & -lld - & +b1/c1*(2*cp*A**2*(Tt1-T1) - & *X1_den-xflow**2*R**2*T1**2) -! -! pressure node1 -! - df(1)=2/pt1*(1/kappa*term-cte) - & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1) -! -! temperature node1 -! - df(2)=expon2*1/Tt1*(-1/kappa*term+1)-cte*1/Tt1 - & +b1/c1*(2*cp*A**2*X1_den - & *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1)) -! -! mass flow -! - df(3)=2.d0/(inv*xflow)*(-term/kappa+cte) - & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0) -! -! pressure node2 -! - df(4)=0.d0 -! -! temperature node2 -! - df(5)=0.d0 - endif -! -! isothermal icase -! - elseif(icase.eq.1) then - T2dTt2=T2/Tt2 - Tt2dT2=1.d0/T2dTt2 - X_T2dTt2=T2dTt2**(2*kdkm1) - T1dTt1=T1/Tt1 - Tt1dT1=1.d0/T1dTt1 - X_T1dTt1=T1dTt1**(2*kdkm1) -! - X2_den=pt2**2*X_T2dTt2 - X2=t2**2/X2_den - X1_den=pt1**2*X_T1dTt1 - X1=T1**2/X1_den -! - C1=2.d0*cp*A**2*X1_den*(1.d0-2.d0*kdkm1*(Tt1dT1-1.d0)) - & +2.d0*xflow**2*R**2*T1 -! - C2=2.d0*cp*A**2*X2_den*(1.d0-2.d0*kdkm1*(Tt2dT2-1.d0)) - & +2.d0*xflow**2*R**2*T2 -! - expon1=(kappa+1)/km1 - expon2=2*kappa/(kappa-1) -! - cte=0.5d0*(kappa+1)/kappa -! - term1=pt1**2*T1**expon1*Tt1**(-expon2)*A**2 - term2=pt2**2*T2**expon1*Tt2**(-expon2)*A**2 -! - term5=T1**(expon1)*Tt1**(-expon2)*(pt1**2*A**2) - term6=T2**(expon1)*Tt2**(-expon2)*(pt2**2*A**2) -! - if(.not.crit) then - B1=1/(R*xflow**2)*term1*expon1/T1 - & -expon1/T1 -! - B2=1/(R*xflow**2)*term2*(-expon1/T2) - & +expon1/T2 -! -! Simplified version -! - f=1/(R*xflow**2)*(term1-term2) - & +(-log(term5)+log(term6)) - & -lld - & +b2/c2*(2*cp*A**2*(Tt2-T2) - & *X2_den-xflow**2*R**2*T2**2) - & +b1/c1*(2*cp*A**2*(Tt1-T1) - & *X1_den-xflow**2*R**2*T1**2) -! -! pressure node1 -! - df(1)=1/(R*xflow**2)*(term1*2/pt1) - & +(-(2/pt1)) - & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1) -! -! temperature node1 -! - df(2)=1/(R*xflow**2)*term1*(-expon2)/Tt1 - & +(expon2/Tt1) - & +b1/c1*(2*cp*A**2*X1_den - & *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1)) -! -! mass flow -! - df(3)=-2.d0/(R*xflow**3)*(term1-term2) - & +B2/C2*(-2.d0*inv*xflow*R*R*T2**2.d0) - & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0) -! -! pressure node2 -! - df(4)=1/(R*xflow**2)*(-term2*2/pt2) - & +(2/pt2) - & +B2/C2*(4.d0*cp*A**2*(Tt2-T2)*pt2*X_T2dTt2) -! -! -! temperature node2 -! - df(5)=1/(R*xflow**2)*term2*(expon2/Tt2) - & +(-expon2/Tt2) - & +b2/c2*(2*cp*A**2*X2_den - & *(1.d0-2.d0*kdkm1*(Tt2-T2)/Tt2)) - - else - term=term1/(xflow**2*R) - B1=expon1/T1*(term-1) -! alternate critical equation -! - f=term-1-log(term) - & -lld - & +b1/c1*(2*cp*A**2*(Tt1-T1) - & *X1_den-xflow**2*R**2*T1**2) -! -! pressure node1 -! - df(1)=2/pt1*(term-1) - & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1) -! -! temperature node1 -! - df(2)=expon2/Tt1*(-term+1) - & +b1/c1*(2*cp*A**2*X1_den - & *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1)) -! -! mass flow -! - df(3)=2/xflow*(-term+1) - & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0) -! -! pressure node2 -! - df(4)=0.d0 -! -! -! temperature node2 -! - df(5)=0.d0 -! - endif - endif -! -! output -! - elseif(iflag.eq.3) then - - pi=4.d0*datan(1.d0) - e=2.7182818d0 -! - kappa=(cp/(cp-R)) - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - kdkp1=kappa/kp1 -! - index=ielprop(nelem) - A=prop(index+1) - d=prop(index+2) - l=prop(index+3) - if(l.lt.0d0) then - l_neg=l - l=abs(l) - else - l_neg=l - endif - ks=prop(index+4) - if(lakon(nelem)(2:6).eq.'GAPFA') then - icase=0 - elseif(lakon(nelem)(2:6).eq.'GAPFI') then - icase=1 - endif - form_fact=prop(index+5) - xflow_oil=prop(index+6) - k_oil=int(prop(index+7)) -! - pt1=v(2,node1) - pt2=v(2,node2) -! - if(xflow.ge.0d0) then - inv=1 - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - if(icase.eq.0) then - Tt2=Tt1 - else - Tt2=v(0,node2)+physcon(1) - endif -! - call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) -! - call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) -! - else - inv=-1 - pt1=v(2,node2) - pt2=v(2,node1) - xflow=v(1,nodem) -! - Tt1=v(0,node2)+physcon(1) - if(icase.eq.0) then - Tt2=Tt1 - else - Tt2=v(0,node1)+physcon(1) - endif -! - call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) - call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - nodef(5)=node1 - endif -! - pt2zpt1=pt2/pt1 -! -! calculation of the dynamic viscosity -! - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif -! - reynolds=dabs(xflow)*d/(dvi*a) -! -! definition of the friction coefficient for 2 phase flows and pure air -! -! Friedel's Method - if(lakon(nelem)(7:7).eq.'F') then -! - if((k_oil.lt.0).or.(k_oil.gt.12)) then - write(*,*) '*ERROR:in gaspipe.f' - write(*,*) ' using two phase flow' - write(*,*) ' the type of oil is not defined' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Current calculation stops here' - stop - elseif(xflow_oil.eq.0) then - write(*,*) '*WARNING:in gaspipe.f' - write(*,*) ' using two phase flow' - write(*,*) ' the oil mass flow rate is NULL' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Only pure air is considered' - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - else - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) -! - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) -! - endif -! - elseif (lakon(nelem)(7:7).eq.'A') then - if((k_oil.lt.0).or.(k_oil.gt.12)) then - write(*,*) '*ERROR:in gaspipe.f' - write(*,*) ' using two phase flow' - write(*,*) ' the type of oil is not defined' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Current calculation stops here' - stop - elseif(xflow_oil.eq.0) then - write(*,*) '*WARNING:in gaspipe.f' - write(*,*) ' using two phase flow' - write(*,*) ' the oil mass flow rate is NULL' - write(*,*) ' check element ',nelem,' definition' - write(*,*) ' Only pure air is considered' - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - else - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) -! - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) -! - endif -! -! for pure air -! - else - phi=1.d0 - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - endif -! - call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, - & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) - -! -! definition of the coefficients -! - M1=dsqrt(2/km1*((Tt1/T1)-1)) - M2=dsqrt(2/km1*((Tt2/T2)-1)) -! - write(1,*) '' - write(1,55) 'In line',int(nodem/1000),' from node',node1, - &' to node', node2,': air massflow rate= ',xflow,'kg/s', - &', oil massflow rate= ',xflow_oil,'kg/s' - 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) -! - if(inv.eq.1) then - write(1,53)' Inlet node ',node1,': Tt1= ',Tt1, - & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, - & 'Bar, M1= ',M1 - write(1,*)' element W ',set(numf)(1:20) - write(1,57)' Eta=',dvi,' kg/(m*s), Re= ' - & ,reynolds,', PHI= ',phi,', LAMBDA= ',lambda, - & ', LAMBDA*l/d= ',lambda*l/d,', ZETA_PHI= ',phi*lambda*l/d - write(1,53)' Outlet node ',node2,' Tt2= ',Tt2, - & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1e5, - & 'Bar, M2= ',M2 -! - else if(inv.eq.-1) then - write(1,53)' Inlet node ',node2,': Tt1= ',Tt1, - & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, - & 'Bar, M1= ',M1 - write(1,*)' element W ',set(numf)(1:20) - write(1,57)' Eta= ',dvi,' kg/(m*s), Re= ' - & ,reynolds,' ,Phi= ',phi,', lambda= ',lambda, - & ', lamda*l/d= ',lambda*l/d,', zeta_phi= ',phi*lambda*l/d - write(1,53)' Outlet node ',node1,' Tt2= ',Tt2, - & 'K, Ts2= ',T2,'K, Pt2=',Pt2/1e5, - & 'Bar, M2= ',M2 - endif - endif - 53 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A,f8.5) - 57 FORMAT(1X,A,G9.4,A,G11.5,A,f8.4,A,f8.5,A,f8.5,A,f8.5) -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gauss.f calculix-ccx-2.3/ccx_2.1/src/gauss.f --- calculix-ccx-2.1/ccx_2.1/src/gauss.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gauss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,269 +0,0 @@ -! -! contains Gauss point information -! -! gauss2d1: quad, 1-point integration (1 integration point) -! gauss2d2: quad, 2-point integration (4 integration points) -! gauss2d3: quad, 3-point integration (9 integration points) -! gauss2d4: tri, 1 integration point -! gauss2d5: tri, 3 integration points -! gauss3d1: hex, 1-point integration (1 integration point) -! gauss3d2: hex, 2-point integration (8 integration points) -! gauss3d3: hex, 3-point integration (27 integration points) -! gauss3d4: tet, 1 integration point -! gauss3d5: tet, 4 integration points -! gauss3d6: tet, 15 integration points -! gauss3d7: wedge, 2 integration points -! gauss3d8: wedge, 9 integration points -! gauss3d9: wedge, 18 integration points -! gauss3d10: wedge, 6 integration points -! gauss3d11: wedge, 18 integration points -! -! weight2d1,... contains the weights -! -! - real*8 gauss2d1(2,1),gauss2d2(2,4),gauss2d3(2,9),gauss2d4(2,1), - & gauss2d5(2,3),gauss3d1(3,1),gauss3d2(3,8),gauss3d3(3,27), - & gauss3d4(3,1),gauss3d5(3,4),gauss3d6(3,15),gauss3d7(3,2), - & gauss3d8(3,9),gauss3d9(3,18),gauss3d10(3,6), - & weight2d1(1),weight2d2(4), - & weight2d3(9),weight2d4(1),weight2d5(3),weight3d1(1), - & weight3d2(8),weight3d3(27),weight3d4(1),weight3d5(4), - & weight3d6(15),weight3d7(2),weight3d8(9),weight3d9(18), - & weight3d10(6),gauss2d61(3,3),gauss2d62(3,3), - & gauss2d71(3,3),gauss2d72(3,3),weight2d7(3),weight2d61(3), - & weight2d62(3) -! - data gauss2d1 /0.,0./ -! -! the order of the Gauss points in gauss2d2 is important -! and should not be changed (used to accelerate the code -! for CAX8R axisymmetric elements in e_c3d_th.f) -! - data gauss2d2 / - & -0.577350269189626d0,-0.577350269189626d0, - & 0.577350269189626d0,-0.577350269189626d0, - & -0.577350269189626d0,0.577350269189626d0, - & 0.577350269189626d0,0.577350269189626d0/ -! - data gauss2d3 / - & -0.774596669241483d0,-0.774596669241483d0, - & -0.d0,-0.774596669241483d0, - & 0.774596669241483d0,-0.774596669241483d0, - & -0.774596669241483d0,0.d0, - & -0.d0,0.d0, - & 0.774596669241483d0,0.d0, - & -0.774596669241483d0,0.774596669241483d0, - & -0.d0,0.774596669241483d0, - & 0.774596669241483d0,0.774596669241483d0/ -! - data gauss2d4 /0.333333333333333d0,0.333333333333333d0/ -! - data gauss2d5 / - & 0.166666666666667d0,0.166666666666667d0, - & 0.666666666666667d0,0.166666666666667d0, - & 0.166666666666667d0,0.666666666666667d0/ -! - data gauss2d61 / - & 0.091576213509771d0,0.091576213509771d0,0.816847572980459d0, - & 0.816847572980459d0,0.091576213509771d0,0.091576213509771d0, - & 0.091576213509771d0,0.816847572980459d0,0.091576213509771d0/ -! - data gauss2d62 / - & 0.445948490915965d0,0.445948490915965d0,0.108103018168070d0, - & 0.108103018168070d0,0.445948490915965d0,0.445948490915965d0, - & 0.445948490915965d0,0.108103018168070d0,0.445948490915965d0/ -! - data gauss2d71 / - & 0.797426985353087d0,0.101286507323456d0,0.101286507323456, - & 0.101286507323456d0,0.797426985353087d0,0.101286507323456, - & 0.101286507323456d0,0.101286507323456d0,0.797426985353087d0/ -! - data gauss2d72 / - & 0.470142064105115d0,0.059715871789770d0,0.470142064105115d0, - & 0.059715871789770d0,0.470142064105115d0,0.470142064105115d0, - & 0.470142064105115d0,0.470142064105115d0,0.059715871789770d0/ -! -! - data gauss3d1 /0.,0.,0./ -! -! the order of the Gauss points in gauss3d2 is important -! and should not be changed (used to accelerate the code -! for CAX8R axisymmetric elements in e_c3d_th.f) -! - data gauss3d2 / - & -0.577350269189626d0,-0.577350269189626d0,-0.577350269189626d0, - & 0.577350269189626d0,-0.577350269189626d0,-0.577350269189626d0, - & -0.577350269189626d0,0.577350269189626d0,-0.577350269189626d0, - & 0.577350269189626d0,0.577350269189626d0,-0.577350269189626d0, - & -0.577350269189626d0,-0.577350269189626d0,0.577350269189626d0, - & 0.577350269189626d0,-0.577350269189626d0,0.577350269189626d0, - & -0.577350269189626d0,0.577350269189626d0,0.577350269189626d0, - & 0.577350269189626d0,0.577350269189626d0,0.577350269189626d0/ -! - data gauss3d3 / - & -0.774596669241483d0,-0.774596669241483d0,-0.774596669241483d0, - & 0.d0,-0.774596669241483d0,-0.774596669241483d0, - & 0.774596669241483d0,-0.774596669241483d0,-0.774596669241483d0, - & -0.774596669241483d0,0.d0,-0.774596669241483d0, - & 0.d0,0.d0,-0.774596669241483d0, - & 0.774596669241483d0,0.d0,-0.774596669241483d0, - & -0.774596669241483d0,0.774596669241483d0,-0.774596669241483d0, - & 0.d0,0.774596669241483d0,-0.774596669241483d0, - & 0.774596669241483d0,0.774596669241483d0,-0.774596669241483d0, - & -0.774596669241483d0,-0.774596669241483d0,0.d0, - & 0.d0,-0.774596669241483d0,0.d0, - & 0.774596669241483d0,-0.774596669241483d0,0.d0, - & -0.774596669241483d0,0.d0,0.d0, - & 0.d0,0.d0,0.d0, - & 0.774596669241483d0,0.d0,0.d0, - & -0.774596669241483d0,0.774596669241483d0,0.d0, - & 0.d0,0.774596669241483d0,0.d0, - & 0.774596669241483d0,0.774596669241483d0,0.d0, - & -0.774596669241483d0,-0.774596669241483d0,0.774596669241483d0, - & 0.d0,-0.774596669241483d0,0.774596669241483d0, - & 0.774596669241483d0,-0.774596669241483d0,0.774596669241483d0, - & -0.774596669241483d0,0.d0,0.774596669241483d0, - & 0.d0,0.d0,0.774596669241483d0, - & 0.774596669241483d0,0.d0,0.774596669241483d0, - & -0.774596669241483d0,0.774596669241483d0,0.774596669241483d0, - & 0.d0,0.774596669241483d0,0.774596669241483d0, - & 0.774596669241483d0,0.774596669241483d0,0.774596669241483d0/ -! - data gauss3d4 /0.25d0,0.25d0,0.25d0/ -! - data gauss3d5 / - & 0.138196601125011d0,0.138196601125011d0,0.138196601125011d0, - & 0.585410196624968d0,0.138196601125011d0,0.138196601125011d0, - & 0.138196601125011d0,0.585410196624968d0,0.138196601125011d0, - & 0.138196601125011d0,0.138196601125011d0,0.585410196624968d0/ -! - data gauss3d6 / - & 0.25,0.25,0.25d0, - & 0.091971078052723d0,0.091971078052723d0,0.091971078052723d0, - & 0.724086765841831d0,0.091971078052723d0,0.091971078052723d0, - & 0.091971078052723d0,0.724086765841831d0,0.091971078052723d0, - & 0.091971078052723d0,0.091971078052723d0,0.724086765841831d0, - & 0.319793627829630d0,0.319793627829630d0,0.319793627829630d0, - & 0.040619116511110d0,0.319793627829630d0,0.319793627829630d0, - & 0.319793627829630d0,0.040619116511110d0,0.319793627829630d0, - & 0.319793627829630d0,0.319793627829630d0,0.040619116511110d0, - & 0.056350832689629d0,0.056350832689629d0,0.443649167310371d0, - & 0.443649167310371d0,0.056350832689629d0,0.056350832689629d0, - & 0.443649167310371d0,0.443649167310371d0,0.056350832689629d0, - & 0.056350832689629d0,0.443649167310371d0,0.443649167310371d0, - & 0.056350832689629d0,0.443649167310371d0,0.056350832689629d0, - & 0.443649167310371d0,0.056350832689629d0,0.443649167310371d0/ -! - data gauss3d7 / - & 0.333333333333333d0,0.333333333333333d0,-0.577350269189626d0, - & 0.333333333333333d0,0.333333333333333d0,0.577350269189626d0/ -! - data gauss3d8 / - & 0.166666666666667d0,0.166666666666667d0,-0.774596669241483d0, - & 0.666666666666667d0,0.166666666666667d0,-0.774596669241483d0, - & 0.166666666666667d0,0.666666666666667d0,-0.774596669241483d0, - & 0.166666666666667d0,0.166666666666667d0,0.d0, - & 0.666666666666667d0,0.166666666666667d0,0.d0, - & 0.166666666666667d0,0.666666666666667d0,0.d0, - & 0.166666666666667d0,0.166666666666667d0,0.774596669241483d0, - & 0.666666666666667d0,0.166666666666667d0,0.774596669241483d0, - & 0.166666666666667d0,0.666666666666667d0,0.774596669241483d0/ -! - data gauss3d9 / - & 0.166666666666667d0,0.166666666666667d0,-0.774596669241483d0, - & 0.166666666666667d0,0.666666666666667d0,-0.774596669241483d0, - & 0.666666666666667d0,0.166666666666667d0,-0.774596669241483d0, - & 0.000000000000000d0,0.500000000000000d0,-0.774596669241483d0, - & 0.500000000000000d0,0.000000000000000d0,-0.774596669241483d0, - & 0.500000000000000d0,0.500000000000000d0,-0.774596669241483d0, - & 0.166666666666667d0,0.166666666666667d0,0.d0, - & 0.166666666666667d0,0.666666666666667d0,0.d0, - & 0.666666666666667d0,0.166666666666667d0,0.d0, - & 0.000000000000000d0,0.500000000000000d0,0.d0, - & 0.500000000000000d0,0.000000000000000d0,0.d0, - & 0.500000000000000d0,0.500000000000000d0,0.d0, - & 0.166666666666667d0,0.166666666666667d0,0.774596669241483d0, - & 0.166666666666667d0,0.666666666666667d0,0.774596669241483d0, - & 0.666666666666667d0,0.166666666666667d0,0.774596669241483d0, - & 0.000000000000000d0,0.500000000000000d0,0.774596669241483d0, - & 0.500000000000000d0,0.000000000000000d0,0.774596669241483d0, - & 0.500000000000000d0,0.500000000000000d0,0.774596669241483d0/ -! - data gauss3d10 / - & 0.166666666666667d0,0.166666666666667d0,-0.577350269189626d0, - & 0.666666666666667d0,0.166666666666667d0,-0.577350269189626d0, - & 0.166666666666667d0,0.666666666666667d0,-0.577350269189626d0, - & 0.166666666666667d0,0.166666666666667d0,0.577350269189626d0, - & 0.666666666666667d0,0.166666666666667d0,0.577350269189626d0, - & 0.166666666666667d0,0.666666666666667d0,0.577350269189626d0/ -! - data weight2d1 /4.d0/ -! - data weight2d2 /1.d0,1.d0,1.d0,1.d0/ -! - data weight2d3 / - & 0.308641975308642d0,0.493827160493827d0,0.308641975308642d0, - & 0.493827160493827d0,0.790123456790123d0,0.493827160493827d0, - & 0.308641975308642d0,0.493827160493827d0,0.308641975308642d0/ -! - data weight2d4 /0.5d0/ -! - data weight2d5 / - & 0.166666666666666d0,0.166666666666666d0,0.166666666666666d0/ -! - data weight2d7 / - & 0.225000d0,0.125939180544827d0,0.132394152788506d0/ -! - data weight2d61 / - & 0.109951743655322d0,0.109951743655322d0,0.109951743655322d0/ -! - data weight2d62 / - & 0.223381589678011d0,0.223381589678011d0,0.223381589678011d0/ -! - data weight3d1 /8.d0/ -! - data weight3d2 /1.d0,1.d0,1.d0,1.d0,1.d0,1.d0,1.d0,1.d0/ -! - data weight3d3 / - & 0.171467764060357d0,0.274348422496571d0,0.171467764060357d0, - & 0.274348422496571d0,0.438957475994513d0,0.274348422496571d0, - & 0.171467764060357d0,0.274348422496571d0,0.171467764060357d0, - & 0.274348422496571d0,0.438957475994513d0,0.274348422496571d0, - & 0.438957475994513d0,0.702331961591221d0,0.438957475994513d0, - & 0.274348422496571d0,0.438957475994513d0,0.274348422496571d0, - & 0.171467764060357d0,0.274348422496571d0,0.171467764060357d0, - & 0.274348422496571d0,0.438957475994513d0,0.274348422496571d0, - & 0.171467764060357d0,0.274348422496571d0,0.171467764060357d0/ -! - data weight3d4 /0.166666666666667d0/ -! - data weight3d5 / - & 0.041666666666667d0,0.041666666666667d0,0.041666666666667d0, - & 0.041666666666667d0/ -! - data weight3d6 / - & 0.019753086419753d0,0.011989513963170d0,0.011989513963170d0, - & 0.011989513963170d0,0.011989513963170d0,0.011511367871045d0, - & 0.011511367871045d0,0.011511367871045d0,0.011511367871045d0, - & 0.008818342151675d0,0.008818342151675d0,0.008818342151675d0, - & 0.008818342151675d0,0.008818342151675d0,0.008818342151675d0/ -! - data weight3d7 /0.5d0,0.5d0/ -! - data weight3d8 / - & 0.092592592592593d0,0.092592592592593d0,0.092592592592593d0, - & 0.148148148148148d0,0.148148148148148d0,0.148148148148148d0, - & 0.092592592592593d0,0.092592592592593d0,0.092592592592593d0/ -! - data weight3d9 / - & 0.083333333333333d0,0.083333333333333d0,0.083333333333333d0, - & 0.009259259259259d0,0.009259259259259d0,0.009259259259259d0, - & 0.133333333333333d0,0.133333333333333d0,0.133333333333333d0, - & 0.014814814814815d0,0.014814814814815d0,0.014814814814815d0, - & 0.083333333333333d0,0.083333333333333d0,0.083333333333333d0, - & 0.009259259259259d0,0.009259259259259d0,0.009259259259259d0/ -! - data weight3d10 / - & 0.166666666666666d0,0.166666666666666d0,0.166666666666666d0, - & 0.166666666666666d0,0.166666666666666d0,0.166666666666666d0/ -! diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dboun.f calculix-ccx-2.3/ccx_2.1/src/gen3dboun.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dboun.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dboun.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,633 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dboun(ikboun,ilboun,nboun,nboun_,nodeboun,ndirboun, - & xboun,iamboun,typeboun,iponoel,inoel,iponoelmax,kon,ipkon, - & lakon,ne,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc,nmpc_, - & mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk,nk_,co, - & nmethod,iperturb,istep,vold,mi) -! -! connects nodes of 1-D and 2-D elements, for which SPC's were -! defined, to the nodes of their expanded counterparts -! - implicit none -! - logical fixed -! - character*1 type,typeboun(*) - character*8 lakon(*) - character*20 labmpc(*) -! - integer ikboun(*),ilboun(*),nboun,nboun_,nodeboun(*),ndirboun(*), - & iamboun(*),iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*),ne, - & iponor(2,*),knor(*),ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree, - & ikmpc(*),ilmpc(*),rig(*),ntrans,inotr(2,*),nbounold,i,node, - & index,ielem,j,indexe,indexk,idir,iamplitude,irotnode,nk,nk_, - & newnode,idof,id,mpcfreenew,k,nam,nmethod,iperturb,ndepnodes, - & idepnodes(80),l,iexpnode,indexx,irefnode,imax,isol,mpcfreeold, - & nod,impc,istep,nrhs,ipiv(3),info,m,mi(2) -! - real*8 xboun(*),xnor(*),coefmpc(*),trab(7,*),val,co(3,*), - & xnoref(3),dmax,d(3,3),e(3,3,3),alpha,q(3),w(3),xn(3), - & a1(3),a2(3),dd,c1,c2,c3,ww,c(3,3),vold(0:mi(2),*),a(3,3) -! - data d /1.,0.,0.,0.,1.,0.,0.,0.,1./ - data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., - & 0.,0.,1.,0.,0.,0.,-1.,0.,0., - & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ -! - fixed=.false. -! - nbounold=nboun - do i=1,nbounold - node=nodeboun(i) - if(node.gt.iponoelmax) then -c if(ndirboun(i).gt.3) then - if(ndirboun(i).gt.4) then - write(*,*) '*WARNING: in gen3dboun: node ',node, - & ' does not' - write(*,*) ' belong to a beam nor shell' - write(*,*) ' element and consequently has no' - write(*,*) ' rotational degrees of freedom' - endif - cycle - endif - index=iponoel(node) - if(index.eq.0) then -c if(ndirboun(i).gt.3) then - if(ndirboun(i).gt.4) then - write(*,*) '*WARNING: in gen3dboun: node ',node, - & ' does not' - write(*,*) ' belong to a beam nor shell' - write(*,*) ' element and consequently has no' - write(*,*) ' rotational degrees of freedom' - endif - cycle - endif - ielem=inoel(1,index) - j=inoel(2,index) - indexe=ipkon(ielem) - indexk=iponor(2,indexe+j) - idir=ndirboun(i) - val=xboun(i) - if(nam.gt.0) iamplitude=iamboun(i) -! - if(rig(node).ne.0) then -c if(idir.gt.3) then - if(idir.gt.4) then - if(rig(node).lt.0) then - write(*,*) '*ERROR in gen3dboun: in node ',node - write(*,*) ' a rotational DOF is constrained' - write(*,*) ' by a SPC; however, the elements' - write(*,*) ' to which this node belongs do not' - write(*,*) ' have rotational DOFs' - stop - endif -c j=idir-3 - j=idir-4 - irotnode=rig(node) - type='B' - call bounadd(irotnode,j,j,val,nodeboun, - & ndirboun,xboun,nboun,nboun_,iamboun, - & iamplitude,nam,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, - & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vold, - & irotnode,mi) - endif - else -! -! check for rotational DOFs defined in any but the first step -! -c if(idir.gt.3) then - if(idir.gt.4) then -! -! create a knot: determine the knot -! - ndepnodes=0 - if(lakon(ielem)(7:7).eq.'L') then - do k=1,3 - ndepnodes=ndepnodes+1 - idepnodes(ndepnodes)=knor(indexk+k) - enddo - elseif(lakon(ielem)(7:7).eq.'B') then - do k=1,8 - ndepnodes=ndepnodes+1 - idepnodes(ndepnodes)=knor(indexk+k) - enddo - else - write(*,*) - & '*ERROR in gen3dboun: a rotational DOF was applied' - write(*,*) - & '* to node',node,' without rotational DOFs' - stop - endif -! -! remove all MPC's in which the knot nodes are -! dependent nodes -! - do k=1,ndepnodes - nod=idepnodes(k) - do l=1,3 - idof=8*(nod-1)+l - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - impc=ilmpc(id) - call mpcrem(impc,mpcfree,nodempc,nmpc, - & ikmpc,ilmpc,labmpc,coefmpc,ipompc) - endif - endif - enddo - enddo -! -! generate a rigid body knot -! - irefnode=node - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in rigidbodies: increase nk_' - stop - endif - irotnode=nk - rig(node)=irotnode - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in rigidbodies: increase nk_' - stop - endif - iexpnode=nk - do k=1,ndepnodes - call knotmpc(ipompc,nodempc,coefmpc,irefnode, - & irotnode,iexpnode, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_, - & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, - & idepnodes(k),typeboun,co,xboun,istep) - enddo -! -! determine the location of the center of gravity of -! the section and its displacements -! - do l=1,3 - q(l)=0.d0 - w(l)=0.d0 - enddo - if(ndepnodes.eq.3) then - do k=1,ndepnodes,2 - nod=idepnodes(k) - do l=1,3 - q(l)=q(l)+co(l,nod) - w(l)=w(l)+vold(l,nod) - enddo - enddo - do l=1,3 - q(l)=q(l)/2.d0 - w(l)=w(l)/2.d0 - enddo - else - do k=1,ndepnodes - nod=idepnodes(k) - do l=1,3 - q(l)=q(l)+co(l,nod) - w(l)=w(l)+vold(l,nod) - enddo - enddo - do l=1,3 - q(l)=q(l)/ndepnodes - w(l)=w(l)/ndepnodes - enddo - endif -! -! determine the first displacements of iexpnode -! -c write(*,*) 'q ',q(1),q(2),q(3) -c write(*,*) 'w ',w(1),w(2),w(3) - alpha=0.d0 - do k=1,ndepnodes - nod=idepnodes(k) - dd=(co(1,nod)-q(1))**2 - & +(co(2,nod)-q(2))**2 - & +(co(3,nod)-q(3))**2 - if(dd.lt.1.d-20) cycle - alpha=alpha+dsqrt( - & ((co(1,nod)+vold(1,nod)-q(1)-w(1))**2 - & +(co(2,nod)+vold(2,nod)-q(2)-w(2))**2 - & +(co(3,nod)+vold(3,nod)-q(3)-w(3))**2)/dd) - enddo - alpha=alpha/ndepnodes -! -! determine the displacements of irotnodes -! - do l=1,3 - do m=1,3 - a(l,m)=0.d0 - enddo - xn(l)=0.d0 - enddo - do k=1,ndepnodes - nod=idepnodes(k) - dd=0.d0 - do l=1,3 - a1(l)=co(l,nod)-q(l) - a2(l)=vold(l,nod)-w(l) - dd=dd+a1(l)*a1(l) - enddo - dd=dsqrt(dd) - if(dd.lt.1.d-10) cycle - do l=1,3 - a1(l)=a1(l)/dd - a2(l)=a2(l)/dd - enddo - xn(1)=xn(1)+(a1(2)*a2(3)-a1(3)*a2(2)) - xn(2)=xn(2)+(a1(3)*a2(1)-a1(1)*a2(3)) - xn(3)=xn(3)+(a1(1)*a2(2)-a1(2)*a2(1)) - do l=1,3 - do m=1,3 - a(l,m)=a(l,m)+a1(l)*a1(m) - enddo - enddo - enddo -! - do l=1,3 - do m=1,3 - a(l,m)=a(l,m)/ndepnodes - enddo - xn(l)=xn(l)/ndepnodes - a(l,l)=1.d0-a(l,l) - enddo -! - m=3 - nrhs=1 -c write(*,*) 'xn before ',xn(1),xn(2),xn(3) - call dgesv(m,nrhs,a,m,ipiv,xn,m,info) - if(info.ne.0) then - write(*,*) '*ERROR in gen3dforc:' - write(*,*) ' singular system of equations' - stop - endif -c write(*,*) 'xn after ',xn(1),xn(2),xn(3) -! - dd=0.d0 - do l=1,3 - dd=dd+xn(l)*xn(l) - enddo - dd=dsqrt(dd) - do l=1,3 - xn(l)=dasin(dd/alpha)*xn(l)/dd - enddo -c write(*,*) 'xn afterafter ',xn(1),xn(2),xn(3) -! -! determine the displacements of irefnode -! - ww=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) -! - c1=dcos(ww) - if(ww.gt.1.d-10) then - c2=dsin(ww)/ww - else - c2=1.d0 - endif - if(ww.gt.1.d-5) then - c3=(1.d0-c1)/ww**2 - else - c3=0.5d0 - endif -! -! rotation matrix c -! - do k=1,3 - do l=1,3 - c(k,l)=c1*d(k,l)+ - & c2*(e(k,1,l)*xn(1)+e(k,2,l)*xn(2)+ - & e(k,3,l)*xn(3))+c3*xn(k)*xn(l) - enddo - enddo -! - do l=1,3 - w(l)=w(l)+(alpha*c(l,1)-d(l,1))*(co(1,irefnode)-q(1)) - & +(alpha*c(l,2)-d(l,2))*(co(2,irefnode)-q(2)) - & +(alpha*c(l,3)-d(l,3))*(co(3,irefnode)-q(3)) - enddo -! -! copying the displacements -! - do l=1,3 - vold(l,irefnode)=w(l) - vold(l,irotnode)=xn(l) - enddo - vold(1,iexpnode)=alpha -c write(*,*) 'w',w(1),w(2),w(3) -c write(*,*) 'xn',xn(1),xn(2),xn(3) -c write(*,*) 'alpha',alpha -! -! apply the boundary condition -! -c idir=idir-3 - idir=idir-4 - type='B' - call bounadd(irotnode,idir,idir,val,nodeboun, - & ndirboun,xboun,nboun,nboun_,iamboun, - & iamplitude,nam,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, - & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vold, - & irotnode,mi) -! -! check for shells whether the rotation about the normal -! on the shell has been eliminated -! - if(lakon(ielem)(7:7).eq.'L') then - indexx=iponor(1,indexe+j) - do j=1,3 - xnoref(j)=xnor(indexx+j) - enddo - dmax=0.d0 - imax=0 - do j=1,3 - if(dabs(xnoref(j)).gt.dmax) then - dmax=dabs(xnoref(j)) - imax=j - endif - enddo -! -! check whether a SPC suffices -! - if(dabs(1.d0-dmax).lt.1.d-3) then - val=0.d0 - if(nam.gt.0) iamplitude=0 - type='R' - call bounadd(irotnode,imax,imax,val,nodeboun, - & ndirboun,xboun,nboun,nboun_,iamboun, - & iamplitude,nam,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, - & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vold, - & irotnode,mi) - else -! -! check for an unused rotational DOF -! - isol=0 - do l=1,3 -c idof=8*(node-1)+3+imax - idof=8*(node-1)+4+imax - call nident(ikboun,idof,nboun,id) - if((id.gt.0).and.(ikboun(id).eq.idof)) then - imax=imax+1 - if(imax.gt.3) imax=imax-3 - cycle - endif - isol=1 - exit - enddo -! -! if one of the rotational dofs was not used so far, -! it can be taken as dependent side for fixing the -! rotation about the normal. If all dofs were used, -! no additional equation is needed. -! - if(isol.eq.1) then - idof=8*(irotnode-1)+imax - call nident(ikmpc,idof,nmpc,id) - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)=' ' -! - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=imax - coefmpc(mpcfree)=xnoref(imax) - mpcfree=nodempc(3,mpcfree) - imax=imax+1 - if(imax.gt.3) imax=imax-3 - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=imax - coefmpc(mpcfree)=xnoref(imax) - mpcfree=nodempc(3,mpcfree) - imax=imax+1 - if(imax.gt.3) imax=imax-3 - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=imax - coefmpc(mpcfree)=xnoref(imax) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - endif - endif - endif - cycle - endif -! -! 2d element shell element: generate MPC's -! - if(lakon(ielem)(7:7).eq.'L') then - newnode=knor(indexk+1) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=knor(indexk+3) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-2.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif -! -! fixing the temperature degrees of freedom -! - if(idir.eq.0) then - type='B' - call bounadd(knor(indexk+3),idir,idir,val,nodeboun, - & ndirboun,xboun,nboun,nboun_,iamboun, - & iamplitude,nam,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, - & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vold, - & irotnode,mi) - endif - elseif(lakon(ielem)(7:7).eq.'B') then -! -! 1d beam element: generate MPC's -! - newnode=knor(indexk+1) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - do k=2,4 - nodempc(1,mpcfree)=knor(indexk+k) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - enddo - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-4.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif -! -! fixing the temperature degrees of freedom -! - if(idir.eq.0) then - type='B' - do k=2,4 - call bounadd(knor(indexk+k),idir,idir,val,nodeboun, - & ndirboun,xboun,nboun,nboun_,iamboun, - & iamplitude,nam,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, - & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vold, - & knor(indexk+k),mi) - enddo - endif - else -! -! 2d plane stress, plane strain or axisymmetric -! element: MPC in all but z-direction -! - newnode=knor(indexk+2) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if(((id.le.0).or.(ikmpc(id).ne.idof)).and. - & (idir.ne.3)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-1.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - endif - endif - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dconnect.f calculix-ccx-2.3/ccx_2.1/src/gen3dconnect.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dconnect.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dconnect.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,233 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dconnect(kon,ipkon,lakon,ne,iponoel,inoel, - & iponoelmax,rig,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc, - & nmpc_,mpcfree,ikmpc,ilmpc,labmpc) -! -! connects expanded 1-D and 2-D elements with genuine 3D elements -! - implicit none -! - character*8 lakon(*) - character*20 labmpc(*) -! - integer kon(*),ipkon(*),ne,iponoel(*),inoel(3,*),iponoelmax, - & rig(*),iponor(2,*),knor(*),ipompc(*),nodempc(3,*),nmpc,nmpc_, - & mpcfree,ikmpc(*),ilmpc(*),i,indexes,nope,l,node,index2,ielem, - & indexe,j,indexk,newnode,idir,idof,id,mpcfreenew,k -! - real*8 xnor(*),coefmpc(*) -! -! generating MPC's to connect shells and beams with solid -! elements -! - do i=1,ne - indexes=ipkon(i) - if(indexes.lt.0) cycle - if((lakon(i)(7:7).ne.' ').and.(lakon(i)(1:1).ne.'E')) cycle -c if((lakon(i)(4:4).ne.'8').and. -c & (lakon(i)(4:4).ne.'1').and. -c & (lakon(i)(7:7).ne.' ')) cycle - if(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:4).eq.'1') then - nope=10 - elseif(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(1:1).eq.'E') then - read(lakon(i)(8:8),'(i1)') nope - else - cycle - endif - do l=1,nope - node=kon(indexes+l) - if(node.le.iponoelmax) then - if(rig(node).eq.0) then - index2=iponoel(node) - if(index2.eq.0) cycle - ielem=inoel(1,index2) - indexe=ipkon(ielem) - j=inoel(2,index2) - indexk=iponor(2,indexe+j) -! -! 2d shell element -! - if(lakon(ielem)(7:7).eq.'L') then - newnode=knor(indexk+1) - do idir=0,3 - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=knor(indexk+3) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-2.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - enddo - elseif(lakon(ielem)(7:7).eq.'B') then -! -! 1d beam element -! - newnode=knor(indexk+1) - do idir=0,3 - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - do k=2,4 - nodempc(1,mpcfree)=knor(indexk+k) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - enddo - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-4.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - enddo - else -! -! 2d plane stress, plane strain or axisymmetric -! element -! - newnode=knor(indexk+2) - do idir=0,2 - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-1.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dconnect: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - enddo - endif - endif - endif - enddo - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3delem.f calculix-ccx-2.3/ccx_2.1/src/gen3delem.f --- calculix-ccx-2.1/ccx_2.1/src/gen3delem.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3delem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,712 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3delem(kon,ipkon,lakon,ne,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,ikboun,ilboun,nboun, - & nboun_,nodeboun,ndirboun,xboun,iamboun,nam, - & inotr,trab,nk,nk_,iponoel,inoel,iponor,xnor,thicke,thickn, - & knor,istep,offset,t0,t1,ikforc,ilforc,rig,nforc, - & nforc_,nodeforc,ndirforc,xforc,iamforc,nelemload,sideload, - & nload,ithermal,ntrans,co,ixfree,ikfree,inoelfree,iponoelmax, - & iperturb,tinc,tper,tmin,tmax,ctrl,typeboun,nmethod,nset,set, - & istartset,iendset,ialset,prop,ielprop,vold,mi) -! -! generates three-dimensional elements: -! for isochoric elements -! for plane stress -! for plane strain -! for plate and shell elements -! for beam elements -! - implicit none -! - logical isochoric -! - character*1 typeboun(*) - character*8 lakon(*) - character*20 labmpc(*),sideload(*),label - character*81 set(*) -! - integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,ikmpc(*), - & ilmpc(*),kon(*),ipkon(*),ne,mpc,indexe,i,j,k,node,idof, - & id,mpcfreeold,ikboun(*),ilboun(*),nboun,nboun_,kflag,idummy, - & iterm(500),nterm,neigh(7,8),l,m,nodeboun(*),ndirboun(*),nk, - & nk_,index,iponoel(*),inoel(3,*),inoelfree,istep,nmpcold, - & ikforc(*),ilforc(*),nodeforc(2,*),ndirforc(*),iamforc(*), - & nelemload(*),nforc,nforc_,ithermal(2),nload,iamboun(*), - & ntrans,inotr(2,*),nam,iponoelmax,iperturb,numnod,itransaxial, - & rig(*),nmethod,nset,istartset(*),iendset(*),ialset(*), - & ielprop(*),idir,indexref,indexold,idofold,idold,indexnew, - & idofnew,idnew,ksol,lsol,nmpc0,nmpc01,nmpcdif,mi(2) -! - integer iponor(2,*),knor(*),ixfree,ikfree -! - real*8 coefmpc(*),thicke(2,*),xnor(*),thickn(2,*),tinc,tper,tmin, - & tmax,offset(2,*),t0(*),t1(*),xforc(*),trab(7,*),co(3,*),b(3,3), - & xboun(*),pi,ctrl(*),prop(*),vold(0:mi(2),*),xlag(3,20), - & xeul(3,20),a(3,3),xi,et,ze,coloc(3,8),xj -! - data neigh /1,9,2,12,4,17,5,2,9,1,10,3,18,6, - & 3,11,4,10,2,19,7,4,11,3,12,1,20,8, - & 5,13,6,16,8,17,1,6,13,5,14,7,18,2, - & 7,15,8,14,6,19,3,8,15,7,16,5,20,4/ -! - data coloc /-1.,-1.,-1.,1.,-1.,-1.,1.,1.,-1.,-1.,1.,-1., - & -1.,-1.,1.,1.,-1.,1.,1.,1.,1.,-1.,1.,1./ -! - isochoric=.false. - pi=4.d0*datan(1.d0) -! -! catalogueing the element per node relationship for shell/beam -! elements and transferring the nodal thickness to the elements -! -! inoelfree=1 means that there is at least one 1D or 2D element -! in the structure. Otherwise inoelfree=0. -! - if((istep.eq.1).and.(inoelfree.eq.1)) then -! - itransaxial=0 -! - do i=1,ne - if(ipkon(i).lt.0) cycle - if((lakon(i)(1:2).ne.'C3').and.(lakon(i)(1:1).ne.'D').and. - & (lakon(i)(1:1).ne.'G').and.(lakon(i)(1:1).ne.'E')) then - if(lakon(i)(1:1).eq.'B') then - numnod=3 - elseif((lakon(i)(2:2).eq.'6').or. - & (lakon(i)(4:4).eq.'6')) then - numnod=6 - else - numnod=8 - endif - indexe=ipkon(i) - do j=1,numnod - node=kon(indexe+j) - iponoelmax=max(iponoelmax,node) - inoel(1,inoelfree)=i - inoel(2,inoelfree)=j - inoel(3,inoelfree)=iponoel(node) - iponoel(node)=inoelfree - inoelfree=inoelfree+1 - if(lakon(i)(1:2).ne.'CA') then - if(thickn(1,node).gt.0.d0) - & thicke(1,indexe+j)=thickn(1,node) - if(thickn(2,node).gt.0.d0) - & thicke(2,indexe+j)=thickn(2,node) - endif - if(thicke(1,indexe+j).le.0.d0) then - if(lakon(i)(1:1).eq.'C') then - thicke(1,indexe+j)=1.d0 - else - write(*,*)'*ERROR in gen3delem: first thickness' - write(*,*)' in node ',j,' of element ',i - write(*,*)' is zero' - stop - endif - endif - if((lakon(i)(1:1).eq.'B').and. - & (thicke(2,indexe+j).le.0.d0)) then - write(*,*) '*ERROR in gen3delem: second thickness' - write(*,*)' in node ',j,' of beam element ',i - write(*,*)' is zero' - stop - endif - enddo - endif - enddo -! -! checking whether any rotational degrees of freedom are fixed -! by SPC's, MPC's or loaded by bending moments or torques -! in the end, rig(i)=0 if no rigid knot is defined in node i, -! else rig(i)=the rotational node of the knot. The value -1 is -! a dummy. -! - do i=1,nboun -c if(ndirboun(i).gt.3) rig(nodeboun(i))=-1 - if(ndirboun(i).gt.4) rig(nodeboun(i))=-1 - enddo - do i=1,nforc -c if(ndirforc(i).gt.3) rig(nodeforc(1,i))=-1 - if(ndirforc(i).gt.4) rig(nodeforc(1,i))=-1 - enddo - do i=1,nmpc - index=ipompc(i) - do - if(index.eq.0) exit -c if(nodempc(2,index).gt.3) then - if(nodempc(2,index).gt.4) then - rig(nodempc(1,index))=-1 - endif - index=nodempc(3,index) - enddo - enddo -! -! calculating the normals in nodes belonging to shells/beams -! - nmpcold=nmpc -! - call gen3dnor(nk,nk_,co,iponoel,inoel,iponoelmax,kon,ipkon, - & lakon,ne,thicke,offset,iponor,xnor,knor,rig,iperturb,tinc, - & tper,tmin,tmax,ctrl,ipompc,nodempc,coefmpc,nmpc,nmpc_, - & mpcfree,ikmpc,ilmpc,labmpc,ikboun,ilboun,nboun,nboun_, - & nodeboun,ndirboun,xboun,iamboun,typeboun,nam,ntrans,inotr, - & trab,ikfree,ixfree,nmethod,ithermal,istep,mi) -! - endif -! - if(istep.eq.1) then -! -! incompressible elements -! - nmpc0=nmpc - nmpc01=nmpc0+1 - do i=1,ne - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:7).eq.'C3D20RI') then - isochoric=.true. - indexe=ipkon(i) -! - do j=1,20 - node=kon(indexe+j) - do k=1,3 - xlag(k,j)=co(k,node) - xeul(k,j)=xlag(k,j)+vold(k,node) - enddo - enddo -! - do j=1,8 - node=kon(indexe+j) - mpc=0 -c write(*,*) 'isochoric condition in node ',node - label(1:9)='ISOCHORIC' - write(label(10:20),'(i11)') node - nmpcdif=nmpc-nmpc0 - call cident20(labmpc(nmpc01),label,nmpcdif,id) - id=id+nmpc0 -c write(*,*) 'newlabel ',label -c do k=1,nmpc -c write(*,*) 'oldlabel ',k,labmpc(k) -c enddo - if(id.gt.0) then - if(labmpc(id).eq.label) then - mpc=id - endif - endif -! -! new MPC: look for suitable dependent dof -! - if(mpc.eq.0) then - mpc=id+1 - ksol=0 - loop: do k=1,7 - do l=1,3 - idof=8*(kon(indexe+neigh(k,j))-1)+l -! -! check for SPC's using the same DOF -! - call nident(ikboun,idof,nboun,id) - if(id.gt.0) then - if(ikboun(id).eq.idof) cycle - endif -! -! check for MPC's using the same DOF -! - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) cycle - endif -! - ksol=k - lsol=l - exit loop - enddo - enddo loop -! -! no mpc available -! - if(ksol.eq.0) then - write(*,*) - & '*WARNING in gen3delem: no free DOF in' - write(*,*) - & ' node ',node,' for isochoric' - write(*,*) ' MPC application' - cycle - endif -! -! new mpc -! - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in gen3delem: increase nmpc_' - stop - endif - do l=1,nmpc - if(ilmpc(l).ge.mpc) ilmpc(l)=ilmpc(l)+1 - enddo - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=mpc - do l=nmpc,mpc+1,-1 - ipompc(l)=ipompc(l-1) - labmpc(l)=labmpc(l-1) - enddo -! - labmpc(mpc)(1:9)='ISOCHORIC ' - write(labmpc(mpc)(10:20),'(i11)') node -! -! terms of the node itself and its neighbors -! - ipompc(mpc)=mpcfree - do l=lsol,3 - nodempc(1,mpcfree)=kon(indexe+neigh(ksol,j)) - nodempc(2,mpcfree)=l - mpcfree=nodempc(3,mpcfree) - enddo -! - do k=ksol+1,7 - do l=1,3 - nodempc(1,mpcfree)=kon(indexe+neigh(k,j)) - nodempc(2,mpcfree)=l - mpcfree=nodempc(3,mpcfree) - enddo - enddo -! - do k=1,ksol-1 - do l=1,3 - nodempc(1,mpcfree)=kon(indexe+neigh(k,j)) - nodempc(2,mpcfree)=l - mpcfree=nodempc(3,mpcfree) - enddo - enddo -! - do l=1,lsol-1 - nodempc(1,mpcfree)=kon(indexe+neigh(ksol,j)) - nodempc(2,mpcfree)=l - mpcfree=nodempc(3,mpcfree) - enddo -! -! add nonhomogeneous term -! - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in gen3delem: increase nk_' - stop - endif - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfreeold)=nk - nodempc(2,mpcfreeold)=1 - nodempc(3,mpcfreeold)=0 - idof=8*(nk-1)+1 - call nident(ikboun,idof,nboun,id) - nboun=nboun+1 - if(nboun.gt.nboun_) then - write(*,*)'*ERROR in gen3delem: increase nboun_' - stop - endif - nodeboun(nboun)=nk - ndirboun(nboun)=1 - typeboun(nboun)='I' - do l=nboun,id+2,-1 - ikboun(l)=ikboun(l-1) - ilboun(l)=ilboun(l-1) - enddo - ikboun(id+1)=idof - ilboun(id+1)=nboun -! - else -! - indexref=nodempc(3,nodempc(3,ipompc(mpc))) - index=nodempc(3,indexref) - nterm=0 - do - if(index.eq.0) exit - nterm=nterm+1 - if(nterm.gt.500) then - write(*,*) '*ERROR in gen3delem:' - write(*,*) ' increase nterm_' - stop - endif - iterm(nterm)= - & 8*(nodempc(1,index)-1)+nodempc(2,index) - index=nodempc(3,index) - enddo - kflag=1 - call isortii(iterm,idummy,nterm,kflag) -! - do k=2,7 - do l=1,3 - m=8*(kon(indexe+neigh(k,j))-1)+l - call nident(iterm,m,nterm,id) - if(id.ne.0) then - if(iterm(id).eq.m) then - cycle - endif - endif - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=nodempc(3,indexref) - nodempc(3,indexref)=mpcfreeold - nodempc(1,mpcfreeold)=kon(indexe+neigh(k,j)) - nodempc(2,mpcfreeold)=l - enddo - enddo -! - endif -! - xi=coloc(1,j) - et=coloc(2,j) - ze=coloc(3,j) -! - call deuldlag(xi,et,ze,xlag,xeul,xj,a) -! - b(1,1)=a(2,2)*a(3,3)-a(2,3)*a(3,2) - b(1,2)=a(3,1)*a(2,3)-a(2,1)*a(3,3) - b(1,3)=a(2,1)*a(3,2)-a(3,1)*a(2,2) - b(2,1)=a(3,2)*a(1,3)-a(1,2)*a(3,3) - b(2,2)=a(1,1)*a(3,3)-a(3,1)*a(1,3) - b(2,3)=a(3,1)*a(1,2)-a(1,1)*a(3,2) - b(3,1)=a(1,2)*a(2,3)-a(2,2)*a(1,3) - b(3,2)=a(2,1)*a(1,3)-a(1,1)*a(2,3) - b(3,3)=a(1,1)*a(2,2)-a(1,2)*a(2,1) -c write(*,*) 'b(1,j)',b(1,1),b(1,2),b(1,3) -c write(*,*) 'b(2,j)',b(2,1),b(2,2),b(2,3) -c write(*,*) 'b(3,j)',b(3,1),b(3,2),b(3,3) -! - index=ipompc(mpc) - do - if(nodempc(3,index).eq.0) then - coefmpc(index)=1.d0 - idof=8*(nodempc(1,index)-1) - & +nodempc(2,index) -c write(*,*) -c & 'gen3delem1 node,idir',nodempc(1,index), -c & nodempc(2,index) - call nident(ikboun,idof,nboun,id) - xboun(ilboun(id))=xboun(ilboun(id))+ - & a(1,1)*b(1,1)+a(1,2)*b(1,2)+a(1,3)*b(1,3) - & -1.d0/xj -c write(*,*) 'nonlinmpcboun ',nodempc(1,index), -c & nodempc(2,index),ilboun(id), -c & xboun(ilboun(id)) - exit - else - node=nodempc(1,index) - idir=nodempc(2,index) -c write(*,*) 'gen3delem2 node,idir',node,idir - do k=1,7 - if(kon(indexe+neigh(k,j)).eq.node) then - if(k.eq.1) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index)+1.5d0* - & (xi*b(1,1)+et*b(1,2)+ze*b(1,3)) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index)+1.5d0* - & (xi*b(2,1)+et*b(2,2)+ze*b(2,3)) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index)+1.5d0* - & (xi*b(3,1)+et*b(3,2)+ze*b(3,3)) - endif - elseif(k.eq.2) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index) - & -2.d0*xi*b(1,1) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index) - & -2.d0*xi*b(2,1) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index) - & -2.d0*xi*b(3,1) - endif - elseif(k.eq.3) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index) - & +0.5d0*xi*b(1,1) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index) - & +0.5d0*xi*b(2,1) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index) - & +0.5d0*xi*b(3,1) - endif - elseif(k.eq.4) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index) - & -2.d0*et*b(1,2) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index) - & -2.d0*et*b(2,2) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index) - & -2.d0*et*b(3,2) - endif - elseif(k.eq.5) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index) - & +0.5d0*et*b(1,2) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index) - & +0.5d0*et*b(2,2) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index) - & +0.5d0*et*b(3,2) - endif - elseif(k.eq.6) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index) - & -2.d0*ze*b(1,3) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index) - & -2.d0*ze*b(2,3) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index) - & -2.d0*ze*b(3,3) - endif - elseif(k.eq.7) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index) - & +0.5d0*ze*b(1,3) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index) - & +0.5d0*ze*b(2,3) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index) - & +0.5d0*ze*b(3,3) - endif - endif - exit - endif - enddo -c write(*,*) 'gen3delem2 node,idir',node,idir, -c & coefmpc(index) - endif - index=nodempc(3,index) - enddo -! - enddo - endif - enddo -! -! 1D and 2D elements -! - do i=1,ne - if(ipkon(i).lt.0) cycle - if((lakon(i)(1:2).eq.'CP').or. - & (lakon(i)(1:1).eq.'S').or. - & (lakon(i)(1:2).eq.'CA')) then -! - call gen3dfrom2d(i,kon,ipkon,lakon,ne,iponor,xnor,knor, - & thicke,offset,ntrans,inotr,trab,ikboun,ilboun,nboun, - & nboun_,nodeboun,ndirboun,xboun,iamboun,typeboun,ipompc, - & nodempc,coefmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc, - & nk,nk_,co,rig,nmethod,iperturb,ithermal,mi,nam) -! - elseif(lakon(i)(1:1).eq.'B') then - call gen3dfrom1d(i,kon,ipkon,lakon,ne,iponor,xnor,knor, - & thicke,ntrans,inotr,trab,nk,nk_,co,offset) - endif -! - if(lakon(i)(1:4).eq.'CPE6') then - lakon(i)(1:7)='C3D15 E' - elseif(lakon(i)(1:5).eq.'CPE8R') then - lakon(i)(1:7)='C3D20RE' - elseif(lakon(i)(1:4).eq.'CPE8') then - lakon(i)(1:7)='C3D20 E' - elseif(lakon(i)(1:4).eq.'CPS6') then - lakon(i)(1:7)='C3D15 S' - elseif(lakon(i)(1:5).eq.'CPS8R') then - lakon(i)(1:7)='C3D20RS' - elseif(lakon(i)(1:4).eq.'CPS8') then - lakon(i)(1:7)='C3D20 S' - elseif(lakon(i)(1:4).eq.'CAX6') then - lakon(i)(1:7)='C3D15 A' - elseif(lakon(i)(1:5).eq.'CAX8R') then - lakon(i)(1:7)='C3D20RA' - elseif(lakon(i)(1:4).eq.'CAX8') then - lakon(i)(1:7)='C3D20 A' - elseif(lakon(i)(1:2).eq.'S6') then - lakon(i)(1:7)='C3D15 L' - elseif(lakon(i)(1:3).eq.'S8R') then - lakon(i)(1:7)='C3D20RL' - elseif(lakon(i)(1:2).eq.'S8') then - lakon(i)(1:7)='C3D20 L' - elseif(lakon(i)(1:4).eq.'B32R') then - lakon(i)(1:7)='C3D20RB' - elseif(lakon(i)(1:1).eq.'B') then - lakon(i)(1:7)='C3D20 B' - endif - enddo -! -! check whether the coefficient of the dependent -! terms in ISOCHORIC MPC's is not zero -! - if(isochoric) then - do i=1,nmpc - if(labmpc(i)(1:9).ne.'ISOCHORIC') cycle - index=ipompc(i) - if(dabs(coefmpc(index)).gt.1.d-10) cycle -! -! coefficient of dependent term is zero: rearranging -! the MPC -! - indexold=index - idofold=8*(nodempc(1,index)-1)+nodempc(2,index) - call nident(ikmpc,idofold,nmpc,idold) - do j=idold,nmpc-1 - ikmpc(j)=ikmpc(j+1) - ilmpc(j)=ilmpc(j+1) - enddo - indexref=index - index=nodempc(3,index) -! - do - if(index.eq.0) then - write(*,*) '*ERROR in gen3delem: coefficient' - write(*,*) ' of dependent term is zero' - write(*,*) ' and no other DOF is available' - stop - endif - if(dabs(coefmpc(index)).gt.1.d-10) then - idofnew=8*(nodempc(1,index)-1)+nodempc(2,index) -! -! check whether DOF is not used in SPC -! - call nident(ikboun,idofnew,nboun,idnew) - if(idnew.gt.0) then - if(ikboun(idnew).eq.idofnew) then - indexref=index - index=nodempc(3,index) - cycle - endif - endif -! -! check whether DOF is not used in MPC -! - call nident(ikmpc,idofnew,nmpc,idnew) - if(idnew.gt.0) then - if(ikmpc(idnew).eq.idofnew) then - indexref=index - index=nodempc(3,index) - cycle - endif - endif -! -! DOF is OK: take it as dependent term -! - do j=nmpc,idnew+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(idnew+1)=idofnew - ilmpc(idnew+1)=i -! - indexnew=index - index=nodempc(3,index) - ipompc(i)=indexnew - nodempc(3,indexnew)=indexold - nodempc(3,indexref)=index - exit - endif - indexref=index - index=nodempc(3,index) - enddo - enddo - endif -c do i=1,nmpc -c write(*,*) 'iklmpc ',i,ikmpc(i),ilmpc(i) -c enddo -! -! filling the new KNOT MPC's (needs the coordinates -! of the expanded nodes) -! - if(inoelfree.ne.0) then - call fillknotmpc(co,ipompc,nodempc,coefmpc,labmpc, - & nmpc,nmpcold) - call gen3dprop(prop,ielprop,iponoel,inoel,iponoelmax,kon, - & ipkon,lakon,ne,iponor,xnor,knor,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr, - & trab,nam,nk,nk_,co,nmethod,iperturb) - endif -! - endif -! -! generating MPC's to connect shells and beams with solid -! elements -! - if((inoelfree.ne.0).and.(istep.eq.1)) then - call gen3dconnect(kon,ipkon,lakon,ne,iponoel,inoel, - & iponoelmax,rig,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc, - & nmpc_,mpcfree,ikmpc,ilmpc,labmpc) - endif -! - if(inoelfree.ne.0) then -! -! multiplying existing boundary conditions -! - call gen3dboun(ikboun,ilboun,nboun,nboun_,nodeboun,ndirboun, - & xboun,iamboun,typeboun,iponoel,inoel,iponoelmax,kon,ipkon, - & lakon,ne,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc,nmpc_, - & mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk,nk_, - & co,nmethod,iperturb,istep,vold,mi) -! -! updating the nodal surfaces: establishing links between the user -! defined nodes and the newly generated nodes (mid-nodes -! for 2d elements, mean of corner nodes for 1d elements) -! - if(istep.eq.1) then - call gen3dsurf(iponoel,inoel,iponoelmax,kon,ipkon, - & lakon,ne,iponor,knor,ipompc,nodempc,coefmpc,nmpc,nmpc_, - & mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk, - & nk_,co,nmethod,iperturb,nset,set,istartset,iendset,ialset) - endif -! -! updating the MPCs: establishing links between the user -! defined nodes and the newly generated nodes (mid-nodes -! for 2d elements, mean of corner nodes for 1d elements) -! - if(istep.eq.1) then - call gen3dmpc(ipompc,nodempc,coefmpc,nmpc,nmpc_,mpcfree, - & ikmpc,ilmpc,labmpc,iponoel,inoel,iponoelmax,kon,ipkon, - & lakon,ne,iponor,xnor,knor,rig) - endif -! -! updating the temperatures -! - if(ithermal(1).gt.0) then - call gen3dtemp(iponoel,inoel,iponoelmax,kon,ipkon,lakon,ne, - & iponor,xnor,knor,t0,t1,thicke,offset,rig,nk,nk_,co, - & istep,ithermal,vold,mi) - endif -! -! updating the concentrated loading -! - call gen3dforc(ikforc,ilforc,nforc,nforc_,nodeforc, - & ndirforc,xforc,iamforc,ntrans,inotr,trab,rig,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,iponoel,inoel, - & iponoelmax,kon,ipkon,lakon,ne,iponor,xnor,knor,nam,nk,nk_, - & co,thicke,nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, - & iamboun,typeboun,xboun,nmethod,iperturb,istep,vold,mi) - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dforc.f calculix-ccx-2.3/ccx_2.1/src/gen3dforc.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dforc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dforc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,576 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dforc(ikforc,ilforc,nforc,nforc_,nodeforc, - & ndirforc,xforc,iamforc,ntrans,inotr,trab,rig,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,iponoel,inoel, - & iponoelmax,kon,ipkon,lakon,ne,iponor,xnor,knor,nam,nk,nk_, - & co,thicke,nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, - & iamboun,typeboun,xboun,nmethod,iperturb,istep,vold,mi) -! -! connects nodes of 1-D and 2-D elements, for which -! concentrated forces were -! defined, to the nodes of their expanded counterparts -! - implicit none -! - logical add,fixed -! - character*1 type,typeboun(*) - character*8 lakon(*) - character*20 labmpc(*) -! - integer ikforc(*),ilforc(*),nodeforc(2,*),ndirforc(*),iamforc(*), - & nforc,nforc_,ntrans,inotr(2,*),rig(*),ipompc(*),nodempc(3,*), - & nmpc,nmpc_,mpcfree,ikmpc(*),ilmpc(*),iponoel(*),inoel(3,*), - & iponoelmax,kon(*),ipkon(*),ne,iponor(2,*),knor(*),nforcold, - & i,node,index,ielem,j,indexe,indexk,nam,iamplitude,idir, - & irotnode,nk,nk_,newnode,idof,id,mpcfreenew,k,isector,ndepnodes, - & idepnodes(80),l,iexpnode,indexx,irefnode,imax,isol,mpcfreeold, - & nod,impc,istep,nodeboun(*),ndirboun(*),ikboun(*),ilboun(*), - & nboun,nboun_,iamboun(*),nmethod,iperturb,nrhs,ipiv(3),info,m, - & mi(2) -! - real*8 xforc(*),trab(7,*),coefmpc(*),xnor(*),val,co(3,*), - & thicke(2,*),pi,xboun(*),xnoref(3),dmax,d(3,3),e(3,3,3), - & alpha,q(3),w(3),xn(3),a(3,3),a1(3),a2(3),dd,c1,c2,c3,ww,c(3,3), - & vold(0:mi(2),*) -! - data d /1.,0.,0.,0.,1.,0.,0.,0.,1./ - data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., - & 0.,0.,1.,0.,0.,0.,-1.,0.,0., - & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ -! - fixed=.false. -! - add=.false. - pi=4.d0*datan(1.d0) - isector=0 -! - nforcold=nforc - do i=1,nforcold - node=nodeforc(1,i) - if(node.gt.iponoelmax) then -c if(ndirforc(i).gt.3) then - if(ndirforc(i).gt.4) then - write(*,*) '*WARNING: in gen3dforc: node ',i, - & ' does not' - write(*,*) ' belong to a beam nor shell' - write(*,*) ' element and consequently has no' - write(*,*) ' rotational degrees of freedom' - endif - cycle - endif - index=iponoel(node) - if(index.eq.0) then -c if(ndirforc(i).gt.3) then - if(ndirforc(i).gt.4) then - write(*,*) '*WARNING: in gen3dforc: node ',i, - & ' does not' - write(*,*) ' belong to a beam nor shell' - write(*,*) ' element and consequently has no' - write(*,*) ' rotational degrees of freedom' - endif - cycle - endif - ielem=inoel(1,index) - j=inoel(2,index) - indexe=ipkon(ielem) - indexk=iponor(2,indexe+j) - if(nam.gt.0) iamplitude=iamforc(i) - idir=ndirforc(i) -! - if(rig(node).ne.0) then -c if(idir.gt.3) then - if(idir.gt.4) then - if(rig(node).lt.0) then - write(*,*) '*ERROR in gen3dforc: in node ',node - write(*,*) ' a rotational DOF is loaded;' - write(*,*) ' however, the elements to which' - write(*,*) ' this node belongs do not have' - write(*,*) ' rotational DOFs' - stop - endif - val=xforc(i) -c j=idir-3 - j=idir-4 - irotnode=rig(node) - call forcadd(irotnode,j,val,nodeforc, - & ndirforc,xforc,nforc,nforc_,iamforc, - & iamplitude,nam,ntrans,trab,inotr,co, - & ikforc,ilforc,isector,add) - endif - else -! -! check for moments defined in any but the first step -! -c if(idir.gt.3) then - if(idir.gt.4) then -! -! create a knot: determine the knot -! - ndepnodes=0 - if(lakon(ielem)(7:7).eq.'L') then - do k=1,3 - ndepnodes=ndepnodes+1 - idepnodes(ndepnodes)=knor(indexk+k) - enddo - elseif(lakon(ielem)(7:7).eq.'B') then - do k=1,8 - ndepnodes=ndepnodes+1 - idepnodes(ndepnodes)=knor(indexk+k) - enddo - else - write(*,*) - & '*ERROR in gen3dboun: a rotational DOF was applied' - write(*,*) - & '* to node',node,' without rotational DOFs' - stop - endif -! -! remove all MPC's in which the knot nodes are -! dependent nodes -! - do k=1,ndepnodes - nod=idepnodes(k) - do l=1,3 - idof=8*(nod-1)+l - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - impc=ilmpc(id) - call mpcrem(impc,mpcfree,nodempc,nmpc, - & ikmpc,ilmpc,labmpc,coefmpc,ipompc) - endif - endif - enddo - enddo -! -! generate a rigid body knot -! - irefnode=node - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in rigidbodies: increase nk_' - stop - endif - irotnode=nk - rig(node)=irotnode - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in rigidbodies: increase nk_' - stop - endif - iexpnode=nk - do k=1,ndepnodes - call knotmpc(ipompc,nodempc,coefmpc,irefnode, - & irotnode,iexpnode, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_, - & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, - & idepnodes(k),typeboun,co,xboun,istep) - enddo -! -! determine the location of the center of gravity of -! the section and its displacements -! - do l=1,3 - q(l)=0.d0 - w(l)=0.d0 - enddo - if(ndepnodes.eq.3) then - do k=1,ndepnodes,2 - nod=idepnodes(k) - do l=1,3 - q(l)=q(l)+co(l,nod) - w(l)=w(l)+vold(l,nod) - enddo - enddo - do l=1,3 - q(l)=q(l)/2.d0 - w(l)=w(l)/2.d0 - enddo - else - do k=1,ndepnodes - nod=idepnodes(k) - do l=1,3 - q(l)=q(l)+co(l,nod) - w(l)=w(l)+vold(l,nod) - enddo - enddo - do l=1,3 - q(l)=q(l)/ndepnodes - w(l)=w(l)/ndepnodes - enddo - endif -! -! determine the first displacements of iexpnode -! -c write(*,*) 'q ',q(1),q(2),q(3) -c write(*,*) 'w ',w(1),w(2),w(3) - alpha=0.d0 - do k=1,ndepnodes - nod=idepnodes(k) - dd=(co(1,nod)-q(1))**2 - & +(co(2,nod)-q(2))**2 - & +(co(3,nod)-q(3))**2 - if(dd.lt.1.d-20) cycle - alpha=alpha+dsqrt( - & ((co(1,nod)+vold(1,nod)-q(1)-w(1))**2 - & +(co(2,nod)+vold(2,nod)-q(2)-w(2))**2 - & +(co(3,nod)+vold(3,nod)-q(3)-w(3))**2)/dd) - enddo - alpha=alpha/ndepnodes -! -! determine the displacements of irotnodes -! - do l=1,3 - do m=1,3 - a(l,m)=0.d0 - enddo - xn(l)=0.d0 - enddo - do k=1,ndepnodes - nod=idepnodes(k) - dd=0.d0 - do l=1,3 - a1(l)=co(l,nod)-q(l) - a2(l)=vold(l,nod)-w(l) - dd=dd+a1(l)*a1(l) - enddo - dd=dsqrt(dd) - if(dd.lt.1.d-10) cycle - do l=1,3 - a1(l)=a1(l)/dd - a2(l)=a2(l)/dd - enddo - xn(1)=xn(1)+(a1(2)*a2(3)-a1(3)*a2(2)) - xn(2)=xn(2)+(a1(3)*a2(1)-a1(1)*a2(3)) - xn(3)=xn(3)+(a1(1)*a2(2)-a1(2)*a2(1)) - do l=1,3 - do m=1,3 - a(l,m)=a(l,m)+a1(l)*a1(m) - enddo - enddo - enddo -! - do l=1,3 - do m=1,3 - a(l,m)=a(l,m)/ndepnodes - enddo - xn(l)=xn(l)/ndepnodes - a(l,l)=1.d0-a(l,l) - enddo -! - m=3 - nrhs=1 -c write(*,*) 'xn before ',xn(1),xn(2),xn(3) - call dgesv(m,nrhs,a,m,ipiv,xn,m,info) - if(info.ne.0) then - write(*,*) '*ERROR in gen3dforc:' - write(*,*) ' singular system of equations' - stop - endif -c write(*,*) 'xn after ',xn(1),xn(2),xn(3) -! - dd=0.d0 - do l=1,3 - dd=dd+xn(l)*xn(l) - enddo - dd=dsqrt(dd) - do l=1,3 - xn(l)=dasin(dd/alpha)*xn(l)/dd - enddo -c write(*,*) 'xn afterafter ',xn(1),xn(2),xn(3) -! -! determine the displacements of irefnode -! - ww=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) -! - c1=dcos(ww) - if(ww.gt.1.d-10) then - c2=dsin(ww)/ww - else - c2=1.d0 - endif - if(ww.gt.1.d-5) then - c3=(1.d0-c1)/ww**2 - else - c3=0.5d0 - endif -! -! rotation matrix c -! - do k=1,3 - do l=1,3 - c(k,l)=c1*d(k,l)+ - & c2*(e(k,1,l)*xn(1)+e(k,2,l)*xn(2)+ - & e(k,3,l)*xn(3))+c3*xn(k)*xn(l) - enddo - enddo -! - do l=1,3 - w(l)=w(l)+(alpha*c(l,1)-d(l,1))*(co(1,irefnode)-q(1)) - & +(alpha*c(l,2)-d(l,2))*(co(2,irefnode)-q(2)) - & +(alpha*c(l,3)-d(l,3))*(co(3,irefnode)-q(3)) - enddo -! -! copying the displacements -! - do l=1,3 - vold(l,irefnode)=w(l) - vold(l,irotnode)=xn(l) - enddo - vold(1,iexpnode)=alpha -c write(*,*) 'w',w(1),w(2),w(3) -c write(*,*) 'xn',xn(1),xn(2),xn(3) -c write(*,*) 'alpha',alpha -! -! apply the moment -! -c idir=idir-3 - idir=idir-4 - val=xforc(i) - call forcadd(irotnode,idir,val,nodeforc, - & ndirforc,xforc,nforc,nforc_,iamforc, - & iamplitude,nam,ntrans,trab,inotr,co, - & ikforc,ilforc,isector,add) -! -! check for shells whether the rotation about the normal -! on the shell has been eliminated -! - if(lakon(ielem)(7:7).eq.'L') then - indexx=iponor(1,indexe+j) - do j=1,3 - xnoref(j)=xnor(indexx+j) - enddo - dmax=0.d0 - imax=0 - do j=1,3 - if(dabs(xnoref(j)).gt.dmax) then - dmax=dabs(xnoref(j)) - imax=j - endif - enddo -! -! check whether a SPC suffices -! - if(dabs(1.d0-dmax).lt.1.d-3) then - val=0.d0 - if(nam.gt.0) iamplitude=0 - type='R' - call bounadd(irotnode,imax,imax,val,nodeboun, - & ndirboun,xboun,nboun,nboun_,iamboun, - & iamplitude,nam,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, - & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vold, - & irotnode,mi) - else -! -! check for an unused rotational DOF -! - isol=0 - do l=1,3 -c idof=8*(node-1)+3+imax - idof=8*(node-1)+4+imax - call nident(ikboun,idof,nboun,id) - if((id.gt.0).and.(ikboun(id).eq.idof)) then - imax=imax+1 - if(imax.gt.3) imax=imax-3 - cycle - endif - isol=1 - exit - enddo -! -! if one of the rotational dofs was not used so far, -! it can be taken as dependent side for fixing the -! rotation about the normal. If all dofs were used, -! no additional equation is needed. -! - if(isol.eq.1) then - idof=8*(irotnode-1)+imax - call nident(ikmpc,idof,nmpc,id) - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dnor: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)=' ' -! - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=imax - coefmpc(mpcfree)=xnoref(imax) - mpcfree=nodempc(3,mpcfree) - imax=imax+1 - if(imax.gt.3) imax=imax-3 - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=imax - coefmpc(mpcfree)=xnoref(imax) - mpcfree=nodempc(3,mpcfree) - imax=imax+1 - if(imax.gt.3) imax=imax-3 - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=imax - coefmpc(mpcfree)=xnoref(imax) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - endif - endif - endif - cycle - endif -! -! 2d element shell element: generate MPC's -! - if(lakon(ielem)(7:7).eq.'L') then - newnode=knor(indexk+1) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dforc: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dforc: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=knor(indexk+3) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dforc: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-2.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dforc: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - elseif(lakon(ielem)(7:7).eq.'B') then -! -! 1d beam element: generate MPC's -! - newnode=knor(indexk+1) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dforc: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dforc: increase nmpc_' - stop - endif - do k=2,4 - nodempc(1,mpcfree)=knor(indexk+k) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dforc: increase nmpc_' - stop - endif - enddo - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-4.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dforc: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - else -! -! 2d plane strain, plane stress or axisymmetric -! element -! - node=knor(indexk+2) - val=xforc(i) -c if(lakon(ielem)(7:7).eq.'A') then -c val=val*thicke(1,indexe+j)/(2.d0*pi) -c endif - call forcadd(node,idir,val,nodeforc, - & ndirforc,xforc,nforc,nforc_,iamforc, - & iamplitude,nam,ntrans,trab,inotr,co, - & ikforc,ilforc,isector,add) - endif - endif - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dfrom1d.f calculix-ccx-2.3/ccx_2.1/src/gen3dfrom1d.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dfrom1d.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dfrom1d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,312 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dfrom1d(i,kon,ipkon,lakon,ne,iponor,xnor,knor, - & thicke,ntrans,inotr,trab,nk,nk_,co,offset) -! -! expands 1d element i into a 3d element -! - implicit none -! - character*8 lakon(*) -! - integer i,kon(*),ipkon(*),ne,iponor(2,*),knor(*),ntrans, - & inotr(2,*),nk,nk_,indexe,j,nodel(8),indexx,indexk,k,nodeb(8,3) -! - real*8 xnor(*),thicke(2,*),trab(7,*),co(3,*),offset(2,*), - & thickb(2,3),xnorb(6,3),sc -! - indexe=ipkon(i) -! -! localizing the nodes, thicknesses and normals for the -! beam element -! - do j=1,3 - nodel(j)=kon(indexe+j) - kon(indexe+20+j)=nodel(j) - indexx=iponor(1,indexe+j) - indexk=iponor(2,indexe+j) - thickb(1,j)=thicke(1,indexe+j) - thickb(2,j)=thicke(2,indexe+j) - do k=1,6 - xnorb(k,j)=xnor(indexx+k) - enddo - do k=1,8 - nodeb(k,j)=knor(indexk+k) - enddo - if(ntrans.gt.0) then - do k=1,8 - inotr(1,nodeb(k,j))=inotr(1,nodel(j)) - enddo - endif - enddo -! -! generating the 3-D element topology for beam elements -! - if(lakon(i)(8:8).eq.'R') then - kon(indexe+1)=nodeb(1,1) - do j=1,3 - co(j,nodeb(1,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*(.5d0+offset(1,i)) - & +thickb(2,1)*xnorb(j+3,1)*(.5d0-offset(2,i)) - enddo - kon(indexe+2)=nodeb(1,3) - do j=1,3 - co(j,nodeb(1,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*(.5d0+offset(1,i)) - & +thickb(2,3)*xnorb(j+3,3)*(.5d0-offset(2,i)) - enddo - kon(indexe+3)=nodeb(2,3) - do j=1,3 - co(j,nodeb(2,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*(.5d0+offset(1,i)) - & -thickb(2,3)*xnorb(j+3,3)*(.5d0+offset(2,i)) - enddo - kon(indexe+4)=nodeb(2,1) - do j=1,3 - co(j,nodeb(2,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*(.5d0+offset(1,i)) - & -thickb(2,1)*xnorb(j+3,1)*(.5d0+offset(2,i)) - enddo - kon(indexe+5)=nodeb(4,1) - do j=1,3 - co(j,nodeb(4,1))=co(j,nodel(1)) - & +thickb(1,1)*xnorb(j,1)*(.5d0-offset(1,i)) - & +thickb(2,1)*xnorb(j+3,1)*(.5d0-offset(2,i)) - enddo - kon(indexe+6)=nodeb(4,3) - do j=1,3 - co(j,nodeb(4,3))=co(j,nodel(3)) - & +thickb(1,3)*xnorb(j,3)*(.5d0-offset(1,i)) - & +thickb(2,3)*xnorb(j+3,3)*(.5d0-offset(2,i)) - enddo - kon(indexe+7)=nodeb(3,3) - do j=1,3 - co(j,nodeb(3,3))=co(j,nodel(3)) - & +thickb(1,3)*xnorb(j,3)*(.5d0-offset(1,i)) - & -thickb(2,3)*xnorb(j+3,3)*(.5d0+offset(2,i)) - enddo - kon(indexe+8)=nodeb(3,1) - do j=1,3 - co(j,nodeb(3,1))=co(j,nodel(1)) - & +thickb(1,1)*xnorb(j,1)*(.5d0-offset(1,i)) - & -thickb(2,1)*xnorb(j+3,1)*(.5d0+offset(2,i)) - enddo - kon(indexe+9)=nodeb(1,2) - do j=1,3 - co(j,nodeb(1,2))=co(j,nodel(2)) - & -thickb(1,2)*xnorb(j,2)*(.5d0+offset(1,i)) - & +thickb(2,2)*xnorb(j+3,2)*(.5d0-offset(2,i)) - enddo - kon(indexe+10)=nodeb(5,3) - do j=1,3 - co(j,nodeb(5,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*(.5d0+offset(1,i)) - & -thickb(2,3)*xnorb(j+3,3)*offset(2,i) - enddo - kon(indexe+11)=nodeb(2,2) - do j=1,3 - co(j,nodeb(2,2))=co(j,nodel(2)) - & -thickb(1,2)*xnorb(j,2)*(.5d0+offset(1,i)) - & -thickb(2,2)*xnorb(j+3,2)*(.5d0+offset(2,i)) - enddo - kon(indexe+12)=nodeb(5,1) - do j=1,3 - co(j,nodeb(5,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*(.5d0+offset(1,i)) - & -thickb(2,1)*xnorb(j+3,1)*offset(2,i) - enddo - kon(indexe+13)=nodeb(4,2) - do j=1,3 - co(j,nodeb(4,2))=co(j,nodel(2)) - & +thickb(1,2)*xnorb(j,2)*(.5d0-offset(1,i)) - & +thickb(2,2)*xnorb(j+3,2)*(.5d0-offset(2,i)) - enddo - kon(indexe+14)=nodeb(7,3) - do j=1,3 - co(j,nodeb(7,3))=co(j,nodel(3)) - & +thickb(1,3)*xnorb(j,3)*(.5d0-offset(1,i)) - & -thickb(2,3)*xnorb(j+3,3)*offset(2,i) - enddo - kon(indexe+15)=nodeb(3,2) - do j=1,3 - co(j,nodeb(3,2))=co(j,nodel(2)) - & +thickb(1,2)*xnorb(j,2)*(.5d0-offset(1,i)) - & -thickb(2,2)*xnorb(j+3,2)*(.5d0+offset(2,i)) - enddo - kon(indexe+16)=nodeb(7,1) - do j=1,3 - co(j,nodeb(7,1))=co(j,nodel(1)) - & +thickb(1,1)*xnorb(j,1)*(.5d0-offset(1,i)) - & -thickb(2,1)*xnorb(j+3,1)*offset(2,i) - enddo - kon(indexe+17)=nodeb(8,1) - do j=1,3 - co(j,nodeb(8,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*offset(1,i) - & +thickb(2,1)*xnorb(j+3,1)*(.5d0-offset(2,i)) - enddo - kon(indexe+18)=nodeb(8,3) - do j=1,3 - co(j,nodeb(8,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*offset(1,i) - & +thickb(2,3)*xnorb(j+3,3)*(.5d0-offset(2,i)) - enddo - kon(indexe+19)=nodeb(6,3) - do j=1,3 - co(j,nodeb(6,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*offset(1,i) - & -thickb(2,3)*xnorb(j+3,3)*(.5d0+offset(2,i)) - enddo - kon(indexe+20)=nodeb(6,1) - do j=1,3 - co(j,nodeb(6,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*offset(1,i) - & -thickb(2,1)*xnorb(j+3,1)*(.5d0+offset(2,i)) - enddo - else -! -! circular cross section -! - sc=.5d0/dsqrt(2.d0) - kon(indexe+1)=nodeb(1,1) - do j=1,3 - co(j,nodeb(1,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*(sc+offset(1,i)) - & +thickb(2,1)*xnorb(j+3,1)*(sc-offset(2,i)) - enddo - kon(indexe+2)=nodeb(1,3) - do j=1,3 - co(j,nodeb(1,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*(sc+offset(1,i)) - & +thickb(2,3)*xnorb(j+3,3)*(sc-offset(2,i)) - enddo - kon(indexe+3)=nodeb(2,3) - do j=1,3 - co(j,nodeb(2,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*(sc+offset(1,i)) - & -thickb(2,3)*xnorb(j+3,3)*(sc+offset(2,i)) - enddo - kon(indexe+4)=nodeb(2,1) - do j=1,3 - co(j,nodeb(2,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*(sc+offset(1,i)) - & -thickb(2,1)*xnorb(j+3,1)*(sc+offset(2,i)) - enddo - kon(indexe+5)=nodeb(4,1) - do j=1,3 - co(j,nodeb(4,1))=co(j,nodel(1)) - & +thickb(1,1)*xnorb(j,1)*(sc-offset(1,i)) - & +thickb(2,1)*xnorb(j+3,1)*(sc-offset(2,i)) - enddo - kon(indexe+6)=nodeb(4,3) - do j=1,3 - co(j,nodeb(4,3))=co(j,nodel(3)) - & +thickb(1,3)*xnorb(j,3)*(sc-offset(1,i)) - & +thickb(2,3)*xnorb(j+3,3)*(sc-offset(2,i)) - enddo - kon(indexe+7)=nodeb(3,3) - do j=1,3 - co(j,nodeb(3,3))=co(j,nodel(3)) - & +thickb(1,3)*xnorb(j,3)*(sc-offset(1,i)) - & -thickb(2,3)*xnorb(j+3,3)*(sc+offset(2,i)) - enddo - kon(indexe+8)=nodeb(3,1) - do j=1,3 - co(j,nodeb(3,1))=co(j,nodel(1)) - & +thickb(1,1)*xnorb(j,1)*(sc-offset(1,i)) - & -thickb(2,1)*xnorb(j+3,1)*(sc+offset(2,i)) - enddo - kon(indexe+9)=nodeb(1,2) - do j=1,3 - co(j,nodeb(1,2))=co(j,nodel(2)) - & -thickb(1,2)*xnorb(j,2)*(sc+offset(1,i)) - & +thickb(2,2)*xnorb(j+3,2)*(sc-offset(2,i)) - enddo - kon(indexe+10)=nodeb(5,3) - do j=1,3 - co(j,nodeb(5,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*(.5d0+offset(1,i)) - & -thickb(2,3)*xnorb(j+3,3)*offset(2,i) - enddo - kon(indexe+11)=nodeb(2,2) - do j=1,3 - co(j,nodeb(2,2))=co(j,nodel(2)) - & -thickb(1,2)*xnorb(j,2)*(sc+offset(1,i)) - & -thickb(2,2)*xnorb(j+3,2)*(sc+offset(2,i)) - enddo - kon(indexe+12)=nodeb(5,1) - do j=1,3 - co(j,nodeb(5,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*(.5d0+offset(1,i)) - & -thickb(2,1)*xnorb(j+3,1)*offset(2,i) - enddo - kon(indexe+13)=nodeb(4,2) - do j=1,3 - co(j,nodeb(4,2))=co(j,nodel(2)) - & +thickb(1,2)*xnorb(j,2)*(sc-offset(1,i)) - & +thickb(2,2)*xnorb(j+3,2)*(sc-offset(2,i)) - enddo - kon(indexe+14)=nodeb(7,3) - do j=1,3 - co(j,nodeb(7,3))=co(j,nodel(3)) - & +thickb(1,3)*xnorb(j,3)*(.5d0-offset(1,i)) - & -thickb(2,3)*xnorb(j+3,3)*offset(2,i) - enddo - kon(indexe+15)=nodeb(3,2) - do j=1,3 - co(j,nodeb(3,2))=co(j,nodel(2)) - & +thickb(1,2)*xnorb(j,2)*(sc-offset(1,i)) - & -thickb(2,2)*xnorb(j+3,2)*(sc+offset(2,i)) - enddo - kon(indexe+16)=nodeb(7,1) - do j=1,3 - co(j,nodeb(7,1))=co(j,nodel(1)) - & +thickb(1,1)*xnorb(j,1)*(.5d0-offset(1,i)) - & -thickb(2,1)*xnorb(j+3,1)*offset(2,i) - enddo - kon(indexe+17)=nodeb(8,1) - do j=1,3 - co(j,nodeb(8,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*offset(1,i) - & +thickb(2,1)*xnorb(j+3,1)*(.5d0-offset(2,i)) - enddo - kon(indexe+18)=nodeb(8,3) - do j=1,3 - co(j,nodeb(8,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*offset(1,i) - & +thickb(2,3)*xnorb(j+3,3)*(.5d0-offset(2,i)) - enddo - kon(indexe+19)=nodeb(6,3) - do j=1,3 - co(j,nodeb(6,3))=co(j,nodel(3)) - & -thickb(1,3)*xnorb(j,3)*offset(1,i) - & -thickb(2,3)*xnorb(j+3,3)*(.5d0+offset(2,i)) - enddo - kon(indexe+20)=nodeb(6,1) - do j=1,3 - co(j,nodeb(6,1))=co(j,nodel(1)) - & -thickb(1,1)*xnorb(j,1)*offset(1,i) - & -thickb(2,1)*xnorb(j+3,1)*(.5d0+offset(2,i)) - enddo - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dfrom2d.f calculix-ccx-2.3/ccx_2.1/src/gen3dfrom2d.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dfrom2d.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dfrom2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,297 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dfrom2d(i,kon,ipkon,lakon,ne,iponor,xnor,knor, - & thicke,offset,ntrans,inotr,trab,ikboun,ilboun,nboun,nboun_, - & nodeboun,ndirboun,xboun,iamboun,typeboun,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,nk,nk_,co,rig,nmethod, - & iperturb,ithermal,mi,nam) -! -! expands 2d element i into a 3d element -! -! generates additional MPC's for plane stress, plane strain and -! axisymmetric elements -! - implicit none -! - logical axial,fixed -! - character*1 type,typeboun(*) - character*8 lakon(*) - character*20 labmpc(*) -! - integer kon(*),ipkon(*),ne,iponor(2,*),knor(*),ntrans,inotr(2,*), - & ikboun(*),ilboun(*),nboun,nboun_,nodeboun(*),ndirboun(*), - & iamboun(*),nam,ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree, - & ikmpc(*),ilmpc(*),nk,nk_,i,rig(*),nmethod,iperturb,ishift -! - integer indexe,j,nodel(8),indexx,indexk,k,nedge,nodes(3,8), - & iamplitude,l,newnode,idir,idof,id,m,mpcfreenew,node,ithermal(2), - & jmin,jmax,idummy,mi(2) -! - real*8 xnor(*),thicke(2,*),offset(2,*),trab(7,*),xboun(*), - & coefmpc(*),co(3,*),vdummy(0:4) -! - real*8 thicks(8),xnors(3,8),dc,ds,val,x,y -! - fixed=.false. -! -! check for axial elements -! - if(lakon(i)(1:2).eq.'CA') then - axial=.true. - else - axial=.false. - endif -! - indexe=ipkon(i) -! -! localizing the nodes, thicknesses and normals for the -! 2-D element -! - if((lakon(i)(2:2).eq.'6').or. - & (lakon(i)(4:4).eq.'6')) then - nedge=3 - ishift=15 - else - nedge=4 - ishift=20 - endif -! - do j=1,2*nedge - nodel(j)=kon(indexe+j) - kon(indexe+ishift+j)=nodel(j) - indexk=iponor(2,indexe+j) - thicks(j)=thicke(1,indexe+j) - do k=1,3 - nodes(k,j)=knor(indexk+k) - enddo - enddo -! -! generating the 3-D element topology for shell and plane -! stress/strain elements -! - if(lakon(i)(1:2).ne.'CA') then - do j=1,2*nedge - indexx=iponor(1,indexe+j) - do k=1,3 - xnors(k,j)=xnor(indexx+k) - enddo - if(ntrans.gt.0) then - do k=1,3 - inotr(1,nodes(k,j))=inotr(1,nodel(j)) - enddo - endif - enddo -! - do k=1,nedge - kon(indexe+k)=nodes(1,k) -! - do j=1,3 - co(j,nodes(1,k))=co(j,nodel(k)) - & -thicks(k)*xnors(j,k)*(.5d0+offset(1,i)) - enddo - enddo - do k=1,nedge - kon(indexe+nedge+k)=nodes(3,k) - do j=1,3 - co(j,nodes(3,k))=co(j,nodel(k)) - & +thicks(k)*xnors(j,k)*(.5d0-offset(1,i)) - enddo - enddo - do k=nedge+1,2*nedge - kon(indexe+nedge+k)=nodes(1,k) - do j=1,3 - co(j,nodes(1,k))=co(j,nodel(k)) - & -thicks(k)*xnors(j,k)*(.5d0+offset(1,i)) - enddo - enddo - do k=nedge+1,2*nedge - kon(indexe+2*nedge+k)=nodes(3,k) - do j=1,3 - co(j,nodes(3,k))=co(j,nodel(k)) - & +thicks(k)*xnors(j,k)*(.5d0-offset(1,i)) - enddo - enddo - do k=1,nedge - kon(indexe+4*nedge+k)=nodes(2,k) - do j=1,3 - co(j,nodes(2,k))=co(j,nodel(k)) - & -thicks(k)*xnors(j,k)*offset(1,i) - enddo - enddo - else -! -! generating the 3-D element topology for axisymmetric elements -! - dc=dcos(thicks(1)/2.d0) - ds=dsin(thicks(1)/2.d0) - do j=1,nedge - indexk=iponor(2,indexe+j) - x=co(1,nodel(j)) - y=co(2,nodel(j)) -! - node=knor(indexk+1) - co(1,node)=x*dc - co(2,node)=y - co(3,node)=-x*ds - kon(indexe+j)=node -! - node=knor(indexk+2) - co(1,node)=x - co(2,node)=y - co(3,node)=0.d0 - kon(indexe+4*nedge+j)=node -! - node=knor(indexk+3) - co(1,node)=x*dc - co(2,node)=y - co(3,node)=x*ds - kon(indexe+nedge+j)=node - enddo -! - do j=nedge+1,2*nedge - indexk=iponor(2,indexe+j) - x=co(1,nodel(j)) - y=co(2,nodel(j)) -! - node=knor(indexk+1) - co(1,node)=x*dc - co(2,node)=y - co(3,node)=-x*ds - kon(indexe+nedge+j)=node -! - node=knor(indexk+3) - co(1,node)=x*dc - co(2,node)=y - co(3,node)=x*ds - kon(indexe+2*nedge+j)=node - enddo - endif -! -! additional SPC's due to plane strain/plane stress/axisymmetric -! conditions -! - do j=1,2*nedge - if(lakon(i)(1:1).ne.'S') then -! -! fixing the middle plane -! - if(rig(nodel(j)).gt.0) cycle -! - if(ithermal(2).ne.2) then - val=0.d0 - k=3 - if(nam.gt.0) iamplitude=0 - type='M' - call bounadd(nodes(2,j),k,k,val,nodeboun, - & ndirboun,xboun,nboun,nboun_,iamboun, - & iamplitude,nam,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, - & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_, - & labmpc,type,typeboun,nmethod,iperturb, - & fixed,vdummy,idummy,mi) - endif -! -! specifying that the side planes do the same -! as the middle plane (in all directions for -! plane strain and axisymmetric elements, in the -! plane for plane stress elements) -! - if(ithermal(2).le.1) then - jmin=1 - jmax=3 - elseif(ithermal(2).eq.2) then - jmin=0 - jmax=0 - else - jmin=0 - jmax=3 - endif -! - do l=1,3,2 - newnode=nodes(l,j) - do idir=jmin,jmax - if((idir.eq.3).and.(lakon(i)(1:3).eq.'CPS')) - & cycle - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dfrom2d: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do m=nmpc,id+2,-1 - ikmpc(m)=ikmpc(m-1) - ilmpc(m)=ilmpc(m-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dfrom2d: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=nodes(2,j) - if((lakon(i)(2:2).eq.'A').and.(idir.eq.3)) - & then - nodempc(2,mpcfree)=1 - else - nodempc(2,mpcfree)=idir - endif - if(lakon(i)(2:2).eq.'A') then - if(idir.eq.1) then - coefmpc(mpcfree)=-dc - elseif(idir.eq.3) then - if(l.eq.1) then - coefmpc(mpcfree)=ds - else - coefmpc(mpcfree)=-ds - endif - else - coefmpc(mpcfree)=-1.d0 - endif - else - coefmpc(mpcfree)=-1.d0 - endif - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dfrom2d: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - enddo - enddo - endif - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dmpc.f calculix-ccx-2.3/ccx_2.1/src/gen3dmpc.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dmpc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dmpc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,238 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dmpc(ipompc,nodempc,coefmpc,nmpc,nmpc_,mpcfree, - & ikmpc,ilmpc,labmpc,iponoel,inoel,iponoelmax,kon,ipkon,lakon, - & ne,iponor,xnor,knor,rig) -! -! connects nodes of 1-D and 2-D elements, for which MPC's were -! defined, to the nodes of their expanded counterparts -! - implicit none -! - character*8 lakon(*) - character*20 labmpc(*) -! - integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,ikmpc(*), - & ilmpc(*),iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*), - & ne,iponor(2,*),knor(*),rig(*),i,index1,node,index2,ielem, - & indexe,j,indexk,newnode,idir,idof,id,mpcfreenew,k -! - real*8 coefmpc(*),xnor(*) -! - do i=1,nmpc - index1=ipompc(i) - do - node=nodempc(1,index1) - if(node.le.iponoelmax) then - if(rig(node).ne.0) then -c if(nodempc(2,index1).gt.3) then - if(nodempc(2,index1).gt.4) then - if(rig(node).lt.0) then - write(*,*) '*ERROR in gen3dmpc: in node ',node - write(*,*) ' a rotational DOF is constrained' - write(*,*) ' by a SPC; however, the elements' - write(*,*) ' to which this node belongs do not' - write(*,*) ' have rotational DOFs' - stop - endif - nodempc(1,index1)=rig(node) -c nodempc(2,index1)=nodempc(2,index1)-3 - nodempc(2,index1)=nodempc(2,index1)-4 - endif - else - index2=iponoel(node) -c -c check for nodes not belonging to 1d or 2d elements -c - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) exit - cycle - endif -c - ielem=inoel(1,index2) - indexe=ipkon(ielem) - j=inoel(2,index2) - indexk=iponor(2,indexe+j) -! -! 2d element shell element -! - if(lakon(ielem)(7:7).eq.'L') then - newnode=knor(indexk+1) - idir=nodempc(2,index1) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=knor(indexk+3) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-2.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - elseif(lakon(ielem)(7:7).eq.'B') then -! -! 1d beam element -! - newnode=knor(indexk+1) - idir=nodempc(2,index1) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - do k=2,4 - nodempc(1,mpcfree)=knor(indexk+k) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - enddo - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-4.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - else -! -! 2d plane stress, plane strain or axisymmetric -! element -! - newnode=knor(indexk+2) - idir=nodempc(2,index1) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if(((id.le.0).or.(ikmpc(id).ne.idof)).and. - & (idir.ne.3)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-1.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - endif - endif - endif - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dnor.f calculix-ccx-2.3/ccx_2.1/src/gen3dnor.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dnor.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dnor.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,897 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dnor(nk,nk_,co,iponoel,inoel,iponoelmax,kon,ipkon, - & lakon,ne,thicke,offset,iponor,xnor,knor,rig,iperturb,tinc, - & tper,tmin,tmax,ctrl,ipompc,nodempc,coefmpc,nmpc,nmpc_,mpcfree, - & ikmpc,ilmpc,labmpc,ikboun,ilboun,nboun,nboun_,nodeboun,ndirboun, - & xboun,iamboun,typeboun,nam,ntrans,inotr,trab,ikfree,ixfree, - & nmethod,ithermal,istep,mi) -! -! calculates normals on 1-D and 2-D elements -! - implicit none -! - logical fixed -! - character*1 type,typeboun(*) - character*8 lakon(*) - character*20 labmpc(*) -! - integer nk,nk_,iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*), - & ne,iponor(2,*),knor(*),rig(*),iperturb,ipompc(*),nodempc(3,*), - & nmpc,nmpc_,mpcfree,ikmpc(*),ilmpc(*),ikboun(*),ilboun(*),nboun, - & nboun_,nodeboun(*),ndirboun(*),iamboun(*),nam,ntrans,inotr(2,*), - & isol,istep,idummy,mi(2) -! - integer i,ndepnodes,index,nexp,nnor,nel,ielem,indexe,j,iel(100), - & jl(100),ial(100),ifi(100),idepnodes(80),indexx,k,l,ifix,nemin, - & jact,ixfree,ikfree,node,nelshell,irefnode,idof,id,mpcfreeold, - & irotnode,imax,iamplitude,nmethod,ithermal(2),iexpnode -! - real*8 co(3,*),thicke(2,*),offset(2,*),xnor(*),tinc,tper,tmin, - & tmax,ctrl(*),coefmpc(*),xboun(*),trab(7,*),vdummy(0:4) -! - real*8 xno(3,100),xta(3,100),xn1(3,100),thl1(100),thl2(100), - & off1(100),off2(100),xi,et,coloc6(2,6),coloc8(2,8),xl(3,8), - & dd,xnoref(3),dot,coloc3(3),dot1,dot2,dmax,val -! - data coloc3 /-1.d0,0.d0,1.d0/ - data coloc6 /0.d0,0.d0,1.d0,0.d0,0.d0,1.d0,0.5d0,0.d0, - & 0.5d0,0.5d0,0.d0,0.5d0/ - data coloc8 /-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0,1.d0, - & 0.d0,-1.d0,1.d0,0.d0,0.d0,1.d0,-1.d0,0.d0/ -! - fixed=.false. -! -! calculating the normals in nodes belonging to shells/beams -! - do i=1,nk - ndepnodes=0 - index=iponoel(i) - if(index.eq.0) cycle -! -! nexp indicates how many times the node was expanded -! - nexp=0 -! -! nnor indicates whether the expanded nodes lie on a point -! (nnor=0, only for plane stress, plane strain or axisymmetric -! elements), on a line (nnor=1) or in a plane (nnor=2) -! - nnor=0 -! -! locating the shell elements to which node i belongs -! - nel=0 - do - if(index.eq.0) exit - ielem=inoel(1,index) - if(lakon(ielem)(1:1).ne.'B') then - if(lakon(ielem)(1:1).eq.'S') nnor=1 - indexe=ipkon(ielem) - nel=nel+1 - if(nel.gt.100) then - write(*,*) '*ERROR in gen3dnor: more than 100' - write(*,*) ' shell elements share the' - write(*,*) ' same node' - stop - endif - j=inoel(2,index) - jl(nel)=j - iel(nel)=ielem - thl1(nel)=thicke(1,indexe+j) - off1(nel)=offset(1,ielem) - endif - index=inoel(3,index) - enddo -! - if(nel.gt.0) then - do j=1,nel - ial(j)=0 - enddo -! -! estimate the normal -! - do j=1,nel - indexe=ipkon(iel(j)) - indexx=iponor(1,indexe+jl(j)) - if(indexx.ge.0) then - do k=1,3 - xno(k,j)=xnor(indexx+k) - enddo - ifi(j)=1 - cycle - else - ifi(j)=0 - endif - if((lakon(iel(j))(2:2).eq.'6').or. - & (lakon(iel(j))(4:4).eq.'6')) then - xi=coloc6(1,jl(j)) - et=coloc6(2,jl(j)) - do k=1,6 - node=kon(indexe+k) - do l=1,3 - xl(l,k)=co(l,node) - enddo - enddo - call norshell6(xi,et,xl,xno(1,j)) - else - xi=coloc8(1,jl(j)) - et=coloc8(2,jl(j)) - do k=1,8 - node=kon(indexe+k) - do l=1,3 - xl(l,k)=co(l,node) - enddo - enddo - call norshell8(xi,et,xl,xno(1,j)) - endif - dd=dsqrt(xno(1,j)**2+xno(2,j)**2+xno(3,j)**2) - if(dd.lt.1.d-10) then - write(*,*) '*ERROR in gen3dnor: size of estimated' - write(*,*) ' shell normal in node ',i, - & ' element ',iel(j) - write(*,*) ' is smaller than 1.e-10' - stop - endif - do k=1,3 - xno(k,j)=xno(k,j)/dd - enddo - enddo -! - do -! -! determining a fixed normal which was not treated yet, -! or, if none is left, the minimum element number of all -! elements containing node i and for which no normal was -! determined yet -! -! if ial(j)=0: the normal on this element has not been -! treated yet -! if ial(j)=2: normal has been treated -! - ifix=0 - nemin=ne+1 - do j=1,nel - if(ial(j).ne.0) cycle - if(ifi(j).eq.1) then - jact=j - ifix=1 - exit - endif - enddo - if(ifix.eq.0) then - do j=1,nel - if(ial(j).eq.0) then - if(iel(j).lt.nemin) then - nemin=iel(j) - jact=j - endif - endif - enddo - if(nemin.eq.ne+1) exit - endif -! - do j=1,3 - xnoref(j)=xno(j,jact) - enddo -! -! determining all elements whose normal in node i makes an -! angle smaller than 0.5 or 20 degrees with the reference normal, -! depending whether the reference normal was given by the -! user or is being calculated; the thickness and offset must -! also fit. -! -! if ial(j)=1: normal on element is being treated now -! - do j=1,nel - if(ial(j).eq.2) cycle - if(j.eq.jact) then - ial(jact)=1 - else - dot=xno(1,j)*xnoref(1)+xno(2,j)*xnoref(2)+ - & xno(3,j)*xnoref(3) - if(ifix.eq.0) then - if(dot.gt.0.939693d0)then - if((dabs(thl1(j)-thl1(jact)).lt.1.d-10) - & .and. - & (dabs(off1(j)-off1(jact)).lt.1.d-10) - & .and. - & ((lakon(iel(j))(1:3).eq.lakon(iel(jact))(1:3)) - & .or. - & ((lakon(iel(j))(1:1).eq.'S').and. - & (lakon(iel(jact))(1:1).eq.'S')))) - & ial(j)=1 -c - if(dot.lt.0.999962) nnor=2 -c - else - if((lakon(iel(j))(1:1).eq.'S').and. - & (lakon(iel(jact))(1:1).eq.'S')) then -! -! if the normals have the opposite -! direction, the expanded nodes are on a -! straight line -! - if(dot.gt.-0.999962) then - nnor=2 - else - write(*,*) '*INFO in gen3dnor: in some - & nodes opposite normals are defined' - endif - endif - endif - else - if(dot.gt.0.999962d0) then - if((dabs(thl1(j)-thl1(jact)).lt.1.d-10) - & .and. - & (dabs(off1(j)-off1(jact)).lt.1.d-10) - & .and. - & ((lakon(iel(j))(1:3).eq.lakon(iel(jact))(1:3)) - & .or. - & ((lakon(iel(j))(1:1).eq.'S').and. - & (lakon(iel(jact))(1:1).eq.'S')))) - & ial(j)=1 -c - if(dot.lt.0.999962) nnor=2 -c - else - if((lakon(iel(j))(1:1).eq.'S').and. - & (lakon(iel(jact))(1:1).eq.'S')) then -! -! if the normals have the opposite -! direction, the expanded nodes are on a -! straight line -! - if(dot.gt.-0.999962) then - nnor=2 - else - write(*,*) '*INFO in gen3dnor: in some - & nodes opposite normals are defined' - endif - endif - endif - endif - endif - enddo -! -! determining the mean normal for the selected elements -! - if(ifix.eq.0) then - do j=1,3 - xnoref(j)=0.d0 - enddo - do j=1,nel - if(ial(j).eq.1) then - do k=1,3 - xnoref(k)=xnoref(k)+xno(k,j) - enddo - endif - enddo - dd=dsqrt(xnoref(1)**2+xnoref(2)**2+xnoref(3)**2) - if(dd.lt.1.d-10) then - write(*,*) '*ERROR in gen3dnor: size of' - write(*,*) ' estimated shell normal is' - write(*,*) ' smaller than 1.e-10' - stop - endif - do j=1,3 - xnoref(j)=xnoref(j)/dd - enddo - endif -! -! updating the pointers iponor -! - nexp=nexp+1 - do j=1,nel - if(ial(j).eq.1) then - ial(j)=2 - if(ifix.eq.0) then - iponor(1,ipkon(iel(j))+jl(j))=ixfree - elseif(j.ne.jact) then - iponor(1,ipkon(iel(j))+jl(j))= - & iponor(1,ipkon(iel(jact))+jl(jact)) - endif - iponor(2,ipkon(iel(j))+jl(j))=ikfree - endif - enddo -! -! storing the normal in xnor and generating 3 nodes -! for knor -! - if(ifix.eq.0) then - do j=1,3 - xnor(ixfree+j)=xnoref(j) - enddo - ixfree=ixfree+3 - endif -! - do k=1,3 - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in nodes: increase nk_' - stop - endif - knor(ikfree+k)=nk -! -! for plane stress, plane strain and axisymmetric -! elements only the middle node is included in the -! rigid body definition -! - if((lakon(iel(jact))(2:2).ne.'P').and. - & (lakon(iel(jact))(2:2).ne.'A')) then - idepnodes(ndepnodes+1)=nk - ndepnodes=ndepnodes+1 - elseif(k.eq.2) then -c if(jl(jact).le.4) then -c write(*,*) 'depnode ',nk - idepnodes(ndepnodes+1)=nk - ndepnodes=ndepnodes+1 -c endif - endif - enddo - ikfree=ikfree+3 - enddo - endif -! - nelshell=nel+1 -! -! locating the beam elements to which node i belongs -! - index=iponoel(i) - do - if(index.eq.0) exit - ielem=inoel(1,index) - if(lakon(ielem)(1:1).eq.'B') then - indexe=ipkon(ielem) - nel=nel+1 - if(nel.gt.100) then - write(*,*) '*ERROR in gen3dnor: more than 100' - write(*,*) ' beam/shell elements share' - write(*,*) ' the same node' - stop - endif - j=inoel(2,index) - jl(nel)=j - iel(nel)=ielem - thl1(nel)=thicke(1,indexe+j) - thl2(nel)=thicke(2,indexe+j) - off1(nel)=offset(1,ielem) - off2(nel)=offset(2,ielem) - endif - index=inoel(3,index) - enddo -! - if(nel.ge.nelshell) then - nnor=2 - do j=nelshell,nel - ial(j)=0 - enddo -! -! estimate the normal -! - do j=nelshell,nel - xi=coloc3(jl(j)) - indexe=ipkon(iel(j)) - do k=1,3 - node=kon(indexe+k) - do l=1,3 - xl(l,k)=co(l,node) - enddo - enddo -! -! determining the tangent vector xta -! - do k=1,3 - xta(k,j)=(xi-0.5d0)*xl(k,1)-2.d0*xi*xl(k,2)+ - & (xi+0.5d0)*xl(k,3) - enddo - dd=dsqrt(xta(1,j)**2+xta(2,j)**2+xta(3,j)**2) - if(dd.lt.1.d-10) then - write(*,*) '*ERROR in gen3dnor: size of estimated' - write(*,*)' beam tangent in node ',i,' element ' - &,iel(j) - write(*,*) ' is smaller than 1.e-10' - stop - endif - do k=1,3 - xta(k,j)=xta(k,j)/dd - enddo -! -! check whether normal was defined with *NORMAL and -! determine vector n1 -! - if(iponor(1,indexe+jl(j)).ge.0) then - indexx=iponor(1,indexe+jl(j)) - if(dabs(xnor(indexx+4)**2+xnor(indexx+5)**2+ - & xnor(indexx+6)**2-1.d0).lt.1.d-5) then - do k=1,3 - xno(k,j)=xnor(indexx+3+k) - enddo - ifi(j)=1 - cycle - endif - ifi(j)=0 - do k=1,3 - xn1(k,j)=xnor(indexx+k) - enddo - else - ifi(j)=0 - xn1(1,j)=0.d0 - xn1(2,j)=0.d0 - xn1(3,j)=-1.d0 - endif -! -! normal (=n2) = xta x xn1 -! - xno(1,j)=xta(2,j)*xn1(3,j)-xta(3,j)*xn1(2,j) - xno(2,j)=xta(3,j)*xn1(1,j)-xta(1,j)*xn1(3,j) - xno(3,j)=xta(1,j)*xn1(2,j)-xta(2,j)*xn1(1,j) - dd=dsqrt(xno(1,j)**2+xno(2,j)**2+xno(3,j)**2) - if(dd.lt.1.d-10) then - write(*,*) '*ERROR in gen3dnor: size of estimated' - write(*,*)' beam normal in 2-direction in node ' - &,i,' element ',iel(j) - write(*,*) ' is smaller than 1.e-10' - stop - endif - do k=1,3 - xno(k,j)=xno(k,j)/dd - enddo - enddo -! - do -! -! determining a fixed normal which was not treated yet, -! or, if none is left, the minimum element number of all -! elements containing node i and for which no normal was -! determined yet -! - ifix=0 - nemin=ne+1 - do j=nelshell,nel - if(ial(j).ne.0) cycle - if(ifi(j).eq.1) then - jact=j - ifix=1 - exit - endif - enddo - if(ifix.eq.0) then - do j=nelshell,nel - if(ial(j).eq.0) then - if(iel(j).lt.nemin) then - nemin=iel(j) - jact=j - endif - endif - enddo - if(nemin.eq.ne+1) exit - endif -! -! the reference normal is the one on the element with the -! smallest element number -! - do j=1,3 - xnoref(j)=xno(j,jact) - enddo -! -! determining all elements whose normal in node i makes an -! angle smaller than 0.5 or 20 degrees with the reference normal, -! depending whether the reference normal was given by the -! user or is being calculated; the thickness and offset must -! also fit. -! - do j=nelshell,nel - if(j.eq.jact) then - ial(jact)=1 - else - dot1=xno(1,j)*xnoref(1)+xno(2,j)*xnoref(2)+ - & xno(3,j)*xnoref(3) - dot2=xta(1,j)*xta(1,jact)+xta(2,j)*xta(2,jact)+ - & xta(3,j)*xta(3,jact) - if(ifix.eq.0) then - if((dot1.gt.0.939693d0).and. - & (dot2.gt.0.939693d0)) then - if((dabs(thl1(j)-thl1(jact)).lt.1.d-10) - & .and. - & (dabs(thl2(j)-thl2(jact)).lt.1.d-10) - & .and. - & (dabs(off1(j)-off1(jact)).lt.1.d-10) - & .and. - & (dabs(off2(j)-off2(jact)).lt.1.d-10) - & .and. - & (lakon(iel(j))(8:8).eq.lakon(iel(jact))(8:8))) - & ial(j)=1 - endif - else - if((dot1.gt.0.999962d0).and. - & (dot2.gt.0.999962d0)) then - if((dabs(thl1(j)-thl1(jact)).lt.1.d-10) - & .and. - & (dabs(thl2(j)-thl2(jact)).lt.1.d-10) - & .and. - & (dabs(off1(j)-off1(jact)).lt.1.d-10) - & .and. - & (dabs(off2(j)-off2(jact)).lt.1.d-10) - & .and. - & (lakon(iel(j))(8:8).eq.lakon(iel(jact))(8:8))) - & ial(j)=1 - endif - endif - endif - enddo -! -! determining the mean normal for the selected elements -! - if(ifix.eq.0) then - do j=1,3 - xnoref(j)=0.d0 - enddo - do j=nelshell,nel - if(ial(j).eq.1) then - do k=1,3 - xnoref(k)=xnoref(k)+xno(k,j) - enddo - endif - enddo - endif -! -! calculating the mean tangent -! - do j=nelshell,nel - if((ial(j).eq.1).and.(j.ne.jact)) then - do k=1,3 - xta(k,jact)=xta(k,jact)+xta(k,j) - enddo - endif - enddo - dd=dsqrt(xta(1,jact)**2+xta(2,jact)**2+xta(3,jact)**2) - if(dd.lt.1.d-10) then - write(*,*) '*ERROR in gen3dnor: size of mean' - write(*,*)' beam tangent is smaller than 1.e-10' - stop - endif - do k=1,3 - xta(k,jact)=xta(k,jact)/dd - enddo -! -! taking care that the mean normal is orthogonal towards -! the mean tangent -! - dd=xnoref(1)*xta(1,jact)+xnoref(2)*xta(2,jact)+ - & xnoref(3)*xta(3,jact) - do j=1,3 - xnoref(j)=xnoref(j)-dd*xta(j,jact) - enddo - dd=dsqrt(xnoref(1)**2+xnoref(2)**2+xnoref(3)**2) - if(dd.lt.1.d-10) then - write(*,*) '*ERROR in gen3dnor: size of' - write(*,*) ' estimated beam normal is' - write(*,*) ' smaller than 1.e-10' - stop - endif - do j=1,3 - xnoref(j)=xnoref(j)/dd - enddo -! -! calculating xn1 = xn2 x tangent -! - xn1(1,jact)=xnoref(2)*xta(3,jact)-xnoref(3)*xta(2,jact) - xn1(2,jact)=xnoref(3)*xta(1,jact)-xnoref(1)*xta(3,jact) - xn1(3,jact)=xnoref(1)*xta(2,jact)-xnoref(2)*xta(1,jact) -! -! storing the normals in xnor and generating 8 nodes -! for knor -! - nexp=nexp+1 - do j=nelshell,nel - if(ial(j).eq.1) then - ial(j)=2 - if(ifix.eq.0) then - iponor(1,ipkon(iel(j))+jl(j))=ixfree - else - iponor(1,ipkon(iel(j))+jl(j))= - & iponor(1,ipkon(iel(jact))+jl(jact)) - endif - iponor(2,ipkon(iel(j))+jl(j))=ikfree - endif - enddo -! - do j=1,3 - xnor(ixfree+j)=xn1(j,jact) - enddo - do j=1,3 - xnor(ixfree+3+j)=xnoref(j) - enddo - ixfree=ixfree+6 - do k=1,8 - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in nodes: increase nk_' - stop - endif - knor(ikfree+k)=nk - idepnodes(ndepnodes+k)=nk - enddo - ikfree=ikfree+8 - ndepnodes=ndepnodes+8 - enddo - endif -! -! check whether the user has specified rotational degrees -! of freedom (in that case rig(i)=-1 was assigned in -! subroutine gen3delem); if so, a rigid MPC must be defined -! - if(rig(i).ne.0) then - rig(i)=0 - if(nexp.le.1) then - nexp=2 - endif - endif -! -! storing the expanded nodes -! -c write(*,*) i,(idepnodes(k),k=1,ndepnodes) -! -! generate rigid MPC's if necessary -! - if(nexp.gt.1) then -cc write(*,*) i,'= KNOT !' -cc if(iperturb.eq.0) then -c if((iperturb.eq.0).and.(nmethod.eq.1)) then -c iperturb=2 -c tinc=1.d0 -c tper=1.d0 -c tmin=1.d-5 -c tmax=1.d+30 -c elseif(iperturb.eq.1) then -c write(*,*) '*ERROR in gen3dnor: the expansion of' -c write(*,*) ' 1D/2D elements has led to the' -c write(*,*) ' creation of rigid body MPCs.' -c write(*,*) ' This is not allowed in a' -c write(*,*) ' perturbation analysis. Please' -c write(*,*) ' generate a truely 3D structure' -c stop -c endif - irefnode=i -! - rig(i)=-1 -! - if(ithermal(2).ne.2) then - if(nnor.eq.0) then -! -! the node belongs to plane stress, plane strain -! or axisymmetric elements only. These are only linked -! through the node in the midplane: the nodes -! coincide; only DOF1 and DOF2 are linked. -! rig(i)=-1 to indicate that a knot has -! been generated without rotational node -! -c rig(i)=-1 -c changed for purely thermal calculations -! - do k=1,ndepnodes - node=idepnodes(k) - do j=1,2 - idof=8*(node-1)+j - call nident(ikmpc,idof,nmpc,id) - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in rigidmpc: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)=' ' -! - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node -c write(*,*) 'dependent node: ',node - nodempc(2,mpcfree)=j - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=irefnode - nodempc(2,mpcfree)=j - coefmpc(mpcfree)=-1.d0 - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - enddo - enddo - else -! -! generate a rigid body knot; rig(i) contains the -! rotational node of the knot -! - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in rigidbodies: increase nk_' - stop - endif - irotnode=nk - rig(i)=irotnode - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in rigidbodies: increase nk_' - stop - endif - iexpnode=nk - do k=1,ndepnodes - call knotmpc(ipompc,nodempc,coefmpc,irefnode, - & irotnode,iexpnode, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_, - & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, - & idepnodes(k),typeboun,co,xboun,istep) - enddo - endif - endif -! -! MPC's for the temperature DOFs -! - if(ithermal(2).ge.2) then - do k=1,ndepnodes - node=idepnodes(k) - idof=8*(node-1) - call nident(ikmpc,idof,nmpc,id) - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dnor: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)=' ' -! - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=0 - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=irefnode - nodempc(2,mpcfree)=0 - coefmpc(mpcfree)=-1.d0 - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - enddo - endif -! - if((nnor.eq.1).and.(ithermal(2).ne.2)) then -! -! generate an additional SPC or MPC for rigid body nodes -! lying on a line to prevent rotation about the -! line -! - dmax=0.d0 - imax=0 - do j=1,3 - if(dabs(xnoref(j)).gt.dmax) then - dmax=dabs(xnoref(j)) - imax=j - endif - enddo -! -! check whether a SPC suffices -! - if(dabs(1.d0-dmax).lt.1.d-3) then - val=0.d0 - if(nam.gt.0) iamplitude=0 - type='R' - call bounadd(irotnode,imax,imax,val,nodeboun, - & ndirboun,xboun,nboun,nboun_,iamboun, - & iamplitude,nam,ipompc,nodempc,coefmpc, - & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, - & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, - & type,typeboun,nmethod,iperturb,fixed,vdummy, - & idummy,mi) - else -! -! check whether the rotational degree of freedom -! imax is fixed through a SPC -! - isol=0 - do l=1,3 -c idof=8*(i-1)+3+imax - idof=8*(i-1)+4+imax - call nident(ikboun,idof,nboun,id) - if(((id.gt.0).and.(ikboun(id).eq.idof)).or. - & (dabs(xnoref(imax)).lt.1.d-10)) then - imax=imax+1 - if(imax.gt.3) imax=imax-3 - cycle - endif - isol=1 - exit - enddo -! -! if one of the rotational dofs was not used so far, -! it can be taken as dependent side for fixing the -! rotation about the normal. If all dofs were used, -! no additional equation is needed. -! - if(isol.eq.1) then - idof=8*(irotnode-1)+imax - call nident(ikmpc,idof,nmpc,id) - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dnor: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)=' ' -! - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=imax - coefmpc(mpcfree)=xnoref(imax) - mpcfree=nodempc(3,mpcfree) - imax=imax+1 - if(imax.gt.3) imax=imax-3 - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=imax - coefmpc(mpcfree)=xnoref(imax) - mpcfree=nodempc(3,mpcfree) - imax=imax+1 - if(imax.gt.3) imax=imax-3 - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=imax - coefmpc(mpcfree)=xnoref(imax) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - endif - endif - endif - endif - enddo -! -c do i=1,nmpc -c call writempc(ipompc,nodempc,coefmpc,labmpc,i) -c enddo -c do i=1,nboun -c write(*,*) nodeboun(i),ndirboun(i),xboun(i) -c enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dprop.f calculix-ccx-2.3/ccx_2.1/src/gen3dprop.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dprop.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dprop.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,218 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dprop(prop,ielprop,iponoel,inoel,iponoelmax,kon, - & ipkon,lakon,ne,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc, - & nmpc_,mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk, - & nk_,co,nmethod,iperturb) -! -! connects nodes of 1-D and 2-D elements which are used in fluid -! property definitions to the nodes of their expanded counterparts -! - implicit none -! - character*8 lakon(*) - character*20 labmpc(*) -! - integer iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*),ne, - & iponor(2,*),knor(*),ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree, - & ikmpc(*),ilmpc(*),rig(*),ntrans,inotr(2,*),i,node,ielprop(*), - & index,ielem,j,indexe,indexk,idir,nk,nk_, - & newnode,idof,id,mpcfreenew,k,nam,nmethod,iperturb,ii -! - real*8 xnor(*),coefmpc(*),trab(7,*),co(3,*),prop(*) -! - do i=1,ne -C if((lakon(i).ne.'DLIPIMAF').and.(lakon(i).ne.'DLIPIWCF')) cycle - if((lakon(i).ne.'DLIPIMAF').and.(lakon(i).ne.'DLIPIWCF') - & .and.(lakon(i)(1:5).ne.'DLABF') - & .and.(lakon(i)(1:6).ne.'DGAPFF') - & .and.(lakon(i)(1:5).ne.'DORFL') - & .and.(lakon(i)(1:6).ne.'DGAPIF')) cycle - do ii=1,6 - node=int(prop(ielprop(i)+int((ii+2.5d0)/3.d0))) - if(node.gt.iponoelmax) cycle - index=iponoel(node) - if(index.eq.0) cycle - ielem=inoel(1,index) - j=inoel(2,index) - indexe=ipkon(ielem) - indexk=iponor(2,indexe+j) - idir=ii-3*(int((ii+2.5d0)/3.d0)-1) -c write(*,*) 'gen3dprop,node,idir',node,idir -! - if(rig(node).ne.0) cycle -! -! 2d element shell element: generate MPC's -! - if(lakon(ielem)(7:7).eq.'L') then - newnode=knor(indexk+1) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dprop: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dprop: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=knor(indexk+3) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dprop: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-2.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dprop: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - elseif(lakon(ielem)(7:7).eq.'B') then -! -! 1d beam element: generate MPC's -! - newnode=knor(indexk+1) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dprop: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dprop: increase nmpc_' - stop - endif - do k=2,4 - nodempc(1,mpcfree)=knor(indexk+k) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dprop: increase nmpc_' - stop - endif - enddo - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-4.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dprop: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - else -! -! 2d plane stress, plane strain or axisymmetric -! element: SPC -! - newnode=knor(indexk+2) - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if(((id.le.0).or.(ikmpc(id).ne.idof)).and. - & (idir.ne.3)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-1.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dmpc: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - endif - enddo - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dsurf.f calculix-ccx-2.3/ccx_2.1/src/gen3dsurf.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dsurf.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dsurf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,192 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dsurf(iponoel,inoel,iponoelmax,kon,ipkon, - & lakon,ne,iponor,knor,ipompc,nodempc,coefmpc,nmpc,nmpc_, - & mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk,nk_,co, - & nmethod,iperturb,nset,set,istartset,iendset,ialset) -! -! connects nodes of 1-D and 2-D elements, for which SPC's were -! defined, to the nodes of their expanded counterparts -! - implicit none -! - character*8 lakon(*) - character*20 labmpc(*) - character*81 set(*) -! - integer iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*),ne, - & iponor(2,*),knor(*),ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree, - & ikmpc(*),ilmpc(*),rig(*),ntrans,inotr(2,*),i,node, - & indexx,ielem,j,indexe,indexk,idir,nk,nk_, - & newnode,idof,id,mpcfreenew,k,nam,nmethod,iperturb,istartset(*), - & iendset(*),ialset(*),nset,ipos,l -! - real*8 coefmpc(*),trab(7,*),co(3,*) -! - do i=1,nset - ipos=index(set(i),' ') - if(set(i)(ipos-1:ipos-1).ne.'S') cycle - do l=istartset(i),iendset(i) - node=ialset(l) - if(node.gt.iponoelmax) cycle - indexx=iponoel(node) - if(indexx.eq.0) cycle - ielem=inoel(1,indexx) - j=inoel(2,indexx) - indexe=ipkon(ielem) - indexk=iponor(2,indexe+j) -! - if(rig(node).eq.0) then -! -! 2d element shell element: generate MPC's -! - if(lakon(ielem)(7:7).eq.'L') then - newnode=knor(indexk+1) - do idir=1,3 - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=knor(indexk+3) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-2.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif - enddo - elseif(lakon(ielem)(7:7).eq.'B') then -! -! 1d beam element: generate MPC's -! - newnode=knor(indexk+1) - do idir=1,3 - idof=8*(newnode-1)+idir - call nident(ikmpc,idof,nmpc,id) - if((id.le.0).or.(ikmpc(id).ne.idof)) then - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - nodempc(1,mpcfree)=newnode - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - do k=2,4 - nodempc(1,mpcfree)=knor(indexk+k) - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - enddo - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-4.d0 - mpcfreenew=nodempc(3,mpcfree) - if(mpcfreenew.eq.0) then - write(*,*) - & '*ERROR in gen3dboun: increase nmpc_' - stop - endif - nodempc(3,mpcfree)=0 - mpcfree=mpcfreenew - endif -! - enddo - else -! -! 2d plane stress, plane strain or axisymmetric -! element: dependent node is replaced by new node in the middle -! -! keeping the old node and generating an additional MPC leads -! to problems since the old node is not restricted in the -! z-direction, only the new node in the middle is. If the old -! node is used subsequently in a contact spring element all -! its DOFs are used and the unrestricted z-DOF leads to a -! singular equation system -! -c write(*,*) ialset(l),' replaced by ',knor(indexk+2) - co(1,knor(indexk+2))=co(1,ialset(l)) - co(2,knor(indexk+2))=co(2,ialset(l)) - co(3,knor(indexk+2))=co(3,ialset(l)) - ialset(l)=knor(indexk+2) - endif - endif - enddo - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gen3dtemp.f calculix-ccx-2.3/ccx_2.1/src/gen3dtemp.f --- calculix-ccx-2.1/ccx_2.1/src/gen3dtemp.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gen3dtemp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,182 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gen3dtemp(iponoel,inoel,iponoelmax,kon,ipkon,lakon,ne, - & iponor,xnor,knor,t0,t1,thicke,offset,rig,nk,nk_,co,istep, - & ithermal,vold,mi) -! -! maps the temperatures and temperature gradients in 1-D and 2-D -! elements on their expanded counterparts -! - implicit none -! - character*8 lakon(*) -! - integer iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*),ne, - & iponor(2,*),knor(*),rig(*),i,i1,nk,nk_,i2,index,ielem,j, - & indexe,indexk,k,node,istep,ithermal,mi(2) -! - real*8 xnor(*),t0(*),t1(*),thicke(2,*),offset(2,*),co(3,*), - & vold(0:mi(2),*) -! -! initial conditions -! - if(istep.eq.1) then - do i=1,iponoelmax - i1=i+nk_ - i2=i+2*nk_ - index=iponoel(i) - do - if(index.eq.0) exit - ielem=inoel(1,index) - j=inoel(2,index) - indexe=ipkon(ielem) - indexk=iponor(2,indexe+j) - if((lakon(ielem)(7:7).eq.'E').or. - & (lakon(ielem)(7:7).eq.'A').or. - & (lakon(ielem)(7:7).eq.'S')) then - do k=1,3 - node=knor(indexk+k) - t0(node)=t0(i) - if(ithermal.gt.1) vold(0,node)=t0(node) - enddo - elseif(lakon(ielem)(7:7).eq.'L') then - node=knor(indexk+1) - t0(node)=t0(i) - & -t0(i1)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - node=knor(indexk+2) - t0(node)=t0(i) - if(ithermal.gt.1) vold(0,node)=t0(node) - node=knor(indexk+3) - t0(node)=t0(i) - & +t0(i1)*thicke(1,indexe+j)*(0.5d0-offset(1,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - elseif(lakon(ielem)(7:7).eq.'B') then - node=knor(indexk+1) - t0(node)=t0(i) - & -t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - & +t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - node=knor(indexk+2) - t0(node)=t0(i) - & -t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - & -t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - node=knor(indexk+3) - t0(node)=t0(i) - & +t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - & -t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - node=knor(indexk+4) - t0(node)=t0(i) - & +t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - & +t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - node=knor(indexk+5) - t0(node)=t0(i) - & -t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - node=knor(indexk+6) - t0(node)=t0(i) - & -t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - node=knor(indexk+7) - t0(node)=t0(i) - & +t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - node=knor(indexk+8) - t0(node)=t0(i) - & +t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - if(ithermal.gt.1) vold(0,node)=t0(node) - endif - if(rig(i).eq.0) exit - index=inoel(3,index) - enddo - enddo - endif -! -! temperature loading for mechanical calculations -! - if(ithermal.eq.1) then - do i=1,iponoelmax - i1=i+nk_ - i2=i+2*nk_ - index=iponoel(i) - do - if(index.eq.0) exit - ielem=inoel(1,index) - j=inoel(2,index) - indexe=ipkon(ielem) - indexk=iponor(2,indexe+j) - if((lakon(ielem)(7:7).eq.'E').or. - & (lakon(ielem)(7:7).eq.'A').or. - & (lakon(ielem)(7:7).eq.'S')) then - do k=1,3 - node=knor(indexk+k) - t1(node)=t1(i) - enddo - elseif(lakon(ielem)(7:7).eq.'L') then - node=knor(indexk+1) - t1(node)=t1(i) - & -t1(i1)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - node=knor(indexk+2) - t1(node)=t1(i) - node=knor(indexk+3) - t1(node)=t1(i) - & +t1(i1)*thicke(1,indexe+j)*(0.5d0-offset(1,ielem)) - elseif(lakon(ielem)(7:7).eq.'B') then - node=knor(indexk+1) - t1(node)=t1(i) - & -t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - & +t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - node=knor(indexk+2) - t1(node)=t1(i) - & -t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - & -t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - node=knor(indexk+3) - t1(node)=t1(i) - & +t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - & -t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - node=knor(indexk+4) - t1(node)=t1(i) - & +t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - & +t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - node=knor(indexk+5) - t1(node)=t1(i) - & -t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - node=knor(indexk+6) - t1(node)=t1(i) - & -t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - node=knor(indexk+7) - t1(node)=t1(i) - & +t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) - node=knor(indexk+8) - t1(node)=t1(i) - & +t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) - endif - if(rig(i).eq.0) exit - index=inoel(3,index) - enddo - enddo - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gencontelem.f calculix-ccx-2.3/ccx_2.1/src/gencontelem.f --- calculix-ccx-2.1/ccx_2.1/src/gencontelem.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gencontelem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,633 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gencontelem(tieset,ntie,itietri,ne,ipkon,kon, - & lakon,set,istartset,iendset,ialset,cg,straight,ifree, - & koncont,co,vold,xo,yo,zo,x,y,z,nx,ny,nz,nset,ielmat,cs, - & elcon,istep,iinc,iit,ncmat_,ntmat_,ifcont1,ifcont2,ne0, - & vini,nmethod,mi,imastop) -! -! generate contact elements for the slave contact nodes -! - implicit none -! - character*8 lakon(*) -c character*18 cfile - character*81 tieset(3,*),slavset,set(*) -! - integer ntie,nset,istartset(*),iendset(*),ialset(*),ifree, - & itietri(2,ntie),ipkon(*),kon(*),koncont(4,*),ne,node, - & neigh(1),nodeedge(2,10),iflag,kneigh,i,j,k,l,islav,isol, - & itri,ll,kflag,n,ipos,nx(*),ny(*),ipointer(10),istep,iinc, - & nz(*),nstart,ielmat(*),material,ifaceq(8,6),ifacet(6,4), - & ifacew1(4,5),ifacew2(8,5),nelem,jface,indexe,iit, - & nnodelem,nface,nope,nodef(8),ncmat_,ntmat_,ifcont1(*), - & ifcont2(*),ne0,ifaceref,isum,nmethod,mi(2),iteller, - & imastop(3,*), itriangle(100),ntriangle,ntriangle_,itriold, - & itrinew,id -! - real*8 cg(3,*),straight(16,*),co(3,*),vold(0:mi(2),*),p(3), - & totdist(10),dist,xo(*),yo(*),zo(*),x(*),y(*),z(*),cs(17,*), - & beta,c0,elcon(0:ncmat_,ntmat_,*),vini(0:mi(2),*) -! -! nodes per face for hex elements -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ -! -! nodes per face for tet elements -! - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ -! -! nodes per face for linear wedge elements -! - data ifacew1 /1,3,2,0, - & 4,5,6,0, - & 1,2,5,4, - & 2,3,6,5, - & 4,6,3,1/ -! -! nodes per face for quadratic wedge elements -! - data ifacew2 /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! - data iteller /0/ - save iteller -! -! maximum number of neighboring master triangles for a slave node -! - kflag=2 -! -! opening a file to store the contact spring elements -! -c iteller=iteller+1 -c cfile(1:18)='contactelem ' -c if(iteller.lt.10) then -c write(cfile(12:12),'(i1)') iteller -c cfile(13:16)='.inp' -c elseif(iteller.lt.100) then -c write(cfile(12:13),'(i2)') iteller -c cfile(14:17)='.inp' -c elseif(iteller.lt.1000) then -c write(cfile(12:14),'(i3)') iteller -c cfile(15:18)='.inp' -c else -c write(*,*) '*ERROR in gencontelem: more than 1000' -c write(*,*) ' contact element files' -c stop -c endif -c open(27,file=cfile,status='unknown') -! - do i=1,ntie - if(tieset(1,i)(81:81).ne.'C') cycle - iflag=0 - kneigh=1 - slavset=tieset(2,i) - material=int(cs(1,i)) -! -! determining the slave set -! - do j=1,nset - if(set(j).eq.slavset) exit - enddo - if(j.gt.nset) then - write(*,*) '*ERROR in gencontelem: contact slave set', - & slavset - write(*,*) ' does not exist' - stop - endif - islav=j -! - nstart=itietri(1,i)-1 - n=itietri(2,i)-nstart - if(n.lt.kneigh) kneigh=n - do j=1,n - xo(j)=cg(1,nstart+j) - x(j)=xo(j) - nx(j)=j - yo(j)=cg(2,nstart+j) - y(j)=yo(j) - ny(j)=j - zo(j)=cg(3,nstart+j) - z(j)=zo(j) - nz(j)=j - enddo - call dsort(x,nx,n,kflag) - call dsort(y,ny,n,kflag) - call dsort(z,nz,n,kflag) -! - do j=istartset(islav),iendset(islav) - if(ialset(j).gt.0) then -! - node=ialset(j) -! - do k=1,3 - p(k)=co(k,node)+vold(k,node) - enddo -! -! determining the kneigh neighboring master contact -! triangle centers of gravity -! - call near3d(xo,yo,zo,x,y,z,nx,ny,nz,p(1),p(2),p(3), - & n,neigh,kneigh) -! - isol=0 -! - itriold=0 - itri=neigh(1)+itietri(1,i)-1 - ntriangle=0 - ntriangle_=100 -! - loop1: do - do l=1,3 - ll=4*l-3 - dist=straight(ll,itri)*p(1)+ - & straight(ll+1,itri)*p(2)+ - & straight(ll+2,itri)*p(3)+ - & straight(ll+3,itri) -c if(dist.gt.0.d0) then - if(dist.gt.1.d-6) then - itrinew=imastop(l,itri) - if(itrinew.eq.0) then -c write(*,*) '**border reached' - exit loop1 - elseif(itrinew.eq.itriold) then -c write(*,*) '**solution in between triangles' - isol=itri - exit loop1 - else - call nident(itriangle,itrinew,ntriangle,id) - if(id.gt.0) then - if(itriangle(id).eq.itrinew) then -c write(*,*) '**circular path; no solution' - exit loop1 - endif - endif - ntriangle=ntriangle+1 - if(ntriangle.gt.ntriangle_) then -c write(*,*) '**too many iterations' - exit loop1 - endif - do k=ntriangle,id+2,-1 - itriangle(k)=itriangle(k-1) - enddo - itriangle(id+1)=itrinew - itriold=itri - itri=itrinew - cycle loop1 - endif - elseif(l.eq.3) then -c write(*,*) '**regular solution' - isol=itri - exit loop1 - endif - enddo - enddo loop1 -! -c do k=1,kneigh -c itri=neigh(k)+itietri(1,i)-1 -c! -c ipos=0 -c totdist(k)=0.d0 -c nodeedge(1,k)=0 -c nodeedge(2,k)=0 -c! -c do l=1,3 -c ll=4*l-3 -c dist=straight(ll,itri)*p(1)+ -c & straight(ll+1,itri)*p(2)+ -c & straight(ll+2,itri)*p(3)+ -c & straight(ll+3,itri) -c if(dist.gt.0.d0) then -c totdist(k)=totdist(k)+dist -c if(ipos.eq.0) then -c nodeedge(1,k)=koncont(l,itri) -c if(l.ne.3) then -c nodeedge(2,k)=koncont(l+1,itri) -c else -c nodeedge(2,k)=koncont(1,itri) -c endif -c else -c if((nodeedge(1,k).eq.koncont(l,itri)).or. -c & (nodeedge(2,k).eq.koncont(l,itri)))then -c nodeedge(1,k)=koncont(l,itri) -c nodeedge(2,k)=0 -c else -c if(l.ne.3) then -c nodeedge(1,k)=koncont(l+1,itri) -c else -c nodeedge(1,k)=koncont(1,itri) -c endif -c endif -c endif -c ipos=ipos+1 -c endif -c enddo -c! -c if(totdist(k).le.0.d0) then -c isol=k -c exit -c endif -c enddo -c! -c! if no independent face was found, a small -c! tolerance is applied -c! -c if(isol.eq.0) then -c do k=1,kneigh -c ipointer(k)=neigh(k)+itietri(1,i)-1 -c enddo -c call dsort(totdist,ipointer,kneigh,kflag) -c do k=1,kneigh -c itri=ipointer(k) -c dist=dabs(straight(1,itri)*cg(1,itri)+ -c & straight(2,itri)*cg(2,itri)+ -c & straight(3,itri)*cg(3,itri)+ -c & straight(4,itri)) -c if(totdist(k).lt.1.d-3*dist) then -c isol=k -c exit -c endif -c enddo -c endif -! -! check whether distance is larger than c0: -! no element is generated -! - if(isol.ne.0) then - dist=straight(13,itri)*p(1)+ - & straight(14,itri)*p(2)+ - & straight(15,itri)*p(3)+ - & straight(16,itri) - beta=elcon(1,1,material) - if(beta.gt.0.d0) then - c0=dlog(100.d0)/beta - else - c0=0.d0 - endif - if(dist.gt.c0) then - isol=0 -! -! adjusting the bodies at the start of the -! calculation such that they touch -! - elseif((istep.eq.1).and.(iinc.eq.1).and. - & (iit.le.0).and.(dist.lt.0.d0).and. - & (nmethod.eq.1)) then - do k=1,3 - vold(k,node)=vold(k,node)- - & dist*straight(12+k,itri) - vini(k,node)=vold(k,node) - enddo - endif - endif -! - if(isol.eq.0) then -! -! no independent face was found: no spring -! element is generated -! - else -! -! plane spring -! - ne=ne+1 - ipkon(ne)=ifree - lakon(ne)='ESPRNGC ' - ielmat(ne)=material - nelem=int(koncont(4,itri)/10.d0) - jface=koncont(4,itri)-10*nelem -! -! storing the face in ifcont1 and the -! element number in ifcont2 -! - ifcont1(ne-ne0)=koncont(4,itri) - ifcont2(ne-ne0)=ne -! - indexe=ipkon(nelem) - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(4:4).eq.'8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.4) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacet(k,jface)) - enddo - elseif(nface.eq.5) then - if(nope.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew1(k,jface)) - enddo - elseif(nope.eq.15) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew2(k,jface)) - enddo - endif - elseif(nface.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifaceq(k,jface)) - enddo - endif -! - do k=1,nnodelem - kon(ifree+k)=nodef(k) - enddo - ifree=ifree+nnodelem+1 - kon(ifree)=node - ifree=ifree+1 -! - write(lakon(ne)(8:8),'(i1)') nnodelem+1 -c write(*,*) 'new elem',ne,(nodef(k),k=1,nnodelem),node - if((nnodelem.eq.3).or.(nnodelem.eq.6)) then -c write(27,100) -c 100 format('*ELEMENT,TYPE=C3D4') -c write(27,*) ne,',',nodef(1),',',nodef(2),',', -c & nodef(3),',',node - else -c write(27,101) -c 101 format('*ELEMENT,TYPE=C3D6') -c write(27,*) ne,',',nodef(2),',',node,',',nodef(3), -c & ',',nodef(1),',',node,',',nodef(4) - endif - endif -! - else - node=ialset(j-2) - do - node=node-ialset(j) - if(node.ge.ialset(j-1)) exit -! - do k=1,3 - p(k)=co(k,node)+vold(k,node) - enddo -! -! determining the kneigh neighboring master contact -! triangle centers of gravity -! - call near3d(xo,yo,zo,x,y,z,nx,ny,nz,p(1),p(2),p(3), - & n,neigh,kneigh) -! - isol=0 -! - do k=1,kneigh - itri=neigh(k)+itietri(1,i)-1 -! - ipos=0 - totdist(k)=0.d0 - nodeedge(1,k)=0 - nodeedge(2,k)=0 -! - do l=1,3 - ll=4*l-3 - dist=straight(ll,itri)*p(1)+ - & straight(ll+1,itri)*p(2)+ - & straight(ll+2,itri)*p(3)+ - & straight(ll+3,itri) - if(dist.gt.0.d0) then - totdist(k)=totdist(k)+dist - if(ipos.eq.0) then - nodeedge(1,k)=koncont(l,itri) - if(l.ne.3) then - nodeedge(2,k)=koncont(l+1,itri) - else - nodeedge(2,k)=koncont(1,itri) - endif - else - if((nodeedge(1,k).eq.koncont(l,itri)).or. - & (nodeedge(2,k).eq.koncont(l,itri)))then - nodeedge(1,k)=koncont(l,itri) - nodeedge(2,k)=0 - else - if(l.ne.3) then - nodeedge(1,k)=koncont(l+1,itri) - else - nodeedge(1,k)=koncont(1,itri) - endif - endif - endif - ipos=ipos+1 - endif - enddo -! - if(totdist(k).le.0.d0) then - isol=k - exit - endif - enddo -! -! if no independent face was found, a small -! tolerance is applied -! - if(isol.eq.0) then - do k=1,kneigh - ipointer(k)=neigh(k)+itietri(1,i)-1 - enddo - call dsort(totdist,ipointer,kneigh,kflag) - do k=1,kneigh - itri=ipointer(k) - dist=straight(1,itri)*cg(1,itri)+ - & straight(2,itri)*cg(2,itri)+ - & straight(3,itri)*cg(3,itri)+ - & straight(4,itri) - if(totdist(k).lt.1.d-3*dist) then - isol=k - exit - endif - enddo - endif -! - if(isol.eq.0) then - else -! -! plane spring -! - ne=ne+1 - ipkon(ne)=ifree - lakon(ne)='ESPRNGC ' - ielmat(ne)=material - nelem=int(koncont(4,itri)/10.d0) - jface=koncont(4,itri)-10*nelem -! -! storing the face in ifcont1 and the -! element number in ifcont2 -! - ifcont1(ne-ne0)=koncont(4,itri) - ifcont2(ne-ne0)=ne -! - indexe=ipkon(nelem) - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(4:4).eq.'8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.4) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacet(k,jface)) - enddo - elseif(nface.eq.5) then - if(nope.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew1(k,jface)) - enddo - elseif(nope.eq.15) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew2(k,jface)) - enddo - endif - elseif(nface.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifaceq(k,jface)) - enddo - endif -! - do k=1,nnodelem - kon(ifree+k)=nodef(k) - enddo - ifree=ifree+nnodelem+1 - kon(ifree)=node - ifree=ifree+1 - write(lakon(ne)(8:8),'(i1)') nnodelem+1 -c write(*,*) 'new elem',ne,(nodef(k),k=1,nnodelem),node - endif -! - enddo - endif - enddo - enddo -! -! sorting all used independent faces -! - n=ne-ne0 - call isortii(ifcont1,ifcont2,n,kflag) -! -! replace the faces by the number of times they were used in -! contact spring elements -! - i=1 - loop: do - ifaceref=ifcont1(i) - isum=1 - j=i+1 - if(j.gt.ne-ne0) exit loop - do - if(ifcont1(j).eq.ifaceref) then - isum=isum+1 - j=j+1 - if(j.gt.ne-ne0) exit loop - cycle - else - do k=i,j-1 - ifcont1(k)=isum - enddo - i=j - exit - endif - enddo - enddo loop - do k=i,j-1 - ifcont1(k)=isum - enddo -! -! sorting in the original order -! - call isortii(ifcont2,ifcont1,n,kflag) -! -! storing the number of dependent nodes as last entry -! in the topology -! - do i=ne0+1,ne - read(lakon(i)(8:8),'(i1)') nope - kon(ipkon(i)+nope+1)=ifcont1(i-ne0) -c write(*,*) 'gencontelem',i,ifcont1(i-ne0) - enddo -! -c close(27) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gencontmpc.c calculix-ccx-2.3/ccx_2.1/src/gencontmpc.c --- calculix-ccx-2.1/ccx_2.1/src/gencontmpc.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gencontmpc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,676 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -void gencontmpc(int *ne, int *ne0, char *lakon, int *ipkon, int *kon, - int *nmpc, int **ikmpcp, int **ilmpcp, int **ipompcp, - int *mpcfree, - double **fmpcp, char **labmpcp, int **nodempcp, int *memmpc_, - double **coefmpcp, int *nmpc_, int *ikboun, int *nboun){ - - /* creates contact MPC's for the middle nodes of the - dependent surface*/ - - char *labmpc=NULL,lakonl[9]=" \0"; - - int *iactdep=NULL,*idummy=NULL,nactdep,i,j,k,nope,indexe,kflag, - node,id,idir,idof,node1,node2,index,*ipompc=NULL,*ikmpc=NULL, - *ilmpc=NULL,*nodempc=NULL; - - int nonei6[9]={7,13,14,8,14,15,9,15,13}; - - int nonei8[12]={9,17,18,10,18,19,11,19,20,12,20,17}; - - int nonei10[18]={5,1,2,6,2,3,7,3,1,8,1,4,9,2,4,10,3,4}; - - int nonei15[27]={7,1,2,8,2,3,9,3,1,10,4,5,11,5,6,12,6,4, - 13,1,4,14,2,5,15,3,6}; - - int nonei20[36]={9,1,2,10,2,3,11,3,4,12,4,1, - 13,5,6,14,6,7,15,7,8,16,8,5, - 17,1,5,18,2,6,19,3,7,20,4,8}; - - double *fmpc=NULL, *coefmpc=NULL; - - ipompc=*ipompcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; - fmpc=*fmpcp;nodempc=*nodempcp;coefmpc=*coefmpcp; - - /* storing all active dependent nodes in a set */ - - nactdep=*ne-(*ne0); - iactdep=NNEW(int,nactdep); - - j=0; - for(i=*ne0;i<*ne;i++){ - for(k=0;k<8;k++){lakonl[k]=lakon[8*i+k];} - nope=atoi(&lakonl[7]); - indexe=ipkon[i]; - iactdep[j]=kon[indexe+nope-1]; - j++; - } - - /* sorting the active dependent nodes */ - - kflag=1; - FORTRAN(isortii,(iactdep,idummy,&nactdep,&kflag)); - - /* determining which nodes are middle nodes */ - - for(i=0;i<*ne0;i++){ - indexe=ipkon[i]; - if(indexe<0) continue; - if(strcmp1(&lakon[8*i+3],"2")==0){ - if(strcmp1(&lakon[8*i+6]," ")==0){ - - /* genuine 20-node element */ - - for(j=8;j<20;j++){ - node=kon[indexe+j]; - FORTRAN(nident,(iactdep,&node,&nactdep,&id)); - if(id>0){ - if(iactdep[id-1]==node){ - - /* create a MPC between node and the - corresponding end nodes */ - - node1=kon[indexe+nonei20[(j-8)*3+1]-1]; - node2=kon[indexe+nonei20[(j-8)*3+2]-1]; - - /* create a MPC between node, node1 and node2 */ - - for(idir=1;idir<4;idir++){ - idof=8*(node-1)+idir; - FORTRAN(nident,(ikboun,&idof,nboun,&id)); - if(id>0){ - if(ikboun[id-1]==idof)continue; - } - FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); - if(id>0){ - if(ikmpc[id-1]==idof)continue; - } - (*nmpc)++; - if(*nmpc>*nmpc_){ - if(*nmpc_<11)*nmpc_=11; - *nmpc_=(int)(1.1**nmpc_); - RENEW(ipompc,int,*nmpc_); - RENEW(labmpc,char,20**nmpc_+1); - RENEW(ikmpc,int,*nmpc_); - RENEW(ilmpc,int,*nmpc_); - RENEW(fmpc,double,*nmpc_); - } - ipompc[*nmpc-1]=*mpcfree; - strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); - for(k=*nmpc-1;k>id;k--){ - ikmpc[k]=ikmpc[k-1]; - ilmpc[k]=ilmpc[k-1]; - } - ikmpc[id]=idof; - ilmpc[id]=*nmpc; - - /* first term */ - - nodempc[3**mpcfree-3]=node; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=2.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* second term */ - - nodempc[3**mpcfree-3]=node1; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* third term */ - - nodempc[3**mpcfree-3]=node2; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - nodempc[3*index-1]=0; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - } /* idir */ - } - } - } /* j */ - - }else if(strcmp1(&lakon[8*i+6],"B")!=0){ - - /* plane strain, plane stress, axisymmetric elements - or shell elements */ - - for(j=8;j<12;j++){ - node=(kon[indexe+j]+kon[indexe+j+4])/2; - FORTRAN(nident,(iactdep,&node,&nactdep,&id)); - if(id>0){ - if(iactdep[id-1]==node){ - - /* create a MPC between node and the - corresponding end nodes */ - - node1=kon[indexe+nonei8[(j-8)*3+1]-1]; - node2=kon[indexe+nonei8[(j-8)*3+2]-1]; - - /* create a MPC between node, node1 and node2 */ - - for(idir=1;idir<3;idir++){ - idof=8*(node-1)+idir; - FORTRAN(nident,(ikboun,&idof,nboun,&id)); - if(id>0){ - if(ikboun[id-1]==idof)continue; - } - FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); - if(id>0){ - if(ikmpc[id-1]==idof)continue; - } - (*nmpc)++; - if(*nmpc>*nmpc_){ - if(*nmpc_<11)*nmpc_=11; - *nmpc_=(int)(1.1**nmpc_); - RENEW(ipompc,int,*nmpc_); - RENEW(labmpc,char,20**nmpc_+1); - RENEW(ikmpc,int,*nmpc_); - RENEW(ilmpc,int,*nmpc_); - RENEW(fmpc,double,*nmpc_); - } - ipompc[*nmpc-1]=*mpcfree; - strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); - for(k=*nmpc-1;k>id;k--){ - ikmpc[k]=ikmpc[k-1]; - ilmpc[k]=ilmpc[k-1]; - } - ikmpc[id]=idof; - ilmpc[id]=*nmpc; - - /* first term */ - - nodempc[3**mpcfree-3]=node; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=2.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* second term */ - - nodempc[3**mpcfree-3]=node1; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* third term */ - - nodempc[3**mpcfree-3]=node2; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - nodempc[3*index-1]=0; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - } /* idir */ - } - } - } /* j */ - - } - - }else if(strcmp1(&lakon[8*i+3],"15")==0){ - - if(strcmp1(&lakon[8*i+6]," ")==0){ - - /* genuine 15-node element */ - - for(j=6;j<15;j++){ - node=kon[indexe+j]; - FORTRAN(nident,(iactdep,&node,&nactdep,&id)); - if(id>0){ - if(iactdep[id-1]==node){ - - /* create a MPC between node and the - corresponding end nodes */ - - node1=kon[indexe+nonei15[(j-6)*3+1]-1]; - node2=kon[indexe+nonei15[(j-6)*3+2]-1]; - - /* create a MPC between node, node1 and node2 */ - - for(idir=1;idir<4;idir++){ - idof=8*(node-1)+idir; - FORTRAN(nident,(ikboun,&idof,nboun,&id)); - if(id>0){ - if(ikboun[id-1]==idof)continue; - } - FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); - if(id>0){ - if(ikmpc[id-1]==idof)continue; - } - (*nmpc)++; - if(*nmpc>*nmpc_){ - if(*nmpc_<11)*nmpc_=11; - *nmpc_=(int)(1.1**nmpc_); - RENEW(ipompc,int,*nmpc_); - RENEW(labmpc,char,20**nmpc_+1); - RENEW(ikmpc,int,*nmpc_); - RENEW(ilmpc,int,*nmpc_); - RENEW(fmpc,double,*nmpc_); - } - ipompc[*nmpc-1]=*mpcfree; - strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); - for(k=*nmpc-1;k>id;k--){ - ikmpc[k]=ikmpc[k-1]; - ilmpc[k]=ilmpc[k-1]; - } - ikmpc[id]=idof; - ilmpc[id]=*nmpc; - - /* first term */ - - nodempc[3**mpcfree-3]=node; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=2.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* second term */ - - nodempc[3**mpcfree-3]=node1; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* third term */ - - nodempc[3**mpcfree-3]=node2; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - nodempc[3*index-1]=0; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - } /* idir */ - } - } - } /* j */ - - }else if(strcmp1(&lakon[8*i+6],"B")!=0){ - - /* plane strain, plane stress, axisymmetric elements - or shell elements */ - - for(j=6;j<9;j++){ - node=(kon[indexe+j]+kon[indexe+j+3])/2; - FORTRAN(nident,(iactdep,&node,&nactdep,&id)); - if(id>0){ - if(iactdep[id-1]==node){ - - /* create a MPC between node and the - corresponding end nodes */ - - node1=kon[indexe+nonei6[(j-6)*3+1]-1]; - node2=kon[indexe+nonei6[(j-6)*3+2]-1]; - - /* create a MPC between node, node1 and node2 */ - - for(idir=1;idir<3;idir++){ - idof=8*(node-1)+idir; - FORTRAN(nident,(ikboun,&idof,nboun,&id)); - if(id>0){ - if(ikboun[id-1]==idof)continue; - } - FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); - if(id>0){ - if(ikmpc[id-1]==idof)continue; - } - (*nmpc)++; - if(*nmpc>*nmpc_){ - if(*nmpc_<11)*nmpc_=11; - *nmpc_=(int)(1.1**nmpc_); - RENEW(ipompc,int,*nmpc_); - RENEW(labmpc,char,20**nmpc_+1); - RENEW(ikmpc,int,*nmpc_); - RENEW(ilmpc,int,*nmpc_); - RENEW(fmpc,double,*nmpc_); - } - ipompc[*nmpc-1]=*mpcfree; - strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); - for(k=*nmpc-1;k>id;k--){ - ikmpc[k]=ikmpc[k-1]; - ilmpc[k]=ilmpc[k-1]; - } - ikmpc[id]=idof; - ilmpc[id]=*nmpc; - - /* first term */ - - nodempc[3**mpcfree-3]=node; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=2.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* second term */ - - nodempc[3**mpcfree-3]=node1; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* third term */ - - nodempc[3**mpcfree-3]=node2; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - nodempc[3*index-1]=0; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - } /* idir */ - } - } - } /* j */ - - } - - }else if(strcmp1(&lakon[8*i+3],"10")==0){ - - /* genuine 10-node element */ - - for(j=4;j<10;j++){ - node=kon[indexe+j]; - FORTRAN(nident,(iactdep,&node,&nactdep,&id)); - if(id>0){ - if(iactdep[id-1]==node){ - - /* create a MPC between node and the - corresponding end nodes */ - - node1=kon[indexe+nonei10[(j-4)*3+1]-1]; - node2=kon[indexe+nonei10[(j-4)*3+2]-1]; - - /* create a MPC between node, node1 and node2 */ - - for(idir=1;idir<4;idir++){ - idof=8*(node-1)+idir; - FORTRAN(nident,(ikboun,&idof,nboun,&id)); - if(id>0){ - if(ikboun[id-1]==idof)continue; - } - FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); - if(id>0){ - if(ikmpc[id-1]==idof)continue; - } - (*nmpc)++; - if(*nmpc>*nmpc_){ - if(*nmpc_<11)*nmpc_=11; - *nmpc_=(int)(1.1**nmpc_); - RENEW(ipompc,int,*nmpc_); - RENEW(labmpc,char,20**nmpc_+1); - RENEW(ikmpc,int,*nmpc_); - RENEW(ilmpc,int,*nmpc_); - RENEW(fmpc,double,*nmpc_); - } - ipompc[*nmpc-1]=*mpcfree; - strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); - for(k=*nmpc-1;k>id;k--){ - ikmpc[k]=ikmpc[k-1]; - ilmpc[k]=ilmpc[k-1]; - } - ikmpc[id]=idof; - ilmpc[id]=*nmpc; - - /* first term */ - - nodempc[3**mpcfree-3]=node; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=2.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* second term */ - - nodempc[3**mpcfree-3]=node1; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - nodempc[3*index-1]=*mpcfree; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - - /* third term */ - - nodempc[3**mpcfree-3]=node2; - nodempc[3**mpcfree-2]=idir; - coefmpc[*mpcfree-1]=-1.; - index=*mpcfree; - *mpcfree=nodempc[3**mpcfree-1]; - nodempc[3*index-1]=0; - if(*mpcfree==0){ - *mpcfree=*memmpc_+1; - if(*memmpc_<11)*memmpc_=11; - *memmpc_=(int)(1.1**memmpc_); - printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=*mpcfree;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - } - } /* idir */ - } - } - } /* j */ - - } - - } /* i */ - - RENEW(ipompc,int,*nmpc); - RENEW(labmpc,char,20**nmpc+1); - RENEW(ikmpc,int,*nmpc); - RENEW(ilmpc,int,*nmpc); - RENEW(fmpc,double,*nmpc); - - *ipompcp=ipompc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; - *fmpcp=fmpc;*nodempcp=nodempc;*coefmpcp=coefmpc; - - return; - -} - diff -Nru calculix-ccx-2.1/ccx_2.1/src/gencontrel.f calculix-ccx-2.3/ccx_2.1/src/gencontrel.f --- calculix-ccx-2.1/ccx_2.1/src/gencontrel.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gencontrel.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1090 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gencontrel(tieset,ntie,itietri,ipkon,kon, - & lakon,set,cg,straight,ifree, - & koncont,co,vold,xo,yo,zo,x,y,z,nx,ny,nz,nset,cs, - & elcon,istep,iinc,iit,ncmat_,ntmat_, - & vini,nmethod,islavsurf,imastsurf,pmastsurf,itiefac, - & islavnode,nslavnode,slavnor,slavtan,imastop,gapmints, - & islavact,mi,ncont,ipe,ime,pslavsurf,pslavdual) -! -! Calculating the normals and tangential vectors in the nodes of -! the slave surface (slavnor, slavtan) -! Determining the locations on the master surface opposite and -! and locally orthogonal to the integration points on the slave -! surface (imastsurf, pmastsurf) -! -! Author: Li, Yang; Rakotonanahary, Samoela; -! - implicit none -! - character*1 c - character*3 m11,m2,m3 - integer one,number_of_nodes -! - character*5 p0,p1,p2,p3,p7,p9999 - character*8 lakon(*) - character*81 tieset(3,*),slavset,set(*) -! - integer ntie,nset,ifree,imastop(3,*),kmax(3),ncont, - & itietri(2,ntie),ipkon(*),kon(*),koncont(4,*),node, - & neigh(10),nodeedge(2,10),iflag,kneigh,i,j,k,l,islav,isol, - & itri,kflag,n,ipos,nx(*),ny(*),ipointer(10),istep,iinc, - & nz(*),nstart,ifaceq(8,6),ifacet(6,4),index1,ifreeintersec, - & ifacew1(4,5),ifacew2(8,5),nelem,jface,indexe,iit,ncmat_,ntmat_, - & nnodelem,nface,nope,nodef(8),m1,km1,km2,km3,number, - & nmethod,islavsurf(2,*),islavnode(*),nslavnode(ntie+1), - & imastsurf(*),itiefac(2,*),ifaces,nelems,jfaces,mi(2), - & mint2d,m,jj,nopes,konl(20),id,islavact(*),indexnode(8), - & itria(4),ntria,itriacorner(4,10),inodesin(3*ncont),line, - & nnodesin,inodesout(3*ncont),nnodesout,iactiveline(3,3*ncont), - & nactiveline,intersec(2,6*ncont),ipe(*),ime(4,*),nintpoint,k1,j1, - & ipiv(4),info,pnt -! - real*8 cg(3,*),straight(16,*),co(3,*),vold(0:mi(2),*),p(3), - & ratio(9),xntersec(3,6*ncont), - & totdist(10),dist,xo(*),yo(*),zo(*),x(*),y(*),z(*),cs(17,*), - & beta,c0,elcon(0:ncmat_,ntmat_,*),vini(0:mi(2),*),pmastsurf(2,*), - & pneigh(3,8),et,xi,weight,xl2(3,8),xsj2(3),shp2(7,8), - & xs2(3,2),slavnor(3,*),slavtan(6,*), xquad(2,8), xtri(2,6),dd, - & al,al1,al2,xn(3),s(3),xnabs(3),gapmints(*),slavstraight(20), - & pslavdual(16,*),diag_els(4),m_els(10),contribution,work(4) -! -c real*8 pslavsurf(2,10000) - real*8 pslavsurf(3,*),err,rand,pnodesin(3,3*ncont) - integer tc,ntric,ltric(10),r1,ik -! - include "gauss.f" -! -! nodes per face for hex elements -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ -! -! nodes per face for tet elements -! - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ -! -! nodes per face for linear wedge elements -! - data ifacew1 /1,3,2,0, - & 4,5,6,0, - & 1,2,5,4, - & 2,3,6,5, - & 4,6,3,1/ -! -! nodes per face for quadratic wedge elements -! - data ifacew2 /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! - data iflag /2/ -! -! new added data for the local coodinates for nodes -! - data xquad /-1, -1, - & 1, -1, - & 1, 1, - & -1, 1, - & 0, -1, - & 1, 0, - & 0, 1, - & -1, 0/ -! - data xtri /0, 0, - & 1, 0, - & 0, 1, - & 0.5, 0, - & 0.5, 0.5, - & 0, 0.5/ -! -! maximum number of neighboring master triangles for a slave node -! - kflag=2 - ifree = 0 -! -! - err=1d-6 -c CALL time(r1) -c CALL srand(REAL(MOD(r1,1000))) -! - open(70,file='contact.frd',status='unknown') - c='C' - m11=' -1' - m2=' -2' - m3=' -3' - p0=' 0' - p1=' 1' - p2=' 2' - p3=' 3' - p7=' 7' - p9999=' 9999' - one=1 - write(70,'(a5,a1)') p1,c - write(70,'(a5,a1,67x,i1)') p2,c,one - number_of_nodes=0 - do i=1,itietri(2,ntie) - number_of_nodes=max(number_of_nodes,koncont(1,i)) - number_of_nodes=max(number_of_nodes,koncont(2,i)) - number_of_nodes=max(number_of_nodes,koncont(3,i)) - enddo - do i=1,number_of_nodes - write(70,'(a3,i10,1p,3e12.5)') m11,i,(co(j,i),j=1,3) - enddo - write(70,'(a3)') m3 - write(70,'(a5,a1,67x,i1)') p3,c,one - do i=1,itietri(2,ntie) - write(70,'(a3,i10,2a5)')m11,i,p7,p0 - write(70,'(a3,3i10)') m2,(koncont(j,i),j=1,3) - enddo - write(70,'(a3)') m3 - write(70,'(a5)') p9999 - close(70) -! -! initialization of intersec -! - ifreeintersec=0 - do i=1,3*ncont - iactiveline(3,i)=0 - iactiveline(2,i)=0 - iactiveline(1,i)=0 - enddo - - do i=1,6*ncont-1 - intersec(2,i)=i+1 - enddo - intersec(2,6*ncont)=0 -! - do i=1,ntie - if(tieset(1,i)(81:81).ne.'C') cycle - kneigh=10 -! - slavset=tieset(2,i) - ipos=index(slavset,' ') - if(slavset(ipos-1:ipos-1).eq.'S') cycle -! -! determining the slave set -! - do j=1,nset - if(set(j).eq.slavset) exit - enddo - if(j.gt.nset) then - write(*,*) '*ERROR in gencontrel: contact slave set', - & slavset - write(*,*) ' does not exist' - stop - endif - islav=j -! - nstart=itietri(1,i)-1 - n=itietri(2,i)-nstart -c write(*,*) 'gencontrel ',kneigh,n - if(n.lt.kneigh) kneigh=n - do j=1,n - xo(j)=cg(1,nstart+j) - x(j)=xo(j) - nx(j)=j - yo(j)=cg(2,nstart+j) - y(j)=yo(j) - ny(j)=j - zo(j)=cg(3,nstart+j) - z(j)=zo(j) - nz(j)=j - enddo - call dsort(x,nx,n,kflag) - call dsort(y,ny,n,kflag) - call dsort(z,nz,n,kflag) -! - do l = itiefac(1,i), itiefac(2,i) - ifaces = islavsurf(1,l) - nelems = int(ifaces/10) - jfaces = ifaces - nelems*10 -! -! initialization for Dualshape Coefficient matrix -! - pnt=0 - do k=1,4 - diag_els(k)=0.0 - do j=k,4 - pnt=pnt+1 - m_els(pnt)=0.0 - enddo - enddo -! -! Decide the max integration points number, just consider 2D situation -! - if(lakon(nelems)(4:5).eq.'8R') then - mint2d=1 - nopes=4 - nope=8 - elseif(lakon(nelems)(4:4).eq.'8') then - mint2d=4 - nopes=4 - nope=8 - elseif(lakon(nelems)(4:6).eq.'20R') then - mint2d=4 - nopes=8 - nope=20 - elseif(lakon(nelems)(4:4).eq.'2') then - mint2d=9 - nopes=8 - nope=20 - elseif(lakon(nelems)(4:5).eq.'10') then - mint2d=3 - nopes=6 - nope=10 - elseif(lakon(nelems)(4:4).eq.'4') then - mint2d=1 - nopes=3 - nope=4 -! -! treatment of wedge faces -! - elseif(lakon(nelems)(4:4).eq.'6') then - mint2d=1 - nope=6 - if(jfaces.le.2) then - nopes=3 - else - nopes=4 - endif - elseif(lakon(nelems)(4:5).eq.'15') then - nope=15 - if(jfaces.le.2) then - mint2d=3 - nopes=6 - else - mint2d=4 - nopes=8 - endif - endif -! -! actual position of the nodes belonging to the -! slave surface -! - do j=1,nope - konl(j)=kon(ipkon(nelems)+j) - enddo -! - if((nope.eq.20).or.(nope.eq.8)) then - do m=1,nopes - do j=1,3 - xl2(j,m)=co(j,konl(ifaceq(m,jfaces)))+ - & vold(j,konl(ifaceq(m,jfaces))) - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - do m=1,nopes - do j=1,3 - xl2(j,m)=co(j,konl(ifacet(m,jfaces)))+ - & vold(j,konl(ifacet(m,jfaces))) - enddo - enddo - else - do m=1,nopes - do j=1,3 - xl2(j,m)=co(j,konl(ifacew1(m,jfaces)))+ - & vold(j,konl(ifacew1(m,jfaces))) - enddo - enddo - endif - -! calculate the normal vector in the nodes belonging to the slave surface -! - if(nopes.eq.8) then - do m = 1, nopes - xi = xquad(1,m) - et = xquad(2,m) - call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) - dd = dsqrt(xsj2(1)*xsj2(1) + xsj2(2)*xsj2(2) - & + xsj2(3)*xsj2(3)) - xsj2(1) = xsj2(1)/dd - xsj2(2) = xsj2(2)/dd - xsj2(3) = xsj2(3)/dd -! - if(nope.eq.20) then - node = konl(ifaceq(m,jfaces)) - elseif(nope.eq.15) then - node=konl(ifacew2(m,jfaces)) - endif -! - call nident(islavnode(nslavnode(i)+1), node, - & nslavnode(i+1)-nslavnode(i), id) - index1=nslavnode(i)+id - indexnode(m)=index1 - slavnor(1,index1) = slavnor(1,index1) - & +xsj2(1) - slavnor(2,index1) = slavnor(2,index1) - & +xsj2(2) - slavnor(3,index1) = slavnor(3,index1) - & +xsj2(3) - enddo - elseif(nopes.eq.4) then - do m = 1, nopes - xi = xquad(1,m) - et = xquad(2,m) - call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) - dd = dsqrt(xsj2(1)*xsj2(1) + xsj2(2)*xsj2(2) - & + xsj2(3)*xsj2(3)) - xsj2(1) = xsj2(1)/dd - xsj2(2) = xsj2(2)/dd - xsj2(3) = xsj2(3)/dd -! - if(nope.eq.8) then - node = konl(ifaceq(m,jfaces)) - elseif(nope.eq.6) then - node=konl(ifacew1(m,jfaces)) - endif -! - call nident(islavnode(nslavnode(i)+1), node, - & nslavnode(i+1)-nslavnode(i), id) -! - index1=nslavnode(i)+id - indexnode(m)=index1 - slavnor(1,index1) = slavnor(1,index1) - & +xsj2(1) - slavnor(2,index1) = slavnor(2,index1) - & +xsj2(2) - slavnor(3,index1) = slavnor(3,index1) - & +xsj2(3) - enddo - elseif(nopes.eq.6) then - do m = 1, nopes - xi = xquad(1,m) - et = xquad(2,m) - call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - dd = dsqrt(xsj2(1)*xsj2(1) + xsj2(2)*xsj2(2) - & + xsj2(3)*xsj2(3)) - xsj2(1) = xsj2(1)/dd - xsj2(2) = xsj2(2)/dd - xsj2(3) = xsj2(3)/dd -! - if(nope.eq.10) then - node = konl(ifacet(m,jfaces)) - elseif(nope.eq.15) then - node = konl(ifacew2(m,jfaces)) - endif -! - call nident(islavnode(nslavnode(i)+1), node, - & nslavnode(i+1)-nslavnode(i), id) - index1=nslavnode(i)+id - indexnode(m)=index1 - slavnor(1,index1) = slavnor(1,index1) - & +xsj2(1) - slavnor(2,index1) = slavnor(2,index1) - & +xsj2(2) - slavnor(3,index1) = slavnor(3,index1) - & +xsj2(3) - enddo - else - do m = 1, nopes - xi = xquad(1,m) - et = xquad(2,m) - call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - dd = dsqrt(xsj2(1)*xsj2(1) + xsj2(2)*xsj2(2) - & + xsj2(3)*xsj2(3)) - xsj2(1) = xsj2(1)/dd - xsj2(2) = xsj2(2)/dd - xsj2(3) = xsj2(3)/dd -! - if(nope.eq.6) then - node = konl(ifacew1(m,jfaces)) - elseif(nope.eq.4) then - node = konl(ifacet(m,jfaces)) - endif -! - call nident(islavnode(nslavnode(i)+1), node, - & nslavnode(i+1)-nslavnode(i), id) - index1=nslavnode(i)+id - indexnode(m)=index1 - slavnor(1,nslavnode(i)+id) = slavnor(1,index1) - & +xsj2(1) - slavnor(2,nslavnode(i)+id) = slavnor(2,index1) - & +xsj2(2) - slavnor(3,nslavnode(i)+id) = slavnor(3,index1) - & +xsj2(3) - enddo - endif -! -! determining the gap contribution of the integration points -! and the coefficient for the slave dualshape functions -! -! - do m = 1,mint2d - ifree = ifree + 1 - if((lakon(nelems)(4:5).eq.'8R').or. - & ((lakon(nelems)(4:4).eq.'6').and.(nopes.eq.4))) then - xi=gauss2d1(1,m) - et=gauss2d1(2,m) - weight=weight2d1(m) - elseif((lakon(nelems)(4:4).eq.'8').or. - & (lakon(nelems)(4:6).eq.'20R').or. - & ((lakon(nelems)(4:5).eq.'15').and. - & (nopes.eq.8))) then - xi=gauss2d2(1,m) - et=gauss2d2(2,m) - weight=weight2d2(m) - elseif(lakon(nelems)(4:4).eq.'2') then - xi=gauss2d3(1,m) - et=gauss2d3(2,m) - weight=weight2d3(m) - elseif((lakon(nelems)(4:5).eq.'10').or. - & ((lakon(nelems)(4:5).eq.'15').and. - & (nopes.eq.6))) then - xi=gauss2d5(1,m) - et=gauss2d5(2,m) - weight=weight2d5(m) - elseif((lakon(nelems)(4:4).eq.'4').or. - & ((lakon(nelems)(4:4).eq.'6').and. - & (nopes.eq.3))) then - xi=gauss2d4(1,m) - et=gauss2d4(2,m) - weight=weight2d4(m) - endif -! - if(nopes.eq.8) then - call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.4) then - call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) - contribution=weight*dsqrt(xsj2(1)**2+xsj2(2)**2+ - & xsj2(3)**2) - pnt=0 - do k=1,4 - diag_els(k)=diag_els(k)+shp2(4,k)*contribution -c WRITE(*,*) "diag",k,"=",diag_els(k) - do j=1,k - pnt=pnt+1 - m_els(pnt)=m_els(pnt)+shp2(4,k)*shp2(4,j)* - & contribution -c WRITE(*,*) "M_e",k,j,"=",m_els(k,j) - enddo - enddo - elseif(nopes.eq.6) then - call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - endif -! -! Calculate the Mass matrix for compilation of the dualshapefunction -! pslavdual(16,*) -! - do k=1,3 - p(k)=0.d0 - do j=1,nopes - p(k)=p(k)+xl2(k,j)*shp2(4,j) - enddo - enddo -! -! determining the kneigh neighboring master contact -! triangle centers of gravity -! - call near3d(xo,yo,zo,x,y,z,nx,ny,nz,p(1),p(2),p(3), - & n,neigh,kneigh) -! - dd=dsqrt(xsj2(1)**2+xsj2(2)**2+xsj2(3)**2) -! - do k=1,3 - xn(k)=xsj2(k)/dd - enddo -! - isol=0 -! - loop1: do k=1,kneigh - itri=neigh(k)+itietri(1,i)-1 - loop2: do - al=-(straight(16,itri)+straight(13,itri)*p(1) - & +straight(14,itri)*p(2)+straight(15,itri)*p(3))/ - & (straight(13,itri)*xn(1)+straight(14,itri)*xn(2) - & +straight(15,itri)*xn(3)) -! - do m1=1,3 - al1=straight(4*m1-3,itri)*p(1)+ - & straight(4*m1-2,itri)*p(2)+ - & straight(4*m1-1,itri)*p(3) - al2=straight(4*m1-3,itri)*xn(1)+ - & straight(4*m1-2,itri)*xn(2)+ - & straight(4*m1-1,itri)*xn(3) - if(al1+al*al2+straight(4*m1,itri).gt.1.d-10)then - if(al.lt.1.d-10) cycle loop1 - itri=imastop(m1,itri) - if(itri.eq.0) cycle loop1 - cycle loop2 - endif - enddo -! - isol=1 -! - exit loop1 - enddo loop2 - enddo loop1 -! - if(isol.ne.0) then - gapmints(ifree)=al; -c WRITE(*,*) "Gap",al -! -! independent face found; all nodes belonging to -! the face are active (only at the start of a new -! step) -! - gapmints(ifree)=al; - if((iinc.eq.1).and.(iit.eq.1)) then - do m1=1,nopes -c write(*,*) 'Active POINT' - islavact(indexnode(m1))=1 - enddo - endif -! - endif - enddo -! computation of psladual -! -! compute inverse of me_ls -! factorisation -! - call dsptrf('U',4,m_els,ipiv,info) -! inverse - call dsptri('U',4,m_els,ipiv,work,info) -! -! stack of pslavdual multiplication with diag_els -! - pslavdual(1,l)=diag_els(1)*m_els(1) - pslavdual(2,l)=diag_els(1)*m_els(2) - pslavdual(3,l)=diag_els(1)*m_els(4) - pslavdual(4,l)=diag_els(1)*m_els(7) - pslavdual(5,l)=diag_els(2)*m_els(2) - pslavdual(6,l)=diag_els(2)*m_els(3) - pslavdual(7,l)=diag_els(2)*m_els(5) - pslavdual(8,l)=diag_els(2)*m_els(8) - pslavdual(9,l)=diag_els(3)*m_els(4) - pslavdual(10,l)=diag_els(3)*m_els(5) - pslavdual(11,l)=diag_els(3)*m_els(6) - pslavdual(12,l)=diag_els(3)*m_els(9) - pslavdual(13,l)=diag_els(4)*m_els(7) - pslavdual(14,l)=diag_els(4)*m_els(8) - pslavdual(15,l)=diag_els(4)*m_els(9) - pslavdual(16,l)=diag_els(4)*m_els(10) -c WRITE(*,*) "A_e" -c do k=1,16 -c WRITE(*,*) k, pslavdual(k,l) -c enddo - enddo -! -! FIRST SLAVE SURFACE LOOP DONE. Search for triangulation -! -! normalizing the normals -! - do l=nslavnode(i)+1,nslavnode(i+1) - dd=dsqrt(slavnor(1,l)**2+slavnor(2,l)**2+ - & slavnor(3,l)**2) - do m=1,3 - slavnor(m,l)=slavnor(m,l)/dd - enddo -! -! determining the tangential directions -! - do m=1,3 - xn(m)=slavnor(m,l) - xnabs(m)=dabs(xn(m)) - enddo - number=3 - kmax(1)=1 - kmax(2)=2 - kmax(3)=3 - kflag=2 -! -! sorting the components of the normal -! - call dsort(xnabs,kmax,number,kflag) -! - km1=kmax(3) - km2=km1+1 - if(km2.gt.3) km2=1 - km3=km2+1 - if(km3.gt.3) km3=1 -! - slavtan(km1,l)=-slavnor(km2,l) - slavtan(km2,l)=slavnor(km1,l) - slavtan(km3,l)=0.d0 - dd=dsqrt(slavtan(km1,l)**2+slavtan(km2,l)**2) - slavtan(km1,l)=slavtan(km1,l)/dd - slavtan(km2,l)=slavtan(km2,l)/dd -! - slavtan(4,l)=xn(2)*slavtan(3,l) - & -xn(3)*slavtan(2,l) - slavtan(5,l)=xn(3)*slavtan(1,l) - & -xn(1)*slavtan(3,l) - slavtan(6,l)=xn(1)*slavtan(2,l) - & -xn(2)*slavtan(1,l) - enddo -! -! *****************BEGIN SECOND LOOP ******************* -! Research of the contact integration points -! - nintpoint=0 - do l = itiefac(1,i), itiefac(2,i) - ifaces = islavsurf(1,l) - nelems = int(ifaces/10) - jfaces = ifaces - nelems*10 - islavsurf(2,l)=nintpoint -! -! INITIALIZATION of the inside node of the slave surface -! - do ik=1,1 - pnodesin(1,ik)=0.d0 - pnodesin(2,ik)=0.d0 - pnodesin(3,ik)=0.d0 - enddo -! -! Decide the max integration points number, just consider 2D situation -! - if(lakon(nelems)(4:5).eq.'8R') then - nopes=4 - nope=8 - elseif(lakon(nelems)(4:4).eq.'8') then - nopes=4 - nope=8 - elseif(lakon(nelems)(4:6).eq.'20R') then - nopes=8 - nope=20 - elseif(lakon(nelems)(4:4).eq.'2') then - nopes=8 - nope=20 - elseif(lakon(nelems)(4:5).eq.'10') then - nopes=6 - nope=10 - elseif(lakon(nelems)(4:4).eq.'4') then - nopes=3 - nope=4 -! -! treatment of wedge faces -! - elseif(lakon(nelems)(4:4).eq.'6') then - nope=6 - if(jfaces.le.2) then - nopes=3 - else - nopes=4 - endif - elseif(lakon(nelems)(4:5).eq.'15') then - nope=15 - if(jfaces.le.2) then - nopes=6 - else - nopes=8 - endif - endif -! -! actual position of the nodes belonging to the -! slave surface -! - do j=1,nope - konl(j)=kon(ipkon(nelems)+j) - enddo -! - if((nope.eq.20).or.(nope.eq.8)) then - do m=1,nopes - do j=1,3 - xl2(j,m)=co(j,konl(ifaceq(m,jfaces)))+ -c & vold(j,konl(ifaceq(m,jfaces))) - & vold(j,konl(ifaceq(m,jfaces)))+err*rand(1) - - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - do m=1,nopes - do j=1,3 - xl2(j,m)=co(j,konl(ifacet(m,jfaces)))+ -c & vold(j,konl(ifacet(m,jfaces))) - & vold(j,konl(ifacet(m,jfaces)))+err*rand(1) - enddo - enddo - else - do m=1,nopes - do j=1,3 - xl2(j,m)=co(j,konl(ifacew1(m,jfaces)))+ -c & vold(j,konl(ifacew1(m,jfaces))) - & vold(j,konl(ifacew1(m,jfaces)))+err*rand(1) - enddo - enddo - endif - -! calculate the mean normal vector on the Slave Surface -! - do k=1,3 - xn(k)=0.d0 - enddo - if(nopes.eq.8) then - do m = 1, nopes -! - if(nope.eq.20) then - node = konl(ifaceq(m,jfaces)) - elseif(nope.eq.15) then - node=konl(ifacew2(m,jfaces)) - endif -! - call nident(islavnode(nslavnode(i)+1), node, - & nslavnode(i+1)-nslavnode(i), id) - index1=nslavnode(i)+id - do k=1,3 - xn(k)=slavnor(k,index1)+xn(k) - enddo - enddo - elseif(nopes.eq.4) then - do m = 1, nopes -! - if(nope.eq.8) then - node = konl(ifaceq(m,jfaces)) - elseif(nope.eq.6) then - node=konl(ifacew1(m,jfaces)) - endif -! - call nident(islavnode(nslavnode(i)+1), node, - & nslavnode(i+1)-nslavnode(i), id) -! - index1=nslavnode(i)+id - do k=1,3 - xn(k)=slavnor(k,index1)+xn(k) - enddo - enddo - elseif(nopes.eq.6) then - do m = 1, nopes -! - if(nope.eq.10) then - node = konl(ifacet(m,jfaces)) - elseif(nope.eq.15) then - node = konl(ifacew2(m,jfaces)) - endif -! - call nident(islavnode(nslavnode(i)+1), node, - & nslavnode(i+1)-nslavnode(i), id) - index1=nslavnode(i)+id - do k=1,3 - xn(k)=slavnor(k,index1)+xn(k) - enddo - enddo - else - do m = 1, nopes -! - if(nope.eq.6) then - node = konl(ifacew1(m,jfaces)) - elseif(nope.eq.4) then - node = konl(ifacet(m,jfaces)) - endif -! - call nident(islavnode(nslavnode(i)+1), node, - & nslavnode(i+1)-nslavnode(i), id) - index1=nslavnode(i)+id - do k=1,3 - xn(k)=slavnor(k,index1)+xn(k) - enddo - enddo - endif -! -! normalizing the mean normal on the Slave surface -! - dd=dsqrt(xn(1)**2+xn(2)**2+xn(3)**2) - do k=1,3 - xn(k)=xn(k)/dd - enddo -! -! determine the equations of the triangle/quadrilateral -! (mean)plane and of the planes boardering the -! triangle/quadrilateral -! - if(nopes.eq.3) then - call straighteq3d(xl2,slavstraight) - else - call approxplane(xl2,slavstraight,xn) - endif -! -! determine the triangles corresponding to the corner -! nodes -! - ntria=0 - do j=1,4 - itria(j)=0 - do k=1,10 - itriacorner(j,k)=0 - enddo - enddo -!**************************************************************** -!*********************FIRST METHOD **************************** -!*************************************************************** -! -c do j=1,nopes -c call neartriangle(xl2(1,j),xn,xo,yo,zo,x,y,z,nx,ny,nz, -c & n,neigh,kneigh,itietri,ntie,straight,imastop,itri,i) -! -c call nident(itria,itri,ntria,id) -c if(id.gt.0) then -c if(itria(id).eq.itri) then -c itriacorner(j,id)=1 -c cycle -c endif -c endif -! -! triangle was not covered yet: add to stack -! -c ntria=ntria+1 -c do k=ntria,id+2,-1 -c itria(k)=itria(k-1) -c do m=1,j-1 -c itriacorner(m,k)=itriacorner(m,k-1) -c enddo -c enddo -c itria(id+1)=itri -c itriacorner(j,id+1)=1 -c do m=1,j-1 -c itriacorner(m,id+1)=0 -c enddo -c enddo -! -!***************************ESSAI 2nd ***************************** -! - do j=1,nopes - call neartriangle2(xl2(1,j),xn,xo,yo,zo,x,y,z,nx,ny,nz, - & n,neigh,kneigh,itietri,ntie,straight, - & imastop,i,ntric,ltric) -! - do tc=1,ntric - call nident(itria,ltric(tc),ntria,id) - if(id.gt.0) then - if(itria(id).eq.ltric(tc)) then - itriacorner(j,id)=1 - cycle - endif - endif -! -! triangle was not covered yet: add to stack -! - ntria=ntria+1 - do k=ntria,id+2,-1 - itria(k)=itria(k-1) - do m=1,j - itriacorner(m,k)=itriacorner(m,k-1) - enddo - enddo - itria(id+1)=ltric(tc) - itriacorner(j,id+1)=1 - do m=1,j-1 - itriacorner(m,id+1)=0 - enddo - enddo - enddo -! -!*************************FIN ESSAI 2nd ******************************* -! - nnodesin = 0 - nnodesout = 0 - nactiveline = 0 -! -! treating the corner triangles first -! - do j=1,ntria - itri=itria(j) - nelem=int(koncont(4,itri)/10.d0) - jface=koncont(4,itri)-10*nelem -! - indexe=ipkon(nelem) - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(4:4).eq.'8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.4) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacet(k,jface)) - enddo - elseif(nface.eq.5) then - if(nope.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew1(k,jface)) - enddo - elseif(nope.eq.15) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew2(k,jface)) - enddo - endif - elseif(nface.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifaceq(k,jface)) - enddo - endif -! - do k1=1,nnodelem - do j1 = 1,3 - pneigh(j1,k1) = co(j1,nodef(k1))+vold(j1,nodef(k1)) - enddo - enddo -! -! -c WRITE(*,*) "gen ctriangle",itri, "surface",l - call treattriangle(inodesin,nnodesin,inodesout, - & nnodesout,nopes,slavstraight,xn,co,xl2,ipe,ime, - & iactiveline,nactiveline,intersec,xntersec, - & ifreeintersec,itri,koncont,itriacorner(1,j), - & nintpoint,pslavsurf,ncont,imastsurf,pmastsurf, - & pneigh,nnodelem,vold,mi,pnodesin) - enddo -! -! retrieving all triangles by neighborhood search -! - do - line=iactiveline(1,1) -c if(line.eq.0) exit - if(nactiveline.eq.0) exit - if(ime(2,line).eq.iactiveline(2,1)) then - itri=imastop(ime(3,line),ime(2,line)) - else - itri=ime(2,line) - endif -! -! corners of the Slave surface have already been treated -! - if(itri.eq.0) exit - do j=1,4 - itriacorner(j,1)=0 - enddo -! -c WRITE(*,*) "itri=",itri - nelem=int(koncont(4,itri)/10.d0) - jface=koncont(4,itri)-10*nelem -! - indexe=ipkon(nelem) - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(4:4).eq.'8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.4) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacet(k,jface)) - enddo - elseif(nface.eq.5) then - if(nope.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew1(k,jface)) - enddo - elseif(nope.eq.15) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew2(k,jface)) - enddo - endif - elseif(nface.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifaceq(k,jface)) - enddo - endif -! - do k1=1,nnodelem - do j1 = 1,3 - pneigh(j1,k1) = co(j1,nodef(k1))+vold(j1,nodef(k1)) - enddo - enddo -! -! -c WRITE(*,*) "gen triangle",itri, "surface",l - call treattriangle(inodesin,nnodesin,inodesout, - & nnodesout,nopes,slavstraight,xn,co,xl2,ipe,ime, - & iactiveline,nactiveline,intersec,xntersec, - & ifreeintersec,itri,koncont,itriacorner,nintpoint, - & pslavsurf,ncont,imastsurf,pmastsurf, - & pneigh,nnodelem,vold,mi,pnodesin) - enddo -! all integration points found! -! -! - enddo - islavsurf(2,l)=nintpoint -! -! - enddo - ifree=nintpoint - write(*,*) "gencontrel fin GP : ",nintpoint -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/generatecycmpcs.f calculix-ccx-2.3/ccx_2.1/src/generatecycmpcs.f --- calculix-ccx-2.1/ccx_2.1/src/generatecycmpcs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/generatecycmpcs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,478 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine generatecycmpcs(tolloc,co,nk,ipompc,nodempc, - & coefmpc,nmpc,ikmpc,ilmpc,mpcfree,rcs,zcs,ics,nr,nz, - & rcs0,zcs0,labmpc, - & mcs,triangulation,csab,xn,yn,zn,phi,noded,ncsnodes, - & nodesonaxis,rcscg,rcs0cg,zcscg,zcs0cg,nrcg,nzcg,jcs,lcs, - & kontri,straight,ne,ipkon,kon,lakon,ifacetet,inodface,ncounter, - & jobnamec,vold,cfd,mi) -! -! generate cyclic mpc's -! - implicit none -! - logical triangulation,nodesonaxis,interpolation -! - character*1 c - character*3 m1,m2,m3 - character*5 p0,p1,p2,p3,p7,p9999 - character*8 lakon(*) - character*20 labmpc(*),label - character*132 jobnamec(*),fntria -! - integer ipompc(*),nodempc(3,*),nneigh,ne,ipkon(*),kon(*), - & j,k,nk,nmpc,mpcfree,ics(*),nterms, - & nr(*),nz(*),noded,nodei,ikmpc(*),ilmpc(*),kontri(3,*), - & number,idof,ndir,node,ncsnodes,id,mpcfreeold, - & mcs,nrcg(*),nzcg(*),jcs(*),lcs(*),nodef(8), - & netri,ifacetet(*),inodface(*),lathyp(3,6),inum,one,i, - & noden(10),ncounter,ier,ipos,cfd,mi(2) -! - real*8 tolloc,co(3,*),coefmpc(*),rcs(*),zcs(*),rcs0(*),zcs0(*), - & csab(7),xn,yn,zn,xap,yap,zap,rp,zp,al(3,3),ar(3,3),phi, - & x2,y2,z2,x3,y3,z3,rcscg(*),rcs0cg(*),zcscg(*),zcs0cg(*), - & straight(9,*),ratio(8),vold(0:mi(2),*) -! - save netri -! -! latin hypercube positions in a 3 x 3 matrix -! - data lathyp /1,2,3,1,3,2,2,1,3,2,3,1,3,1,2,3,2,1/ -! -c nneigh=1 - nneigh=10 -! - xap=co(1,noded)-csab(1) - yap=co(2,noded)-csab(2) - zap=co(3,noded)-csab(3) -! - zp=xap*xn+yap*yn+zap*zn - rp=dsqrt((xap-zp*xn)**2+(yap-zp*yn)**2+(zap-zp*zn)**2) -! - call near2d(rcs0,zcs0,rcs,zcs,nr,nz,rp,zp,ncsnodes,noden,nneigh) - node=noden(1) - nodei=abs(ics(noden(1))) -! -! check whether node is on axis -! - if(nodei.eq.noded) then - return - endif -! - interpolation=.false. -! - if(rp.gt.1.d-10) then - x2=(xap-zp*xn)/rp - y2=(yap-zp*yn)/rp - z2=(zap-zp*zn)/rp - x3=yn*z2-y2*zn - y3=x2*zn-xn*z2 - z3=xn*y2-x2*yn - endif -! - if((tolloc.ge.0.d0).and. - & (tolloc.le.dsqrt((rp-rcs0(node))**2+(zp-zcs0(node))**2))) - & then -! -! the nodal positions on the dependent and independent -! sides of the mpc's do no agree: interpolation is -! necessary. -! - write(*,*) '*WARNING in generatecycmpcs: no cyclic' - write(*,*) ' symmetric partner found for' - write(*,*) ' dependent node ',noded,'.' - write(*,*) ' allowed tolerance:',tolloc - write(*,*) ' best partner node number:',nodei - write(*,*) ' actual distance in a radial plane: ', - & dsqrt((rp-rcs0(node))**2+(zp-zcs0(node))**2) - write(*,*) ' Remedy: the node is connected to an' - write(*,*) ' independent element side.' - write(*,*) -! - interpolation=.true. -! - if(.not.triangulation) then - call triangulate(ics,rcs0,zcs0,ncsnodes, - & rcscg,rcs0cg,zcscg,zcs0cg,nrcg,nzcg,jcs,kontri, - & straight,ne,ipkon,kon,lakon,lcs,netri,ifacetet, - & inodface) - triangulation=.true. -! - ipos=index(jobnamec(1),char(0)) - fntria(1:ipos-1)=jobnamec(1)(1:ipos-1) - fntria(ipos:ipos+3)=".tri" - do i=ipos+4,132 - fntria(i:i)=' ' - enddo -! - open(70,file=fntria,status='unknown') - c='C' - m1=' -1' - m2=' -2' - m3=' -3' - p0=' 0' - p1=' 1' - p2=' 2' - p3=' 3' - p7=' 7' - p9999=' 9999' - one=1 - write(70,'(a5,a1)') p1,c - write(70,'(a5,a1,67x,i1)') p2,c,one - do i=1,nk - write(70,'(a3,i10,1p,3e12.5)') m1,i,(co(j,i),j=1,3) - enddo - write(70,'(a3)') m3 - write(70,'(a5,a1,67x,i1)') p3,c,one - do i=1,netri - write(70,'(a3,i10,2a5)')m1,i,p7,p0 - write(70,'(a3,3i10)') m2,(kontri(j,i),j=1,3) - enddo - write(70,'(a3)') m3 - write(70,'(a5)') p9999 - close(70) -! - endif -! - label='CYCLIC ' - if(mcs.lt.10) then - write(label(7:7),'(i1)') mcs - elseif(mcs.lt.100) then - write(label(7:8),'(i2)') mcs - else - write(*,*)'*ERROR in generatecycmpcs: no more than 99' - write(*,*)' cyclic symmetry definitions allowed' - stop - endif -! - nodei=nk+1 -! -! copying the initial conditions for the new node -! - do i=0,mi(2) - vold(i,nodei)=vold(i,noded) - enddo -! - co(1,nodei)=csab(1)+zp*xn+rp*(x2*dcos(phi)+x3*dsin(phi)) - co(2,nodei)=csab(2)+zp*yn+rp*(y2*dcos(phi)+y3*dsin(phi)) - co(3,nodei)=csab(3)+zp*zn+rp*(z2*dcos(phi)+z3*dsin(phi)) -! - ier=0 -! - call linkdissimilar(co,nk,ics,csab,ncsnodes, - & rcscg,rcs0cg,zcscg,zcs0cg,nrcg,nzcg,jcs,kontri,straight, - & lcs,nodef,ratio,nterms,rp,zp,netri, - & nodesonaxis,nodei,ifacetet,inodface,noded,tolloc,xn,yn, - & zn,ier) -! - if(ier.ne.0) then - ncounter=ncounter+1 - return - endif -! -! moving the dependent node such that is corresponds exactly -! to the independent node -! -c xap=co(1,nodei)-csab(1) -c yap=co(2,nodei)-csab(2) -c zap=co(3,nodei)-csab(3) -c! -c zp=xap*xn+yap*yn+zap*zn -c rp=dsqrt((xap-zp*xn)**2+(yap-zp*yn)**2+(zap-zp*zn)**2) -c! -c x2=(xap-zp*xn)/rp -c y2=(yap-zp*yn)/rp -c z2=(zap-zp*zn)/rp -c x3=yn*z2-y2*zn -c y3=x2*zn-xn*z2 -c z3=xn*y2-x2*yn -c! -c co(1,noded)=csab(1)+zp*xn+rp*(x2*dcos(phi)-x3*dsin(phi)) -c co(2,noded)=csab(2)+zp*yn+rp*(y2*dcos(phi)-y3*dsin(phi)) -c co(3,noded)=csab(3)+zp*zn+rp*(z2*dcos(phi)-z3*dsin(phi)) - else - if(ics(node).lt.0) return -! -! moving the dependent node such that is corresponds exactly -! to the independent node -! -c xap=co(1,nodei)-csab(1) -c yap=co(2,nodei)-csab(2) -c zap=co(3,nodei)-csab(3) -! -c zp=xap*xn+yap*yn+zap*zn -c rp=dsqrt((xap-zp*xn)**2+(yap-zp*yn)**2+(zap-zp*zn)**2) -! -c x2=(xap-zp*xn)/rp -c y2=(yap-zp*yn)/rp -c z2=(zap-zp*zn)/rp -c x3=yn*z2-y2*zn -c y3=x2*zn-xn*z2 -c z3=xn*y2-x2*yn -! -c co(1,noded)=csab(1)+zp*xn+rp*(x2*dcos(phi)-x3*dsin(phi)) -c co(2,noded)=csab(2)+zp*yn+rp*(y2*dcos(phi)-y3*dsin(phi)) -c co(3,noded)=csab(3)+zp*zn+rp*(z2*dcos(phi)-z3*dsin(phi)) - endif -! -! generating the mechanical MPC's; the generated MPC's are for -! nodal diameter 0. For other nodal diameters the MPC's are -! changed implicitly in mastructcs and mafillsmcs -! - call transformatrix(csab,co(1,noded),al) - call transformatrix(csab,co(1,nodei),ar) -! -! checking for latin hypercube positions in matrix al none of -! which are zero -! - do inum=1,6 - if((dabs(al(lathyp(1,inum),1)).gt.1.d-3).and. - & (dabs(al(lathyp(2,inum),2)).gt.1.d-3).and. - & (dabs(al(lathyp(3,inum),3)).gt.1.d-3)) exit - enddo -! - do ndir=1,3 -! -! determining which direction to use for the -! dependent side: should not occur on the dependent -! side in another MPC and should have a nonzero -! coefficient -! - number=lathyp(ndir,inum) - idof=8*(noded-1)+number - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*WARNING in generatecycmpcs: cyclic MPC in no - &de' - write(*,*) ' ',noded,' and direction ',ndir - write(*,*) ' cannot be created: the' - write(*,*) ' DOF in this node is already used' - cycle - endif - endif - number=number-1 -! - nmpc=nmpc+1 - labmpc(nmpc)='CYCLIC ' - if(mcs.lt.10) then - write(labmpc(nmpc)(7:7),'(i1)') mcs - elseif(mcs.lt.100) then - write(labmpc(nmpc)(7:8),'(i2)') mcs - else - write(*,*)'*ERROR in generatecycmpcs: no more than 99' - write(*,*)' cyclic symmetry definitions allowed' - stop - endif - ipompc(nmpc)=mpcfree -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - do j=1,3 - number=number+1 - if(number.gt.3) number=1 - if(dabs(al(number,ndir)).lt.1.d-5) cycle - nodempc(1,mpcfree)=noded - nodempc(2,mpcfree)=number - coefmpc(mpcfree)=al(number,ndir) - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' - stop - endif - enddo - do j=1,3 - number=number+1 - if(number.gt.3) number=1 - if(dabs(ar(number,ndir)).lt.1.d-5) cycle - if(.not.interpolation) then - nodempc(1,mpcfree)=nodei - nodempc(2,mpcfree)=number - coefmpc(mpcfree)=-ar(number,ndir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' - stop - endif - else - do k=1,nterms - nodempc(1,mpcfree)=nodef(k) - nodempc(2,mpcfree)=number - coefmpc(mpcfree)=-ar(number,ndir)*ratio(k) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) '*ERROR in generatecycmpcs: increase nmp - &c_' - stop - endif - enddo - endif - enddo - nodempc(3,mpcfreeold)=0 - enddo -! -! generating the thermal MPC's; the generated MPC's are for nodal -! diameter 0. -! - nmpc=nmpc+1 - labmpc(nmpc)='CYCLIC ' - if(mcs.lt.10) then - write(labmpc(nmpc)(7:7),'(i1)') mcs - elseif(mcs.lt.100) then - write(labmpc(nmpc)(7:8),'(i2)') mcs - else - write(*,*)'*ERROR in generatecycmpcs: no more than 99' - write(*,*)' cyclic symmetry definitions allowed' - stop - endif - ipompc(nmpc)=mpcfree - idof=8*(noded-1) - call nident(ikmpc,idof,nmpc-1,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*ERROR in generatecycmpcs: temperature' - write(*,*) ' in node',noded,'is already used' - stop - endif - endif -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=noded - nodempc(2,mpcfree)=0 - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' - stop - endif - if(.not.interpolation) then - nodempc(1,mpcfree)=nodei - nodempc(2,mpcfree)=0 - coefmpc(mpcfree)=-1.d0 - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' - stop - endif - else - do k=1,nterms - nodempc(1,mpcfree)=nodef(k) - nodempc(2,mpcfree)=0 - coefmpc(mpcfree)=-ratio(k) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' - stop - endif - enddo - endif - nodempc(3,mpcfreeold)=0 -! -! generating the static pressure MPC's for 3D fluid calculations; -! the generated MPC's are for nodal diameter 0. -! - if(cfd.eq.1) then - nmpc=nmpc+1 - labmpc(nmpc)='CYCLIC ' - if(mcs.lt.10) then - write(labmpc(nmpc)(7:7),'(i1)') mcs - elseif(mcs.lt.100) then - write(labmpc(nmpc)(7:8),'(i2)') mcs - else - write(*,*)'*ERROR in generatecycmpcs: no more than 99' - write(*,*)' cyclic symmetry definitions allowed' - stop - endif - ipompc(nmpc)=mpcfree - idof=8*(noded-1)+4 - call nident(ikmpc,idof,nmpc-1,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*ERROR in generatecycmpcs: temperature' - write(*,*) ' in node',noded,'is already used' - stop - endif - endif -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=noded - nodempc(2,mpcfree)=4 - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' - stop - endif - if(.not.interpolation) then - nodempc(1,mpcfree)=nodei - nodempc(2,mpcfree)=4 - coefmpc(mpcfree)=-1.d0 - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' - stop - endif - else - do k=1,nterms - nodempc(1,mpcfree)=nodef(k) - nodempc(2,mpcfree)=4 - coefmpc(mpcfree)=-ratio(k) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' - stop - endif - enddo - endif - nodempc(3,mpcfreeold)=0 - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/genislavactdof.f calculix-ccx-2.3/ccx_2.1/src/genislavactdof.f --- calculix-ccx-2.1/ccx_2.1/src/genislavactdof.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/genislavactdof.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine genislavactdof(ntie,neq,nactdof,nslavnode,islavact, - & islavactdof,islavnode,mi) -! -! Author : Samoela Rakotonanahary -! genislavactdof get the field islavactdof in order to -! help calculating the tangential matrices. -! -! islavactdof is the inverse of nactdof for active slave nodes: -! it links an active slave degree of freedom to the -! corresponding slave node position in field islavnode and the -! global (x-y-z) degree of freedom -! - integer i,j,k,ntie,neq(*),node,nslavnode(*),mi(2), - & nactdof(0:mi(2),*), - & islavact(*),islavactdof(*),islavnode(*) -! - do i=1,ntie - do j = nslavnode(i)+1,nslavnode(i+1) - node=islavnode(j) - if(islavact(j).eq.1) then - do k=1,3 - if (nactdof(k,node).eq.0) cycle - islavactdof(nactdof(k,node))=10*j+k - enddo - endif - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/genran.f calculix-ccx-2.3/ccx_2.1/src/genran.f --- calculix-ccx-2.1/ccx_2.1/src/genran.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/genran.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,43 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine genran(iix,g,k) -! -! used in the Lanczos routines (cf. netlib CD) -! generates k random numbers between 0. and 1. from seed iix -! and stores them in g -! - integer iix,k - real*4 g(k) -! - i1=nint(iix*1974./2546.) - i2=nint(iix*235./2546.) - i3=nint(iix*337./2546.) -! -! initialisation of ranewr -! - call iniran(i1,i2,i3) -! -! repeatedly calling ranewr to generate k random numbers -! - do i=1,k - g(i)=ranewr() - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/gentiedmpc.f calculix-ccx-2.3/ccx_2.1/src/gentiedmpc.f --- calculix-ccx-2.1/ccx_2.1/src/gentiedmpc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/gentiedmpc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,598 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine gentiedmpc(tieset,ntie,itietri,ipkon,kon, - & lakon,set,istartset,iendset,ialset,cg,straight, - & koncont,co,xo,yo,zo,x,y,z,nx,ny,nz,nset, - & ifaceslave,istartfield,iendfield,ifield, - & ipompc,nodempc,coefmpc,nmpc,nmpctied,mpcfree,ikmpc,ilmpc, - & labmpc,ithermal,tietol,cfd,ncont) -! -! generates MPC's for the slave tied contact nodes -! - implicit none -! - character*8 lakon(*) - character*20 labmpc(*) - character*81 tieset(3,*),slavset,set(*) -! - integer ntie,nset,istartset(*),iendset(*),ialset(*), - & itietri(2,ntie),ipkon(*),kon(*),koncont(4,*),ne,node, - & neigh(20),iflag,kneigh,i,j,k,l,islav,isol, - & itri,ll,kflag,n,ipos,nx(*),ny(*),ipointer(20), - & nz(*),nstart,ifaceq(8,6),ifacet(6,4), - & ifacew1(4,5),ifacew2(8,5),nelem,jface,indexe, - & nnodelem,nface,nope,nodef(8),idof, - & ifaceref,isum,kstart,kend,jstart,id, - & jend,ifield(*),istartfield(*),iendfield(*),ifaceslave(*), - & ipompc(*),nodempc(3,*),nmpc,nmpctied,mpcfree,ikmpc(*), - & ilmpc(*),ithermal(2),cfd,ncont,mpcfreeold,m -! - real*8 cg(3,*),straight(16,*),co(3,*),p(3), - & totdist(20),dist,xo(*),yo(*),zo(*),x(*),y(*),z(*), - & beta,c0,pl(3,8),cgdist, - & ratio(8),xi,et,coefmpc(*),tietol(*),tolloc -! -! nodes per face for hex elements -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ -! -! nodes per face for tet elements -! - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ -! -! nodes per face for linear wedge elements -! - data ifacew1 /1,3,2,0, - & 4,5,6,0, - & 1,2,5,4, - & 2,3,6,5, - & 4,6,3,1/ -! -! nodes per face for quadratic wedge elements -! - data ifacew2 /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! -! -! - open(9,file='nodes_not_connected.fbd',status='unknown',err=51) - close(9,status='delete',err=52) - open(9,file='nodes_not_connected.fbd',status='unknown',err=51) -! - nmpctied=nmpc -! -! calculating a typical element size -! - tolloc=0.d0 - do i=1,ncont - tolloc=tolloc+dabs(straight(1,i)*cg(1,i)+ - & straight(2,i)*cg(2,i)+ - & straight(3,i)*cg(3,i)+ - & straight(4,i)) - enddo - tolloc=0.025*tolloc/ncont -! -! determining for which dofs MPC's have to be generated -! - if(cfd.eq.1) then - if(ithermal(2).le.1) then - kstart=1 - kend=4 - else - kstart=0 - kend=4 - endif - else - if(ithermal(2).le.1) then - kstart=1 - kend=3 - elseif(ithermal(2).eq.2) then - kstart=0 - kend=0 - else - kstart=0 - kend=3 - endif - endif -! -! maximum number of neighboring master triangles for a slave node -! - kflag=2 -! - do i=1,ntie - if(tieset(1,i)(81:81).ne.'T') cycle - iflag=0 - kneigh=20 - slavset=tieset(2,i) -! -! default tolerance if none is specified -! - if(tietol(i).lt.1.d-10) tietol(i)=tolloc -! -! determining the slave set -! - if(ifaceslave(i).eq.0) then -c ipos=index(slavset,' ') -c slavset(ipos:ipos)='S' - do j=1,nset - if(set(j).eq.slavset) then - exit - endif - enddo -c if(j.gt.nset) then -c write(*,*) -c & '*ERROR in gentiedmpc: tied contact slave set', -c & slavset -c write(*,*) ' does not exist' -c stop -c endif - jstart=istartset(j) - jend=iendset(j) - else - jstart=istartfield(i) - jend=iendfield(i) - endif -! - nstart=itietri(1,i)-1 - n=itietri(2,i)-nstart - if(n.lt.kneigh) kneigh=n - do j=1,n - xo(j)=cg(1,nstart+j) - x(j)=xo(j) - nx(j)=j - yo(j)=cg(2,nstart+j) - y(j)=yo(j) - ny(j)=j - zo(j)=cg(3,nstart+j) - z(j)=zo(j) - nz(j)=j - enddo - call dsort(x,nx,n,kflag) - call dsort(y,ny,n,kflag) - call dsort(z,nz,n,kflag) -! - do j=jstart,jend - if(((ifaceslave(i).eq.0).and.(ialset(j).gt.0)).or. - & (ifaceslave(i).eq.1)) then -! - if(ifaceslave(i).eq.0) then - node=ialset(j) - else - node=ifield(j) - endif -! -c write(*,*) 'gentiedmpc ',j,node - do k=1,3 - p(k)=co(k,node) - enddo -! -! determining the kneigh neighboring master contact -! triangle centers of gravity -! - call near3d(xo,yo,zo,x,y,z,nx,ny,nz,p(1),p(2),p(3), - & n,neigh,kneigh) -! - isol=0 -! - do k=1,kneigh - itri=neigh(k)+itietri(1,i)-1 -! - totdist(k)=0.d0 -! - do l=1,3 - ll=4*l-3 - dist=straight(ll,itri)*p(1)+ - & straight(ll+1,itri)*p(2)+ - & straight(ll+2,itri)*p(3)+ - & straight(ll+3,itri) - if(dist.gt.0.d0) then - totdist(k)=totdist(k)+dist - endif - enddo -c write(*,*) 'gentiedmpc ',k,itri,koncont(4,itri), -c & totdist(k) - totdist(k)=dsqrt(totdist(k)**2+ - & (straight(13,itri)*p(1)+ - & straight(14,itri)*p(2)+ - & straight(15,itri)*p(3)+ - & straight(16,itri))**2) -c cgdist=dsqrt((p(1)-cg(1,itri))**2+ -c & (p(2)-cg(2,itri))**2+ -c & (p(3)-cg(3,itri))**2) -c write(*,*) 'gentiedmpc ',k,itri,koncont(4,itri), -c & totdist(k),cgdist -! - if(totdist(k).le.tietol(i)) then - isol=k - exit - endif - enddo -! -! check whether distance is larger than tietol(i): -! no element is generated -! - if(isol.eq.0) then -! -! distance is too large: no MPC is generated -! - call dsort(totdist,ipointer,kneigh,kflag) - write(*,*) '*WARNING in gentiedmpc: no tied MPC' - write(*,*) ' generated for node ',node - write(*,*) ' master face too far away' - write(*,*) ' distance: ',totdist(1) - write(*,*) ' tolerance: ',tietol(i) - write(9,*) 'seta nodes_not_connected n ',node - else -! - nelem=int(koncont(4,itri)/10.d0) - jface=koncont(4,itri)-10*nelem -! - indexe=ipkon(nelem) - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(4:4).eq.'8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.4) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacet(k,jface)) - enddo - elseif(nface.eq.5) then - if(nope.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew1(k,jface)) - enddo - elseif(nope.eq.15) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew2(k,jface)) - enddo - endif - elseif(nface.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifaceq(k,jface)) - enddo - endif -! -! attaching the node with coordinates in p -! to the face -! - do k=1,nnodelem - do l=1,3 - pl(l,k)=co(l,nodef(k)) - enddo - enddo - call attach(pl,p,nnodelem,ratio,dist,xi,et) - do k=1,3 - co(k,node)=p(k) - enddo -! -! generating MPC's -! - do l=kstart,kend - idof=8*(node-1)+l - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*WARNING in gentiedmpc:' - write(*,*) ' DOF ',l,' of node ', - & node,' is not active;' - write(*,*) ' no tied constraint ', - & 'is generated' - write(9,*) 'seta nodes_not_connected n ',node - cycle - endif - endif -! - nmpc=nmpc+1 - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree -! -! updating ikmpc and ilmpc -! - do m=nmpc,id+2,-1 - ikmpc(m)=ikmpc(m-1) - ilmpc(m)=ilmpc(m-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=l - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gentiedmpc: increase memmpc_' - stop - endif - do k=1,nnodelem - nodempc(1,mpcfree)=nodef(k) - nodempc(2,mpcfree)=l - coefmpc(mpcfree)=-ratio(k) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gentiedmpc: increase memmpc_' - stop - endif - enddo - nodempc(3,mpcfreeold)=0 - -c call writempc(ipompc,nodempc,coefmpc,labmpc,nmpc) - enddo -! - endif -! - else - node=ialset(j-2) - do - node=node-ialset(j) - if(node.ge.ialset(j-1)) exit -! - do k=1,3 - p(k)=co(k,node) - enddo -! -! determining the kneigh neighboring master contact -! triangle centers of gravity -! - call near3d(xo,yo,zo,x,y,z,nx,ny,nz,p(1),p(2),p(3), - & n,neigh,kneigh) -! - isol=0 -! - do k=1,kneigh - itri=neigh(k)+itietri(1,i)-1 -! - totdist(k)=0.d0 -! - do l=1,3 - ll=4*l-3 - dist=straight(ll,itri)*p(1)+ - & straight(ll+1,itri)*p(2)+ - & straight(ll+2,itri)*p(3)+ - & straight(ll+3,itri) - if(dist.gt.0.d0) then - totdist(k)=totdist(k)+dist - endif - enddo -c write(*,*) 'gentiedmpc ',k,itri,koncont(4,itri), -c & totdist(k) - totdist(k)=dsqrt(totdist(k)**2+ - & (straight(13,itri)*p(1)+ - & straight(14,itri)*p(2)+ - & straight(15,itri)*p(3)+ - & straight(16,itri))**2) -c cgdist=dsqrt((p(1)-cg(1,itri))**2+ -c & (p(2)-cg(2,itri))**2+ -c & (p(3)-cg(3,itri))**2) -c write(*,*) 'gentiedmpc ',k,itri,koncont(4,itri), -c & totdist(k),cgdist -! - if(totdist(k).le.tietol(i)) then - isol=k - exit - endif - enddo -! -! check whether distance is larger than tietol(i): -! no element is generated -! - if(isol.eq.0) then -! -! distance is too large: no MPC is generated -! - call dsort(totdist,ipointer,kneigh,kflag) - write(*,*) '*WARNING in gentiedmpc: no tied MPC' - write(*,*) ' generated for node ',node - write(*,*) ' master face too far away' - write(*,*) ' distance: ',totdist(1) - write(*,*) ' tolerance: ',tietol(i) - write(9,*) 'seta nodes_not_connected n ',node - else -! - nelem=int(koncont(4,itri)/10.d0) - jface=koncont(4,itri)-10*nelem -! - indexe=ipkon(nelem) - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(4:4).eq.'8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.4) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacet(k,jface)) - enddo - elseif(nface.eq.5) then - if(nope.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew1(k,jface)) - enddo - elseif(nope.eq.15) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew2(k,jface)) - enddo - endif - elseif(nface.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifaceq(k,jface)) - enddo - endif -! -! attaching the node with coordinates in p -! to the face -! - do k=1,nnodelem - do l=1,3 - pl(l,k)=co(l,nodef(k)) - enddo - enddo - call attach(pl,p,nnodelem,ratio,dist,xi,et) - do k=1,3 - co(k,node)=p(k) - enddo -! -! generating MPC's -! - do l=kstart,kend - idof=8*(node-1)+l - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*WARNING in gentiedmpc:' - write(*,*) ' DOF ',l,' of node ', - & node,' is not active;' - write(*,*) ' no tied constraint ', - & 'is generated' - write(9,*) 'seta nodes_not_connected n ',node - cycle - endif - endif -! - nmpc=nmpc+1 - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree -! -! updating ikmpc and ilmpc -! - do m=nmpc,id+2,-1 - ikmpc(m)=ikmpc(m-1) - ilmpc(m)=ilmpc(m-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=l - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gentiedmpc: increase memmpc_' - stop - endif - do k=1,nnodelem - nodempc(1,mpcfree)=nodef(k) - nodempc(2,mpcfree)=l - coefmpc(mpcfree)=-ratio(k) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) - & '*ERROR in gentiedmpc: increase memmpc_' - stop - endif - enddo - nodempc(3,mpcfreeold)=0 - enddo - endif -! - enddo - endif - enddo - enddo -! -! number of tied MPC's -! - nmpctied=nmpc-nmpctied -! - close(9) -! - return -! - 51 write(*,*) '*ERROR in openfile: could not open file ', - & 'nodes_not_connected.fbd' - stop - 52 write(*,*) '*ERROR in openfile: could not delete file ', - & 'nodes_not_connected.fbd' - stop -! - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/getnewline.f calculix-ccx-2.3/ccx_2.1/src/getnewline.f --- calculix-ccx-2.1/ccx_2.1/src/getnewline.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/getnewline.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,86 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine getnewline(inpc,textpart,istat,n,key,iline, - & ipol,inl,ipoinp,inp,ipoinpc) -! - implicit none -! - integer nentries - parameter(nentries=14) -! -! parser for the input file (original order) -! - integer istat,n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*), - & ipoinpc(0:*),i,j -! - character*1 inpc(*) - character*132 text,textpart(16) -! -! reading a new line -! - if(iline.eq.inp(2,inl)) then - if(inp(3,inl).eq.0) then -c ipoinp(1,ipol)=0 - do - ipol=ipol+1 - if(ipol.gt.nentries) then - istat=-1 - return - elseif(ipoinp(1,ipol).ne.0) then - exit - endif - enddo - inl=ipoinp(1,ipol) - iline=inp(1,inl) - else - inl=inp(3,inl) - iline=inp(1,inl) - endif - else - iline=iline+1 - endif -c text=inpc(iline) - j=0 - do i=ipoinpc(iline-1)+1,ipoinpc(iline) - j=j+1 - text(j:j)=inpc(i) - enddo - text(j+1:j+1)=' ' -! - istat=0 - key=0 -! -! only free format is supported -! - if((text(1:1).eq.'*').and.(text(2:2).ne.'*')) then - key=1 - endif -! -c write(*,*) text - call splitline(text,textpart,n) -c write(*,*) text -c write(*,*) textpart(1) -c write(*,*) textpart(2) -c write(*,*) textpart(3) -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/graph.f calculix-ccx-2.3/ccx_2.1/src/graph.f --- calculix-ccx-2.1/ccx_2.1/src/graph.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/graph.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine graph(n,ne,inpn,npn,xnpn,iadj,adj,xadj) -! -! Sloan routine (Int.J.Num.Meth.Engng 28, 2651-2679(1989)) -! - integer n,ne,nodej,nodek,mstrt,iadj,i,j,k,jstrt,jstop,lstrt,lstop, - & l,nen1,mstop,m,inpn,xnpn(ne+1),npn(inpn),adj(iadj),xadj(n+1) -! - do 5 i=1,iadj - adj(i)=0 - 5 continue - do 10 i=1,n - xadj(i)=0 - 10 continue -! - do 30 i=1,ne - jstrt=xnpn(i) - jstop=xnpn(i+1)-1 - nen1=jstop-jstrt - do 20 j=jstrt,jstop - nodej=npn(j) - xadj(nodej)=xadj(nodej)+nen1 - 20 continue - 30 continue -! - l=1 - do 40 i=1,n - l=l+xadj(i) - xadj(i)=l-xadj(i) - 40 continue - xadj(n+1)=l -! - do 90 i=1,ne - jstrt=xnpn(i) - jstop=xnpn(i+1)-1 - do 80 j=jstrt,jstop-1 - nodej=npn(j) - lstrt=xadj(nodej) - lstop=xadj(nodej+1)-1 - do 70 k=j+1,jstop - nodek=npn(k) - do 50 l=lstrt,lstop - if(adj(l).eq.nodek) go to 70 - if(adj(l).eq.0) go to 55 - 50 continue - write(6,1000) - stop - 55 continue - adj(l)=nodek - mstrt=xadj(nodek) - mstop=xadj(nodek+1)-1 - do 60 m=mstrt,mstop - if(adj(m).eq.0) go to 65 - 60 continue - write(6,1000) - stop - 65 continue - adj(m)=nodej - 70 continue - 80 continue - 90 continue -! - k=0 - jstrt=1 - do 110 i=1,n - jstop=xadj(i+1)-1 - do 100 j=jstrt,jstop - if(adj(j).eq.0) go to 105 - k=k+1 - adj(k)=adj(j) - 100 continue - 105 continue - xadj(i+1)=k+1 - jstrt=jstop+1 - 110 continue -! - 1000 format(//,1x,'***error in graph***', - & //,1x,'cannot assemble node adjacency list', - & //,1x,'check npn and xnpn arrays') - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/headings.f calculix-ccx-2.3/ccx_2.1/src/headings.f --- calculix-ccx-2.1/ccx_2.1/src/headings.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/headings.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine headings(inpc,textpart,istat,n,iline,ipol,inl,ipoinp, - & inp,ipoinpc) -! -! reading the input deck: *HEADING -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer istat,n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*), - & ipoinpc(0:*) -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((key.ne.0).or.(istat.lt.0))exit - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/heattransfers.f calculix-ccx-2.3/ccx_2.1/src/heattransfers.f --- calculix-ccx-2.1/ccx_2.1/src/heattransfers.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/heattransfers.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,266 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine heattransfers(inpc,textpart,nmethod,iperturb,isolver, - & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline,ipol, - & inl,ipoinp,inp,alpha,mei,fei,ipoinpc,ctrl,ttime) -! -! reading the input deck: *HEAT TRANSFER -! -! isolver=0: SPOOLES -! 2: iterative solver with diagonal scaling -! 3: iterative solver with Cholesky preconditioning -! 4: sgi solver -! 5: TAUCS -! 7: pardiso -! - implicit none -! - logical timereset -! - character*1 inpc(*) - character*20 solver - character*132 textpart(16) -! - integer nmethod,iperturb,isolver,istep,istat,n,key,i,idrct,nev, - & ithermal,iline,ipol,inl,ipoinp(2,*),inp(3,*),mei(4),ncv,mxiter, - & ipoinpc(0:*),idirect -! - real*8 tinc,tper,tmin,tmax,alpha,fei(3),tol,fmin,fmax,ctrl(*), - & ttime -! - tmin=0.d0 - tmax=0.d0 - nmethod=4 - alpha=0.d0 - mei(4)=0 - timereset=.false. -! - if(iperturb.eq.0) then - iperturb=2 - elseif((iperturb.eq.1).and.(istep.gt.1)) then - write(*,*) '*ERROR in heattransfers: perturbation analysis is' - write(*,*) ' not provided in a *HEAT TRANSFER step.' - stop - endif -! - if(istep.lt.1) then - write(*,*) '*ERROR in heattransfers: *HEAT TRANSFER can only' - write(*,*) ' be used within a STEP' - stop - endif -! -! default solver -! - if(isolver.eq.0) then - solver(1:7)='SPOOLES' - elseif(isolver.eq.2) then - solver(1:16)='ITERATIVESCALING' - elseif(isolver.eq.3) then - solver(1:17)='ITERATIVECHOLESKY' - elseif(isolver.eq.4) then - solver(1:3)='SGI' - elseif(isolver.eq.5) then - solver(1:5)='TAUCS' - elseif(isolver.eq.7) then - solver(1:7)='PARDISO' - endif -! - idirect=2 - do i=2,n - if(textpart(i)(1:7).eq.'SOLVER=') then - read(textpart(i)(8:27),'(a20)') solver - elseif((textpart(i)(1:6).eq.'DIRECT').and. - & (textpart(i)(1:9).ne.'DIRECT=NO')) then - idirect=1 - elseif(textpart(i)(1:9).eq.'DIRECT=NO') then - idirect=0 - elseif(textpart(i)(1:11).eq.'STEADYSTATE') then - nmethod=1 - elseif(textpart(i)(1:9).eq.'FREQUENCY') then - nmethod=2 - elseif(textpart(i)(1:12).eq.'MODALDYNAMIC') then - iperturb=0 - elseif(textpart(i)(1:11).eq.'STORAGE=YES') then - mei(4)=1 - elseif(textpart(i)(1:7).eq.'DELTMX=') then - read(textpart(i)(8:27),'(f20.0)',iostat=istat) ctrl(27) - elseif(textpart(i)(1:9).eq.'TIMERESET') then - timereset=.true. - endif - enddo - if(nmethod.eq.1) ctrl(27)=1.d30 -! -! default for modal dynamic calculations is DIRECT, -! for static or dynamic calculations DIRECT=NO -! - if(iperturb.eq.0) then - idrct=1 - if(idirect.eq.0)idrct=0 - else - idrct=0 - if(idirect.eq.1)idrct=1 - endif -! - if((ithermal.eq.0).and.(nmethod.ne.1).and. - & (nmethod.ne.2).and.(iperturb.ne.0)) then - write(*,*) '*ERROR in heattransfers: please define initial ' - write(*,*) ' conditions for the temperature' - stop - else - ithermal=2 - endif -! - if((nmethod.ne.2).and.(iperturb.ne.0)) then -! -! static or dynamic thermal analysis -! - if(solver(1:7).eq.'SPOOLES') then - isolver=0 - elseif(solver(1:16).eq.'ITERATIVESCALING') then - isolver=2 - elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then - isolver=3 - elseif(solver(1:3).eq.'SGI') then - isolver=4 - elseif(solver(1:5).eq.'TAUCS') then - isolver=5 - elseif(solver(1:7).eq.'PARDISO') then - isolver=7 - else - write(*,*) '*WARNING in heattransfers: unknown solver;' - write(*,*) ' the default solver is used' - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - if(iperturb.ge.2) then - write(*,*) '*WARNING in heattransfers: a nonlinear geomet - &ric analysis is requested' - write(*,*) ' but no time increment nor step is sp - &ecified' - write(*,*) ' the defaults (1,1) are used' - tinc=1.d0 - tper=1.d0 - tmin=1.d-5 - tmax=1.d+30 - endif - if(timereset)ttime=ttime-tper - return - endif -! - read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) tmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(4)(1:20),'(f20.0)',iostat=istat) tmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! - if(tinc.le.0.d0) then - write(*,*) '*ERROR in heattransfers: initial increment size - &is negative' - endif - if(tper.le.0.d0) then - write(*,*) '*ERROR in heattransfers: step size is negative' - endif - if(tinc.gt.tper) then - write(*,*) '*ERROR in heattransfers: initial increment size - &exceeds step size' - endif -! - if(idrct.ne.1) then - if(dabs(tmin).lt.1.d-10) then - tmin=min(tinc,1.d-5*tper) - endif - if(dabs(tmax).lt.1.d-10) then - tmax=1.d+30 - endif - endif - elseif(nmethod.eq.2) then -! -! thermal eigenmode analysis -! - iperturb=0 -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*)'*ERROR in heattransfers: definition not complete' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - read(textpart(1)(1:10),'(i10)',iostat=istat) nev - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(nev.le.0) then - write(*,*) '*ERROR in frequencies: less than 1 eigenvalue re - &quested' - stop - endif - tol=1.d-2 - ncv=4*nev - ncv=ncv+nev - mxiter=1000 - read(textpart(2)(1:20),'(f20.0)',iostat=istat) fmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) fmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! - mei(1)=nev - mei(2)=ncv - mei(3)=mxiter - fei(1)=tol - fei(2)=fmin - fei(3)=fmax - else -! -! modal dynamic analysis for variables which satisfy the -! Helmholtz equation -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*)'*ERROR in heattransfers: definition not complete' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif -! - if(timereset)ttime=ttime-tper -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/hybsvd.f calculix-ccx-2.3/ccx_2.1/src/hybsvd.f --- calculix-ccx-2.1/ccx_2.1/src/hybsvd.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/hybsvd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1010 +0,0 @@ - SUBROUTINE HYBSVD(NA, NU, NV, NZ, NB, M, N, A, W, MATU, U, MATV, - * V, Z, B, IRHS, IERR, RV1) - INTEGER NA, NU, NV, NZ, M, N, IRHS, IERR, MIN0 - REAL*8 A(NA,1), W(1), U(NU,1), V(NV,1), Z(NZ,1), B(NB,IRHS) - REAL*8 RV1(1) - LOGICAL MATU, MATV -C -C THIS ROUTINE IS A MODIFICATION OF THE GOLUB-REINSCH PROCEDURE (1) -C T -C FOR COMPUTING THE SINGULAR VALUE DECOMPOSITION A = UWV OF A -C REAL M BY N RECTANGULAR MATRIX. U IS M BY MIN(M,N) CONTAINING -C THE LEFT SINGULAR VECTORS, W IS A MIN(M,N) BY MIN(M,N) DIAGONAL -C MATRIX CONTAINING THE SINGULAR VALUES, AND V IS N BY MIN(M,N) -C CONTAINING THE RIGHT SINGULAR VECTORS. -C -C THE ALGORITHM IMPLEMENTED IN THIS -C ROUTINE HAS A HYBRID NATURE. WHEN M IS APPROXIMATELY EQUAL TO N, -C THE GOLUB-REINSCH ALGORITHM IS USED, BUT WHEN EITHER OF THE RATIOS -C M/N OR N/M IS GREATER THAN ABOUT 2, -C A MODIFIED VERSION OF THE GOLUB-REINSCH -C ALGORITHM IS USED. THIS MODIFIED ALGORITHM FIRST TRANSFORMS A -C T -C INTO UPPER TRIANGULAR FORM BY HOUSEHOLDER TRANSFORMATIONS L -C AND THEN USES THE GOLUB-REINSCH ALGORITHM TO FIND THE SINGULAR -C VALUE DECOMPOSITION OF THE RESULTING UPPER TRIANGULAR MATRIX R. -C WHEN U IS NEEDED EXPLICITLY IN THE CASE M.GE.N (OR V IN THE CASE -C M.LT.N), AN EXTRA ARRAY Z (OF SIZE AT LEAST -C MIN(M,N)**2) IS NEEDED, BUT OTHERWISE Z IS NOT REFERENCED -C AND NO EXTRA STORAGE IS REQUIRED. THIS HYBRID METHOD -C SHOULD BE MORE EFFICIENT THAN THE GOLUB-REINSCH ALGORITHM WHEN -C M/N OR N/M IS LARGE. FOR DETAILS, SEE (2). -C -C WHEN M .GE. N, -C HYBSVD CAN ALSO BE USED TO COMPUTE THE MINIMAL LENGTH LEAST -C SQUARES SOLUTION TO THE OVERDETERMINED LINEAR SYSTEM A*X=B. -C IF M .LT. N (I.E. FOR UNDERDETERMINED SYSTEMS), THE RHS B -C IS NOT PROCESSED. -C -C NOTICE THAT THE SINGULAR VALUE DECOMPOSITION OF A MATRIX -C IS UNIQUE ONLY UP TO THE SIGN OF THE CORRESPONDING COLUMNS -C OF U AND V. -C -C THIS ROUTINE HAS BEEN CHECKED BY THE PFORT VERIFIER (3) FOR -C ADHERENCE TO A LARGE, CAREFULLY DEFINED, PORTABLE SUBSET OF -C AMERICAN NATIONAL STANDARD FORTRAN CALLED PFORT. -C -C REFERENCES: -C -C (1) GOLUB,G.H. AND REINSCH,C. (1970) 'SINGULAR VALUE -C DECOMPOSITION AND LEAST SQUARES SOLUTIONS,' -C NUMER. MATH. 14,403-420, 1970. -C -C (2) CHAN,T.F. (1982) 'AN IMPROVED ALGORITHM FOR COMPUTING -C THE SINGULAR VALUE DECOMPOSITION,' ACM TOMS, VOL.8, -C NO. 1, MARCH, 1982. -C -C (3) RYDER,B.G. (1974) 'THE PFORT VERIFIER,' SOFTWARE - -C PRACTICE AND EXPERIENCE, VOL.4, 359-377, 1974. -C -C ON INPUT: -C -C NA MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY PARAMETER A AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. NOTE THAT NA MUST BE AT LEAST -C AS LARGE AS M. -C -C NU MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY U AS DECLARED IN THE CALLING PROGRAM DIMENSION -C STATEMENT. NU MUST BE AT LEAST AS LARGE AS M. -C -C NV MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY PARAMETER V AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. NV MUST BE AT LEAST AS LARGE AS N. -C -C NZ MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY PARAMETER Z AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. NOTE THAT NZ MUST BE AT LEAST -C AS LARGE AS MIN(M,N). -C -C NB MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY PARAMETER B AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. NB MUST BE AT LEAST AS LARGE AS M. -C -C M IS THE NUMBER OF ROWS OF A (AND U). -C -C N IS THE NUMBER OF COLUMNS OF A (AND NUMBER OF ROWS OF V). -C -C A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED. -C -C B CONTAINS THE IRHS RIGHT-HAND-SIDES OF THE OVERDETERMINED -C LINEAR SYSTEM A*X=B. IF IRHS .GT. 0 AND M .GE. N, -C THEN ON OUTPUT, THE FIRST N COMPONENTS OF THESE IRHS COLUMNS -C T -C WILL CONTAIN U B. THUS, TO COMPUTE THE MINIMAL LENGTH LEAST -C + -C SQUARES SOLUTION, ONE MUST COMPUTE V*W TIMES THE COLUMNS OF -C + + -C B, WHERE W IS A DIAGONAL MATRIX, W (I)=0 IF W(I) IS -C NEGLIGIBLE, OTHERWISE IS 1/W(I). IF IRHS=0 OR M.LT.N, -C B IS NOT REFERENCED. -C -C IRHS IS THE NUMBER OF RIGHT-HAND-SIDES OF THE OVERDETERMINED -C SYSTEM A*X=B. IRHS SHOULD BE SET TO ZERO IF ONLY THE SINGULAR -C VALUE DECOMPOSITION OF A IS DESIRED. -C -C MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE -C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. -C -C MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE -C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. -C -C WHEN HYBSVD IS USED TO COMPUTE THE MINIMAL LENGTH LEAST -C SQUARES SOLUTION TO AN OVERDETERMINED SYSTEM, MATU SHOULD -C BE SET TO .FALSE. , AND MATV SHOULD BE SET TO .TRUE. . -C -C ON OUTPUT: -C -C A IS UNALTERED (UNLESS OVERWRITTEN BY U OR V). -C -C W CONTAINS THE (NON-NEGATIVE) SINGULAR VALUES OF A (THE -C DIAGONAL ELEMENTS OF W). THEY ARE SORTED IN DESCENDING -C ORDER. IF AN ERROR EXIT IS MADE, THE SINGULAR VALUES -C SHOULD BE CORRECT AND SORTED FOR INDICES IERR+1,...,MIN(M,N). -C -C U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE -C DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE. IF MATU IS -C FALSE, THEN U IS EITHER USED AS A TEMPORARY STORAGE (IF -C M .GE. N) OR NOT REFERENCED (IF M .LT. N). -C U MAY COINCIDE WITH A IN THE CALLING SEQUENCE. -C IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING -C TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT. -C -C V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF -C MATV HAS BEEN SET TO .TRUE. IF MATV IS -C FALSE, THEN V IS EITHER USED AS A TEMPORARY STORAGE (IF -C M .LT. N) OR NOT REFERENCED (IF M .GE. N). -C IF M .GE. N, V MAY ALSO COINCIDE WITH A. IF AN ERROR -C EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO INDICES OF -C CORRECT SINGULAR VALUES SHOULD BE CORRECT. -C -C Z CONTAINS THE MATRIX X IN THE SINGULAR VALUE DECOMPOSITION -C T -C OF R=XSY, IF THE MODIFIED ALGORITHM IS USED. IF THE -C GOLUB-REINSCH PROCEDURE IS USED, THEN IT IS NOT REFERENCED. -C IF MATU HAS BEEN SET TO .FALSE. IN THE CASE M.GE.N (OR -C MATV SET TO .FALSE. IN THE CASE M.LT.N), THEN Z IS NOT -C REFERENCED AND NO EXTRA STORAGE IS REQUIRED. -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C K IF THE K-TH SINGULAR VALUE HAS NOT BEEN -C DETERMINED AFTER 30 ITERATIONS. -C -1 IF IRHS .LT. 0 . -C -2 IF M .LT. 1 .OR. N .LT. 1 -C -3 IF NA .LT. M .OR. NU .LT. M .OR. NB .LT. M. -C -4 IF NV .LT. N . -C -5 IF NZ .LT. MIN(M,N). -C -C RV1 IS A TEMPORARY STORAGE ARRAY OF LENGTH AT LEAST MIN(M,N). -C -C PROGRAMMED BY : TONY CHAN -C BOX 2158, YALE STATION, -C COMPUTER SCIENCE DEPT, YALE UNIV., -C NEW HAVEN, CT 06520. -C LAST MODIFIED : JANUARY, 1982. -C -C HYBSVD USES THE FOLLOWING FUNCTIONS AND SUBROUTINES. -C INTERNAL GRSVD, MGNSVD, SRELPR -C FORTRAN MIN0,DABS,DSQRT,DFLOAT,DSIGN,DMAX1 -C BLAS SSWAP -C -C ----------------------------------------------------------------- -C ERROR CHECK. -C - IERR = 0 - IF (IRHS.GE.0) GO TO 10 - IERR = -1 - RETURN - 10 IF (M.GE.1 .AND. N.GE.1) GO TO 20 - IERR = -2 - RETURN - 20 IF (NA.GE.M .AND. NU.GE.M .AND. NB.GE.M) GO TO 30 - IERR = -3 - RETURN - 30 IF (NV.GE.N) GO TO 40 - IERR = -4 - RETURN - 40 IF (NZ.GE.MIN0(M,N)) GO TO 50 - IERR = -5 - RETURN - 50 CONTINUE -C -C FIRST COPIES A INTO EITHER U OR V ACCORDING TO WHETHER -C M .GE. N OR M .LT. N, AND THEN CALLS SUBROUTINE MGNSVD -C WHICH ASSUMES THAT NUMBER OF ROWS .GE. NUMBER OF COLUMNS. -C - IF (M.LT.N) GO TO 80 -C -C M .GE. N CASE. -C - DO 70 I=1,M - DO 60 J=1,N - U(I,J) = A(I,J) - 60 CONTINUE - 70 CONTINUE -C - CALL MGNSVD(NU, NV, NZ, NB, M, N, W, MATU, U, MATV, V, Z, B, - * IRHS, IERR, RV1) - RETURN -C - 80 CONTINUE -C T -C M .LT. N CASE. COPIES A INTO V. -C - DO 100 I=1,M - DO 90 J=1,N - V(J,I) = A(I,J) - 90 CONTINUE - 100 CONTINUE - CALL MGNSVD(NV, NU, NZ, NB, N, M, W, MATV, V, MATU, U, Z, B, 0, - * IERR, RV1) - RETURN - END -C MGN 10 - SUBROUTINE MGNSVD(NU, NV, NZ, NB, M, N, W, MATU, U, MATV, V, Z, MGN 20 - * B, IRHS, IERR, RV1) -C -C THE DESCRIPTION OF SUBROUTINE MGNSVD IS ALMOST IDENTICAL -C TO THAT FOR SUBROUTINE HYBSVD ABOVE, WITH THE EXCEPTION -C THAT MGNSVD ASSUMES M .GE. N. -C IT ALSO ASSUMES THAT A COPY OF THE MATRIX A IS IN THE ARRAY U. -C - INTEGER NU, NV, NZ, M, N, IRHS, IERR, IP1, I, J, K, IM1, IBACK - REAL*8 W(1), U(NU,1), V(NV,1), Z(NZ,1), B(NB,IRHS), RV1(1) - REAL*8 XOVRPT, C, R, G, SCALE, DSIGN, DABS, DSQRT, F, S, H - REAL*8 DFLOAT - LOGICAL MATU, MATV -C -C SET VALUE FOR C. THE VALUE FOR C DEPENDS ON THE RELATIVE -C EFFICIENCY OF FLOATING POINT MULTIPLICATIONS, FLOATING POINT -C ADDITIONS AND TWO-DIMENSIONAL ARRAY INDEXINGS ON THE -C COMPUTER WHERE THIS SUBROUTINE IS TO BE RUN. C SHOULD -C USUALLY BE BETWEEN 2 AND 4. FOR DETAILS ON CHOOSING C, SEE -C (2). THE ALGORITHM IS NOT SENSITIVE TO THE VALUE OF C -C ACTUALLY USED AS LONG AS C IS BETWEEN 2 AND 4. -C - C = 4.d0 -C -C DETERMINE CROSS-OVER POINT -C - IF (MATU .AND. MATV) XOVRPT = (C+7.d0/3.d0)/C - IF (MATU .AND. .NOT.MATV) XOVRPT = (C+7.d0/3.d0)/C - IF (.NOT.MATU .AND. MATV) XOVRPT = 5.d0/3.d0 - IF (.NOT.MATU .AND. .NOT.MATV) XOVRPT = 5.d0/3.d0 -C -C DETERMINE WHETHER TO USE GOLUB-REINSCH OR THE MODIFIED -C ALGORITHM. -C - R = DFLOAT(M)/DFLOAT(N) - IF (R.GE.XOVRPT) GO TO 10 -C -C USE GOLUB-REINSCH PROCEDURE -C - CALL GRSVD(NU, NV, NB, M, N, W, MATU, U, MATV, V, B, IRHS, IERR, - * RV1) - GO TO 330 -C -C USE MODIFIED ALGORITHM -C - 10 CONTINUE -C -C TRIANGULARIZE U BY HOUSEHOLDER TRANSFORMATIONS, USING -C W AND RV1 AS TEMPORARY STORAGE. -C - DO 110 I=1,N - G = 0.d0 - S = 0.d0 - SCALE = 0.d0 -C -C PERFORM SCALING OF COLUMNS TO AVOID UNNECSSARY OVERFLOW -C OR UNDERFLOW -C - DO 20 K=I,M - SCALE = SCALE + DABS(U(K,I)) - 20 CONTINUE - IF (SCALE.EQ.0.d0) GO TO 110 - DO 30 K=I,M - U(K,I) = U(K,I)/SCALE - S = S + U(K,I)*U(K,I) - 30 CONTINUE -C -C THE VECTOR E OF THE HOUSEHOLDER TRANSFORMATION I + EE'/H -C WILL BE STORED IN COLUMN I OF U. THE TRANSFORMED ELEMENT -C U(I,I) WILL BE STORED IN W(I) AND THE SCALAR H IN -C RV1(I). -C - F = U(I,I) - G = -DSIGN(DSQRT(S),F) - H = F*G - S - U(I,I) = F - G - RV1(I) = H - W(I) = SCALE*G -C - IF (I.EQ.N) GO TO 70 -C -C APPLY TRANSFORMATIONS TO REMAINING COLUMNS OF A -C - IP1 = I + 1 - DO 60 J=IP1,N - S = 0.d0 - DO 40 K=I,M - S = S + U(K,I)*U(K,J) - 40 CONTINUE - F = S/H - DO 50 K=I,M - U(K,J) = U(K,J) + F*U(K,I) - 50 CONTINUE - 60 CONTINUE -C -C APPLY TRANSFORMATIONS TO COLUMNS OF B IF IRHS .GT. 0 -C - 70 IF (IRHS.EQ.0) GO TO 110 - DO 100 J=1,IRHS - S = 0.d0 - DO 80 K=I,M - S = S + U(K,I)*B(K,J) - 80 CONTINUE - F = S/H - DO 90 K=I,M - B(K,J) = B(K,J) + F*U(K,I) - 90 CONTINUE - 100 CONTINUE - 110 CONTINUE -C -C COPY R INTO Z IF MATU = .TRUE. -C - IF (.NOT.MATU) GO TO 290 - DO 130 I=1,N - DO 120 J=I,N - Z(J,I) = 0.d0 - Z(I,J) = U(I,J) - 120 CONTINUE - Z(I,I) = W(I) - 130 CONTINUE -C -C ACCUMULATE HOUSEHOLDER TRANSFORMATIONS IN U -C - DO 240 IBACK=1,N - I = N - IBACK + 1 - IP1 = I + 1 - G = W(I) - H = RV1(I) - IF (I.EQ.N) GO TO 150 -C - DO 140 J=IP1,N - U(I,J) = 0.d0 - 140 CONTINUE -C - 150 IF (H.EQ.0.d0) GO TO 210 - IF (I.EQ.N) GO TO 190 -C - DO 180 J=IP1,N - S = 0.d0 - DO 160 K=IP1,M - S = S + U(K,I)*U(K,J) - 160 CONTINUE - F = S/H - DO 170 K=I,M - U(K,J) = U(K,J) + F*U(K,I) - 170 CONTINUE - 180 CONTINUE -C - 190 S = U(I,I)/H - DO 200 J=I,M - U(J,I) = U(J,I)*S - 200 CONTINUE - GO TO 230 -C - 210 DO 220 J=I,M - U(J,I) = 0.d0 - 220 CONTINUE - 230 U(I,I) = U(I,I) + 1.d0 - 240 CONTINUE -C -C COMPUTE SVD OF R (WHICH IS STORED IN Z) -C - CALL GRSVD(NZ, NV, NB, N, N, W, MATU, Z, MATV, V, B, IRHS, IERR, - * RV1) -C -C T -C FORM L*X TO OBTAIN U (WHERE R=XWY ). X IS RETURNED IN Z -C BY GRSVD. THE MATRIX MULTIPLY IS DONE ONE ROW AT A TIME, -C USING RV1 AS SCRATCH SPACE. -C - DO 280 I=1,M - DO 260 J=1,N - S = 0.d0 - DO 250 K=1,N - S = S + U(I,K)*Z(K,J) - 250 CONTINUE - RV1(J) = S - 260 CONTINUE - DO 270 J=1,N - U(I,J) = RV1(J) - 270 CONTINUE - 280 CONTINUE - GO TO 330 -C -C FORM R IN U BY ZEROING THE LOWER TRIANGULAR PART OF R IN U -C - 290 IF (N.EQ.1) GO TO 320 - DO 310 I=2,N - IM1 = I - 1 - DO 300 J=1,IM1 - U(I,J) = 0.d0 - 300 CONTINUE - U(I,I) = W(I) - 310 CONTINUE - 320 U(1,1) = W(1) -C - CALL GRSVD(NU, NV, NB, N, N, W, MATU, U, MATV, V, B, IRHS, IERR, - * RV1) - 330 CONTINUE - IERRP1 = IERR + 1 - IF (IERR.LT.0 .OR. N.LE.1 .OR. IERRP1.EQ.N) RETURN -C -C SORT SINGULAR VALUES AND EXCHANGE COLUMNS OF U AND V ACCORDINGLY. -C SELECTION SORT MINIMIZES SWAPPING OF U AND V. -C - NM1 = N - 1 - DO 360 I=IERRP1,NM1 -C... FIND INDEX OF MAXIMUM SINGULAR VALUE - ID = I - IP1 = I + 1 - DO 340 J=IP1,N - IF (W(J).GT.W(ID)) ID = J - 340 CONTINUE - IF (ID.EQ.I) GO TO 360 -C... SWAP SINGULAR VALUES AND VECTORS - T = W(I) - W(I) = W(ID) - W(ID) = T - IF (MATV) CALL SSWAP(N, V(1,I), 1, V(1,ID), 1) - IF (MATU) CALL SSWAP(M, U(1,I), 1, U(1,ID), 1) - IF (IRHS.LT.1) GO TO 360 - DO 350 KRHS=1,IRHS - T = B(I,KRHS) - B(I,KRHS) = B(ID,KRHS) - B(ID,KRHS) = T - 350 CONTINUE - 360 CONTINUE - RETURN -C ************** LAST CARD OF HYBSVD ***************** - END - SUBROUTINE GRSVD(NU, NV, NB, M, N, W, MATU, U, MATV, V, B, IRHS, GRS 10 - * IERR, RV1) -C - INTEGER I, J, K, L, M, N, II, I1, KK, K1, LL, L1, MN, NU, NV, NB, - * ITS, IERR, IRHS - REAL*8 W(1), U(NU,1), V(NV,1), B(NB,IRHS), RV1(1) - REAL*8 C, F, G, H, S, X, Y, Z, EPS, SCALE, SRELPR, DUMMY - REAL*8 DSQRT, DMAX1, DABS, DSIGN - LOGICAL MATU, MATV -C -C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE SVD, -C NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH. -C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). -C -C THIS SUBROUTINE DETERMINES THE SINGULAR VALUE DECOMPOSITION -C T -C A=USV OF A REAL M BY N RECTANGULAR MATRIX. HOUSEHOLDER -C BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED. -C GRSVD ASSUMES THAT A COPY OF THE MATRIX A IS IN THE ARRAY U. IT -C ALSO ASSUMES M .GE. N. IF M .LT. N, THEN COMPUTE THE SINGULAR -C T T T T -C VALUE DECOMPOSITION OF A . IF A =UWV , THEN A=VWU . -C -C GRSVD CAN ALSO BE USED TO COMPUTE THE MINIMAL LENGTH LEAST SQUARES -C SOLUTION TO THE OVERDETERMINED LINEAR SYSTEM A*X=B. -C -C ON INPUT- -C -C NU MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS U AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. NOTE THAT NU MUST BE AT LEAST -C AS LARGE AS M, -C -C NV MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL -C ARRAY PARAMETER V AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. NV MUST BE AT LEAST AS LARGE AS N, -C -C NB MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL -C ARRAY PARAMETERS B AS DECLARED IN THE CALLING PROGRAM -C DIMENSION STATEMENT. NOTE THAT NB MUST BE AT LEAST -C AS LARGE AS M, -C -C M IS THE NUMBER OF ROWS OF A (AND U), -C -C N IS THE NUMBER OF COLUMNS OF A (AND U) AND THE ORDER OF V, -C -C A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED, -C -C B CONTAINS THE IRHS RIGHT-HAND-SIDES OF THE OVERDETERMINED -C LINEAR SYSTEM A*X=B. IF IRHS .GT. 0, THEN ON OUTPUT, -C THE FIRST N COMPONENTS OF THESE IRHS COLUMNS OF B -C T -C WILL CONTAIN U B. THUS, TO COMPUTE THE MINIMAL LENGTH LEAST -C + -C SQUARES SOLUTION, ONE MUST COMPUTE V*W TIMES THE COLUMNS OF -C + + -C B, WHERE W IS A DIAGONAL MATRIX, W (I)=0 IF W(I) IS -C NEGLIGIBLE, OTHERWISE IS 1/W(I). IF IRHS=0, B MAY COINCIDE -C WITH A OR U AND WILL NOT BE REFERENCED, -C -C IRHS IS THE NUMBER OF RIGHT-HAND-SIDES OF THE OVERDETERMINED -C SYSTEM A*X=B. IRHS SHOULD BE SET TO ZERO IF ONLY THE SINGULA -C VALUE DECOMPOSITION OF A IS DESIRED, -C -C MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE -C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE, -C -C MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE -C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. -C -C ON OUTPUT- -C -C W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE -C DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN -C ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT -C FOR INDICES IERR+1,IERR+2,...,N, -C -C U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE -C DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE. OTHERWISE -C U IS USED AS A TEMPORARY ARRAY. -C IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING -C TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT, -C -C V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF -C MATV HAS BEEN SET TO .TRUE. OTHERWISE V IS NOT REFERENCED. -C IF AN ERROR EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO -C INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT, -C -C IERR IS SET TO -C ZERO FOR NORMAL RETURN, -C K IF THE K-TH SINGULAR VALUE HAS NOT BEEN -C DETERMINED AFTER 30 ITERATIONS, -C -1 IF IRHS .LT. 0 , -C -2 IF M .LT. N , -C -3 IF NU .LT. M .OR. NB .LT. M, -C -4 IF NV .LT. N . -C -C RV1 IS A TEMPORARY STORAGE ARRAY. -C -C THIS SUBROUTINE HAS BEEN CHECKED BY THE PFORT VERIFIER -C (RYDER, B.G. 'THE PFORT VERIFIER', SOFTWARE - PRACTICE AND -C EXPERIENCE, VOL.4, 359-377, 1974) FOR ADHERENCE TO A LARGE, -C CAREFULLY DEFINED, PORTABLE SUBSET OF AMERICAN NATIONAL STANDAR -C FORTRAN CALLED PFORT. -C -C ORIGINAL VERSION OF THIS CODE IS SUBROUTINE SVD IN RELEASE 2 OF -C EISPACK. -C -C MODIFIED BY TONY F. CHAN, -C COMP. SCI. DEPT, YALE UNIV., -C BOX 2158, YALE STATION, -C CT 06520 -C LAST MODIFIED : JANUARY, 1982. -C -C ------------------------------------------------------------------ -C -C ********** SRELPR IS A MACHINE-DEPENDENT FUNCTION SPECIFYING -C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. -C -C ********** -C - IERR = 0 - IF (IRHS.GE.0) GO TO 10 - IERR = -1 - RETURN - 10 IF (M.GE.N) GO TO 20 - IERR = -2 - RETURN - 20 IF (NU.GE.M .AND. NB.GE.M) GO TO 30 - IERR = -3 - RETURN - 30 IF (NV.GE.N) GO TO 40 - IERR = -4 - RETURN - 40 CONTINUE -C -C ********** HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM ********** - G = 0.d0 - SCALE = 0.d0 - X = 0.d0 -C - DO 260 I=1,N - L = I + 1 - RV1(I) = SCALE*G - G = 0.d0 - S = 0.d0 - SCALE = 0.d0 -C -C COMPUTE LEFT TRANSFORMATIONS THAT ZERO THE SUBDIAGONAL ELEMENTS -C OF THE I-TH COLUMN. -C - DO 50 K=I,M - SCALE = SCALE + DABS(U(K,I)) - 50 CONTINUE -C - IF (SCALE.EQ.0.d0) GO TO 160 -C - DO 60 K=I,M - U(K,I) = U(K,I)/SCALE - S = S + U(K,I)**2 - 60 CONTINUE -C - F = U(I,I) - G = -DSIGN(DSQRT(S),F) - H = F*G - S - U(I,I) = F - G - IF (I.EQ.N) GO TO 100 -C -C APPLY LEFT TRANSFORMATIONS TO REMAINING COLUMNS OF A. -C - DO 90 J=L,N - S = 0.d0 -C - DO 70 K=I,M - S = S + U(K,I)*U(K,J) - 70 CONTINUE -C - F = S/H -C - DO 80 K=I,M - U(K,J) = U(K,J) + F*U(K,I) - 80 CONTINUE - 90 CONTINUE -C -C APPLY LEFT TRANSFORMATIONS TO THE COLUMNS OF B IF IRHS .GT. 0 -C - 100 IF (IRHS.EQ.0) GO TO 140 - DO 130 J=1,IRHS - S = 0.d0 - DO 110 K=I,M - S = S + U(K,I)*B(K,J) - 110 CONTINUE - F = S/H - DO 120 K=I,M - B(K,J) = B(K,J) + F*U(K,I) - 120 CONTINUE - 130 CONTINUE -C -C COMPUTE RIGHT TRANSFORMATIONS. -C - 140 DO 150 K=I,M - U(K,I) = SCALE*U(K,I) - 150 CONTINUE -C - 160 W(I) = SCALE*G - G = 0.d0 - S = 0.d0 - SCALE = 0.d0 - IF (I.GT.M .OR. I.EQ.N) GO TO 250 -C - DO 170 K=L,N - SCALE = SCALE + DABS(U(I,K)) - 170 CONTINUE -C - IF (SCALE.EQ.0.d0) GO TO 250 -C - DO 180 K=L,N - U(I,K) = U(I,K)/SCALE - S = S + U(I,K)**2 - 180 CONTINUE -C - F = U(I,L) - G = -DSIGN(DSQRT(S),F) - H = F*G - S - U(I,L) = F - G -C - DO 190 K=L,N - RV1(K) = U(I,K)/H - 190 CONTINUE -C - IF (I.EQ.M) GO TO 230 -C - DO 220 J=L,M - S = 0.d0 -C - DO 200 K=L,N - S = S + U(J,K)*U(I,K) - 200 CONTINUE -C - DO 210 K=L,N - U(J,K) = U(J,K) + S*RV1(K) - 210 CONTINUE - 220 CONTINUE -C - 230 DO 240 K=L,N - U(I,K) = SCALE*U(I,K) - 240 CONTINUE -C - 250 X = DMAX1(X,DABS(W(I))+DABS(RV1(I))) - 260 CONTINUE -C ********** ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS ********** - IF (.NOT.MATV) GO TO 350 -C ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** - DO 340 II=1,N - I = N + 1 - II - IF (I.EQ.N) GO TO 330 - IF (G.EQ.0.d0) GO TO 310 -C - DO 270 J=L,N -C ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** - V(J,I) = (U(I,J)/U(I,L))/G - 270 CONTINUE -C - DO 300 J=L,N - S = 0.d0 -C - DO 280 K=L,N - S = S + U(I,K)*V(K,J) - 280 CONTINUE -C - DO 290 K=L,N - V(K,J) = V(K,J) + S*V(K,I) - 290 CONTINUE - 300 CONTINUE -C - 310 DO 320 J=L,N - V(I,J) = 0.d0 - V(J,I) = 0.d0 - 320 CONTINUE -C - 330 V(I,I) = 1.d0 - G = RV1(I) - L = I - 340 CONTINUE -C ********** ACCUMULATION OF LEFT-HAND TRANSFORMATIONS ********** - 350 IF (.NOT.MATU) GO TO 470 -C **********FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- ********** - MN = N - IF (M.LT.N) MN = M -C - DO 460 II=1,MN - I = MN + 1 - II - L = I + 1 - G = W(I) - IF (I.EQ.N) GO TO 370 -C - DO 360 J=L,N - U(I,J) = 0.d0 - 360 CONTINUE -C - 370 IF (G.EQ.0.d0) GO TO 430 - IF (I.EQ.MN) GO TO 410 -C - DO 400 J=L,N - S = 0.d0 -C - DO 380 K=L,M - S = S + U(K,I)*U(K,J) - 380 CONTINUE -C ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** - F = (S/U(I,I))/G -C - DO 390 K=I,M - U(K,J) = U(K,J) + F*U(K,I) - 390 CONTINUE - 400 CONTINUE -C - 410 DO 420 J=I,M - U(J,I) = U(J,I)/G - 420 CONTINUE -C - GO TO 450 -C - 430 DO 440 J=I,M - U(J,I) = 0.d0 - 440 CONTINUE -C - 450 U(I,I) = U(I,I) + 1.d0 - 460 CONTINUE -C ********** DIAGONALIZATION OF THE BIDIAGONAL FORM ********** - 470 EPS = SRELPR(DUMMY)*X -C ********** FOR K=N STEP -1 UNTIL 1 DO -- ********** - DO 650 KK=1,N - K1 = N - KK - K = K1 + 1 - ITS = 0 -C ********** TEST FOR SPLITTING. -C FOR L=K STEP -1 UNTIL 1 DO -- ********** - 480 DO 490 LL=1,K - L1 = K - LL - L = L1 + 1 - IF (DABS(RV1(L)).LE.EPS) GO TO 550 -C ********** RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT -C THROUGH THE BOTTOM OF THE LOOP ********** - IF (DABS(W(L1)).LE.EPS) GO TO 500 - 490 CONTINUE -C ********** CANCELLATION OF RV1(L) IF L GREATER THAN 1 ********** - 500 C = 0.d0 - S = 1.d0 -C - DO 540 I=L,K - F = S*RV1(I) - RV1(I) = C*RV1(I) - IF (DABS(F).LE.EPS) GO TO 550 - G = W(I) - H = DSQRT(F*F+G*G) - W(I) = H - C = G/H - S = -F/H -C -C APPLY LEFT TRANSFORMATIONS TO B IF IRHS .GT. 0 -C - IF (IRHS.EQ.0) GO TO 520 - DO 510 J=1,IRHS - Y = B(L1,J) - Z = B(I,J) - B(L1,J) = Y*C + Z*S - B(I,J) = -Y*S + Z*C - 510 CONTINUE - 520 CONTINUE -C - IF (.NOT.MATU) GO TO 540 -C - DO 530 J=1,M - Y = U(J,L1) - Z = U(J,I) - U(J,L1) = Y*C + Z*S - U(J,I) = -Y*S + Z*C - 530 CONTINUE -C - 540 CONTINUE -C ********** TEST FOR CONVERGENCE ********** - 550 Z = W(K) - IF (L.EQ.K) GO TO 630 -C ********** SHIFT FROM BOTTOM 2 BY 2 MINOR ********** - IF (ITS.EQ.30) GO TO 660 - ITS = ITS + 1 - X = W(L) - Y = W(K1) - G = RV1(K1) - H = RV1(K) - F = ((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.d0*H*Y) - G = DSQRT(F*F+1.0) - F = ((X-Z)*(X+Z)+H*(Y/(F+DSIGN(G,F))-H))/X -C ********** NEXT QR TRANSFORMATION ********** - C = 1.0 - S = 1.0 -C - DO 620 I1=L,K1 - I = I1 + 1 - G = RV1(I) - Y = W(I) - H = S*G - G = C*G - Z = DSQRT(F*F+H*H) - RV1(I1) = Z - C = F/Z - S = H/Z - F = X*C + G*S - G = -X*S + G*C - H = Y*S - Y = Y*C - IF (.NOT.MATV) GO TO 570 -C - DO 560 J=1,N - X = V(J,I1) - Z = V(J,I) - V(J,I1) = X*C + Z*S - V(J,I) = -X*S + Z*C - 560 CONTINUE -C - 570 Z = DSQRT(F*F+H*H) - W(I1) = Z -C ********** ROTATION CAN BE ARBITRARY IF Z IS ZERO ********** - IF (Z.EQ.0.d0) GO TO 580 - C = F/Z - S = H/Z - 580 F = C*G + S*Y - X = -S*G + C*Y -C -C APPLY LEFT TRANSFORMATIONS TO B IF IRHS .GT. 0 -C - IF (IRHS.EQ.0) GO TO 600 - DO 590 J=1,IRHS - Y = B(I1,J) - Z = B(I,J) - B(I1,J) = Y*C + Z*S - B(I,J) = -Y*S + Z*C - 590 CONTINUE - 600 CONTINUE -C - IF (.NOT.MATU) GO TO 620 -C - DO 610 J=1,M - Y = U(J,I1) - Z = U(J,I) - U(J,I1) = Y*C + Z*S - U(J,I) = -Y*S + Z*C - 610 CONTINUE -C - 620 CONTINUE -C - RV1(L) = 0.d0 - RV1(K) = F - W(K) = X - GO TO 480 -C ********** CONVERGENCE ********** - 630 IF (Z.GE.0.d0) GO TO 650 -C ********** W(K) IS MADE NON-NEGATIVE ********** - W(K) = -Z - IF (.NOT.MATV) GO TO 650 -C - DO 640 J=1,N - V(J,K) = -V(J,K) - 640 CONTINUE -C - 650 CONTINUE -C - GO TO 670 -C ********** SET ERROR -- NO CONVERGENCE TO A -C SINGULAR VALUE AFTER 30 ITERATIONS ********** - 660 IERR = K - 670 RETURN -C ********** LAST CARD OF GRSVD ********** - END - SUBROUTINE SSWAP(N, SX, INCX, SY, INCY) SSW 10 -C -C INTERCHANGES TWO VECTORS. -C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO 1. -C JACK DONGARRA, LINPACK, 3/11/78. -C - REAL*8 SX(1), SY(1), STEMP - INTEGER I, INCX, INCY, IX, IY, M, MP1, N -C - IF (N.LE.0) RETURN - IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20 -C -C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL -C TO 1 -C - IX = 1 - IY = 1 - IF (INCX.LT.0) IX = (-N+1)*INCX + 1 - IF (INCY.LT.0) IY = (-N+1)*INCY + 1 - DO 10 I=1,N - STEMP = SX(IX) - SX(IX) = SY(IY) - SY(IY) = STEMP - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C CODE FOR BOTH INCREMENTS EQUAL TO 1 -C -C -C CLEAN-UP LOOP -C - 20 M = MOD(N,3) - IF (M.EQ.0) GO TO 40 - DO 30 I=1,M - STEMP = SX(I) - SX(I) = SY(I) - SY(I) = STEMP - 30 CONTINUE - IF (N.LT.3) RETURN - 40 MP1 = M + 1 - DO 50 I=MP1,N,3 - STEMP = SX(I) - SX(I) = SY(I) - SY(I) = STEMP - STEMP = SX(I+1) - SX(I+1) = SY(I+1) - SY(I+1) = STEMP - STEMP = SX(I+2) - SX(I+2) = SY(I+2) - SY(I+2) = STEMP - 50 CONTINUE - RETURN - END - REAL*8 FUNCTION SRELPR(DUMMY) SRE 10 - REAL*8 DUMMY -C -C SRELPR COMPUTES THE RELATIVE PRECISION OF THE FLOATING POINT -C ARITHMETIC OF THE MACHINE. -C -C IF TROUBLE WITH AUTOMATIC COMPUTATION OF THESE QUANTITIES, -C THEY CAN BE SET BY DIRECT ASSIGNMENT STATEMENTS. -C ASSUME THE COMPUTER HAS -C -C B = BASE OF ARITHMETIC -C T = NUMBER OF BASE B DIGITS -C -C THEN -C -C SRELPR = B**(1-T) -C - REAL*8 S -C - SRELPR = 1.d0 - 10 SRELPR = SRELPR/2.d0 - S = 1.d0 + SRELPR - IF (S.GT.1.d0) GO TO 10 - SRELPR = 2.d0*SRELPR - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/hyperelastics.f calculix-ccx-2.3/ccx_2.1/src/hyperelastics.f --- calculix-ccx-2.1/ccx_2.1/src/hyperelastics.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/hyperelastics.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,241 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine hyperelastics(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb,iline,ipol, - & inl,ipoinp,inp,ipoinpc) -! -! reading the input deck: *HYPERELASTIC -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nelcon(2,*),nmat,ntmat,ntmat_,istep,istat,ipoinpc(0:*), - & n,key,i,j,k,ityp,iperturb(*),iend,jcoef(3,14),ncmat_,irstrt, - & iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - real*8 elcon(0:ncmat_,ntmat_,*),um -! -! jcoef indicates for each hyperelastic model the position of -! the compressibility coefficients in the field elcon (max. 3 -! positions per model) -! - data jcoef /3,0,0,3,0,0,2,0,0,3,0,0,5,6,0,7,8,9,3,0,0, - & 6,7,0,12,13,14,2,0,0,3,4,0,4,5,6,5,0,0,4,5,6/ -! - ntmat=0 - iperturb(1)=3 - iperturb(2)=1 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in hyperelastics: *HYPERELASTIC should be' - write(*,*) ' placed before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in hyperelastics: *HYPERELASTIC should be' - write(*,*) ' preceded by a *MATERIAL card' - stop - endif -! - ityp=-7 -! - do i=2,n - if(textpart(i)(1:12).eq.'ARRUDA-BOYCE') then - ityp=-1 - elseif(textpart(i)(1:13).eq.'MOONEY-RIVLIN') then - ityp=-2 - elseif(textpart(i)(1:8).eq.'NEOHOOKE') then - ityp=-3 - elseif(textpart(i)(1:5).eq.'OGDEN') then - ityp=-4 - elseif(textpart(i)(1:10).eq.'POLYNOMIAL') then - ityp=-7 - elseif(textpart(i)(1:17).eq.'REDUCEDPOLYNOMIAL') then - ityp=-10 - elseif(textpart(i)(1:11).eq.'VANDERWAALS') then - ityp=-13 - elseif(textpart(i)(1:4).eq.'YEOH') then - ityp=-14 - elseif(textpart(i)(1:2).eq.'N=') then - if(textpart(i)(3:3).eq.'1') then - elseif(textpart(i)(3:3).eq.'2') then - if(ityp.eq.-4) then - ityp=-5 - elseif(ityp.eq.-7) then - ityp=-8 - elseif(ityp.eq.-10) then - ityp=-11 - else - write(*,*) '*WARNING in hyperelastics: N=2 is not appl - &icable for this material type; ' - call inputerror(inpc,ipoinpc,iline) - endif - elseif(textpart(i)(3:3).eq.'3') then - if(ityp.eq.-4) then - ityp=-6 - elseif(ityp.eq.-7) then - ityp=-9 - elseif(ityp.eq.-10) then - ityp=-12 - else - write(*,*) '*WARNING in hyperelastics: N=3 is not appl - &icable for this material type; ' - call inputerror(inpc,ipoinpc,iline) - endif - else - write(*,*) '*WARNING in hyperelastics: only N=1, N=2, or - &N=3 are allowed; ' - call inputerror(inpc,ipoinpc,iline) - endif - else - write(*,*) '*WARNING in hyperelastics: unknown option:' - write(*,'(a132)') textpart(i) - endif - enddo -! - nelcon(1,nmat)=ityp -! - if((ityp.ne.-6).and.(ityp.ne.-9)) then - if((ityp.eq.-3).or.(ityp.eq.-10)) then - iend=2 - elseif((ityp.eq.-1).or.(ityp.eq.-2).or.(ityp.eq.-4).or. - & (ityp.eq.-7)) then - iend=3 - elseif(ityp.eq.-11) then - iend=4 - elseif(ityp.eq.-13) then - iend=5 - elseif((ityp.eq.-5).or.(ityp.eq.-12).or.(ityp.eq.-14)) then - iend=6 - elseif(ityp.eq.-8) then - iend=7 - endif - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmat=ntmat+1 - nelcon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in hyperelastics: increase ntmat_' - stop - endif - do i=1,iend - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - read(textpart(iend+1)(1:20),'(f20.0)',iostat=istat) - & elcon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - else - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmat=ntmat+1 - nelcon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in hyperelastics: increase ntmat_' - stop - endif - do i=1,8 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo -! - if(ityp.eq.-6) then - iend=1 - else - iend=4 - endif - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*) - & '*ERROR in hyperelastics: hyperelastic definition' - write(*,*) ' is not complete. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - do i=1,iend - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(8+i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - read(textpart(iend+1)(1:20),'(f20.0)',iostat=istat) - & elcon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - endif -! -! if any of the compressibility coefficients is zero (incompressible -! material), it is replaced. The lowest order coefficient is replaced -! such that it corresponds to a Poisson coeffient of 0.475, the -! following ones are replaced by a power of the first one -! - do j=1,ntmat -! -! calculating the shear coefficient in the undeformed state -! - if(ityp.eq.-1) then - um=elcon(1,j,nmat) - elseif(ityp.eq.-2) then - um=2.d0*(elcon(1,j,nmat)+elcon(2,j,nmat)) - elseif(ityp.eq.-3) then - um=2.d0*elcon(1,j,nmat) - elseif(ityp.eq.-4) then - um=elcon(1,j,nmat) - elseif(ityp.eq.-5) then - um=elcon(1,j,nmat)+elcon(3,j,nmat) - elseif(ityp.eq.-6) then - um=elcon(1,j,nmat)+elcon(3,j,nmat)+elcon(5,j,nmat) - elseif((ityp.eq.-7).or.(ityp.eq.-8).or.(ityp.eq.-9)) then - um=2.d0*(elcon(1,j,nmat)+elcon(2,j,nmat)) - elseif((ityp.eq.-10).or.(ityp.eq.-11).or.(ityp.eq.-12)) then - um=2.d0*elcon(1,j,nmat) - elseif(ityp.eq.-13) then - um=elcon(1,j,nmat) - elseif(ityp.eq.-14) then - um=2.d0*elcon(1,j,nmat) - endif -! - do i=1,3 - k=jcoef(i,abs(ityp)) - if(k.eq.0) exit - if(dabs(elcon(k,j,nmat)).lt.1.d-10) then - elcon(k,j,nmat)=(0.1d0/um)**i - write(*,*) '*WARNING in hyperelastics: default value was' - write(*,*) ' used for compressibility coefficient - &s' - write(*,100) i,elcon(k,j,nmat) - endif - enddo - enddo -! - 100 format(' D',i1,' = ',e11.4) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/hyperfoams.f calculix-ccx-2.3/ccx_2.1/src/hyperfoams.f --- calculix-ccx-2.1/ccx_2.1/src/hyperfoams.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/hyperfoams.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,138 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine hyperfoams(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb,iline,ipol, - & inl,ipoinp,inp,ipoinpc) -! -! reading the input deck: *HYPERFOAM -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nelcon(2,*),nmat,ntmat,ntmat_,istep,istat,ipoinpc(0:*), - & n,key,i,ityp,iperturb(*),iend,ncmat_,irstrt,iline,ipol,inl, - & ipoinp(2,*),inp(3,*) -! - real*8 elcon(0:ncmat_,ntmat_,*) -! - ntmat=0 - iperturb(1)=3 - iperturb(2)=1 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in hyperfoams: *HYPERFOAM should be' - write(*,*) ' placed before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in hyperfoams: *HYPERFOAM should be' - write(*,*) ' preceded by a *MATERIAL card' - stop - endif -! - ityp=-15 -! - do i=2,n - if(textpart(i)(1:2).eq.'N=') then - if(textpart(i)(3:3).eq.'1') then - elseif(textpart(i)(3:3).eq.'2') then - ityp=-16 - elseif(textpart(i)(3:3).eq.'3') then - ityp=-17 - else - write(*,*) '*WARNING in hyperfoams: only N=1, N=2, or - &N=3 are allowed; ' - call inputerror(inpc,ipoinpc,iline) - endif - else - write(*,*) '*WARNING in hyperfoams: unknown option:' - write(*,'(a132)') textpart(i) - endif - enddo -! - nelcon(1,nmat)=ityp -! - if(ityp.ne.-17) then - if(ityp.eq.-15) then - iend=3 - elseif(ityp.eq.-16) then - iend=6 - endif - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - nelcon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in hyperfoams: increase ntmat_' - stop - endif - do i=1,iend - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - read(textpart(3)(1:20),'(f20.0)',iostat=istat) - & elcon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - else - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - nelcon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in hyperfoams: increase ntmat_' - stop - endif - do i=1,8 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo -! - iend=1 - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*) '*ERROR in hyperfoams: orthotropic definition' - write(*,*) ' is not complete. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - do i=1,iend - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(8+i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - read(textpart(2)(1:20),'(f20.0)',iostat=istat) - & elcon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/ident2.f calculix-ccx-2.3/ccx_2.1/src/ident2.f --- calculix-ccx-2.1/ccx_2.1/src/ident2.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ident2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! -! identifies the position id of px in an ordered array -! x of real numbers; The numbers in x are at positions -! 1, 1+ninc, 1+2*ninc, 1+3*ninc... up to 1+(n-1)*ninc -! -! id is such that x(id).le.px and x(id+1).gt.px -! - SUBROUTINE IDENT2(X,PX,N,ninc,ID) - IMPLICIT none - integer n,id,n2,m,ninc - real*8 X(N*ninc),px - id=0 - if(n.eq.0) return - N2=N+1 - DO - M=(N2+ID)/2 -c write(*,*) 'ident2',px,ninc,m,1+ninc*(m-1) - IF(PX.GE.X(1+ninc*(M-1))) then - ID=M - else - N2=M - endif - IF((N2-ID).EQ.1) return - enddo - END - diff -Nru calculix-ccx-2.1/ccx_2.1/src/identamta.f calculix-ccx-2.3/ccx_2.1/src/identamta.f --- calculix-ccx-2.1/ccx_2.1/src/identamta.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/identamta.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! -! identifies the position id of reftime in an ordered array -! amta(1,istart...iend) of real numbers; amta is defined as amta(2,*) -! -! id is such that amta(1,id).le.reftime and amta(1,id+1).gt.reftime -! - SUBROUTINE identamta(amta,reftime,istart,iend,ID) - IMPLICIT none -! - integer id,istart,iend,n2,m - real*8 amta(2,*),reftime - id=istart-1 - if(iend.lt.istart) return - N2=iend+1 - DO - M=(N2+ID)/2 - IF(reftime.GE.amta(1,M)) then - ID=M - else - N2=M - endif - IF((N2-ID).EQ.1) return - enddo - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/ident.f calculix-ccx-2.3/ccx_2.1/src/ident.f --- calculix-ccx-2.1/ccx_2.1/src/ident.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ident.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! -! identifies the position id of px in an ordered array -! x of real numbers; -! -! id is such that x(id).le.px and x(id+1).gt.px -! - SUBROUTINE IDENT(X,PX,N,ID) - IMPLICIT none - integer n,id,n2,m - real*8 X(N),px - id=0 - if(n.eq.0) return - N2=N+1 - DO - M=(N2+ID)/2 - IF(PX.GE.X(M)) then - ID=M - else - N2=M - endif - IF((N2-ID).EQ.1) return - enddo - END - diff -Nru calculix-ccx-2.1/ccx_2.1/src/identifytiedface.f calculix-ccx-2.3/ccx_2.1/src/identifytiedface.f --- calculix-ccx-2.1/ccx_2.1/src/identifytiedface.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/identifytiedface.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine identifytiedface(tieset,ntie,set,nset,ifaceslave) -! -! identifies slave nodes in tied slave faces -! - implicit none -! - character*81 tieset(3,*),slavset,set(*) -! - integer ifaceslave(*),i,j,nset,ipos,ntie -! -! nodes per face for tet elements -! - do i=1,ntie - if(tieset(1,i)(81:81).ne.'T') cycle - slavset=tieset(2,i) - ipos=index(slavset,' ') - slavset(ipos:ipos)='T' - do j=1,nset - if(set(j).eq.slavset) exit - enddo - if(j.gt.nset) then - slavset(ipos:ipos)='S' - do j=1,nset - if(set(j).eq.slavset) then - exit - endif - enddo - if(j.gt.nset) then - write(*,*) - & '*ERROR in identifytiedface: ', - & 'tied contact nodal slave surface', - & slavset - write(*,*) ' does not exist' - stop - else - tieset(2,i)(ipos:ipos)='S' - ifaceslave(i)=0 - endif - else - tieset(2,i)(ipos:ipos)='T' - ifaceslave(i)=1 - endif - enddo - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/includefilename.f calculix-ccx-2.3/ccx_2.1/src/includefilename.f --- calculix-ccx-2.1/ccx_2.1/src/includefilename.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/includefilename.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine includefilename(text,includefn,lincludefn) -! -! determines the name of an include file -! - implicit none -! - character*132 includefn - character*1320 text -! - integer nstart,nend,ii,jj,kk,lincludefn -! - nstart=0 - nend=0 -! - loop: do ii=1,lincludefn - if(text(ii:ii).eq.'=') then - jj=ii+1 - if(text(jj:jj).eq.'"') then - nstart=jj+1 - do kk=jj+1,lincludefn - if(text(kk:kk).eq.'"') then - nend=kk-1 - exit loop - endif - enddo - write(*,*)'*ERROR in includefilename: ', - & 'finishing quotes are lacking' - write(*,*) '*ERROR in the input deck. Card image:' - write(*,'(132a1)') - & (text(kk:kk),kk=1,lincludefn) - stop - else - nstart=jj - nend=lincludefn - exit - endif - endif - enddo loop - if(ii.eq.lincludefn+1) then - write(*,*) '*ERROR in includefilename: syntax error' - write(*,*) '*ERROR in the input deck. Card image:' - write(*,'(132a1)') - & (text(kk:kk),kk=1,lincludefn) - stop - endif -! - if(nend.ge.nstart) then - if(nend-nstart+1.le.132) then - includefn(1:nend-nstart+1)=text(nstart:nend) - lincludefn=nend-nstart+1 - else - write(*,*) '*ERROR in includefilename: file name too long' - write(*,*) '*ERROR in the input deck. Card image:' - write(*,'(132a1)') - & (text(kk:kk),kk=1,lincludefn) - stop - endif - else - write(*,*) '*ERROR in includefilename: file name is lacking' - write(*,*) '*ERROR in the input deck. Card image:' - write(*,'(132a1)') - & (text(kk:kk),kk=1,lincludefn) - stop - endif -! - return - end - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/incplas.f calculix-ccx-2.3/ccx_2.1/src/incplas.f --- calculix-ccx-2.1/ccx_2.1/src/incplas.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/incplas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,738 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine incplas(elconloc,plconloc,xstate,xstateini, - & elas,emec,emec0,ithermal,icmd,beta,stre,vj,kode, - & ielas,amat,t1l,dtime,time,ttime,iel,iint,nstate_,mi, - & eloc,pgauss) -! -! calculates stiffness and stresses for the incremental plasticity -! material law (Ref: J.C. Simo, A framework for finite strain -! elastoplasticity, Comp. Meth. Appl. Mech. Engng., 66(1988)199-219 -! and 68(1988)1-31) -! -! icmd=3: calculates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! the stresses in the routine proposed by Simo are Kirchhoff -! stresses. Since the stress in the hardening laws are Chauchy -! stresses, they are converted into Kirchhoff stress by -! multiplication with the Jacobian determinant -! - implicit none -! - logical user_hardening,user_creep -! - character*80 amat -! - integer ithermal,icmd,i,j,k,l,m,n,nt,kk(84),kode, - & niso,nkin,ielas,iel,iint,nstate_,mi(2),id,leximp,lend,layer, - & kspt,kstep,kinc,iloop -! - real*8 elconloc(21),elas(21),emec(6),emec0(6),beta(6),stre(6), - & vj,plconloc(82),stbl(6),epl,stril(6),xitril(6), - & ee,un,um,al,xk,cop,umb,umbb,dxitril,f0,d0,f1,d1,d2,xg(3,3), - & xs(3,3),xx(3,3),xn(3,3),xd(3,3),cpl(6),c(6),ci(6), - & c1,c2,c3,c4,c5,c6,c7,c8,c9,cplb(6),stblb(6), - & ftrial,xiso(20),yiso(20),xkin(20),ykin(20), - & fiso,dfiso,fkin,dfkin,fiso0,fkin0,ep,t1l,dtime, - & epini,a1,dsvm,xxa,xxn,vj2,vj23, - & cop1,cop2,fu1,fu2,fu,dcop,time,ttime,eloc(6), - & xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*), - & g1,g2,g3,g4,g5,g6,g7,g8,g9,g10,g11,g12,g13,g14,g15,g16, - & g17,g18,g28,g29,g30,g31,g32,g33,decra(5),deswa(5),serd, - & esw(2),ec(2),p,qtild,predef(1),dpred(1),timeabq(2),pgauss(3), - & dtemp -! - data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, - & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, - & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, - & 2,3,2,3/ -! - data xg /1.,0.,0.,0.,1.,0.,0.,0.,1./ -! - data leximp /1/ - data lend /2/ -! -c write(*,*) 'iel,iint ',iel,iint -! -! localizing the plastic fields -! - do i=1,6 - cpl(i)=-2.d0*xstateini(1+i,iint,iel) - stbl(i)=xstateini(7+i,iint,iel) - enddo - do i=1,3 - cpl(i)=cpl(i)+1.d0 - enddo - epl=xstateini(1,iint,iel) - epini=xstateini(1,iint,iel) -! - ee=elconloc(1) - un=elconloc(2) - um=ee/(1.d0+un) - al=um*un/(1.d0-2.d0*un) - xk=al+um/3.d0 - um=um/2.d0 -! - ep=epl -! -! right Cauchy-Green tensor (eloc contains the Lagrange strain, -! including thermal strain) -! - c(1)=2.d0*emec(1)+1.d0 - c(2)=2.d0*emec(2)+1.d0 - c(3)=2.d0*emec(3)+1.d0 - c(4)=2.d0*emec(4) - c(5)=2.d0*emec(5) - c(6)=2.d0*emec(6) -! -! calculating the Jacobian -! - vj=c(1)*(c(2)*c(3)-c(6)*c(6)) - & -c(4)*(c(4)*c(3)-c(6)*c(5)) - & +c(5)*(c(4)*c(6)-c(2)*c(5)) - if(vj.gt.1.d-30) then - vj=dsqrt(vj) - else - write(*,*) '*WARNING in incplas: deformation inside-out' -! -! deformation is reset to zero in order to continue the -! calculation. Alternatively, a flag could be set forcing -! a reiteration of the increment with a smaller size (to -! be done) -! - c(1)=1.d0 - c(2)=1.d0 - c(3)=1.d0 - c(4)=0.d0 - c(5)=0.d0 - c(6)=0.d0 - vj=1.d0 - endif -! -! check for user subroutines -! - if((plconloc(81).lt.0.8d0).and.(plconloc(82).lt.0.8d0)) then - user_hardening=.true. - else - user_hardening=.false. - endif - if(kode.eq.-52) then - if(elconloc(3).lt.0.d0) then - user_creep=.true. - else - user_creep=.false. -c if(xxa.lt.1.d-20) xxa=1.d-20 - xxa=elconloc(3)*(ttime+dtime)**elconloc(5) - if(xxa.lt.1.d-20) xxa=1.d-20 - xxn=elconloc(4) - a1=xxa*dtime -c a2=xxn*a1 -c a3=1.d0/xxn - endif - endif -! -! inversion of the right Cauchy-Green tensor -! - vj2=vj*vj - ci(1)=(c(2)*c(3)-c(6)*c(6))/vj2 - ci(2)=(c(1)*c(3)-c(5)*c(5))/vj2 - ci(3)=(c(1)*c(2)-c(4)*c(4))/vj2 - ci(4)=(c(5)*c(6)-c(4)*c(3))/vj2 - ci(5)=(c(4)*c(6)-c(2)*c(5))/vj2 - ci(6)=(c(4)*c(5)-c(1)*c(6))/vj2 -! -! reducing the plastic right Cauchy-Green tensor and -! the back stress to "isochoric" quantities (b stands -! for bar) -! - vj23=vj**(2.d0/3.d0) - do i=1,6 - cplb(i)=cpl(i)/vj23 - stblb(i)=stbl(i)/vj23 - enddo -! -! calculating the (n+1) trace and the (n+1) deviation of -! the (n) "isochoric" plastic right Cauchy-Green tensor -! - umb=(c(1)*cplb(1)+c(2)*cplb(2)+c(3)*cplb(3)+ - & 2.d0*(c(4)*cplb(4)+c(5)*cplb(5)+c(6)*cplb(6)))/3.d0 - do i=1,6 - cplb(i)=cplb(i)-umb*ci(i) - enddo -! -! calculating the (n+1) trace and the (n+1) deviation of -! the (n) "isochoric" back stress tensor -! - umbb=(c(1)*stblb(1)+c(2)*stblb(2)+c(3)*stblb(3)+ - & 2.d0*(c(4)*stblb(4)+c(5)*stblb(5)+c(6)*stblb(6)))/3.d0 - do i=1,6 - stblb(i)=stblb(i)-umbb*ci(i) - enddo -! -! calculating the trial stress -! - do i=1,6 - stril(i)=um*cplb(i)-beta(i) - enddo -! -! calculating the trial radius vector of the yield surface -! - do i=1,6 - xitril(i)=stril(i)-stblb(i) - enddo - g1=c(6) - g2=xitril(6) - g3=xitril(3) - g4=xitril(2) - g5=c(5) - g6=xitril(5) - g7=xitril(4) - g8=c(4) - g9=c(3) - g10=c(2) - g11=c(1) - g12=xitril(1) - g13=g12*g11 - g14=g10*g4 - g15=g9*g3 - g16=g8*g7 - g17=g6*g5 - g18=g2*g1 - g28=4*(g16 + g15) - g29=4*g13 - g30=4*g14 - g31=4*g6*g1 - g32=4*g8*g2 - g33=4*g7*g5 - dxitril=(g13*g13 + g14*g14 + g15*g15 + g16*(g30 + g29 + 2* - & g16) + g17*(g29 + g28 + 2*g17) + g18*(g30 + g28 + 2* - & g18 + 4*g17) + g11*g7*(g31 + 2*g10*g7) + g9*g6*(g32 + - & 2*g11*g6) + g10*g2*(g33 + 2*g9*g2) + g8*g4*(g31 + 2* - & g12*g8) + g12*g5*(g32 + 2*g5*g3) + g3*g1*(g33 + 2*g4* - & g1)) - if(dxitril.lt.0.d0) then - write(*,*) '*WARNING in incplas: dxitril < 0' - dxitril=0.d0 - else - dxitril=dsqrt(dxitril) - endif -! -! restoring the hardening curves for the actual temperature -! plconloc contains the true stresses. By multiplying by -! the Jacobian, yiso and ykin are Kirchhoff stresses, as -! required by the hyperelastic theory (cf. Simo, 1988). -! - niso=int(plconloc(81)) - nkin=int(plconloc(82)) - if(niso.ne.0) then - do i=1,niso - xiso(i)=plconloc(2*i-1) - yiso(i)=vj*plconloc(2*i) - enddo - endif - if(nkin.ne.0) then - do i=1,nkin - xkin(i)=plconloc(39+2*i) - ykin(i)=vj*plconloc(40+2*i) - enddo - endif -! -! check for yielding -! - if(user_hardening) then - call uhardening(amat,iel,iint,t1l,epini,ep,dtime, - & fiso,dfiso,fkin,dfkin) - fiso=fiso*vj - else - if(niso.ne.0) then - call ident(xiso,ep,niso,id) - if(id.eq.0) then - fiso=yiso(1) - elseif(id.eq.niso) then - fiso=yiso(niso) - else - dfiso=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) - fiso=yiso(id)+dfiso*(ep-xiso(id)) - endif - elseif(nkin.ne.0) then - fiso=ykin(1) - else - fiso=0.d0 - endif - endif -! - ftrial=dxitril-dsqrt(2.d0/3.d0)*fiso - if((ftrial.le.1.d-10).or.(ielas.eq.1)) then -! -! no plastic deformation -! beta contains the Cauchy residual stresses -! -c write(*,*) 'no plastic deformation' - c8=xk*(vj2-1.d0)/2.d0 -! -! residual stresses are de facto PK2 stresses -! (Piola-Kirchhoff of the second kind) -! - stre(1)=c8*ci(1)+stril(1)-beta(1) - stre(2)=c8*ci(2)+stril(2)-beta(2) - stre(3)=c8*ci(3)+stril(3)-beta(3) - stre(4)=c8*ci(4)+stril(4)-beta(4) - stre(5)=c8*ci(5)+stril(5)-beta(5) - stre(6)=c8*ci(6)+stril(6)-beta(6) -! - if(icmd.ne.3) then -! - umb=um*umb -! -! calculating the local stiffness matrix -! - xg(1,1)=(c(2)*c(3)-c(6)*c(6))/vj2 - xg(2,2)=(c(1)*c(3)-c(5)*c(5))/vj2 - xg(3,3)=(c(1)*c(2)-c(4)*c(4))/vj2 - xg(1,2)=(c(5)*c(6)-c(4)*c(3))/vj2 - xg(1,3)=(c(4)*c(6)-c(2)*c(5))/vj2 - xg(2,3)=(c(4)*c(5)-c(1)*c(6))/vj2 - xg(2,1)=xg(1,2) - xg(3,1)=xg(1,3) - xg(3,2)=xg(2,3) -! - xs(1,1)=stril(1) - xs(2,2)=stril(2) - xs(3,3)=stril(3) - xs(1,2)=stril(4) - xs(2,1)=stril(4) - xs(1,3)=stril(5) - xs(3,1)=stril(5) - xs(2,3)=stril(6) - xs(3,2)=stril(6) -! - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - elas(i)=umb*(xg(k,m)*xg(l,n)+xg(k,n)*xg(l,m)- - & 2.d0*xg(k,l)*xg(m,n)/3.d0) - & -2.d0*(xs(k,l)*xg(m,n)+xg(k,l)*xs(m,n))/3.d0 - & +xk*vj2*xg(k,l)*xg(m,n) - & -xk*(vj2-1.d0)*(xg(k,m)*xg(l,n) - & +xg(k,n)*xg(l,m))/2.d0 - enddo -! - endif -! - return - endif -! -! plastic deformation -! - umb=um*umb - umbb=umb-umbb -! -! calculating the consistency parameter -! - c1=2.d0/3.d0 - c2=dsqrt(c1) - c3=c1/um - c4=c2/um -! - iloop=0 - cop=0.d0 -! - loop: do - iloop=iloop+1 - ep=epl+c2*cop -! - if(user_hardening) then - call uhardening(amat,iel,iint,t1l,epini,ep,dtime, - & fiso,dfiso,fkin,dfkin) - fiso=fiso*vj - dfiso=dfiso*vj - fkin=fkin*vj - dfkin=dfkin*vj - else - if(niso.ne.0) then - call ident(xiso,ep,niso,id) - if(id.eq.0) then - fiso=yiso(1) - dfiso=0.d0 - elseif(id.eq.niso) then - fiso=yiso(niso) - dfiso=0.d0 - else - dfiso=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) - fiso=yiso(id)+dfiso*(ep-xiso(id)) - endif - elseif(nkin.ne.0) then - fiso=ykin(1) - dfiso=0.d0 - else - fiso=0.d0 - dfiso=0.d0 - endif -! - if(nkin.ne.0) then - call ident(xkin,ep,nkin,id) - if(id.eq.0) then - fkin=ykin(1) - dfkin=0.d0 - elseif(id.eq.nkin) then - fkin=ykin(nkin) - dfkin=0.d0 - else - dfkin=(ykin(id+1)-ykin(id))/(xkin(id+1)-xkin(id)) - fkin=ykin(id)+dfkin*(ep-xkin(id)) - endif - elseif(niso.ne.0) then - fkin=yiso(1) - dfkin=0.d0 - else - fkin=0.d0 - dfkin=0.d0 - endif - endif -! - if(dabs(cop).lt.1.d-10) then - fiso0=fiso - fkin0=fkin - endif -! - if(kode.eq.-51) then - dcop=(ftrial-c2*(fiso-fiso0) - & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/ - & (-c1*dfiso-umbb*(2.d0+c3*dfkin)) - else - if(user_creep) then - if(ithermal.eq.0) then - write(*,*) '*ERROR in incplas: no temperature defined' - stop - endif - timeabq(1)=time - timeabq(2)=ttime - qtild=(ftrial-c2*(fiso-fiso0) - & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/(c2*vj) -! -! the Von Mises stress must be positive -! - if(qtild.lt.1.d-10) qtild=1.d-10 - ec(1)=epini - call creep(decra,deswa,xstateini(1,iint,iel),serd,ec, - & esw,p,qtild,t1l,dtemp,predef,dpred,timeabq,dtime, - & amat,leximp,lend,pgauss,nstate_,iel,iint,layer,kspt, - & kstep,kinc) - dsvm=1.d0/decra(5) - dcop=-(decra(1)-c2*cop)/ - & (c2*(decra(5)*(dfiso+umbb*(3.d0+dfkin/um))+1.d0)) - else - qtild=(ftrial-c2*(fiso-fiso0) - & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/(c2*vj) -! -! the Von Mises stress must be positive -! - if(qtild.lt.1.d-10) qtild=1.d-10 - decra(1)=a1*qtild**xxn - decra(5)=xxn*decra(1)/qtild - dsvm=1.d0/decra(5) - dcop=-(decra(1)-c2*cop)/ - & (c2*(decra(5)*(dfiso+umbb*(3.d0+dfkin/um))+1.d0)) - endif - endif - cop=cop-dcop -! - if((dabs(dcop).lt.cop*1.d-4).or. - & (dabs(dcop).lt.1.d-10)) exit -! -! check for endless loops or a negative consistency -! parameter -! - if((iloop.gt.15).or.(cop.le.0.d0)) then - iloop=1 - cop=0.d0 - do - ep=epl+c2*cop -! - if(user_hardening) then - call uhardening(amat,iel,iint,t1l,epini,ep,dtime, - & fiso,dfiso,fkin,dfkin) - fiso=fiso*vj - fkin=fkin*vj - else - if(niso.ne.0) then - call ident(xiso,ep,niso,id) - if(id.eq.0) then - fiso=yiso(1) - elseif(id.eq.niso) then - fiso=yiso(niso) - else - dfiso=(yiso(id+1)-yiso(id))/ - & (xiso(id+1)-xiso(id)) - fiso=yiso(id)+dfiso*(ep-xiso(id)) - endif - elseif(nkin.ne.0) then - fiso=ykin(1) - else - fiso=0.d0 - endif -! - if(nkin.ne.0) then - call ident(xkin,ep,nkin,id) - if(id.eq.0) then - fkin=ykin(1) - elseif(id.eq.nkin) then - fkin=ykin(nkin) - else - dfkin=(ykin(id+1)-ykin(id))/ - & (xkin(id+1)-xkin(id)) - fkin=ykin(id)+dfkin*(ep-xkin(id)) - endif - elseif(niso.ne.0) then - fkin=yiso(1) - else - fkin=0.d0 - endif - endif -! - if(dabs(cop).lt.1.d-10) then - fiso0=fiso - fkin0=fkin - endif -! - if(kode.eq.-51) then - fu=(ftrial-c2*(fiso-fiso0) - & -umbb*(2.d0*cop+c4*(fkin-fkin0))) - else - if(user_creep) then - timeabq(1)=time - timeabq(2)=ttime - qtild=(ftrial-c2*(fiso-fiso0) - & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/(c2*vj) -! -! the Von Mises stress must be positive -! - if(qtild.lt.1.d-10) qtild=1.d-10 - ec(1)=epini - call creep(decra,deswa,xstateini(1,iint,iel),serd, - & ec,esw,p,qtild,t1l,dtemp,predef,dpred,timeabq, - & dtime,amat,leximp,lend,pgauss,nstate_,iel, - & iint,layer,kspt,kstep,kinc) - dsvm=1.d0/decra(5) - fu=decra(1)-c2*cop - else - qtild=(ftrial-c2*(fiso-fiso0) - & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/(c2*vj) -! -! the Von Mises stress must be positive -! - if(qtild.lt.1.d-10) qtild=1.d-10 - decra(1)=a1*qtild**xxn - decra(5)=xxn*decra(1)/qtild - dsvm=1.d0/decra(5) - fu=decra(1)-c2*cop - endif - endif -! - if(iloop.eq.1) then -c write(*,*) 'cop,fu ',cop,fu - cop1=0.d0 - fu1=fu - iloop=2 - cop=1.d-10 - elseif(iloop.eq.2) then - if(fu*fu1.le.0.d0) then -c write(*,*) cop,fu - iloop=3 - fu2=fu - cop2=cop - cop=(cop1+cop2)/2.d0 - dcop=(cop2-cop1)/2.d0 - else -c write(*,*) cop,fu - cop=cop*10.d0 - if(cop.gt.100.d0) then - write(*,*) '*ERROR: no convergence in incplas' - stop - endif - endif - else -c write(*,*) cop,fu - if(fu*fu1.ge.0.d0) then - cop1=cop - fu1=fu - else - cop2=cop - fu2=fu - endif - cop=(cop1+cop2)/2.d0 - dcop=(cop2-cop1)/2.d0 - if((dabs(dcop).lt.cop*1.d-4).or. - & (dabs(dcop).lt.1.d-10)) exit loop - endif - enddo - endif -! - enddo loop -! -! updating the equivalent plastic strain -! - epl=epl+c2*cop -! -! updating the back stress -! - c5=2.d0*umbb*cop/dxitril - c6=c5/(3.d0*um) - c7=c6*dfkin*vj23 - do i=1,6 - stbl(i)=stbl(i)+c7*xitril(i) - enddo -! -! updating the stress -! vj: Jacobian of the total deformation gradient -! - c8=xk*(vj2-1.d0)/2.d0 -! - do i=1,6 - stre(i)=c8*ci(i)-beta(i)+stril(i)-c5*xitril(i) - enddo -! -! updating the plastic right Cauchy-Green tensor -! - c9=c6*3.d0*vj23 - do i=1,6 - cpl(i)=cpl(i)-c9*xitril(i) - enddo -! - if(icmd.ne.3) then -! -! calculating the local stiffness matrix -! - xg(1,1)=(c(2)*c(3)-c(6)*c(6))/vj2 - xg(2,2)=(c(1)*c(3)-c(5)*c(5))/vj2 - xg(3,3)=(c(1)*c(2)-c(4)*c(4))/vj2 - xg(1,2)=(c(5)*c(6)-c(4)*c(3))/vj2 - xg(1,3)=(c(4)*c(6)-c(2)*c(5))/vj2 - xg(2,3)=(c(4)*c(5)-c(1)*c(6))/vj2 - xg(2,1)=xg(1,2) - xg(3,1)=xg(1,3) - xg(3,2)=xg(2,3) -! - xs(1,1)=stril(1) - xs(2,2)=stril(2) - xs(3,3)=stril(3) - xs(1,2)=stril(4) - xs(2,1)=stril(4) - xs(1,3)=stril(5) - xs(3,1)=stril(5) - xs(2,3)=stril(6) - xs(3,2)=stril(6) -! - f0=2.d0*umbb*cop/dxitril - d0=1.d0+(dfkin/um+dfiso/umbb)/3.d0 -! -! creep contribution -! - if(kode.eq.-52) then - d0=d0+dsvm/(3.d0*umbb) - endif -! - f1=1.d0/d0-f0 - d1=2.d0*f1*umbb-((1.d0+dfkin/(3.d0*um))/d0-1.d0)* - & 4.d0*cop*dxitril/3.d0 - d2=2d0*dxitril*f1 -! - xx(1,1)=xitril(1) - xx(2,2)=xitril(2) - xx(3,3)=xitril(3) - xx(1,2)=xitril(4) - xx(2,1)=xitril(4) - xx(1,3)=xitril(5) - xx(3,1)=xitril(5) - xx(2,3)=xitril(6) - xx(3,2)=xitril(6) -! - xn(1,1)=xitril(1)/dxitril - xn(2,2)=xitril(2)/dxitril - xn(3,3)=xitril(3)/dxitril - xn(1,2)=xitril(4)/dxitril - xn(2,1)=xitril(4)/dxitril - xn(1,3)=xitril(5)/dxitril - xn(3,1)=xitril(5)/dxitril - xn(2,3)=xitril(6)/dxitril - xn(3,2)=xitril(6)/dxitril -! - do i=1,3 - do j=i,3 - xd(i,j)=xn(i,1)*xn(1,j)*c(1)+xn(i,1)*xn(2,j)*c(4)+ - & xn(i,1)*xn(3,j)*c(5)+xn(i,2)*xn(1,j)*c(4)+ - & xn(i,2)*xn(2,j)*c(2)+xn(i,2)*xn(3,j)*c(6)+ - & xn(i,3)*xn(1,j)*c(5)+xn(i,3)*xn(2,j)*c(6)+ - & xn(i,3)*xn(3,j)*c(3) - enddo - enddo - xd(2,1)=xd(1,2) - xd(3,1)=xd(1,3) - xd(3,2)=xd(2,3) -! -! deviatoric part -! - c1=(xd(1,1)*c(1)+xd(2,2)*c(2)+xd(3,3)*c(3)+ - & 2.d0*(xd(1,2)*c(4)+xd(1,3)*c(5)+xd(2,3)*c(6)))/3.d0 - do i=1,3 - do j=i,3 - xd(i,j)=xd(i,j)-c1*xg(i,j) - enddo - enddo - xd(2,1)=xd(1,2) - xd(3,1)=xd(1,3) - xd(3,2)=xd(2,3) -! - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - elas(i)=(umb-f0*umbb)*(xg(k,m)*xg(l,n)+xg(k,n)*xg(l,m)- - & 2.d0*xg(k,l)*xg(m,n)/3.d0) - & -2.d0*(xs(k,l)*xg(m,n)+xg(k,l)*xs(m,n))/3.d0 - & +f0*2.d0*(xx(k,l)*xg(m,n)+xg(k,l)*xx(m,n))/3.d0 - & -d1*xn(k,l)*xn(m,n)-d2*(xn(k,l)*xd(m,n)+ - & xd(k,l)*xn(m,n))/2.d0+xk*vj2*xg(k,l)*xg(m,n) - & -xk*(vj2-1.d0)*(xg(k,m)*xg(l,n)+xg(k,n)*xg(l,m))/2.d0 - enddo -! - endif -! -! updating the plastic fields -! - do i=1,3 - cpl(i)=cpl(i)-1.d0 - enddo - do i=1,6 - xstate(1+i,iint,iel)=-cpl(i)/2.d0 - xstate(7+i,iint,iel)=stbl(i) - enddo - xstate(1,iint,iel)=epl -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/inicont.c calculix-ccx-2.3/ccx_2.1/src/inicont.c --- calculix-ccx-2.1/ccx_2.1/src/inicont.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/inicont.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,103 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -void inicont(int * nk,int *ncont, int *ntie, char *tieset, int *nset, char *set, - int *istartset, int *iendset, int *ialset, int **itietrip, - char *lakon, int *ipkon, int *kon, int **koncontp, - int *ncone, double *tietol, int *ismallsliding, int **itiefacp, - int **islavsurfp, int **islavnodep, int **imastnodep, - int **nslavnodep, int **nmastnodep, int *mortar, - int **imastopp,int *nkon,int **iponoelsp,int **inoelsp, - int **ipep, int **imep){ - - char kind[2]="C"; - - int *itietri=NULL,*koncont=NULL, *itiefac=NULL, *islavsurf=NULL, - *islavnode=NULL,*imastnode=NULL,*nslavnode=NULL,*nmastnode=NULL, - nslavs, nmasts, ifacecount, *ipe=NULL, *ime=NULL, *imastop=NULL, - *iponoels=NULL,*inoels=NULL,ifreenoels,ifreeme; - - itietri=*itietrip;koncont=*koncontp;itiefac=*itiefacp;islavsurf=*islavsurfp; - islavnode=*islavnodep;imastnode=*imastnodep;nslavnode=*nslavnodep; - nmastnode=*nmastnodep;imastop=*imastopp,iponoels=*iponoelsp, - inoels=*inoelsp;ipe=*ipep;ime=*imep; - - /* determining the number of slave entities (nodes or faces, ncone), - and the number of master triangles (ncont) */ - - FORTRAN(allocont,(ncont,ntie,tieset,nset,set,istartset,iendset, - ialset,lakon,ncone,tietol,ismallsliding,kind,mortar)); - if(ncont==0) return; - - itietri=NNEW(int,2**ntie); - koncont=NNEW(int,4**ncont); - - /* triangulation of the master side */ - - FORTRAN(triangucont,(ncont,ntie,tieset,nset,set,istartset,iendset, - ialset,itietri,lakon,ipkon,kon,koncont,kind)); - - RENEW(ipe,int,*nk); - RENEW(ime,int,12**ncont); - memset(&ipe[0],0,sizeof(int)**nk); - memset(&ime[0],0,sizeof(int)*12**ncont); - imastop=NNEW(int,3**ncont); - - FORTRAN(trianeighbor,(ipe,ime,imastop,ncont,koncont, - &ifreeme)); - - if(*mortar==0){free(ipe);free(ime);} - else{RENEW(ime,int,4*ifreeme);} - - if(*mortar==1){ - - itiefac=NNEW(int,2**ntie); - islavsurf=NNEW(int,2**ncone); - islavnode=NNEW(int,8**ncone); - imastnode=NNEW(int,3**ncont); - nslavnode=NNEW(int,*ntie+1); - nmastnode=NNEW(int,*ntie+1); - iponoels=NNEW(int,*nk); - inoels=NNEW(int,3**nkon); - - FORTRAN(tiefaccont,(lakon,ipkon,kon,ntie,tieset,nset,set, - istartset,iendset,ialset,itiefac,islavsurf,islavnode, - imastnode,nslavnode,nmastnode,&nslavs,&nmasts,&ifacecount, - ipe,ime,imastop,ncont,koncont,iponoels,inoels,&ifreenoels, - &ifreeme)); - - RENEW(islavsurf, int, 2*ifacecount+2); - RENEW(islavnode, int, nslavs); - RENEW(imastnode, int, nmasts); - RENEW(inoels,int,3*ifreenoels); - } - - *itietrip=itietri;*koncontp=koncont; - *itiefacp=itiefac;*islavsurfp=islavsurf; - *islavnodep=islavnode;*imastnodep=imastnode; - *nslavnodep=nslavnode;*nmastnodep=nmastnode; - *imastopp=imastop;*iponoelsp=iponoels;*inoelsp=inoels; - *ipep=ipe;*imep=ime; - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/initialaccel.c calculix-ccx-2.3/ccx_2.1/src/initialaccel.c --- calculix-ccx-2.1/ccx_2.1/src/initialaccel.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/initialaccel.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,304 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - - /* calculating the initial acceleration at the start of the step - for dynamic calculations */ - - if((*nmethod==4)&&(*ithermal!=2)){ - bet=(1.-*alpha)*(1.-*alpha)/4.; - gam=0.5-*alpha; - - /* calculating the stiffness and mass matrix - the stress must be determined to calculate the - stiffness matrix*/ - - reltime=0.; - time=0.; - dtime=0.; - - FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc,xloadold,xload, - xloadact,iamload,nload,ibody,xbody,nbody,xbodyold,xbodyact, - t1old,t1,t1act,iamt1,nk,amta, - namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal,nmethod, - xbounold,xboun,xbounact,iamboun,nboun, - nodeboun,ndirboun,nodeforc,ndirforc,istep,&iinc, - co,vold,itg,&ntg,amname,ikboun,ilboun,nelemload,sideload,mi)); - - time=0.; - dtime=1.; - - /* updating the nonlinear mpc's (also affects the boundary - conditions through the nonhomogeneous part of the mpc's) - if contact arises the number of MPC's can also change */ - - cam[0]=0.;cam[1]=0.; - if(*ithermal>1){radflowload(itg,ieg,&ntg,&ntr,&ntm, - ac,bc,nload,sideload,nelemload,xloadact,lakon,ipiv,ntmat_,vold, - shcon,nshcon,ipkon,kon,co,pmid,e1,e2,e3,iptri, - kontri,&ntri,nloadtr,tarea,tenv,physcon,erad,fij, - dist,idist,area,nflow,ikboun,xboun,nboun,ithermal,&iinc,&iit, - cs,mcs,inocs,&ntrit,nk,fenv,istep,&dtime,ttime,&time,ilboun, - ikforc,ilforc,xforcact,nforc,cam,ielmat,&nteq,prop,ielprop, - nactdog,nacteq,nodeboun,ndirboun,&network,rhcon, - nrhcon,ipobody,ibody,xbodyact,nbody,iviewfile,jobnamef,ctrl, - xloadold,&reltime,nmethod,set,mi,istartset,iendset,ialset,nset);} - - if((icascade==2)||(ncont!=0)){ - /**nmpc=nmpcref;*/ - memmpc_=memmpcref_;mpcfree=mpcfreeref; - RENEW(nodempc,int,3*memmpcref_); - for(k=0;k<3*memmpcref_;k++){nodempc[k]=nodempcref[k];} - RENEW(coefmpc,double,memmpcref_); - for(k=0;k0) remastruct(ipompc,&coefmpc,&nodempc,nmpc, - &mpcfree,nodeboun,ndirboun,nboun,ikmpc,ilmpc,ikboun,ilboun, - labmpc,nk,&memmpc_,&icascade,&maxlenmpc, - kon,ipkon,lakon,ne,nnn,nactdof,icol,jq,&irow,isolver, - neq,nzs,nmethod,&f,&fext,&b,&aux2,&fini,&fextini, - &adb,&aub,ithermal,iperturb,mass,mi); - - iout=-1; - ielas=1; - - fn=NNEW(double,mt**nk); - stx=NNEW(double,6*mi[0]**ne); - if(*ithermal>1) qfx=NNEW(double,3*mi[0]**ne); - - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,vold,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1old,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xbounold,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold,&bet, - &gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,sti,vini,ikboun,ilboun,ener,enern,sti,xstaten, - eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,istep,&iinc)); - - free(fn);free(stx);if(*ithermal>1)free(qfx); - - iout=0; - ielas=0; - - reltime=0.; - time=0.; - dtime=0.; - - if(*iexpl<=1){intscheme=1;} - - /* in mafillsm the stiffness and mass matrix are computed; - The primary aim is to calculate the mass matrix (not - lumped for an implicit dynamic calculation, lumped for an - explicit dynamic calculation). However: - - for an implicit calculation the mass matrix is "doped" with - a small amount of stiffness matrix, therefore the calculation - of the stiffness matrix is needed. - - for an explicit calculation the stiffness matrix is not - needed at all. Since the calculation of the mass matrix alone - is not possible in mafillsm, the determination of the stiffness - matrix is taken as unavoidable "ballast". */ - - ad=NNEW(double,neq[1]); - au=NNEW(double,nzs[1]); - - FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xbounold,nboun, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, - nforc,nelemload,sideload,xloadact,nload,xbodyact,ipobody, - nbody,cgr,ad,au,fext,nactdof,icol,jq,irow,neq,nzl, - nmethod,ikmpc,ilmpc,ikboun,ilboun, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero, - ielmat,ielorien,norien,orab,ntmat_, - t0,t1act,ithermal,prestr,iprestr,vold,iperturb,sti, - nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, - xstiff,npmat_,&dtime,matname,mi, - ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme, - physcon,shcon,nshcon,cocon,ncocon,ttime,&time,istep,&iinc, - &coriolis,ibody,xloadold,&reltime,veold)); - - if(nmethod==0){ - - /* error occurred in mafill: storing the geometry in frd format */ - - ++*kode; - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab, - een,t1,fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_,istep, - &iinc,iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, - set,nset,istartset,iendset,ialset)); - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - - FORTRAN(stop,()); - - } - - /* calculating the acceleration at the start of the step. - This can be different from the acceleration at the end - of the last step due to a discontinuous loading increase */ - - /* reltime=0.; - time=0.; - dtime=0.; - - FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc,xloadold,xload, - xloadact,iamload,nload,ibody,xbody,nbody,xbodyold,xbodyact, - t1old,t1,t1act,iamt1,nk,amta, - namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal,nmethod, - xbounold,xboun,xbounact,iamboun,nboun, - nodeboun,ndirboun,nodeforc,ndirforc,istep,&iinc, - co,vold,itg,&ntg,amname,ikboun,ilboun,nelemload,sideload));*/ - - /* determining the external loading vector */ - - /* FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, - nforc,nelemload,sideload,xloadact,nload,xbodyact,ipobody, - nbody,cgr,fext,nactdof,&neq[1], - nmethod,ikmpc,ilmpc, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero, - ielmat,ielorien,norien,orab,ntmat_, - t0,t1act,ithermal,iprestr,vold,iperturb, - iexpl,plicon,nplicon,plkcon,nplkcon, - npmat_,ttime,&time,istep,&iinc,&dtime,physcon,ibody));*/ - - /* mass x acceleration = f(external)-f(internal) - only for the mechanical loading*/ - - for(k=0;k stop -! - if((nactdog(2,node1).eq.0) - & .and.(nactdog(2,node2).eq.0)) then - WRITE(*,*) '*****************************************' - write(*,*) '*ERROR:in subroutine initialgas.f' - write(*,*) ' in element', nelem - write(*,*) ' Inlet and outlet pressures are ' - write(*,*) ' boundary conditions ' - write(*,*) ' node1',node1,' pressure',v(2,node1) - write(*,*) ' node2',node2,' pressure',v(2,node2) - stop -! -! if inlet pressure is an active degree of freedom -! - else if((nactdog(2,node1).ne.0) - & .and.(nactdog(2,node2).eq.0))then - WRITE(*,*) '*****************************************' - write(*,*) '*WARNING:in subroutine initialgas.f' - write(*,*) ' in element', nelem - write(*,*) ' Inlet pressure initial condition ' - write(*,*) ' is changed ' - write(*,*) ' node1',node1,' given initial pressure' - & ,v(2,node1) - v(2,node1)=1.1*v(2,node1) - write(*,*) ' node1',node1,' new initial pressure', - & v(2,node1) - write(*,*) ' node2',node2,' pressure',v(2,node2) -! -! if outlet pressure is an active D.O.F. -! - else if((nactdog(2,node1).eq.0) - & .and.(nactdog(2,node2).ne.0))then - WRITE(*,*) '*****************************************' - write(*,*) '*WARNING:in subroutine initialgas.f' - write(*,*) ' in element', nelem - write(*,*) ' Outlet pressure initial condition ' - write(*,*) ' is changed ' - write(*,*) ' node1',node1,' pressure' - & ,v(2,node1) - write(*,*) ' node2',node2,'given intial pressure', - & v(2,node2) - v(2,node2)=0.9*v(2,node2) - write(*,*) ' node2',node2,' new initial pressure', - & v(2,node2) -! -! if both inlet and outlet pressures are active D.O.F. -! - else if((nactdog(2,node1).ne.0) - & .and.(nactdog(2,node2).ne.0))then - WRITE(*,*) '*****************************************' - write(*,*) '*WARNING:in subroutine initialgas.f' - write(*,*) ' in element', nelem - write(*,*) ' Inlet and outlet pressure ' - write(*,*) ' initial condition are changed ' - write(*,*) ' node1',node1,' given initial pressure' - & ,v(2,node1) - v(2,node1)=1.05*v(2,node2) - write(*,*) ' node1',node1,' new intial pressure', - & v(2,node1) - write(*,*) ' node2',node2,' given initial pressure' - & ,v(2,node2) - v(2,node2)=0.95*v(2,node2) - write(*,*) ' node2',node2,' new intial pressure', - & v(2,node2) - endif - endif - - call flux(node1,node2,nodem,nelem,lakon,kon,ipkon, - & nactdog,identity,ielprop,prop,kflag,v,xflow,f, - & nodef,idirf,df,cp,r,rho,physcon,g,co,dvi,numf, - & vold,set,shcon,nshcon,rhcon,nrhcon,ntmat_,mi) -! - v(1,nodem)=xflow -! - if(lakon(nelem)(2:4).ne.'LIP') then - if(v(1,nodem).eq.0d0) then - WRITE(*,*) '*****************************************' - write(*,*) '*ERROR:in subroutine initialgas.f' - write(*,*) ' in element', nelem,lakon(nelem)(1:6) - write(*,*) ' mass flow rate value = 0 !' - write(*,*) ' node1',node1,' pressure',v(2,node1) - write(*,*) ' node2',node2,' pressure',v(2,node2) - stop - endif - if (v(1,nodem).lt.0) then - WRITE(*,*) '*****************************************' - write(*,*) '*WARNING: in subroutine initialgas.f' - write(*,*) ' in element', nelem - write(*,*) ' mass flow rate value .le. 0 !' - write(*,*) ' node1',node1,'pressure',v(2,node1) - write(*,*) ' node2',node2,'pressure',v(2,node2) - write(*,*) ' check element definition' - endif - endif - enddo -! -! calculating the static temperature for nodes belonging to gas pipes -! and restrictors (except RESTRICTOR WALL ORIFICE) -! - if(gaspipe) then - node=nelem - endif - if(iin_abs.eq.0) then - node=nelem - endif - if (gaspipe.and.(iin_abs.eq.0)) then -! -! nactdog(3,node) is set to zero for chamber nodes -! - do i=1,ntg - node=itg(i) - if(nactdog(3,node).lt.0) nactdog(3,node)=0 - if(nactdog(3,node).gt.2) nactdog(3,node)=-nactdog(3,node) - enddo -! - do i=1,nflow - nelem=ieg(i) - index=ipkon(nelem) - node1=kon(index+1) - node2=kon(index+3) -! -! if exactly one or two pipes are connected to a node then -! the number of the element the node belongs to is stored -! in nactdog(3,nodei) -! - if(node1.gt.0) then - if((nactdog(3,node1).eq.1).or. - & (nactdog(3,node1).eq.2)) then - if(node2.ne.0)then - nactdog(3,node1)=nelem - endif - elseif(nactdog(3,node1).lt.-2) then - nactdog(3,node1)=0 - write(*,*) '*WARNING :in subroutine initialgas.f' - write(*,*) ' more than 2 elements GASPIPE' - write(*,*) ' or RESTRICTOR are connected ' - write(*,*) ' to the same node',node1 - write(*,*) ' The common node is a chamber' - write(*,*) ' Total and static parameters are' - write(*,*) ' equal' - endif - endif -! - if(node2.gt.0) then - if((nactdog(3,node2).eq.1).or. - & (nactdog(3,node2).eq.2)) then - if (node1.ne.0) then - nactdog(3,node2)=nelem - endif - elseif(nactdog(3,node2).lt.-2) then - nactdog(3,node2)=0 - write(*,*) '*WARNING :in subroutine initialgas.f' - write(*,*) ' more than 2 elements GASPIPE' - write(*,*) ' or RESTRICTOR are connected ' - write(*,*) ' to the same node',node2 - write(*,*) ' The common node is a chamber' - write(*,*) ' Total and static parameters are' - write(*,*) ' equal' - endif - endif - enddo -! -! for a non-chamber node, the gaspipe element this node belongs -! to is stored in nactdog(3,node) -! - do i=1,ntg - node=itg(i) - if(nactdog(3,node).le.0) then - nactdog(3,node)=-1 - endif - enddo -! -! The static temperature is calculated and stored in v(3,node) -! total temperatures are supposed equal (adiabatic pipe) -! - do i=1,ntg - node=itg(i) - if(nactdog(3,node).gt.0) then -! - nelem=nactdog(3,node) - index=ielprop(nelem) - nodem=kon(ipkon(nelem)+2) -! - imat=ielmat(nelem) - call materialdata_tg(imat,ntmat_,v(0,node), - & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho) - kappa=cp/(cp-R) - xflow=v(1,nodem) - Tt=v(0,node) - Pt=v(2,node) -! - if((lakon(nelem)(2:5).eq.'GAPF') - & .or.(lakon(nelem)(2:5).eq.'GAPI')) then - A=prop(index+1) - if((lakon(nelem)(2:6).eq.'GAPFA') - & .or.(lakon(nelem)(2:6).eq.'GAPIA')) then - icase=0 - elseif((lakon(nelem)(2:6).eq.'GAPFI') - & .or.(lakon(nelem)(2:6).eq.'GAPII')) then - icase=1 - endif -! - elseif(lakon(nelem)(2:3).eq.'RE') then - index2=ipkon(nelem) - node1=kon(index2+1) - node2=kon(index2+3) - if(lakon(nelem)(4:5).eq.'EX') then - if((lakon(int(prop(index+4)))(2:6).eq.'GAPFA') - & .or.(lakon(int(prop(index+4)))(2:6).eq.'GAPIA')) then - icase=0 - elseif((lakon(int(prop(index+4)))(2:6).eq.'GAPFI') - & .or.(lakon(int(prop(index+4)))(2:6).eq.'GAPII')) - & then - icase=1 - endif - else - icase=0 - endif -! - if(lakon(nelem)(4:5).eq.'BE') then - a=prop(index+1) -! - elseif(lakon(nelem)(4:5).eq.'BR') then - if(lakon(nelem)(4:6).eq.'BRJ') then - if(nelem.eq.nint(prop(index+2)))then - A=prop(index+5) - elseif(nelem.eq.nint(prop(index+3))) then - A=prop(index+6) - endif - elseif(lakon(nelem)(4:6).eq.'BRS') then - if(nelem.eq.nint(prop(index+2)))then - A=prop(index+5) - elseif(nelem.eq.nint(prop(index+3))) then - A=prop(index+6) - endif - endif -! - else - if(node.eq.node1) then - a=prop(index+1) - elseif(node.eq.node2) then - a=prop(index+2) - endif - endif - endif -! - if(v(3,node).eq.0) then - call ts_calc(xflow,Tt,Pt,kappa,r,a,Ts,icase) - v(3,node)=Ts - endif -! -! if the element is not of gaspipe or branch type, -! total and static temperatures are equal -! - elseif(node.ne.0) then - v(3,node)=v(0,node) - endif - enddo - endif - endif -! -! initialisation of bc -! - do i=1,ntm - bc(i)=0.d0 - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/inputerror.f calculix-ccx-2.3/ccx_2.1/src/inputerror.f --- calculix-ccx-2.1/ccx_2.1/src/inputerror.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/inputerror.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine inputerror(inpc,ipoinpc,iline) -! -! input error message subroutine -! - implicit none -! - character*1 inpc(*) -! - integer ipoinpc(0:*),iline,i -! - write(*,*) '*ERROR in the input deck. Card image:' - write(*,'(1320a1)') (inpc(i),i=ipoinpc(iline-1)+1,ipoinpc(iline)) - write(*,*) -! - stop - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/inputinfo.f calculix-ccx-2.3/ccx_2.1/src/inputinfo.f --- calculix-ccx-2.1/ccx_2.1/src/inputinfo.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/inputinfo.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine inputinfo(inpc,ipoinpc,iline) -! -! input error message subroutine -! - implicit none -! - character*1 inpc(*) -! - integer ipoinpc(0:*),iline,i -! - write(*,*) '*INFO in the input deck. Card image:' - write(*,'(1320a1)') (inpc(i),i=ipoinpc(iline-1)+1,ipoinpc(iline)) - write(*,*) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/inputwarning.f calculix-ccx-2.3/ccx_2.1/src/inputwarning.f --- calculix-ccx-2.1/ccx_2.1/src/inputwarning.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/inputwarning.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine inputwarning(inpc,ipoinpc,iline) -! -! input error message subroutine -! - implicit none -! - character*1 inpc(*) -! - integer ipoinpc(0:*),iline,i -! - write(*,*) '*WARNING in the input deck. Card image:' - write(*,'(1320a1)') (inpc(i),i=ipoinpc(iline-1)+1,ipoinpc(iline)) - write(*,*) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/insertas.c calculix-ccx-2.3/ccx_2.1/src/insertas.c --- calculix-ccx-2.1/ccx_2.1/src/insertas.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/insertas.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -void insertas(int *ipointer, int **irowp, int **mast1p, int *i1, - int *i2, int *ifree, int *nzs_, double *contribution, double **bdp){ - - /* inserts a new nonzero matrix position into the data structure - the structure is not assumed to be symmetric - i1: row number (FORTRAN convention) - i2: column number (FORTRAN convention) */ - - int idof1,idof2,istart,*irow=NULL,*mast1=NULL; - double *bd=NULL; - - irow=*irowp; - mast1=*mast1p; - bd=*bdp; - - idof1 = *i1; - idof2 = *i2; - - if(ipointer[idof2-1]==0){ - ++*ifree; - if(*ifree>*nzs_){ - *nzs_=(int)(1.1**nzs_); - RENEW(irow,int,*nzs_); - RENEW(mast1,int,*nzs_); - RENEW(bd,double,*nzs_); - } - ipointer[idof2-1]=*ifree; - irow[*ifree-1]=idof1; - mast1[*ifree-1]=0; - bd[*ifree-1]=*contribution; - } - else{ - istart=ipointer[idof2-1]; - while(1){ - if(irow[istart-1]==idof1){ //Former row number -> update value - bd[istart-1]+=*contribution; - break; - } - if(mast1[istart-1]==0){ // new row number value - ++*ifree; - if(*ifree>*nzs_){ - *nzs_=(int)(1.1**nzs_); - RENEW(bd,double,*nzs_); - RENEW(mast1,int,*nzs_); - RENEW(irow,int,*nzs_); - } - mast1[istart-1]=*ifree; - irow[*ifree-1]=idof1; - mast1[*ifree-1]=0; - bd[*ifree-1]=*contribution; //first value - - break; - } - else{ - istart=mast1[istart-1]; - } - } - } - - *irowp=irow; - *mast1p=mast1; - *bdp=bd; - - return; - -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/insert.c calculix-ccx-2.3/ccx_2.1/src/insert.c --- calculix-ccx-2.1/ccx_2.1/src/insert.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/insert.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,140 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -void insert(int *ipointer, int **mast1p, int **mast2p, int *i1, - int *i2, int *ifree, int *nzs_){ - - /* inserts a new nonzero matrix position into the data structure */ - - int idof1,idof2,istart,*mast1=NULL,*mast2=NULL; - - mast1=*mast1p; - mast2=*mast2p; - - if(*i1<*i2){ - idof1=*i1; - idof2=*i2; - } - else{ - idof1=*i2; - idof2=*i1; - } - - if(ipointer[idof2-1]==0){ - ++*ifree; - if(*ifree>*nzs_){ - *nzs_=(int)(1.1**nzs_); - RENEW(mast1,int,*nzs_); - RENEW(mast2,int,*nzs_); - /* printf(" reallocation: nzs_=%d\n\n",*nzs_);*/ - } - ipointer[idof2-1]=*ifree; -/* printf("idof1=%d,idof2=%d,ifree=%d\n",idof1,idof2,*ifree);*/ - mast1[*ifree-1]=idof1; - mast2[*ifree-1]=0; - } - else{ - istart=ipointer[idof2-1]; - while(1){ - if(mast1[istart-1]==idof1) break; - if(mast2[istart-1]==0){ - ++*ifree; - if(*ifree>*nzs_){ - *nzs_=(int)(1.1**nzs_); - RENEW(mast1,int,*nzs_); - RENEW(mast2,int,*nzs_); -/* printf(" reallocation: nzs_=%d\n\n",*nzs_);*/ - } - mast2[istart-1]=*ifree; - mast1[*ifree-1]=idof1; - mast2[*ifree-1]=0; - break; - } - else{ - istart=mast2[istart-1]; - } - } - } - - *mast1p=mast1; - *mast2p=mast2; - - return; - -} - -/* - -Here starts the original FORTRAN code, which was transferred to the -C-code above in order to allow automatic reallocation - - subroutine insert(ipointer,mast1,mast2,i1,i2,ifree,nzs_) -! -! inserts a new nonzero matrix position into the data structure -! - implicit none -! - integer ipointer(*),mast1(*),mast2(*),i1,i2,ifree,nzs_,idof1, - & idof2,istart -! - if(i1.lt.i2) then - idof1=i1 - idof2=i2 - else - idof1=i2 - idof2=i1 - endif -! - if(ipointer(idof2).eq.0) then - ifree=ifree+1 - if(ifree.gt.nzs_) then - write(*,*) '*ERROR in insert: increase nzs_' - stop - endif - ipointer(idof2)=ifree - mast1(ifree)=idof1 - mast2(ifree)=0 - else - istart=ipointer(idof2) - do - if(mast1(istart).eq.idof1) exit - if(mast2(istart).eq.0) then - ifree=ifree+1 - if(ifree.gt.nzs_) then - write(*,*) '*ERROR in insert: increase nzs_' - stop - endif - mast2(istart)=ifree - mast1(ifree)=idof1 - mast2(ifree)=0 - exit - else - istart=mast2(istart) - endif - enddo - endif -! - return - end - - */ diff -Nru calculix-ccx-2.1/ccx_2.1/src/interpol_alfa2.f calculix-ccx-2.3/ccx_2.1/src/interpol_alfa2.f --- calculix-ccx-2.1/ccx_2.1/src/interpol_alfa2.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/interpol_alfa2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,29 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine interpol_alfa2(lzd,reynolds,alfa2) -! - implicit none -! - real*8 alfa2,lzd,reynolds -! - alfa2=1.d0 - -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/isortic.f calculix-ccx-2.3/ccx_2.1/src/isortic.f --- calculix-ccx-2.1/ccx_2.1/src/isortic.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/isortic.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,325 +0,0 @@ -*DECK ISORT - SUBROUTINE ISORTIC (IX, IY, N, KFLAG) -C***BEGIN PROLOGUE ISORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2A -C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C ISORT sorts array IX and optionally makes the same interchanges in -C array IY. The array IX may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C IX - integer array of values to be sorted -C IY - character*1 array to be (optionally) carried along -C N - number of values in integer array IX to be sorted -C KFLAG - control parameter -C = 2 means sort IX in increasing order and carry IY along. -C = 1 means sort IX in increasing order (ignoring IY) -C = -1 means sort IX in decreasing order (ignoring IY) -C = -2 means sort IX in decreasing order and carry IY along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761118 DATE WRITTEN -C 810801 Modified by David K. Kahaner. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE ISORT -C .. Scalar Arguments .. - INTEGER KFLAG, N -C .. Array Arguments .. - INTEGER IX(*) - character*1 IY(*) -C .. Local Scalars .. - REAL R - INTEGER I, IJ, J, K, KK, L, M, NN, T, TT - character*1 TTY, TY -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. -! EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT ISORT - NN = N - IF (NN .LT. 1) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The number of values to be sorted is not positive.', 1, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, -! + 1) - RETURN - ENDIF -C -C Alter array IX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - IX(I) = -IX(I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort IX only -C - M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (IX(L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (IX(K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = IX(I+1) - IF (IX(I) .LE. T) GO TO 80 - K = I -C - 90 IX(K+1) = IX(K) - K = K-1 - IF (T .LT. IX(K)) GO TO 90 - IX(K+1) = T - GO TO 80 -C -C Sort IX and carry IY along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) - TY = IY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - IY(IJ) = IY(I) - IY(I) = TY - TY = IY(IJ) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) - IY(IJ) = IY(J) - IY(J) = TY - TY = IY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - IY(IJ) = IY(I) - IY(I) = TY - TY = IY(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (IX(L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (IX(K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - TTY = IY(L) - IY(L) = IY(K) - IY(K) = TTY - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = IX(I+1) - TY = IY(I+1) - IF (IX(I) .LE. T) GO TO 170 - K = I -C - 180 IX(K+1) = IX(K) - IY(K+1) = IY(K) - K = K-1 - IF (T .LT. IX(K)) GO TO 180 - IX(K+1) = T - IY(K+1) = TY - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - IX(I) = -IX(I) - 200 CONTINUE - ENDIF - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/isortiddc1.f calculix-ccx-2.3/ccx_2.1/src/isortiddc1.f --- calculix-ccx-2.1/ccx_2.1/src/isortiddc1.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/isortiddc1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,424 +0,0 @@ -*DECK ISORT - SUBROUTINE ISORTIDDC1 (IX, DY1,DY2,CY, N, KFLAG) -! -! modified to sort in addition a double (dy) and char*20 (cy) array! -! -C***BEGIN PROLOGUE ISORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2A -C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C ISORT sorts array IX and optionally makes the same interchanges in -C array IY. The array IX may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C IX - integer array of values to be sorted -C IY - integer array to be (optionally) carried along -C N - number of values in integer array IX to be sorted -C KFLAG - control parameter -C = 2 means sort IX in increasing order and carry IY along. -C = 1 means sort IX in increasing order (ignoring IY) -C = -1 means sort IX in decreasing order (ignoring IY) -C = -2 means sort IX in decreasing order and carry IY along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761118 DATE WRITTEN -C 810801 Modified by David K. Kahaner. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE ISORT -C .. Scalar Arguments .. - INTEGER KFLAG, N,iside,istat -C .. Array Arguments .. - INTEGER IX(2,*) - real*8 DY1(2,*),DY2(2,*) - character*20 CY(*) -C .. Local Scalars .. - REAL R - INTEGER I, IJ, J, K, KK, L, M, NN, T, TT - real*8 TTY11,TTY12,TY11,TY12,TTY21,TTY22,TY21,TY22,TTX2,TX2 - character*20 UUY,UY -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. -! EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT ISORT -! - do i=1,n - read(cy(i)(2:2),'(i1)',iostat=istat) iside - if(istat.gt.0) iside=0 - ix(1,i)=10*ix(1,i)+iside - enddo -! - NN = N - IF (NN .LT. 1) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The number of values to be sorted is not positive.', 1, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, -! + 1) - RETURN - ENDIF -C -C Alter array IX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - IX(1,I) = -IX(1,I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort IX only -C - M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(1,IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(1,I) .GT. T) THEN - IX(1,IJ) = IX(1,I) - IX(1,I) = T - T = IX(1,IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (IX(1,J) .LT. T) THEN - IX(1,IJ) = IX(1,J) - IX(1,J) = T - T = IX(1,IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(1,I) .GT. T) THEN - IX(1,IJ) = IX(1,I) - IX(1,I) = T - T = IX(1,IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (IX(1,L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (IX(1,K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(1,L) - IX(1,L) = IX(1,K) - IX(1,K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = IX(1,I+1) - IF (IX(1,I) .LE. T) GO TO 80 - K = I -C - 90 IX(1,K+1) = IX(1,K) - K = K-1 - IF (T .LT. IX(1,K)) GO TO 90 - IX(1,K+1) = T - GO TO 80 -C -C Sort IX and carry IY along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(1,IJ) - TY11 = DY1(1,IJ) - TY21 = DY1(2,IJ) - TY12 = DY2(1,IJ) - TY22 = DY2(2,IJ) - TX2 = IX(2,IJ) - uy = cy(ij) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(1,I) .GT. T) THEN - IX(1,IJ) = IX(1,I) - IX(1,I) = T - T = IX(1,IJ) - DY1(1,IJ) = DY1(1,I) - DY1(2,IJ) = DY1(2,I) - DY2(1,IJ) = DY2(1,I) - DY2(2,IJ) = DY2(2,I) - IX(2,IJ) = IX(2,I) - cy(ij) = cy(i) - DY1(1,I) = TY11 - DY1(2,I) = TY21 - DY2(1,I) = TY12 - DY2(2,I) = TY22 - IX(2,I) = TX2 - cy(i) = uy - TY11 = DY1(1,IJ) - TY21 = DY1(2,IJ) - TY12 = DY2(1,IJ) - TY22 = DY2(2,IJ) - TX2 = IX(2,IJ) - uy = cy(ij) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (IX(1,J) .LT. T) THEN - IX(1,IJ) = IX(1,J) - IX(1,J) = T - T = IX(1,IJ) - DY1(1,IJ) = DY1(1,J) - DY1(2,IJ) = DY1(2,J) - DY2(1,IJ) = DY2(1,J) - DY2(2,IJ) = DY2(2,J) - IX(2,IJ) = IX(2,J) - cy(ij) = cy(j) - DY1(1,J) = TY11 - DY1(2,J) = TY21 - DY2(1,J) = TY12 - DY2(2,J) = TY22 - IX(2,J) = TX2 - cy(j) = uy - TY11 = DY1(1,IJ) - TY21 = DY1(2,IJ) - TY12 = DY2(1,IJ) - TY22 = DY2(2,IJ) - TX2 = IX(2,IJ) - uy = cy(ij) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(1,I) .GT. T) THEN - IX(1,IJ) = IX(1,I) - IX(1,I) = T - T = IX(1,IJ) - DY1(1,IJ) = DY1(1,I) - DY1(2,IJ) = DY1(2,I) - DY2(1,IJ) = DY2(1,I) - DY2(2,IJ) = DY2(2,I) - IX(2,IJ) = IX(2,I) - cy(ij) = cy(i) - DY1(1,I) = TY11 - DY1(2,I) = TY21 - DY2(1,I) = TY12 - DY2(2,I) = TY22 - IX(2,I) = TX2 - cy(i) = uy - TY11 = DY1(1,IJ) - TY21 = DY1(2,IJ) - TY12 = DY2(1,IJ) - TY22 = DY2(2,IJ) - TX2 = IX(2,IJ) - uy = cy(ij) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (IX(1,L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (IX(1,K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(1,L) - IX(1,L) = IX(1,K) - IX(1,K) = TT - TTY11 = DY1(1,L) - TTY21 = DY1(2,L) - TTY12 = DY2(1,L) - TTY22 = DY2(2,L) - TTX2 = IX(2,L) - uuy = cy(l) - DY1(1,L) = DY1(1,K) - DY1(2,L) = DY1(2,K) - DY2(1,L) = DY2(1,K) - DY2(2,L) = DY2(2,K) - IX(2,L) = IX(2,K) - cy(l) = cy(k) - DY1(1,K) = TTY11 - DY1(2,K) = TTY21 - DY2(1,K) = TTY12 - DY2(2,K) = TTY22 - IX(2,K) = TTX2 - cy(k) = uuy - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = IX(1,I+1) - TY11 = DY1(1,I+1) - TY21 = DY1(2,I+1) - TY12 = DY2(1,I+1) - TY22 = DY2(2,I+1) - TX2 = IX(2,I+1) - uy = cy(i+1) - IF (IX(1,I) .LE. T) GO TO 170 - K = I -C - 180 IX(1,K+1) = IX(1,K) - DY1(1,K+1) = DY1(1,K) - DY1(2,K+1) = DY1(2,K) - DY2(1,K+1) = DY2(1,K) - DY2(2,K+1) = DY2(2,K) - IX(2,K+1) = IX(2,K) - cy(k+1) = cy(k) - K = K-1 - IF (T .LT. IX(1,K)) GO TO 180 - IX(1,K+1) = T - DY1(1,K+1) = TY11 - DY1(2,K+1) = TY21 - DY2(1,K+1) = TY12 - DY2(2,K+1) = TY22 - IX(2,K+1) = TX2 - cy(k+1) = uy - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - IX(1,I) = -IX(1,I) - 200 CONTINUE - ENDIF -! - do i=1,nn - read(cy(i)(2:2),'(i1)',iostat=istat) iside - if(istat.gt.0) iside=0 - ix(1,i)=(ix(1,i)-iside)/10 - enddo -! - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/isortiddc2.f calculix-ccx-2.3/ccx_2.1/src/isortiddc2.f --- calculix-ccx-2.1/ccx_2.1/src/isortiddc2.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/isortiddc2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,459 +0,0 @@ -*DECK ISORT - SUBROUTINE ISORTIDDC2 (IX1,ix2, DY1,DY2,CY, N, KFLAG) -! -! modified to sort in addition a double (dy) and char*20 (cy) array! -! -C***BEGIN PROLOGUE ISORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2A -C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C ISORT sorts array IX1 and optionally makes the same interchanges in -C array IY. The array IX1 may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C IX1 - integer array of values to be sorted -C IY - integer array to be (optionally) carried along -C N - number of values in integer array IX1 to be sorted -C KFLAG - control parameter -C = 2 means sort IX1 in increasing order and carry IY along. -C = 1 means sort IX1 in increasing order (ignoring IY) -C = -1 means sort IX1 in decreasing order (ignoring IY) -C = -2 means sort IX1 in decreasing order and carry IY along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761118 DATE WRITTEN -C 810801 Modified by David K. Kahaner. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901012 Declared all variables; changed X,Y to IX1,IY. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE ISORT -C .. Scalar Arguments .. - implicit none -c - INTEGER KFLAG, N,iside,istat -C .. Array Arguments .. - INTEGER IX1(2,*),ix2(2,*) - real*8 DY1(2,*),DY2(2,*) - character*20 CY(*) -C .. Local Scalars .. - REAL R - INTEGER I, IJ, J, K, KK, L, M, NN, T, TT,tx21,tx12,tx22, - & ttx21,ttx12,ttx22 - real*8 TTY11,TTY12,TY11,TY12,TTY21,TTY22,TY21,TY22 - character*20 UUY,UY -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. -! EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT ISORT -! - do i=1,n - read(cy(i)(2:2),'(i1)',iostat=istat) iside - if(istat.gt.0) iside=0 - ix1(1,i)=10*ix1(1,i)+iside - enddo -! - NN = N - IF (NN .LT. 1) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The number of values to be sorted is not positive.', 1, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, -! + 1) - RETURN - ENDIF -C -C Alter array IX1 to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - IX1(1,I) = -IX1(1,I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort IX1 only -C - M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX1(1,IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX1(1,I) .GT. T) THEN - IX1(1,IJ) = IX1(1,I) - IX1(1,I) = T - T = IX1(1,IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (IX1(1,J) .LT. T) THEN - IX1(1,IJ) = IX1(1,J) - IX1(1,J) = T - T = IX1(1,IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX1(1,I) .GT. T) THEN - IX1(1,IJ) = IX1(1,I) - IX1(1,I) = T - T = IX1(1,IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (IX1(1,L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (IX1(1,K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX1(1,L) - IX1(1,L) = IX1(1,K) - IX1(1,K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = IX1(1,I+1) - IF (IX1(1,I) .LE. T) GO TO 80 - K = I -C - 90 IX1(1,K+1) = IX1(1,K) - K = K-1 - IF (T .LT. IX1(1,K)) GO TO 90 - IX1(1,K+1) = T - GO TO 80 -C -C Sort IX1 and carry IY along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX1(1,IJ) - TY11 = DY1(1,IJ) - TY21 = DY1(2,IJ) - TY12 = DY2(1,IJ) - TY22 = DY2(2,IJ) - TX21 = IX1(2,IJ) - tx12=ix2(1,ij) - tx22=ix2(2,ij) - uy = cy(ij) -C -C If first element of array is greater than T, interchange with T -C - IF (IX1(1,I) .GT. T) THEN - IX1(1,IJ) = IX1(1,I) - IX1(1,I) = T - T = IX1(1,IJ) - DY1(1,IJ) = DY1(1,I) - DY1(2,IJ) = DY1(2,I) - DY2(1,IJ) = DY2(1,I) - DY2(2,IJ) = DY2(2,I) - IX1(2,IJ) = IX1(2,I) - ix2(1,ij)=ix2(1,i) - ix2(2,ij)=ix2(2,i) - cy(ij) = cy(i) - DY1(1,I) = TY11 - DY1(2,I) = TY21 - DY2(1,I) = TY12 - DY2(2,I) = TY22 - IX1(2,I) = TX21 - ix2(1,i)=tx12 - ix2(2,i)=tx22 - cy(i) = uy - TY11 = DY1(1,IJ) - TY21 = DY1(2,IJ) - TY12 = DY2(1,IJ) - TY22 = DY2(2,IJ) - TX21 = IX1(2,IJ) - tx12=ix2(1,ij) - tx22=ix2(2,ij) - uy = cy(ij) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (IX1(1,J) .LT. T) THEN - IX1(1,IJ) = IX1(1,J) - IX1(1,J) = T - T = IX1(1,IJ) - DY1(1,IJ) = DY1(1,J) - DY1(2,IJ) = DY1(2,J) - DY2(1,IJ) = DY2(1,J) - DY2(2,IJ) = DY2(2,J) - IX1(2,IJ) = IX1(2,J) - ix2(1,ij)=ix2(1,j) - ix2(2,ij)=ix2(2,j) - cy(ij) = cy(j) - DY1(1,J) = TY11 - DY1(2,J) = TY21 - DY2(1,J) = TY12 - DY2(2,J) = TY22 - IX1(2,J) = TX21 - ix2(1,j)=tx12 - ix2(2,j)=tx22 - cy(j) = uy - TY11 = DY1(1,IJ) - TY21 = DY1(2,IJ) - TY12 = DY2(1,IJ) - TY22 = DY2(2,IJ) - TX21 = IX1(2,IJ) - tx12=ix2(1,ij) - tx22=ix2(2,ij) - uy = cy(ij) -C -C If first element of array is greater than T, interchange with T -C - IF (IX1(1,I) .GT. T) THEN - IX1(1,IJ) = IX1(1,I) - IX1(1,I) = T - T = IX1(1,IJ) - DY1(1,IJ) = DY1(1,I) - DY1(2,IJ) = DY1(2,I) - DY2(1,IJ) = DY2(1,I) - DY2(2,IJ) = DY2(2,I) - IX1(2,IJ) = IX1(2,I) - ix2(1,ij)=ix2(1,i) - ix2(2,ij)=ix2(2,i) - cy(ij) = cy(i) - DY1(1,I) = TY11 - DY1(2,I) = TY21 - DY2(1,I) = TY12 - DY2(2,I) = TY22 - IX1(2,I) = TX21 - ix2(1,i)=tx12 - ix2(2,i)=tx22 - cy(i) = uy - TY11 = DY1(1,IJ) - TY21 = DY1(2,IJ) - TY12 = DY2(1,IJ) - TY22 = DY2(2,IJ) - TX21 = IX1(2,IJ) - tx12=ix2(1,ij) - tx22=ix2(2,ij) - uy = cy(ij) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (IX1(1,L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (IX1(1,K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX1(1,L) - IX1(1,L) = IX1(1,K) - IX1(1,K) = TT - TTY11 = DY1(1,L) - TTY21 = DY1(2,L) - TTY12 = DY2(1,L) - TTY22 = DY2(2,L) - TTX21 = IX1(2,L) - ttx12=ix2(1,l) - ttx22=ix2(2,l) - uuy = cy(l) - DY1(1,L) = DY1(1,K) - DY1(2,L) = DY1(2,K) - DY2(1,L) = DY2(1,K) - DY2(2,L) = DY2(2,K) - IX1(2,L) = IX1(2,K) - ix2(1,l)=ix2(1,k) - ix2(2,l)=ix2(2,k) - cy(l) = cy(k) - DY1(1,K) = TTY11 - DY1(2,K) = TTY21 - DY2(1,K) = TTY12 - DY2(2,K) = TTY22 - IX1(2,K) = TTX21 - ix2(1,k)=ttx12 - ix2(2,k)=ttx22 - cy(k) = uuy - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = IX1(1,I+1) - TY11 = DY1(1,I+1) - TY21 = DY1(2,I+1) - TY12 = DY2(1,I+1) - TY22 = DY2(2,I+1) - TX21 = IX1(2,I+1) - tx12=ix2(1,i+1) - tx22=ix2(2,i+1) - uy = cy(i+1) - IF (IX1(1,I) .LE. T) GO TO 170 - K = I -C - 180 IX1(1,K+1) = IX1(1,K) - DY1(1,K+1) = DY1(1,K) - DY1(2,K+1) = DY1(2,K) - DY2(1,K+1) = DY2(1,K) - DY2(2,K+1) = DY2(2,K) - IX1(2,K+1) = IX1(2,K) - ix2(1,k+1)=ix2(1,k) - ix2(2,k+1)=ix2(2,k) - cy(k+1) = cy(k) - K = K-1 - IF (T .LT. IX1(1,K)) GO TO 180 - IX1(1,K+1) = T - DY1(1,K+1) = TY11 - DY1(2,K+1) = TY21 - DY2(1,K+1) = TY12 - DY2(2,K+1) = TY22 - IX1(2,K+1) = TX21 - ix2(1,k+1)=tx12 - ix2(2,k+1)=tx22 - cy(k+1) = uy - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - IX1(1,I) = -IX1(1,I) - 200 CONTINUE - ENDIF -! - do i=1,nn - read(cy(i)(2:2),'(i1)',iostat=istat) iside - if(istat.gt.0) iside=0 - ix1(1,i)=(ix1(1,i)-iside)/10 - enddo -! - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/isortid.f calculix-ccx-2.3/ccx_2.1/src/isortid.f --- calculix-ccx-2.1/ccx_2.1/src/isortid.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/isortid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,327 +0,0 @@ -*DECK ISORT - SUBROUTINE ISORTID (IX, DY, N, KFLAG) -c -c changed on 01.02.2001: auxiliary array is now real*8 -c -C***BEGIN PROLOGUE ISORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2A -C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C ISORT sorts array IX and optionally makes the same interchanges in -C array DY. The array IX may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C IX - integer array of values to be sorted -C DY - real*8 array to be (optionally) carried along -C N - number of values in integer array IX to be sorted -C KFLAG - control parameter -C = 2 means sort IX in increasing order and carry DY along. -C = 1 means sort IX in increasing order (ignoring DY) -C = -1 means sort IX in decreasing order (ignoring DY) -C = -2 means sort IX in decreasing order and carry DY along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761118 DATE WRITTEN -C 810801 Modified by David K. Kahaner. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901012 Declared all variables; changed X,Y to IX,DY. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE ISORT -C .. Scalar Arguments .. - INTEGER KFLAG, N -C .. Array Arguments .. - INTEGER IX(*) - real*8 DY(*),TY,TTY -C .. Local Scalars .. - REAL R - INTEGER I, IJ, J, K, KK, L, M, NN, T, TT -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. -! EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT ISORT - NN = N - IF (NN .LT. 1) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The number of values to be sorted is not positive.', 1, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, -! + 1) - RETURN - ENDIF -C -C Alter array IX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - IX(I) = -IX(I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort IX only -C - M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (IX(L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (IX(K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = IX(I+1) - IF (IX(I) .LE. T) GO TO 80 - K = I -C - 90 IX(K+1) = IX(K) - K = K-1 - IF (T .LT. IX(K)) GO TO 90 - IX(K+1) = T - GO TO 80 -C -C Sort IX and carry DY along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) - TY = DY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - DY(IJ) = DY(I) - DY(I) = TY - TY = DY(IJ) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) - DY(IJ) = DY(J) - DY(J) = TY - TY = DY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - DY(IJ) = DY(I) - DY(I) = TY - TY = DY(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (IX(L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (IX(K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - TTY = DY(L) - DY(L) = DY(K) - DY(K) = TTY - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = IX(I+1) - TY = DY(I+1) - IF (IX(I) .LE. T) GO TO 170 - K = I -C - 180 IX(K+1) = IX(K) - DY(K+1) = DY(K) - K = K-1 - IF (T .LT. IX(K)) GO TO 180 - IX(K+1) = T - DY(K+1) = TY - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - IX(I) = -IX(I) - 200 CONTINUE - ENDIF - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/isorti.f calculix-ccx-2.3/ccx_2.1/src/isorti.f --- calculix-ccx-2.1/ccx_2.1/src/isorti.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/isorti.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine isorti(nl,list,nk,key) -! -! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) -! - integer nl,nk,i,j,t,value,list(nl),key(nk) - do 20 i=2,nl - t=list(i) - value=key(t) - do 10 j=i-1,1,-1 - if(value.ge.key(list(j))) then - list(j+1)=t - go to 20 - endif - list(j+1)=list(j) - 10 continue - list(1)=t - 20 continue - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/isortiid.f calculix-ccx-2.3/ccx_2.1/src/isortiid.f --- calculix-ccx-2.1/ccx_2.1/src/isortiid.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/isortiid.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,346 +0,0 @@ -*DECK ISORT - SUBROUTINE ISORTIID (IX,CY,DY,N,KFLAG) -! -! modified to sort in addition an integer (cy) and double (dy) array! -! -C***BEGIN PROLOGUE ISORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2A -C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C ISORT sorts array IX and optionally makes the same interchanges in -C array IY. The array IX may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C IX - integer array of values to be sorted -C IY - integer array to be (optionally) carried along -C N - number of values in integer array IX to be sorted -C KFLAG - control parameter -C = 2 means sort IX in increasing order and carry IY along. -C = 1 means sort IX in increasing order (ignoring IY) -C = -1 means sort IX in decreasing order (ignoring IY) -C = -2 means sort IX in decreasing order and carry IY along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761118 DATE WRITTEN -C 810801 Modified by David K. Kahaner. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE ISORT -C .. Scalar Arguments .. - INTEGER KFLAG, N -C .. Array Arguments .. - INTEGER IX(*) - real*8 dy(*) - integer cy(*) -C .. Local Scalars .. - REAL R - INTEGER I, IJ, J, K, KK, L, M, NN, T, TT - real*8 tty,ty - integer uuy,uy -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. -! EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT ISORT - NN = N - IF (NN .LT. 1) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The number of values to be sorted is not positive.', 1, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, -! + 1) - RETURN - ENDIF -C -C Alter array IX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - IX(I) = -IX(I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort IX only -C - M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (IX(L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (IX(K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = IX(I+1) - IF (IX(I) .LE. T) GO TO 80 - K = I -C - 90 IX(K+1) = IX(K) - K = K-1 - IF (T .LT. IX(K)) GO TO 90 - IX(K+1) = T - GO TO 80 -C -C Sort IX and carry IY along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) - TY = DY(IJ) - uy = cy(ij) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - DY(IJ) = DY(I) - cy(ij) = cy(i) - DY(I) = TY - cy(i) = uy - TY = DY(IJ) - uy = cy(ij) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) - DY(IJ) = DY(J) - cy(ij) = cy(j) - DY(J) = TY - cy(j) = uy - TY = DY(IJ) - uy = cy(ij) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - DY(IJ) = DY(I) - cy(ij) = cy(i) - DY(I) = TY - cy(i) = uy - TY = DY(IJ) - uy = cy(ij) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (IX(L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (IX(K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - TTY = DY(L) - uuy = cy(l) - DY(L) = DY(K) - cy(l) = cy(k) - DY(K) = TTY - cy(k) = uuy - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = IX(I+1) - TY = DY(I+1) - uy = cy(i+1) - IF (IX(I) .LE. T) GO TO 170 - K = I -C - 180 IX(K+1) = IX(K) - DY(K+1) = DY(K) - cy(k+1) = cy(k) - K = K-1 - IF (T .LT. IX(K)) GO TO 180 - IX(K+1) = T - DY(K+1) = TY - cy(k+1) = uy - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - IX(I) = -IX(I) - 200 CONTINUE - ENDIF - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/isortii.f calculix-ccx-2.3/ccx_2.1/src/isortii.f --- calculix-ccx-2.1/ccx_2.1/src/isortii.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/isortii.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,323 +0,0 @@ -*DECK ISORT - SUBROUTINE ISORTII (IX, IY, N, KFLAG) -C***BEGIN PROLOGUE ISORT -C***PURPOSE Sort an array and optionally make the same interchanges in -C an auxiliary array. The array may be sorted in increasing -C or decreasing order. A slightly modified QUICKSORT -C algorithm is used. -C***LIBRARY SLATEC -C***CATEGORY N6A2A -C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) -C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING -C***AUTHOR Jones, R. E., (SNLA) -C Kahaner, D. K., (NBS) -C Wisniewski, J. A., (SNLA) -C***DESCRIPTION -C -C ISORT sorts array IX and optionally makes the same interchanges in -C array IY. The array IX may be sorted in increasing order or -C decreasing order. A slightly modified quicksort algorithm is used. -C -C Description of Parameters -C IX - integer array of values to be sorted -C IY - integer array to be (optionally) carried along -C N - number of values in integer array IX to be sorted -C KFLAG - control parameter -C = 2 means sort IX in increasing order and carry IY along. -C = 1 means sort IX in increasing order (ignoring IY) -C = -1 means sort IX in decreasing order (ignoring IY) -C = -2 means sort IX in decreasing order and carry IY along. -C -C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm -C for sorting with minimal storage, Communications of -C the ACM, 12, 3 (1969), pp. 185-187. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 761118 DATE WRITTEN -C 810801 Modified by David K. Kahaner. -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890831 Modified array declarations. (WRB) -C 891009 Removed unreferenced statement labels. (WRB) -C 891009 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) -C 920501 Reformatted the REFERENCES section. (DWL, WRB) -C 920519 Clarified error messages. (DWL) -C 920801 Declarations section rebuilt and code restructured to use -C IF-THEN-ELSE-ENDIF. (RWC, WRB) -C***END PROLOGUE ISORT -C .. Scalar Arguments .. - INTEGER KFLAG, N -C .. Array Arguments .. - INTEGER IX(*), IY(*) -C .. Local Scalars .. - REAL R - INTEGER I, IJ, J, K, KK, L, M, NN, T, TT, TTY, TY -C .. Local Arrays .. - INTEGER IL(21), IU(21) -C .. External Subroutines .. -! EXTERNAL XERMSG -C .. Intrinsic Functions .. - INTRINSIC ABS, INT -C***FIRST EXECUTABLE STATEMENT ISORT - NN = N - IF (NN .LT. 1) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The number of values to be sorted is not positive.', 1, 1) - RETURN - ENDIF -C - KK = ABS(KFLAG) - IF (KK.NE.1 .AND. KK.NE.2) THEN -! CALL XERMSG ('SLATEC', 'ISORT', -! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, -! + 1) - RETURN - ENDIF -C -C Alter array IX to get decreasing order if needed -C - IF (KFLAG .LE. -1) THEN - DO 10 I=1,NN - IX(I) = -IX(I) - 10 CONTINUE - ENDIF -C - IF (KK .EQ. 2) GO TO 100 -C -C Sort IX only -C - M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 20 IF (I .EQ. J) GO TO 60 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 30 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - L = J -C -C If last element of array is less than than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 40 L = L-1 - IF (IX(L) .GT. T) GO TO 40 -C -C Find an element in the first half of the array which is greater -C than T -C - 50 K = K+1 - IF (IX(K) .LT. T) GO TO 50 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - GO TO 40 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 70 -C -C Begin again on another portion of the unsorted array -C - 60 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 70 IF (J-I .GE. 1) GO TO 30 - IF (I .EQ. 1) GO TO 20 - I = I-1 -C - 80 I = I+1 - IF (I .EQ. J) GO TO 60 - T = IX(I+1) - IF (IX(I) .LE. T) GO TO 80 - K = I -C - 90 IX(K+1) = IX(K) - K = K-1 - IF (T .LT. IX(K)) GO TO 90 - IX(K+1) = T - GO TO 80 -C -C Sort IX and carry IY along -C - 100 M = 1 - I = 1 - J = NN - R = 0.375E0 -C - 110 IF (I .EQ. J) GO TO 150 - IF (R .LE. 0.5898437E0) THEN - R = R+3.90625E-2 - ELSE - R = R-0.21875E0 - ENDIF -C - 120 K = I -C -C Select a central element of the array and save it in location T -C - IJ = I + INT((J-I)*R) - T = IX(IJ) - TY = IY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - IY(IJ) = IY(I) - IY(I) = TY - TY = IY(IJ) - ENDIF - L = J -C -C If last element of array is less than T, interchange with T -C - IF (IX(J) .LT. T) THEN - IX(IJ) = IX(J) - IX(J) = T - T = IX(IJ) - IY(IJ) = IY(J) - IY(J) = TY - TY = IY(IJ) -C -C If first element of array is greater than T, interchange with T -C - IF (IX(I) .GT. T) THEN - IX(IJ) = IX(I) - IX(I) = T - T = IX(IJ) - IY(IJ) = IY(I) - IY(I) = TY - TY = IY(IJ) - ENDIF - ENDIF -C -C Find an element in the second half of the array which is smaller -C than T -C - 130 L = L-1 - IF (IX(L) .GT. T) GO TO 130 -C -C Find an element in the first half of the array which is greater -C than T -C - 140 K = K+1 - IF (IX(K) .LT. T) GO TO 140 -C -C Interchange these elements -C - IF (K .LE. L) THEN - TT = IX(L) - IX(L) = IX(K) - IX(K) = TT - TTY = IY(L) - IY(L) = IY(K) - IY(K) = TTY - GO TO 130 - ENDIF -C -C Save upper and lower subscripts of the array yet to be sorted -C - IF (L-I .GT. J-K) THEN - IL(M) = I - IU(M) = L - I = K - M = M+1 - ELSE - IL(M) = K - IU(M) = J - J = L - M = M+1 - ENDIF - GO TO 160 -C -C Begin again on another portion of the unsorted array -C - 150 M = M-1 - IF (M .EQ. 0) GO TO 190 - I = IL(M) - J = IU(M) -C - 160 IF (J-I .GE. 1) GO TO 120 - IF (I .EQ. 1) GO TO 110 - I = I-1 -C - 170 I = I+1 - IF (I .EQ. J) GO TO 150 - T = IX(I+1) - TY = IY(I+1) - IF (IX(I) .LE. T) GO TO 170 - K = I -C - 180 IX(K+1) = IX(K) - IY(K+1) = IY(K) - K = K-1 - IF (T .LT. IX(K)) GO TO 180 - IX(K+1) = T - IY(K+1) = TY - GO TO 170 -C -C Clean up -C - 190 IF (KFLAG .LE. -1) THEN - DO 200 I=1,NN - IX(I) = -IX(I) - 200 CONTINUE - ENDIF - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/keystart.f calculix-ccx-2.3/ccx_2.1/src/keystart.f --- calculix-ccx-2.1/ccx_2.1/src/keystart.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/keystart.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine keystart(ifreeinp,ipoinp,inp,name,iline,ikey) -! - implicit none -! -! stores the order in which the input is to be read in fields -! ipoinp and inp; for details on these fields, look at file -! variables.txt -! -! order: -! 1) *RESTART,READ -! 2) *NODE -! 3) *ELEMENT -! 4) *NSET -! 5) *ELSET -! 6) *TRANSFORM -! 7) *MATERIAL -! 8) *ORIENTATION -! 9) *SURFACE -! 10) *TIE -! 11) *SURFACE INTERACTION -! 12) *INITIAL CONDITIONS -! 13) *AMPLITUDE -! 14) everything else -! - integer nentries - parameter(nentries=14) -! - character*20 name,nameref(nentries) -! - integer ifreeinp,ipoinp(2,*),inp(3,*),namelen(nentries),i,ikey, - & iline -! -! order in which the cards have to be read -! - data nameref /'RESTART,READ','NODE','ELEMENT','NSET', - & 'ELSET','TRANSFORM','MATERIAL','ORIENTATION', - & 'SURFACE','TIE','SURFACEINTERACTION', - & 'INITIALCONDITIONS','AMPLITUDE','REST'/ -! -! length of the names in field nameref -! - data namelen /12,4,7,4,5,9,8,11,7,3,18,17,9,4/ -! - do i=1,nentries - if(name(1:namelen(i)).eq.nameref(i)(1:namelen(i))) then - if(ikey.eq.i) return - if(ikey.gt.0) inp(2,ipoinp(2,ikey))=iline-1 - ikey=i - if(ipoinp(1,i).eq.0) then - ipoinp(1,i)=ifreeinp - else - inp(3,ipoinp(2,i))=ifreeinp - endif - ipoinp(2,i)=ifreeinp - exit - endif - enddo - inp(1,ifreeinp)=iline - ifreeinp=ifreeinp+1 -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/knotmpc.f calculix-ccx-2.3/ccx_2.1/src/knotmpc.f --- calculix-ccx-2.1/ccx_2.1/src/knotmpc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/knotmpc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,149 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine knotmpc(ipompc,nodempc,coefmpc,irefnode,irotnode, - & iexpnode, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, - & ikboun,ilboun,nboun,nboun_,node,typeboun,co,xboun,istep) -! -! generates three knot MPC's for node "node" about reference -! (translational) node irefnode and rotational node irotnode -! - implicit none -! - character*1 typeboun(*) - character*20 labmpc(*) -! - integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), - & ilmpc(*),node,id,mpcfreeold,j,idof,l,nodeboun(*), - & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,irefnode, - & irotnode,iexpnode,istep -! - real*8 coefmpc(*),co(3,*),xboun(*),e(3,3,3) -! - data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., - & 0.,0.,1.,0.,0.,0.,-1.,0.,0., - & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ -! - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in knotmpc: increase nk_' - stop - endif - do j=1,3 - idof=8*(node-1)+j - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - cycle - endif - endif - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in knotmpc: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)='KNOT ' -! - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=j - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) -! -! translation term -! - nodempc(1,mpcfree)=irefnode - nodempc(2,mpcfree)=j - coefmpc(mpcfree)=-1.d0 - mpcfree=nodempc(3,mpcfree) -! -! expansion term -! - nodempc(1,mpcfree)=iexpnode - nodempc(2,mpcfree)=1 - if(istep.gt.1) then - coefmpc(mpcfree)=co(j,irefnode)-co(j,node) - endif - mpcfree=nodempc(3,mpcfree) -! -! rotation terms -! - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=1 - if(istep.gt.1) then - coefmpc(mpcfree)=e(j,1,1)*(co(1,irefnode)-co(1,node))+ - & e(j,2,1)*(co(2,irefnode)-co(2,node))+ - & e(j,3,1)*(co(3,irefnode)-co(3,node)) - endif - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=2 - if(istep.gt.1) then - coefmpc(mpcfree)=e(j,1,2)*(co(1,irefnode)-co(1,node))+ - & e(j,2,2)*(co(2,irefnode)-co(2,node))+ - & e(j,3,2)*(co(3,irefnode)-co(3,node)) - endif - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=3 - if(istep.gt.1) then - coefmpc(mpcfree)=e(j,1,3)*(co(1,irefnode)-co(1,node))+ - & e(j,2,3)*(co(2,irefnode)-co(2,node))+ - & e(j,3,3)*(co(3,irefnode)-co(3,node)) - endif - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=j - coefmpc(mpcfree)=1.d0 - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - idof=8*(nk-1)+j - call nident(ikboun,idof,nboun,id) - nboun=nboun+1 - if(nboun.gt.nboun_) then - write(*,*) '*ERROR in knotmpc: increase nboun_' - stop - endif - nodeboun(nboun)=nk - ndirboun(nboun)=j - typeboun(nboun)='R' - if(istep.gt.1) then - xboun(nboun)=0.d0 - endif - do l=nboun,id+2,-1 - ikboun(l)=ikboun(l-1) - ilboun(l)=ilboun(l-1) - enddo - ikboun(id+1)=idof - ilboun(id+1)=nboun - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/label.f calculix-ccx-2.3/ccx_2.1/src/label.f --- calculix-ccx-2.1/ccx_2.1/src/label.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/label.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine label(n,e2,adj,xadj,nnn,iw,oldpro,newpro, - & oldpro_exp,newpro_exp) -! -! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) -! - integer n,i1,i2,i3,i,snode,lstnum,nc,oldpro,newpro,e2,xadj(n+1), - & adj(e2),nnn(n),iw(3*n+1),oldpro_exp,newpro_exp -! - do 10 i=1,n - nnn(i)=0 - 10 continue -! - i1=1 - i2=i1+n - i3=i2+n+1 -! - lstnum=0 - 20 if(lstnum.lt.n) then -! - call diamtr(n,e2,adj,xadj,nnn,iw(i1),iw(i2),iw(i3),snode,nc) -! - call number(n,nc,snode,lstnum,e2,adj,xadj,nnn,iw(i1),iw(i2)) - go to 20 - endif -! - call profil(n,nnn,e2,adj,xadj,oldpro,newpro,oldpro_exp, - & newpro_exp) -! - if((oldpro_exp.lt.newpro_exp).or. - & ((oldpro_exp.eq.newpro_exp).and.(oldpro.lt.newpro))) then - do 30 i=1,n - nnn(i)=i - 30 continue - newpro=oldpro - newpro_exp=oldpro_exp - endif - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/lab_straight_ppkrit.f calculix-ccx-2.3/ccx_2.1/src/lab_straight_ppkrit.f --- calculix-ccx-2.1/ccx_2.1/src/lab_straight_ppkrit.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/lab_straight_ppkrit.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,45 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! this subroutines enables to calculate the critical pressure ratio of a straight -! labyrinth seal as a function of the number of spikes (n). -! -! The following table is obtained by solving iteratively the equation : -! Ps_inf/Pt0=ppkrit=1/dsqrt(1+2.n-ln(ppkrit)) -! -! this equation can be found by using the formula for the ideal mass flow in a straight labyrinth -! see "Air system Correlations Part 1 : Labyrith Seals" H.Zimmermann and K.H. Wollf ASME98-GT-206 -! and determining the maximum flow for a given number of fin. -! - subroutine lab_straight_ppkrit (n,ppkrit) -! - implicit none -! - integer n -! - real*8 fppkrit(9),ppkrit -! - data fppkrit - & /0.47113022d0,0.37968106d0,0.32930492d0,0.29569704d0, - & 0.27105479d0,0.25191791d0,0.23646609d0,0.22363192d0, - & 0.21274011/ -! - ppkrit=fppkrit(n) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/labyrinth.f calculix-ccx-2.3/ccx_2.1/src/labyrinth.f --- calculix-ccx-2.1/ccx_2.1/src/labyrinth.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/labyrinth.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,668 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine labyrinth(node1,node2,nodem,nelem,lakon, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,cp,R,physcon,co,dvi,numf,vold,set, - & kon,ipkon,mi) -! -! labyrinth element -! - implicit none -! - logical identity - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, - & ielprop(*),nodef(4),idirf(4),index,iflag,mi(2), - & inv,kgas,n,iaxial,nodea,nodeb,ipkon(*),kon(*),i -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R,a,d, - & p1,p2,T1,Aeff,C1,C2,C3,cd,cp,physcon(3),p2p1,km1,dvi, - & kp1,kdkm1,tdkp1,km1dk,x,y,ca1,cb1,ca2,cb2,dT1,alambda, - & rad,reynolds,pi,ppkrit,co(3,*), - & carry_over,lc,hst,e,szt,num,denom,t,s,b,h,cdu, - & cd_radius,cst,dh,cd_honeycomb,cd_lab,bdh, - & pt0zps1,cd_1spike,cdbragg,rzdh, - & cd_correction,p1p2,xflow_oil,T2,vold(0:mi(2),*) -! - pi=4.d0*datan(1.d0) - e=2.718281828459045d0 -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif (iflag.eq.1)then -! - index=ielprop(nelem) - kappa=(cp/(cp-R)) -! -! Usual Labyrinth -! - if(lakon(nelem)(2:5).ne.'LABF') then - t=prop(index+1) - s=prop(index+2) - iaxial=int(prop(index+3)) - d=prop(index+4) - n=int(prop(index+5)) - b=prop(index+6) - h=prop(index+7) - lc=prop(index+8) - rad=prop(index+9) - X=prop(index+10) - Hst=prop(index+11) -! - A=pi*D*s -! -! "flexible" labyrinth for thermomechanical coupling -! - elseif(lakon(nelem)(2:5).eq.'LABF') then - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - iaxial=int(prop(index+3)) - t=prop(index+4) - d=prop(index+5) - n=int(prop(index+6)) - b=prop(index+7) - h=prop(index+8) -! hc=prop(index+7) - lc=prop(index+9) - rad=prop(index+10) - X=prop(index+11) - Hst=prop(index+12) - -! -! gap definition - s=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2) - if(iaxial.ne.0) then - a=pi*d*s/iaxial - else - a=pi*d*s - endif - endif -! - p1=v(2,node1) - p2=v(2,node2) - if(p1.ge.p2) then - inv=1 - T1=v(0,node1)+physcon(1) - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - T1=v(0,node2)+physcon(1) - endif -! - cd=1.d0 - Aeff=A*cd - p2p1=p2/p1 -! -!************************ -! one fin -!************************* - if(n.eq.1.d0) then -! - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - tdkp1=2.d0/kp1 - C2=tdkp1**kdkm1 -! -! subcritical -! - if(p2p1.gt.C2) then - xflow=inv*p1*Aeff*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa) - & *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(T1) -! -! critical -! - else - xflow=inv*p1*Aeff*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ - & dsqrt(T1) - endif - endif -! -!*********************** -! straight labyrinth and stepped labyrinth -! method found in "Air system Correlations Part1 Labyrinth Seals" -! H.Zimmermann and K.H. Wolff -! ASME 98-GT-206 -!********************** -! - if (n.ge.2) then -! - call lab_straight_ppkrit(n,ppkrit) -! -! subcritical case -! - if (p2p1.gt.ppkrit) then - xflow=inv*p1*Aeff/dsqrt(T1)*dsqrt((1.d0-p2p1**2.d0) - & /(R*(n-log(p2p1)/log(e)))) -! -! critical case -! - else - xflow=inv*p1*Aeff/dsqrt(T1)*dsqrt(2.d0/R)*ppkrit - endif - endif -! - elseif (iflag.eq.2)then - numf=4 - alambda=10000.d0 -! - p1=v(2,node1) - p2=v(2,node2) - if(p1.ge.p2) then - inv=1 - xflow=v(1,nodem) - T1=v(0,node1)+physcon(1) - T2=v(0,node2)+physcon(1) - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - xflow=-v(1,nodem) - T1=v(0,node2)+physcon(1) - T2=v(0,node1)+physcon(1) - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 -! -! Usual labyrinth -! - if(lakon(nelem)(2:5).ne. 'LABF') then - index=ielprop(nelem) - kappa=(cp/(cp-R)) - t=prop(index+1) - s=prop(index+2) - iaxial=int(prop(index+3)) - d=prop(index+4) - n=int(prop(index+5)) - b=prop(index+6) - h=prop(index+7) - lc=prop(index+8) - rad=prop(index+9) - X=prop(index+10) - Hst=prop(index+11) - A=pi*D*s -! -! Flexible labyrinth for coupled calculations -! - elseif(lakon(nelem)(2:5).eq.'LABF') then - index=ielprop(nelem) - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - iaxial=int(prop(index+3)) - t=prop(index+4) - d=prop(index+5) - n=int(prop(index+6)) - b=prop(index+7) - h=prop(index+8) - lc=prop(index+9) - rad=prop(index+10) - X=prop(index+11) - Hst=prop(index+12) -! -! gap definition - s=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2) - if(iaxial.ne.0) then - a=pi*d*s/iaxial - else - a=pi*d*s - endif - endif -! - p2p1=p2/p1 - dT1=dsqrt(T1) -! - Aeff=A -! -! honeycomb stator correction -! - cd_honeycomb=1.d0 - if (lc.ne.0.d0)then - call cd_lab_honeycomb(s,lc,cd_honeycomb) - cd_honeycomb=1+cd_honeycomb/100 - endif -! -! inlet radius correction -! - cd_radius=1.d0 - if((rad.ne.0.d0).and.(n.ne.1d0)) then - call cd_lab_radius(rad,s,Hst,cd_radius) - endif -! -! carry over factor (only for straight throught labyrinth) -! - if ((n.ge.2).and.(hst.eq.0d0)) then - cst=n/(n-1.d0) - szt=s/t - carry_over=cst/dsqrt(cst-szt/(szt+0.02)) - Aeff=Aeff*carry_over - endif -! -! calculation of the dynamic viscosity -! - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif -! -! calculation of the number of reynolds for a gap -! - reynolds=dabs(xflow)*2.d0*s/(dvi*A*cd_honeycomb/cd_radius) -! -!************************************** -! single fin labyrinth -! the resolution procedure is the same as for the restrictor -!************************************** -! - if(n.eq.1)then -! -! single fin labyrinth -! -! incompressible basis cd , reynolds correction,and radius correction -! -! "Flow Characteristics of long orifices with rotation and corner radiusing" -! W.F. Mcgreehan and M.J. Schotsch -! ASME 87-GT-162 -! - dh=2*s - bdh=b/dh - rzdh=rad/dh -! - call cd_Mcgreehan_Schotsch(rzdh,bdh,reynolds,cdu) -! -! compressibility correction factor -! -! S.L.Bragg -! "Effect of conpressibility on the discharge coefficient of orifices and convergent nozzles" -! Journal of Mechanical engineering vol 2 No 1 1960 -! - call cd_bragg(cdu,p2p1,cdbragg) - cd=cdbragg - Aeff=Aeff*cd -! - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - tdkp1=2.d0/kp1 - C2=tdkp1**kdkm1 -! - if(p2p1.gt.C2) then - C1=dsqrt(2.d0*kdkm1/r)*Aeff - km1dk=1.d0/kdkm1 - y=p2p1**km1dk - x=dsqrt(1.d0-y) - ca1=-C1*x/(kappa*p1*y) - cb1=C1*km1dk/(2.d0*p1) - ca2=-ca1*p2p1-xflow*dT1/(p1*p1) - cb2=-cb1*p2p1 - f=xflow*dT1/p1-C1*p2p1**(1.d0/kappa)*x - if(cb2.le.-(alambda+ca2)*x) then - df(1)=-alambda - elseif(cb2.ge.(alambda-ca2)*x) then - df(1)=alambda - else - df(1)=ca2+cb2/x - endif - df(2)=xflow/(2.d0*p1*dT1) - df(3)=inv*dT1/p1 - if(cb1.le.-(alambda+ca1)*x) then - df(4)=-alambda - elseif(cb1.ge.(alambda-ca1)*x) then - df(4)=alambda - else - df(4)=ca1+cb1/x - endif - else - C3=dsqrt(kappa/r)*(tdkp1)**(kp1/(2.d0*km1))*Aeff - f=xflow*dT1/p1-C3 - df(1)=-xflow*dT1/(p1)**2 - df(2)=xflow/(2*p1*dT1) - df(3)=inv*dT1/p1 - df(4)=0.d0 - endif - endif -! -!**************************************** -! straight labyrinth & stepped labyrinth -! method found in "Air system Correlations Part1 Labyrinth Seals" -! H.Zimmermann and K.H. Wolff -! ASME 98-GT-206 -!**************************************** -! - if(n.ge.2) then - num=(1.d0-p2p1**2) - denom=R*(n-log(p2p1)/log(e)) -! -! straight labyrinth -! - if((hst.eq.0.d0).and.(n.ne.1)) then - call cd_lab_straight(n,p2p1,s,b,reynolds,cd_lab) - Aeff=Aeff*cd_lab*cd_honeycomb*cd_radius -! -! Stepped Labyrinth -! - else -! corrective term for the first spike - p1p2=p1/p2 - pt0zps1=(p1p2)**(1/prop(index+4)) - call cd_lab_1spike (pt0zps1,s,b,cd_1spike) -! -! corrective term for cd_lab_1spike -! - call cd_lab_correction (p1p2,s,b,cd_correction) -! -! calculation of the discharge coefficient of the stepped labyrinth -! - cd=cd_1spike*cd_correction - cd_lab=cd -! - Aeff=Aeff*cd_lab*cd_radius*cd_honeycomb - endif -! - call lab_straight_ppkrit(n,ppkrit) -! -! subcritical case -! - if (p2p1.gt.ppkrit) then -! - f=xflow*dT1/p1-dsqrt(num/denom)*Aeff -! - df(1)=xflow*dt1/p1**2.d0-Aeff/2.d0 - & *dsqrt(denom/num)*(2.d0*(p2**2.d0/p1**3.d0)/denom) - & +num/denom**2.d0*r/p1 - df(2)=xflow/(2.d0*p1*dT1) - df(3)=inv*dT1/p1 - df(4)=-Aeff/2.d0*dsqrt(denom/num)*(-2.d0*(p2/p1**2.d0) - & /denom)+num/denom**2.d0*r/p2 -! -! critical case -! - else - C2=dsqrt(2/R)*Aeff*ppkrit -! - f=xflow*dT1/p1-C2 - df(1)=-xflow*dT1/(p1**2) - df(2)=xflow/(2.d0*p1*dT1) - df(3)=inv*dT1/p1 - df(4)=0.d0 - endif - endif -! -! output -! - elseif(iflag.eq.3)then -! - - p1=v(2,node1) - p2=v(2,node2) - if(p1.ge.p2) then - inv=1 - xflow=v(1,nodem) - T1=v(0,node1)+physcon(1) - T2=v(0,node2)+physcon(1) - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - xflow=-v(1,nodem) - T1=v(0,node2)+physcon(1) - T2=v(0,node2)+physcon(1) - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif -! - index=ielprop(nelem) - kappa=(cp/(cp-R)) - t=prop(index+1) - s=prop(index+2) - d=prop(index+3) - n=int(prop(index+4)) - b=prop(index+5) - h=prop(index+6) - lc=prop(index+7) - rad=prop(index+8) - X=prop(index+9) - Hst=prop(index+10) -! - p2p1=p2/p1 - dT1=dsqrt(T1) -! - pi=4.d0*datan(1.d0) - A=pi*D*s - Aeff=A - e=2.718281828459045d0 -! -! honeycomb stator correction -! - if (lc.ne.0.d0)then - call cd_lab_honeycomb(s,lc,cd_honeycomb) - Aeff=Aeff*(1.d0+cd_honeycomb/100.d0) - else - cd_honeycomb=0 - endif -! -! inlet radius correction -! - if((rad.ne.0.d0).and.(n.ne.1d0)) then - call cd_lab_radius(rad,s,Hst,cd_radius) - Aeff=Aeff*cd_radius - else - cd_radius=1 - endif -! -! carry over factor (only for straight throught labyrinth) -! - if((n.gt.1).and.(hst.eq.0d0)) then - cst=n/(n-1.d0) - szt=s/t - carry_over=cst/dsqrt(cst-szt/(szt+0.02)) - Aeff=Aeff*carry_over - endif -! -! calculation of the dynamic viscosity -! - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif -! -! calculation of the number of reynolds for a gap -! - reynolds=dabs(xflow)*2.d0*s/(dvi*A) -!************************************** -! single fin labyrinth -! the resolution procedure is the same as for the restrictor -!************************************** -! - if(n.eq.1)then -! -! single fin labyrinth -! -! incompressible basis cd , reynolds correction,and radius correction -! -! "Flow Characteristics of long orifices with rotation and corner radiusing" -! W.F. Mcgreehan and M.J. Schotsch -! ASME 87-GT-162 -! - dh=2*s - bdh=b/dh - rzdh=rad/dh -! - call cd_Mcgreehan_Schotsch(rzdh,bdh,reynolds,cdu) -! -! compressibility correction factor -! -! S.L.Bragg -! "Effect of conpressibility on the discharge coefficient of orifices and convergent nozzles" -! Journal of Mechanical engineering vol 2 No 1 1960 -! - call cd_bragg(cdu,p2p1,cdbragg) - cd=cdbragg - Aeff=Aeff*cd - endif -! -!**************************************** -! straight labyrinth & stepped labyrinth -! method found in "Air system Correlations Part1 Labyrinth Seals" -! H.Zimmermann and K.H. Wolff -! ASME 98-GT-206 -!**************************************** -! - if(n.ge.2) then - num=(1.d0-p2p1**2) - denom=R*(n-log(p2p1)/log(e)) -! -! straight labyrinth -! - if((hst.eq.0.d0).and.(n.ne.1)) then - call cd_lab_straight(n,p2p1,s,b,reynolds,cd_lab) - Aeff=Aeff*cd_lab*cd_honeycomb*cd_radius -! -! Stepped Labyrinth -! - else -! corrective term for the first spike - p1p2=p1/p2 - pt0zps1=(p1p2)**(1/prop(index+4)) - call cd_lab_1spike (pt0zps1,s,b,cd_1spike) -! -! corrective term for cd_lab_1spike -! - call cd_lab_correction (p1p2,s,b,cd_correction) -! -! calculation of the discharge coefficient of the stepped labyrinth -! - cd=cd_1spike*cd_correction - cd_lab=cd -! - Aeff=Aeff*cd_lab*cd_radius*cd_honeycomb - endif -! - call lab_straight_ppkrit(n,ppkrit) - - endif - - xflow_oil=0 - - write(1,*) '' - write(1,55) 'In line',int(nodem/100),' from node',node1, - &' to node', node2,': air massflow rate= ',xflow,'kg/s', - &', oil massflow rate= ',xflow_oil,'kg/s' - 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) - - if(inv.eq.1) then - write(1,56)' Inlet node ',node1,': Tt1=',T1, - & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' - - write(1,*)' element S ',set(numf)(1:20) - write(1,57)' eta= ',dvi,'kg/(m*s), Re= ' , - & reynolds, - &', Cd_radius= ',cd_radius,', Cd_honeycomb= ', 1+cd_honeycomb/100 - -! straight labyrinth - if((hst.eq.0.d0).and.(n.ne.1)) then - write(1,58)' COF= ',carry_over, - & ', Cd_lab= ',cd_lab,', Cd= ',carry_over*cd_lab - -! stepped labyrinth - elseif(hst.ne.0d0) then - write(1,59)' Cd_1_fin= ', - & cd_1spike, ', Cd= ',cd,', pt0/ps1= ',pt0zps1, - & ', p0/pn= ',p1/p2 - -! single fin labyrinth - elseif(n.eq.1) then - write(1,60) ' Cd_Mcgreehan= ',cdu, - & ', Cd= ',cdbragg - endif - - write(1,56)' Outlet node ',node2,': Tt2= ',T2, - & 'K, Ts2= ',T2,'K, Pt2= ',P2/1e5,'Bar' - -! - else if(inv.eq.-1) then - write(1,56)' Inlet node ',node2,': Tt1= ',T1, - & 'K, Ts1= ',T1,'K, Pt1= ',P1/1E5, 'Bar' - - write(1,*)' element S ',set(numf)(1:20) - write(1,57)' eta=',dvi,'kg/(m*s), Re= ' - & ,reynolds, - & ', Cd_radius= ',cd_radius,', Cd_honeycomb= ',1+cd_honeycomb/100 -! -! straight labyrinth - if((hst.eq.0.d0).and.(n.ne.1)) then - write(1,58)' COF = ',carry_over, - & ', Cd_lab= ',cd_lab,', Cd= ',carry_over*cd_lab -! -! stepped labyrinth - elseif(hst.ne.0d0) then - write(1,59)' Cd_1_fin= ', - & cd_1spike,', Cd= ',cd,', pt0/ps1= ',pt0zps1, - & ', p0/pn= ',p1/p2 - -! single fin labyrinth - elseif(n.eq.1) then - write(1,60) ' Cd_Mcgreehan= ', - & cdu,' Cd= ',cdbragg - endif - write(1,56)' Outlet node ',node1,': Tt2= ',T2, - & 'K, Ts2= ',T2,'K, Pt2= ',P2/1e5, 'Bar' - - endif -! - 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A) - 57 FORMAT(1X,A,E11.5,A,G9.4,A,f6.4,A,f6.4) - 58 FORMAT(1X,A,f7.5,A,f7.5,A,f7.5) - 59 FORMAT(1X,A,f7.5,A,f7.5,A,f7.5,A,f5.3) - 60 FORMAT(1X,A,f7.5,A,f7.5) - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/limit_case_calc.f calculix-ccx-2.3/ccx_2.1/src/limit_case_calc.f --- calculix-ccx-2.1/ccx_2.1/src/limit_case_calc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/limit_case_calc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2005 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine limit_case_calc(a2,pt1,Tt2,xflow,zeta,r,kappa, - & pt2_lim,M2) -! -! For restrictor elements A1 equation is not needed -! iflag=1: calculation of the initial flux -! iflag=2: evaluate the element equation and all derivatives -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif((iflag.eq.1).or.(iflag.eq.2))then -! - index=ielprop(nelem) -! - h1=v(2,node1) - h2=v(2,node2) -! - z1=-g(1)*co(1,node1)-g(2)*co(2,node1)-g(3)*co(3,node1) - z2=-g(1)*co(1,node2)-g(2)*co(2,node2)-g(3)*co(3,node2) -! - dg=dsqrt(g(1)*g(1)+g(2)*g(2)+g(3)*g(3)) -! - if(iflag.eq.1) then - inv=0 - else - xflow=v(1,nodem) - if(xflow.ge.0.d0) then - inv=1 - else - inv=-1 - endif - nodef(1)=node1 - nodef(2)=nodem - nodef(3)=node2 - idirf(1)=2 - idirf(2)=1 - idirf(3)=2 - endif -! - if(lakon(nelem)(6:7).eq.'WC') then -! -! channel, White-Colebrook -! - b=prop(index+1) - s0=prop(index+2) - xks=prop(index+3) - dl=dsqrt((co(1,node2)-co(1,node1))**2+ - & (co(2,node2)-co(2,node1))**2+ - & (co(3,node2)-co(3,node1))**2) -! - if(s0.lt.0.d0) then - s0=dasin((z1-z2)/dl) - endif - sqrts0=dsqrt(1.d0-s0*s0) -! -! auxiliary variable -! - xi=dg*(rho*b)**2*(h1+h2)**3 -! - if(iflag.eq.1) then -! -! assuming large reynolds number -! - friction=1.d0/(2.03*dlog10(xks/(d*3.7)))**2 - else -! -! solving the implicit White-Colebrook equation -! - reynolds=xflow*d/(a*dvi) - friction=(200.d0*d/(xks*reynolds))**2 - do - ds=dsqrt(friction) - dd=2.51d0/(reynolds*ds)+xks/(2.7d0*d) - dfriction=(1.d0/ds+2.03*dlog10(dd))*2.d0*friction*ds/ - & (1.d0+2.213d0/(reynolds*dd)) - if(dfriction.le.friction*1.d-3) then - friction=friction+dfriction - exit - endif - friction=friction+dfriction - enddo - endif - if(inv.ne.0) then - xk=friction*dl - else - xkn=friction*dl - xkp=xkn - endif -! -! check whether the critical depth lies in between h1 and h2 -! - if(iflag.gt.1) then -! -! calculate HK (critical depth) -! - hk=((xflow/(rho*b))**2/(dg*sqrts0))**(1.d0/3.d0) - if(inv.eq.1) then - if((h1.lt.hk).and.(h2.gt.hk)) then - fjump=((h2-h1)**3)/(4.d0*h1*h2) - else - fjump=0.d0 - dfjumpdh1=0.d0 - dfjumpdh2=0.d0 - endif - else - if((h1.gt.hk).and.(h2.lt.hk)) then - fjump=((h1-h2)**3)/(4.d0*h1*h2) - else - fjump=0.d0 - dfjumpdh1=0.d0 - dfjumpdh2=0.d0 - endif - endif - feq=0.d0 - dfeqdh1=0.d0 - dfeqdh2=0.d0 - endif - elseif(lakon(nelem)(6:7).eq.'EL') then -! -! pipe, sudden enlargement -! - b1=prop(index+1) - b2=prop(index+2) - angle=prop(index+3) - call ident(xcoel,angle,ncoel,id) - dl=0.d0 -! -! calculating the special head loss -! - if(h2*b2.gt.h1*b1) then - sgn=-1.d0 - else - sgn=1.d0 - endif - du1=((b1+b2)**2*(h1+h2)**3)/8.d0*sgn - feq=du1*(1.d0/(h2*b2)**2-1.d0/(h1*b1)**2) -! - if(inv.ne.0) then - fjump=0.d0 - dfjumpdh1=0.d0 - dfjumpdh2=0.d0 - dfeqdh1=3.d0*feq/(h1+h2) -! - dfeqdh2=dfeqdh1-2.d0*du1/(h2**3*b2**2) - dfeqdh1=dfeqdh1+2.d0*du1/(h1**3*b1**2) - endif -! - if(inv.ge.0) then - if(id.eq.0) then - zeta=yel(1) - elseif(id.eq.ncoel) then - zeta=yel(ncoel) - else - zeta=yel(id)+(yel(id+1)-yel(id))*(ratio-xcoel(id))/ - & (xcoel(id+1)-xcoel(id)) - endif - if(inv.ne.0) then - xk=zeta*feq - else - xkp=zeta*feq - endif - endif - if(inv.le.0) then - if(id.eq.0) then - zeta=yco(1) - elseif(id.eq.ncoel) then - zeta=yco(ncoel) - else - zeta=yco(id)+(yco(id+1)-yco(id))*(ratio-xcoel(id))/ - & (xcoel(id+1)-xcoel(id)) - endif - if(inv.ne.0) then - xk=zeta*feq - else - xkn=zeta*feq - endif - endif - - elseif(lakon(nelem)(6:7).eq.'CO') then -! -! pipe, sudden contraction -! - a1=prop(index+1) - a2=prop(index+2) - ratio=a2/a1 - call ident(xcoel,ratio,ncoel,id) - if(inv.ge.0) then - if(id.eq.0) then - zeta=yco(1) - elseif(id.eq.ncoel) then - zeta=yco(ncoel) - else - zeta=yco(id)+(yco(id+1)-yco(id))*(ratio-xcoel(id))/ - & (xcoel(id+1)-xcoel(id)) - endif - if(inv.ne.0) then - xk=zeta/(a2*a2) - else - xkp=zeta/(a2*a2) - endif - endif - if(inv.le.0) then - if(id.eq.0) then - zeta=yel(1) - elseif(id.eq.ncoel) then - zeta=yel(ncoel) - else - zeta=yel(id)+(yel(id+1)-yel(id))*(ratio-xcoel(id))/ - & (xcoel(id+1)-xcoel(id)) - endif - if(inv.ne.0) then - xk=zeta/(a2*a2) - else - xkn=zeta/(a2*a2) - endif - endif - elseif(lakon(nelem)(6:7).eq.'DI') then -! -! pipe, diaphragm -! - a=prop(index+1) - a0=prop(index+2) - a1=a - a2=a - ratio=a0/a - call ident(xdi,ratio,ndi,id) - if(id.eq.0) then - zeta=ydi(1) - elseif(id.eq.ndi) then - zeta=ydi(ndi) - else - zeta=ydi(id)+(ydi(id+1)-ydi(id))*(ratio-xdi(id))/ - & (xdi(id+1)-xdi(id)) - endif - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - elseif(lakon(nelem)(6:7).eq.'EN') then -! -! pipe, entrance -! - a=prop(index+1) - a0=prop(index+2) - a1=a*1.d10 - a2=a - ratio=a0/a - call ident(xen,ratio,nen,id) - if(id.eq.0) then - zeta=yen(1) - elseif(id.eq.nen) then - zeta=yen(nen) - else - zeta=yen(id)+(yen(id+1)-yen(id))*(ratio-xen(id))/ - & (xen(id+1)-xen(id)) - endif - if(inv.ne.0) then - xk=zeta/(a*a) - else -c -c to be changed: entrance is different from exit -c - xkn=zeta/(a*a) - xkp=xkn - endif - elseif(lakon(nelem)(6:7).eq.'GV') then -! -! pipe, gate valve -! - a=prop(index+1) - alpha=prop(index+2) - a1=a - a2=a - call ident(xgv,alpha,ngv,id) - if(id.eq.0) then - zeta=ygv(1) - elseif(id.eq.ngv) then - zeta=ygv(ngv) - else - zeta=ygv(id)+(ygv(id+1)-ygv(id))*(alpha-xgv(id))/ - & (xgv(id+1)-xgv(id)) - endif - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - elseif(lakon(nelem)(6:7).eq.'BE') then -! -! pipe, bend -! - a=prop(index+1) - rd=prop(index+2) - alpha=prop(index+3) - coarseness=prop(index+4) - a1=a - a2=a - call ident(xbe,rd,nbe,id) - if(id.eq.0) then - zeta=ybe(1)+(zbe(1)-ybe(1))*coarseness - elseif(id.eq.nbe) then - zeta=ybe(nbe)+(zbe(nbe)-ybe(nbe))*coarseness - else - zeta=(1.d0-coarseness)* - & (ybe(id)+(ybe(id+1)-ybe(id))*(rd-xbe(id))/ - & (xbe(id+1)-xbe(id))) - & +coarseness* - & (zbe(id)+(zbe(id+1)-zbe(id))*(rd-xbe(id))/ - & (xbe(id+1)-xbe(id))) - endif - zeta=zeta*alpha/90.d0 - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - endif -! - if(iflag.eq.1) then - xflow=xi*((h2-h1)*sqrts0-dl*s0)/ - & (8.d0*(h2-h1)-xkp) - if(xflow.lt.0.d0) then - xflow=xi*((h2-h1)*sqrts0-dl*s0)/ - & (8.d0*(h2-h1)+xkn) - if(xflow.lt.0.d0) then - write(*,*) '*WARNING in liquidpipe:' - write(*,*) ' initial mass flow could' - write(*,*) ' not be determined' - write(*,*) ' 1.d-10 is taken' - xflow=1.d-10 - else - xflow=-dsqrt(xflow) - endif - else - xflow=dsqrt(xflow) - endif - else - dxidh1=3.d0*xi/(h1+h2) - df(1)=((h2-h1)*sqrts0-(dl*s0-inv*fjump))*dxidh1 - df(2)=df(1) -! - xflow2=xflow*xflow - du1=xi*sqrts0-8.d0*xflow2 -! - df(1)=df(1)-du1+(xi*dfjumpdh1+xflow2*dfeqdh1)*inv - df(2)=df(2)+du1+(xi*dfjumpdh2+xflow2*dfeqdh2)*inv - df(3)=(-8.d0*(h2-h1)+inv*(friction*dl+feq))*2.d0*xflow - f=(h2-h1)*du1-xi*(dl*s0-inv*fjump)+ - & inv*(friction*dl+feq)*xflow2 - endif -! - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/liquidpipe.f calculix-ccx-2.3/ccx_2.1/src/liquidpipe.f --- calculix-ccx-2.1/ccx_2.1/src/liquidpipe.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/liquidpipe.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,671 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine liquidpipe(node1,node2,nodem,nelem,lakon, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,rho,g,co,dvi,numf,vold,mi,ipkon,kon) -! -! pipe element for incompressible media -! - implicit none -! - logical identity - character*8 lakon(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,iaxial, - & ielprop(*),nodef(4),idirf(4),index,iflag,mi(2), - & inv,ncoel,ndi,nbe,id,nen,ngv,numf,nodea,nodeb, - & ipkon(*),isothermal,kon(*) -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),a,d,pi,radius, - & p1,p2,rho,dvi,friction,reynolds,vold(0:mi(2),*), - & g(3),a1,a2,xn,xk,xk1,xk2,zeta,dl,dg,rh,a0,alpha, - & coarseness,rd,xks,z1,z2,co(3,*),xcoel(11),yel(11), - & yco(11),xdi(10),ydi(10),xbe(7),ybe(7),zbe(7),ratio, - & xen(10),yen(10),xgv(8),ygv(8),ds,dd,dfriction,xkn,xkp, - & dh,kappa,r -! - data ncoel /7/ - data xcoel /0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/ - data yco /0.5,0.46,0.41,0.36,0.30,0.24,0.18,0.12,0.06,0.02,0./ - data yel /1.,0.81,0.64,0.49,0.36,0.25,0.16,0.09,0.04,0.01,0./ -! - data ndi /10/ - data xdi /0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1./ - data ydi /226.,47.5,17.5,7.8,3.75,1.80,0.8,0.29,0.06,0./ -! - data nbe /7/ - data xbe /1.,1.5,2.,3.,4.,6.,10./ - data ybe /0.21,0.12,0.10,0.09,0.09,0.08,0.2/ - data zbe /0.51,0.32,0.29,0.26,0.26,0.17,0.31/ -! - data nen /10/ - data xen /0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1./ - data yen /232.,51.,18.8,9.6,5.26,3.08,1.88,1.17,0.734,0.46/ -! - data ngv /8/ - data xgv /0.125,0.25,0.375,0.5,0.625,0.75,0.875,1./ - data ygv /98.,17.,5.52,2.,0.81,0.26,0.15,0.12/ -! - numf=3 -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif((iflag.eq.1).or.(iflag.eq.2))then -! - index=ielprop(nelem) -! - p1=v(2,node1) - p2=v(2,node2) -! - z1=-g(1)*co(1,node1)-g(2)*co(2,node1)-g(3)*co(3,node1) - z2=-g(1)*co(1,node2)-g(2)*co(2,node2)-g(3)*co(3,node2) -! - if(iflag.eq.1) then - inv=0 - else - xflow=v(1,nodem) - if(xflow.ge.0.d0) then - inv=1 - else - inv=-1 - endif - nodef(1)=node1 - nodef(2)=nodem - nodef(3)=node2 - idirf(1)=2 - idirf(2)=1 - idirf(3)=2 - endif -! - if(lakon(nelem)(6:7).eq.'MA') then -! -! pipe, Manning -! - if(lakon(nelem)(8:8).eq.'F') then - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - xn=prop(index+3) - iaxial=int(prop(index+4)) - radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2+ - & (co(2,nodeb)+vold(2,nodeb)- - & co(2,nodea)-vold(2,nodea))**2+ - & (co(3,nodeb)+vold(3,nodeb)- - & co(3,nodea)-vold(3,nodea))**2) - pi=4.d0*datan(1.d0) - if(iaxial.ne.0) then - a=pi*radius*radius/iaxial - else - a=pi*radius*radius - endif - rh=radius/2.d0 - else - a=prop(index+1) - rh=prop(index+2) - endif - xn=prop(index+3) - a1=a - a2=a - dl=dsqrt((co(1,node2)-co(1,node1))**2+ - & (co(2,node2)-co(2,node1))**2+ - & (co(3,node2)-co(3,node1))**2) - dg=dsqrt(g(1)*g(1)+g(2)*g(2)+g(3)*g(3)) - if(inv.ne.0) then - xk=2.d0*xn*xn*dl*dg/(a*a*rh**(4.d0/3.d0)) - else - xkn=2.d0*xn*xn*dl*dg/(a*a*rh**(4.d0/3.d0)) - xkp=xkn - endif - elseif(lakon(nelem)(6:7).eq.'WC') then -! -! pipe, White-Colebrook -! - if(lakon(nelem)(8:8).eq.'F') then - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - xn=prop(index+3) - iaxial=int(prop(index+4)) - radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2+ - & (co(2,nodeb)+vold(2,nodeb)- - & co(2,nodea)-vold(2,nodea))**2+ - & (co(3,nodeb)+vold(3,nodeb)- - & co(3,nodea)-vold(3,nodea))**2) - pi=4.d0*datan(1.d0) - if(iaxial.ne.0) then - a=pi*radius*radius/iaxial - else - a=pi*radius*radius - endif - d=2.d0*radius - else - a=prop(index+1) - d=prop(index+2) - endif - xks=prop(index+3) - a1=a - a2=a - dl=dsqrt((co(1,node2)-co(1,node1))**2+ - & (co(2,node2)-co(2,node1))**2+ - & (co(3,node2)-co(3,node1))**2) - if(iflag.eq.1) then -! -! assuming large reynolds number -! - friction=1.d0/(2.03*dlog10(xks/(d*3.7)))**2 - else -! -! solving the implicit White-Colebrook equation -! - reynolds=xflow*d/(a*dvi) - friction=(200.d0*d/(xks*reynolds))**2 - do - ds=dsqrt(friction) - dd=2.51d0/(reynolds*ds)+xks/(2.7d0*d) - dfriction=(1.d0/ds+2.03*dlog10(dd))*2.d0*friction*ds/ - & (1.d0+2.213d0/(reynolds*dd)) - if(dfriction.le.friction*1.d-3) then - friction=friction+dfriction - exit - endif - friction=friction+dfriction - enddo - endif - if(inv.ne.0) then - xk=friction*dl/(d*a*a) - else - xkn=friction*dl/(d*a*a) - xkp=xkn - endif - elseif(lakon(nelem)(6:7).eq.'EL') then -! -! pipe, sudden enlargement Berlamont version: fully turbulent -! all section ratios -! - a1=prop(index+1) - a2=prop(index+2) - ratio=a1/a2 - call ident(xcoel,ratio,ncoel,id) - if(inv.ge.0) then - if(id.eq.0) then - zeta=yel(1) - elseif(id.eq.ncoel) then - zeta=yel(ncoel) - else - zeta=yel(id)+(yel(id+1)-yel(id))*(ratio-xcoel(id))/ - & (xcoel(id+1)-xcoel(id)) - endif - if(inv.ne.0) then - xk=zeta/(a1*a1) - else - xkp=zeta/(a1*a1) - endif - endif - if(inv.le.0) then - if(id.eq.0) then - zeta=yco(1) - elseif(id.eq.ncoel) then - zeta=yco(ncoel) - else - zeta=yco(id)+(yco(id+1)-yco(id))*(ratio-xcoel(id))/ - & (xcoel(id+1)-xcoel(id)) - endif - if(inv.ne.0) then - xk=zeta/(a1*a1) - else - xkn=zeta/(a1*a1) - endif - endif - elseif(lakon(nelem)(4:5).eq.'EL') then -! -! pipe, sudden enlargement Idelchik version: reynolds dependent, -! 0.01 <= section ratio <= 0.6 -! - a1=prop(index+1) - a2=prop(index+2) - dh=prop(index+3) - if(inv.eq.0) then - reynolds=5000.d0 - else - reynolds=xflow*dh/(dvi*a1) - endif - if(inv.ge.0) then - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - if(inv.ne.0) then - xk=zeta/(a1*a1) - else - xkp=zeta/(a1*a1) - endif - endif - if(inv.le.0) then - reynolds=-reynolds -! -! setting length and angle for contraction to zero -! - prop(index+4)=0.d0 - prop(index+5)=0.d0 - lakon(nelem)(4:5)='CO' - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - lakon(nelem)(4:5)='EL' - if(inv.ne.0) then - xk=zeta/(a1*a1) - else - xkn=zeta/(a1*a1) - endif - endif - elseif(lakon(nelem)(6:7).eq.'CO') then -! -! pipe, sudden contraction Berlamont version: fully turbulent -! all section ratios -! - a1=prop(index+1) - a2=prop(index+2) - ratio=a2/a1 - call ident(xcoel,ratio,ncoel,id) - if(inv.ge.0) then - if(id.eq.0) then - zeta=yco(1) - elseif(id.eq.ncoel) then - zeta=yco(ncoel) - else - zeta=yco(id)+(yco(id+1)-yco(id))*(ratio-xcoel(id))/ - & (xcoel(id+1)-xcoel(id)) - endif - if(inv.ne.0) then - xk=zeta/(a2*a2) - else - xkp=zeta/(a2*a2) - endif - endif - if(inv.le.0) then - if(id.eq.0) then - zeta=yel(1) - elseif(id.eq.ncoel) then - zeta=yel(ncoel) - else - zeta=yel(id)+(yel(id+1)-yel(id))*(ratio-xcoel(id))/ - & (xcoel(id+1)-xcoel(id)) - endif - if(inv.ne.0) then - xk=zeta/(a2*a2) - else - xkn=zeta/(a2*a2) - endif - endif - elseif(lakon(nelem)(4:5).eq.'CO') then -! -! pipe, sudden contraction Idelchik version: reynolds dependent, -! 0.1 <= section ratio <= 0.6 -! - a1=prop(index+1) - a2=prop(index+2) - dh=prop(index+3) - if(inv.eq.0) then - reynolds=5000.d0 - else - reynolds=xflow*dh/(dvi*a2) - endif - if(inv.ge.0) then - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - if(inv.ne.0) then - xk=zeta/(a2*a2) - else - xkp=zeta/(a2*a2) - endif - endif - if(inv.le.0) then - reynolds=-reynolds - lakon(nelem)(4:5)='EL' - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - lakon(nelem)(4:5)='CO' - if(inv.ne.0) then - xk=zeta/(a2*a2) - else - xkn=zeta/(a2*a2) - endif - endif - elseif(lakon(nelem)(6:7).eq.'DI') then -! -! pipe, diaphragm -! - a=prop(index+1) - a0=prop(index+2) - a1=a - a2=a - ratio=a0/a - call ident(xdi,ratio,ndi,id) - if(id.eq.0) then - zeta=ydi(1) - elseif(id.eq.ndi) then - zeta=ydi(ndi) - else - zeta=ydi(id)+(ydi(id+1)-ydi(id))*(ratio-xdi(id))/ - & (xdi(id+1)-xdi(id)) - endif - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - elseif(lakon(nelem)(6:7).eq.'EN') then -! -! pipe, entrance (Berlamont data) -! - a=prop(index+1) - a0=prop(index+2) - a1=a*1.d10 - a2=a - ratio=a0/a - call ident(xen,ratio,nen,id) - if(id.eq.0) then - zeta=yen(1) - elseif(id.eq.nen) then - zeta=yen(nen) - else - zeta=yen(id)+(yen(id+1)-yen(id))*(ratio-xen(id))/ - & (xen(id+1)-xen(id)) - endif - if(inv.ne.0) then - if(inv.gt.0) then -! entrance - xk=zeta/(a*a) - else -! exit - xk=1.d0/(a*a) - endif - else - xkn=1.d0/(a*a) - xkp=zeta/(a*a) - endif - elseif(lakon(nelem)(4:5).eq.'EN') then -! -! pipe, entrance (Idelchik) -! - a1=prop(index+1) - a2=prop(index+2) - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) -! -! check for negative flow: in that case the loss -! coefficient is wrong -! - if(inv.lt.0) then - write(*,*) '*ERROR in liquidpipe: loss coefficients' - write(*,*) ' for entrance (Idelchik) do not apply' - write(*,*) ' to reversed flow' - stop - endif - if(inv.ne.0) then - xk=zeta/(a2*a2) - else - xkn=zeta/(a2*a2) - xkp=xkn - endif - elseif(lakon(nelem)(4:5).eq.'EN') then -! -! pipe, exit (Idelchik) -! - a1=prop(index+1) - a2=prop(index+2) - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - if(inv.lt.0) then - write(*,*) '*ERROR in liquidpipe: loss coefficients' - write(*,*) ' for exit (Idelchik) do not apply to' - write(*,*) ' reversed flow' - stop - endif - if(inv.ne.0) then - xk=zeta/(a1*a1) - else - xkn=zeta/(a1*a1) - xkp=xkn - endif - elseif(lakon(nelem)(4:5).eq.'US') then -! -! pipe, user defined loss coefficient -! - a1=prop(index+1) - a2=prop(index+2) - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - if(inv.lt.0) then - write(*,*) '*ERROR in liquidpipe: loss coefficients' - write(*,*) ' for a user element do not apply to' - write(*,*) ' reversed flow' - stop - endif - if(a1.lt.a2) then - a=a1 - else - a=a2 - endif - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - elseif(lakon(nelem)(6:7).eq.'GV') then -! -! pipe, gate valve -! - a=prop(index+1) - alpha=prop(index+2) - a1=a - a2=a - call ident(xgv,alpha,ngv,id) - if(id.eq.0) then - zeta=ygv(1) - elseif(id.eq.ngv) then - zeta=ygv(ngv) - else - zeta=ygv(id)+(ygv(id+1)-ygv(id))*(alpha-xgv(id))/ - & (xgv(id+1)-xgv(id)) - endif - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - elseif(lakon(nelem)(6:7).eq.'BE') then -! -! pipe, bend; values from Berlamont -! - a=prop(index+1) - rd=prop(index+2) - alpha=prop(index+3) - coarseness=prop(index+4) - a1=a - a2=a - call ident(xbe,rd,nbe,id) - if(id.eq.0) then - zeta=ybe(1)+(zbe(1)-ybe(1))*coarseness - elseif(id.eq.nbe) then - zeta=ybe(nbe)+(zbe(nbe)-ybe(nbe))*coarseness - else - zeta=(1.d0-coarseness)* - & (ybe(id)+(ybe(id+1)-ybe(id))*(rd-xbe(id))/ - & (xbe(id+1)-xbe(id))) - & +coarseness* - & (zbe(id)+(zbe(id+1)-zbe(id))*(rd-xbe(id))/ - & (xbe(id+1)-xbe(id))) - endif - zeta=zeta*alpha/90.d0 - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - elseif(lakon(nelem)(4:5).eq.'BE') then -! -! pipe, bend; values from Idelchik or Miller -! - a=prop(index+1) - dh=prop(index+3) - a1=a - a2=a - if(inv.eq.0) then - reynolds=5000.d0 - else - reynolds=dabs(xflow)*dh/(dvi*a1) - endif - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - elseif(lakon(nelem)(4:5).eq.'LO') then -! -! long orifice; values from Idelchik or Lichtarowicz -! - a1=prop(index+1) - a2=prop(index+1) - dh=prop(index+3) - if(inv.eq.0) then - reynolds=5000.d0 - else - reynolds=dabs(xflow)*dh/(dvi*a1) - endif - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - if(inv.ne.0) then - xk=zeta/(a1*a1) - else - xkn=zeta/(a1*a1) - xkp=xkn - endif - a2=a1 - elseif(lakon(nelem)(4:5).eq.'WA') then -! -! wall orifice; values from Idelchik -! -! entrance is infinitely large -! - a1=1.d10*prop(index+1) -! -! reduced cross section -! - a2=prop(index+2) - dh=prop(index+3) - if(inv.eq.0) then - reynolds=5000.d0 - else - reynolds=dabs(xflow)*dh/(dvi*a2) - endif - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) -! -! check for negative flow: in that case the loss -! coefficient is wrong -! - if(inv.lt.0) then - write(*,*) '*ERROR in liquidpipe: loss coefficients' - write(*,*) ' for wall orifice do not apply to' - write(*,*) ' reversed flow' - stop - endif - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - elseif(lakon(nelem)(4:5).eq.'BR') then -! -! branches (joints and splits); values from Idelchik and GE -! - if(nelem.eq.int(prop(index+2))) then - a=prop(index+5) - else - a=prop(index+6) - endif - a1=a - a2=a - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) -! -! check for negative flow: in that case the loss -! coefficient is wroing -! - if(inv.lt.0) then - write(*,*) '*ERROR in liquidpipe: loss coefficients' - write(*,*) ' for branches do not apply to' - write(*,*) ' reversed flow' - stop - endif - if(inv.ne.0) then - xk=zeta/(a*a) - else - xkn=zeta/(a*a) - xkp=xkn - endif - endif -! - xk1=1.d0/(a1*a1) - xk2=1.d0/(a2*a2) -! - if(iflag.eq.1) then - xflow=(z1-z2+(p1-p2)/rho)/(xk2-xk1+xkp) - if(xflow.lt.0.d0) then - xflow=(z1-z2+(p1-p2)/rho)/(xk2-xk1-xkn) - if(xflow.lt.0.d0) then - write(*,*) '*WARNING in liquidpipe:' - write(*,*) ' initial mass flow could' - write(*,*) ' not be determined' - write(*,*) ' 1.d-10 is taken' - xflow=1.d-10 - else - xflow=-rho*dsqrt(2.d0*xflow) - endif - else - xflow=rho*dsqrt(2.d0*xflow) - endif - else - df(3)=1.d0/rho - df(1)=-df(3) - df(2)=(xk2-xk1+inv*xk)*xflow/(rho*rho) - f=df(3)*p2+df(1)*p1+df(2)*xflow/2.d0+z2-z1 - endif -! - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/liquidpump.f calculix-ccx-2.3/ccx_2.1/src/liquidpump.f --- calculix-ccx-2.1/ccx_2.1/src/liquidpump.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/liquidpump.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,132 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine liquidpump(node1,node2,nodem,nelem, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,rho,g,co,numf,mi) -! -! pump for incompressible media -! - implicit none -! - logical identity -! - integer nelem,nactdog(0:3,*),node1,node2,nodem, - & ielprop(*),nodef(4),idirf(4),index,iflag, - & inv,id,numf,npu,i,mi(2) -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(4), - & p1,p2,rho,g(3),dg,z1,z2,co(3,*), - & xpu(10),ypu(10),xxpu(10),yypu(10),dh -! - numf=3 -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif((iflag.eq.1).or.(iflag.eq.2))then -! - index=ielprop(nelem) -! - npu=nint(prop(index+1)) - do i=1,npu - xpu(i)=prop(index+2*i) - ypu(i)=prop(index+2*i+1) - enddo -! - p1=v(2,node1) - p2=v(2,node2) -! - z1=-g(1)*co(1,node1)-g(2)*co(2,node1)-g(3)*co(3,node1) - z2=-g(1)*co(1,node2)-g(2)*co(2,node2)-g(3)*co(3,node2) -! - if(iflag.eq.2) then - xflow=v(1,nodem) - if(xflow.ge.0.d0) then - inv=1 - else - inv=-1 - endif - nodef(1)=node1 - nodef(2)=nodem - nodef(3)=node2 - idirf(1)=2 - idirf(2)=1 - idirf(3)=2 - endif -! - dg=dsqrt(g(1)*g(1)+g(2)*g(2)+g(3)*g(3)) -! - if(iflag.eq.1) then - dh=(z2-z1+(p2-p1)/rho)/dg -! -! reverting the order in xpu and ypu and storing the -! result in xxpu and yypu -! - do i=1,npu - xxpu(i)=xpu(npu+1-i) - yypu(i)=ypu(npu+1-i) - enddo - call ident(yypu,dh,npu,id) - if(id.eq.0) then - xflow=xxpu(1) - elseif(id.eq.npu) then - xflow=0.d0 - else - xflow=xxpu(id)+(xxpu(id+1)-xxpu(id))*(dh-yypu(id))/ - & (yypu(id+1)-yypu(id)) - endif - else - df(1)=1.d0/rho - df(3)=-df(1) - xflow=xflow/rho - call ident(xpu,xflow,npu,id) - if(id.eq.0) then - if(xflow.ge.0.d0) then - f=z1-z2+(p1-p2)/rho+dg*ypu(1) - df(2)=0.d0 - else - df(2)=-1.d10 - f=z1-z2+(p1-p2)/rho+dg*(ypu(1)+xflow*df(2)) - df(2)=df(2)*dg/rho - endif - elseif(id.eq.npu) then - df(2)=-1.d10 - f=z1-z2+(p1-p2)/rho+dg*(ypu(npu)+df(2)*(xflow-xpu(npu))) - df(2)=df(2)*dg/rho - else - df(2)=(ypu(id+1)-ypu(id))/(xpu(id+1)-xpu(id)) - f=z1-z2+(p1-p2)/rho+dg*(ypu(id)+(xflow-xpu(id))*df(2)) - df(2)=df(2)*dg/rho - endif - endif -! - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/loadadd.f calculix-ccx-2.3/ccx_2.1/src/loadadd.f --- calculix-ccx-2.1/ccx_2.1/src/loadadd.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/loadadd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine loadadd(nelement,label,value,nelemload,sideload, - & xload,nload,nload_,iamload,iamplitude,nam,isector) -! -! adds a facial dload condition to the data base -! - implicit none -! - integer nelemload(2,*),iamload(2,*) -! - integer nelement,nload,nload_,j,iamplitude,nam,isector -! - real*8 xload(2,*) -! - real*8 value -! - character*20 label,sideload(*) -! - do j=1,nload - if((nelemload(1,j).eq.nelement).and. - & (nelemload(2,j).eq.isector).and. - & (sideload(j).eq.label)) then - xload(1,j)=value - if(nam.gt.0) iamload(1,j)=iamplitude - return - endif - enddo - nload=nload+1 - if(nload.gt.nload_) then - write(*,*) '*ERROR in loadadd: increase nload_' - stop - endif - nelemload(1,nload)=nelement - nelemload(2,nload)=isector - sideload(nload)=label - xload(1,nload)=value - xload(2,nload)=0. - if(nam.gt.0) then - iamload(1,nload)=iamplitude - iamload(2,nload)=0 - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/loadaddp.f calculix-ccx-2.3/ccx_2.1/src/loadaddp.f --- calculix-ccx-2.1/ccx_2.1/src/loadaddp.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/loadaddp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine loadaddp(nelement,label,nelemload,sideload, - & xload,nload,nload_,iamload,iamplitude,nam,node) -! -! adds a facial dload condition to the data base -! - implicit none -! - integer nelemload(2,*),iamload(2,*) -! - integer nelement,nload,nload_,j,iamplitude,nam,node -! - real*8 xload(2,*) -! - character*20 label,sideload(*) -! - do j=1,nload - if((nelemload(1,j).eq.nelement).and. - & (sideload(j).eq.label)) then - xload(1,j)=0.d0 - if(nam.gt.0) iamload(1,j)=iamplitude - return - endif - enddo - nload=nload+1 - if(nload.gt.nload_) then - write(*,*) '*ERROR in loadadd: increase nload_' - stop - endif - nelemload(1,nload)=nelement - nelemload(2,nload)=node - sideload(nload)=label - xload(1,nload)=0.d0 - xload(2,nload)=0. - if(nam.gt.0) then - iamload(1,nload)=iamplitude - iamload(2,nload)=0 - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/loadaddt.f calculix-ccx-2.3/ccx_2.1/src/loadaddt.f --- calculix-ccx-2.1/ccx_2.1/src/loadaddt.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/loadaddt.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine loadaddt(nelement,label,valfilm,valtemp,nelemload, - & sideload,xload,nload,nload_,iamload,iamptemp, - & iampfilm,nam,node) -! -! adds a thermal dload condition to the data base -! - implicit none -! - character*20 label,sideload(*) -! - integer nelemload(2,*),iamload(2,*), - & nelement,nload,nload_,j,iamptemp,nam,iampfilm,node -! - real*8 xload(2,*),valfilm,valtemp -! - do j=1,nload - if((nelemload(1,j).eq.nelement).and. - & (sideload(j).eq.label)) then - xload(1,j)=valfilm - xload(2,j)=valtemp - nelemload(2,j)=node - if(nam.gt.0) then - iamload(1,j)=iampfilm - iamload(2,j)=iamptemp - endif - return - endif - enddo - nload=nload+1 - if(nload.gt.nload_) then - write(*,*) '*ERROR in loadadd: increase nload_' - stop - endif - nelemload(1,nload)=nelement - sideload(nload)=label - xload(1,nload)=valfilm - xload(2,nload)=valtemp - nelemload(2,nload)=node - if(nam.gt.0) then - iamload(1,nload)=iampfilm - iamload(2,nload)=iamptemp - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/LOGBOOK calculix-ccx-2.3/ccx_2.1/src/LOGBOOK --- calculix-ccx-2.1/ccx_2.1/src/LOGBOOK 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/LOGBOOK 1970-01-01 00:00:00.000000000 +0000 @@ -1,1627 +0,0 @@ -======== -LOG-BOOK Version 2.1 -======== - -09 Nov 1998 - removed mistake from anisotropic.f - - faster code for orthotropic materials in stress.f and - elemmatr_pr.f (replacement of orthotropic.f); to be - implemented in elemmatr_la.f too. - -10 Nov 1998 - definition of sets within *NODE and *ELEMENT. - -11 Nov 1998 - several steps within one calculation. - - no allocation of mast1 and mast2 for static calculations. - -16 Nov 1998 - small correction to orientations. - - correction to material transformation in kyrinput. - -17 Nov 1998 - small corrections for multiple step calculations. - -23 Nov 1998 - correction for second order frequency calculations. - - resetting the loads for perturbative steps - -24 Nov 1998 - check for second order static calculations OK. - -26 Nov 1998 - frequency calculations with prestress works! At - buckling load the frequency reduces to zero. - -10 Dec 1998 - corrected an error in kyrinput (call of nquickx2). - -Jan 1999 - implemented LANSO for eigenvalue calculations: - did not work; abandoned. - - implemented ARPACK for eigenvalue calculations: - problems under Linux, which do not occur on the - IRIX. TO BE ANALYZED! - - implemented UMFPACK for static calculations: for - small problems half as fast as PROFILE; for big - problems too much memory grabbed; abandoned. - - implemented SPOOLES for static calculations: works - fine; for big problems and nested dissection ordering - about 25% faster than PROFILE (18,000 equations). - Probably even faster for really big problems and low - fill-in (> 50,000 equations and < 5 % fill-in). - -3 Feb 1999 - on a SGI, SPOOLES is about 7 times faster than the - profile method for about 110,000 degrees of freedom - (900 MB RAM needed). - -7 Feb 1999 - started reorganization: (*) instead of (1), implicit - none instead of implicit real*8(a-h,o-z) - -Mar 1999 - ARPACK works on Linux when compiled with FC=f77-f2c; reason - unclear; however, it is not necessarily faster than - LEVALH. Maybe calculating the largest eigenvalues of the - inverse matrix is faster? - -27 Mar 1999 - MODAL DYNAMIC works. Testing of buckling with ARPACK started. - -8 April 1999 - calculating frequencies in shift-invert mode with ARPACK/ - SPOOLES works and is significantly faster than the direct - mode (factor 4 or 5). - - BUCKLING works! - -18 April 1999 - checked shift-invert mode for big problems. Up to a factor - of 90 faster than the direct method! - - refined output selection: U, NT, S or E. - -21 April 1999 - united the routine composing the eigenvalue matrices - with the routine constructing the static stiffness matrix - (elemmatr_ei.f and elemmatr_st.f -> c_3d20.f) - - automation of the test routine (compare) - -20 May 1999 - reorganisation of the element topology information - - inclusion of C3D8 elements. - -7 juni 1999 - in previous releases 2nd order static calculations used - the large displacment stiffness only, 2nd order modal - calculations used the stress stiffness only. Now both - stiffnesses are used in any of these cases. What is - left to do is the use of the differential large deformation - matrix for buckling calculations (independent of iperturb), - in addition to the stress stiffness differential used now. - -6 juli 1999 - correction of small errors - -7 juli 1999 - removed lumping in modal analysis. Results match ABAQUS - results very well (deviation < 0.5 %). - -10 juli 1999 - started removing lumping from linear dynamic calculations. - eigenmodes should be normalized with respect to the mass - matrix. To do! - -11 juli 1999 - normalization with respect to the mass matrix done. Still - differences with ABAQUS for beta (damping coef) != 0. Maybe - there is still an error for the supercritical regime. To - check - - removed levalh and subprograms: default and only solver for - modal analysis is ARPACK - -31 juli 1999 - took care of inhomogeneous equations: introduce a dummy - node with fixed displacements. - -Sept. 1999 - started to work on geometrically nonlinear calculations - -26 Oct. 1999 - geometrically nonlinear option implemented and checked. - - in second order frequency calculations the material - temperatures from the previous nonperturbative step are - kept. - -2 Dec. 1999 - changed the extrapolated stress and strain values in the - midpoints of the 20-node elements to the ABAQUS convention, - i.e. extrapolation is made within each element after which - the mean is taken of values in neighboring elements. - -Dec. 1999 - started the implementation of hyperelastic solids, - hyperfoam materials and deformation plasticity. - -25 Dec. 1999 - removed an error in mafillsm and mafillpr: introduced - a new variable idof3 - -Jan-Feb 2000 - check of the hyperelastic capabilities; merges disp and - stress into one subroutine results to cover nonlinear - calculations with prescribed displacements. - -7 Feb 2000 - corrected an error in materialdata for mixed isotropic/ - orthotropic/anisotropic materials - -20 Feb 2000 - accelerated hyperelastic calculations by a factor of 15 - -5 Mar 2000 - deformation plasticity works (mechanical forces)! - -9 Mar 2000 - deformation plasticity subject to thermal forces works! - -30 April 2000 - C3D20R seems to work very well for thick and thin shells - (just one layer of brick elements) - - upgraded to SPOOLES.2.2. - -19 May 2000 - started implementing implicit and explicit integration - dynamics - -June 2000 - implementation nonlinear dynamics finished; - needs checking - - material data are determined in each integration point - separately instead of per element - -3 July 2000 - corrected an error occurring in nonlinear calculations - with mpc's - -July 2000 - changed the stress-strain curve to be given for deformation - plasticity from 2nd Piola-Kirchhoff stress vs. Lagrangian - strain to true stress vs. Eulerian strain. - -18 July 2000 - included extrapolation of one increment to the next: - accelerates convergence - -5 Aug 2000 - started implementing incremental plasticity with - isotropic and/or kinematic hardening - -Sept 2000 - started checking implicit and explicit dynamics - -18 Sept 2000 - corrected the allocation of jq: 3*nk+1 (needed in - mastruct) - - implicit and explicit dynamics seem to work! - However, the calculation of the initial acceleration due - to a sudden load change at the start of a step, requiring - the solution of a linear equation set with the full mass - matrix causes problems: the solution of the system is not - plausible (1.e24). The problem improves drastically by - adding some stiffness to the mass. - -1 Oct 2000 - the only environment variable left is the job-name - all other file names are derived from the job-name: - .inp,.dat,.frd,.eig and .sta - - changed CALCULIX into CalculiX - - stored increment information in the .sta file - -15 Oct 2000 - started to replace the FORTRAN input files by C input - files; purpose: automatic reallocation if the problem - data size exceed preset values - -16 Oct 2000 - postponed the replacement of FORTRAN by C to a later date; - -6 Nov 2000 - isotropic incremental plasticity works for beam - example! - -16 Nov 2000 - implemented interpolation between hardening curves at - different temperatures - -9 Dec 2000 - accelerated nonlinear calculations for given - displacements or temperatures: first iteration in - a new increment must be purely linear elastic - -23 Dec 2000 - put version 0.9 on our webpage - -28 Dec 2000 - started to implement creep; user routines option provided - for plastic hardening curves and the creep law. - -17 Jan 2001 - creep (viscoplasticity) works - -25 Jan 2001 - looked into iterative solvers (ITPACK-nspcg and - pcgsolver-TU-Muenchen) - -4 Feb 2001 - abandoned iterative solvers: worked for small - examples (1,000 DOFs) but not for intermediate ones - (20,000 DOFs) - -5 Feb 2001 - started to implement cyclic symmetry - -6 Feb 2001 - fixed format is not longer supported. Use free format. - -16 Feb 2001 - invested some more time in pcgsolver. Works well - with Cholesky preconditioning. Convergence slow for - 2-D problems such as plates. For large, compact 3-D problems - faster than SPOOLES. Pcgsolver can be selected for - linear problems (test phase). - -27 Feb 2001 - started to implement C3D8R, C3D20 and C3D10 elements. - -10 Mar 2001 - changed the Nested Dissection Ordering in SPOOLES to - Multi-Section Ordering. Seems to be faster for medium - size problems (150,000 DOF). - - implemention of C3D8R, C3D20 and C3D10 elements - successfully finished. - -26 Mar 2001 - introduced pre-processor directives to cope with different - C - FORTRAN interface conventions on different machines - (underscore or not) - -27 Mar 2001 - changes input and output format from record length 80 to - record length 132 - - started to code transformations (rectangular and - cylindrical) (*TRANSFORM). - -21 Apr 2001 - introduced an iterative procedure to improve the - results in a *BUCKLE procedure: the buckling factor - is linked to the value of sigma (ARPACK) - - transformations work - - started to implement the iterative procedure for - nonlinear calculations - -22 Apr 2001 - iterative procedure for nonlinear calculations works - -30 Apr 2001 - collapsed elements work now! (changed the add*f subroutines) - - corrected some storage inconsistensies in CalculiX.c; should - solve the problems encountered when several steps occur in - the same input deck. - -2 May 2001 - corrected an error leading to wrong results for - element types with weight different from 1 and anisotropic - material behavior (subroutines orthonl.f and anisonl.f: - forgot to multiply with weight) - -14 May 2001 - changed the Sloan renumbering routines to allow skylines - larger than 4-byte integers (>2147483647). - -17 May 2001 - started to change mastruct from FORTRAN to C in order to - be able to reallocate the # of nonzero's in the matrix - -21 May 2001 - automatic reallocation of nonzero's works - -26 May 2001 - started automatic allocation of input data - (subroutine allocation.f) - -5 June 2001 - auomatic allocation works; - - started implementation of cyclic symmetry conditions - for frequency calculations - -23 June 2001 - corrected an error in the residual stress (- sign) - -19 July 2001 - started to work on tetrahedral meshing of point - clouds - -9 Aug 2001 - tetrahedral meshing of a box enclosing a point - cloud works - -14 Sep 2001 - corrected an error in file incplas.f: - "c9=c6*umb*3.d0" replaced by "c9=c6*3.d0" - -18 Sep 2001 - started change from updated Lagrangian to total - Lagrangian for incremental plasticity - -7 Oct 2001 - concluded change to total Lagrangian formulation - - started introduction of field xstiff and xstate - in preparation for umat routine - -25 Oct 2001 - wrote first user material subroutine - -29 Oct 2001 - umat (material) subroutine seems to work - -24 Nov 2001 - included stress at start of increment in umat - - new investigation of cyclic symmetry: frequencies - are correct, eigenmodes too, except at the - dependent boundary - -25 Nov 2001 - cyclic symmetry seems to work! - -29 Nov 2001 - correction for MPC's with only one term (= zero - SPC) - -9 Dec 2001 - mapping of the results for one sector to other sectors - in a cyclic symmetry calculation works. - -7 Jan 2002 - started coding rigid body motion - - worked on tension-only umat routine - -8 Jan 2002 - corrected an error in the C translation in mastructcs.c - -11 Jan 2002 - corrected an integer internal overflow in arpackcs.c - -30 Jan 2002 - finished coding rigid body motion - - cyclic symmetry in conjunction with other MPC's works - -7 Feb 2002 - fixed some minor errors related to *FREQUENCY and - *BUCKLING - -March 2002 - started to work on the theory manual. - -2 Apr 2002 - corrected an error in frdcyc: the coordinates have - to be duplicated also for kode>1 - -10 Apr 2002 - corrected an error in boundaries: deletion of SPCs - in local coordinate systems with OP=NEW did not work - properly - -16 Apr 2002 - continued to work on rigid body motion and nonlinear - mpc's in general - -27 Apr 2002 - *RIGID BODY works - - with RF only EXTERNAL forces are obtained. If a MPC - connects two nodes of the structure, the force - is internal and cannot be obtained using RF. - -5 June 2002 - allowed for nested *INCLUDE statements up to three - levels deep - -12 June 2002 - took out the normalization of the displacements in - arpackbu.c (buckling). - -6 July 2002 - changed getnewline: the input is freed from blanks - and changed to upper case. Thus, input is more - flexible. - -17 July 2002 - same name can be used for node sets and element sets - internally, a "N" or "E" is appended to distinguish - them - -18 July 2002 - sets can be defined using previously defined sets - - abbreviating u_calloc with NNEW - -24 July 2002 - a set can be defined using multiple *NSET or *ELSET - cards - - abbreviating realloc with RENEW - -29 July 2002 - corrected a bug in boundaries.f which occurred when - SPC's in transformed coordinates were removed with - OP=NEW - -6 Sept 2002 - corrected wrong file names in some of the *WARNING - and *ERROR messages - - initialized all allocation size variables in - CalculiX.c - -16 Sept 2002 - started to code umat_elastic_fiber.f to model fiber - reinforced hyperelastic materials - -26 Sept 2002 - umat_elastic_fiber.f seems to work - -28 Sept 2002 - changed the names of the stress tensors - -1 Oct 2002 - started to code the energy calculation - -3 Oct 2002 - the energy calculation seems to work - - implemented the local orientation option in the - umat routine - -5 Oct 2002 - got rid of the environment variable; ccx is started - with -i flag for the input file (without .inp) - -9 Oct 2002 - started to change cascade: solving for the dependent - DOFs in the MPCs using SPOOLES - -29 Oct 2002 - finished C-version of cascade. The decascading is - performed by calling SPOOLES to solve the - nonsymmetric system of equations. - -3 Nov 2002 - execution of renumber.f is removed for SPOOLES - -4 Nov 2002 - started to treat nonlinear MPC's more generally: - variable number of MPC terms between iterations - must be taken into account - -8 Nov 2002 - corrected an error in cycsymmods.f - -16 Nov 2002 - started to work on STRAIGHT, PLANE and MEAN ROTATION - nonlinear MPCs - -21 Nov 2002 - started to work on plane strain, plane stress, - axisymmetric, shell and beam elements - -Dec 2002 - started to work on single crystal plasticity - -15 Jan 2003 - STRAIGHT, PLANE and MEAN ROTATION MPCs seem to work - -18 Jan 2003 - *AMPLITUDE can also be used for linear static - calculations - - linear MPCs can have more than 9 terms - -26 Jan 2003 - updating the User's Manual and the test example set - - finishing the tests on plane strain, plane stress, - axisymmetric, shell and beam elements - - the use of SPOOLES in cascade leads to significant - longer run times. Original method is restored and - translated into C. SPOOLES maybe useful for MPC's - with a large radius of influence such as - incompressibility. - - fixed the connection between solid elements and 1-D - or 2-D elements. - -8 Feb 2003 - the internal state variables can be stored in the - .dat and .frd file - - improved the boundary conditions for plane strain, - plane stress and axisymmetric elements. - -9 Feb 2003 - single crystal umat seems to work - (caveat: for ithermal=0 the field eth(1..6) is not - defined) - -13 Feb 2003 - corrected some mistakes in cycsymmods.f - -27 Feb 2003 - changed the meaning of OP=NEW - - changed the effect of output options in multi-step - analyses - -01 Mar 2003 - corrected an error in the energy calculation and - incremental plasticity: calculation of irreversible - quantities must start from the values at the start - of the increment and not rely on intermediate values - -04 Mar 2003 - solved the problem with beammr (definition of neq - in CalculiX.c for icascade!=0) - -02 Apr 2003 - started to work on wedges and 4-node tets - - corrected the implementation of the alpha method - (starting acceleration zero); convergence is - accelerated - -09 Apr 2003 - changed integration scheme for the mass matrix in - dynamic calculations with discontinuous forces - -10 Apr 2003 - simplified shape functions for 20-node hexa elements - -13 Apr 2003 - changed extrapolation coefficients for C3D20 - - replaced alp=.2215 by alp=.2917 for explicit dynamic - calculations with 20-node elements (e_c3d.f) - - important change in ikmpc and ikboun: 6 DOFs are - assigned to each node instead of 3 DOFs - -27 Apr 2003 - introduced for frequency calculations a stiffness - contribution due to centrifugal forces - -01 May 2003 - started working on stiffness contribution of - distributed surface loads - -06 May 2003 - stiffness contribution of distributed surface - loads seems to work - -10 May 2003 - introduced rotational DOFs for shells and beams - -26 May 2003 - added the parameter TIME=TOTAL TIME to the - *AMPLITUDE keyword card - -04 June 2003 - introduced bending moment and torque for 1d and 2d - structures - - allowed for seven DOFs in ikboun, ikforc and ikmpc: - DOF zero is reserved for the temperature - - tet4, wedge6 and wedge15 seem to work - -08 June 2003 - MPC's can contain rotational degrees of freedom now - -11 June 2003 - started to code thermal calculations - -14 June 2003 - changed the first dimension of v,vold,vini,veold, - accold,veini,accini,fn,nactdof,vt and fnt to four in - order to accommodate temperature and thermal flux - -23 June 2003 - introduced the logical parameters mass, stiffness, - buckling and rhs to decide which entities to build. - -25 June 2003 - changed xload(i) to xload(1..2,i), similarly for - nelemload and iamload to accommodate both convection/ - radiation coefficients and environmental temperatures - for heat transfer calculations - -17 Juli 2003 - started forced convection and cavity radiation - -31 Juli 2003 - introduced the keyword card *CONTROLS to control - convergence and allow for linear calculations with - 1d and 2d elements. - -2 Aug 2003 - allowed for linear calculations with 1-D and 2-D - elements (beams, shells..) by setting the - convergence criteria to 1.d+30. - -3 Aug 2003 - allowed for linearization of *MPC constraints and - *RIGID BODY constraints by adapting the convergence - criteria to 1.d+30. - -31 Aug 2003 - change integration point numbering for C3D15 - (conform to ABAQUS) - -5 Oct 2003 - reintroduced damping in direct dynamic calculations; - improves performance without deteriorating the - quality of the results - -7 Oct 2003 - started to work on a restart file - -29 Oct 2003 - corrected a bug in the calculation of the - distributed load stiffness - - finished the restart capability - -29 Nov 2003 - reorganization of the output in the .dat file: - output is grouped per set (node set/element set) - - implementation of whole element output: ELSE and - EVOL, TOTALS=YES and TOTALS=ONLY - -03 Dec 2003 - read and write files for a RESTART are now - different: extension .rin for RESTART,READ and - .rout for RESTART,WRITE - - there is no default any more for *EL FILE and - *NODE FILE - -09 Dec 2003 - corrected a mistake in restartshort.f - -23 Dec 2003 - finished the theory manual! - -26 Dec 2003 - maxlenmpc is stored in the restart file - - removed a possible division through zero in - arpackcs.c (cyclic symmetry) - -5 Jan 2004 - introduced a new field typeboun to classify the type - of boundary conditions. Only the BC's defined by - *BOUNDARY should be deleted for OP=NEW. - types: R=rigidbody, P=planempc, S=straightmpc - M=midplane, U=usermpc and B=boundary. - -6 Jan 2004 - prescribing the displacements of all DOFs is now - possible (neq=0) - -12 Jan 2004 - improved the convergence of STRAIGHT and PLANE MPC's - -14 Jan 2004 - changed the syntax of - *INITIAL CONDITIONS,TYPE=STRESS: the residual stress - tensor must be given in each integration point, - not just one tensor per element - - corrected an error in allocation.f - -19 Jan 2004 - made a correction for dynamic calculations in - allocation.f - - made a correction for restart calculations: - additional definitions of amplitudes and sets is - allowed. - -20 Jan 2004 - started to check thermal analysis - -21 Jan 2004 - made a correction in incplas.f for thermal - viscoplastic calculations (J_mech) - -24 Jan 2004 - corrected an error in cycsymmods.f - -26 Jan 2004 - coded the output of heat flux and heat generation - -2 Feb 2004 - introduced nenerold to take energy requests into - account in frequency steps with preload. - -22 Feb 2004 - started the user subroutines for heat flux, the film - coefficient and the emissivity - -24 Feb 2004 - the elastically anisotropic material model with von - Mises viscoplasticity is automatically selected as - soon as a *PLASTIC, *CYCLIC HARDENING or *CREEP card - is combined with a *ELASTIC,TYPE=ORTHO card. - -26 Feb 2004 - finished the user subroutines dflux.f, film.f, - radiate.f and dload.f - -28 Feb 2004 - introduced uniform and nonuniform body-generated - heat flux; seems to work. - -2 Mar 2004 - started changing the way the input is read: the - importance of the order of the cards is minimized - -8 Mar 2004 - made the step time and total time available in the - umat routines - -9 Mar 2004 - started to make changes to distinguish between the - mechanical and thermal part of the equation system - (e.g. neq is replace by neq[0] and neq[1]). This - is needed for instationary thermal calculations - -13 Mar 2004 - blank lines in the input file are disregarded - - new materials can be defined after a restart - - primary creep was included in the Norton creep law - (power of total time) - -17 Mar 2004 - started to work on reducing the effect of the order - of the keywords in the input deck - -22 Mar 2004 - changed the calculation of the strain in - perturbative frequency and buckling steps: the - strain is calculated about the deformed - configuration - -25 Mar 2004 - reduction of the effect of the order in the input - deck seems to work - -30 Mar 2004 - the input data for *FREQUENCY were changed: now, you - can restrict the eigenfrequencies to an interval by - specifying its lower and upper value. - -31 Mar 2004 - transient heat transfer calculations seem to work - -21 April 2004 - forced convection heat transfer works - -23 April 2004 - first calculations with cavity radiation - -22 May 2004 - first acoustic frequency calculations - - static step following heat transfer step works - -10 June 2004 - changed sideload from character*5 to character*20 - allows user-defined name for user-defined loading - -12 June 2004 - started changes to allow for modal dynamic calculations - of the standard wave equation (e.g. in acoustics, - shallow waves etc.) - -30 June 2004 - forces can be summed and the sum printed in the - .dat file (TOTALS=YES or TOTALS=ONLY) - - modal dynamics of phenomena governed by the - Helmholtz equations seems to work - -12 July 2004 - changed the * format in internal reads for integers - into '(i40)' - -22 July 2004 - included the changes by Manfred Spraul enabling - multithreading with SPOOLES - -3 Aug 2004 - made the SPOOLES call modular (in order to easily - include TAUCS and other solvers). - -8 Aug 2004 - changed the * format in internal reads for reals - into '(f40)' - - included options to call TAUCS and the SGIsolver - (at compile time with -DTAUCS and -DSGI) - -11 Aug 2004 - started to work on the storage of results in local - coordinates - -13 Aug 2004 - storing results in local coordinates works. - (GLOBAL=YES or GLOBAL=NO after the *EL PRINT, *EL FILE - *NODE PRINT and *NODE FILE keyword cards). - -4 Sept 2004 - the value of jout is kept across the increments - unless a new value is defined - -5 Sept 2004 - removed an error: xload was sorted, xloadold was not - now xloadold is sorted as well (routine isortiddc) - -8 Sept 2004 - coupled temperature-displacement calculations work - -14 Sept 2004 - started to code 6-noded triangular 2-d elements - (they are expanded to 15-node wedges) - - started to work on 1-D and 2-D elements for - thermal and thermomechanical calculations - -16 Sept 2004 - splitting of gen3delem.f in smaller subroutines started - -17 Sept 2004 - splitting of gen3delem.f finished - -6 Oct 2004 - 6-nodes 2-d elements work - - 1-d and 2-d elements for thermal calculations work - - started to work on axisymmetric elements for - cavity radiation - -7 Oct 2004 - cavity radiation for axisymmetric elements works - -10 Oct 2004 - in case of divergence the actual solution fields - and residual forces are stored in the frd file - -14 Oct 2004 - started an interface between the ABAQUS umat user - routine and CalculiX umat user routine. - -19 Oct 2004 - introduced mechanical strain to calculate the - energy density and for the ABAQUS umat user routine - -25 Oct 2004 - changed the syntax of *NODAL DAMPING to provide - compatibility with ABAQUS - - introduced the heat transfer elements DC3D4,DC3D6, - DC3D10,DC3D15 and DC3D20 for compatility with ABAQUS. - Internally, they are identical to C3D4, C3D6 etc. - -30 Oct 2004 - CalculiX checks length of set names, amplitude names.. - to verify whether they do not exceed 20 characters - -31 Oct 2004 - removed alph from linel: everything is based on - eth now (thermal strain) - -7 Nov 2004 - started to work on maximum distance MPC - -16 Nov 2004 - removed an error in mastruct.c (loop should start from - 0 instead of 1) - -18 Nov 2004 - introduced a field fmpc for the MPC force - -24 Nov 2004 - corrected an error in mastructcs.c (cf. 16 Nov). - -25 Nov 2004 - introduced a variable idiscon to mark a discontinuity; - if a discontinuity occurs the displacements at the - start of the next increment are not extrapolated - -28 Nov 2004 - introduced a new field irowsgi in routine sgi.c - -8 Dec 2004 - included tieset and ntie in the restart files - -11 Dec 2004 - started to code the gap MPC. - -21 Dec 2004 - corrected some small errors in dyna and dynsolv - -23 Dec 2004 - introduced sorted search for amplitudes (identamta.f) - -4 Jan 2005 - finalized the DIST and GAP MPC; made the GAP MPC - accessible through a GAPUNI element and *GAP card. - - adjusted the year in the copyright statement - -5 Jan 2005 - worked on dealing with ABAQUS umat routines for nonlinear - materials (umat_abaqusnl) - -22 Jan 2005 - started to implement the possibility to define several - volumetric forces within one structure - -2 Feb 2005 - removed an error in e_c3d.f (for lumping) - - allowed for smaller increments in dynamic explicit - calculations - - checked the size of force and displacement residuals - if too big, the increment size is reduced - -13 Feb 2005 - several volumetric forces within one structure work; - - generalized gravity works - -18 Feb 2005 - applied constraints to nodes on a cyclic symmetry - axis in static calculations - -26 Feb 2005 - material, orientation, amplitude and set names - are scheduled to be 80 characters long, textpart - is scheduled to be 132 characters long. - -2 Mar 2005 - finished extending names and textpart - -3 Mar 2005 - create user routines utemp and cflux; added field vold - in user routines dflux, film and radiate. - -12 Mar 2005 - introduced the parameter TIME DELAY to shift the time - within an amplitude - -29 Mar 2005 - started the inclusion of nonzero SPCs in modal dynamic - calculations (similar to *BASE MOTION in ABAQUS) - -2 Apr 2005 - changed dynsolv from FORTRAN to C - -17 Apr 2005 - inclusion of nonzero SPCs in modal dynamic calculations - works - -19 Apr 2005 - started to work on steady state dynamics (harmonic loading) - -3 May 2005 - steady state dynamics works (harmonic loading) - -10 May 2005 - started steady state dynamics for nonharmonic periodic - loading - -16 May 2005 - started *SENSITIVITY to determine eigenvalues of - geometrically slightly perturbed structures - -30 May 2005 - steady state dynamics for nonharmonic periodic loading - works - -22 Juni 2005 - started a more efficient storage of the boundary - stiffness coefficients (those stiffness coefficients - which correspond to SPC's; important for modal - dynamic calculations) - -29 Juni 2005 - changed application of force to axisymmetric elements: - now, the force is the one applied to the sector the angle - of which is defined on the *SOLID SECTION card, and not - the total force over 2*pi - - new storage works (fields neq and nzs have now a - length 3) - -5 July 2005 - created user subroutine massflowrate.f - -6 July 2005 - removed an error in CalculiX.c: if nam>0, iamload - must be sorted too in routine isortiddc. - -10 July 2005 - corrected an error in radflowload.f - - allowed for description in .frd file - -16 July 2005 - corrected an error in gen3dconnect.f - -23 July 2005 - simplified some code in results.f - - worked on 1d/2d output of 1d/2d elements - -26 July 2005 - worked on section forces - -30 July 2005 - 1d/2d output and section forces work - - for axisymmetric elements *CLOAD, *CFLUX and - *MASS FLOW RATE are to be defined for the complete - circumference - -31 July 2005 - for 1d/2d elements NLGEOM is selected automatically - -11 Aug 2005 - corrected an error in map3dto1d2d.f - -5 Sept 2005 - corrected an error in solidsections (axisymmetric - elements) - -7 Sept 2005 - changed nonlingeo, radflowload and results: now the - gas temperatures are taken into account in the - convergence check (cam) - -9 Sept 2005 - same issue is on Sept 7: if gas temperatures are - calculated the "displacement" convergence check is - mandatory, no matter the size of the residual forces - -13 Sept 2005 - removed sensitivity.c and sensitivities.f (did not - bring any gain). - -14 Sept 2005 - changed renumber.f such that gaps in the node numbering - do not increase the execution time - -21 Sept 2005 - inserted temporarily the Zienckiewicz-Zhu error - estimator - -23 Sept 2005 - finished the coding of the Zienckiewicz-Zhu error - estimator for C3D20R elements - -28 Sept 2005 - put part of nonlingeo.c into checkconvergence.c - -29 Sept 2005 - put part of nonlingeo.c into calcresidual.c - rename residual.f into storeresidual.f - -1 Oct 2005 - extrapolation of previous results as start values - for the next increment is not done at the start - of a new step, else it is always done (nonlingeo.c) - -2 Oct 2005 - introduced user routine sigini.f for the - specification of initial stress fields - -10 Oct 2005 - started a major revision of the fluid elements for - forced convection purposes: now - they consist of three nodes, in the end nodes the - temperature is unknown, in the middle node the mass - flow rate is to be given (DOF 1) with *BOUNDARY - - revision of the convection equations in radflowload.f - to reach agreement with QTRAN - -11 Oct 2005 - finished forced convection changes - -24 Oct 2005 - started the generation of cyclic symmetry conditions - for dissimilar meshes - -6 Nov 2005 - cyclic symmetry conditions for dissimilar meshes work - -14 Nov 2005 - corrected an error in mastructcs.c (element types - C3D4, C3D6 and C3D15 were not taken into account) - -16 Nov 2005 - got rid of the NORENUMBER option: not needed any more - -1 Dec 2005 - corrected an error in e_c3d.f and linel.f - (initial shear stresses) - -9 Dec 2005 - corrected an error in some umat routines: +beta - should be -beta - -12 Dec 2005 - started to work on modal dynamics and steady state - dynamics for cyclic symmetric structures - -22 Jan 2006 - adapted dyna.c (modal dynamics) for cyclic symmetry - calculations - -30 Jan 2006 - performed some changes to prepare for gas dynamics - calculations: instead of *SOLID SECTION, *GAS SECTION - should be used. - -9 Feb 2006 - corrected an error related to nam and nam_ in CalculiX.c - and calinput.f - -27 Feb 2006 - corrected an error in dyna.c and steadystate.c: t0, - t1old, t1 and iamt1 must be reallocated for cyclic - symmetric structures - -28 Feb 2006 - started the implementation of a thermal user material - -5 March 2006 - refined the cyclic symmetry conditions for - dissimilar meshes. - -6 March 2006 - starting a harmonized treatment of linear and - nonlinear materials. - -7 March 2006 - the profile solver is inactivated - -12 March 2006 - the harmonization of linear and nonlinear materials - is finished. - -17 March 2006 - allowing for more than one gravity load in an element - -26 March 2006 - heat conduction through the edges of a shell element - and the face of a plane stress element is possible - -2 April 2006 - started the extension of the forced convection - formulation into an aerodynamic network: - implementation of the orifice element - -14 April 2006 - introduced a Laplace-type method to find initial - pressures in an aerodynamic network - -20 April 2006 - started coding liquid networks - -23 April 2006 - calculations with liquid networks work - -9 May 2006 - allowed for imaginary gravity and centrifugal - loading (for steady state dynamics) - -12 May 2006 - speeded up all *ident*f files - -25 May 2006 - completed the discharge coefficient files for the - orifice, bleed tapping and preswirl nozzle - -30 May 2006 - change in tempload: gas nodes do not move during - the calculation - -3 June 2006 - started to code contact conditions - -21 June 2006 - corrected an error in mafillsm.f and - materialdata_th.f - -11 Juli 2006 - CYCLIC SYMMETRY and TYPE=NODE are required parameters - for the *TIE card and the *SURFACE card, respectively - -26 Juli 2006 - small corrections in radmatrix - - nodes with prescribed boundary conditions but not - belonging to elements are also stored in the frd file - -30 Juli 2006 - implemented time points at which output can be - requested - -7 Sept 2006 - one .onf file instead of several - - changed the order of the Gauss points for 4-node - integration of faces of hexahedral elements - -11 Sept 2006 - speeded up cyclic symmetric thermal calculations - (took the symmetry of the integration points into - account in subroutine e_c3d_th.f) - -27 Sept 2006 - changed spooles.c to accommodate for nonsymmetric - systems of equations - -28 Sept 2006 - switched to spooles for the solution of the - nonsymmetric fluid network equation sets. - -7 Oct 2006 - switched back to dgesv (spooles is slower for small - systems) - - accelerated e_c3d_th.f - -9 Oct 2006 - incorporated some slight accelerations in e_c3d_th.f - -14 Oct 2006 - introduced a shape function routine specifically - for axisymmetric elements - -15 Oct 2006 - corrected an error in rubber.f - -16 Oct 2006 - accelerated axisymmetric calculations in results.f - -17 Oct 2006 - accelerated gen3dfrom2d.f - - contact with one element works - -2 Nov 2006 - introduced the parameter CAVITY on the *RADIATE - card - -6 Nov 2006 - accelerated axisymmetric calculations in mafillgas.f - and resultgas.f - - got rid of a segmentation fault in nonlingeo.c - -7 Nov 2006 - corrected a typing mistake for axisymmetric elements - in results.f - -14 Nov 2006 - changed the angle for axisymmetric elements to 2 - degrees - -17 Nov 2006 - improved the connection with the user routine radiate - in radmatrix.f - -23 Nov 2006 - changed the argument list of attach.f - -25 Nov 2006 - changed 4-node contact elements into 4 to 9-node ones - -3 Dec 2006 - change did not improve convergence: 23 Nov state - reinstalled - - included the gas pipe element and a new convergence - strategy for fluids - -10 Dec 2006 - introduced *SURFACE INTERACTION and *SURFACE BEHAVIOR - -13 Dec 2006 - changed contact force into contact pressure (alpha is - multiplied with the area of the triangle) - -17 Dec 2006 - allowed for user-defined viewfactor inputdeck name - - use of shape20h_pl for plane stress and plane strain - elements - - extension for viewfactor file is .vwf - -18 Dec 2006 - only nonzero viewfactors are stored - - error estimator (Sascha Merz) included - - sorting of nelemload includes face number - -21 Dec 2006 - corrected an error in radflowload.c and nonlingeo.c - -22 Dec 2006 - made some changes in gen3dnor.f - -26 Dec 2006 - accelerated plane stress/strain and axisymmetric - calculations in e_c3d.f - -6 Jan 2007 - changed contact stiffness matrix slightly - -7 Jan 2007 - changed 4-node contact elements into 5 to 9-node ones: - second try (consistent stiffness matrix). - -9 Jan 2007 - 5 to 9-node contact elements seem to work. - -14 Jan 2007 - adapted surfaces.f in order to cover beam, shell and - 2-D elements - -15 Jan 2007 - corrected an error in e_c3d.f - -16 Jan 2007 - corrected an error in gaspipe.f - -20 Jan 2007 - started some changes to take 2D contact into account - (file gen3dsurf.f) - -23 Jan 2007 - corrected a mistake in the restart file - - treated Norton in the same way as the creep routine - (incplas.f) - -31 Jan 2007 - frequency calculations for 1D and 2D elements seem to - work. - -9 Feb 2007 - made a small change in frdcyc.c - -22 Feb 2007 - corrected an error in mafillsm.f - -25 Feb 2007 - made a change in map3dto1d2d.f, arpack.c and arpackcs.c - (rotational speed needed for stiffness matrix in - frequency calculations) - -4 Mar 2007 - introducted restrictor elements in the gas network - -6 Mar 2007 - made a change in arpack.c to allow for frequency - calculations after plastic calculations - - changes in the restrictor element files - -11 Mar 2007 - removed error occurring for empty node or element sets - -20 Mar 2007 - added parameter ADD to *CFLUX card - -22 Mar 2007 - updated umat_aniso_creep.f - -24 Mar 2007 - corrected an error in linear 1d/2d calculations: - created file fillrigidmpc.f - -26 Mar 2007 - removed vjj from subroutine incplas; modified the - influence of the thermal strain - -3 April 2007 - modified umat_aniso_creep.f - -16 April 2007 - replaced the rigid body formulation by a knot - formulation for 1d/2d elements: allows expansion - -19 April 2007 - corrected an error in allocation.f - -20 April 2007 - changed the size of field inpc to (long long) in order - to be able to read larger input files - -21 April 2007 - allowed for initial plastic strains - -24 April 2007 - made a correction in readinput.c - -30 April 2007 - started to make corrections for consecutive thermal - and mechanical calculations (especially for 1d/2d - elements) - -2 May 2007 - inclusion of branch fluid elements (start) - -4 May 2007 - made a correction in gen3dboun.f - -15 May 2007 - reduced the storage needs for the input deck: - introduced field ipoinpc to take variable length - lines into account - -20 May 2007 - updated the documention for fluid elements - of type branch - -21 May 2007 - allowed for linear rigid body calculations - -23 May 2007 - modified ithermal into a field to treat the BC's - for plane stress, plane strain and axisymmetric - elements in mixed *STATIC and *HEAT TRANSFER - calculations. - -28 May 2007 - created fully liquid-structure coupling for a one- - dimensional flow in a flexible tube - -30 May 2007 - simplified materialdata_me.f - -3 June 2007 - started to split overall check of mechanical - and thermal convergence: qa,cam.. vectors of - length 2 instead of scalars - -5 June 2007 - corrected an error in couptempdisps.f - -7 June 2007 - simplified initialaccel.c - -9 June 2007 - simplified mafillsm.f - -16 June 2007 - transformed the logical mass into a vector: index 0 - for mechanical calculations, index 1 for thermal - calculations - -20 June 2007 - started to implement spring elements - -27 June 2007 - linear and nonlinear springs seem to work - -7 July 2007 - started to code dashpots for linear dynamic calculations - -10 July 2007 - corrected a couple of small errors in gen3dnor.f. - -26 July 2007 - tried different differential equation solvers for - damped linear dynamics (dderkf, ddeabm and ddebdf) - -30 July 2007 - dashpots in combination with steady state dynamics - works - -6 Aug 2007 - new fluid elements: free and forced vortex, absolute- - to-relative elements and vice-versa, Moehring elements - -10 Sep 2007 - closed the .inp, .dat and .sta file properly at the - end of the calculation - -11 Sep 2007 - changed ithermal into ithermal(2) in file gen3dnor.f - -16 Sep 2007 - introduced an error message in gen3dboun and gen3dforc - to cover the situation in which rotational loadings - or constrains are applied to a node in any but the - first step - -24 Sep 2007 - made a change in results.f (treatment of MPC's) - -25 Sep 2007 - made a change to nonlingeo.c and prediction.c: - mechanical results were not correctly saved during - a heat transfer step. - -30 Sep 2007 - resolved the problem from 16 Sep 2007: definition of - rotational BC's and moments in any but the first step - is now OK. - -2 Oct 2007 - small corrections to creeps.f, plastics.f, gen3dboun.f, - gen3dforc.f and checkconvergence.c - -6 Oct 2007 - made a change in steadystate.c: for cyclic symmetry - only ngraph sectors are stored - - allowed for a user-defined amplitude definition - -10 Oct 2007 - continued to work on frequency-dependent dashpot - constants - -15 Oct 2007 - correction in the expansion of MPC's in expand.c - -16 Oct 2007 - replaced umat_aniso_creep.f and expand.c - for an anisotropic creep subroutine the creep - strain goes in and the stress comes out - -20 Oct 2007 - started to implement an uncoupled - temperature-displacement procedure - -25 Oct 2007 - changed the way the imaginary part of cloads and - dloads is stored - -7 Nov 2007 - improvements in frd output in case of divergence - - linear application of user defined loads for - static calculations - -14 Nov 2007 - included participation factors for steady state - dynamics calculations in the .dat file - -19 Nov 2007 - modified dyna.c in order to take contact - into account - -21 Nov 2007 - added the variable OUTPUT to *VIEWFACTOR,WRITE. - - P*NP can be used for *STATIC calculations as well - -01 Dec 2007 - started to combine contact with modal dynamic - calculations - -15 Dec 2007 - removed an error in rhs.f and mafillsm.f: force on - dependent node in MPC is redistributed among the - independent nodes - -18 Dec 2007 - thickness of plane strain elements is reduced if - there are axisymmetric elements in the model - -20 Dec 2007 - corrected an error in tempload - -9 Jan 2008 - started the implementation of computational fluid - dynamics - -10 Jan 2008 - changed the format for elements in the .dat file to - allow for element numbers exceeding 99999 - - implemented engineering constants for orthotropic - elastic materials - -14 Jan 2008 - made a change in gen3dnor.f - -22 Jan 2008 - worked on the implementation of isochoric elements - (C3D20RH; was started years ago) - -23 Jan 2008 - made a correction in nonlingeo.c, mafillgas.f and - resultgas.f - -30 Jan 2008 - corrected the node order of 3-node elements in frd.f - - replaced f20.10 by f20.0 in buckles.f, frequencies.f - and heattransfers.f - -02 Feb 2008 - finished a preliminary version of cfd (coding only); - -05 Feb 2008 - continued work on rotational rigid body motion with - linear dynamics - - continued work on incompressible elements - -09 Feb 2008 - expanded v,vold,vini,vr,vi and vt to contain 5 - entries for the variables (one extra space for - static pressure) - -10 Feb 2008 - checking expansion; nearly OK, only segststate - still deviates - -11 Feb 2008 - expansion to 5 entries works - -12 Feb 2008 - the calculation of idof is changed to allow for 8 dofs: - temperature, 3 displacements or velocities, static - pressure, 3 angles or rotation (instead of 7: static - pressure is new) - - changed the internal dofs for rotations to 5,6 and 7. - dof 4 is for static pressure. The external dofs for - rotations remain 4,5 and 6, for static pressure it is 8. - For temperature the internal dof is 0, the external - dof is 11. - -16 Feb 2008 - calculated a default position tolerance in case none is - given by the user. - -17 Feb 2008 - removed an error in calinput.f and near2d.f - - continued checking of precfd.f - -21 Feb 2008 - removed an error in arpackcs.c - -24 Feb 2008 - debugged initialcfd.f - -1 Mar 2008 - started adaptive increment size in modal dynamic - calculations. - -4 Mar 2008 - modal dynamics with adaptive increment size seems to - run - -5 Mar 2008 - corrected an error in dyna.c - -11 Mar 2008 - corrected an error in selcycsymmods.f and mpcrem.f - - in modal dynamics and steady state dynamics calulations - any previous loading is removed - -12 Mar 2008 - isochoric elements seem to work - - .sta file is written for modal dynamics calculations - too - -21 Mar 2008 - included code for multistage MPC's - - continued computational fluid dynamics - -27 Mar 2008 - made some changes to multistages.f - - modified the header of user subroutine dflux.f - -31 Mar 2008 - continued debugging of 3D fluid dynamics - -3 April 2008 - modifications to dyna.c - -10 April 2008 - started an update of the gas network elements - -15 April 2008 - continued update of gas network elements - -19 April 2008 - finished update of gas network elements - - extended output for cyclic frequency calculations - (PHS,MAXU,MAXS) - -23 April 2008 - made some quality improvements in incplas.f - -28 April 2008 - continued computational fluid dynamics - ordered nelemface - - corrected an error in mafilltrhs.f - -29 April 2008 - update of dyna.c - -7 Mai 2008 - introduced contact damping and friction for - modal dynamic calculations - -15 Mai 2008 - different meaning of MAXU and MAXS in arpackcs.c - - correction in steadystate.c - -27 Mai 2008 - changed the order of the integration points in - gauss3d6 - -31 Mai 2008 - coded a linearized version of the mean rotation MPC - -3 June 2008 - implemented pre-tension section to simulate - pre-tension in bolts (3D only). - -5 June 2008 - connected the linear equations solvers to compfluid.c - for liquids (pressure equation) - - improved error message for zero columns in the - stiffness matrix - -12 June 2008 - started to work on the improvement of the viewfactor - calculations - -18 June 2008 - corrections in expand.c and pretensionsections.c - -21 June 2008 - corrected an error in expand.c - - introduced the FIXED parameter on the *BOUNDARY card - -23 June 2008 - changed 1.d-10 to 1.d-5 as smallest allowable - coefficient in a MPC - -28 June 2008 - implemented STEADY STATE calculations for the - linear dynamics procedure - -1 July 2008 - coded an update of CYCLIC MPC's for nonlinear - calculations (nonlinmpc) - -3 July 2008 - corrected an error in envtemp.f - -6 July 2008 - made some changes in compfluid.c: stable time increment - is calculated in each iteration anew - -9 July 2008 - continued fluid dynamics: change of boundary conditions - has to be limited to guarantee stability. - -13 July 2008 - improved the time increment management for - computational fluid dynamics - -19 July 2008 - set the mechanical strain to zero at the end of a - frequency step - - started changes in the contact formulation: 1. adjust - in the first iteration of the first increment of the - first step; 2. zero force for too large distances - 3. contact area division number - -30 July 2008 - made a change to surfaces.f - -8 August 2008 - corrected an error in printoutint.f - -4 Sept 2008 - coded 2nd order derivatives in shape3tri,shape6tri, - shape4q and shape8q - -9 Sept 2008 - supplemented subroutine springstiff with the derivatives - of xi and eta; contact convergence should improve - - corrected errors in nonlinmpc (CYCLIC) and bounadd - -14 Sept 2008 - made corrections in radiates.f, incplas.f and - usermaterials.f - -20 Sept 2008 - introduced CE for the equivalent creep strain - for anisotropic materials - -24 Sept 2008 - changed to another viewfactor calculation - - minor changes in radmatrix, e_c3d_th and cascade - -11 Oct 2008 - change of extrapolation of the mass flow to the - end nodes (fluidextrapolate.f) - - correction in umat_abaqus.f and umat_abaqusnl.f - - correction for section forces in map3dto1d2d.f - -13 Oct 2008 - the FREQUENCY and TIME POINTS parameters are - mutually exclusive for data storage keyword cards. - -28 Oct 2008 - modified the calculation of section forces to - accommodate for large deformations - -7 Nov 2008 - modified the output format for SDV in the .dat - and .frd file - -9 Nov 2008 - no correction of dependent node for nonmatching - cyclic symmetry conditions - - cyclic conditions are considered to be linear - (no update due to large deformation) - - changed interface for umatht and dload (for - lubrication problems) - -13 Nov 2008 - wrote user routines for coupled mechanical- - lubrication problems - -15 Nov 2008 - made a change in springstiff: consistent tangent - matrix was not correct - -17 Nov 2008 - started to change dyna to take contact into account - -30 Nov 2008 - driven lid cavity (incompressibile fluid dynamics) - works! - - started the implementation of additional MPC's for - middle nodes belonging to dependent contact - surfaces - -7 Dec 2008 - additional MPC's for 3D and 2D elements seem to work - -10 Dec 2008 - changed PE into PEEQ and CE into CEEQ (print requests - or frd requests for the equivalent plastic/creep - strain) - - created printing output (.dat file) for gas networks: - static pressure (PS), total pressure (PT) and - mass flow (MF) - -11 Dec 2008 - created printing output (.dat file) for 3D fluid flow: - velocities (V) and static pressure (PT) - -15 Dec 2008 - no motion of dependent variables in cyclic - symmetric calculations (generatecycmpcs.f) - -16 Dec 2008 - the triangulation file for cyclic symmetry conditions - with dissimilar meshes takes the job name and - ending .tri - -18 Dec 2008 - corrected an error in shape8q (calculation of xsi) and - all other 2D shape functions - -24 Jan 2009 - got to work airfoil with near zero viscosity and zero - wall conditions (compressible fluid); smoothing is - not exactly the same as in Nithiarasu's program; - -25 Jan 2009 - got to work airfoil with Euler conditions (MPC's for - fluids) - -2 Feb 2009 - corrected an error in gen3dnor.f - -4 Feb 2009 - Zienkiewicz-Zhu error estimator now also works for - frequency, buckling, modal dynamics and steady - state dynamics calculations (stx instead of sti in - the call of out.f) - -7 Feb 2009 - coded shock viscosity smoothing - - included PARDISO as solver - -10 Feb 2009 - corrected an error in remastruct: mass[0]=1 - -21 Feb 2009 - wrote a routine to calculate the lift and drag force - -5 Mar 2009 - calculation of the velocity through derivation - in dyna and dynacont - - replaced logical by integer in fluid calculations - -7 Mar 2009 - worked on turbulence (SST model) - -8 Mar 2009 - started work on pre-tension for 2D elements - -10 Mar 2009 - finished pre-tension for 2D elements - -19 Mar 2009 - introduced the variable pnewdt in umat_user.f - -21 Mar 2009 - coded direct modal damping - -22 Mar 2009 - continued to work on 3Dfluids and cyclic MPC's - -4 April 2009 - provided for BX, BY and BZ as volumetric loading - including nonuniform loading (BXNU...) - - included the velocity in the subroutine parameters - of dload.f - -10 April 2009 - started acceleration of dyna - -19 April 2009 - added some parameters to user routine dload - -21 April 2009 - coded direct damping for steady state dynamics - -22 April 2009 - PU and PHS are calculated for all sectors - requested - -26 April 2009 - corrected an error in incplas.f (residual stress) - -2 May 2009 - started tied contact - -10 May 2009 - tied contact works - - corrected an error in e_c3d_trhs.f - -19 May 2009 - started Mortar contact - -15 June 2009 - allowed for local coordinate systems for - fluid output - -20 June 2009 - changed the calculation of rf for nodes belonging - to MPC's and 1-d or 2-d elements - - made an update for gas networks (not finished) - - started debugging turbulence - -23 June 2009 - made a correction in results.f and pretensionsections.f - -26 June 2009 - added the cylic symmetry axis to the displacement - headers in the frd file - -27 June 2009 - provided two entries in field iperturb in order to - distinguish between material and geometrical - nonlinearities; nlgeom not automatically active for - *DYNAMIC and *COMBINED TEMPERATURE-DISPLACEMENT - procedures - -28 June 2009 - started the multithreading version of compfluid - -8 July 2009 - update of mortar contact - -10 July 2009 - removed an error in radmatrix.f - - updated modal dynamic and contact - -23 July 2009 - accelerated the execution of dynacont and dfdbj - -25 July 2009 - change in nonlingeo: ielas=1 is only active in the first - iteration of the first increment if ilin=1 AND if the - step is not dynamic - -3 August 2009 - some small changes to Mortar contact - -5 August 2009 - added istep and iinc to the ABAQUS umat files - - user material does not automatically imply geometric - nonlinearity - -11 August 2009 - checked for SPC's in contact middle slave nodes in - routine gencontmpc.c - -20 Sept 2009 - updated Mortar contact - -21 Sept 2009 - made a correction in frequencies.f, buckles.f, - modaldynamics.f and steadystatedynamics.f - -3 Oct 2009 - accounted for 'NLGEOM=NO' for ABAQUS compatibility - - made some corrections in dynacont.c - -11 Oct 2009 - allowed for a selection of nodes for modal dynamics - calculations in order to speed up the calculations - -12 Oct 2009 - started to change mint_ into mi(2) in order to store - the maximum number of dofs per node - -13 Oct 2009 - continued (not finished yet) - -24 Oct 2009 - changed nactdof(1:3,*) into nactdof(1:mi(2),*) - -25 Oct 2009 - introduced the parameter TIME RESET on the *STATIC and - *HEAT TRANSFER keyword card - -26 Oct 2009 - in nonlinear calculations the nodes are listed where the - residual forces and variable changes are maximum - -28 Oct 2009 - corrected an error in springstiff.f - - inverted the order of working through the amplitudes: - last comes first (a redefined amplitude overrules - the earlier definitions) - -31 Oct 2009 - ran valgrind and started removing complaints by - valgrind - -1 Nov 2009 - started to use mi(2) for defining the size of field - v, vold... -> smaller fields for thermal and - mechanical calculations - -4 Nov 2009 - mi(2) works for values >= 3. - - started introducing sets to limit output to the - frd file - -10 Nov 2009 - output to the frd file can be limited to a node set - -14 Nov 2009 - made substantial changes in dyna.c and dynacont.c - to speed up modal dynamic contact calculations - -15 Nov 2009 - xl2 and similar fields start now from 1, not 0. - -22 Nov 2009 - made substantial changes in dyna.c and subprograms - to speed up execution (force CHANGES are calculated) - -28 Nov 2009 - major speed up changes for modal dynamics finished - -12 Dec 2009 - continued speed optimization of modal dynamics - calculations - -15 Dec 2009 - implemented local system output for tensors in - frdtensor.f - -9 Jan 2010 - started coding liquid channels as 1-D networks - -12 Jan 2010 - von Karman vortex street about a cylinder works - -17 Jan 2010 - coded linear pressure-overclosure - -23 Jan 2010 - changed once again output for MAXS in arpackcs - (quousque tandem abutere......) - - worked on friction in modal dynamics + contact - - started coding a different shock capturing - procedure - -25 Jan 2010 - made some changes in e_c3d_th.f (no displacement - information available for purely thermal calculations) - -31 Jan 2010 - expanded restrictors and branches to liquid - applications (1D networks). - -4 Feb 2010 - changed the way in which, for a given slave node, the - corresponding master triangle is found for spring contact - purposes - -14 Feb 2010 - made a change in results.f diff -Nru calculix-ccx-2.1/ccx_2.1/src/lump.f calculix-ccx-2.3/ccx_2.1/src/lump.f --- calculix-ccx-2.1/ccx_2.1/src/lump.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/lump.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine lump(adb,aub,adl,irow,jq,neq) -! -! lumping the matrix stored in adb,aub and storing the result -! in adl -! - implicit none -! - integer irow(*),jq(*),neq,i,j,k -! - real*8 adb(*),aub(*),adl(*) -! - do i=1,neq - adl(i)=adb(i) - enddo -! - do j=1,neq - do k=jq(j),jq(j+1)-1 - i=irow(k) - adl(i)=adl(i)+aub(k) - adl(j)=adl(j)+aub(k) - enddo - enddo -! -! change of meaning of adb and adl -! first adb is replaced by adb-adl -! then, adl is replaced by 1./adl -! - do i=1,neq - adb(i)=adb(i)-adl(i) - adl(i)=1.d0/adl(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafilldm.f calculix-ccx-2.3/ccx_2.1/src/mafilldm.f --- calculix-ccx-2.1/ccx_2.1/src/mafilldm.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafilldm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,264 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafilldm(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun, - & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - & ad,au,nactdof,icol,jq,irow,neq,nzl,nmethod, - & ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon, - & nrhcon,alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - & t0,t1,ithermal,prestr, - & iprestr,vold,iperturb,sti,nzs,stx,adb,aub,iexpl,plicon, - & nplicon,plkcon,nplkcon,xstiff,npmat_,dtime, - & matname,mi,ncmat_,ttime,time,istep,iinc,ibody) -! -! filling the damping matrix in spare matrix format (sm) -! - implicit none -! - character*8 lakon(*) - character*20 sideload(*) - character*80 matname(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & nodeforc(2,*),ndirforc(*),nelemload(2,*),icol(*),jq(*),ikmpc(*), - & ilmpc(*),ikboun(*),ilboun(*),mi(2),nactdof(0:mi(2),*),konl(20), - & irow(*), - & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), - & ipkon(*),ipobody(2,*),nbody, - & ibody(3,*) -! - integer nk,ne,nboun,nmpc,nforc,nload,neq(2),nzl,nmethod,icolumn, - & ithermal,iprestr,iperturb,nzs(3),i,j,k,l,m,idist,jj, - & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, - & mpc1,mpc2,index1,index2,node1,node2, - & ntmat_,indexe,nope,norien,iexpl,i0,ncmat_,istep,iinc -! - integer nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ -! - real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), - & p2(3),ad(*),au(*),bodyf(3), - & t0(*),t1(*),prestr(6,mi(1),*),vold(0:mi(2),*),s(60,60),ff(60), - & sti(6,mi(1),*),sm(60,60),stx(6,mi(1),*),adb(*),aub(*), - & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*), - & alcon(0:6,ntmat_,*),alzero(*),orab(7,*),xbody(7,*),cgr(4,*) -! - real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), - & xstiff(27,mi(1),*) -! - real*8 om,value,dtime,ttime,time -! - i0=0 -! -! determining nzl -! - nzl=0 - do i=neq(2),1,-1 - if(icol(i).gt.0) then - nzl=i - exit - endif - enddo -! -! initializing the matrices -! - do i=1,neq(2) - ad(i)=0.d0 - enddo - do i=1,nzs(2) - au(i)=0.d0 - enddo -! - if((ithermal.le.1).or.(ithermal.eq.3)) then -! -! mechanical analysis: loop over all elements -! - do i=1,ne -! - if(lakon(i)(1:2).ne.'ED') cycle - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - read(lakon(i)(8:8),'(i1)') nope -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - call e_damp(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody,s,sm,ff,i, - & elcon,nelcon,rhcon,nrhcon,alcon,nalcon, - & alzero,ielmat,ielorien,norien,orab,ntmat_, - & t0,t1,ithermal,vold,iperturb, - & nelemload,sideload,xload,nload,idist,sti,stx, - & iexpl,plicon,nplicon,plkcon,nplkcon,xstiff,npmat_, - & dtime,matname,mi(1),ncmat_,ttime,time,istep,iinc, - & nmethod) -! - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdof(k,node1) -! - do ll=jj,3*nope -! - l=(ll-1)/3+1 - m=ll-3*(l-1) -! - node2=kon(indexe+l) - jdof2=nactdof(m,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - call add_sm_st(au,ad,jq,irow,jdof1,jdof2, - & s(jj,ll),jj,ll) - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*8+k - else - idof1=jdof1 - idof2=(node2-1)*8+m - endif - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - idof2=nactdof(nodempc(2,index),nodempc(1,index)) - value=-coefmpc(index)*s(jj,ll)/coefmpc(ist) - if(idof1.eq.idof2) value=2.d0*value - if(idof2.ne.0) then - call add_sm_st(au,ad,jq,irow,idof1, - & idof2,value,i0,i0) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif - else - idof1=(node1-1)*8+k - idof2=(node2-1)*8+m - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - idof1=nactdof(nodempc(2,index1), - & nodempc(1,index1)) - index2=index1 - do - idof2=nactdof(nodempc(2,index2), - & nodempc(1,index2)) - value=coefmpc(index1)*coefmpc(index2)* - & s(jj,ll)/coefmpc(ist)/coefmpc(ist) - if((idof1.ne.0).and.(idof2.ne.0)) then - call add_sm_st(au,ad,jq,irow, - & idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - idof1=nactdof(nodempc(2,index1), - & nodempc(1,index1)) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - idof2=nactdof(nodempc(2,index2), - & nodempc(1,index2)) - value=coefmpc(index1)*coefmpc(index2)* - & s(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - if(idof1.eq.idof2) value=2.d0*value - if((idof1.ne.0).and.(idof2.ne.0)) then - call add_sm_st(au,ad,jq,irow, - & idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif - endif - endif - enddo -! - enddo - enddo -! - endif -! -c do i=1,neq(2) -c write(*,*) i,ad(i) -c enddo -c do i=1,nzs(2) -c write(*,*) i,au(i) -c enddo - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillgas.f calculix-ccx-2.3/ccx_2.1/src/mafillgas.f --- calculix-ccx-2.1/ccx_2.1/src/mafillgas.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillgas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,630 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! This subroutine creates the matrix ac for gas problems -! - subroutine mafillgas(itg,ieg,ntg,ntm, - & ac,nload,sideload,nelemload,xloadact,lakon,ntmat_,v, - & shcon,nshcon,ipkon,kon,co,nflow,iinc, - & istep,dtime,ttime,time, - & ielmat,nteq,prop,ielprop,nactdog,nacteq,physcon, - & rhcon,nrhcon,ipobody,ibody,xbodyact,nbody,vold,xloadold, - & reltime,nmethod,set,mi) -! - implicit none -! - logical identity - character*8 lakonl,lakon(*) - character*20 sideload(*) - character*81 set(*) -! - integer itg(*),ieg(*),ntg,nteq,nflow,nload,ielmat(*), - & nelemload(2,*),nope,nopes,mint2d,i,j,k,l,iflag, - & node,imat,ntmat_,id,ntm,ifaceq(8,6),ifacet(6,4), - & ifacew(8,5),node1,node2,nshcon(*),nelem,ig,index,konl(20), - & ipkon(*),kon(*),idof,iinc,ibody(3,*), - & istep,jltyp,nfield,ipobody(2,*), - & nodem,ieq,kflag,nrhcon(*),numf, - & idofp1,idofp2,idofm,idoft1,idoft2,idoft,nactdog(0:3,*), - & nacteq(0:3,*),ielprop(*),nodef(5),idirf(5),nbody, - & nmethod,icase,mi(2) -! - real*8 ac(ntm,*),xloadact(2,*),cp,h(2),physcon(*),dvi, - & xl2(3,8),coords(3),dxsj2,temp,xi,et,weight,xsj2(3), - & gastemp,v(0:mi(2),*),shcon(0:3,ntmat_,*),co(3,*),shp2(7,8), - & ftot,field,prop(*),f,df(5),tg1,tg2,r,rho,tl2(8), - & dtime,ttime,time,areaj,xflow,tvar(2),g(3), - & rhcon(0:1,ntmat_,*),xbodyact(7,*),sinktemp,ts1,ts2,xs2(3,7), - & xdenom1,xdenom2,xcst,xk1,xk2,expon,a,dt1,dt2,kappa, - & pt1,pt2,inv,vold(0:mi(2),*),xloadold(2,*),reltime,pi -! - include "gauss.f" -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ - data ifacew /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! - data iflag /2/ -! - kflag=2 -! - Pi=4.d0*datan(1.d0) - tvar(1)=time - tvar(2)=ttime+dtime -! -! reinitialisation of the Ac matrix -! - do i=1,nteq - do j=1,nteq - ac(i,j)=0.d0 - enddo - enddo -! -! solving for the gas temperatures in forced convection -! - ftot=0.d0 -! -! element contribution. -! - - do i=1,nflow - nelem=ieg(i) - index=ipkon(nelem) - node1=kon(index+1) - nodem=kon(index+2) - node2=kon(index+3) -! - xflow=v(1,nodem) -! - if(node1.eq.0) then - tg1=v(0,node2) - tg2=tg1 - ts1=v(3,node2) - ts2=ts1 - elseif(node2.eq.0) then - tg1=v(0,node1) - tg2=tg1 - ts1=v(3,node1) - ts2=ts1 - else - tg1=v(0,node1) - tg2=v(0,node2) - ts1=v(3,node1) - ts2=v(3,node2) - endif - gastemp=(ts1+ts2)/2.d0 -! - imat=ielmat(nelem) -! - call materialdata_tg(imat,ntmat_,gastemp,shcon,nshcon,cp,r,dvi, - & rhcon,nrhcon,rho) -! - kappa=(cp/(cp-R)) -! -! Definitions of the constant for isothermal flow elements -! - if((lakon(nelem)(2:6).eq.'GAPFI') - & .or.(lakon(nelem)(2:6).eq.'GAPII'))then - if((node1.ne.0).and.(node2.ne.0)) then -! - icase=1 - A=prop(ielprop(nelem)+1) - pt1=v(2,node1) - pt2=v(2,node2) - if(pt1.ge.pt2)then - inv=1.d0 - pt1=v(2,node1) - pt2=v(2,node2) - if(dabs(tg2/ts2-(1+0.5*(kappa-1)/kappa)).lt.1E-5) then - - pt2=dabs(xflow)*dsqrt(Tg2*R)/A - & *(1+0.5*(kappa-1)/kappa) - & **(0.5*(kappa+1)/(kappa-1)) - endif - tg1=v(0,node1) - call ts_calc(xflow,Tg1,Pt1,kappa,r,a,Ts1,icase) - - - tg2=v(0,node2) - call ts_calc(xflow,Tg2,Pt2,kappa,r,a,Ts2,icase) - else - - inv=-1.d0 - pt1=v(2,node2) - pt2=v(2,node1) - if(dabs(tg2/ts2-(1+0.5*(kappa-1)/kappa)).lt.1E-5) then - - pt2=dabs(xflow)*dsqrt(Tg2*R)/A - & *(1+0.5*(kappa-1)/kappa) - & **(0.5*(kappa+1)/(kappa-1)) - endif - tg1=v(0,node2) - call ts_calc(xflow,Tg1,Pt1,kappa,r,a,Ts1,icase) - tg2=v(0,node1) - call ts_calc(xflow,Tg2,Pt2,kappa,r,a,Ts2,icase) - endif - dt1=tg1/ts1-1d0 - dt2=tg2/ts2-1d0 - expon=2.d0*kappa/(kappa-1.d0) - xcst=2.d0*Cp*A**2/r**2 - xk1=pt1**2*(ts1/tg1)**expon - xdenom1=xcst*xk1*(1.d0-expon*(tg1/ts1-1.d0)) - & /ts1+2.d0*xflow**2 - xk2=pt2**2*(ts2/tg2)**expon - xdenom2=xcst*xk2*(1.d0-expon*(tg2/ts2-1.d0)) - & /ts2+2.d0*xflow**2 - endif - endif -! - if(node1.ne.0) then - idoft1=nactdog(0,node1) - idofp1=nactdog(2,node1) - else - idoft1=0 - idofp1=0 - endif - if(node2.ne.0) then - idoft2=nactdog(0,node2) - idofp2=nactdog(2,node2) - else - idoft2=0 - idofp2=0 - endif - idofm=nactdog(1,nodem) -! - if(node1.ne.0) then -! -! energy equation contribution node1 -! - if (nacteq(0,node1).ne.0) then - ieq=nacteq(0,node1) - if ((xflow.le.0d0).and.(nacteq(3,node1).eq.0))then -! -! adiabatic element -! - if(idoft1.ne.0) then - ac(ieq,idoft1)=ac(ieq,idoft1)-cp*xflow - endif -! - if(idoft2.ne.0)then - ac(ieq,idoft2)=ac(ieq,idoft2)+cp*xflow - endif -! - if(idofm.ne.0) then - ac(ieq,idofm)=ac(ieq,idofm)-cp*(tg1-tg2) - endif -! - elseif(nacteq(3,node1).ne.0)then -! -! isothermal element -! - if(nacteq(3,node1).eq.node2) then -! - if(inv.eq.-1d0) then - if(idoft1.ne.0) then - ac(ieq,idoft1)=-xcst*xk1*(1.d0-expon - & *(1.d0-ts1/tg1))/(xdenom1*ts1) - endif -! - if(idoft2.ne.0)then - ac(ieq,idoft2)=xcst*xk2*(1.d0-expon - & *(1.d0-ts2/tg2))/(xdenom2*ts2) - endif -! - if(idofm.ne.0) then - ac(ieq,idofm)=(-2.d0*xflow*ts2 - & /xdenom2+2.d0*xflow*ts1/xdenom1) - endif -! - if(idofp1.ne.0) then - ieq=nacteq(2,idofp1) - ac(ieq,idofp1)=2.d0*xcst*dt1*xk1 - & /(pt1*xdenom1) - endif -! - if(idofp2.ne.0) then - ac(ieq,idofp2)=-2.d0*xcst*dt2*xk2 - & /(pt2*xdenom2) - endif -! - elseif(inv.eq.1d0)then - if(idoft1.ne.0) then - ac(ieq,idoft1)=xcst*xk1*(1.d0-expon - & *(1.d0-ts1/tg1))/(xdenom1*ts1) - endif -! - if(idoft2.ne.0)then - ac(ieq,idoft2)=-xcst*xk2*(1.d0-expon - & *(1.d0-ts2/tg2))/(xdenom2*ts2) - endif -! - if(idofm.ne.0) then - ac(ieq,idofm)=-(-2.d0*xflow*ts2 - & /xdenom2+2.d0*xflow*ts1/xdenom1) - endif -! - if(idofp1.ne.0) then - ieq=nacteq(2,idofp1) - ac(ieq,idofp1)=-2.d0*xcst*dt1*xk1 - & /(pt1*xdenom1) - endif -! - if(idofp2.ne.0) then - ac(ieq,idofp2)=2.d0*xcst*dt2*xk2 - & /(pt2*xdenom2) - endif -! - endif - endif - endif - endif -! -! mass equation contribution node1 -! - if (nacteq(1,node1).ne.0) then - ieq=nacteq(1,node1) - if (idofm.ne.0) then - ac(ieq,idofm)=1.d0 - endif - endif - endif -! - if(node2.ne.0) then -! -! energy equation contribution node2 -! - if (nacteq(0,node2).ne.0) then - ieq=nacteq(0,node2) - if ((xflow.ge.0d0).and.(nacteq(3,node2).eq.0))then -! -! adiabatic element -! - if(idoft1.ne.0)then - ac(ieq,idoft1)=ac(ieq,idoft1)-cp*xflow - endif -! - if(idoft2.ne.0) then - ac(ieq,idoft2)=ac(ieq,idoft2)+cp*xflow - endif -! - if(idofm.ne.0) then - ac(ieq,idofm)=ac(ieq,idofm)+cp*(tg2-tg1) - endif -! - elseif((nacteq(3,node2).eq.node1))then -! -! isothermal element -! - if(inv.eq.-1d0) then - if(idoft1.ne.0)then - ac(ieq,idoft1)=-xcst*xk1*(1.d0-expon - & *(1.d0-ts1/tg1))/(xdenom1*ts1) - endif -! - if(idoft2.ne.0) then - ac(ieq,idoft2)=(xcst*xk2*(1.d0-expon - & *(1.d0-ts2/tg2))/(xdenom2*ts2)) - endif -! - if(idofm.ne.0) then - ac(ieq,idofm)=(-2.d0*xflow*ts2 - & /xdenom2+2.d0*xflow*ts1/xdenom1) - endif -! - if(idofp1.ne.0) then - ac(ieq,idofp1)=+2.d0*xcst*dt1*xk1 - & /(pt1*xdenom1) - endif -! - if(idofp2.ne.0) then - ac(ieq,idofp2)=-2.d0*xcst*dt2*xk2 - & /(pt2*xdenom2) - endif -! - elseif(inv.eq.1d0) then - - if(idoft1.ne.0)then - ac(ieq,idoft1)=xcst*xk1*(1.d0-expon - & *(1.d0-ts1/tg1))/(xdenom1*ts1) - endif -! - if(idoft2.ne.0) then - ac(ieq,idoft2)=-(xcst*xk2*(1.d0-expon - & *(1.d0-ts2/tg2))/(xdenom2*ts2)) - endif -! - if(idofm.ne.0) then - ac(ieq,idofm)=-(-2.d0*xflow*ts2 - & /xdenom2+2.d0*xflow*ts1/xdenom1) - endif -! - if(idofp1.ne.0) then - ac(ieq,idofp1)=+2.d0*xcst*dt1*xk1 - & /(pt1*xdenom1) - endif -! - if(idofp2.ne.0) then - ac(ieq,idofp2)=-2.d0*xcst*dt2*xk2 - & /(pt2*xdenom2) - endif - endif -! - endif - endif -! -! mass equation contribution node2 -! - if (nacteq(1,node2).ne.0) then - ieq=nacteq(1,node2) - if(idofm.ne.0)then - ac(ieq,idofm)=-1.d0 - endif - endif - endif -! -! element equation -! - if (nacteq(2,nodem).ne.0) then - ieq=nacteq(2,nodem) -! -! for liquids: determine the gravity vector -! - if(lakon(nelem)(2:3).eq.'LI') then - do j=1,3 - g(j)=0.d0 - enddo - if(nbody.gt.0) then - index=nelem - do - j=ipobody(1,index) - if(j.eq.0) exit - if(ibody(1,j).eq.2) then - g(1)=g(1)+xbodyact(1,j)*xbodyact(2,j) - g(2)=g(2)+xbodyact(1,j)*xbodyact(3,j) - g(3)=g(3)+xbodyact(1,j)*xbodyact(4,j) - endif - index=ipobody(2,index) - if(index.eq.0) exit - enddo - endif - endif -! - call flux(node1,node2,nodem,nelem,lakon,kon,ipkon, - & nactdog,identity,ielprop,prop,kflag,v,xflow,f, - & nodef,idirf,df,cp,R,rho,physcon,g,co,dvi,numf, - & vold,set,shcon,nshcon,rhcon,nrhcon,ntmat_,mi) -! - do k=1,numf - idof=nactdog(idirf(k),nodef(k)) - if(idof.ne.0)then - ac(ieq,idof)=df(k) - endif - enddo - endif - enddo -! -! convection with the walls -! - do i=1,nload - if(sideload(i)(3:4).eq.'FC') then - nelem=nelemload(1,i) - lakonl=lakon(nelem) - node=nelemload(2,i) - ieq=nacteq(0,node) - if(ieq.eq.0) then - cycle - endif -! - call nident(itg,node,ntg,id) -! -! calculate the area -! - read(sideload(i)(2:2),'(i1)') ig -! -! number of nodes and integration points in the face -! - if(lakonl(4:4).eq.'2') then - nope=20 - nopes=8 - elseif(lakonl(4:4).eq.'8') then - nope=8 - nopes=4 - elseif(lakonl(4:5).eq.'10') then - nope=10 - nopes=6 - elseif(lakonl(4:4).eq.'4') then - nope=4 - nopes=3 - elseif(lakonl(4:5).eq.'15') then - nope=15 - else - nope=6 - endif -! - if(lakonl(4:5).eq.'8R') then - mint2d=1 - elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R')) - & then - if(lakonl(7:7).eq.'A') then - mint2d=2 - else - mint2d=4 - endif - elseif(lakonl(4:4).eq.'2') then - mint2d=9 - elseif(lakonl(4:5).eq.'10') then - mint2d=3 - elseif(lakonl(4:4).eq.'4') then - mint2d=1 - endif -! - if(lakonl(4:4).eq.'6') then - mint2d=1 - if(ig.le.2) then - nopes=3 - else - nopes=4 - endif - endif - if(lakonl(4:5).eq.'15') then - if(ig.le.2) then - mint2d=3 - nopes=6 - else - mint2d=4 - nopes=8 - endif - endif -! -! connectivity of the element -! - index=ipkon(nelem) - if(index.lt.0) then - write(*,*) '*ERROR in radflowload: element ',nelem - write(*,*) ' is not defined' - stop - endif - do k=1,nope - konl(k)=kon(index+k) - enddo -! -! coordinates of the nodes belonging to the face -! - if((nope.eq.20).or.(nope.eq.8)) then - do k=1,nopes - tl2(k)=v(0,konl(ifaceq(k,ig))) - do j=1,3 - xl2(j,k)=co(j,konl(ifaceq(k,ig)))+ - & v(j,konl(ifaceq(k,ig))) - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - do k=1,nopes - tl2(k)=v(0,konl(ifacet(k,ig))) - do j=1,3 - xl2(j,k)=co(j,konl(ifacet(k,ig)))+ - & v(j,konl(ifacet(k,ig))) - enddo - enddo - else - do k=1,nopes - tl2(k)=v(0,konl(ifacew(k,ig))) - do j=1,3 - xl2(j,k)=co(j,konl(ifacew(k,ig)))+ - & v(j,konl(ifacew(k,ig))) - enddo - enddo - endif -! -! integration to obtain the area and the mean -! temperature -! - do l=1,mint2d - if((lakonl(4:5).eq.'8R').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then - xi=gauss2d1(1,l) - et=gauss2d1(2,l) - weight=weight2d1(l) - elseif((lakonl(4:4).eq.'8').or. - & (lakonl(4:6).eq.'20R').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then - xi=gauss2d2(1,l) - et=gauss2d2(2,l) - weight=weight2d2(l) - elseif(lakonl(4:4).eq.'2') then - xi=gauss2d3(1,l) - et=gauss2d3(2,l) - weight=weight2d3(l) - elseif((lakonl(4:5).eq.'10').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then - xi=gauss2d5(1,l) - et=gauss2d5(2,l) - weight=weight2d5(l) - elseif((lakonl(4:4).eq.'4').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then - xi=gauss2d4(1,l) - et=gauss2d4(2,l) - weight=weight2d4(l) - endif -! - if(nopes.eq.8) then - call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.4) then - call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.6) then - call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - endif -! - dxsj2=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+ - & xsj2(3)*xsj2(3)) - areaj=dxsj2*weight -! - temp=0.d0 - do k=1,3 - coords(k)=0.d0 - enddo - do j=1,nopes - temp=temp+tl2(j)*shp2(4,j) - do k=1,3 - coords(k)=coords(k)+xl2(k,j)*shp2(4,j) - enddo - enddo -! - if(sideload(i)(5:6).ne.'NU') then - h(1)=xloadact(1,i) - else - read(sideload(i)(2:2),'(i1)') jltyp - jltyp=jltyp+10 - sinktemp=v(0,node) - call film(h,sinktemp,temp,istep, - & iinc,tvar,nelem,l,coords,jltyp,field,nfield, - & sideload(i),node,areaj,v,mi) - if(nmethod.eq.1) h(1)=xloadold(1,i)+ - & (h(1)-xloadold(1,i))*reltime - endif -! - idoft=nactdog(0,node) - if(idoft.gt.0) then - if(lakonl(5:7).eq.'0RA') then - ac(ieq,idoft)=ac(ieq,idoft)+2.d0*h(1)*dxsj2*weight - else - ac(ieq,idoft)=ac(ieq,idoft)+h(1)*dxsj2*weight - endif - endif - enddo - endif - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillklhs.f calculix-ccx-2.3/ccx_2.1/src/mafillklhs.f --- calculix-ccx-2.1/ccx_2.1/src/mafillklhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillklhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,233 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillklhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, - & nactdok,icolk,jqk,irowk,neqk,nzlk, - & ikmpc,ilmpc,ikboun,ilboun,nzsk,adbk,aubk,nmethod) -! -! filling the lhs turbulence matrix in spare matrix format (sm) -! -! it is assumed that the temperature MPC's also apply to the -! turbulence. Temperature MPC's are not allowed to contain -! other variables than the temperature. -! - implicit none -! - character*8 lakon(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & icolk(*),jqk(*),ikmpc(*),nzsk,nmethod, - & ilmpc(*),ikboun(*),ilboun(*),nactdok(*),konl(20),irowk(*), - & ipkon(*) -! - integer nk,ne,nboun,nmpc,neqk,nzlk,i,j,jj, - & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, - & mpc1,mpc2,index1,index2,node1,node2, - & indexe,nope,i0 -! - real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbk(*),aubk(*) -! - real*8 value -! - i0=0 -! -! determining nzlk -! - nzlk=0 - do i=neqk,1,-1 - if(icolk(i).gt.0) then - nzlk=i - exit - endif - enddo -! - do i=1,neqk - adbk(i)=0.d0 - enddo - do i=1,nzsk - aubk(i)=0.d0 - enddo -! -! loop over all fluid elements -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! -! the temperature element routine = the turbulence element -! routine -! - call e_c3d_tlhs(co,nk,konl,lakon(i),sm,i,nmethod) -! - do jj=1,nope -! - node1=kon(indexe+jj) - jdof1=nactdok(node1) -! - do ll=jj,nope -! - node2=kon(indexe+ll) - jdof2=nactdok(node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - call add_sm_fl(aubk,adbk,jqk,irowk,jdof1,jdof2, - & sm(jj,ll),jj,ll) - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*8 - else - idof1=jdof1 - idof2=(node2-1)*8 - endif - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - idof2=nactdok(nodempc(1,index)) - if(idof2.ne.0) then - value=-coefmpc(index)*sm(jj,ll)/ - & coefmpc(ist) - if(idof1.eq.idof2) value=2.d0*value - call add_sm_fl(aubk,adbk,jqk,irowk, - & idof1,idof2,value,i0,i0) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif - else - idof1=(node1-1)*8 - idof2=(node2-1)*8 - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - idof1=nactdok(nodempc(1,index1)) - index2=index1 - do - idof2=nactdok(nodempc(1,index2)) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) - call add_sm_fl(aubk,adbk,jqk, - & irowk,idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - idof1=nactdok(nodempc(1,index1)) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - idof2=nactdok(nodempc(1,index2)) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - if(idof1.eq.idof2) value=2.d0*value - call add_sm_fl(aubk,adbk,jqk, - & irowk,idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif - endif - endif - enddo - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillkrhs.f calculix-ccx-2.3/ccx_2.1/src/mafillkrhs.f --- calculix-ccx-2.1/ccx_2.1/src/mafillkrhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillkrhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,139 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillkrhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nelemface,sideface, - & nface,nactdok,neqk,nmethod,ikmpc,ilmpc, - & ikboun,ilboun,rhcon,nrhcon,ielmat,ntmat_,vold,voldaux,nzsk, - & dtime,matname,mi,ncmat_,shcon,nshcon,v,theta1, - & bk,bt,voldtu,isolidsurf,nsolidsurf,ifreestream,nfreestream, - & xsolidsurf,yy,compressible,turbulent) -! -! filling the rhs b of the turbulence equations (step 5) -! -! it is assumed that the temperature MPC's also apply to the -! turbulence. The temperature MPC's are not allowed to contain -! any other variables but temperatures -! - implicit none -! - character*1 sideface(*) - character*8 lakon(*) - character*80 matname(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & nelemface(*),ikmpc(*),ilmpc(*),ikboun(*),compressible, - & ilboun(*),nactdok(*),konl(20),nrhcon(*),ielmat(*), - & ipkon(*),nshcon(*),ifreestream(*),nfreestream,isolidsurf(*), - & nsolidsurf,turbulent -! - integer nk,ne,nboun,nmpc,nface,neqk,nmethod,nzsk,i,j,k,jj, - & id,ist,index,jdof1,idof1, - & node1,kflag,ntmat_,indexe,nope, - & mi(2),i0,ncmat_ -! - real*8 co(3,*),xboun(*),coefmpc(*),bk(*),v(0:mi(2),*), - & vold(0:mi(2),*), - & voldaux(0:4,*),ffk(60),rhcon(0:1,ntmat_,*),yy(*), - & shcon(0:3,ntmat_,*),theta1,bt(*),fft(60),voldtu(2,*), - & xsolidsurf(*) -! - real*8 dtime -! - kflag=2 - i0=0 -! - do i=1,neqk - bk(i)=0.d0 - bt(i)=0.d0 - enddo -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - call e_c3d_krhs(co,nk,konl,lakon(i),ffk,fft,i,nmethod,rhcon, - & nrhcon,ielmat,ntmat_,vold,voldaux,dtime,matname,mi(1), - & shcon,nshcon,voldtu,compressible,yy,nelemface,sideface, - & nface,turbulent) -! - do jj=1,nope -! - j=jj - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdok(node1) -! -! inclusion of ffk and fft -! - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8 - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof1=nactdok(nodempc(1,index)) - if(jdof1.ne.0) then - bk(jdof1)=bk(jdof1) - & -coefmpc(index)*ffk(jj) - & /coefmpc(ist) - bt(jdof1)=bt(jdof1) - & -coefmpc(index)*fft(jj) - & /coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - bk(jdof1)=bk(jdof1)+ffk(jj) - bt(jdof1)=bt(jdof1)+fft(jj) -! - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillplhs.f calculix-ccx-2.3/ccx_2.1/src/mafillplhs.f --- calculix-ccx-2.1/ccx_2.1/src/mafillplhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillplhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,230 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillplhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nactdoh,icolp,jqp,irowp, - & neqp,nzlp,ikmpc,ilmpc,ikboun,ilboun,nzsp,adbp,aubp,nmethod, - & iexplicit) -! -! filling the lhs pressure matrix in sparse matrix format -! -! it is assumed that the temperature MPC's also apply to the -! pressure. Temperature MPC's are not allowed to contain -! other variables than the temperature. -! - implicit none -! - character*8 lakon(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & icolp(*),jqp(*),ikmpc(*),nzsp,nmethod,iexplicit, - & ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20),irowp(*), - & ipkon(*) -! - integer nk,ne,nboun,nmpc,neqp,nzlp,i,j,jj, - & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, - & mpc1,mpc2,index1,index2,node1,node2, - & indexe,nope,i0 -! - real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbp(*),aubp(*) -! - real*8 value -! - i0=0 -! -! determining nzlp -! - nzlp=0 - do i=neqp,1,-1 - if(icolp(i).gt.0) then - nzlp=i - exit - endif - enddo -! - do i=1,neqp - adbp(i)=0.d0 - enddo - do i=1,nzsp - aubp(i)=0.d0 - enddo -! -! loop over all fluid elements -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - call e_c3d_plhs(co,nk,konl,lakon(i),sm,i,nmethod,iexplicit) -! - do jj=1,nope -! - node1=kon(indexe+jj) - jdof1=nactdoh(4,node1) -! - do ll=jj,nope -! - node2=kon(indexe+ll) - jdof2=nactdoh(4,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - call add_sm_fl(aubp,adbp,jqp,irowp,jdof1,jdof2, - & sm(jj,ll),jj,ll) - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*8+4 - else - idof1=jdof1 - idof2=(node2-1)*8+4 - endif - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - idof2=nactdoh(4,nodempc(1,index)) - if(idof2.ne.0) then - value=-coefmpc(index)*sm(jj,ll)/ - & coefmpc(ist) - if(idof1.eq.idof2) value=2.d0*value - call add_sm_fl(aubp,adbp,jqp,irowp, - & idof1,idof2,value,i0,i0) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif - else - idof1=(node1-1)*8+4 - idof2=(node2-1)*8+4 - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - idof1=nactdoh(4,nodempc(1,index1)) - index2=index1 - do - idof2=nactdoh(4,nodempc(1,index2)) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) - call add_sm_fl(aubp,adbp,jqp, - & irowp,idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - idof1=nactdoh(4,nodempc(1,index1)) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - idof2=nactdoh(4,nodempc(1,index2)) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - if(idof1.eq.idof2) value=2.d0*value - call add_sm_fl(aubp,adbp,jqp, - & irowp,idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif - endif - endif - enddo - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillprhs.f calculix-ccx-2.3/ccx_2.1/src/mafillprhs.f --- calculix-ccx-2.1/ccx_2.1/src/mafillprhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillprhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,374 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillprhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nelemface,sideface, - & nface,b,nactdoh,icolp,jqp,irowp,neqp,nzlp,nmethod,ikmpc,ilmpc, - & ikboun,ilboun,rhcon,nrhcon,ielmat,ntmat_,vold,voldaux,nzsp, - & dtime,matname,mi,ncmat_,shcon,nshcon,v,theta1, - & iexplicit,physcon,nea,neb) -! -! filling the rhs b of the pressure equations (step 2) -! - implicit none -! - character*1 sideface(*) - character*8 lakon(*) - character*80 matname(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & nelemface(*),icolp(*),jqp(*),ikmpc(*),ilmpc(*),ikboun(*), - & ilboun(*),nactdoh(0:4,*),konl(20),irowp(*),nrhcon(*),ielmat(*), - & ipkon(*),nshcon(*),iexplicit,nea,neb -! - integer nk,ne,nboun,nmpc,nface,neqp,nzlp,nmethod,nzsp,i,j,k,l,jj, - & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, - & mpc1,mpc2,index1,index2,node1,node2,kflag,ntmat_,indexe,nope, - & mi(2),i0,ncmat_,idof3 -! - real*8 co(3,*),xboun(*),coefmpc(*),b(*),v(0:mi(2),*), - & vold(0:mi(2),*), - & voldaux(0:4,*),ff(60),sm(60,60),rhcon(0:1,ntmat_,*), - & shcon(0:3,ntmat_,*),theta1,physcon(*) -! - real*8 value,dtime -! - kflag=2 - i0=0 -! -! determining nzlp -! -c if(iexplicit) then -c nzlp=0 -c do i=neqp,1,-1 -c if(icolp(i).gt.0) then -c nzlp=i -c exit -c endif -c enddo -c endif -! - do i=1,neqp - b(i)=0.d0 - enddo -! - do i=nea,neb -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - call e_c3d_prhs(co,nk,konl,lakon(i),sm,ff,i,nmethod,rhcon, - & nrhcon,ielmat,ntmat_,v,vold,voldaux,nelemface,sideface, - & nface,dtime,matname,mi(1),shcon,nshcon,theta1,physcon, - & iexplicit) -! - do jj=1,nope -! - j=jj - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdoh(4,node1) -! - do ll=jj,nope -! - l=ll -! - node2=kon(indexe+l) - jdof2=nactdoh(4,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then -c call add_sm_fl(aubp,adbp,jqp,irowp,jdof1,jdof2, -c & sm(jj,ll),jj,ll) - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*8+4 - else - idof1=jdof1 - idof2=(node2-1)*8+4 - endif - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - idof2=nactdoh(4,nodempc(1,index)) - value=-coefmpc(index)*sm(jj,ll)/coefmpc(ist) - if(idof1.eq.idof2) value=2.d0*value - if(idof2.ne.0) then -c call add_sm_fl(aubp,adbp,jqp,irowp, -cd & idof1,idof2,value,i0,i0) -c else -c if(iexplicit.eq.0) then -c idof2=8*(nodempc(1,index)-1)+ -c & nodempc(2,index) -c call nident(ikboun,idof2,nboun,id) -c b(idof1)=b(idof1) -c & -xboun(ilboun(id))*value -c endif -cd - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif -c! -c! regular DOF / SPC -c! -cd -c if(iexplicit.eq.0) then -cc idof2=idof2+4 -c call nident(ikboun,idof2,nboun,id) -c b(idof1)=b(idof1)-xboun(ilboun(id))*sm(jj,ll) -c endif -cd - else - idof1=(node1-1)*8+4 - idof2=(node2-1)*8+4 - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - idof1=nactdoh(4,nodempc(1,index1)) - index2=index1 - do - idof2=nactdoh(4,nodempc(1,index2)) - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) - if((idof1.ne.0).and.(idof2.ne.0)) then -c call add_sm_fl(aubp,adbp,jqp, -c & irowp,idof1,idof2,value,i0,i0) -cd -c elseif((iexplicit.eq.0).and. -c & ((idof1.ne.0).or.(idof2.ne.0))) then -c if(idof2.ne.0) then -c idof3=idof2 -c idof2=8*(nodempc(1,index1)-1)+ -c & nodempc(2,index1) -c else -c idof3=idof1 -c idof2=8*(nodempc(1,index2)-1)+ -c & nodempc(2,index2) -c endif -c call nident(ikboun,idof2,nboun,id) -c b(idof3)=b(idof3) -c & -value*xboun(ilboun(id)) -cd - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - idof1=nactdoh(4,nodempc(1,index1)) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - idof2=nactdoh(4,nodempc(1,index2)) - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - if(idof1.eq.idof2) value=2.d0*value - if((idof1.ne.0).and.(idof2.ne.0)) then -c call add_sm_fl(aubp,adbp,jqp, -c & irowp,idof1,idof2,value,i0,i0) -cd -c elseif((iexplicit.eq.0).and. -c & ((idof1.ne.0).or.(idof2.ne.0))) then -c if(idof2.ne.0) then -c idof3=idof2 -c idof2=8*(nodempc(1,index1)-1)+ -c & nodempc(2,index1) -c else -c idof3=idof1 -c idof2=8*(nodempc(1,index2)-1)+ -c & nodempc(2,index2) -c endif -c call nident(ikboun,idof2,nboun,id) -c b(idof3)=b(idof3) -c & -value*xboun(ilboun(id)) -cd - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif -cd -c elseif(((mpc1.eq.1).or.(mpc2.eq.1)).and.(iexplicit.eq.0)) -c & then -c if(mpc1.eq.1) then -c! -c! MPC id1 / SPC -c! -cc idof2=idof2+4 -c call nident(ikboun,idof2,nboun,id2) -c idof2=ilboun(id2) -c ist1=ipompc(id1) -c index1=nodempc(3,ist1) -c if(index1.eq.0) cycle -c do -c idof1=nactdoh(nodempc(2,index1), -c & nodempc(1,index1)) -c if(idof1.ne.0) then -c b(idof1)=b(idof1)+xboun(idof2)* -c & coefmpc(index1)*sm(jj,ll)/coefmpc(ist1) -c endif -c index1=nodempc(3,index1) -c if(index1.eq.0) exit -c enddo -c elseif(mpc2.eq.1) then -c! -c! MPC id2 / SPC -c! -cc idof1=idof1+4 -c call nident(ikboun,idof1,nboun,id1) -c idof1=ilboun(id1) -c ist2=ipompc(id2) -c index2=nodempc(3,ist2) -c if(index2.eq.0) cycle -c do -c idof2=nactdoh(nodempc(2,index2), -c & nodempc(1,index2)) -c if(idof2.ne.0) then -c b(idof2)=b(idof2)+xboun(idof1)* -c & coefmpc(index2)*sm(jj,ll)/coefmpc(ist2) -c endif -c index2=nodempc(3,index2) -c if(index2.eq.0) exit -c enddo -c endif -cd - endif - endif - enddo -! -! inclusion of ff -! - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8+4 - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof1=nactdoh(4,nodempc(1,index)) - if(jdof1.ne.0) then - b(jdof1)=b(jdof1) - & -coefmpc(index)*ff(jj) - & /coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - b(jdof1)=b(jdof1)+ff(jj) -! - enddo - enddo -! -c write(*,*) 'press 136 ',b(128) -c write(*,*) 'press 68 ',b(64) -c write(*,*) 'press 323 ',b(304) -c write(*,*) 'press 289 ',b(272) -c write(*,*) 'press 243 ',b(322) -c write(*,*) 'press 392 ',b(369) -c write(*,*) -c write(*,*) 'rhspressure' -c do i=1,neqp -c write(*,*) 'rhs press ',i,b(i)*2.e10 -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillsmas.f calculix-ccx-2.3/ccx_2.1/src/mafillsmas.f --- calculix-ccx-2.1/ccx_2.1/src/mafillsmas.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillsmas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,128 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillsmas(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun, - & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - & ad,au,bb,nactdof,icol,jq,irow,neq,nzl,nmethod, - & ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon, - & nrhcon,alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - & t0,t1,ithermal,prestr, - & iprestr,vold,iperturb,sti,nzs,stx,adb,aub,iexpl,plicon, - & nplicon,plkcon,nplkcon,xstiff,npmat_,dtime, - & matname,mi,ncmat_,mass,stiffness,buckling,rhsi,intscheme, - & physcon,shcon,nshcon,cocon,ncocon,ttime,time,istep,iinc, - & coriolis,ibody,xloadold,reltime,veold) -! -! filling the stiffness matrix in spare matrix format (sm) -! asymmetric contributions -! - implicit none -! - logical mass,stiffness,buckling,rhsi,coriolis -! - character*8 lakon(*) - character*20 sideload(*) - character*80 matname(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & nodeforc(2,*),ndirforc(*),nelemload(2,*),icol(*),jq(*),ikmpc(*), - & ilmpc(*),ikboun(*),ilboun(*),mi(2), - & nactdof(0:mi(2),*),konl(20),irow(*), - & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), - & ipkon(*),intscheme,ncocon(2,*),nshcon(*),ipobody(2,*),nbody, - & ibody(3,*) -! - integer nk,ne,nboun,nmpc,nforc,nload,neq,nzl,nmethod, - & ithermal,iprestr,iperturb(*),nzs(3),i,j,k,l,m,idist,jj, - & ll,jdof1,jdof2,node1,node2, - & ntmat_,indexe,nope,norien,iexpl,ncmat_,istep,iinc -! - integer nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ -! - real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), - & p2(3),ad(*),au(*),bodyf(3),bb(*),xloadold(2,*), - & t0(*),t1(*),prestr(6,mi(1),*),vold(0:mi(2),*),s(60,60),ff(60), - & sti(6,mi(1),*),sm(60,60),stx(6,mi(1),*),adb(*),aub(*), - & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*),reltime, - & alcon(0:6,ntmat_,*),physcon(*),cocon(0:6,ntmat_,*), - & shcon(0:3,ntmat_,*),alzero(*),orab(7,*),xbody(7,*),cgr(4,*) -! - real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), - & xstiff(27,mi(1),*),veold(0:mi(2),*) -! - real*8 om,dtime,ttime,time -! -! storing the symmetric matrix in asymmetric format -! - do i=1,nzs(3) - au(nzs(3)+i)=au(i) - enddo -! -! mechanical analysis: asymmetric contributions -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'E') cycle - indexe=ipkon(i) - nope=4 -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - call e_c3d(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody,s,sm,ff,i, - & nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon, - & alzero,ielmat,ielorien,norien,orab,ntmat_, - & t0,t1,ithermal,vold,iperturb,nelemload,sideload,xload, - & nload,idist,sti,stx,iexpl,plicon, - & nplicon,plkcon,nplkcon,xstiff,npmat_, - & dtime,matname,mi(1),ncmat_,mass,stiffness,buckling,rhsi, - & intscheme,ttime,time,istep,iinc,coriolis,xloadold, - & reltime,ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold) -! - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdof(k,node1) -! - do ll=1,3*nope -! - l=(ll-1)/3+1 - m=ll-3*(l-1) -! - node2=kon(indexe+l) - jdof2=nactdof(m,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - call add_sm_st_as(au,ad,jq,irow,jdof1,jdof2, - & s(jj,ll),jj,ll,nzs) - endif - enddo - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillsmcs.f calculix-ccx-2.3/ccx_2.1/src/mafillsmcs.f --- calculix-ccx-2.1/ccx_2.1/src/mafillsmcs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillsmcs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,621 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillsmcs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun, - & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - & ad,au,bb,nactdof,icol,jq,irow,neq,nzl,nmethod, - & ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon, - & nrhcon,alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - & t0,t1,ithermal,prestr, - & iprestr,vold,iperturb,sti,nzs,stx,adb,aub,iexpl,plicon, - & nplicon,plkcon,nplkcon,xstiff,npmat_,dtime, - & matname,mi,ics,cs,nm,ncmat_,labmpc,mass,stiffness,buckling, - & rhsi,intscheme,mcs,coriolis,ibody,xloadold,reltime,ielcs, - & veold) -! -! filling the stiffness matrix in spare matrix format (sm) -! for cyclic symmetry calculations -! - implicit none -! - logical mass,stiffness,buckling,rhsi,coriolis -! - character*8 lakon(*) - character*20 labmpc(*),sideload(*) - character*80 matname(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & nodeforc(2,*),ndirforc(*),nelemload(2,*),icol(*),jq(*),ikmpc(*), - & ilmpc(*),ikboun(*),ilboun(*),mi(2), - & nactdof(0:mi(2),*),konl(20),irow(*), - & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), - & ipkon(*),ics(*),ij,ilength,lprev,ipobody(2,*),nbody, - & ibody(3,*) -! - integer nk,ne,nboun,nmpc,nforc,nload,neq,nzl,nmethod, - & ithermal,iprestr,iperturb(*),nzs,i,j,k,l,m,idist,jj, - & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, - & mpc1,mpc2,index1,index2,node1,node2,kflag, - & ntmat_,indexe,nope,norien,iexpl,i0,nm,inode,icomplex, - & inode1,icomplex1,inode2,icomplex2,ner,ncmat_,intscheme,istep, - & iinc,mcs,ielcs(*) -! - integer nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ -! - real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), - & p2(3),ad(*),au(*),bodyf(3),bb(*),xbody(7,*),cgr(4,*), - & t0(*),t1(*),prestr(6,mi(1),*),vold(0:mi(2),*),s(60,60),ff(60), - & sti(6,mi(1),*),sm(60,60),stx(6,mi(1),*),adb(*),aub(*), - & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*),xloadold(2,*), - & alcon(0:6,ntmat_,*),cs(17,*),alzero(*),orab(7,*),reltime -! - real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), - & xstiff(27,mi(1),*),pi,theta,ti,tr,veold(0:mi(2),*) -! - real*8 om,valu2,value,dtime,walue,walu2,time,ttime -! -! -! calculating the scaling factors for the cyclic symmetry calculation -! -c do i=1,nmpc -c write(*,*) i,labmpc(i) -c index=ipompc(i) -c do -c write(*,'(i5,1x,i5,1x,e11.4)') nodempc(1,index), -c & nodempc(2,index),coefmpc(index) -c index=nodempc(3,index) -c if(index.eq.0) exit -c enddo -c write(*,*) -c enddo -! - pi=4.d0*datan(1.d0) -! - do i=1,mcs - theta=nm*2.d0*pi/cs(1,i) - cs(15,i)=dcos(theta) - cs(16,i)=dsin(theta) - enddo -! - kflag=2 - i0=0 -! -! determining nzl -! - nzl=0 - do i=neq,1,-1 - if(icol(i).gt.0) then - nzl=i - exit - endif - enddo -! -! initializing the matrices -! - do i=1,neq - ad(i)=0.d0 - enddo - do i=1,nzs - au(i)=0.d0 - enddo -! - do i=1,neq - adb(i)=0.d0 - enddo - do i=1,nzs - aub(i)=0.d0 - enddo -! - ner=neq/2 -! -! loop over all elements -! -! initialisation of the error parameter -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - else - nope=6 - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -c! -c! assigning centrifugal forces -c! -c j=ipobody(1,i) -c if(j.ne.0) then -c om=xbody(1,j) -c p1(1)=xbody(2,j) -c p1(2)=xbody(3,j) -c p1(3)=xbody(4,j) -c p2(1)=xbody(5,j) -c p2(2)=xbody(6,j) -c p2(3)=xbody(7,j) -c else -c om=0.d0 -c endif -! - om=0.d0 -! - if(nbody.gt.0) then -! -! assigning centrifugal forces -! - index=i - do - j=ipobody(1,index) - if(j.eq.0) exit - if(ibody(1,j).eq.1) then - om=xbody(1,j) - p1(1)=xbody(2,j) - p1(2)=xbody(3,j) - p1(3)=xbody(4,j) - p2(1)=xbody(5,j) - p2(2)=xbody(6,j) - p2(3)=xbody(7,j) - endif - index=ipobody(2,index) - if(index.eq.0) exit - enddo - endif -! - call e_c3d(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody,s,sm,ff,i, - & nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon, - & alzero,ielmat,ielorien,norien,orab,ntmat_, - & t0,t1,ithermal,vold,iperturb,nelemload,sideload,xload, - & nload,idist,sti,stx,iexpl,plicon, - & nplicon,plkcon,nplkcon,xstiff,npmat_, - & dtime,matname,mi(1),ncmat_,mass,stiffness,buckling,rhsi, - & intscheme,ttime,time,istep,iinc,coriolis,xloadold, - & reltime,ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold) -! - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdof(k,node1) -! - do ll=jj,3*nope - if (mcs.gt.1)then - if(cs(1,(ielcs(i)+1)).ne.1.d0) then - s(jj,ll)=(cs(1,(ielcs(i)+1))/cs(1,1))*s(jj,ll) - sm(jj,ll)=(cs(1,(ielcs(i)+1))/cs(1,1))*sm(jj,ll) - endif - endif -! - l=(ll-1)/3+1 - m=ll-3*(l-1) -! - node2=kon(indexe+l) - jdof2=nactdof(m,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - call add_sm_ei(au,ad,aub,adb,jq,irow,jdof1,jdof2, - & s(jj,ll),sm(jj,ll),jj,ll) - call add_sm_ei(au,ad,aub,adb,jq,irow,jdof1+ner,jdof2+ner, - & s(jj,ll),sm(jj,ll),jj,ll) - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*8+k - else - idof1=jdof1 - idof2=(node2-1)*8+m - endif -! - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id1=ilmpc(id) - ist=ipompc(id1) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - inode=nodempc(1,index) - icomplex=0 -c write(*,*) id1,labmpc(id1)(1:9) - if(labmpc(id1)(1:6).eq.'CYCLIC') then - read(labmpc(id1)(7:20),'(i14)') icomplex - elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then - do ij=1,mcs - ilength=int(cs(4,ij)) - lprev=int(cs(14,ij)) - call nident(ics(lprev+1),inode,ilength,id) - if(id.gt.0) then - if(ics(lprev+id).eq.inode) then - icomplex=ij - exit - endif - endif - enddo - endif - idof2=nactdof(nodempc(2,index),inode) - if(idof2.ne.0) then - value=-coefmpc(index)*s(jj,ll)/coefmpc(ist) - valu2=-coefmpc(index)*sm(jj,ll)/ - & coefmpc(ist) - if(idof1.eq.idof2) then - value=2.d0*value - valu2=2.d0*valu2 - endif - if(icomplex.eq.0) then - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1,idof2,value,valu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1+ner,idof2+ner,value,valu2,i0,i0) - else - walue=value*cs(15,icomplex) - walu2=valu2*cs(15,icomplex) - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1,idof2,walue,walu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1+ner,idof2+ner,walue,walu2,i0,i0) - if(idof1.ne.idof2) then - walue=value*cs(16,icomplex) - walu2=valu2*cs(16,icomplex) - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1,idof2+ner,walue,walu2,i0,i0) - walue=-walue - walu2=-walu2 - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1+ner,idof2,walue,walu2,i0,i0) - endif - endif - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif -! - else - idof1=(node1-1)*8+k - idof2=(node2-1)*8+m -! - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - inode1=nodempc(1,index1) - icomplex1=0 - if(labmpc(id1)(1:6).eq.'CYCLIC') then - read(labmpc(id1)(7:20),'(i14)') icomplex1 - elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then - do ij=1,mcs - ilength=int(cs(4,ij)) - lprev=int(cs(14,ij)) - call nident(ics(lprev+1),inode1, - & ilength,id) - if(id.gt.0) then - if(ics(lprev+id).eq.inode1) then - icomplex1=ij - exit - endif - endif - enddo - endif - idof1=nactdof(nodempc(2,index1),inode1) - index2=index1 - do - inode2=nodempc(1,index2) - icomplex2=0 - if(labmpc(id1)(1:6).eq.'CYCLIC') then - read(labmpc(id1)(7:20),'(i14)') icomplex2 - elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then - do ij=1,mcs - ilength=int(cs(4,ij)) - lprev=int(cs(14,ij)) - call nident(ics(lprev+1),inode2, - & ilength,id) - if(id.gt.0) then - if(ics(lprev+id).eq.inode2) then - icomplex2=ij - exit - endif - endif - enddo - endif - idof2=nactdof(nodempc(2,index2),inode2) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & s(jj,ll)/coefmpc(ist)/coefmpc(ist) - valu2=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) - if((icomplex1.eq.0).and. - & (icomplex2.eq.0)) then - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,value,valu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1+ner,idof2+ner,value, - & valu2,i0,i0) - elseif((icomplex1.ne.0).and. - & (icomplex2.ne.0)) then - if(icomplex1.eq.icomplex2) then - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,value,valu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1+ner,idof2+ner,value, - & valu2,i0,i0) - else - tr=cs(15,icomplex1)*cs(15,icomplex2) - & +cs(16,icomplex1)*cs(16,icomplex2) -c write(*,*) 'tr= ',tr - walue=value*tr - walu2=valu2*tr - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,walue,walu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1+ner,idof2+ner,walue, - & walu2,i0,i0) - ti=cs(15,icomplex1)*cs(16,icomplex2) - & -cs(15,icomplex2)*cs(16,icomplex1) -c write(*,*) icomplex1,icomplex2, -c & cs(15,icomplex1),cs(16,icomplex1), -c & cs(15,icomplex2),cs(16,icomplex2) -c write(*,*) 'ti= ',ti - walue=value*ti - walu2=valu2*ti -c write(*,'(2i8,2(1x,e11.4))') -c & idof1,idof2+ner, -c & walue,walu2 - call add_sm_ei(au,ad,aub,adb,jq,irow - & ,idof1,idof2+ner,walue,walu2,i0,i0) - walue=-walue - walu2=-walu2 - call add_sm_ei(au,ad,aub,adb,jq,irow - & ,idof1+ner,idof2,walue,walu2,i0,i0) - endif - elseif((icomplex1.eq.0).or. - & (icomplex2.eq.0)) then - if(icomplex2.ne.0) then - walue=value*cs(15,icomplex2) - walu2=valu2*cs(15,icomplex2) - else - walue=value*cs(15,icomplex1) - walu2=valu2*cs(15,icomplex1) - endif - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1,idof2,walue,walu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1+ner,idof2+ner,walue,walu2,i0,i0) - if(icomplex2.ne.0) then - walue=value*cs(16,icomplex2) - walu2=valu2*cs(16,icomplex2) - else - walue=-value*cs(16,icomplex1) - walu2=-valu2*cs(16,icomplex1) - endif -c walue=value*st -c walu2=valu2*st - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1,idof2+ner,walue,walu2,i0,i0) - walue=-walue - walu2=-walu2 - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1+ner,idof2,walue,walu2,i0,i0) - endif - endif - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - inode1=nodempc(1,index1) - icomplex1=0 - if(labmpc(id1)(1:6).eq.'CYCLIC') then - read(labmpc(id1)(7:20),'(i14)') icomplex1 - elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then - do ij=1,mcs - ilength=int(cs(4,ij)) - lprev=int(cs(14,ij)) - call nident(ics(lprev+1),inode1, - & ilength,id) - if(id.gt.0) then - if(ics(lprev+id).eq.inode1) then - icomplex1=ij - exit - endif - endif - enddo - endif - idof1=nactdof(nodempc(2,index1),inode1) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - inode2=nodempc(1,index2) - icomplex2=0 - if(labmpc(id2)(1:6).eq.'CYCLIC') then - read(labmpc(id2)(7:20),'(i14)') icomplex2 - elseif(labmpc(id2)(1:9).eq.'SUBCYCLIC') then - do ij=1,mcs - ilength=int(cs(4,ij)) - lprev=int(cs(14,ij)) - call nident(ics(lprev+1),inode2, - & ilength,id) - if(id.gt.0) then - if(ics(lprev+id).eq.inode2) then - icomplex2=ij - exit - endif - endif - enddo - endif - idof2=nactdof(nodempc(2,index2),inode2) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & s(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - valu2=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - if(idof1.eq.idof2) then - value=2.d0*value - valu2=2.d0*valu2 - endif - if((icomplex1.eq.0).and. - & (icomplex2.eq.0)) then - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,value,valu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1+ner,idof2+ner,value, - & valu2,i0,i0) - elseif((icomplex1.ne.0).and. - & (icomplex2.ne.0)) then - if(icomplex1.eq.icomplex2) then - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,value,valu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1+ner,idof2+ner,value, - & valu2,i0,i0) - else - tr=cs(15,icomplex1)*cs(15,icomplex2) - & +cs(16,icomplex1)*cs(16,icomplex2) -c write(*,*) 'tr= ',tr - walue=value*tr - walu2=valu2*tr - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,walue,walu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1+ner,idof2+ner,walue, - & walu2,i0,i0) - ti=cs(15,icomplex1)*cs(16,icomplex2) - & -cs(15,icomplex2)*cs(16,icomplex1) -c write(*,*) icomplex1,icomplex2, -c & cs(15,icomplex1),cs(16,icomplex1), -c & cs(15,icomplex2),cs(16,icomplex2) -c write(*,*) 'ti= ',ti - walue=value*ti - walu2=valu2*ti -c write(*,'(2i8,2(1x,e11.4))') -c & idof1,idof2+ner, -c & walue,walu2 - call add_sm_ei(au,ad,aub,adb,jq,irow - & ,idof1,idof2+ner,walue,walu2,i0,i0) - walue=-walue - walu2=-walu2 - call add_sm_ei(au,ad,aub,adb,jq,irow - & ,idof1+ner,idof2,walue,walu2,i0,i0) - endif - elseif((icomplex1.eq.0).or. - & (icomplex2.eq.0)) then - if(icomplex2.ne.0) then - walue=value*cs(15,icomplex2) - walu2=valu2*cs(15,icomplex2) - else - walue=value*cs(15,icomplex1) - walu2=valu2*cs(15,icomplex1) - endif - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1,idof2,walue,walu2,i0,i0) - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1+ner,idof2+ner,walue,walu2,i0,i0) - if(idof1.ne.idof2) then - if(icomplex2.ne.0) then - walue=value*cs(16,icomplex2) - walu2=valu2*cs(16,icomplex2) - else - walue=-value*cs(16,icomplex1) - walu2=-valu2*cs(16,icomplex1) - endif -c walue=value*st -c walu2=valu2*st - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2+ner,walue, - & walu2,i0,i0) - walue=-walue - walu2=-walu2 - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1+ner,idof2,walue, - & walu2,i0,i0) - endif - endif - endif - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif - endif - endif - enddo -! - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillsm.f calculix-ccx-2.3/ccx_2.1/src/mafillsm.f --- calculix-ccx-2.1/ccx_2.1/src/mafillsm.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillsm.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,800 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillsm(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun, - & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - & ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, - & ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon, - & nrhcon,alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - & t0,t1,ithermal,prestr, - & iprestr,vold,iperturb,sti,nzs,stx,adb,aub,iexpl,plicon, - & nplicon,plkcon,nplkcon,xstiff,npmat_,dtime, - & matname,mi,ncmat_,mass,stiffness,buckling,rhsi,intscheme, - & physcon,shcon,nshcon,cocon,ncocon,ttime,time,istep,iinc, - & coriolis,ibody,xloadold,reltime,veold) -! -! filling the stiffness matrix in spare matrix format (sm) -! - implicit none -! - logical mass(2),stiffness,buckling,rhsi,stiffonly(2),coriolis -! - character*8 lakon(*) - character*20 sideload(*) - character*80 matname(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & nodeforc(2,*),ndirforc(*),nelemload(2,*),icol(*),jq(*),ikmpc(*), - & ilmpc(*),ikboun(*),ilboun(*),mi(2), - & nactdof(0:mi(2),*),konl(20),irow(*), - & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), - & ipkon(*),intscheme,ncocon(2,*),nshcon(*),ipobody(2,*),nbody, - & ibody(3,*) -! - integer nk,ne,nboun,nmpc,nforc,nload,neq(2),nzl,nmethod,icolumn, - & ithermal(2),iprestr,iperturb(*),nzs(3),i,j,k,l,m,idist,jj, - & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, - & mpc1,mpc2,index1,index2,jdof,node1,node2,kflag,icalccg, - & ntmat_,indexe,nope,norien,iexpl,i0,ncmat_,istep,iinc -! - integer nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ -! - real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), - & p2(3),ad(*),au(*),bodyf(3),fext(*),xloadold(2,*),reltime, - & t0(*),t1(*),prestr(6,mi(1),*),vold(0:mi(2),*),s(60,60),ff(60), - & sti(6,mi(1),*),sm(60,60),stx(6,mi(1),*),adb(*),aub(*), - & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*), - & alcon(0:6,ntmat_,*),physcon(*),cocon(0:6,ntmat_,*), - & shcon(0:3,ntmat_,*),alzero(*),orab(7,*),xbody(7,*),cgr(4,*) -! - real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), - & xstiff(27,mi(1),*),veold(0:mi(2),*) -! - real*8 om,valu2,value,dtime,ttime,time -! - kflag=2 - i0=0 - icalccg=0 -! - if(stiffness.and.(.not.mass(1)).and.(.not.buckling)) then - stiffonly(1)=.true. - else - stiffonly(1)=.false. - endif - if(stiffness.and.(.not.mass(2)).and.(.not.buckling)) then - stiffonly(2)=.true. - else - stiffonly(2)=.false. - endif -! -! determining nzl -! - nzl=0 - do i=neq(2),1,-1 - if(icol(i).gt.0) then - nzl=i - exit - endif - enddo -! -! initializing the matrices -! - if(.not.buckling) then - do i=1,neq(2) - ad(i)=0.d0 - enddo - do i=1,nzs(3) - au(i)=0.d0 - enddo - endif -! - if(rhsi) then - do i=1,neq(2) - fext(i)=0.d0 - enddo - endif -c elseif(mass.or.buckling) then - if(mass(1).or.buckling) then - do i=1,neq(1) - adb(i)=0.d0 - enddo - do i=1,nzs(1) - aub(i)=0.d0 - enddo - endif - if(mass(2)) then - do i=neq(1)+1,neq(2) - adb(i)=0.d0 - enddo - do i=nzs(1)+1,nzs(2) - aub(i)=0.d0 - enddo - endif -! - if(rhsi) then -! -! distributed forces (body forces or thermal loads or -! residual stresses or distributed face loads) -! - if((nbody.ne.0).or.(ithermal(1).ne.0).or. - & (iprestr.ne.0).or.(nload.ne.0)) then - idist=1 - else - idist=0 - endif -! - endif -! - if((ithermal(1).le.1).or.(ithermal(1).eq.3)) then -! -! mechanical analysis: loop over all elements -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - elseif(lakon(i)(1:2).eq.'ES') then - read(lakon(i)(8:8),'(i1)') nope - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - om=0.d0 -! -c if((rhsi).and.(nbody.gt.0).and.(lakon(i)(1:1).ne.'E')) then - if((nbody.gt.0).and.(lakon(i)(1:1).ne.'E')) then -! -! assigning centrifugal forces -! - bodyf(1)=0. - bodyf(2)=0. - bodyf(3)=0. -! - index=i - do - j=ipobody(1,index) - if(j.eq.0) exit - if(ibody(1,j).eq.1) then - om=xbody(1,j) - p1(1)=xbody(2,j) - p1(2)=xbody(3,j) - p1(3)=xbody(4,j) - p2(1)=xbody(5,j) - p2(2)=xbody(6,j) - p2(3)=xbody(7,j) -! -! assigning gravity forces -! - elseif(ibody(1,j).eq.2) then - bodyf(1)=bodyf(1)+xbody(1,j)*xbody(2,j) - bodyf(2)=bodyf(2)+xbody(1,j)*xbody(3,j) - bodyf(3)=bodyf(3)+xbody(1,j)*xbody(4,j) -! -! assigning newton gravity forces -! - elseif(ibody(1,j).eq.3) then - call newton(icalccg,ne,ipkon,lakon,kon,t0,co,rhcon, - & nrhcon,ntmat_,physcon,i,cgr,bodyf,ielmat,ithermal, - & vold,mi) - endif - index=ipobody(2,index) - if(index.eq.0) exit - enddo - endif -c write(*,*) 'mafillsm ',i,bodyf(1),bodyf(2),bodyf(3) -! - call e_c3d(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody,s,sm,ff,i, - & nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon, - & alzero,ielmat,ielorien,norien,orab,ntmat_, - & t0,t1,ithermal,vold,iperturb,nelemload,sideload,xload, - & nload,idist,sti,stx,iexpl,plicon, - & nplicon,plkcon,nplkcon,xstiff,npmat_, - & dtime,matname,mi(1),ncmat_,mass(1),stiffness,buckling, - & rhsi,intscheme,ttime,time,istep,iinc,coriolis,xloadold, - & reltime,ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold) -! - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdof(k,node1) -! - do ll=jj,3*nope -! - l=(ll-1)/3+1 - m=ll-3*(l-1) -! - node2=kon(indexe+l) - jdof2=nactdof(m,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - if(stiffonly(1)) then - call add_sm_st(au,ad,jq,irow,jdof1,jdof2, - & s(jj,ll),jj,ll) - else - call add_sm_ei(au,ad,aub,adb,jq,irow,jdof1,jdof2, - & s(jj,ll),sm(jj,ll),jj,ll) - endif - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*8+k - else - idof1=jdof1 - idof2=(node2-1)*8+m - endif - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - idof2=nactdof(nodempc(2,index),nodempc(1,index)) - value=-coefmpc(index)*s(jj,ll)/coefmpc(ist) - if(idof1.eq.idof2) value=2.d0*value - if(idof2.ne.0) then - if(stiffonly(1)) then - call add_sm_st(au,ad,jq,irow,idof1, - & idof2,value,i0,i0) - else - valu2=-coefmpc(index)*sm(jj,ll)/ - & coefmpc(ist) -c - if(idof1.eq.idof2) valu2=2.d0*valu2 -c - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1,idof2,value,valu2,i0,i0) - endif - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif -! -! regular DOF / SPC -! - if(rhsi) then - elseif(nmethod.eq.2) then - value=s(jj,ll) - call nident(ikboun,idof2,nboun,id) - icolumn=neq(2)+ilboun(id) - call add_bo_st(au,jq,irow,idof1,icolumn,value) - endif - else - idof1=(node1-1)*8+k - idof2=(node2-1)*8+m - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - idof1=nactdof(nodempc(2,index1), - & nodempc(1,index1)) - index2=index1 - do - idof2=nactdof(nodempc(2,index2), - & nodempc(1,index2)) - value=coefmpc(index1)*coefmpc(index2)* - & s(jj,ll)/coefmpc(ist)/coefmpc(ist) - if((idof1.ne.0).and.(idof2.ne.0)) then - if(stiffonly(1)) then - call add_sm_st(au,ad,jq,irow, - & idof1,idof2,value,i0,i0) - else - valu2=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,value,valu2,i0,i0) - endif - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - idof1=nactdof(nodempc(2,index1), - & nodempc(1,index1)) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - idof2=nactdof(nodempc(2,index2), - & nodempc(1,index2)) - value=coefmpc(index1)*coefmpc(index2)* - & s(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - if(idof1.eq.idof2) value=2.d0*value - if((idof1.ne.0).and.(idof2.ne.0)) then - if(stiffonly(1)) then - call add_sm_st(au,ad,jq,irow, - & idof1,idof2,value,i0,i0) - else - valu2=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) -c - if(idof1.eq.idof2) valu2=2.d0*valu2 -c - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,value,valu2,i0,i0) - endif - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif -c elseif(((mpc1.eq.1).or.(mpc2.eq.1)).and.rhsi) -c & then -c if(mpc1.eq.1) then -c! -c! MPC id1 / SPC -c! -c call nident(ikboun,idof2,nboun,id2) -c idof2=ilboun(id2) -c ist1=ipompc(id1) -c index1=nodempc(3,ist1) -c if(index1.eq.0) cycle -c elseif(mpc2.eq.1) then -c! -c! MPC id2 / SPC -c! -c call nident(ikboun,idof1,nboun,id1) -c idof1=ilboun(id1) -c ist2=ipompc(id2) -c index2=nodempc(3,ist2) -c if(index2.eq.0) cycle -c endif - endif - endif - enddo -! - if(rhsi) then -! -! distributed forces -! - if(idist.ne.0) then - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8+k - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof1=nactdof(nodempc(2,index), - & nodempc(1,index)) - if(jdof1.ne.0) then - fext(jdof1)=fext(jdof1) - & -coefmpc(index)*ff(jj) - & /coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - fext(jdof1)=fext(jdof1)+ff(jj) - endif - endif -! - enddo - enddo -! - endif - if(ithermal(1).gt.1) then -! -! thermal analysis: loop over all elements -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - call e_c3d_th(co,nk,konl,lakon(i),s,sm, - & ff,i,nmethod,rhcon,nrhcon,ielmat,ielorien,norien,orab, - & ntmat_,t0,t1,ithermal,vold,iperturb,nelemload, - & sideload,xload,nload,idist,iexpl,dtime, - & matname,mi(1),mass(2),stiffness,buckling,rhsi,intscheme, - & physcon,shcon,nshcon,cocon,ncocon,ttime,time,istep,iinc, - & xstiff,xloadold,reltime,ipompc,nodempc,coefmpc,nmpc,ikmpc, - & ilmpc) -! - do jj=1,nope -! - j=jj -c k=0 -! - node1=kon(indexe+j) - jdof1=nactdof(0,node1) -! - do ll=jj,nope -! - l=ll -c m=0 -! - node2=kon(indexe+l) - jdof2=nactdof(0,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - if(stiffonly(2)) then - call add_sm_st(au,ad,jq,irow,jdof1,jdof2, - & s(jj,ll),jj,ll) - else - call add_sm_ei(au,ad,aub,adb,jq,irow,jdof1,jdof2, - & s(jj,ll),sm(jj,ll),jj,ll) - endif - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*8 - else - idof1=jdof1 - idof2=(node2-1)*8 - endif - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - idof2=nactdof(nodempc(2,index),nodempc(1,index)) - value=-coefmpc(index)*s(jj,ll)/coefmpc(ist) - if(idof1.eq.idof2) value=2.d0*value - if(idof2.ne.0) then - if(stiffonly(2)) then - call add_sm_st(au,ad,jq,irow,idof1, - & idof2,value,i0,i0) - else - valu2=-coefmpc(index)*sm(jj,ll)/ - & coefmpc(ist) -c - if(idof1.eq.idof2) valu2=2.d0*valu2 -c - call add_sm_ei(au,ad,aub,adb,jq,irow, - & idof1,idof2,value,valu2,i0,i0) - endif - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif -! -! regular DOF / SPC -! - if(rhsi) then - elseif(nmethod.eq.2) then - value=s(jj,ll) - call nident(ikboun,idof2,nboun,id) - icolumn=neq(2)+ilboun(id) - call add_bo_st(au,jq,irow,idof1,icolumn,value) - endif - else - idof1=(node1-1)*8 - idof2=(node2-1)*8 - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - idof1=nactdof(nodempc(2,index1), - & nodempc(1,index1)) - index2=index1 - do - idof2=nactdof(nodempc(2,index2), - & nodempc(1,index2)) - value=coefmpc(index1)*coefmpc(index2)* - & s(jj,ll)/coefmpc(ist)/coefmpc(ist) - if((idof1.ne.0).and.(idof2.ne.0)) then - if(stiffonly(2)) then - call add_sm_st(au,ad,jq,irow, - & idof1,idof2,value,i0,i0) - else - valu2=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,value,valu2,i0,i0) - endif - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - idof1=nactdof(nodempc(2,index1), - & nodempc(1,index1)) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - idof2=nactdof(nodempc(2,index2), - & nodempc(1,index2)) - value=coefmpc(index1)*coefmpc(index2)* - & s(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - if(idof1.eq.idof2) value=2.d0*value - if((idof1.ne.0).and.(idof2.ne.0)) then - if(stiffonly(2)) then - call add_sm_st(au,ad,jq,irow, - & idof1,idof2,value,i0,i0) - else - valu2=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) -c - if(idof1.eq.idof2) valu2=2.d0*valu2 -c - call add_sm_ei(au,ad,aub,adb,jq, - & irow,idof1,idof2,value,valu2,i0,i0) - endif - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif -c elseif(((mpc1.eq.1).or.(mpc2.eq.1)).and.rhsi) -c & then -c if(mpc1.eq.1) then -c! -c! MPC id1 / SPC -c! -c call nident(ikboun,idof2,nboun,id2) -c idof2=ilboun(id2) -c ist1=ipompc(id1) -c index1=nodempc(3,ist1) -c if(index1.eq.0) cycle -c do -c idof1=nactdof(nodempc(2,index1), -c & nodempc(1,index1)) -c index1=nodempc(3,index1) -c if(index1.eq.0) exit -c enddo -c elseif(mpc2.eq.1) then -c! -c! MPC id2 / SPC -c! -c call nident(ikboun,idof1,nboun,id1) -c idof1=ilboun(id1) -c ist2=ipompc(id2) -c index2=nodempc(3,ist2) -c if(index2.eq.0) cycle -c endif - endif - endif - enddo -! - if(rhsi) then -! -! distributed forces -! - if(idist.ne.0) then - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8 - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof1=nactdof(nodempc(2,index), - & nodempc(1,index)) - if(jdof1.ne.0) then - fext(jdof1)=fext(jdof1) - & -coefmpc(index)*ff(jj) - & /coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - fext(jdof1)=fext(jdof1)+ff(jj) - endif - endif -! - enddo - enddo -! - endif -! - if(rhsi) then -! -! point forces -! - do i=1,nforc - if(ndirforc(i).gt.3) cycle - jdof=nactdof(ndirforc(i),nodeforc(1,i)) - if(jdof.ne.0) then - fext(jdof)=fext(jdof)+xforc(i) - else -! -! node is a dependent node of a MPC: distribute -! the forces among the independent nodes -! (proportional to their coefficients) -! - jdof=8*(nodeforc(1,i)-1)+ndirforc(i) - call nident(ikmpc,jdof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.jdof) then - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof=nactdof(nodempc(2,index),nodempc(1,index)) - if(jdof.ne.0) then - fext(jdof)=fext(jdof)- - & coefmpc(index)*xforc(i)/coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - endif - enddo -! - endif -! -c write(*,'(6(1x,e11.4))') (au(i),i=1,nzs(2)) -c write(*,'(6(1x,e11.4))') (ad(i),i=1,neq(2)) -c write(*,'(6(1x,e11.4))') (aub(i),i=1,nzs(2)) -c write(*,'(6(1x,e11.4))') (adb(i),i=1,neq(2)) -c write(*,'(6(1x,e11.4))') (b(i),i=1,neq(2)) -c write(*,*) 'mafillsm ' -c write(*,'(6(1x,e11.4))') (fext(i),i=1,neq(2)) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafilltlhs.f calculix-ccx-2.3/ccx_2.1/src/mafilltlhs.f --- calculix-ccx-2.1/ccx_2.1/src/mafilltlhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafilltlhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,230 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafilltlhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, - & nactdoh,icolt,jqt,irowt,neqt,nzlt, - & ikmpc,ilmpc,ikboun,ilboun,nzst,adbt,aubt,nmethod) -! -! filling the stiffness matrix in spare matrix format (sm) -! - implicit none -! - character*8 lakon(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & icolt(*),jqt(*),ikmpc(*),nzst,nmethod, - & ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20),irowt(*), - & ipkon(*) -! - integer nk,ne,nboun,nmpc,neqt,nzlt,i,j,jj, - & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, - & mpc1,mpc2,index1,index2,node1,node2, - & indexe,nope,i0 -! - real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbt(*),aubt(*) -! - real*8 value -! - i0=0 -! -! determining nzlt -! - nzlt=0 - do i=neqt,1,-1 - if(icolt(i).gt.0) then - nzlt=i - exit - endif - enddo -! - do i=1,neqt - adbt(i)=0.d0 - enddo - do i=1,nzst - aubt(i)=0.d0 - enddo -! -! loop over all elements -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - call e_c3d_tlhs(co,nk,konl,lakon(i),sm,i,nmethod) -! - do jj=1,nope -! - node1=kon(indexe+jj) - jdof1=nactdoh(0,node1) -! - do ll=jj,nope -! - node2=kon(indexe+ll) - jdof2=nactdoh(0,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - call add_sm_fl(aubt,adbt,jqt,irowt,jdof1,jdof2, - & sm(jj,ll),jj,ll) - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*8 - else - idof1=jdof1 - idof2=(node2-1)*8 - endif - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - idof2=nactdoh(nodempc(2,index),nodempc(1,index)) - if(idof2.ne.0) then - value=-coefmpc(index)*sm(jj,ll)/ - & coefmpc(ist) - if(idof1.eq.idof2) value=2.d0*value - call add_sm_fl(aubt,adbt,jqt,irowt, - & idof1,idof2,value,i0,i0) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif - else - idof1=(node1-1)*8 - idof2=(node2-1)*8 - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - idof1=nactdoh(nodempc(2,index1), - & nodempc(1,index1)) - index2=index1 - do - idof2=nactdoh(nodempc(2,index2), - & nodempc(1,index2)) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) - call add_sm_fl(aubt,adbt,jqt, - & irowt,idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - idof1=nactdoh(nodempc(2,index1), - & nodempc(1,index1)) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - idof2=nactdoh(nodempc(2,index2), - & nodempc(1,index2)) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - if(idof1.eq.idof2) value=2.d0*value - call add_sm_fl(aubt,adbt,jqt, - & irowt,idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif - endif - endif - enddo - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafilltrhs.f calculix-ccx-2.3/ccx_2.1/src/mafilltrhs.f --- calculix-ccx-2.1/ccx_2.1/src/mafilltrhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafilltrhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,192 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafilltrhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody, - & b,nactdoh,neqt,nmethod,ikmpc,ilmpc,ikboun, - & ilboun,rhcon,nrhcon,ielmat,ntmat_,t0,ithermal,vold,voldaux,nzst, - & dtime,matname,mi,ncmat_,physcon,shcon,nshcon,ttime,time, - & istep,iinc,ibody,xloadold,reltimef,cocon,ncocon,nelemface, - & sideface,nface,compressible,v,voldtu,yy,turbulent,nea,neb) -! -! filling the rhs b of the velocity equations (step 1) -! - implicit none -! - character*1 sideface(*) - character*8 lakon(*) - character*20 sideload(*) - character*80 matname(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & nodeforc(2,*),ndirforc(*),nelemload(2,*),nelemface(*),nface, - & ikmpc(*),ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20), - & nrhcon(*),ielmat(*),ipkon(*),nshcon(*),ipobody(2,*), - & nbody,ibody(3,*),ncocon(2,*),compressible,nea,neb -! - integer nk,ne,nboun,nmpc,nforc,nload,neqt,nmethod, - & ithermal,nzst,i,j,idist,jj,id,ist,index,jdof1,idof1, - & node1,kflag,ntmat_,indexe,nope,mi(2),i0,ncmat_,istep,iinc, - & turbulent -! - real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), - & p2(3),bodyf(3),b(*),xloadold(2,*),reltimef,cocon(0:6,ntmat_,*), - & t0(*),vold(0:mi(2),*),voldaux(0:4,*),ff(60),v(0:mi(2),*),yy(*), - & rhcon(0:1,ntmat_,*),physcon(*),voldtu(2,*), - & shcon(0:3,ntmat_,*),xbody(7,*) -! - real*8 om,dtime,ttime,time -! - kflag=2 - i0=0 -! - do i=1,neqt - b(i)=0.d0 - enddo -! -! distributed forces (body forces or thermal loads or -! residual stresses or distributed face loads) -! - if((nbody.ne.0).or.(ithermal.ne.0).or. - & (nload.ne.0)) then - idist=1 - else - idist=0 - endif -! - do i=nea,neb -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - om=0.d0 -! - if(nbody.gt.0) then -! -! assigning centrifugal forces -! - bodyf(1)=0. - bodyf(2)=0. - bodyf(3)=0. -! - index=i - do - j=ipobody(1,index) - if(j.eq.0) exit - if(ibody(1,j).eq.1) then - om=xbody(1,j) - p1(1)=xbody(2,j) - p1(2)=xbody(3,j) - p1(3)=xbody(4,j) - p2(1)=xbody(5,j) - p2(2)=xbody(6,j) - p2(3)=xbody(7,j) -! -! assigning gravity forces -! - elseif(ibody(1,j).eq.2) then - bodyf(1)=bodyf(1)+xbody(1,j)*xbody(2,j) - bodyf(2)=bodyf(2)+xbody(1,j)*xbody(3,j) - bodyf(3)=bodyf(3)+xbody(1,j)*xbody(4,j) - endif - index=ipobody(2,index) - if(index.eq.0) exit - enddo - endif -! - call e_c3d_trhs(co,nk,konl,lakon(i),p1,p2,om,bodyf, - & nbody,ff,i,nmethod,rhcon,nrhcon, - & ielmat,ntmat_,vold,voldaux,nelemload, - & sideload,xload,nload,idist,dtime,matname,mi(1), - & ttime,time,istep,iinc,xloadold,reltimef,shcon,nshcon, - & cocon,ncocon,physcon,nelemface,sideface,nface, - & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,compressible,v, - & voldtu,yy,turbulent) -! - do jj=1,nope -! - node1=kon(indexe+jj) - jdof1=nactdoh(0,node1) -! -! distributed forces -! - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8 - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof1=nactdoh(nodempc(2,index), - & nodempc(1,index)) - if(jdof1.ne.0) then - b(jdof1)=b(jdof1) - & -coefmpc(index)*ff(jj) - & /coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - b(jdof1)=b(jdof1)+ff(jj) -! - enddo - enddo -! -c do i=1,neqt -c write(*,*) 'mafilltrhs ',i,b(i) -c enddo -c write(*,*) 'press 3 ',b(2) -c write(*,*) 'press 392 ',b(369) -c write(*,*) 'press 256 ',b(241) -c write(*,*) 'press 343 ',b(322) -c write(*,*) 'press 104 ',b(97) -c write(*,*) 'press 256 ',b(241) -c write(*,*) -c write(*,*) 'voldaux(0,1) ',voldaux(0,1) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillv1rhs.f calculix-ccx-2.3/ccx_2.1/src/mafillv1rhs.f --- calculix-ccx-2.1/ccx_2.1/src/mafillv1rhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillv1rhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,215 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillv1rhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody, - & b,nactdoh,icolv,jqv,irowv,neqv,nzlv,nmethod,ikmpc,ilmpc,ikboun, - & ilboun,rhcon,nrhcon,ielmat,ntmat_,t0,ithermal,vold,voldaux,nzsv, - & dtime,matname,mi,ncmat_,physcon,shcon,nshcon,ttime,time, - & istep,iinc,ibody,xloadold,turbulent,voldtu,yy, - & nelemface,sideface,nface,compressible,ne1,ne2) -! -! filling the rhs b of the velocity equations (step 1) -! - implicit none -! - integer turbulent,compressible -! - character*1 sideface(*) - character*8 lakon(*) - character*20 sideload(*) - character*80 matname(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & nodeforc(2,*),ndirforc(*),nelemload(2,*),icolv(*),jqv(*), - & ikmpc(*),ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20), - & irowv(*),nrhcon(*),ielmat(*),ipkon(*),nshcon(*),ipobody(2,*), - & nbody,ibody(3,*),nelemface(*),nface,ne1,ne2 -! - integer nk,ne,nboun,nmpc,nforc,nload,neqv,nzlv,nmethod, - & ithermal,nzsv,i,j,k,idist,jj,id,ist,index,jdof1,idof1, - & jdof,node1,kflag,ntmat_,indexe,nope,mi(2),i0,ncmat_,istep,iinc -! - real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), - & p2(3),bodyf(3),b(*),xloadold(2,*),voldtu(2,*),yy(*), - & t0(*),vold(0:mi(2),*),voldaux(0:4,*),ff(60),rhcon(0:1,ntmat_,*), - & physcon(*),shcon(0:3,ntmat_,*),xbody(7,*) -! - real*8 om,dtime,ttime,time -! - kflag=2 - i0=0 -! - do i=1,neqv - b(i)=0.d0 - enddo -! -! distributed forces (body forces or thermal loads or -! residual stresses or distributed face loads) -! - if((nbody.ne.0).or.(ithermal.ne.0).or. - & (nload.ne.0)) then - idist=1 - else - idist=0 - endif -! - do i=ne1,ne2 -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - om=0.d0 -! - if(nbody.gt.0) then -! -! assigning centrifugal forces -! - bodyf(1)=0. - bodyf(2)=0. - bodyf(3)=0. -! - index=i - do - j=ipobody(1,index) - if(j.eq.0) exit - if(ibody(1,j).eq.1) then - om=xbody(1,j) - p1(1)=xbody(2,j) - p1(2)=xbody(3,j) - p1(3)=xbody(4,j) - p2(1)=xbody(5,j) - p2(2)=xbody(6,j) - p2(3)=xbody(7,j) -! -! assigning gravity forces -! - elseif(ibody(1,j).eq.2) then - bodyf(1)=bodyf(1)+xbody(1,j)*xbody(2,j) - bodyf(2)=bodyf(2)+xbody(1,j)*xbody(3,j) - bodyf(3)=bodyf(3)+xbody(1,j)*xbody(4,j) - endif - index=ipobody(2,index) - if(index.eq.0) exit - enddo - endif -! - call e_c3d_v1rhs(co,nk,konl,lakon(i),p1,p2,om,bodyf, - & nbody,ff,i,nmethod,rhcon,nrhcon,ielmat,ntmat_,vold, - & voldaux,idist,dtime,matname,mi(1), - & ttime,time,istep,iinc,shcon,nshcon, - & turbulent,voldtu,yy,nelemface,sideface,nface,compressible) -! - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdoh(k,node1) -! -! distributed forces -! - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8+k - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof1=nactdoh(nodempc(2,index), - & nodempc(1,index)) - if(jdof1.ne.0) then - b(jdof1)=b(jdof1) - & -coefmpc(index)*ff(jj) - & /coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - b(jdof1)=b(jdof1)+ff(jj) -! - enddo - enddo -! -! point forces -! - if(ne1.eq.1) then - do i=1,nforc - if(ndirforc(i).gt.3) cycle - jdof=nactdoh(ndirforc(i),nodeforc(1,i)) - if(jdof.ne.0) then - b(jdof)=b(jdof)+xforc(i) - else -! -! node is a dependent node of a MPC: distribute -! the forces among the independent nodes -! (proportional to their coefficients) -! - jdof=8*(nodeforc(1,i)-1)+ndirforc(i) - call nident(ikmpc,jdof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.jdof) then - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof=nactdoh(nodempc(2,index),nodempc(1,index)) - if(jdof.ne.0) then - b(jdof)=b(jdof)- - & coefmpc(index)*xforc(i)/coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - endif - enddo - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillv2rhs.f calculix-ccx-2.3/ccx_2.1/src/mafillv2rhs.f --- calculix-ccx-2.1/ccx_2.1/src/mafillv2rhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillv2rhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,115 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillv2rhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, - & b,nactdoh,icolv,jqv,irowv,neqv,nzlv,nmethod,ikmpc,ilmpc,ikboun, - & ilboun,vold,nzsv,dtime,v,theta2,iexplicit,nea,neb,mi) -! -! filling the rhs b of the velocity equations (step 3) -! - implicit none -! - character*8 lakon(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & icolv(*),jqv(*),ikmpc(*),ilmpc(*),ikboun(*),ilboun(*), - & nactdoh(0:4,*),konl(20),irowv(*),ipkon(*),nea,neb,mi(2) -! - integer nk,ne,nboun,nmpc,neqv,nzlv,nmethod,nzsv,i,j,k,jj, - & id,ist,index,jdof1,idof1,iexplicit,node1,kflag,indexe,nope,i0 -! - real*8 co(3,*),xboun(*),coefmpc(*),b(*),v(0:mi(2),*),theta2, - & vold(0:mi(2),*),ff(60),dtime -! - kflag=2 - i0=0 -! - do i=1,neqv - b(i)=0.d0 - enddo -! - do i=nea,neb -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - call e_c3d_v2rhs(co,nk,konl,lakon(i), - & ff,i,nmethod,vold,v,dtime,theta2,iexplicit,mi) -! - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdoh(k,node1) -! -! distributed forces -! - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8+k - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof1=nactdoh(nodempc(2,index), - & nodempc(1,index)) - if(jdof1.ne.0) then - b(jdof1)=b(jdof1) - & -coefmpc(index)*ff(jj) - & /coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - b(jdof1)=b(jdof1)+ff(jj) -! - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mafillvlhs.f calculix-ccx-2.3/ccx_2.1/src/mafillvlhs.f --- calculix-ccx-2.1/ccx_2.1/src/mafillvlhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mafillvlhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,241 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mafillvlhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, - & nactdoh,icolv,jqv,irowv,neqv,nzlv, - & ikmpc,ilmpc,ikboun,ilboun,nzsv,adbv,aubv,nmethod) -! -! filling the stiffness matrix in spare matrix format (sm) -! - implicit none -! - character*8 lakon(*) -! - integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), - & icolv(*),jqv(*),ikmpc(*),nzsv,nmethod, - & ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20),irowv(*), - & ipkon(*) -! - integer nk,ne,nboun,nmpc,neqv,nzlv,i,j,k,l,m,jj, - & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, - & mpc1,mpc2,index1,index2,node1,node2, - & indexe,nope,i0 -! - real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbv(*),aubv(*) -! - real*8 value -! -c write(*,*) 'print nactdoh' -c do i=1,nk -c write(*,*) i,(nactdoh(j,i),j=0,4) -c enddo -! - i0=0 -! -! determining nzlv -! - nzlv=0 - do i=neqv,1,-1 - if(icolv(i).gt.0) then - nzlv=i - exit - endif - enddo -! - do i=1,neqv - adbv(i)=0.d0 - enddo - do i=1,nzsv - aubv(i)=0.d0 - enddo -! -! loop over all fluid elements -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - call e_c3d_vlhs(co,nk,konl,lakon(i),sm,i,nmethod) -! - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdoh(k,node1) -! - do ll=jj,3*nope -! - l=(ll-1)/3+1 - m=ll-3*(l-1) -! - node2=kon(indexe+l) - jdof2=nactdoh(m,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - call add_sm_fl(aubv,adbv,jqv,irowv,jdof1,jdof2, - & sm(jj,ll),jj,ll) - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*8+k - else - idof1=jdof1 - idof2=(node2-1)*8+m - endif - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - idof2=nactdoh(nodempc(2,index),nodempc(1,index)) - if(idof2.ne.0) then - value=-coefmpc(index)*sm(jj,ll)/ - & coefmpc(ist) - if(idof1.eq.idof2) value=2.d0*value - call add_sm_fl(aubv,adbv,jqv,irowv, - & idof1,idof2,value,i0,i0) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif - else - idof1=(node1-1)*8+k - idof2=(node2-1)*8+m - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - idof1=nactdoh(nodempc(2,index1), - & nodempc(1,index1)) - index2=index1 - do - idof2=nactdoh(nodempc(2,index2), - & nodempc(1,index2)) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) - call add_sm_fl(aubv,adbv,jqv, - & irowv,idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - idof1=nactdoh(nodempc(2,index1), - & nodempc(1,index1)) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - idof2=nactdoh(nodempc(2,index2), - & nodempc(1,index2)) - if((idof1.ne.0).and.(idof2.ne.0)) then - value=coefmpc(index1)*coefmpc(index2)* - & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) - if(idof1.eq.idof2) value=2.d0*value - call add_sm_fl(aubv,adbv,jqv, - & irowv,idof1,idof2,value,i0,i0) - endif -! - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif - endif - endif - enddo - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/Makefile calculix-ccx-2.3/ccx_2.1/src/Makefile --- calculix-ccx-2.1/ccx_2.1/src/Makefile 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ - -CFLAGS = -Wall -O -I ../../../SPOOLES.2.2 -DARCH="Linux" -DSPOOLES -DARPACK -DMATRIXSTORAGE -FFLAGS = -Wall -O -fopenmp - -CC=cc -FC=gfortran - -.c.o : - $(CC) $(CFLAGS) -c $< -.f.o : - $(FC) $(FFLAGS) -c $< - -include Makefile.inc - -SCCXMAIN = ccx_2.1.c - -OCCXF = $(SCCXF:.f=.o) -OCCXC = $(SCCXC:.c=.o) -OCCXMAIN = $(SCCXMAIN:.c=.o) - -DIR=../../../SPOOLES.2.2 - -LIBS = \ - $(DIR)/spooles.a \ - ../../../ARPACK/libarpack_INTEL.a \ - -lm -lc - -ccx_2.1: $(OCCXMAIN) ccx_2.1.a $(LIBS) - ./date.pl; $(CC) $(CFLAGS) -c ccx_2.1.c; $(FC) -Wall -O -o $@ $(OCCXMAIN) ccx_2.1.a -lpthread $(LIBS) - -ccx_2.1.a: $(OCCXF) $(OCCXC) - ar vr $@ $? - diff -Nru calculix-ccx-2.1/ccx_2.1/src/Makefile.inc calculix-ccx-2.3/ccx_2.1/src/Makefile.inc --- calculix-ccx-2.1/ccx_2.1/src/Makefile.inc 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/Makefile.inc 1970-01-01 00:00:00.000000000 +0000 @@ -1,516 +0,0 @@ -SCCXF = \ -absolute_relative.f \ -add_bo_st.f \ -add_pr.f \ -add_sm_ei.f \ -add_sm_fl.f \ -add_sm_st.f \ -add_sm_st_as.f \ -addimd.f \ -addimdnodedof.f \ -allocation.f \ -allocont.f \ -amplitudes.f \ -angsum.f \ -anisonl.f \ -anisotropic.f \ -applybounk.f \ -applybounp.f \ -applybounpgas.f \ -applybount.f \ -applybounv.f \ -approxplane.f \ -attach.f \ -beamsections.f \ -bodyadd.f \ -bodyforce.f \ -bounadd.f \ -boundaries.f \ -bounrem.f \ -buckles.f \ -calinput.f \ -carbon_seal.f \ -cd_bleedtapping.f \ -cd_bragg.f \ -cd_chamfer.f \ -cd_lab_1spike.f \ -cd_lab_cdrzcdlab.f \ -cd_lab_correction.f \ -cd_lab_honeycomb.f \ -cd_lab_radius.f \ -cd_lab_reynolds.f \ -cd_lab_straight.f \ -cd_lichtarowicz.f \ -cd_Mcgreehan_Schotsch.f \ -cd_ms_ms.f \ -cd_own_albers.f \ -cd_pk_albers.f \ -cd_pk_ms.f \ -cd_preswirlnozzle.f \ -cflux.f \ -cfluxes.f \ -changedepterm.f \ -characteristic.f \ -checkarpackcs.f \ -checkslavevertex.f \ -checktime.f \ -checktriaedge.f \ -checktriavertex.f \ -chksurf.f \ -cident.f \ -cident20.f \ -cloads.f \ -closefile.f \ -compdt.f \ -conductivities.f \ -contactdampings.f \ -contactpairs.f \ -contactprints.f \ -controlss.f \ -couptempdisps.f \ -cp_corrected.f \ -createbdentry.f \ -createddentry.f \ -createmddof.f \ -creep.f \ -creeps.f \ -cubtri.f \ -cychards.f \ -cycsymmods.f \ -dashdamp.f \ -dashforc.f \ -dashpots.f \ -datest.f \ -ddeabm.f \ -ddebdf.f \ -dderkf.f \ -defplasticities.f \ -defplas.f \ -densities.f \ -depvars.f \ -deuldlag.f \ -dflux.f \ -dfluxes.f \ -dgesv.f \ -diamtr.f \ -distattach.f \ -distributedcouplings.f \ -dKdm.f \ -dKdp.f \ -dKdt.f \ -dKdX.f \ -dload.f \ -dloads.f \ -dot.f \ -dqag.f \ -dredu.f \ -drfftf.f \ -dsort.f \ -dsptri.f \ -dualshape4q.f \ -dualshape8q.f \ -dualshape3tri.f \ -dualshape6tri.f \ -dynamics.f \ -dynamic_viscosity.f \ -dynamic_viscosity_oil.f \ -dynresults.f \ -elastics.f \ -elements.f \ -elprints.f \ -enthalpy.f \ -envtemp.f \ -equationcheck.f \ -equations.f \ -estimator.f \ -expansions.f \ -extrapolate.f \ -e_c3d.f \ -e_c3d_krhs.f \ -e_c3d_plhs.f \ -e_c3d_prhs.f \ -e_c3d_rhs.f \ -e_c3d_rhs_th.f \ -e_c3d_th.f \ -e_c3d_tlhs.f \ -e_c3d_trhs.f \ -e_c3d_vlhs.f \ -e_c3d_v1rhs.f \ -e_c3d_v2rhs.f \ -e_damp.f \ -faceprints.f \ -fcrit.f \ -fillknotmpc.f \ -film.f \ -films.f \ -finpro.f \ -flowoutput.f \ -flowresult.f \ -fluidconstants.f \ -fluidextrapolate.f \ -fluidsections.f \ -flux.f \ -forcadd.f \ -frd.f \ -frdfluid.f \ -frdheader.f \ -frdscalar.f \ -frdset.f \ -frdtensor.f \ -frdvector.f \ -frdvectorcomp.f \ -frequencies.f \ -friction_coefficient.f \ -frictions.f \ -fridaforc.f \ -fsub.f \ -fsuper.f \ -gaps.f \ -gasmechbc.f \ -gaspipe.f \ -gaspipe_fanno.f \ -gen3dboun.f \ -gen3dconnect.f \ -gen3delem.f \ -gen3dforc.f \ -gen3dfrom1d.f \ -gen3dfrom2d.f \ -gen3dmpc.f \ -gen3dnor.f \ -gen3dprop.f \ -gen3dsurf.f \ -gen3dtemp.f \ -gencontelem.f \ -gencontrel.f \ -generatecycmpcs.f \ -genislavactdof.f \ -genran.f \ -gentiedmpc.f \ -getnewline.f \ -graph.f \ -headings.f \ -heattransfers.f \ -hybsvd.f \ -hyperelastics.f \ -hyperfoams.f \ -ident.f \ -ident2.f \ -identamta.f \ -identifytiedface.f \ -includefilename.f \ -incplas.f \ -initialcfd.f \ -initialconditions.f \ -initialgas.f \ -inputerror.f \ -inputinfo.f \ -inputwarning.f \ -interpol_alfa2.f \ -isorti.f \ -isortic.f \ -isortid.f \ -isortiddc1.f \ -isortiddc2.f \ -isortii.f \ -isortiid.f \ -keystart.f \ -knotmpc.f \ -label.f \ -labyrinth.f \ -lab_straight_ppkrit.f \ -limit_case_calc.f \ -linel.f \ -linkdissimilar.f \ -lintemp.f \ -lintemp_th.f \ -liquidchannel.f \ -liquidpipe.f \ -liquidpump.f \ -loadadd.f \ -loadaddp.f \ -loadaddt.f \ -lump.f \ -mafillgas.f \ -mafilldm.f \ -mafillklhs.f \ -mafillkrhs.f \ -mafillplhs.f \ -mafillprhs.f \ -mafillsm.f \ -mafillsmcs.f \ -mafillsmas.f \ -mafilltlhs.f \ -mafilltrhs.f \ -mafillvlhs.f \ -mafillv1rhs.f \ -mafillv2rhs.f \ -map3dto1d2d.f \ -materialdata_cond.f \ -materialdata_cp.f \ -materialdata_cp_sec.f \ -materialdata_dvi.f \ -materialdata_me.f \ -materialdata_rho.f \ -materialdata_sp.f \ -materialdata_tg.f \ -materialdata_th.f \ -materials.f \ -mechmodel.f \ -modaldampings.f \ -modaldynamics.f \ -moehring.f \ -mpcrem.f \ -mpcs.f \ -mult.f \ -multistages.f \ -nident.f \ -nident2.f \ -nidentk.f \ -near2d.f \ -near3d.f \ -neartriangle.f \ -neartriangle2.f \ -newton.f \ -noanalysis.f \ -nodalthicknesses.f \ -nodeprints.f \ -nodes.f \ -nodestiedface.f \ -noelfiles.f \ -noelsets.f \ -nonlinmpc.f \ -normals.f \ -norshell6.f \ -norshell8.f \ -number.f \ -onedint.f \ -onf.f \ -op.f \ -opcs.f \ -openfile.f \ -opnonsym.f \ -opnonsymt.f \ -orientations.f \ -orifice.f \ -orthonl.f \ -orthotropic.f \ -out.f \ -parser.f \ -patch.f \ -physicalconstants.f \ -pk_cdc_cl1.f \ -pk_cdc_cl3.f \ -pk_cdc_cl3a.f \ -pk_cdc_cl3b.f \ -pk_cdc_cl3d.f \ -pk_cdi_noz.f \ -pk_cdi_r.f \ -pk_cdi_rl.f \ -pk_cdi_se.f \ -pk_y0_yg.f \ -planempc.f \ -plane3.f \ -plane4.f \ -plastics.f \ -plcopy.f \ -plinterpol.f \ -plmix.f \ -polynom.f \ -precfd.f \ -presgradient.f \ -pretensionsections.f \ -printout.f \ -printoutelem.f \ -printoutface.f \ -printoutint.f \ -printoutnode.f \ -profil.f \ -pt2_lim_calc.f \ -pt2zpt1_crit.f \ -radiate.f \ -radiates.f \ -radmatrix.f \ -radresult.f \ -ranewr.f \ -rearrange.f \ -rectcyl.f \ -rectcylvi.f \ -renumber.f \ -restartread.f \ -restarts.f \ -restartshort.f \ -restartwrite.f \ -restrictor.f \ -resultgas.f \ -results.f \ -resultsk.f \ -resultsp.f \ -resultst.f \ -resultsv1.f \ -resultsv2.f \ -rhs.f \ -rigidbodies.f \ -rigidmpc.f \ -rimseal.f \ -rimseal_calc.f \ -rootls.f \ -rs.f \ -rubber.f \ -saxpb.f \ -scavenge_pump.f \ -sdvini.f \ -selcycsymmods.f \ -shape3tri.f \ -shape4q.f \ -shape4tet.f \ -shape6tri.f \ -shape6w.f \ -shape8h.f \ -shape8q.f \ -shape10tet.f \ -shape15w.f \ -shape20h.f \ -shape20h_ax.f \ -shape20h_pl.f \ -shellsections.f \ -sigini.f \ -skip.f \ -smooth.f \ -smoothshock.f \ -solidsections.f \ -solveeq.f \ -spcmatch.f \ -specificgasconstants.f \ -specificheats.f \ -splitline.f \ -springs.f \ -springforc.f \ -springstiff.f \ -statics.f \ -steadystatedynamics.f \ -steps.f \ -stiff2mat.f \ -stop.f \ -storeresidual.f \ -str2mat.f \ -straighteq2d.f \ -straighteq3d.f \ -straightmpc.f \ -subspace.f \ -surfacebehaviors.f \ -surfaceinteractions.f \ -surfaces.f \ -temperatures.f \ -tempload.f \ -temploaddiff.f \ -temploadmodal.f \ -thermmodel.f \ -tiefaccont.f \ -ties.f \ -timepointss.f \ -transformatrix.f \ -transforms.f \ -treattriangle.f \ -trianeighbor.f \ -triangucont.f \ -triangulate.f \ -ts_calc.f \ -twodint.f \ -two_phase_flow.f \ -uamplitude.f \ -uboun.f \ -ucreep.f \ -ufaceload.f \ -uhardening.f \ -umat.f \ -umatht.f \ -umat_abaqus.f \ -umat_abaqusnl.f \ -umat_aniso_creep.f \ -umat_aniso_plas.f \ -umat_elastic_fiber.f \ -umat_gurson.f \ -umat_iso_creep.f \ -umat_lin_iso_el.f \ -umat_main.f \ -umat_single_crystal.f \ -umat_user.f \ -umpc_dist.f \ -umpc_gap.f \ -umpc_mean_rot.f \ -umpc_user.f \ -uncouptempdisps.f \ -uout.f \ -updatecfd.f \ -updatecont.f \ -usermaterials.f \ -usermpc.f \ -utemp.f \ -valuesatinf.f \ -viewfactors.f \ -viscos.f \ -vortex.f \ -wcoef.f \ -writeboun.f \ -writebv.f \ -writeev.f \ -writeevcs.f \ -writehe.f \ -writeim.f \ -writeinput.f \ -writematrix.f \ -writempc.f \ -writepf.f \ -writere.f \ -writesummary.f \ -zeta_calc.f - -SCCXC = \ -arpack.c \ -arpackbu.c \ -arpackcs.c \ -bdfill.c \ -calcresidual.c \ -cascade.c \ -checkconvergence.c \ -checkconvgas.c \ -checkinclength.c \ -compfluid.c \ -contact.c \ -contactmortar.c \ -contactstress.c \ -dfdbj.c \ -dyna.c \ -dynacont.c \ -dynboun.c \ -expand.c \ -frdcyc.c \ -gencontmpc.c \ -inicont.c \ -insert.c \ -insertas.c \ -mastruct.c \ -mastructcs.c \ -mastructf.c \ -matrixstorage.c \ -multimortar.c \ -nonlingeo.c \ -pardiso.c \ -pcgsolver.c \ -prediction.c \ -preiter.c \ -prespooles.c \ -radcyc.c \ -radflowload.c \ -readinput.c \ -remastruct.c \ -remcontmpc.c \ -sgi.c \ -spooles.c \ -steadystate.c \ -storecontactdof.c \ -strcmp1.c \ -strcpy1.c \ -tau.c \ -tiedcontact.c \ -u_calloc.c diff -Nru calculix-ccx-2.1/ccx_2.1/src/Makefile_MT calculix-ccx-2.3/ccx_2.1/src/Makefile_MT --- calculix-ccx-2.1/ccx_2.1/src/Makefile_MT 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/Makefile_MT 1970-01-01 00:00:00.000000000 +0000 @@ -1,34 +0,0 @@ - -CFLAGS = -Wall -O3 -I ../../../SPOOLES.2.2 -DARCH="Linux" -DSPOOLES -DARPACK -DMATRIXSTORAGE -DUSE_MT=1 -FFLAGS = -Wall -O3 - -CC=cc -FC=gfortran - -.c.o : - $(CC) $(CFLAGS) -c $< -.f.o : - $(FC) $(FFLAGS) -c $< - -include Makefile.inc - -SCCXMAIN = ccx_2.1.c - -OCCXF = $(SCCXF:.f=.o) -OCCXC = $(SCCXC:.c=.o) -OCCXMAIN = $(SCCXMAIN:.c=.o) - -DIR=../../../SPOOLES.2.2 - -LIBS = \ - $(DIR)/MT/src/spoolesMT.a \ - $(DIR)/spooles.a \ - ../../../ARPACK/libarpack_INTEL.a \ - -lpthread -lm - -ccx_2.1_MT: $(OCCXMAIN) ccx_2.1_MT.a $(LIBS) - ./date.pl; $(CC) $(CFLAGS) -c ccx_2.1.c; $(FC) -Wall -O3 -o $@ $(OCCXMAIN) ccx_2.1_MT.a $(LIBS) - -ccx_2.1_MT.a: $(OCCXF) $(OCCXC) - ar vr $@ $? - diff -Nru calculix-ccx-2.1/ccx_2.1/src/map3dto1d2d.f calculix-ccx-2.3/ccx_2.1/src/map3dto1d2d.f --- calculix-ccx-2.1/ccx_2.1/src/map3dto1d2d.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/map3dto1d2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,498 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine map3dto1d2d(yn,ipkon,inum,kon,lakon,nfield,nk, - & ne,cflag,co,vold,force,mi) -! -! interpolates 3d field nodal values to 1d/2d nodal locations -! -! the number of internal state variables is limited to 999 -! (cfr. array field) -! - implicit none -! - logical force -! - character*1 cflag - character*8 lakon(*),lakonl -! - integer ipkon(*),inum(*),kon(*),ne,indexe,nfield,nk,i,j,k,l,m, - & node3(8,3),node6(3,6),node8(3,8),node2d,node3d,indexe2d,ne1d2d, - & node3m(8,3),node(8),m1,m2,nodea,nodeb,nodec,iflag,mi(2) -! - real*8 yn(nfield,*),cg(3),p(3),pcg(3),t(3),xl(3,8),shp(7,8), - & xsj(3),e1(3),e2(3),e3(3),s(6),dd,xi,et,co(3,*),xs(3,7), - & vold(0:mi(2),*),ratioe(3) -! - include "gauss.f" -! -c data node3 /1,4,8,5,9,11,15,13,2,3,7,6/ - data node3 /1,4,8,5,12,20,16,17,9,11,15,13, - & 0,0,0,0,2,3,7,6,10,19,14,18/ - data node3m /1,5,8,4,17,16,20,12, - & 0,0,0,0,0,0,0,0, - & 3,7,6,2,19,14,18,10/ -c data node6 /1,4,2,5,3,6,7,10,8,11,9,12/ -c data node8 /1,5,2,6,3,7,4,8,9,13,10,14,11,15,12,16/ - data node6 /1,13,4,2,14,5,3,15,6,7,0,10,8,0,11,9,0,12/ - data node8 /1,17,5,2,18,6,3,19,7,4,20,8,9,0,13,10,0,14, - & 11,0,15,12,0,16/ - data ratioe /0.16666666666667d0,0.66666666666666d0, - & 0.16666666666667d0/ - data iflag /2/ -! -! removing any results in 1d/2d nodes -! - ne1d2d=0 -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - lakonl=lakon(i) - if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'G').or. - & (lakonl(1:1).ne.'C')) cycle - ne1d2d=1 - indexe=ipkon(i) -! -! inactivating the 3d expansion nodes of 1d/2d elements -! - do j=1,20 - inum(kon(indexe+j))=0 - enddo -! - if(lakonl(4:5).eq.'15') then - indexe2d=indexe+15 - do j=1,6 - node2d=kon(indexe2d+j) - inum(node2d)=0 - do k=1,nfield - yn(k,node2d)=0.d0 - enddo - enddo - elseif(lakonl(7:7).eq.'B') then - indexe2d=indexe+20 - do j=1,3 - node2d=kon(indexe2d+j) - inum(node2d)=0 - do k=1,nfield - yn(k,node2d)=0.d0 - enddo - enddo - else - indexe2d=indexe+20 - do j=1,8 - node2d=kon(indexe2d+j) - inum(node2d)=0 - do k=1,nfield - yn(k,node2d)=0.d0 - enddo - enddo - endif -! - enddo -! -! if no 1d/2d elements return -! - if(ne1d2d.eq.0) return -! -! interpolation of 3d results on 1d/2d nodes -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - lakonl=lakon(i) - if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'G').or. - & (lakonl(1:1).ne.'C')) cycle - indexe=ipkon(i) -! - if(lakonl(4:5).eq.'15') then - indexe2d=indexe+15 - do j=1,6 - node2d=kon(indexe2d+j) -c do l=1,2 -c inum(node2d)=inum(node2d)-1 -c node3d=kon(indexe+node6(l,j)) -c do k=1,nfield -c yn(k,node2d)=yn(k,node2d)+yn(k,node3d) -c enddo -c enddo - inum(node2d)=inum(node2d)-1 - if(.not.force) then -! -! taking the mean across the thickness -! - if(j.le.3) then -! -! end nodes: weights 1/6,2/3 and 1/6 -! - do l=1,3 - node3d=kon(indexe+node6(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+ - & yn(k,node3d)*ratioe(l) - enddo - enddo - else -! -! middle nodes: weights 1/2,1/2 -! - do l=1,3,2 - node3d=kon(indexe+node6(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+yn(k,node3d)/2.d0 - enddo - enddo - endif - else -! -! forces must be summed -! - if(j.le.3) then -! -! end nodes -! - do l=1,3 - node3d=kon(indexe+node6(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+yn(k,node3d) - enddo - enddo - else -! -! middle nodes -! - do l=1,3,2 - node3d=kon(indexe+node6(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+yn(k,node3d) - enddo - enddo - endif - endif - enddo - elseif(lakonl(7:7).eq.'B') then - indexe2d=indexe+20 - if(cflag.ne.'M') then -! -! mean values for beam elements -! - do j=1,3 - node2d=kon(indexe2d+j) - if(.not.force) then -! -! mean value of vertex values -! - do l=1,4 - inum(node2d)=inum(node2d)-1 - node3d=kon(indexe+node3(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+yn(k,node3d) - enddo - enddo - else -! -! forces must be summed across the section -! - inum(node2d)=inum(node2d)-1 - if(j.ne.2) then - do l=1,8 - node3d=kon(indexe+node3(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+yn(k,node3d) - enddo - enddo - else - do l=1,4 - node3d=kon(indexe+node3(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+yn(k,node3d) - enddo - enddo - endif - endif - enddo - else -! -! section forces for beam elements -! - do j=1,3,2 - node2d=kon(indexe2d+j) - inum(node2d)=inum(node2d)-1 -! -! coordinates of the nodes belonging to the section -! - do l=1,8 - node(l)=kon(indexe+node3m(l,j)) - do m=1,3 -c xl(m,l)=co(m,node(l)) - xl(m,l)=co(m,node(l))+vold(m,node(l)) -c write(*,*) 'i,j,l ',i,j,l,co(m,node(l)), -c & vold(m,node(l)),node(l) - enddo - enddo -! -! center of gravity and unit vectors 1 and 2 -! - do m=1,3 - cg(m)=(xl(m,6)+xl(m,8))/2.d0 - if(j.eq.1) then - e1(m)=(xl(m,8)-xl(m,6)) - else - e1(m)=(xl(m,6)-xl(m,8)) - endif - e2(m)=(xl(m,7)-xl(m,5)) - enddo -! -! normalizing e1 -! - dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3)) - do m=1,3 - e1(m)=e1(m)/dd - enddo -! -! making sure that e2 is orthogonal to e1 -! - dd=e1(1)*e2(1)+e1(2)*e2(2)+e1(3)*e2(3) - do m=1,3 - e2(m)=e2(m)-dd*e1(m) - enddo -! -! normalizing e2 -! - dd=dsqrt(e2(1)*e2(1)+e2(2)*e2(2)+e2(3)*e2(3)) - do m=1,3 - e2(m)=e2(m)/dd - enddo -! -! e3 = e1 x e2 for j=3, e3 = e2 x e1 for j=1 -! - if(j.eq.1) then - e3(1)=e2(2)*e1(3)-e1(2)*e2(3) - e3(2)=e2(3)*e1(1)-e1(3)*e2(1) - e3(3)=e2(1)*e1(2)-e1(1)*e2(2) - else - e3(1)=e1(2)*e2(3)-e2(2)*e1(3) - e3(2)=e1(3)*e2(1)-e2(3)*e1(1) - e3(3)=e1(1)*e2(2)-e2(1)*e1(2) - endif -! -c write(*,*) i,j,e3(1),e3(2),e3(3) -! -! loop over the integration points (2x2) -! - do l=1,4 -c do l=1,9 - xi=gauss2d2(1,l) - et=gauss2d2(2,l) -c xi=gauss2d3(1,l) -c et=gauss2d3(2,l) - call shape8q(xi,et,xl,xsj,xs,shp,iflag) -c! -c! local unit normal (only once per section) -c! -c if(l.eq.1) then -c dd=dsqrt(xsj(1)*xsj(1)+xsj(2)*xsj(2)+ -c & xsj(3)*xsj(3)) -c if(j.eq.1) then -c do m=1,3 -c e3(m)=-xsj(m)/dd -c enddo -c else -cc do m=1,3 -cc e3(m)=xsj(m)/dd -cc enddo -c endif -c endif -! -! local stress tensor -! - do m1=1,6 - s(m1)=0.d0 - do m2=1,8 - s(m1)=s(m1)+shp(4,m2)*yn(m1,node(m2)) - enddo - enddo -! -! local coordinates -! - do m1=1,3 - p(m1)=0.d0 - do m2=1,8 - p(m1)=p(m1)+shp(4,m2)*xl(m1,m2) - enddo - pcg(m1)=p(m1)-cg(m1) - enddo -! -! local stress vector on section -! - t(1)=s(1)*xsj(1)+s(4)*xsj(2)+s(5)*xsj(3) - t(2)=s(4)*xsj(1)+s(2)*xsj(2)+s(6)*xsj(3) - t(3)=s(5)*xsj(1)+s(6)*xsj(2)+s(3)*xsj(3) -! -! section forces -! - yn(1,node2d)=yn(1,node2d)+ - & (e1(1)*t(1)+e1(2)*t(2)+e1(3)*t(3)) -c & *weight2d3(l) - yn(2,node2d)=yn(2,node2d)+ - & (e2(1)*t(1)+e2(2)*t(2)+e2(3)*t(3)) -c & *weight2d3(l) - yn(3,node2d)=yn(3,node2d)+ - & (e3(1)*t(1)+e3(2)*t(2)+e3(3)*t(3)) -c & *weight2d3(l) -! -! section moments -! -! about beam axis -! - yn(4,node2d)=yn(4,node2d)+ - & (e3(1)*pcg(2)*t(3)+e3(2)*pcg(3)*t(1)+ - & e3(3)*pcg(1)*t(2)-e3(3)*pcg(2)*t(1)- - & e3(1)*pcg(3)*t(2)-e3(2)*pcg(1)*t(3)) -c & *weight2d3(l) -! -! about 2-direction -! - yn(5,node2d)=yn(5,node2d)+ - & (e2(1)*pcg(2)*t(3)+e2(2)*pcg(3)*t(1)+ - & e2(3)*pcg(1)*t(2)-e2(3)*pcg(2)*t(1)- - & e2(1)*pcg(3)*t(2)-e2(2)*pcg(1)*t(3)) -c & *weight2d3(l) -! -! about 1-direction -! - yn(6,node2d)=yn(6,node2d)+ - & (e1(1)*pcg(2)*t(3)+e1(2)*pcg(3)*t(1)+ - & e1(3)*pcg(1)*t(2)-e1(3)*pcg(2)*t(1)- - & e1(1)*pcg(3)*t(2)-e1(2)*pcg(1)*t(3)) -c & *weight2d3(l) -! -! components 5 and 6 are switched in the frd -! format, so the final order is beam axis, -! 1-direction and 2-direction, or s12, s23 and s31 -! - enddo - enddo -! - endif - else - indexe2d=indexe+20 - do j=1,8 - node2d=kon(indexe2d+j) - inum(node2d)=inum(node2d)-1 - if(.not.force) then -! -! taking the mean across the thickness -! - if(j.le.4) then -! -! end nodes: weights 1/6,2/3 and 1/6 -! - do l=1,3 - node3d=kon(indexe+node8(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+ - & yn(k,node3d)*ratioe(l) - enddo - enddo - else -! -! middle nodes: weights 1/2,1/2 -! - do l=1,3,2 - node3d=kon(indexe+node8(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+yn(k,node3d)/2.d0 - enddo - enddo - endif - else -! -! forces must be summed -! - if(j.le.4) then -! -! end nodes -! - do l=1,3 - node3d=kon(indexe+node8(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+yn(k,node3d) - enddo - enddo - else -! -! middle nodes -! - do l=1,3,2 - node3d=kon(indexe+node8(l,j)) - do k=1,nfield - yn(k,node2d)=yn(k,node2d)+yn(k,node3d) - enddo - enddo - endif - endif - enddo - endif -! - enddo -! -! taking the mean of nodal contributions coming from different -! elements having the node in common -! - do i=1,nk - if(inum(i).lt.0) then - inum(i)=-inum(i) - do j=1,nfield - yn(j,i)=yn(j,i)/inum(i) - enddo - endif - enddo -! -! beam section forces in the middle nodes -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - lakonl=lakon(i) - if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'G').or. - & (lakonl(1:1).ne.'C')) cycle - indexe=ipkon(i) -! - if(lakonl(7:7).eq.'B') then - indexe2d=indexe+20 - if(cflag.eq.'M') then -! -! section forces in the middle node are the mean -! of those in the end nodes -! - nodea=kon(indexe2d+1) - nodeb=kon(indexe2d+2) - nodec=kon(indexe2d+3) - inum(nodeb)=1 - do j=1,6 - yn(j,nodeb)=yn(j,nodeb)+(yn(j,nodea)+yn(j,nodec))/2.d0 - enddo -! - endif - endif -! - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/mastruct.c calculix-ccx-2.3/ccx_2.1/src/mastruct.c --- calculix-ccx-2.1/ccx_2.1/src/mastruct.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mastruct.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1031 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -#define min(a,b) ((a) <= (b) ? (a) : (b)) -#define max(a,b) ((a) >= (b) ? (a) : (b)) - -void mastruct(int *nk, int *kon, int *ipkon, char *lakon, int *ne, - int *nodeboun, int *ndirboun, int *nboun, int *ipompc, - int *nodempc, int *nmpc, int *nactdof, int *icol, - int *jq, int **mast1p, int **irowp, int *isolver, int *neq, - int *nnn, int *ikmpc, int *ilmpc,int *ipointer, int *nzs, - int *nmethod,int *ithermal, int *ikboun, int *ilboun, - int *iperturb, int *mi){ - - char lakonl[2]=" \0"; - - int i,j,k,l,jj,ll,id,index,jdof1,jdof2,idof1,idof2,mpc1,mpc2,id1,id2, - ist1,ist2,node1,node2,isubtract,nmast,ifree,istart,istartold, - index1,index2,m,node,nzs_,ist,kflag,indexe,nope,isize,*mast1=NULL, - *irow=NULL,icolumn,nmastboun,fluid=0,mt=mi[1]+1,jmax; - - /* the indices in the comments follow FORTRAN convention, i.e. the - fields start with 1 */ - - mast1=*mast1p; - irow=*irowp; - - kflag=2; - nzs_=nzs[1]; - - /* initialisation of nactmpc */ - - for(i=0;i=3)){ - for(i=0;i<*ne;++i){ - - if(ipkon[i]<0) continue; - if(strcmp1(&lakon[8*i],"F")==0){ - fluid=1; - continue; - } - indexe=ipkon[i]; - if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; - else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; - else if (strcmp1(&lakon[8*i],"E")==0){ - lakonl[0]=lakon[8*i+7]; - nope=atoi(lakonl);} - else continue; - - for(j=0;j1){ - for(i=0;i<*ne;++i){ - - if(ipkon[i]<0) continue; - if(strcmp1(&lakon[8*i],"F")==0)continue; - indexe=ipkon[i]; - if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; - else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; - else continue; - - for(j=0;j3){continue;} - nactdof[mt*(nodeboun[i]-1)+ndirboun[i]]=0; - } - - for(i=0;i<*nmpc;++i){ - index=ipompc[i]-1; - if(nodempc[3*index+1]>3) continue; - nactdof[mt*(nodempc[3*index]-1)+nodempc[3*index+1]]=0; - } - - /* numbering the active degrees of freedom */ - - neq[0]=0; - jmax=4;if(mi[1]+1<4){jmax=mi[1]+1;} - for(i=0;i<*nk;++i){ - for(j=1;j=3)){ - ++neq[0]; - nactdof[mt*(nnn[i]-1)+j]=neq[0]; - } - else{ - nactdof[mt*(nnn[i]-1)+j]=0; - } - } - } - } - neq[1]=neq[0]; - for(i=0;i<*nk;++i){ - if(nactdof[mt*(nnn[i]-1)]!=0){ - if(*ithermal>1){ - ++neq[1]; - nactdof[mt*(nnn[i]-1)]=neq[1]; - } - else{ - nactdof[mt*(nnn[i]-1)]=0; - } - } - } - if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ - neq[2]=neq[1]+*nboun; - } - else{neq[2]=neq[1];} - - ifree=0; - /* for(i=0;i<4**nk;++i){printf("nactdof=%d,%d,%d\n",i/4+1,i-(i/4)*4,nactdof[i]);}*/ - - /* determining the position of each nonzero matrix element - - mast1(ipointer(i)) = first nonzero row in column i - irow(ipointer(i)) points to further nonzero elements in - column i */ - - for(i=0;i<4**nk;++i){ipointer[i]=0;} - - /* mechanical entries */ - - if((*ithermal<2)||(*ithermal>=3)){ - - for(i=0;i<*ne;++i){ - - if(ipkon[i]<0) continue; - if(strcmp1(&lakon[8*i],"F")==0)continue; - indexe=ipkon[i]; - if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; - else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; - else if (strcmp1(&lakon[8*i],"E")==0){ - lakonl[0]=lakon[8*i+7]; - nope=atoi(lakonl);} - else continue; - - for(jj=0;jj<3*nope;++jj){ - - j=jj/3; - k=jj-3*j; - - node1=kon[indexe+j]; - jdof1=nactdof[mt*(node1-1)+k+1]; - - for(ll=jj;ll<3*nope;++ll){ - - l=ll/3; - m=ll-3*l; - - node2=kon[indexe+l]; - jdof2=nactdof[mt*(node2-1)+m+1]; - - /* check whether one of the DOF belongs to a SPC or MPC */ - - if((jdof1!=0)&&(jdof2!=0)){ - insert(ipointer,&mast1,&irow,&jdof1,&jdof2,&ifree,&nzs_); - } - else if((jdof1!=0)||(jdof2!=0)){ - - /* idof1: genuine DOF - idof2: nominal DOF of the SPC/MPC */ - - if(jdof1==0){ - idof1=jdof2; - idof2=8*node1+k-7;} - else{ - idof1=jdof1; - idof2=8*node2+m-7;} - - if(*nmpc>0){ - - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); - if((id>0)&&(ikmpc[id-1]==idof2)){ - - /* regular DOF / MPC */ - - id=ilmpc[id-1]; - ist=ipompc[id-1]; - index=nodempc[3*ist-1]; - if(index==0) continue; - while(1){ -// idof2=nactdof[mt*nodempc[3*index-3]+nodempc[3*index-2]-4]; - idof2=nactdof[mt*(nodempc[3*index-3]-1)+nodempc[3*index-2]]; - if(idof2!=0){ - insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); - } - index=nodempc[3*index-1]; - if(index==0) break; - } - continue; - } - } - - /* boundary stiffness coefficients (for frequency - and modal dynamic calculations) */ - - if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ - FORTRAN(nident,(ikboun,&idof2,nboun,&id)); - icolumn=neq[1]+ilboun[id-1]; - /* printf("idof1=%d,icolumn=%d\n",idof1,icolumn);*/ - insert(ipointer,&mast1,&irow,&idof1,&icolumn,&ifree,&nzs_); - } - - } - - else{ - idof1=8*node1+k-7; - idof2=8*node2+m-7; - mpc1=0; - mpc2=0; - if(*nmpc>0){ - FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); - if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); - if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; - } - if((mpc1==1)&&(mpc2==1)){ - id1=ilmpc[id1-1]; - id2=ilmpc[id2-1]; - if(id1==id2){ - - /* MPC id1 / MPC id1 */ - - ist=ipompc[id1-1]; - index1=nodempc[3*ist-1]; - if(index1==0) continue; - while(1){ -// idof1=nactdof[mt*nodempc[3*index1-3]+nodempc[3*index1-2]-4]; - idof1=nactdof[mt*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; - index2=index1; - while(1){ -// idof2=nactdof[mt*nodempc[3*index2-3]+nodempc[3*index2-2]-4]; - idof2=nactdof[mt*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - - else{ - - /* MPC id1 /MPC id2 */ - - ist1=ipompc[id1-1]; - index1=nodempc[3*ist1-1]; - if(index1==0) continue; - while(1){ -// idof1=nactdof[mt*nodempc[3*index1-3]+nodempc[3*index1-2]-4]; - idof1=nactdof[mt*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; - ist2=ipompc[id2-1]; - index2=nodempc[3*ist2-1]; - if(index2==0){ - index1=nodempc[3*index1-1]; - if(index1==0){break;} - else{continue;} - } - while(1){ -// idof2=nactdof[mt*nodempc[3*index2-3]+nodempc[3*index2-2]-4]; - idof2=nactdof[mt*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - } - } - } - } - } - - } - - /* nzs[0]=ifree-neq[0];*/ - /* printf("\nneq[0]=%d,nzs[0]=%d\n\n",neq[0],nzs[0]);*/ - - /* thermal entries*/ - - if(*ithermal>1){ - - for(i=0;i<*ne;++i){ - - if(ipkon[i]<0) continue; - if(strcmp1(&lakon[8*i],"F")==0)continue; - indexe=ipkon[i]; - if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; - else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; - else continue; - - for(jj=0;jj0){ - - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); - if((id>0)&&(ikmpc[id-1]==idof2)){ - - /* regular DOF / MPC */ - - id=ilmpc[id-1]; - ist=ipompc[id-1]; - index=nodempc[3*ist-1]; - if(index==0) continue; - while(1){ -// idof2=nactdof[mt*nodempc[3*index-3]+nodempc[3*index-2]-4]; - idof2=nactdof[mt*(nodempc[3*index-3]-1)+nodempc[3*index-2]]; - if(idof2!=0){ - insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); - } - index=nodempc[3*index-1]; - if(index==0) break; - } - continue; - } - } - - /* boundary stiffness coefficients (for frequency and - modal dynamic calculations */ - - if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ - FORTRAN(nident,(ikboun,&idof2,nboun,&id)); - icolumn=neq[1]+ilboun[id-1]; - insert(ipointer,&mast1,&irow,&idof1,&icolumn,&ifree,&nzs_); - } - - } - - else{ - idof1=8*node1-8; - idof2=8*node2-8; - mpc1=0; - mpc2=0; - if(*nmpc>0){ - FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); - if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); - if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; - } - if((mpc1==1)&&(mpc2==1)){ - id1=ilmpc[id1-1]; - id2=ilmpc[id2-1]; - if(id1==id2){ - - /* MPC id1 / MPC id1 */ - - ist=ipompc[id1-1]; - index1=nodempc[3*ist-1]; - if(index1==0) continue; - while(1){ -// idof1=nactdof[mt*nodempc[3*index1-3]+nodempc[3*index1-2]-4]; - idof1=nactdof[mt*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; - index2=index1; - while(1){ -// idof2=nactdof[mt*nodempc[3*index2-3]+nodempc[3*index2-2]-4]; - idof2=nactdof[mt*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - - else{ - - /* MPC id1 /MPC id2 */ - - ist1=ipompc[id1-1]; - index1=nodempc[3*ist1-1]; - if(index1==0) continue; - while(1){ -// idof1=nactdof[mt*nodempc[3*index1-3]+nodempc[3*index1-2]-4]; - idof1=nactdof[mt*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; - ist2=ipompc[id2-1]; - index2=nodempc[3*ist2-1]; - if(index2==0){ - index1=nodempc[3*index1-1]; - if(index1==0){break;} - else{continue;} - } - while(1){ -// idof2=nactdof[mt*nodempc[3*index2-3]+nodempc[3*index2-2]-4]; - idof2=nactdof[mt*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - } - } - } - } - } - - } - - for(i=0;i=neq[1]) continue; - node1=0; - for(j=0;j<*nk;j++){ - for(k=0;k<4;++k){ -// if(nactdof[mt*nnn[j]+k-4]==i+1){ - if(nactdof[mt*(nnn[j]-1)+k]==i+1){ - node1=nnn[j]; - idof1=k; - break; - } - } - if(node1!=0) break; - } - printf("*ERROR in mastruct: zero column\n"); - printf(" node=%d,DOF=%d\n",node1,idof1); - FORTRAN(stop,()); - } - istart=ipointer[i]; - while(1){ - istartold=istart; - istart=irow[istart-1]; - irow[istartold-1]=i+1; - if(istart==0) break; - } - } - - /* defining icol and jq */ - - if(neq[1]==0){ - printf("\n*WARNING: no degrees of freedom in the model\n\n"); - } - - nmast=ifree; - - /* for frequency calculations and modal dynamic calculations: - sorting column after column; - determining the end of the classical stiffness matrix - in fields irow and mast1 */ - - if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ - FORTRAN(isortii,(irow,mast1,&nmast,&kflag)); - nmastboun=nmast; - FORTRAN(nident,(irow,&neq[1],&nmast,&id)); - if((id>0)&&(irow[id-1]==neq[1])) nmast=id; - } - - /* summary */ - - printf(" number of equations\n"); - printf(" %d\n",neq[1]); - printf(" number of nonzero matrix elements\n"); - printf(" %d\n",nmast); - printf("\n"); - - /* changing the meaning of icol,j1,mast1,irow: - - - irow is going to contain the row numbers of the SUBdiagonal - nonzero's, column per column - - mast1 contains the column numbers - - icol(i)=# SUBdiagonal nonzero's in column i - - jq(i)= location in field irow of the first SUBdiagonal - nonzero in column i - - */ - - /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ - - FORTRAN(isortii,(mast1,irow,&nmast,&kflag)); - - /* filtering out the diagonal elements and generating icol and jq */ - - isubtract=0; - for(i=0;i0){ - isize=jq[i+1]-jq[i]; - FORTRAN(isortii,(&irow[jq[i]-1],&mast1[jq[i]-1],&isize,&kflag)); - } - } - - if(neq[0]==0){nzs[0]=0;} - else{nzs[0]=jq[neq[0]]-1;} - nzs[1]=jq[neq[1]]-1; - - /* determining jq for the boundary stiffness matrix (only - for frequency and modal dynamic calculations */ - - if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ - for(i=neq[1];i0){ - isize=jq[i+1]-jq[i]; - FORTRAN(isortii,(&irow[jq[i]-1],&mast1[jq[i]-1],&isize,&kflag)); - } - } - nzs[2]=jq[neq[2]]-1; - } - else{nzs[2]=nzs[1];} - -/* for(i=nzs[1];i -#include -#include -#include -#include "CalculiX.h" - -#define min(a,b) ((a) <= (b) ? (a) : (b)) -#define max(a,b) ((a) >= (b) ? (a) : (b)) - -void mastructcs(int *nk, int *kon, int *ipkon, char *lakon, int *ne, - int *nodeboun, int *ndirboun, int *nboun, int *ipompc, - int *nodempc, int *nmpc, int *nactdof, int *icol, - int *jq, int **mast1p, int **irowp, int *isolver, int *neq, - int *nnn, int *ikmpc, int *ilmpc, - int *ipointer, int *nzs, int *nmethod, - int *ics, double *cs, char *labmpc, int *mcs, int *mi){ - - int i,j,k,l,jj,ll,id,index,jdof1,jdof2,idof1,idof2,mpc1,mpc2,id1,id2, - ist1,ist2,node1,node2,isubtract,nmast,ifree,istart,istartold, - index1,index2,m,node,nzs_,ist,kflag,indexe,nope,isize,*mast1=NULL, - *irow=NULL,inode,icomplex,inode1,icomplex1,inode2, - icomplex2,kdof1,kdof2,ilength,lprev,ij,mt=mi[1]+1; - - /* the indices in the comments follow FORTRAN convention, i.e. the - fields start with 1 */ - - mast1=*mast1p; - irow=*irowp; - - kflag=2; - nzs_=nzs[1]; - - /* initialisation of nactmpc */ - - for(i=0;i0){ - - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); - if((id>0)&&(ikmpc[id-1]==idof2)){ - - /* regular DOF / MPC */ - - id1=ilmpc[id-1]; - ist=ipompc[id1-1]; - index=nodempc[3*ist-1]; - if(index==0) continue; - while(1){ - inode=nodempc[3*index-3]; - icomplex=0; - if(strcmp1(&labmpc[(id1-1)*20],"CYCLIC")==0){ - icomplex=atoi(&labmpc[20*(id1-1)+6]); - } - else if(strcmp1(&labmpc[(id1-1)*20],"SUBCYCLIC")==0){ - for(ij=0;ij<*mcs;ij++){ - ilength=cs[17*ij+3]; - lprev=cs[17*ij+13]; - FORTRAN(nident,(&ics[lprev],&inode,&ilength,&id)); - if(id>0){ - if(ics[lprev+id-1]==inode){ - icomplex=ij+1; - break; - } - } - } - } -// idof2=nactdof[mt*inode+nodempc[3*index-2]-4]; - idof2=nactdof[mt*(inode-1)+nodempc[3*index-2]]; - if(idof2!=0){ - insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); - kdof1=idof1+neq[0];kdof2=idof2+neq[0]; - insert(ipointer,&mast1,&irow,&kdof1,&kdof2,&ifree,&nzs_); - if((icomplex!=0)&&(idof1!=idof2)){ - insert(ipointer,&mast1,&irow,&kdof1,&idof2,&ifree,&nzs_); - insert(ipointer,&mast1,&irow,&idof1,&kdof2,&ifree,&nzs_); - } - } - index=nodempc[3*index-1]; - if(index==0) break; - } - continue; - } - } - } - - else{ - idof1=8*node1+k-7; - idof2=8*node2+m-7; - mpc1=0; - mpc2=0; - if(*nmpc>0){ - FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); - if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); - if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; - } - if((mpc1==1)&&(mpc2==1)){ - id1=ilmpc[id1-1]; - id2=ilmpc[id2-1]; - if(id1==id2){ - - /* MPC id1 / MPC id1 */ - - ist=ipompc[id1-1]; - index1=nodempc[3*ist-1]; - if(index1==0) continue; - while(1){ - inode1=nodempc[3*index1-3]; - icomplex1=0; - if(strcmp1(&labmpc[(id1-1)*20],"CYCLIC")==0){ - icomplex1=atoi(&labmpc[20*(id1-1)+6]); - } - else if(strcmp1(&labmpc[(id1-1)*20],"SUBCYCLIC")==0){ - for(ij=0;ij<*mcs;ij++){ - ilength=cs[17*ij+3]; - lprev=cs[17*ij+13]; - FORTRAN(nident,(&ics[lprev],&inode1,&ilength,&id)); - if(id>0){ - if(ics[lprev+id-1]==inode1){ - icomplex1=ij+1; - break; - } - } - } - } -// idof1=nactdof[mt*inode1+nodempc[3*index1-2]-4]; - idof1=nactdof[mt*(inode1-1)+nodempc[3*index1-2]]; - index2=index1; - while(1){ - inode2=nodempc[3*index2-3]; - icomplex2=0; - if(strcmp1(&labmpc[(id1-1)*20],"CYCLIC")==0){ - icomplex2=atoi(&labmpc[20*(id1-1)+6]); - } - else if(strcmp1(&labmpc[(id1-1)*20],"SUBCYCLIC")==0){ - for(ij=0;ij<*mcs;ij++){ - ilength=cs[17*ij+3]; - lprev=cs[17*ij+13]; - FORTRAN(nident,(&ics[lprev],&inode2,&ilength,&id)); - if(id>0){ - if(ics[lprev+id-1]==inode2){ - icomplex2=ij+1; - break; - } - } - } - } -// idof2=nactdof[mt*inode2+nodempc[3*index2-2]-4]; - idof2=nactdof[mt*(inode2-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); - kdof1=idof1+neq[0];kdof2=idof2+neq[0]; - insert(ipointer,&mast1,&irow,&kdof1,&kdof2,&ifree,&nzs_); - if(((icomplex1!=0)||(icomplex2!=0))&& - (icomplex1!=icomplex2)){ - /* if(((icomplex1!=0)||(icomplex2!=0))&& - ((icomplex1==0)||(icomplex2==0))){*/ - insert(ipointer,&mast1,&irow,&kdof1,&idof2,&ifree,&nzs_); - insert(ipointer,&mast1,&irow,&idof1,&kdof2,&ifree,&nzs_); - } - } - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - - else{ - - /* MPC id1 /MPC id2 */ - - ist1=ipompc[id1-1]; - index1=nodempc[3*ist1-1]; - if(index1==0) continue; - while(1){ - inode1=nodempc[3*index1-3]; - icomplex1=0; - if(strcmp1(&labmpc[(id1-1)*20],"CYCLIC")==0){ - icomplex1=atoi(&labmpc[20*(id1-1)+6]); - } - else if(strcmp1(&labmpc[(id1-1)*20],"SUBCYCLIC")==0){ - for(ij=0;ij<*mcs;ij++){ - ilength=cs[17*ij+3]; - lprev=cs[17*ij+13]; - FORTRAN(nident,(&ics[lprev],&inode1,&ilength,&id)); - if(id>0){ - if(ics[lprev+id-1]==inode1){ - icomplex1=ij+1; - break; - } - } - } - } -// idof1=nactdof[mt*inode1+nodempc[3*index1-2]-4]; - idof1=nactdof[mt*(inode1-1)+nodempc[3*index1-2]]; - ist2=ipompc[id2-1]; - index2=nodempc[3*ist2-1]; - if(index2==0){ - index1=nodempc[3*index1-1]; - if(index1==0){break;} - else{continue;} - } - while(1){ - inode2=nodempc[3*index2-3]; - icomplex2=0; - if(strcmp1(&labmpc[(id2-1)*20],"CYCLIC")==0){ - icomplex2=atoi(&labmpc[20*(id2-1)+6]); - } - else if(strcmp1(&labmpc[(id2-1)*20],"SUBCYCLIC")==0){ - for(ij=0;ij<*mcs;ij++){ - ilength=cs[17*ij+3]; - lprev=cs[17*ij+13]; - FORTRAN(nident,(&ics[lprev],&inode2,&ilength,&id)); - if(id>0){ - if(ics[lprev+id-1]==inode2){ - icomplex2=ij+1; - break; - } - } - } - } -// idof2=nactdof[mt*inode2+nodempc[3*index2-2]-4]; - idof2=nactdof[mt*(inode2-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); - kdof1=idof1+neq[0];kdof2=idof2+neq[0]; - insert(ipointer,&mast1,&irow,&kdof1,&kdof2,&ifree,&nzs_); - if(((icomplex1!=0)||(icomplex2!=0))&& - (icomplex1!=icomplex2)){ - /* if(((icomplex1!=0)||(icomplex2!=0))&& - ((icomplex1==0)||(icomplex2==0))){*/ - insert(ipointer,&mast1,&irow,&kdof1,&idof2,&ifree,&nzs_); - insert(ipointer,&mast1,&irow,&idof1,&kdof2,&ifree,&nzs_); - } - } - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - } - } - } - } - } - - neq[0]=2*neq[0]; - neq[1]=neq[0]; - - /* ordering the nonzero nodes in the SUPERdiagonal columns - mast1 contains the row numbers column per column, - irow the column numbers */ - -/* for(i=0;i=neq[1]) continue; - printf("*ERROR in mastructcs: zero column\n"); - FORTRAN(stop,()); - } - istart=ipointer[i]; - while(1){ - istartold=istart; - istart=irow[istart-1]; - irow[istartold-1]=i+1; - if(istart==0) break; - } - } - - if(neq[0]==0){ - printf("\n*WARNING: no degrees of freedom in the model\n"); - FORTRAN(stop,()); - } - - printf(" number of equations\n"); - printf(" %d\n",neq[0]); - printf(" number of nonzero matrix elements\n"); - printf(" %d\n",ifree); - - /* new meaning of icol,j1,mast1,irow: - - - irow is going to contain the row numbers of the SUBdiagonal - nonzero's, column per column - - mast1 contains the column numbers - - icol(i)=# SUBdiagonal nonzero's in column i - - jq(i)= location in field irow of the first SUBdiagonal - nonzero in column i - - */ - - nmast=ifree; - - /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ - - FORTRAN(isortii,(mast1,irow,&nmast,&kflag)); - - /* filtering out the diagonal elements and generating icol and jq */ - - isubtract=0; - for(i=0;i0){ - isize=jq[i+1]-jq[i]; - FORTRAN(isortii,(&irow[jq[i]-1],&mast1[jq[i]-1],&isize,&kflag)); - } - } - - nzs[0]=jq[neq[0]-1]-1; - nzs[1]=nzs[0]; - nzs[2]=nzs[0]; - - *mast1p=mast1; - *irowp=irow; - - return; - -} - -/* - -What follows is the original FORTRAN code. The C Code is a one-to-one -manual translation of the FORTRAN code. However, the FORTRAN code might -be easier to understand. - -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine mastructcs(nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, - & nboun,ipompc, - & nodempc,nmpc,nactdof,icol,jq,mast1,irow,isolver,neq,nnn, - & ikmpc,ilmpc,ikcol,ipointer,nsky,nzs,nmethod,ics,ns,labmpc) -! - implicit none -! - character*6 lakon(*) - character*20 labmpc(*) -! - integer kon(*),nodeboun(*),ndirboun(*),nodempc(3,*),ipompc(*), - & nactdof(3,*),icol(*),jq(*),ipointer(*),nnn(*),ikmpc(*),ilmpc(*), - & ikcol(*),mast1(*),irow(*),ipkon(*),inode,icomplex,inode1, - & icomplex1,inode2,icomplex2,nsky_exp,nsky_inc,ns(5),ics(*) -! - integer nk,ne,nboun,nmpc,isolver,neq,nsky,nzs,i,j,k,l,jj,ll,id, - & index,jdof1,jdof2,idof1,idof2,mpc1,mpc2,id1,id2,ist1,ist2,node1, - & node2,isubtract,nmast,ifree,istart,istartold,itot,index1,index2, - & m,node,nzs_,ist,kflag,nmethod,indexe,nope -! - kflag=2 - nzs_=nzs -! -! initialisation of nactmpc -! - do i=1,nk - do j=1,3 - nactdof(j,i)=0 - enddo - enddo -! -! determining the active degrees of freedom due to elements -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if((lakon(i).eq.'C3D20R').or.(lakon(i).eq.'C3D20 ')) then - nope=20 - elseif((lakon(i).eq.'C3D8R ').or.(lakon(i).eq.'C3D8 ')) then - nope=8 - else - nope=10 - endif -! - do j=1,nope - node=kon(indexe+j) - do k=1,3 - nactdof(k,node)=1 - enddo - enddo - enddo -! -! determining the active degrees of freedom due to mpc's -! - do i=1,nmpc - index=ipompc(i) - do - nactdof(nodempc(2,index),nodempc(1,index))=1 - index=nodempc(3,index) - if(index.eq.0) exit - enddo - enddo -! -! subtracting the SPC and MPC nodes -! - do i=1,nboun - nactdof(ndirboun(i),nodeboun(i))=0 - enddo -! - do i=1,nmpc - index=ipompc(i) - nactdof(nodempc(2,index),nodempc(1,index))=0 - enddo -! -! numbering the active degrees of freedom -! - neq=0 - do i=1,nk - do j=1,3 - if(nactdof(j,nnn(i)).ne.0) then - neq=neq+1 - nactdof(j,nnn(i))=neq - endif - enddo - enddo -! - ifree=0 -! -! -! determining the position of each nonzero matrix element -! -! mast1(ipointer(i)) = first nonzero row in column i -! irow(ipointer(i)) points to further nonzero elements in -! column i -! - do i=1,6*nk - ipointer(i)=0 - enddo -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if((lakon(i).eq.'C3D20R').or.(lakon(i).eq.'C3D20 ')) then - nope=20 - elseif((lakon(i).eq.'C3D8R ').or.(lakon(i).eq.'C3D8 ')) then - nope=8 - else - nope=10 - endif -! - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdof(k,node1) -! - do ll=jj,3*nope -! - l=(ll-1)/3+1 - m=ll-3*(l-1) -! - node2=kon(indexe+l) - jdof2=nactdof(m,node2) -! -! check whether one of the DOF belongs to a SPC or MPC -! - if((jdof1.ne.0).and.(jdof2.ne.0)) then - call inserf(ipointer,mast1,irow, - & jdof1,jdof2,ifree,nzs_) - call inserf(ipointer,mast1,irow, - & jdof1+neq,jdof2+neq,ifree,nzs_) - elseif((jdof1.ne.0).or.(jdof2.ne.0)) then -! -! idof1: genuine DOF -! idof2: nominal DOF of the SPC/MPC -! - if(jdof1.eq.0) then - idof1=jdof2 - idof2=(node1-1)*3+k - else - idof1=jdof1 - idof2=(node2-1)*3+m - endif - if(nmpc.gt.0) then - call nident(ikmpc,idof2,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof2)) then -! -! regular DOF / MPC -! - id1=ilmpc(id) - ist=ipompc(id1) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - inode=nodempc(1,index) - icomplex=0 - if(labmpc(id1)(1:6).eq.'CYCLIC') then - icomplex=1 - elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then - call nident(ics,inode,ns(4),id) - if(id.gt.0) then - if(ics(id).eq.inode) then - icomplex=1 - endif - endif - endif - idof2=nactdof(nodempc(2,index),inode) - if(idof2.ne.0) then - call inserf(ipointer,mast1,irow, - & idof1,idof2,ifree,nzs_) - call inserf(ipointer,mast1,irow, - & idof1+neq,idof2+neq,ifree,nzs_) - if((icomplex.eq.1).and.(idof1.ne.idof2)) then - call inserf(ipointer,mast1,irow, - & idof1+neq,idof2,ifree,nzs_) - call inserf(ipointer,mast1,irow, - & idof1,idof2+neq,ifree,nzs_) - endif - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - cycle - endif - endif -! - else - idof1=(node1-1)*3+k - idof2=(node2-1)*3+m - mpc1=0 - mpc2=0 - if(nmpc.gt.0) then - call nident(ikmpc,idof1,nmpc,id1) - if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 - call nident(ikmpc,idof2,nmpc,id2) - if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 - endif - if((mpc1.eq.1).and.(mpc2.eq.1)) then - id1=ilmpc(id1) - id2=ilmpc(id2) - if(id1.eq.id2) then -! -! MPC id1 / MPC id1 -! - ist=ipompc(id1) - index1=nodempc(3,ist) - if(index1.eq.0) cycle - do - inode1=nodempc(1,index1) - icomplex1=0 - if(labmpc(id1)(1:6).eq.'CYCLIC') then - icomplex1=1 - elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then - call nident(ics,inode1,ns(4),id) - if(id.gt.0) then - if(ics(id).eq.inode1) then - icomplex1=1 - endif - endif - endif - idof1=nactdof(nodempc(2,index1),inode1) - index2=index1 - do - inode2=nodempc(1,index2) - call nident(ics,inode2,ns(4),id) - icomplex2=0 - if(labmpc(id1)(1:6).eq.'CYCLIC') then - icomplex2=1 - elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then - call nident(ics,inode2,ns(4),id) - if(id.gt.0) then - if(ics(id).eq.inode2) then - icomplex2=1 - endif - endif - endif - idof2=nactdof(nodempc(2,index2),inode2) - if((idof1.ne.0).and.(idof2.ne.0)) then - call inserf(ipointer,mast1,irow, - & idof1,idof2,ifree,nzs_) - call inserf(ipointer,mast1,irow, - & idof1+neq,idof2+neq,ifree,nzs_) - if(((icomplex1.eq.1).or.(icomplex2.eq.1)). - & and.((icomplex1.eq.0).or.(icomplex2.eq.0))) - & then - call inserf(ipointer,mast1,irow, - & idof1+neq,idof2,ifree,nzs_) - call inserf(ipointer,mast1,irow, - & idof1,idof2+neq,ifree,nzs_) - endif - endif - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - else -! -! MPC id1 / MPC id2 -! - ist1=ipompc(id1) - index1=nodempc(3,ist1) - if(index1.eq.0) cycle - do - inode1=nodempc(1,index1) - icomplex1=0 - if(labmpc(id1)(1:6).eq.'CYCLIC') then - icomplex1=1 - elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then - call nident(ics,inode1,ns(4),id) - if(id.gt.0) then - if(ics(id).eq.inode1) then - icomplex1=1 - endif - endif - endif - idof1=nactdof(nodempc(2,index1),inode1) - ist2=ipompc(id2) - index2=nodempc(3,ist2) - if(index2.eq.0) then - index1=nodempc(3,index1) - if(index1.eq.0) then - exit - else - cycle - endif - endif - do - inode2=nodempc(1,index2) - icomplex2=0 - if(labmpc(id2)(1:6).eq.'CYCLIC') then - icomplex2=1 - elseif(labmpc(id2)(1:9).eq.'SUBCYCLIC') then - call nident(ics,inode2,ns(4),id) - if(id.gt.0) then - if(ics(id).eq.inode2) then - icomplex2=1 - endif - endif - endif - idof2=nactdof(nodempc(2,index2),inode2) - if((idof1.ne.0).and.(idof2.ne.0)) then - call inserf(ipointer,mast1,irow, - & idof1,idof2,ifree,nzs_) - call inserf(ipointer,mast1,irow, - & idof1+neq,idof2+neq,ifree,nzs_) - if(((icomplex1.eq.1).or.(icomplex2.eq.1)). - & and.((icomplex1.eq.0).or.(icomplex2.eq.0)). - & and.(idof1.ne.idof2)) - & then - call inserf(ipointer,mast1,irow, - & idof1+neq,idof2,ifree,nzs_) - call inserf(ipointer,mast1,irow, - & idof1,idof2+neq,ifree,nzs_) - endif - endif - index2=nodempc(3,index2) - if(index2.eq.0) exit - enddo - index1=nodempc(3,index1) - if(index1.eq.0) exit - enddo - endif - endif - endif - enddo - enddo - enddo -! -! ordering the nonzero nodes in the SUPERdiagonal columns -! mast1 contains the row numbers column per column, -! irow the column numbers -! - neq=2*neq -! - do i=1,neq - itot=0 - if(ipointer(i).eq.0) then - write(*,*) 'error in mastructcs: zero column' - stop - endif - istart=ipointer(i) - do - itot=itot+1 - ikcol(itot)=mast1(istart) - istart=irow(istart) - if(istart.eq.0) exit - enddo - call isortii(ikcol,icol,itot,kflag) - istart=ipointer(i) - do j=1,itot-1 - mast1(istart)=ikcol(j) - istartold=istart - istart=irow(istart) - irow(istartold)=i - enddo - mast1(istart)=ikcol(itot) - irow(istart)=i - enddo -! -! defining icol and jq -! - nsky=0 - nsky_exp=0 - do i=2,neq - nsky_inc=i-mast1(ipointer(i)) - if(2147483647-nsky.lt.nsky_inc) then - nsky_exp=nsky_exp+1 - nsky_inc=nsky_inc-2147483647 - endif - nsky=nsky+nsky_inc - enddo -! - if(neq.eq.0) then - write(*,*) '*WARNING: no degrees of freedom in the model' - stop - endif -! - write(*,*) 'number of equations' - write(*,*) neq - write(*,*) 'number of nonzero matrix elements' - write(*,*) ifree - write(*,*) 'total length of the skyline' - write(*,*) nsky_exp,'*2147483647+',nsky - write(*,*) 'percentage of nonzero skyline elements' - write(*,*) real(ifree)/ - & (real(nsky+neq)+nsky_exp*real(2147483647))*100. - write(*,*) -! -! new meaning of icol,j1,mast1,irow: -! - irow is going to contain the row numbers of the SUBdiagonal -! nonzero's, column per column -! - mast1 contains the column numbers -! - icol(i)=# SUBdiagonal nonzero's in column i -! - jq(i)= location in field irow of the first SUBdiagonal -! nonzero in column i -! - nmast=ifree -! -! switching from a SUPERdiagonal inventary to a SUBdiagonal one -! - call isortii(mast1,irow,nmast,kflag) -! -! filtering out the diagonal elements and generating icol and jq -! - isubtract=0 - do i=1,neq - icol(i)=0 - enddo - k=0 - do i=1,nmast - if(mast1(i).eq.irow(i)) then - isubtract=isubtract+1 - else - mast1(i-isubtract)=mast1(i) - irow(i-isubtract)=irow(i) - if(k.ne.mast1(i)) then - do l=k+1,mast1(i) - jq(l)=i-isubtract - enddo - k=mast1(i) - endif - icol(k)=icol(k)+1 - endif - enddo - nmast=nmast-isubtract - do l=k+1,neq+1 - jq(l)=nmast+1 - enddo -! - do i=1,neq - if(jq(i+1)-jq(i).gt.0) then - call isortii(irow(jq(i)),mast1(jq(i)),jq(i+1)-jq(i), - & kflag) - endif - enddo -! - nzs=jq(neq)-1 -! - return - end - - */ diff -Nru calculix-ccx-2.1/ccx_2.1/src/mastructf.c calculix-ccx-2.3/ccx_2.1/src/mastructf.c --- calculix-ccx-2.1/ccx_2.1/src/mastructf.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/mastructf.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1151 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -#define min(a,b) ((a) <= (b) ? (a) : (b)) -#define max(a,b) ((a) >= (b) ? (a) : (b)) - -void mastructf(int *nk, int *kon, int *ipkon, char *lakon, int *ne, - int *nodeboun, int *ndirboun, int *nboun, int *ipompc, - int *nodempc, int *nmpc, int *nactdoh, int *icolt, - int *icolv, int *icolp, int *icolk,int *jqt, int *jqv, int *jqp, - int *jqk,int **mast1p, int **irowtp, int **irowvp, int **irowpp, - int **irowkp, int *isolver, int *neqt, int *neqv, int *neqp, - int *neqk,int *ikmpc, int *ilmpc,int *ipointer, - int *nzst, int *nzsv, int *nzsp, int *nzsk, - int *ithermal, int *ikboun, int *ilboun, int *turbulent, - int *nactdok, int *ifreestream, int *nfreestream, - int *isolidface, int *nsolidface, int *nzs, int *iexplicit, - int *ielmat, int *inomat, char *labmpc){ - - int i,j,k,l,jj,ll,id,index,jdof1,jdof2,idof1,idof2,mpc1,mpc2,id1,id2, - ist1,ist2,node1,node2,isubtract,nmast,ifree,istart,istartold,idir, - index1,index2,m,node,nzs_,ist,kflag,indexe,nope,isize,*mast1=NULL, - *irowt=NULL,*irowv=NULL,*irowp=NULL,*irowk=NULL,fluid,imaterial; - - /* the indices in the comments follow FORTRAN convention, i.e. the - fields start with 1 */ - - mast1=*mast1p; - irowt=*irowtp;irowv=*irowvp;irowp=*irowpp;irowk=*irowkp; - - kflag=2; - - /* initialisation of nactdoh */ - - for(i=0;i<5**nk;++i){nactdoh[i]=0;} - - /* determining the active degrees of freedom due to elements */ - - for(i=0;i<*ne;++i){ - - if(ipkon[i]<0) continue; - if(strcmp1(&lakon[8*i],"F")!=0) continue; - indexe=ipkon[i]; - if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; - else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; - else continue; - - for(j=0;j4){continue;} - if(nodempc[3*index+1]==4){ - nactdoh[5*(nodempc[3*index]-1)+4]=0; - } - } - } - - /* numbering the active degrees of freedom */ - - *neqt=0;*neqv=0;*neqp=0; - for(i=0;i<*nk;++i){ - if(*ithermal>1){ - if(nactdoh[5*i]!=0){ - ++(*neqt); - nactdoh[5*i]=*neqt; - } - } - for(j=1;j<4;++j){ - if(nactdoh[5*i+j]!=0){ - ++(*neqv); - nactdoh[5*i+j]=*neqv; - } - } - if(nactdoh[5*i+4]!=0){ - ++(*neqp); - nactdoh[5*i+4]=*neqp; - } - } - if(*ithermal>1) printf("neqttt=%d\n",*neqt); - printf("neqvvv=%d\n",*neqv); - printf("neqppp=%d\n",*neqp); - - /* determining the turbulence degrees of freedom */ - - if(*turbulent!=0){ - - /* initialisation of nactdok */ - - for(i=0;i<*nk;++i){nactdok[i]=0;} - - /* determining the turbulence degrees of freedom due to elements */ - - for(i=0;i<*ne;++i){ - - if(ipkon[i]<0) continue; - if(strcmp1(&lakon[8*i],"F")!=0) continue; - indexe=ipkon[i]; - if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; - else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; - else continue; - - for(j=0;j1){ - - ifree=0; - nzs_=*nzs; - - /* determining the position of each nonzero matrix element - - mast1(ipointer(i)) = first nonzero row in column i - irow(ipointer(i)) points to further nonzero elements in - column i */ - - for(i=0;i<3**nk;++i){ipointer[i]=0;} - - for(i=0;i<*ne;++i){ - - if(ipkon[i]<0) continue; - if(strcmp1(&lakon[8*i],"F")!=0) continue; - indexe=ipkon[i]; - if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; - else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; - else continue; - - for(jj=0;jj0){ - - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); - if((id>0)&&(ikmpc[id-1]==idof2)){ - - /* regular DOF / MPC */ - - id=ilmpc[id-1]; - ist=ipompc[id-1]; - index=nodempc[3*ist-1]; - if(index==0) continue; - while(1){ - idof2=nactdoh[5*(nodempc[3*index-3]-1)+nodempc[3*index-2]]; - if(idof2!=0){ - insert(ipointer,&mast1,&irowt,&idof1,&idof2,&ifree,&nzs_); - } - index=nodempc[3*index-1]; - if(index==0) break; - } - continue; - } - } - - } - - else{ - idof1=8*node1-8; - idof2=8*node2-8; - mpc1=0; - mpc2=0; - if(*nmpc>0){ - FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); - if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); - if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; - } - if((mpc1==1)&&(mpc2==1)){ - id1=ilmpc[id1-1]; - id2=ilmpc[id2-1]; - if(id1==id2){ - - /* MPC id1 / MPC id1 */ - - ist=ipompc[id1-1]; - index1=nodempc[3*ist-1]; - if(index1==0) continue; - while(1){ - idof1=nactdoh[5*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; - index2=index1; - while(1){ - idof2=nactdoh[5*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irowt,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - - else{ - - /* MPC id1 /MPC id2 */ - - ist1=ipompc[id1-1]; - index1=nodempc[3*ist1-1]; - if(index1==0) continue; - while(1){ - idof1=nactdoh[5*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; - ist2=ipompc[id2-1]; - index2=nodempc[3*ist2-1]; - if(index2==0){ - index1=nodempc[3*index1-1]; - if(index1==0){break;} - else{continue;} - } - while(1){ - idof2=nactdoh[5*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irowt,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - } - } - } - } - } - - for(i=0;i<*neqt;++i){ - if(ipointer[i]==0){ - if(i>=*neqt) continue; - printf("*ERROR in mastructf: zero column\n"); - FORTRAN(stop,()); - } - istart=ipointer[i]; - while(1){ - istartold=istart; - istart=irowt[istart-1]; - irowt[istartold-1]=i+1; - if(istart==0) break; - } - } - - /* defining icolt and jqt */ - - if(*neqt==0){ - printf("\n*WARNING in mastructf: no degrees of freedom in the temperature matrix\n\n"); - } - - nmast=ifree; - - /* summary */ - - printf(" number of temperature equations\n"); - printf(" %d\n",*neqt); - printf(" number of nonzero temperature matrix elements\n"); - printf(" %d\n",nmast); - printf("\n"); - - /* changing the meaning of icolt,jqt,mast1,irowt: - - - irowt is going to contain the row numbers of the SUBdiagonal - nonzero's, column per column - - mast1 contains the column numbers - - icolt(i)=# SUBdiagonal nonzero's in column i - - jqt(i)= location in field irow of the first SUBdiagonal - nonzero in column i - - */ - - /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ - - FORTRAN(isortii,(mast1,irowt,&nmast,&kflag)); - - /* filtering out the diagonal elements and generating icolt and jqt */ - - isubtract=0; - for(i=0;i<*neqt;++i){icolt[i]=0;} - k=0; - for(i=0;i0){ - isize=jqt[i+1]-jqt[i]; - FORTRAN(isortii,(&irowt[jqt[i]-1],&mast1[jqt[i]-1],&isize,&kflag)); - } - } - - if(*neqt==0){*nzst=0;} - else{*nzst=jqt[*neqt]-1;} - - } - - /* velocity entries */ - - ifree=0; - nzs_=*nzs; - RENEW(mast1,int,nzs_); - for(i=0;i0){ - - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); - if((id>0)&&(ikmpc[id-1]==idof2)){ - - /* regular DOF / MPC */ - - id=ilmpc[id-1]; - ist=ipompc[id-1]; - index=nodempc[3*ist-1]; - if(index==0) continue; - while(1){ - idof2=nactdoh[5*(nodempc[3*index-3]-1)+nodempc[3*index-2]]; - if(idof2!=0){ - insert(ipointer,&mast1,&irowv,&idof1,&idof2,&ifree,&nzs_); - } - index=nodempc[3*index-1]; - if(index==0) break; - } - continue; - } - } - } - - else{ - idof1=8*node1+k-7; - idof2=8*node2+m-7; - mpc1=0; - mpc2=0; - if(*nmpc>0){ - FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); - if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); - if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; - } - if((mpc1==1)&&(mpc2==1)){ - id1=ilmpc[id1-1]; - id2=ilmpc[id2-1]; - if(id1==id2){ - - /* MPC id1 / MPC id1 */ - - ist=ipompc[id1-1]; - index1=nodempc[3*ist-1]; - if(index1==0) continue; - while(1){ - idof1=nactdoh[5*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; - index2=index1; - while(1){ - idof2=nactdoh[5*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irowv,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - - else{ - - /* MPC id1 /MPC id2 */ - - ist1=ipompc[id1-1]; - index1=nodempc[3*ist1-1]; - if(index1==0) continue; - while(1){ - idof1=nactdoh[5*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; - ist2=ipompc[id2-1]; - index2=nodempc[3*ist2-1]; - if(index2==0){ - index1=nodempc[3*index1-1]; - if(index1==0){break;} - else{continue;} - } - while(1){ - idof2=nactdoh[5*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irowv,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - } - } - } - } - } - - for(i=0;i<*neqv;++i){ - if(ipointer[i]==0){ - if(i>=*neqv) continue; - printf("*ERROR in mastructf: zero column in the velocity matrix\n"); - printf(" DOF %d\n",i); - FORTRAN(stop,()); - } - istart=ipointer[i]; - while(1){ - istartold=istart; - istart=irowv[istart-1]; - irowv[istartold-1]=i+1; - if(istart==0) break; - } - } - - /* defining icolv and jqv */ - - if(*neqv==0){ - printf("\n*WARNING in mastructf: no degrees of freedom in the velocity matrix\n\n"); - } - - nmast=ifree; - - /* summary */ - - printf(" number of velocity equations\n"); - printf(" %d\n",*neqv); - printf(" number of nonzero velocity matrix elements\n"); - printf(" %d\n",nmast); - printf("\n"); - - /* changing the meaning of icolv,jqv,mast1,irowv: - - - irowv is going to contain the row numbers of the SUBdiagonal - nonzero's, column per column - - mast1 contains the column numbers - - icolv(i)=# SUBdiagonal nonzero's in column i - - jqv(i)= location in field irow of the first SUBdiagonal - nonzero in column i - - */ - - /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ - - FORTRAN(isortii,(mast1,irowv,&nmast,&kflag)); - - /* filtering out the diagonal elements and generating icolv and jqv */ - - isubtract=0; - for(i=0;i<*neqv;++i){icolv[i]=0;} - k=0; - for(i=0;i0){ - isize=jqv[i+1]-jqv[i]; - FORTRAN(isortii,(&irowv[jqv[i]-1],&mast1[jqv[i]-1],&isize,&kflag)); - } - } - - if(*neqv==0){*nzsv=0;} - else{*nzsv=jqv[*neqv]-1;} - - /* pressure entries */ - - ifree=0; - nzs_=*nzs; - RENEW(mast1,int,nzs_); - for(i=0;i0){ - - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); - if((id>0)&&(ikmpc[id-1]==idof2)){ - - /* regular DOF / MPC */ - - id=ilmpc[id-1]; - ist=ipompc[id-1]; - index=nodempc[3*ist-1]; - if(index==0) continue; - while(1){ - idof2=nactdoh[5*(nodempc[3*index-3]-1)+4]; - if(idof2!=0){ - insert(ipointer,&mast1,&irowp,&idof1,&idof2,&ifree,&nzs_); - } - index=nodempc[3*index-1]; - if(index==0) break; - } - continue; - } - } - } - - else{ - idof1=8*node1-4; - idof2=8*node2-4; - mpc1=0; - mpc2=0; - if(*nmpc>0){ - FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); - if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); - if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; - } - if((mpc1==1)&&(mpc2==1)){ - id1=ilmpc[id1-1]; - id2=ilmpc[id2-1]; - if(id1==id2){ - - /* MPC id1 / MPC id1 */ - - ist=ipompc[id1-1]; - index1=nodempc[3*ist-1]; - if(index1==0) continue; - while(1){ - idof1=nactdoh[5*(nodempc[3*index1-3]-1)+4]; - index2=index1; - while(1){ - idof2=nactdoh[5*(nodempc[3*index2-3]-1)+4]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irowp,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - - else{ - - /* MPC id1 /MPC id2 */ - - ist1=ipompc[id1-1]; - index1=nodempc[3*ist1-1]; - if(index1==0) continue; - while(1){ - idof1=nactdoh[5*(nodempc[3*index1-3]-1)+4]; - ist2=ipompc[id2-1]; - index2=nodempc[3*ist2-1]; - if(index2==0){ - index1=nodempc[3*index1-1]; - if(index1==0){break;} - else{continue;} - } - while(1){ - idof2=nactdoh[5*(nodempc[3*index2-3]-1)+4]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irowp,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - } - } - } - } - } - - for(i=0;i<*neqp;++i){ - if(ipointer[i]==0){ - if(i>=*neqp) continue; - printf("*ERROR in mastructf: zero column\n"); - FORTRAN(stop,()); - } - istart=ipointer[i]; - while(1){ - istartold=istart; - istart=irowp[istart-1]; - irowp[istartold-1]=i+1; - if(istart==0) break; - } - } - - /* defining icolp and jqp */ - - if(*neqp==0){ - printf("\n*WARNING in matructf: no degrees of freedom in the pressure matrix\n\n"); - } - - nmast=ifree; - - /* summary */ - - printf(" number of pressure equations\n"); - printf(" %d\n",*neqp); - printf(" number of nonzero pressure matrix elements\n"); - printf(" %d\n",nmast); - printf("\n"); - - /* changing the meaning of icolp,jqp,mast1,irowp: - - - irowp is going to contain the row numbers of the SUBdiagonal - nonzero's, column per column - - mast1 contains the column numbers - - icolp(i)=# SUBdiagonal nonzero's in column i - - jqp(i)= location in field irow of the first SUBdiagonal - nonzero in column i - - */ - - /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ - - FORTRAN(isortii,(mast1,irowp,&nmast,&kflag)); - - /* filtering out the diagonal elements and generating icolp and jqp */ - - isubtract=0; - for(i=0;i<*neqp;++i){icolp[i]=0;} - k=0; - for(i=0;i0){ - isize=jqp[i+1]-jqp[i]; - FORTRAN(isortii,(&irowp[jqp[i]-1],&mast1[jqp[i]-1],&isize,&kflag)); - } - } - - if(*neqp==0){*nzsp=0;} - else{*nzsp=jqp[*neqp]-1;} - - /* turbulence entries */ - - if(*turbulent!=0){ - - ifree=0; - nzs_=*nzs; - RENEW(mast1,int,nzs_); - for(i=0;i0){ - - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); - if((id>0)&&(ikmpc[id-1]==idof2)){ - - /* regular DOF / MPC */ - - id=ilmpc[id-1]; - ist=ipompc[id-1]; - index=nodempc[3*ist-1]; - if(index==0) continue; - while(1){ - idof2=nactdok[nodempc[3*index-3]-1]; - if(idof2!=0){ - insert(ipointer,&mast1,&irowk,&idof1,&idof2,&ifree,&nzs_); - } - index=nodempc[3*index-1]; - if(index==0) break; - } - continue; - } - } - } - - else{ - idof1=8*node1-8; - idof2=8*node2-8; - mpc1=0; - mpc2=0; - if(*nmpc>0){ - FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); - if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; - FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); - if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; - } - if((mpc1==1)&&(mpc2==1)){ - id1=ilmpc[id1-1]; - id2=ilmpc[id2-1]; - if(id1==id2){ - - /* MPC id1 / MPC id1 */ - - ist=ipompc[id1-1]; - index1=nodempc[3*ist-1]; - if(index1==0) continue; - while(1){ - idof1=nactdok[nodempc[3*index1-3]-1]; - index2=index1; - while(1){ - idof2=nactdok[nodempc[3*index2-3]-1]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irowk,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - - else{ - - /* MPC id1 /MPC id2 */ - - ist1=ipompc[id1-1]; - index1=nodempc[3*ist1-1]; - if(index1==0) continue; - while(1){ - idof1=nactdok[nodempc[3*index1-3]-1]; - ist2=ipompc[id2-1]; - index2=nodempc[3*ist2-1]; - if(index2==0){ - index1=nodempc[3*index1-1]; - if(index1==0){break;} - else{continue;} - } - while(1){ - idof2=nactdok[nodempc[3*index2-3]-1]; - if((idof1!=0)&&(idof2!=0)){ - insert(ipointer,&mast1,&irowk,&idof1,&idof2,&ifree,&nzs_);} - index2=nodempc[3*index2-1]; - if(index2==0) break; - } - index1=nodempc[3*index1-1]; - if(index1==0) break; - } - } - } - } - } - } - } - - for(i=0;i<*neqk;++i){ - if(ipointer[i]==0){ - if(i>=*neqk) continue; - printf("*ERROR in mastructf: zero column\n"); - FORTRAN(stop,()); - } - istart=ipointer[i]; - while(1){ - istartold=istart; - istart=irowk[istart-1]; - irowk[istartold-1]=i+1; - if(istart==0) break; - } - } - - /* defining icolk and jqk */ - - if(*neqk==0){ - printf("\n*WARNING in matructf: no degrees of freedom in the turbulence matrix\n\n"); - } - - nmast=ifree; - - /* summary */ - - printf(" number of turbulence equations\n"); - printf(" %d\n",*neqk); - printf(" number of nonzero turbulence matrix elements\n"); - printf(" %d\n",nmast); - printf("\n"); - - /* changing the meaning of icolk,jqk,mast1,irowk: - - - irowk is going to contain the row numbers of the SUBdiagonal - nonzero's, column per column - - mast1 contains the column numbers - - icolk(i)=# SUBdiagonal nonzero's in column i - - jqk(i)= location in field irow of the first SUBdiagonal - nonzero in column i - - */ - - /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ - - FORTRAN(isortii,(mast1,irowk,&nmast,&kflag)); - - /* filtering out the diagonal elements and generating icolk and jqk */ - - isubtract=0; - for(i=0;i<*neqk;++i){icolk[i]=0;} - k=0; - for(i=0;i0){ - isize=jqk[i+1]-jqk[i]; - FORTRAN(isortii,(&irowk[jqk[i]-1],&mast1[jqk[i]-1],&isize,&kflag)); - } - } - - if(*neqk==0){*nzsk=0;} - else{*nzsk=jqk[*neqk]-1;} - - } - - *mast1p=mast1; - *irowtp=irowt;*irowvp=irowv;*irowpp=irowp;*irowkp=irowk; - - return; - -} - diff -Nru calculix-ccx-2.1/ccx_2.1/src/materialdata_cond.f calculix-ccx-2.3/ccx_2.1/src/materialdata_cond.f --- calculix-ccx-2.1/ccx_2.1/src/materialdata_cond.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materialdata_cond.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materialdata_cond(imat,ntmat_,t1l,cocon,ncocon,cond) -! - implicit none -! -! determines the following gas properties: the density, -! specific heat, the dynamic viscosity, the specific gas constant -! and the thermal conductivity -! - integer imat,ntmat_,id,ncocon(2,*),ncoconst,seven -! - real*8 t1l,cocon(0:6,ntmat_,*),cond -! - seven=7 -! -! calculating the conductivity coefficients -! - ncoconst=ncocon(1,imat) - if(ncoconst.ne.1) then - write(*,*) '*ERROR in materialdata_fl' - write(*,*) - & ' conductivity for fluids must be isotropic' - stop - endif -! - call ident2(cocon(0,1,imat),t1l,ncocon(2,imat),seven,id) - if(ncocon(2,imat).eq.0) then - cond=0.d0 - continue - elseif(ncocon(2,imat).eq.1) then - cond=cocon(1,1,imat) - elseif(id.eq.0) then - cond=cocon(1,1,imat) - elseif(id.eq.ncocon(2,imat)) then - cond=cocon(1,id,imat) - else - cond=(cocon(1,id,imat)+ - & (cocon(1,id+1,imat)-cocon(1,id,imat))* - & (t1l-cocon(0,id,imat))/ - & (cocon(0,id+1,imat)-cocon(0,id,imat))) - & - endif -! - return - end - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/materialdata_cp.f calculix-ccx-2.3/ccx_2.1/src/materialdata_cp.f --- calculix-ccx-2.1/ccx_2.1/src/materialdata_cp.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materialdata_cp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materialdata_cp(imat,ntmat_,t1l,shcon,nshcon,cp) -! - implicit none -! -! determines the specific heat -! - integer imat,ntmat_,id,nshcon(*),four -! - real*8 t1l,shcon(0:3,ntmat_,*),cp -! - four=4 -! -! calculating the specific heat and the dynamic viscosity -! - call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) - if(nshcon(imat).eq.0) then - continue - elseif(nshcon(imat).eq.1) then - cp=shcon(1,1,imat) - elseif(id.eq.0) then - cp=shcon(1,1,imat) - elseif(id.eq.nshcon(imat)) then - cp=shcon(1,id,imat) - else - cp=shcon(1,id,imat)+ - & (shcon(1,id+1,imat)-shcon(1,id,imat))* - & (t1l-shcon(0,id,imat))/ - & (shcon(0,id+1,imat)-shcon(0,id,imat)) - endif -! - return - end - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/materialdata_cp_sec.f calculix-ccx-2.3/ccx_2.1/src/materialdata_cp_sec.f --- calculix-ccx-2.1/ccx_2.1/src/materialdata_cp_sec.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materialdata_cp_sec.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,80 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materialdata_cp_sec(imat,ntmat_,t1l,shcon,nshcon,cp, - & physcon) -! - implicit none -! -! determines the secant specific heat at constant pressure cp -! -! the difference with materialdata_cp is that the specific heat at -! constant pressure cp as returned from the present routine -! is the secant value and not the differential value. -! For the differential value we have: -! dh=cp*dT -! and consequently -! h=int_from_0_to_T cp*dT cp*dT -! For the secant value one has: -! h=cp_secant*T -! - integer imat,ntmat_,id,nshcon(*),four,i -! - real*8 t1l,shcon(0:3,ntmat_,*),cp,physcon(*) -! - four=4 -! -! calculating the tangent specific heat -! - call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) - if(nshcon(imat).eq.0) then - continue - elseif(nshcon(imat).eq.1) then - cp=shcon(1,1,imat) - elseif(id.eq.0) then - cp=shcon(1,1,imat) - elseif(id.eq.nshcon(imat)) then - cp=(shcon(0,1,imat)-physcon(1))*shcon(1,1,imat) - do i=2,nshcon(imat) - cp=cp+(shcon(0,i,imat)-shcon(0,i-1,imat))* - & (shcon(1,i,imat)+shcon(1,i-1,imat))/2.d0 - enddo - cp=cp+(t1l-shcon(0,nshcon(imat),imat))* - & (shcon(1,nshcon(imat),imat))/(t1l-physcon(1)) - else - cp=shcon(1,id,imat)+ - & (shcon(1,id+1,imat)-shcon(1,id,imat))* - & (t1l-shcon(0,id,imat))/ - & (shcon(0,id+1,imat)-shcon(0,id,imat)) - cp=(t1l-shcon(0,id,imat))*(cp+shcon(1,id,imat))/2.d0 - do i=2,id - cp=cp+(shcon(0,i,imat)-shcon(0,i-1,imat))* - & (shcon(1,i,imat)+shcon(1,i-1,imat))/2.d0 - enddo - cp=cp+(shcon(0,1,imat)-physcon(1))*shcon(1,1,imat) - cp=cp/(t1l-physcon(1)) - endif -! - return - end - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/materialdata_dvi.f calculix-ccx-2.3/ccx_2.1/src/materialdata_dvi.f --- calculix-ccx-2.1/ccx_2.1/src/materialdata_dvi.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materialdata_dvi.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materialdata_dvi(imat,ntmat_,t1l,shcon,nshcon,dvi) -! - implicit none -! -! determines the dynamic viscosity -! - integer imat,ntmat_,id,nshcon(*),four -! - real*8 t1l,shcon(0:3,ntmat_,*),dvi -! - four=4 -! - call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) - if(nshcon(imat).eq.0) then - continue - elseif(nshcon(imat).eq.1) then - dvi=shcon(2,1,imat) - elseif(id.eq.0) then - dvi=shcon(2,1,imat) - elseif(id.eq.nshcon(imat)) then - dvi=shcon(2,id,imat) - else - dvi=shcon(2,id,imat)+ - & (shcon(2,id+1,imat)-shcon(2,id,imat))* - & (t1l-shcon(0,id,imat))/ - & (shcon(0,id+1,imat)-shcon(0,id,imat)) - endif -! - return - end - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/materialdata_me.f calculix-ccx-2.3/ccx_2.1/src/materialdata_me.f --- calculix-ccx-2.1/ccx_2.1/src/materialdata_me.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materialdata_me.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,470 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materialdata_me(elcon,nelcon,rhcon,nrhcon,alcon,nalcon, - & imat,amat,iorien,pgauss,orab,ntmat_,elas,rho,i,ithermal, - & alzero,mattyp,t0l,t1l,ihyper,istiff,elconloc,eth,kode,plicon, - & nplicon,plkcon,nplkcon,npmat_,plconloc,mi,dtime,iel,iint, - & xstiff,ncmat_) -! - implicit none -! -! determines the material data for element i -! -! istiff=0: only interpolation of material data -! istiff=1: copy the consistent tangent matrix from the field -! xstiff and check for zero entries -! - character*80 amat -! - integer nelcon(2,*),nrhcon(*),nalcon(2,*), - & imat,iorien,ithermal,i,j,k,mattyp,kal(2,6),j1,j2,j3,j4, - & jj,ntmat_,istiff,nelconst,ihyper,kode,itemp,kin,nelas, - & iel,iint,mi(2),ncmat_,id,two,seven -! - integer nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ -! - real*8 elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*), - & alcon(0:6,ntmat_,*),eth(6),xstiff(27,mi(1),*), - & orab(7,*),elas(21),alph(6),alzero(*),rho,t0l,t1l, - & skl(3,3),xa(3,3),elconloc(21),emax,pgauss(3) -! - real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), - & plconloc(82),dtime -! - data kal /1,1,2,2,3,3,1,2,1,3,2,3/ -! - two=2 - seven=7 -! -! nelconst: # constants read from file -! nelas: # constants in the local tangent stiffness matrix -! - if(istiff.eq.1) then - - nelas=nelcon(1,imat) - if((nelas.lt.0).or.((nelas.ne.2).and.(iorien.ne.0))) nelas=21 -! -! calculating the density (needed for the mass matrix and -! gravity or centrifugal loading) -! - if(ithermal.eq.0) then - rho=rhcon(1,1,imat) - else - call ident2(rhcon(0,1,imat),t1l,nrhcon(imat),two,id) - if(nrhcon(imat).eq.0) then - continue - elseif(nrhcon(imat).eq.1) then - rho=rhcon(1,1,imat) - elseif(id.eq.0) then - rho=rhcon(1,1,imat) - elseif(id.eq.nrhcon(imat)) then - rho=rhcon(1,id,imat) - else - rho=rhcon(1,id,imat)+ - & (rhcon(1,id+1,imat)-rhcon(1,id,imat))* - & (t1l-rhcon(0,id,imat))/ - & (rhcon(0,id+1,imat)-rhcon(0,id,imat)) - endif - endif -! -! for nonlinear behavior (nonlinear geometric or -! nonlinear material behavior): copy the stiffness matrix -! from the last stress calculation -! - do j=1,21 - elas(j)=xstiff(j,iint,iel) - enddo -! -! check whether the fully anisotropic case can be -! considered as orthotropic -! - if(nelas.eq.21) then - emax=0.d0 - do j=1,9 - emax=max(emax,dabs(elas(j))) - enddo - do j=10,21 - if(dabs(elas(j)).gt.emax*1.d-10) then - emax=-1.d0 - exit - endif - enddo - if(emax.gt.0.d0) nelas=9 - endif -! -! determining the type: isotropic, orthotropic or anisotropic -! - if(nelas.le.2) then - mattyp=1 - elseif(nelas.le.9) then - mattyp=2 - else - mattyp=3 - endif -! - else -! - nelconst=nelcon(1,imat) -! - if(nelconst.lt.0) then -! -! inelastic material or user material -! - if(nelconst.eq.-1) then - nelconst=3 - elseif(nelconst.eq.-2) then - nelconst=3 - elseif(nelconst.eq.-3) then - nelconst=2 - elseif(nelconst.eq.-4) then - nelconst=3 - elseif(nelconst.eq.-5) then - nelconst=6 - elseif(nelconst.eq.-6) then - nelconst=9 - elseif(nelconst.eq.-7) then - nelconst=3 - elseif(nelconst.eq.-8) then - nelconst=7 - elseif(nelconst.eq.-9) then - nelconst=12 - elseif(nelconst.eq.-10) then - nelconst=2 - elseif(nelconst.eq.-11) then - nelconst=4 - elseif(nelconst.eq.-12) then - nelconst=6 - elseif(nelconst.eq.-13) then - nelconst=5 - elseif(nelconst.eq.-14) then - nelconst=6 - elseif(nelconst.eq.-15) then - nelconst=3 - elseif(nelconst.eq.-16) then - nelconst=6 - elseif(nelconst.eq.-17) then - nelconst=9 - elseif(nelconst.eq.-50) then - nelconst=5 - elseif(nelconst.eq.-51) then - nelconst=2 - elseif(nelconst.eq.-52) then - nelconst=5 - elseif(nelconst.le.-100) then - nelconst=-nelconst-100 - endif -! - endif -! -! in case no initial temperatures are defined, the calculation -! is assumed athermal, and the first available set material -! constants are used -! - if(ithermal.eq.0) then - if(ihyper.ne.1) then - do k=1,nelconst - elconloc(k)=elcon(k,1,imat) - enddo - else - do k=1,nelconst - elconloc(k)=elcon(k,1,imat) - enddo -! - itemp=1 -! - if((kode.lt.-50).and.(kode.gt.-100)) then - plconloc(1)=0.d0 - plconloc(2)=0.d0 - plconloc(3)=0.d0 - plconloc(81)=nplicon(1,imat)+0.5d0 - plconloc(82)=nplkcon(1,imat)+0.5d0 -! -! isotropic hardening -! - if(nplicon(1,imat).ne.0) then - kin=0 - call plcopy(plicon,nplicon,plconloc,npmat_,ntmat_, - & imat,itemp,i,kin) - endif -! -! kinematic hardening -! - if(nplkcon(1,imat).ne.0) then - kin=1 - call plcopy(plkcon,nplkcon,plconloc,npmat_,ntmat_, - & imat,itemp,i,kin) - endif -! - endif -! - endif - else -! -! calculating the expansion coefficients -! - call ident2(alcon(0,1,imat),t1l,nalcon(2,imat),seven,id) - if(nalcon(2,imat).eq.0) then - do k=1,6 - alph(k)=0.d0 - enddo - continue - elseif(nalcon(2,imat).eq.1) then - do k=1,nalcon(1,imat) - alph(k)=alcon(k,1,imat)*(t1l-alzero(imat)) - enddo - elseif(id.eq.0) then - do k=1,nalcon(1,imat) - alph(k)=alcon(k,1,imat)*(t1l-alzero(imat)) - enddo - elseif(id.eq.nalcon(2,imat)) then - do k=1,nalcon(1,imat) - alph(k)=alcon(k,id,imat)*(t1l-alzero(imat)) - enddo - else - do k=1,nalcon(1,imat) - alph(k)=(alcon(k,id,imat)+ - & (alcon(k,id+1,imat)-alcon(k,id,imat))* - & (t1l-alcon(0,id,imat))/ - & (alcon(0,id+1,imat)-alcon(0,id,imat))) - & *(t1l-alzero(imat)) - enddo - endif -! -! subtracting the initial temperature influence -! - call ident2(alcon(0,1,imat),t0l,nalcon(2,imat),seven,id) - if(nalcon(2,imat).eq.0) then - continue - elseif(nalcon(2,imat).eq.1) then - do k=1,nalcon(1,imat) - alph(k)=alph(k)-alcon(k,1,imat)*(t0l-alzero(imat)) - enddo - elseif(id.eq.0) then - do k=1,nalcon(1,imat) - alph(k)=alph(k)-alcon(k,1,imat)*(t0l-alzero(imat)) - enddo - elseif(id.eq.nalcon(2,imat)) then - do k=1,nalcon(1,imat) - alph(k)=alph(k)-alcon(k,id,imat)*(t0l-alzero(imat)) - enddo - else - do k=1,nalcon(1,imat) - alph(k)=alph(k)-(alcon(k,id,imat)+ - & (alcon(k,id+1,imat)-alcon(k,id,imat))* - & (t0l-alcon(0,id,imat))/ - & (alcon(0,id+1,imat)-alcon(0,id,imat))) - & *(t0l-alzero(imat)) - enddo - endif -! -! storing the thermal strains -! - if(nalcon(1,imat).eq.1) then - do k=1,3 - eth(k)=alph(1) - enddo - do k=4,6 - eth(k)=0.d0 - enddo - elseif(nalcon(1,imat).eq.3) then - do k=1,3 - eth(k)=alph(k) - enddo - do k=4,6 - eth(k)=0.d0 - enddo - else - do k=1,6 - eth(k)=alph(k) - enddo - endif -! -! calculating the hardening coefficients -! -! for the calculation of the stresses, the whole curve -! has to be stored: -! plconloc(2*k-1), k=1...20: equivalent plastic strain values (iso) -! plconloc(2*k),k=1...20: corresponding stresses (iso) -! plconloc(39+2*k),k=1...20: equivalent plastic strain values (kin) -! plconloc(40+2*k),k=1...20: corresponding stresses (kin) -! -! initialization -! - if((kode.lt.-50).and.(kode.gt.-100)) then - plconloc(1)=0.d0 - plconloc(2)=0.d0 - plconloc(3)=0.d0 - plconloc(81)=nplicon(1,imat)+0.5d0 - plconloc(82)=nplkcon(1,imat)+0.5d0 -! -! isotropic hardening -! - if(nplicon(1,imat).ne.0) then -! - if(nplicon(0,imat).eq.1) then - id=-1 - else - call ident2(plicon(0,1,imat),t1l,nplicon(0,imat), - & 2*npmat_+1,id) - endif -! - if(nplicon(0,imat).eq.0) then - continue - elseif((nplicon(0,imat).eq.1).or.(id.eq.0).or. - & (id.eq.nplicon(0,imat))) then - if(id.le.0) then - itemp=1 - else - itemp=id - endif - kin=0 - call plcopy(plicon,nplicon,plconloc,npmat_,ntmat_, - & imat,itemp,i,kin) - if((id.eq.0).or.(id.eq.nplicon(0,imat))) then - endif - else - kin=0 - call plmix(plicon,nplicon,plconloc,npmat_,ntmat_, - & imat,id+1,t1l,i,kin) - endif - endif -! -! kinematic hardening -! - if(nplkcon(1,imat).ne.0) then -! - if(nplkcon(0,imat).eq.1) then - id=-1 - else - call ident2(plkcon(0,1,imat),t1l,nplkcon(0,imat), - & 2*npmat_+1,id) - endif -! - if(nplkcon(0,imat).eq.0) then - continue - elseif((nplkcon(0,imat).eq.1).or.(id.eq.0).or. - & (id.eq.nplkcon(0,imat))) then - if(id.le.0)then - itemp=1 - else - itemp=id - endif - kin=1 - call plcopy(plkcon,nplkcon,plconloc,npmat_,ntmat_, - & imat,itemp,i,kin) - if((id.eq.0).or.(id.eq.nplkcon(0,imat))) then - endif - else - kin=1 - call plmix(plkcon,nplkcon,plconloc,npmat_,ntmat_, - & imat,id+1,t1l,i,kin) - endif - endif - endif -! -! calculating the elastic constants -! - call ident2(elcon(0,1,imat),t1l,nelcon(2,imat),ncmat_+1,id) - if(nelcon(2,imat).eq.0) then - continue - elseif(nelcon(2,imat).eq.1) then -c if(ihyper.ne.1) then -c do k=1,nelconst -c elconloc(k)=elcon(k,1,imat) -c enddo -c else - do k=1,nelconst - elconloc(k)=elcon(k,1,imat) - enddo -c endif - elseif(id.eq.0) then -c if(ihyper.ne.1) then -c do k=1,nelconst -c elconloc(k)=elcon(k,1,imat) -c enddo -c else - do k=1,nelconst - elconloc(k)=elcon(k,1,imat) - enddo -c endif - elseif(id.eq.nelcon(2,imat)) then -c if(ihyper.ne.1) then -c do k=1,nelconst -c elconloc(k)=elcon(k,id,imat) -c enddo -c else - do k=1,nelconst - elconloc(k)=elcon(k,id,imat) - enddo -c endif - else -c if(ihyper.ne.1) then -c do k=1,nelconst -c elconloc(k)=elcon(k,id,imat)+ -c & (elcon(k,id+1,imat)-elcon(k,id,imat))* -c & (t1l-elcon(0,id,imat))/ -c & (elcon(0,id+1,imat)-elcon(0,id,imat)) -c enddo -c else - do k=1,nelconst - elconloc(k)=elcon(k,id,imat)+ - & (elcon(k,id+1,imat)-elcon(k,id,imat))* - & (t1l-elcon(0,id,imat))/ - & (elcon(0,id+1,imat)-elcon(0,id,imat)) - enddo -c endif - endif -! -! modifying the thermal constants if anisotropic and -! a transformation was defined -! - if((iorien.ne.0).and.(nalcon(1,imat).gt.1)) then -! -! calculating the transformation matrix -! - call transformatrix(orab(1,iorien),pgauss,skl) -! -! transforming the thermal strain -! - xa(1,1)=eth(1) - xa(1,2)=eth(4) - xa(1,3)=eth(5) - xa(2,1)=eth(4) - xa(2,2)=eth(2) - xa(2,3)=eth(6) - xa(3,1)=eth(5) - xa(3,2)=eth(6) - xa(3,3)=eth(3) -! - do jj=1,6 - eth(jj)=0.d0 - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - eth(jj)=eth(jj)+ - & xa(j3,j4)*skl(j1,j3)*skl(j2,j4) - enddo - enddo - enddo - endif - endif - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/materialdata_rho.f calculix-ccx-2.3/ccx_2.1/src/materialdata_rho.f --- calculix-ccx-2.1/ccx_2.1/src/materialdata_rho.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materialdata_rho.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materialdata_rho(rhcon,nrhcon,imat,rho, - & t1l,ntmat_) -! - implicit none -! -! determines the density of the material -! - integer nrhcon(*),imat,two,ntmat_,id -! - real*8 rhcon(0:1,ntmat_,*),rho,t1l -! - two=2 -! -c if(ithermal.eq.0) then -c rho=rhcon(1,1,imat) -c else - call ident2(rhcon(0,1,imat),t1l,nrhcon(imat),two,id) - if(nrhcon(imat).eq.0) then - continue - elseif(nrhcon(imat).eq.1) then - rho=rhcon(1,1,imat) - elseif(id.eq.0) then - rho=rhcon(1,1,imat) - elseif(id.eq.nrhcon(imat)) then - rho=rhcon(1,id,imat) - else - rho=rhcon(1,id,imat)+ - & (rhcon(1,id+1,imat)-rhcon(1,id,imat))* - & (t1l-rhcon(0,id,imat))/ - & (rhcon(0,id+1,imat)-rhcon(0,id,imat)) - endif -c endif - return - end -! diff -Nru calculix-ccx-2.1/ccx_2.1/src/materialdata_sp.f calculix-ccx-2.3/ccx_2.1/src/materialdata_sp.f --- calculix-ccx-2.1/ccx_2.1/src/materialdata_sp.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materialdata_sp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,110 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materialdata_sp(elcon,nelcon,imat,ntmat_,i,t0l,t1l, - & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) -! - implicit none -! -! determines the material data for element i -! - integer nelcon(2,*),imat,i,k,kin,ntmat_,nelconst,kode, - & itemp,ncmat_,id,nplicon(0:ntmat_,*),npmat_ -! - real*8 elcon(0:ncmat_,ntmat_,*),t0l,t1l,elconloc(21), - & plicon(0:2*npmat_,ntmat_,*),plconloc(82) -! -! nelconst: # constants read from file -! -! calculating the hardening coefficients -! -! for the calculation of the spring stiffness, the whole curve -! has to be stored: -! plconloc(2*k-1), k=1...20: displacement -! plconloc(2*k),k=1...20: force -! - if(kode.lt.-50) then - plconloc(1)=0.d0 - plconloc(2)=0.d0 - plconloc(3)=0.d0 - plconloc(81)=nplicon(1,imat)+0.5d0 - plconloc(82)=0.5d0 -! -! nonlinear spring characteristic -! - if(nplicon(1,imat).ne.0) then -! - if(nplicon(0,imat).eq.1) then - id=-1 - else - call ident2(plicon(0,1,imat),t1l,nplicon(0,imat), - & 2*npmat_+1,id) - endif -! - if(nplicon(0,imat).eq.0) then - continue - elseif((nplicon(0,imat).eq.1).or.(id.eq.0).or. - & (id.eq.nplicon(0,imat))) then - if(id.le.0) then - itemp=1 - else - itemp=id - endif - kin=0 - call plcopy(plicon,nplicon,plconloc,npmat_,ntmat_, - & imat,itemp,i,kin) - if((id.eq.0).or.(id.eq.nplicon(0,imat))) then - endif - else - kin=0 - call plmix(plicon,nplicon,plconloc,npmat_,ntmat_, - & imat,id+1,t1l,i,kin) - endif - endif - else -! -! linear spring characteristic -! - nelconst=nelcon(1,imat) - call ident2(elcon(0,1,imat),t1l,nelcon(2,imat),ncmat_+1,id) - if(nelcon(2,imat).eq.0) then - continue - elseif(nelcon(2,imat).eq.1) then - do k=1,nelconst - elconloc(k)=elcon(k,1,imat) - enddo - elseif(id.eq.0) then - do k=1,nelconst - elconloc(k)=elcon(k,1,imat) - enddo - elseif(id.eq.nelcon(2,imat)) then - do k=1,nelconst - elconloc(k)=elcon(k,id,imat) - enddo - else - do k=1,nelconst - elconloc(k)=elcon(k,id,imat)+ - & (elcon(k,id+1,imat)-elcon(k,id,imat))* - & (t1l-elcon(0,id,imat))/ - & (elcon(0,id+1,imat)-elcon(0,id,imat)) - enddo - endif - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/materialdata_tg.f calculix-ccx-2.3/ccx_2.1/src/materialdata_tg.f --- calculix-ccx-2.1/ccx_2.1/src/materialdata_tg.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materialdata_tg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,90 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materialdata_tg(imat,ntmat_,t1l,shcon,nshcon,sph,r, - & dvi,rhcon,nrhcon,rho) -! - implicit none -! -! determines the following gas properties: the density, -! the specific heat, the dynamic viscosity and the specific gas constant -! - integer imat,ntmat_,id,nshcon(*),two,four,nrhcon(*) -! - real*8 t1l,shcon(0:3,ntmat_,*),sph,r,dvi,rhcon(0:1,ntmat_,*), - & rho -! - two=2 - four=4 -! -! calculating the density (needed for liquids) -! - call ident2(rhcon(0,1,imat),t1l,nrhcon(imat),two,id) - if(nrhcon(imat).eq.0) then - rho=0.d0 - continue - elseif(nrhcon(imat).eq.1) then - rho=rhcon(1,1,imat) - elseif(id.eq.0) then - rho=rhcon(1,1,imat) - elseif(id.eq.nrhcon(imat)) then - rho=rhcon(1,id,imat) - else - rho=rhcon(1,id,imat)+ - & (rhcon(1,id+1,imat)-rhcon(1,id,imat))* - & (t1l-rhcon(0,id,imat))/ - & (rhcon(0,id+1,imat)-rhcon(0,id,imat)) - endif -! -! calculating the specific heat and the dynamic viscosity -! - call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) - if(nshcon(imat).eq.0) then - continue - elseif(nshcon(imat).eq.1) then - sph=shcon(1,1,imat) - dvi=shcon(2,1,imat) - elseif(id.eq.0) then - sph=shcon(1,1,imat) - dvi=shcon(2,1,imat) - elseif(id.eq.nshcon(imat)) then - sph=shcon(1,id,imat) - dvi=shcon(2,id,imat) - else - sph=shcon(1,id,imat)+ - & (shcon(1,id+1,imat)-shcon(1,id,imat))* - & (t1l-shcon(0,id,imat))/ - & (shcon(0,id+1,imat)-shcon(0,id,imat)) - dvi=shcon(2,id,imat)+ - & (shcon(2,id+1,imat)-shcon(2,id,imat))* - & (t1l-shcon(0,id,imat))/ - & (shcon(0,id+1,imat)-shcon(0,id,imat)) - endif -! -! specific gas constant -! - r=shcon(3,1,imat) -! - return - end - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/materialdata_th.f calculix-ccx-2.3/ccx_2.1/src/materialdata_th.f --- calculix-ccx-2.1/ccx_2.1/src/materialdata_th.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materialdata_th.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,136 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materialdata_th(cocon,ncocon,imat,iorien,pgauss,orab, - & ntmat_,coconloc,mattyp,t1l,rhcon,nrhcon,rho,shcon,nshcon,sph, - & xstiff,iint,iel,istiff,mi) -! - implicit none -! -! determines the density, the specific heat and the conductivity -! in an integration point with coordinates pgauss -! - integer ncocon(2,*),imat,iorien,k,mattyp,mi(2), - & ntmat_,id,two,four,seven,nrhcon(*),nshcon(*), - & iint,iel,ncond,istiff,ncoconst -! - real*8 cocon(0:6,ntmat_,*),orab(7,*),coconloc(6),t1l, - & pgauss(3),rhcon(0:1,ntmat_,*), - & shcon(0:3,ntmat_,*),rho,sph,xstiff(27,mi(1),*) -! - two=2 - four=4 - seven=7 -! - if(istiff.eq.1) then -! - ncond=ncocon(1,imat) - if((ncond.le.-100).or.(iorien.ne.0)) ncond=6 -! -! calculating the density (needed for the capacity matrix) -! - call ident2(rhcon(0,1,imat),t1l,nrhcon(imat),two,id) - if(nrhcon(imat).eq.0) then - continue - elseif(nrhcon(imat).eq.1) then - rho=rhcon(1,1,imat) - elseif(id.eq.0) then - rho=rhcon(1,1,imat) - elseif(id.eq.nrhcon(imat)) then - rho=rhcon(1,id,imat) - else - rho=rhcon(1,id,imat)+ - & (rhcon(1,id+1,imat)-rhcon(1,id,imat))* - & (t1l-rhcon(0,id,imat))/ - & (rhcon(0,id+1,imat)-rhcon(0,id,imat)) - endif -! -! calculating the specific heat (needed for the capacity matrix) -! - call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) - if(nshcon(imat).eq.0) then - continue - elseif(nshcon(imat).eq.1) then - sph=shcon(1,1,imat) - elseif(id.eq.0) then - sph=shcon(1,1,imat) - elseif(id.eq.nshcon(imat)) then - sph=shcon(1,id,imat) - else - sph=shcon(1,id,imat)+ - & (shcon(1,id+1,imat)-shcon(1,id,imat))* - & (t1l-shcon(0,id,imat))/ - & (shcon(0,id+1,imat)-shcon(0,id,imat)) - endif -! -! determining the conductivity coefficients -! - do k=1,6 - coconloc(k)=xstiff(21+k,iint,iel) - enddo -! -! determining the type: isotropic, orthotropic or anisotropic -! - if(ncond.le.1) then - mattyp=1 - elseif(ncond.le.3) then - mattyp=2 - else - mattyp=3 - endif -! - else -! - ncoconst=ncocon(1,imat) - if(ncoconst.le.-100) ncoconst=-ncoconst-100 -! -! calculating the conductivity coefficients -! - call ident2(cocon(0,1,imat),t1l,ncocon(2,imat),seven,id) - if(ncocon(2,imat).eq.0) then - do k=1,6 - coconloc(k)=0.d0 - enddo - continue - elseif(ncocon(2,imat).eq.1) then - do k=1,ncoconst - coconloc(k)=cocon(k,1,imat) - enddo - elseif(id.eq.0) then - do k=1,ncoconst - coconloc(k)=cocon(k,1,imat) - enddo - elseif(id.eq.ncocon(2,imat)) then - do k=1,ncoconst - coconloc(k)=cocon(k,id,imat) - enddo - else - do k=1,ncoconst - coconloc(k)=(cocon(k,id,imat)+ - & (cocon(k,id+1,imat)-cocon(k,id,imat))* - & (t1l-cocon(0,id,imat))/ - & (cocon(0,id+1,imat)-cocon(0,id,imat))) - & - enddo - endif - endif -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/materials.f calculix-ccx-2.3/ccx_2.1/src/materials.f --- calculix-ccx-2.1/ccx_2.1/src/materials.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/materials.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine materials(inpc,textpart,matname,nmat,nmat_, - & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! -! reading the input deck: *MATERIAL -! - implicit none -! - character*1 inpc(*) - character*80 matname(*) - character*132 textpart(16) -! - integer nmat,nmat_,istep,istat,n,key,i,irstrt,iline,ipol,inl, - & ipoinp(2,*),inp(3,*),ipoinpc(0:*) -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in materials: *MATERIAL should be placed' - write(*,*) ' before all step definitions' - stop - endif -! - nmat=nmat+1 - if(nmat.gt.nmat_) then - write(*,*) '*ERROR in materials: increase nmat_' - stop - endif -! - do i=2,n - if(textpart(i)(1:5).eq.'NAME=') then - matname(nmat)=textpart(i)(6:85) - if(textpart(i)(86:86).ne.' ') then - write(*,*) '*ERROR in materials: material name too long' - write(*,*) ' (more than 80 characters)' - write(*,*) ' material name:',textpart(i)(1:132) - stop - endif - exit - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/matrixstorage.c calculix-ccx-2.3/ccx_2.1/src/matrixstorage.c --- calculix-ccx-2.1/ccx_2.1/src/matrixstorage.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/matrixstorage.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,503 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" -#include "matrixstorage.h" - -void matrixstorage(double *ad, double **aup, double *adb, double *aub, - double *sigma,int *icol, int **irowp, - int *neq, int *nzs, int *ntrans, int *inotr, - double *trab, double *co, int *nk, int *nactdof, - char *jobnamec, int *mi){ - - char fsti[132]="",fmas[132]=""; - int i,j,k,l,*irow=NULL,*ai=NULL,*aj=NULL,kflag=2,ndim,jref,kstart,klen, - *ipoint=NULL,npoint_,npoint,neq3,index,i3l,i3c,i3lo,i3co,idof,n,il, - ic,id,itrans,ndim2,*ipoindex=NULL,mt=mi[1]+1; - double *au=NULL,*aa=NULL,*trans=NULL,*aa3=NULL,a[9]; - FILE *f2,*f3; - - strcpy(fsti,jobnamec); - strcat(fsti,".sti"); - - printf(" Storing the stiffness matrix in file %s \n\n",fsti); - printf(" *INFO: this routine only works in the absence of SPC's!\n and in the absence of transformations in combination\n with equations\n\n "); - - if((f2=fopen(fsti,"wb"))==NULL){ - printf("*ERROR in matrixstorage: cannot open %s for writing...\n",fsti); - FORTRAN(stop,()); - } - - au=*aup; - irow=*irowp; - - ndim=*neq+*nzs; - - itrans=0; - if(*ntrans!=0){ - for(i=0;i<*nk;i++){ - if(inotr[2*i]!=0){ - itrans=1; - break; - } - } - } - - /* stiffness matrix */ - - if(itrans==0){ - - /* no transformation */ - - aa=NNEW(double,ndim); - ai=NNEW(int,ndim); - aj=NNEW(int,ndim); - - k=0; - for(i=0;i<*neq;i++){ - ai[k]=i+1; - aj[k]=i+1; - aa[k]=ad[i]; - k++; - } - l=0; - for(i=0;i<*neq;i++){ - for(j=0;jnpoint_){ - npoint_=(int)(1.1*npoint_); - RENEW(ipoint,int,npoint_); - RENEW(ipoindex,int,npoint_); - } - index+=9; - ipoint[npoint-1]=k; - ipoindex[npoint-1]=index; - } - else{ - index=ipoindex[id-1]; - } - aa3[index+3*i3co+i3lo]=aa[i]; - } - - /* defining the transformation matrix (diagonal matrix of - 3x3 submatrices */ - - trans=NNEW(double,9*neq3); - for (i=0;i<*nk;i++){ - idof=nactdof[mt*i+1]; - if(idof==0) continue; - itrans=inotr[2*i]; - if(itrans==0){ - for(j=0;j<9;j++){ - trans[3*(idof-1)+j]=0.; - } - trans[3*(idof-1)]=1.; - trans[3*(idof-1)+4]=1.; - trans[3*(idof-1)+8]=1.; - } - else{ - FORTRAN(transformatrix,(&trab[7*itrans-7],&co[3*i],a)); - for(j=0;j<9;j++){ - trans[3*(idof-1)+j]=a[j]; - } - } - } - - /* postmultiplying the matrix with the transpose of the - transformation matrix */ - - for(i=0;iic) continue; - k++; - ai[k]=il; - aj[k]=ic; - aa[k]=aa3[9*i+j]; - } - } - free(aa3);free(ipoint);free(ipoindex);free(trans); - } - - FORTRAN(isortiid,(aj,ai,aa,&ndim,&kflag)); - - k=0; - for(i=0;i<*neq;i++){ - jref=aj[k]; - kstart=k; - do{ - k++; - if(aj[k]!=jref) break; - }while(1); - klen=k-kstart; - FORTRAN(isortiid,(&ai[kstart],&aj[kstart],&aa[kstart],&klen,&kflag)); - } - - for(i=0;inpoint_){ - npoint_=(int)(1.1*npoint_); - RENEW(ipoint,int,npoint_); - RENEW(ipoindex,int,npoint_); - } - index+=9; - ipoint[npoint-1]=k; - ipoindex[npoint-1]=index; - } - else{ - index=ipoindex[id-1]; - } - aa3[index+3*i3co+i3lo]=aa[i]; - } - - /* defining the transformation matrix (diagonal matrix of - 3x3 submatrices */ - - trans=NNEW(double,9*neq3); - for (i=0;i<*nk;i++){ - idof=nactdof[mt*i+1]; - if(idof==0) continue; - itrans=inotr[2*i]; - if(itrans==0){ - for(j=0;j<9;j++){ - trans[3*(idof-1)+j]=0.; - } - trans[3*(idof-1)]=1.; - trans[3*(idof-1)+4]=1.; - trans[3*(idof-1)+8]=1.; - } - else{ - FORTRAN(transformatrix,(&trab[7*itrans-7],&co[3*i],a)); - for(j=0;j<9;j++){ - trans[3*(idof-1)+j]=a[j]; - } - } - } - - /* postmultiplying the matrix with the transpose of the - transformation matrix */ - - for(i=0;iic) continue; - k++; - ai[k]=il; - aj[k]=ic; - aa[k]=aa3[9*i+j]; - } - } - free(aa3);free(ipoint);free(ipoindex);free(trans); - } - - FORTRAN(isortiid,(aj,ai,aa,&ndim,&kflag)); - - k=0; - for(i=0;i<*neq;i++){ - jref=aj[k]; - kstart=k; - do{ - k++; - if(aj[k]!=jref) break; - }while(1); - klen=k-kstart; - FORTRAN(isortiid,(&ai[kstart],&aj[kstart],&aa[kstart],&klen,&kflag)); - } - - for(i=0;i -#include -#include -#include -#include "CalculiX.h" - -/** - *Multiplication of (Bd)^T*A*Bd -*/ - -void multimortar(double *au, double *ad, int *irow, int *jq, int *nzs, - double *aubd, double *bdd, int *irowbd, int *jqbd, int *nzsbd, - double **aucp, double *adc, int **irowcp, int *jqc, int *nzsc, - double *auqdt,int *irowqdt,int *jqqdt,int *nzsqdt, - int *neq,double *b, double *bhat){ - - int i, j, k, l,m,n, icol, kflag,index,indexold, *irowi=NULL,ifree, - *irows=NULL, *irowc=NULL, *jqi=NULL, *jqs=NULL,nzsi, *irowbdt=NULL, - *mast1=NULL,*ipointer=NULL,*irowqd=NULL,*jqqd=NULL,nzsqd; - - double *adi=NULL, *aui=NULL, *aus=NULL, value, *aux=NULL, *auc=NULL, - *auqd=NULL,*unitmatrix=NULL; - - irowc = *irowcp; auc=*aucp; - - //Reference: Stefan Hueber's thesis page 28-33 - - - /* copy aubd into auqdt (transpose of qd) */ - - for (j=0;j<*nzsbd;j++){ - auqdt[j]=aubd[j]; - irowqdt[j]=irowbd[j]; - } - for(j=0;j nk' - stop - elseif(ialset(nalset+2).gt.nk) then - write(*,*) '*WARNING in noelsets: end value in' - write(*,*) ' set ',set(iset),' > nk;' - write(*,*) ' replaced by nk' - ialset(nalset+2)=nk - elseif(ialset(nalset+3).le.0) then - write(*,*) '*ERROR in noelsets: increment in' - write(*,*) ' set ',set(iset),' <=0' - stop - endif - else - if(ialset(nalset+1).gt.ne) then - write(*,*) '*ERROR in noelsets: starting value in' - write(*,*) ' set ',set(iset),' > ne' - stop - elseif(ialset(nalset+2).gt.ne) then - write(*,*) '*WARNING in noelsets: end value in' - write(*,*) ' set ',set(iset),' > ne;' - write(*,*) ' replaced by ne' - ialset(nalset+2)=nk - elseif(ialset(nalset+3).le.0) then - write(*,*) '*ERROR in noelsets: increment in' - write(*,*) ' set ',set(iset),' <=0' - stop - endif - endif - if(ialset(nalset+1).eq.ialset(nalset+2)) then - ialset(nalset+2)=0 - ialset(nalset+3)=0 - nalset=nalset+1 - else - ialset(nalset+3)=-ialset(nalset+3) - nalset=nalset+3 - endif - iendset(iset)=nalset - else - do i=1,n - read(textpart(i)(1:10),'(i10)',iostat=istat) - & ialset(nalset+1) - if(istat.gt.0) then -! -! set name -! - noelset=textpart(i)(1:80) - noelset(81:81)=' ' - ipos=index(noelset,' ') - if(kode.eq.0) then - noelset(ipos:ipos)='N' - else - noelset(ipos:ipos)='E' - endif - do j=1,nset - if(j.eq.iset)cycle - if(noelset.eq.set(j)) then - m=iendset(j)-istartset(j)+1 - do k=1,m - ialset(nalset+k)=ialset(istartset(j)+k-1) - enddo - nalset=nalset+m - exit - endif - enddo - if(noelset.ne.set(j)) then - noelset(ipos:ipos)=' ' - if(kode.eq.0) then - write(*,*) '*ERROR in noelsets: node set ', - & noelset - else - write(*,*) '*ERROR in noelsets: element set ', - & noelset - endif - write(*,*) ' has not been defined yet' - stop - endif - else -! -! node or element number -! - if(kode.eq.0) then - if(ialset(nalset+1).gt.nk) then - write(*,*) '*WARNING in noelsets: value ', - & ialset(nalset+1) - write(*,*) ' in set ',set(iset),' > nk' - else - nalset=nalset+1 - endif - else - if(ialset(nalset+1).gt.ne) then - write(*,*) '*WARNING in noelsets: value ', - & ialset(nalset+1) - write(*,*) ' in set ',set(iset),' > ne' - else - nalset=nalset+1 - endif - endif - endif - enddo - iendset(iset)=nalset - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/nonlingeo.c calculix-ccx-2.3/ccx_2.1/src/nonlingeo.c --- calculix-ccx-2.1/ccx_2.1/src/nonlingeo.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/nonlingeo.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1688 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif -#ifdef PARDISO - #include "pardiso.h" -#endif - - -void nonlingeo(double **cop, int *nk, int **konp, int **ipkonp, char **lakonp, - int *ne, - int *nodeboun, int *ndirboun, double *xboun, int *nboun, - int **ipompcp, int **nodempcp, double **coefmpcp, char **labmpcp, - int *nmpc, - int *nodeforc, int *ndirforc,double *xforc, int *nforc, - int *nelemload, char *sideload, double *xload,int *nload, - double *ad, double *au, double *b, int *nactdof, - int **icolp, int *jq, int **irowp, int *neq, int *nzl, - int *nmethod, int **ikmpcp, int **ilmpcp, int *ikboun, - int *ilboun, - double *elcon, int *nelcon, double *rhcon, int *nrhcon, - double *alcon, int *nalcon, double *alzero, int **ielmatp, - int **ielorienp, int *norien, double *orab, int *ntmat_, - double *t0, double *t1, double *t1old, - int *ithermal,double *prestr, int *iprestr, - double **voldp,int *iperturb, double *sti, int *nzs, - int *kode, double *adb, double *aub,char *filab, - int *idrct, int *jmax, int *jout, double *tinc, - double *tper, double *tmin, double *tmax, double *eme, - double *xbounold, double *xforcold, double *xloadold, - double *veold, double *accold, - char *amname, double *amta, int *namta, int *nam, - int *iamforc, int *iamload, - int *iamt1, double *alpha, int *iexpl, - int *iamboun, double *plicon, int *nplicon, double *plkcon, - int *nplkcon, - double *xstate, int *npmat_, int *istep, double *ttime, - char *matname, double *qaold, int *mi, - int *isolver, int *ncmat_, int *nstate_, int *iumat, - double *cs, int *mcs, int *nkon, double **enerp, int *mpcinfo, - int *nnn, char *output, - double *shcon, int *nshcon, double *cocon, int *ncocon, - double *physcon, int *nflow, double *ctrl, - char *set, int *nset, int *istartset, - int *iendset, int *ialset, int *nprint, char *prlab, - char *prset, int *nener,int *ikforc,int *ilforc, double *trab, - int *inotr, int *ntrans, double **fmpcp, char *cbody, - int *ibody, double *xbody, int *nbody, double *xbodyold, - int *ielprop, double *prop, int *ntie, char *tieset, - int *itpamp, int *iviewfile, char *jobnamec, double *tietol){ - - char description[13]=" ",*lakon=NULL,jobnamef[396]="", - *sideface=NULL,*labmpc=NULL; - - int *inum=NULL,k,iout=0,icntrl,iinc=0,jprint=0,iit=-1,jnz=0, - icutb=0,istab=0,ifreebody,uncoupled,n1,n2,nzlc, - iperturb_sav[2],ilin,*icol=NULL,*irow=NULL,ielas=0,icmd=0, - memmpc_,mpcfree,icascade,maxlenmpc,*nodempc=NULL,*iaux=NULL, - *nodempcref=NULL,memmpcref_,mpcfreeref,*itg=NULL, - *ieg=NULL,ntg=0,ntr,ntm,*iptri=NULL,*kontri=NULL,*nloadtr=NULL, - *ipiv=NULL,*idist=NULL,ntri,newstep,mode=-1,noddiam=-1, - ntrit,*inocs=NULL,inewton=0,*ipobody=NULL,*nacteq=NULL, - *nactdog=NULL,nteq,network,*itietri=NULL,*koncont=NULL, - ncont,ne0,nkon0,*ipkon=NULL,*kon=NULL,*ielorien=NULL, - *ielmat=NULL,ncone,inext,itp=0,symmetryflag=0,inputformat=0, - *iruc=NULL,iitterm=0,turbulent,ngraph=1,ismallsliding=0, - *ifcont1=NULL,*ifcont2=NULL,*ipompc=NULL,*ikmpc=NULL,*ilmpc=NULL, - *itiefac=NULL,*islavsurf=NULL,*islavnode=NULL,*imastnode=NULL, - *nslavnode=NULL,*nmastnode=NULL,mortar=0,*imastop=NULL, - *iponoels=NULL,*inoels=NULL,nzsc,*irowc=NULL,*jqc=NULL, - *islavact=NULL,*irowqdt=NULL,*jqqdt=NULL,nzsqdt,*icolc=NULL, - *irowbd=NULL,*jqbd=NULL,mt=mi[1]+1,*nactdofinv=NULL,*ipe=NULL, - *ime=NULL,*ikactmech=NULL,nactmech; - - int mass[2]={0,0}, stiffness=1, buckling=0, rhsi=1, intscheme=0,idiscon=0, - coriolis=0,*ipogn=NULL,*ign=NULL,*ipneigh=NULL,*neigh=NULL, - *nelemface=NULL,*ipoface=NULL,*nodface=NULL,*ifreestream=NULL, - *isolidsurf=NULL,*neighsolidsurf=NULL,*iponoel=NULL,*inoel=NULL, - nef=0,nface,nfreestream,nsolidsurf,inoelfree,i,indexe,cfd=0,id, - node,networknode,*jqtemp=NULL,*icoltemp=NULL,*irowtemp=NULL, - nzstemp[3],iflagact=0; - - double *stn=NULL,*v=NULL,*een=NULL,cam[5],*epn=NULL,*cg=NULL, - *f=NULL,*fn=NULL,qa[3]={0.,0.,-1.},qam[2]={0.,0.},dtheta,theta, - err,ram[4]={0.,0.,0.,0.}, - ram1[2]={0.,0.},ram2[2]={0.,0.},deltmx,*auc=NULL,*adc=NULL, - uam[2]={0.,0.},*vini=NULL,*ac=NULL,qa0,qau,ea,*straight=NULL, - *t1act=NULL,qamold[2],*xbounact=NULL,*bc=NULL,*bdd=NULL, - *xforcact=NULL,*xloadact=NULL,*fext=NULL,*gap=NULL, - reltime,time,bet=0.,gam=0.,*aux1=NULL,*aux2=NULL,dtime,*fini=NULL, - *fextini=NULL,*veini=NULL,*accini=NULL,*xstateini=NULL, - *ampli=NULL,scal1,*eei=NULL,*t1ini=NULL,*auqdt=NULL, - *xbounini=NULL,dev,*xstiff=NULL,*stx=NULL,*stiini=NULL, - *enern=NULL,*coefmpc=NULL,*aux=NULL,*xstaten=NULL, - *coefmpcref=NULL,*enerini=NULL,*area=NULL,*slavnor=NULL, - *tarea=NULL,*tenv=NULL,*dist=NULL,*erad=NULL,*pmid=NULL, - *fij=NULL,*e1=NULL,*e2=NULL,*e3=NULL, *qfx=NULL,*bhat=NULL, - *qfn=NULL,*co=NULL,*vold=NULL,*fenv=NULL,sigma=0., - *xbodyact=NULL,*cgr=NULL,dthetaref, *voldtu=NULL,*vr=NULL,*vi=NULL, - *stnr=NULL,*stni=NULL,*vmax=NULL,*stnmax=NULL,*fmpc=NULL,*ener=NULL, - *cstress=NULL,*lambda=NULL,*aubd=NULL, *f_cm=NULL, *f_cs=NULL, aux3, - *vectornull=NULL; - -#ifdef SGI - int token; -#endif - - if(*ithermal==4){ - uncoupled=1; - *ithermal=3; - }else{ - uncoupled=0; - } - - /* turbulence model - turbulent==0: laminar - turbulent==1: k-epsilon - turbulent==2: q-omega - turbulent==3: SST */ - - turbulent=(int)physcon[8]; - - /* invert nactdof */ - - nactdofinv=NNEW(int,mt**nk); - for(i=0;i0){ - ifreebody=*ne+1; - ipobody=NNEW(int,2*ifreebody**nbody); - for(k=1;k<=*nbody;k++){ - FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, - iendset,ialset,&inewton,nset,&ifreebody,&k)); - RENEW(ipobody,int,2*(*ne+ifreebody)); - } - RENEW(ipobody,int,2*(ifreebody-1)); - if(inewton==1){cgr=NNEW(double,4**ne);} - } - - /* for mechanical calculations: updating boundary conditions - calculated in a previous thermal step */ - - if(*ithermal<2) FORTRAN(gasmechbc,(vold,nload,sideload, - nelemload,xload,mi)); - - /* for thermal calculations: forced convection and cavity - radiation*/ - - if(*ithermal>1){ - itg=NNEW(int,*nload+3**nflow); - ieg=NNEW(int,*nflow); - iptri=NNEW(int,*nload); - kontri=NNEW(int,18**nload); - nloadtr=NNEW(int,*nload); - nacteq=NNEW(int,4**nk); - nactdog=NNEW(int,4**nk); - v=NNEW(double,mt**nk); - ipogn=NNEW(int,*nload+2**nflow); - ign=NNEW(int,4**nk); - FORTRAN(envtemp,(itg,ieg,&ntg,&ntr,sideload,nelemload, - ipkon,kon,lakon,ielmat,ne,nload,iptri, - kontri,&ntri,nloadtr,nflow,ndirboun,nactdog, - nodeboun,nacteq,nboun,ielprop,prop,&nteq, - v,&network,physcon,shcon,ntmat_,co,ipogn,ign, - vold,set,nshcon,rhcon,nrhcon,mi)); - free(ign);free(ipogn);free(v); - - if((*mcs>0)&&(ntr>0)){ - inocs=NNEW(int,*nk); - radcyc(nk,kon,ipkon,lakon,ne,cs,mcs,nkon,ialset,istartset, - iendset,&kontri,&ntri,&co,&vold,&ntrit,inocs,mi); - } - else{ntrit=ntri;} - - RENEW(itg,int,ntg); - RENEW(iptri,int,ntri); - RENEW(kontri,int,3*ntrit); - RENEW(nloadtr,int,ntr); - - area=NNEW(double,ntrit); - pmid=NNEW(double,3*ntrit); - e1=NNEW(double,3*ntrit); - e2=NNEW(double,3*ntrit); - e3=NNEW(double,4*ntrit); - dist=NNEW(double,ntrit); - idist=NNEW(int,ntrit); - - fij=NNEW(double,ntr*ntr); - tarea=NNEW(double,ntr); - tenv=NNEW(double,ntr); - fenv=NNEW(double,ntr); - erad=NNEW(double,ntr); - if(nteq>ntr){ - ntm=nteq;} - else{ - ntm=ntr;} - ac=NNEW(double,ntm*ntm); - bc=NNEW(double,ntm); - ipiv=NNEW(int,ntm); - } - - /* check for fluid elements */ - - for(i=0;i<*ne;++i){ - if(ipkon[i]<0) continue; - indexe=ipkon[i]; - if(strcmp1(&lakon[8*i],"F")==0){cfd=1;nef++;} - } - if(cfd==1){ - sideface=NNEW(char,6*nef); - nelemface=NNEW(int,6*nef); - ipoface=NNEW(int,*nk); - nodface=NNEW(int,5*6*nef); - ifreestream=NNEW(int,*nk); - isolidsurf=NNEW(int,*nk); - neighsolidsurf=NNEW(int,*nk); - iponoel=NNEW(int,*nk); - inoel=NNEW(int,3*20*nef); - FORTRAN(precfd,(nelemface,sideface,&nface,ipoface,nodface, - ne,ipkon,kon,lakon,ikboun,ilboun,xboun,nboun,nk,isolidsurf, - &nsolidsurf,ifreestream,&nfreestream,neighsolidsurf, - iponoel,inoel,&inoelfree,&nef,co,ipompc,nodempc,ikmpc,ilmpc,nmpc)); - RENEW(sideface,char,nface); - RENEW(nelemface,int,nface); - free(ipoface);free(nodface); - RENEW(ifreestream,int,nfreestream); - RENEW(isolidsurf,int,nsolidsurf); - RENEW(neighsolidsurf,int,nsolidsurf); - RENEW(inoel,int,3*inoelfree); - voldtu=NNEW(double,2**nk); - } - - /* contact conditions */ - -// ipe=NNEW(int,1);ime=NNEW(int,1); - inicont(nk,&ncont,ntie,tieset,nset,set,istartset,iendset,ialset,&itietri, - lakon,ipkon,kon,&koncont,&ncone,tietol,&ismallsliding,&itiefac, - &islavsurf,&islavnode,&imastnode,&nslavnode,&nmastnode, - &mortar,&imastop,nkon,&iponoels,&inoels,&ipe,&ime); - - if(ncont!=0){ - - if(*nener==1){ - RENEW(ener,double,mi[0]*(*ne+ncone)*2); - } - RENEW(ipkon,int,*ne+ncone); - RENEW(lakon,char,8*(*ne+ncone)); - - /* 10 instead of 9: last position is reserved for how - many dependent nodes are paired to this face */ - - RENEW(kon,int,*nkon+10*ncone); - if(*norien>0){ - RENEW(ielorien,int,*ne+ncone); - for(k=*ne;k<*ne+ncone;k++) ielorien[k]=0; - } - RENEW(ielmat,int,*ne+ncone); - for(k=*ne;k<*ne+ncone;k++) ielmat[k]=1; - cg=NNEW(double,3*ncont); - straight=NNEW(double,16*ncont); - ifcont1=NNEW(int,ncone); - ifcont2=NNEW(int,ncone); - - if(mortar==1){ - - islavact=NNEW(int,nslavnode[*ntie]); - gap=NNEW(double,nslavnode[*ntie]); - slavnor=NNEW(double,3*nslavnode[*ntie]); - - bdd=NNEW(double,neq[1]); - bhat=NNEW(double,neq[1]); - - jqqdt=NNEW(int,neq[1]+1); - - /* allocation of temperary fields: stores the structure - of the stiffness matrix without mortar contact */ - - jqtemp=NNEW(int,neq[1]+1); - irowtemp=NNEW(int,nzs[1]); - icoltemp=NNEW(int,neq[1]); - cstress=NNEW(double,neq[1]); - lambda=NNEW(double,neq[1]); - - /* contact force fields (master and slave) */ - - f_cm=NNEW(double,neq[1]); - f_cs=NNEW(double,neq[1]); - } - } - - if((icascade==2)||(ncont!=0)){ - memmpcref_=memmpc_;mpcfreeref=mpcfree; - nodempcref=NNEW(int,3*memmpc_); - for(k=0;k<3*memmpc_;k++){nodempcref[k]=nodempc[k];} - coefmpcref=NNEW(double,memmpc_); - for(k=0;k=3)){ - t1ini=NNEW(double,*nk); - t1act=NNEW(double,*nk); - for(k=0;k<*nk;++k){t1act[k]=t1old[k];} - } - - /* allocating a field for the instantaneous amplitude */ - - ampli=NNEW(double,*nam); - - /* allocating fields for nonlinear dynamics */ - - fini=NNEW(double,neq[1]); - if(*nmethod==4){ - mass[0]=1; - mass[1]=1; - aux2=NNEW(double,neq[1]); - fextini=NNEW(double,neq[1]); - veini=NNEW(double,mt**nk); - accini=NNEW(double,mt**nk); - adb=NNEW(double,neq[1]); - aub=NNEW(double,nzs[1]); - } - - if(*nstate_!=0){ - xstateini=NNEW(double,*nstate_*mi[0]**ne); - for(k=0;k<*nstate_*mi[0]**ne;++k){ - xstateini[k]=xstate[k]; - } - } - eei=NNEW(double,6*mi[0]**ne); - stiini=NNEW(double,6*mi[0]**ne); - if(*nener==1) - enerini=NNEW(double,mi[0]**ne); - - qa[0]=qaold[0]; - qa[1]=qaold[1]; - - /* normalizing the time */ - - FORTRAN(checktime,(itpamp,namta,tinc,ttime,amta,tmin,&inext,&itp)); - dtheta=(*tinc)/(*tper); - dthetaref=dtheta; - if((dtheta<=1.e-6)&&(*iexpl<=1)){ - printf("\n *ERROR in nonlingeo\n"); - printf(" increment size smaller than one millionth of step size\n"); - printf(" increase increment size\n\n"); - } - *tmin=*tmin/(*tper); - *tmax=*tmax/(*tper); - theta=0.; - - /* calculating an initial flux norm */ - - if(*ithermal!=2){ - if(qau>1.e-10){qam[0]=qau;} - else if(qa0>1.e-10){qam[0]=qa0;} - else if(qa[0]>1.e-10){qam[0]=qa[0];} - else {qam[0]=1.e-2;} - } - if(*ithermal>1){ - if(qau>1.e-10){qam[1]=qau;} - else if(qa0>1.e-10){qam[1]=qa0;} - else if(qa[1]>1.e-10){qam[1]=qa[1];} - else {qam[1]=1.e-2;} - } - - /* storing the element and topology information before introducing - contact elements */ - - ne0=*ne;nkon0=*nkon; - - /* calculating the initial acceleration at the start of the step - for dynamic calculations */ - - #include "initialaccel.c" - - if(*iexpl>1) icmd=3; - - /**************************************************************/ - /* starting the loop over the increments */ - /**************************************************************/ - - newstep=1; - - /* storing the element and topology information before introducing - contact elements */ - - /*ne0=*ne;nkon0=*nkon;*/ - -/* while(dtheta>1.e-6){*/ - while(1.-theta>1.e-6){ - - if(icutb==0){ - - /* previous increment converged: update the initial values */ - - iinc++; - jprint++; - -/* if(*ithermal<2){ - for(k=1;k=3)){ - for(k=0;k<*nk;++k){t1ini[k]=t1act[k];} - } - for(k=0;k*jmax){ - printf(" *ERROR: max. # of increments reached\n\n"); - FORTRAN(stop,()); - } - printf(" increment %d attempt %d \n",iinc,icutb+1); - printf(" increment size= %e\n",dtheta**tper); - printf(" sum of previous increments=%e\n",theta**tper); - printf(" actual step time=%e\n",(theta+dtheta)**tper); - printf(" actual total time=%e\n\n",*ttime+dtheta**tper); - - printf(" iteration 1\n\n"); - - qamold[0]=qam[0]; - qamold[1]=qam[1]; - - /* determining the actual loads at the end of the new increment*/ - - reltime=theta+dtheta; - time=reltime**tper; - dtime=dtheta**tper; - - FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc,xloadold,xload, - xloadact,iamload,nload,ibody,xbody,nbody,xbodyold,xbodyact, - t1old,t1,t1act,iamt1,nk,amta, - namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal,nmethod, - xbounold,xboun,xbounact,iamboun,nboun, - nodeboun,ndirboun,nodeforc,ndirforc,istep,&iinc, - co,vold,itg,&ntg,amname,ikboun,ilboun,nelemload,sideload,mi)); - -// cam[0]=0.;cam[1]=0.;cam[2]=0.; - for(i=0;i<3;i++){cam[i]=0.;}for(i=3;i<5;i++){cam[i]=0.5;} - if(*ithermal>1){radflowload(itg,ieg,&ntg,&ntr,&ntm, - ac,bc,nload,sideload,nelemload,xloadact,lakon,ipiv,ntmat_,vold, - shcon,nshcon,ipkon,kon,co,pmid,e1,e2,e3,iptri, - kontri,&ntri,nloadtr,tarea,tenv,physcon,erad,fij, - dist,idist,area,nflow,ikboun,xbounact,nboun,ithermal,&iinc,&iit, - cs,mcs,inocs,&ntrit,nk,fenv,istep,&dtime,ttime,&time,ilboun, - ikforc,ilforc,xforcact,nforc,cam,ielmat,&nteq,prop,ielprop, - nactdog,nacteq,nodeboun,ndirboun,&network, - rhcon,nrhcon,ipobody,ibody,xbodyact,nbody,iviewfile,jobnamef, - ctrl,xloadold,&reltime,nmethod,set,mi,istartset,iendset,ialset,nset); - } - - if(cfd==1){ - compfluid(co,nk,ipkon,kon,lakon,ne,ipoface,sideface, - ifreestream,&nfreestream,isolidsurf,neighsolidsurf,&nsolidsurf, - iponoel,inoel,nshcon,shcon,nrhcon,rhcon,vold,ntmat_,nodeboun, - ndirboun,nboun,ipompc,nodempc,nmpc,ikmpc,ilmpc,ithermal, - ikboun,ilboun,&turbulent,isolver,iexpl,voldtu,ttime, - &time,&dtime,nodeforc,ndirforc,xforc,nforc,nelemload,sideload, - xload,nload,xbody,ipobody,nbody,ielmat,matname,mi,ncmat_, - physcon,istep,&iinc,ibody,xloadold,xboun,coefmpc, - nmethod,xforcold,xforcact,iamforc,iamload,xbodyold,xbodyact, - t1old,t1,t1act,iamt1,amta,namta,nam,ampli,xbounold,xbounact, - iamboun,itg,&ntg,amname,t0,nelemface,&nface,cocon,ncocon,xloadact, - tper,jmax,jout,set,nset,istartset,iendset,ialset,prset,prlab, - nprint,trab,inotr,ntrans,filab,labmpc); - } - - if((icascade==2)|| - ((ncont!=0)&&((iinc==1)||(ismallsliding<2)))){ - memmpc_=memmpcref_;mpcfree=mpcfreeref; - RENEW(nodempc,int,3*memmpcref_); - for(k=0;k<3*memmpcref_;k++){nodempc[k]=nodempcref[k];} - RENEW(coefmpc,double,memmpcref_); - for(k=0;k0) remastruct(ipompc,&coefmpc,&nodempc,nmpc, - &mpcfree,nodeboun,ndirboun,nboun,ikmpc,ilmpc,ikboun,ilboun, - labmpc,nk,&memmpc_,&icascade,&maxlenmpc, - kon,ipkon,lakon,ne,nnn,nactdof,icol,jq,&irow,isolver, - neq,nzs,nmethod,&f,&fext,&b,&aux2,&fini,&fextini, - &adb,&aub,ithermal,iperturb,mass,mi); - - /* check whether the forced displacements changed; if so, and - if the procedure is static, the first iteration has to be - purely linear elastic, in order to get an equilibrium - displacement field; otherwise huge (maybe nonelastic) - stresses may occur, jeopardizing convergence */ - - ilin=0; - - /* only for iinc=1 a linearized calculation is performed, since - for iinc>1 a reasonable displacement field is predicted by using the - initial velocity field at the end of the last increment */ - - if((iinc==1)&&(*ithermal<2)){ - dev=0.; - for(k=0;k<*nboun;++k){ - err=fabs(xbounact[k]-xbounini[k]); - if(err>dev){dev=err;} - } - if(dev>1.e-5) ilin=1; - } - - /* prediction of the kinematic vectors */ - - v=NNEW(double,mt**nk); - - prediction(uam,nmethod,&bet,&gam,&dtime,ithermal,nk,veold,accold,v, - &iinc,&idiscon,vold,nactdof,mi); - - fn=NNEW(double,mt**nk); - stx=NNEW(double,6*mi[0]**ne); - if(*ithermal>1) qfx=NNEW(double,3*mi[0]*ne0); - - /* determining the internal forces at the start of the increment - - for a static calculation with increased forced displacements - the linear strains are calculated corresponding to - - the displacements at the end of the previous increment, extrapolated - if appropriate (for nondispersive media) + - the forced displacements at the end of the present increment + - the temperatures at the end of the present increment (this sum is - v) - - the displacements at the end of the previous increment (this is vold) - - these linear strains are converted in stresses by multiplication - with the tangent element stiffness matrix and converted into nodal - forces. - - this boils down to the fact that the effect of forced displacements - should be handled in a purely linear way at the - start of a new increment, in order to speed up the convergence and - (for dissipative media) guarantee smooth loading within the increment. - - for all other cases the nodal force calculation is based on - the true stresses derived from the appropriate strain tensor taking - into account the extrapolated displacements at the end of the - previous increment + the forced displacements and the temperatures - at the end of the present increment */ - - iout=-1; - iperturb_sav[0]=iperturb[0]; - iperturb_sav[1]=iperturb[1]; - - /* first iteration in first increment: elastic tangent */ - - if((*nmethod!=4)&&(ilin==1)){ - - ielas=1; - - iperturb[0]=-1; - iperturb[1]=0; - - for(k=0;k1)free(qfx);free(v); - - /***************************************************************/ - /* iteration counter and start of the loop over the iterations */ - /***************************************************************/ - - iit=1; - icntrl=0; - if(uncoupled){ - *ithermal=2; - iruc=NNEW(int,nzs[1]-nzs[0]); - for(k=0;k1){radflowload(itg,ieg,&ntg,&ntr,&ntm, - ac,bc,nload,sideload,nelemload,xloadact,lakon,ipiv, - ntmat_,vold,shcon,nshcon,ipkon,kon,co,pmid,e1,e2,e3, - iptri,kontri,&ntri,nloadtr,tarea,tenv,physcon,erad,fij, - dist,idist,area,nflow,ikboun,xbounact,nboun,ithermal,&iinc,&iit, - cs,mcs,inocs,&ntrit,nk,fenv,istep,&dtime,ttime,&time,ilboun, - ikforc,ilforc,xforcact,nforc,cam,ielmat,&nteq,prop,ielprop, - nactdog,nacteq,nodeboun,ndirboun,&network, - rhcon,nrhcon,ipobody,ibody,xbodyact,nbody,iviewfile,jobnamef, - ctrl,xloadold,&reltime,nmethod,set,mi,istartset,iendset,ialset,nset); - } - - if((icascade==2)|| - ((ncont!=0)&&(ismallsliding==0))){ - memmpc_=memmpcref_;mpcfree=mpcfreeref; - RENEW(nodempc,int,3*memmpcref_); - for(k=0;k<3*memmpcref_;k++){nodempc[k]=nodempcref[k];} - RENEW(coefmpc,double,memmpcref_); - for(k=0;k0){ - remastruct(ipompc,&coefmpc,&nodempc,nmpc, - &mpcfree,nodeboun,ndirboun,nboun,ikmpc,ilmpc,ikboun,ilboun, - labmpc,nk,&memmpc_,&icascade,&maxlenmpc, - kon,ipkon,lakon,ne,nnn,nactdof,icol,jq,&irow,isolver, - neq,nzs,nmethod,&f,&fext,&b,&aux2,&fini,&fextini, - &adb,&aub,ithermal,iperturb,mass,mi); - - v=NNEW(double,mt**nk); - stx=NNEW(double,6*mi[0]**ne); - if(*ithermal>1) qfx=NNEW(double,3*mi[0]*ne0); - fn=NNEW(double,mt**nk); - - memcpy(&v[0],&vold[0],sizeof(double)*mt**nk); - iout=-1; - - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1act,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xbounact,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, - xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,istep,&iinc)); - - /*for(k=0;k1)free(qfx); - iout=0; - - }else{ - - /*for(k=0;k1)||(icascade>0)){*/ - -/* for(k=0;k1){ - for(k=neq[0];k1){ - for(k=neq[0];k1) qfx=NNEW(double,3*mi[0]*ne0); - fn=NNEW(double,mt**nk); - - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1act,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xbounact,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, - &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, - sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, - fmpc,nelemload,nload,ikmpc,ilmpc,istep,&iinc)); - - if(*ithermal!=2){ - if(cam[0]>uam[0]){uam[0]=cam[0];} - if(qau<1.e-10){ - if(qa[0]>ea*qam[0]){qam[0]=(qamold[0]*jnz+qa[0])/(jnz+1);} - else {qam[0]=qamold[0];} - } - } - if(*ithermal>1){ - if(cam[1]>uam[1]){uam[1]=cam[1];} - if(qau<1.e-10){ - if(qa[1]>ea*qam[1]){qam[1]=(qamold[1]*jnz+qa[1])/(jnz+1);} - else {qam[1]=qamold[1];} - } - } - -/* if(*ithermal<2){ - for(k=1;k1)free(qfx); - - /* calculating the residual */ - - calcresidual(nmethod,neq,b,fext,f,iexpl,nactdof,aux1,aux2,vold, - vini,&dtime,accold,nk,adb,aub,icol,irow,nzl,alpha,fextini,fini, - islavnode,nslavnode,imastnode,nmastnode,&mortar,ntie,f_cm,f_cs,mi); - - /* calculating the maximum residual */ - - for(k=0;k<2;++k){ - ram2[k]=ram1[k]; - ram1[k]=ram[k]; - ram[k]=0.; - } - if(*ithermal!=2){ - for(k=0;kram[0]){ram[0]=err;ram[2]=k+0.5;} - } - } - if(*ithermal>1){ - for(k=neq[0];kram[1]){ram[1]=err;ram[3]=k+0.5;} - } - } - - /* next line is inserted to cope with stress-less - temperature calculations */ - - if(*ithermal!=2){ - if(ram[0]<1.e-6) ram[0]=0.; - printf(" average force= %f\n",qa[0]); - printf(" time avg. forc= %f\n",qam[0]); - if((int)((double)nactdofinv[(int)ram[2]]/mt)==0){ - printf(" largest residual force= %f\n", - ram[0]); - }else{ - printf(" largest residual force= %f in node %d\n", - ram[0],(int)((double)nactdofinv[(int)ram[2]]/mt)); - } - printf(" largest increment of disp= %e\n",uam[0]); - if((int)cam[3]==0){ - printf(" largest correction to disp= %e\n\n", - cam[0]); - }else{ - printf(" largest correction to disp= %e in node %d\n\n", - cam[0],(int)cam[3]); - } - } - if(*ithermal>1){ - if(ram[1]<1.e-6) ram[1]=0.; - printf(" average flux= %f\n",qa[1]); - printf(" time avg. flux= %f\n",qam[1]); - if((int)((double)nactdofinv[(int)ram[3]]/mt)==0){ - printf(" largest residual flux= %f\n", - ram[1]); - }else{ - printf(" largest residual flux= %f in node %d\n", - ram[1],(int)((double)nactdofinv[(int)ram[3]]/mt)); - } - printf(" largest increment of temp= %e\n",uam[1]); - if((int)cam[4]==0){ - printf(" largest correction to temp= %e\n\n", - cam[1]); - }else{ - printf(" largest correction to temp= %e in node %d\n\n", - cam[1],(int)cam[4]); - } - } - - checkconvergence(co,nk,kon,ipkon,lakon,ne,stn,nmethod, - kode,filab,een,t1act,&time,epn,ielmat,matname,enern, - xstaten,nstate_,istep,&iinc,iperturb,ener,mi,output, - ithermal,qfn,&mode,&noddiam,trab,inotr,ntrans,orab, - ielorien,norien,description,sti,&icutb,&iit,&dtime,qa, - vold,qam,ram1,ram2,ram,cam,uam,&ntg,ttime,&icntrl, - &theta,&dtheta,veold,vini,idrct,tper,&istab,tmax, - nactdof,b,tmin,ctrl,amta,namta,itpamp,&inext,&dthetaref, - &itp,&jprint,jout,&uncoupled,t1,&iitterm,nelemload, - nload,nodeboun,nboun,itg,ndirboun,&deltmx,&iflagact, - set,nset,istartset,iendset,ialset); - } - - /*********************************************************/ - /* end of the iteration loop */ - /*********************************************************/ - - /* icutb=0 means that the iterations in the increment converged, - icutb!=0 indicates that the increment has to be reiterated with - another increment size (dtheta) */ - - if(uncoupled){ - free(iruc); - } - - if(((qa[0]>ea*qam[0])||(qa[1]>ea*qam[1]))&&(icutb==0)){jnz++;} - iit=0; - - if(icutb!=0){ - -/* if(*ithermal<2){ - for(k=1;k=3)){ - for(k=0;k<*nk;++k){t1act[k]=t1ini[k];} - } - for(k=0;k1) qfn=NNEW(double,3**nk); - inum=NNEW(int,*nk); - stx=NNEW(double,6*mi[0]**ne); - if(*ithermal>1) qfx=NNEW(double,3*mi[0]*ne0); - - if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); - if(strcmp1(&filab[435],"PEEQ")==0) epn=NNEW(double,*nk); - if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); - if(strcmp1(&filab[609],"SDV ")==0) xstaten=NNEW(double,*nstate_**nk); - - memcpy(&v[0],&vold[0],sizeof(double)*mt**nk); - - iout=2; - icmd=3; - - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1act,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xbounact,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, - xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,istep,&iinc)); - -/* if(*ithermal<2){ - for(k=1;k0){inum[itg[k]-1]*=-1;} - - ++*kode; - if(*mcs!=0){ - frdcyc(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een, - t1act,fn,ttime,epn,ielmat,matname,cs,mcs,nkon,enern,xstaten, - nstate_,istep,&iinc,iperturb,ener,mi,output,ithermal,qfn, - ialset,istartset,iendset,trab,inotr,ntrans,orab,ielorien, - norien,stx,veold,&noddiam,set,nset); - } - else{ - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(co,nk,kon,ipkon,lakon,&ne0,v,stn,inum,nmethod,kode, - filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, - xstaten,nstate_,istep,&iinc,iperturb,ener,mi,output, - ithermal,qfn,&mode,&noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,stx,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - } - - free(v);free(fn);free(stn);free(inum);free(stx); - if(*ithermal>1){free(qfx);free(qfn);} - - if(strcmp1(&filab[261],"E ")==0) free(een); - if(strcmp1(&filab[435],"PEEQ")==0) free(epn); - if(strcmp1(&filab[522],"ENER")==0) free(enern); - if(strcmp1(&filab[609],"SDV ")==0) free(xstaten); - } - - } - - /*********************************************************/ - /* end of the increment loop */ - /*********************************************************/ - - if(jprint!=0){ - - /* calculating the displacements and the stresses and storing - the results in frd format */ - - v=NNEW(double,mt**nk); - fn=NNEW(double,mt**nk); - stn=NNEW(double,6**nk); - if(*ithermal>1) qfn=NNEW(double,3**nk); - inum=NNEW(int,*nk); - stx=NNEW(double,6*mi[0]**ne); - if(*ithermal>1) qfx=NNEW(double,3*mi[0]*ne0); - - if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); - if(strcmp1(&filab[435],"PEEQ")==0) epn=NNEW(double,*nk); - if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); - if(strcmp1(&filab[609],"SDV ")==0) xstaten=NNEW(double,*nstate_**nk); - - memcpy(&v[0],&vold[0],sizeof(double)*mt**nk); - iout=2; - icmd=3; - - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xbounact,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, - xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,istep,&iinc)); - - /* if(*ithermal<2){ - for(k=1;k0){inum[itg[k]-1]*=-1;} - - ++*kode; - if(*mcs>0){ - frdcyc(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een, - t1act,fn,ttime,epn,ielmat,matname,cs,mcs,nkon,enern,xstaten, - nstate_,istep,&iinc,iperturb,ener,mi,output,ithermal,qfn, - ialset,istartset,iendset,trab,inotr,ntrans,orab,ielorien, - norien,stx,veold,&noddiam,set,nset); - } - else{ - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(co,nk,kon,ipkon,lakon,&ne0,v,stn,inum,nmethod,kode,filab, - een,t1act,fn,ttime,epn,ielmat,matname,enern,xstaten, - nstate_,istep,&iinc,iperturb,ener,mi,output,ithermal, - qfn,&mode,&noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,stx,vr,vi,stnr,stni,vmax,stnmax,&ngraph, - veold,ne,cs,set,nset,istartset,iendset,ialset)); - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - } - - free(v);free(fn);free(stn);free(inum);free(stx); - if(*ithermal>1){free(qfx);free(qfn);} - - if(strcmp1(&filab[261],"E ")==0) free(een); - if(strcmp1(&filab[435],"PEEQ")==0) free(epn); - if(strcmp1(&filab[522],"ENER")==0) free(enern); - if(strcmp1(&filab[609],"SDV ")==0) free(xstaten); - - } - - /* setting the velocity to zero at the end of a quasistatic or stationary - step */ - - if(*nmethod==1){ - for(k=0;k0)&&(ndirboun[k]<4)){ - node=nodeboun[k]; - FORTRAN(nident,(itg,&node,&ntg,&id)); - networknode=0; - if(id>0){ - if(itg[id-1]==node) networknode=1; - } - if((*ithermal==2)&&(networknode==0)) continue; - } - xbounold[k]=xbounact[k]; - } - for(k=0;k<*nforc;++k){xforcold[k]=xforcact[k];} - for(k=0;k<2**nload;++k){xloadold[k]=xloadact[k];} - for(k=0;k<7**nbody;k=k+7){xbodyold[k]=xbodyact[k];} - if(*ithermal==1){ - for(k=0;k<*nk;++k){t1old[k]=t1act[k];} - for(k=0;k<*nk;++k){vold[mt*k]=t1act[k];} - } - else if(*ithermal>1){ - for(k=0;k<*nk;++k){t1[k]=vold[mt*k];} - if(*ithermal>=3){ - for(k=0;k<*nk;++k){t1old[k]=t1act[k];} - } - } - - qaold[0]=qa[0]; - qaold[1]=qa[1]; - - free(f); - free(b); - free(xbounact);free(xforcact);free(xloadact);free(xbodyact); - if(*nbody>0) free(ipobody);if(inewton==1){free(cgr);} - free(fext);free(ampli);free(xbounini);free(xstiff); - if((*ithermal==1)||(*ithermal>=3)){free(t1act);free(t1ini);} - - if(*ithermal>1){ - free(itg);free(ieg);free(iptri);free(kontri);free(nloadtr); - free(area);free(pmid);free(nactdog);free(nacteq); - free(dist);free(idist);free(fij);free(tarea);free(tenv);free(fenv); - free(erad);free(ac);free(bc);free(ipiv);free(e1);free(e2);free(e3); - if((*mcs>0)&&(ntr>0)){free(inocs);} - } - - if(cfd==1){ - free(sideface);free(nelemface);free(ifreestream); - free(isolidsurf);free(neighsolidsurf);free(iponoel);free(inoel); - free(voldtu); - } - - free(fini); - if(*nmethod==4){ - free(aux2);free(fextini);free(veini);free(accini); - free(adb);free(aub); - } - free(eei);free(stiini); - if(*nener==1) - free(enerini); - if(*nstate_!=0){free(xstateini);} - - free(aux);free(iaux);free(vini); - - if((icascade==2)||(ncont!=0)){ - memmpc_=memmpcref_;mpcfree=mpcfreeref; - RENEW(nodempc,int,3*memmpcref_); - for(k=0;k<3*memmpcref_;k++){nodempc[k]=nodempcref[k];} - RENEW(coefmpc,double,memmpcref_); - for(k=0;k0){ - RENEW(ielorien,int,*ne); - } - RENEW(ielmat,int,*ne); - free(cg);free(straight);free(ifcont1);free(ifcont2); - free(imastop); - - /* deleting contact MPC's (not for modal dynamics calculations) */ - - remcontmpc(nmpc,labmpc,&mpcfree,nodempc,ikmpc,ilmpc,coefmpc,ipompc); - - if(mortar==1){ - free(islavact);free(gap);free(slavnor);free(bdd); - free(auqdt);free(irowqdt);free(jqqdt);free(bhat); - free(iponoels);free(inoels);free(jqtemp);free(irowtemp); - free(icoltemp);free(islavnode);free(nslavnode);free(imastnode); - free(nmastnode);free(cstress);free(f_cm);free(f_cs);free(ipe); - free(ime);free(lambda);free(islavsurf); - } - } - - mpcinfo[0]=memmpc_;mpcinfo[1]=mpcfree;mpcinfo[2]=icascade; - mpcinfo[3]=maxlenmpc; - - *icolp=icol;*irowp=irow;*cop=co;*voldp=vold; - - *ipompcp=ipompc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; - *fmpcp=fmpc;*nodempcp=nodempc;*coefmpcp=coefmpc; - - *ipkonp=ipkon;*lakonp=lakon;*konp=kon;*ielorienp=ielorien; - *ielmatp=ielmat; - *enerp=ener; - - (*tmin)*=(*tper); - (*tmax)*=(*tper); - - free(nactdofinv); - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/nonlinmpc.f calculix-ccx-2.3/ccx_2.1/src/nonlinmpc.f --- calculix-ccx-2.1/ccx_2.1/src/nonlinmpc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/nonlinmpc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1011 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine nonlinmpc(co,vold,ipompc,nodempc,coefmpc,labmpc, - & nmpc,ikboun,ilboun,nboun,xbounact,aux,iaux,maxlenmpc,ikmpc, - & ilmpc,icascade,kon,ipkon,lakon,ne,reltime,newstep,xboun,fmpc, - & iit,idiscon,ncont,trab,ntrans,ithermal,mi) -! -! updates the coefficients in nonlinear MPC's -! - implicit none -! - logical isochoric -! - character*8 lakon(*) - character*20 labmpc(*),label -! - integer ipompc(*),nodempc(3,*),irefnode,irotnode,idir, - & nmpc,index,ii,inode,node,id,ikboun(*),ilboun(*),nboun, - & i,j,k,idof,na,nb,nc,np,i1,i2,i3,iaux(*),maxlenmpc,n, - & l,m,lmax,mmax,ikmpc(*),ilmpc(*),icascade,neigh(7,8), - & mpc,kon(*),ipkon(*),indexe,ne,idofrem,idofins,nmpc0,nmpc01, - & newstep,iit,idiscon,ncont,iexpnode,indexexp,nmpcdif,ntrans, - & nodei,noded,lathyp(3,6),inum,ndir,number,ithermal,mi(2) -! - real*8 co(3,*),coefmpc(*),vold(0:mi(2),*),c(3,3),dc(3,3,3),ww, - & e(3,3,3),d(3,3),w(3),f(3,3),c1,c2,c3,c4,c5,c6,xbounact(*), - & xboun(*),fmpc(*),expan - real*8 dd,a11,a12,a13,a21,a22,a23,a31,a32,a33, - & b11,b12,b13,b21,b22,b23,b31,b32,b33,aux(*),const, - & ddmax,a(3,3),b(3,3),xj,xi,et,ze,xlag(3,20),xeul(3,20), - & coloc(3,8),reltime,csab(7),trab(7,*),pd(3),pi(3), - & ad(3,3),ai(3,3) -! - data d /1.,0.,0.,0.,1.,0.,0.,0.,1./ - data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., - & 0.,0.,1.,0.,0.,0.,-1.,0.,0., - & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ - data neigh /1,9,2,12,4,17,5,2,9,1,10,3,18,6, - & 3,11,4,10,2,19,7,4,11,3,12,1,20,8, - & 5,13,6,16,8,17,1,6,13,5,14,7,18,2, - & 7,15,8,14,6,19,3,8,15,7,16,5,20,4/ - data coloc /-1.,-1.,-1.,1.,-1.,-1.,1.,1.,-1.,-1.,1.,-1., - & -1.,-1.,1.,1.,-1.,1.,1.,1.,1.,-1.,1.,1./ -! -! latin hypercube positions in a 3 x 3 matrix -! - data lathyp /1,2,3,1,3,2,2,1,3,2,3,1,3,1,2,3,2,1/ -! - irotnode=0 - if((icascade.eq.1).and.(newstep.ne.1).and.(ncont.eq.0)) icascade=0 - isochoric=.false. -! - ii=0 - loop: do - ii=ii+1 - if(ii.gt.nmpc) exit - if(labmpc(ii)(1:5).eq.'RIGID') then -! - index=ipompc(ii) - inode=nodempc(1,index) - idir=nodempc(2,index) - coefmpc(index)=1.d0 -! - index=nodempc(3,index) - irefnode=nodempc(1,index) - coefmpc(index)=-1.d0 -! - index=nodempc(3,index) - node=nodempc(1,index) -! -! check whether the rotational node is the same as in -! the last rigid body MPC -! - if(node.ne.irotnode) then - irotnode=node - w(1)=vold(1,node) - w(2)=vold(2,node) - w(3)=vold(3,node) -c write(*,*) 'w ',w(1),w(2),w(3) - ww=dsqrt(w(1)*w(1)+w(2)*w(2)+w(3)*w(3)) -! - c1=dcos(ww) - if(ww.gt.1.d-10) then - c2=dsin(ww)/ww - else - c2=1.d0 - endif - if(ww.gt.1.d-5) then - c3=(1.d0-c1)/ww**2 - else - c3=0.5d0 - endif -! -! rotation matrix c -! - do i=1,3 - do j=1,3 - c(i,j)=c1*d(i,j)+ - & c2*(e(i,1,j)*w(1)+e(i,2,j)*w(2)+e(i,3,j)*w(3))+ - & c3*w(i)*w(j) - enddo - enddo -! - c4=-c2 - if(ww.gt.0.00464159) then - c5=(ww*dcos(ww)-dsin(ww))/ww**3 - else - c5=-1.d0/3.d0 - endif - if(ww.gt.0.0031623) then - c6=(ww*dsin(ww)-2.d0+2.d0*dcos(ww))/ww**4 - else - c6=-1.d0/12.d0 - endif -! -! derivative of the rotation matrix c with respect to -! the rotation vector w -! - do i=1,3 - do j=1,3 - do k=1,3 - dc(i,j,k)=c4*w(k)*d(i,j)+ - & c5*w(k)*(e(i,1,j)*w(1)+ - & e(i,2,j)*w(2)+e(i,3,j)*w(3))+ - & c2*e(i,k,j)+ - & c6*w(k)*w(i)*w(j)+ - & c3*(d(i,k)*w(j)+d(j,k)*w(i)) - enddo - enddo - enddo -! -! dummy variable -! - do i=1,3 - do j=1,3 -c f(i,j)=c(i,j)-d(i,j)-dc(i,j,1)*w(1)-dc(i,j,2)*w(2)- -c & dc(i,j,3)*w(3) - f(i,j)=c(i,j)-d(i,j) - enddo - enddo - endif -! -! determining the coefficients of the rotational degrees -! of freedom -! - coefmpc(index)=dc(idir,1,1)*(co(1,irefnode)-co(1,inode))+ - & dc(idir,2,1)*(co(2,irefnode)-co(2,inode))+ - & dc(idir,3,1)*(co(3,irefnode)-co(3,inode)) -! - index=nodempc(3,index) - coefmpc(index)=dc(idir,1,2)*(co(1,irefnode)-co(1,inode))+ - & dc(idir,2,2)*(co(2,irefnode)-co(2,inode))+ - & dc(idir,3,2)*(co(3,irefnode)-co(3,inode)) -! - index=nodempc(3,index) - coefmpc(index)=dc(idir,1,3)*(co(1,irefnode)-co(1,inode))+ - & dc(idir,2,3)*(co(2,irefnode)-co(2,inode))+ - & dc(idir,3,3)*(co(3,irefnode)-co(3,inode)) -! -! determining the nonhomogeneous part -! - index=nodempc(3,index) - coefmpc(index)=1.d0 -! -! old value of the nonhomogeneous term must be zero -! - vold(nodempc(2,index),nodempc(1,index))=0.d0 - idof=8*(nodempc(1,index)-1)+nodempc(2,index) - call nident(ikboun,idof,nboun,id) - xbounact(ilboun(id))=f(idir,1)*(co(1,irefnode)-co(1,inode))+ - & f(idir,2)*(co(2,irefnode)-co(2,inode))+ - & f(idir,3)*(co(3,irefnode)-co(3,inode))- - & vold(idir,irefnode)+vold(idir,inode) -! - elseif(labmpc(ii)(1:4).eq.'KNOT') then -! -! dependent node -! - index=ipompc(ii) - inode=nodempc(1,index) - idir=nodempc(2,index) - coefmpc(index)=1.d0 -! -! translation node -! - index=nodempc(3,index) - irefnode=nodempc(1,index) - coefmpc(index)=-1.d0 -! -! expansion node -! - index=nodempc(3,index) - iexpnode=nodempc(1,index) - expan=1.d0+vold(1,iexpnode) - indexexp=index -! -! rotation node -! - index=nodempc(3,index) - node=nodempc(1,index) -! -! check whether the rotational node is the same as in -! the last rigid body MPC -! - if(node.ne.irotnode) then - irotnode=node - w(1)=vold(1,node) - w(2)=vold(2,node) - w(3)=vold(3,node) - ww=dsqrt(w(1)*w(1)+w(2)*w(2)+w(3)*w(3)) -! - c1=dcos(ww) - if(ww.gt.1.d-10) then - c2=dsin(ww)/ww - else - c2=1.d0 - endif - if(ww.gt.1.d-5) then - c3=(1.d0-c1)/ww**2 - else - c3=0.5d0 - endif -! -! rotation matrix c -! - do i=1,3 - do j=1,3 - c(i,j)=c1*d(i,j)+ - & c2*(e(i,1,j)*w(1)+e(i,2,j)*w(2)+e(i,3,j)*w(3))+ - & c3*w(i)*w(j) - enddo - enddo -! - c4=-c2 - if(ww.gt.0.00464159) then - c5=(ww*dcos(ww)-dsin(ww))/ww**3 - else - c5=-1.d0/3.d0 - endif - if(ww.gt.0.0031623) then - c6=(ww*dsin(ww)-2.d0+2.d0*dcos(ww))/ww**4 - else - c6=-1.d0/12.d0 - endif -! -! derivative of the rotation matrix c with respect to -! the rotation vector w -! - do i=1,3 - do j=1,3 - do k=1,3 - dc(i,j,k)=c4*w(k)*d(i,j)+ - & c5*w(k)*(e(i,1,j)*w(1)+ - & e(i,2,j)*w(2)+e(i,3,j)*w(3))+ - & c2*e(i,k,j)+ - & c6*w(k)*w(i)*w(j)+ - & c3*(d(i,k)*w(j)+d(j,k)*w(i)) - enddo - enddo - enddo -! -! dummy variable -! - do i=1,3 - do j=1,3 -c f(i,j)=c(i,j)-d(i,j)-dc(i,j,1)*w(1)-dc(i,j,2)*w(2)- -c & dc(i,j,3)*w(3) - f(i,j)=expan*c(i,j)-d(i,j) - enddo - enddo - endif -! - coefmpc(indexexp)=c(idir,1)*(co(1,irefnode)-co(1,inode))+ - & c(idir,2)*(co(2,irefnode)-co(2,inode))+ - & c(idir,3)*(co(3,irefnode)-co(3,inode)) -! -! determining the coefficients of the rotational degrees -! of freedom -! - coefmpc(index)=(dc(idir,1,1)*(co(1,irefnode)-co(1,inode))+ - & dc(idir,2,1)*(co(2,irefnode)-co(2,inode))+ - & dc(idir,3,1)*(co(3,irefnode)-co(3,inode)))*expan -! - index=nodempc(3,index) - coefmpc(index)=(dc(idir,1,2)*(co(1,irefnode)-co(1,inode))+ - & dc(idir,2,2)*(co(2,irefnode)-co(2,inode))+ - & dc(idir,3,2)*(co(3,irefnode)-co(3,inode)))*expan -! - index=nodempc(3,index) - coefmpc(index)=(dc(idir,1,3)*(co(1,irefnode)-co(1,inode))+ - & dc(idir,2,3)*(co(2,irefnode)-co(2,inode))+ - & dc(idir,3,3)*(co(3,irefnode)-co(3,inode)))*expan -! -! determining the nonhomogeneous part -! - index=nodempc(3,index) - coefmpc(index)=1.d0 -! -! old value of the nonhomogeneous term must be zero -! - vold(nodempc(2,index),nodempc(1,index))=0.d0 - idof=8*(nodempc(1,index)-1)+nodempc(2,index) - call nident(ikboun,idof,nboun,id) - xbounact(ilboun(id))=f(idir,1)*(co(1,irefnode)-co(1,inode))+ - & f(idir,2)*(co(2,irefnode)-co(2,inode))+ - & f(idir,3)*(co(3,irefnode)-co(3,inode))- - & vold(idir,irefnode)+vold(idir,inode) -! - elseif(labmpc(ii)(1:8).eq.'STRAIGHT') then -! -! determining nodes and directions involved in MPC -! - index=ipompc(ii) - np=nodempc(1,index) - j=nodempc(2,index) - index=nodempc(3,index) - i=nodempc(2,index) - index=nodempc(3,index) - na=nodempc(1,index) - index=nodempc(3,nodempc(3,index)) - nb=nodempc(1,index) -! -! determining the coefficients -! - index=ipompc(ii) - c2=co(i,na)+vold(i,na)-co(i,nb)-vold(i,nb) - if(dabs(c2).lt.1.d-5) then - write(*,*) '*WARNING in nonlinmpc: coefficient of' - write(*,*) - & ' dependent node in STRAIGHT MPC is zero' - idofrem=8*(np-1)+j -! -! determining a new dependent term -! - ddmax=abs(c2) - l=i - m=j - do k=1,2 - l=l+1 - m=m+1 - if(l.gt.3) l=l-3 - if(m.gt.3) m=m-3 - dd=dabs(co(l,na)+vold(l,na)-co(l,nb)-vold(l,nb)) - if(dd.gt.ddmax) then - ddmax=dd - lmax=l - mmax=m - endif - enddo - i=lmax - j=mmax - idofins=8*(np-1)+j -! - call changedepterm(ikmpc,ilmpc,nmpc,ii,idofrem,idofins) -! - index=ipompc(ii) - nodempc(2,index)=j - index=nodempc(3,index) - nodempc(2,index)=i - index=nodempc(3,index) - nodempc(2,index)=j - index=nodempc(3,index) - nodempc(2,index)=i - index=nodempc(3,index) - nodempc(2,index)=j - index=nodempc(3,index) - nodempc(2,index)=i - index=nodempc(3,index) - nodempc(2,index)=j - if(icascade.eq.0) icascade=1 - c2=co(i,na)+vold(i,na)-co(i,nb)-vold(i,nb) - endif - coefmpc(index)=c2 - index=nodempc(3,index) - c3=co(j,nb)+vold(j,nb)-co(j,na)-vold(j,na) - coefmpc(index)=c3 - index=nodempc(3,index) - c5=co(i,nb)+vold(i,nb)-co(i,np)-vold(i,np) - coefmpc(index)=c5 - index=nodempc(3,index) - c6=co(j,np)+vold(j,np)-co(j,nb)-vold(j,nb) - coefmpc(index)=c6 - index=nodempc(3,index) - c4=co(i,np)+vold(i,np)-co(i,na)-vold(i,na) - coefmpc(index)=c4 - index=nodempc(3,index) - c1=co(j,na)+vold(j,na)-co(j,np)-vold(j,np) - coefmpc(index)=c1 - index=nodempc(3,index) -! -! nonhomogeneous term -! - coefmpc(index)=1.d0 -! -! old value of the nonhomogeneous term must be zero -! - idof=8*(nodempc(1,index)-1)+nodempc(2,index) - call nident(ikboun,idof,nboun,id) - xbounact(ilboun(id))=-c1*c2+c3*c4 - if(newstep.eq.1) xboun(ilboun(id))=xbounact(ilboun(id)) - vold(nodempc(2,index),nodempc(1,index))= - & (1.d0-reltime)*xboun(ilboun(id)) - elseif(labmpc(ii)(1:5).eq.'PLANE') then -! -! determining nodes and directions involved in MPC -! - index=ipompc(ii) - np=nodempc(1,index) - i1=nodempc(2,index) - index=nodempc(3,index) - i2=nodempc(2,index) - index=nodempc(3,index) - i3=nodempc(2,index) - index=nodempc(3,index) - na=nodempc(1,index) - index=nodempc(3,nodempc(3,nodempc(3,index))) - nb=nodempc(1,index) - index=nodempc(3,nodempc(3,nodempc(3,index))) - nc=nodempc(1,index) -! -! determining the coefficients -! - a11=co(i1,np)+vold(i1,np)-co(i1,nc)-vold(i1,nc) - a12=co(i2,np)+vold(i2,np)-co(i2,nc)-vold(i2,nc) - a13=co(i3,np)+vold(i3,np)-co(i3,nc)-vold(i3,nc) - a21=co(i1,na)+vold(i1,na)-co(i1,nc)-vold(i1,nc) - a22=co(i2,na)+vold(i2,na)-co(i2,nc)-vold(i2,nc) - a23=co(i3,na)+vold(i3,na)-co(i3,nc)-vold(i3,nc) - a31=co(i1,nb)+vold(i1,nb)-co(i1,nc)-vold(i1,nc) - a32=co(i2,nb)+vold(i2,nb)-co(i2,nc)-vold(i2,nc) - a33=co(i3,nb)+vold(i3,nb)-co(i3,nc)-vold(i3,nc) -! - b11=a22*a33-a23*a32 - b12=a31*a23-a21*a33 - b13=a21*a32-a31*a22 - b21=a32*a13-a12*a33 - b22=a11*a33-a31*a13 - b23=a31*a12-a11*a32 - b31=a12*a23-a22*a13 - b32=a21*a13-a11*a23 - b33=a11*a22-a12*a21 -! - index=ipompc(ii) - if(dabs(b11).lt.1.d-5) then - write(*,*) '*WARNING in nonlinmpc: coefficient of' - write(*,*) ' dependent node in PLANE MPC is zero' -! - idofrem=8*(nodempc(1,index)-1)+i1 -! - if(dabs(b12).gt.dabs(b13)) then - idofins=8*(nodempc(1,index)-1)+i2 - call changedepterm - & (ikmpc,ilmpc,nmpc,ii,idofrem,idofins) - coefmpc(index)=b12 - nodempc(2,index)=i2 - index=nodempc(3,index) - coefmpc(index)=b11 - nodempc(2,index)=i1 - index=nodempc(3,index) - coefmpc(index)=b13 - index=nodempc(3,index) - coefmpc(index)=b22 - nodempc(2,index)=i2 - index=nodempc(3,index) - coefmpc(index)=b21 - nodempc(2,index)=i1 - index=nodempc(3,index) - coefmpc(index)=b23 - index=nodempc(3,index) - coefmpc(index)=b32 - nodempc(2,index)=i2 - index=nodempc(3,index) - coefmpc(index)=b31 - nodempc(2,index)=i1 - index=nodempc(3,index) - coefmpc(index)=b33 - index=nodempc(3,index) - coefmpc(index)=-b12-b22-b32 - nodempc(2,index)=i2 - index=nodempc(3,index) - coefmpc(index)=-b11-b21-b31 - nodempc(2,index)=i1 - index=nodempc(3,index) - coefmpc(index)=-b13-b23-b33 - if(icascade.eq.0) icascade=1 - else - idofins=8*(nodempc(1,index)-1)+i3 - call changedepterm - & (ikmpc,ilmpc,nmpc,ii,idofrem,idofins) - coefmpc(index)=b13 - nodempc(2,index)=i3 - index=nodempc(3,index) - coefmpc(index)=b12 - index=nodempc(3,index) - coefmpc(index)=b11 - nodempc(2,index)=i1 - index=nodempc(3,index) - coefmpc(index)=b23 - nodempc(2,index)=i3 - index=nodempc(3,index) - coefmpc(index)=b22 - index=nodempc(3,index) - coefmpc(index)=b21 - nodempc(2,index)=i1 - index=nodempc(3,index) - coefmpc(index)=b33 - nodempc(2,index)=i3 - index=nodempc(3,index) - coefmpc(index)=b32 - index=nodempc(3,index) - coefmpc(index)=b31 - nodempc(2,index)=i1 - index=nodempc(3,index) - coefmpc(index)=-b13-b23-b33 - nodempc(2,index)=i3 - index=nodempc(3,index) - coefmpc(index)=-b12-b22-b32 - index=nodempc(3,index) - coefmpc(index)=-b11-b21-b31 - nodempc(2,index)=i1 - if(icascade.eq.0) icascade=1 - endif - else - coefmpc(index)=b11 - index=nodempc(3,index) - coefmpc(index)=b12 - index=nodempc(3,index) - coefmpc(index)=b13 - index=nodempc(3,index) - coefmpc(index)=b21 - index=nodempc(3,index) - coefmpc(index)=b22 - index=nodempc(3,index) - coefmpc(index)=b23 - index=nodempc(3,index) - coefmpc(index)=b31 - index=nodempc(3,index) - coefmpc(index)=b32 - index=nodempc(3,index) - coefmpc(index)=b33 - index=nodempc(3,index) - coefmpc(index)=-b11-b21-b31 - index=nodempc(3,index) - coefmpc(index)=-b12-b22-b32 - index=nodempc(3,index) - coefmpc(index)=-b13-b23-b33 - endif - index=nodempc(3,index) - coefmpc(index)=1.d0 - idof=8*(nodempc(1,index)-1)+nodempc(2,index) -! -! old value of the nonhomogeneous term must be zero -! - call nident(ikboun,idof,nboun,id) - xbounact(ilboun(id))=a11*b11+a12*b12+a13*b13 - if(newstep.eq.1) xboun(ilboun(id))=xbounact(ilboun(id)) - vold(nodempc(2,index),nodempc(1,index))=0.d0 - elseif(labmpc(ii)(1:9).eq.'ISOCHORIC') then - isochoric=.true. -! -! next segment is deactivated (CYCLID instead of CYCLIC): -! cylic MPC's are considered to be linear -! - elseif((labmpc(ii)(1:6).eq.'CYCLID').and.(ithermal.ne.2)) then - index=ipompc(ii) - noded=nodempc(1,index) -! -! check for thermal MPC -! - if(nodempc(2,index).eq.0) cycle loop -! -! check whether the next two MPC's are cyclic MPC's -! applied to the same dependent node -! - if((nodempc(1,ipompc(ii+1)).ne.noded).or. - & (labmpc(ii+1)(1:6).ne.'CYCLIC').or. - & (nodempc(1,ipompc(ii+2)).ne.noded).or. - & (labmpc(ii+2)(1:6).ne.'CYCLIC')) then - write(*,*) '*WARNING in nonlinmpc: no three' - write(*,*) ' cyclic MPCs pertaining' - write(*,*) ' to the same dependent node;' - write(*,*) ' no update' - cycle loop - endif -! -! finding the cyclic symmetry axis -! - do i=1,ntrans - if(trab(7,i).eq.2) exit - enddo - if(i.gt.ntrans) then - write(*,*) '*ERROR in nonlinmpc: cyclic symmetry' - write(*,*) ' axis not found' - stop - endif - do j=1,6 - csab(j)=trab(j,i) - enddo - csab(7)=-1 -! -! determining the independent node -! - nodei=0 - do - if(nodempc(1,index).ne.noded) then - if(nodei.eq.0) then - nodei=nodempc(1,index) - elseif(nodei.ne.nodempc(1,index)) then - write(*,*) '*WARNING in nonlinmpc:' - write(*,*) ' cyclic symmetry conditions' - write(*,*) ' between unequal meshes' - write(*,*) ' no update' - cycle loop - endif - endif - index=nodempc(3,index) - if(index.eq.0) then - if(nodei.eq.0) then - write(*,*) '*ERROR in nonlinmpc:' - write(*,*) ' no independent node found' - stop - else - exit - endif - endif - enddo -! -! actual location of dependent and independent node -! - do i=1,3 - pd(i)=co(i,noded)+vold(i,noded) - pi(i)=co(i,nodei)+vold(i,nodei) - enddo -! -! update transformation matrix -! - call transformatrix(csab,pd,ad) - call transformatrix(csab,pi,ai) -! -! checking for latin hypercube positions in matrix al none of -! which are zero -! - do inum=1,6 - if((dabs(ad(lathyp(1,inum),1)).gt.1.d-3).and. - & (dabs(ad(lathyp(2,inum),2)).gt.1.d-3).and. - & (dabs(ad(lathyp(3,inum),3)).gt.1.d-3)) exit - enddo -! -! remove old DOFs -! - do j=1,3 - idof=8*(noded-1)+j - call nident(ikmpc,idof,nmpc,id) - if(id.lt.0) then - write(*,*) '*ERROR in nonlinmpc: error in' - write(*,*) ' MPC database' - stop - elseif(ikmpc(id).ne.idof) then - write(*,*) '*ERROR in nonlinmpc: error in' - write(*,*) ' MPC database' - stop - endif -! - do k=id,nmpc-1 - ikmpc(k)=ikmpc(k+1) - ilmpc(k)=ilmpc(k+1) - enddo - enddo -! -! add new MPCs -! - ii=ii-1 - do ndir=1,3 - ii=ii+1 - number=lathyp(ndir,inum) - idof=8*(noded-1)+number - call nident(ikmpc,idof,nmpc-1,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*WARNING in nonlinmpc: cyclic MPC - & in node' - write(*,*) ' ',noded,' and direction ',ndir - write(*,*) ' cannot be created: the' - write(*,*) ' DOF in this node is already us - &ed' - cycle - endif - endif - number=number-1 -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! -! update the MPC coefficients -! - index=ipompc(ii) - do j=1,3 - number=number+1 - if(number.gt.3) number=1 - if(dabs(ad(number,ndir)).lt.1.d-5) cycle - if(index.eq.0) then - write(*,*)'*ERROR in nonlinmpc: index=0' - stop - endif - nodempc(1,index)=noded - nodempc(2,index)=number - coefmpc(index)=ad(number,ndir) - index=nodempc(3,index) - enddo - do j=1,3 - number=number+1 - if(number.gt.3) number=1 - if(dabs(ai(number,ndir)).lt.1.d-5) cycle - if(index.eq.0) then - write(*,*)'*ERROR in nonlinmpc: index=0' - stop - endif - nodempc(1,index)=nodei - nodempc(2,index)=number - coefmpc(index)=-ai(number,ndir) - index=nodempc(3,index) - enddo - enddo - elseif((labmpc(ii)(1:20).ne.' ').and. - & (labmpc(ii)(1:7).ne.'CONTACT').and. - & (labmpc(ii)(1:6).ne.'CYCLIC').and. - & (labmpc(ii)(1:9).ne.'SUBCYCLIC')) then - index=ipompc(ii) - i=0 - do - if(index.eq.0) exit - node=nodempc(1,index) - i=i+1 - iaux(i)=nodempc(2,index) - aux(6*maxlenmpc+i)=coefmpc(index) - do j=1,3 - aux(3*(i-1)+j)=co(j,node) - aux(3*(maxlenmpc+i-1)+j)=vold(j,node) - enddo - index=nodempc(3,index) - enddo - n=i-1 - if((labmpc(ii)(1:7).eq.'MEANROT').or. - & (labmpc(ii)(1:1).eq.'1')) then - call umpc_mean_rot(aux,aux(3*maxlenmpc+1),const, - & aux(6*maxlenmpc+1),iaux,n,fmpc(ii),iit,idiscon) - elseif(labmpc(ii)(1:4).eq.'DIST') then - call umpc_dist(aux,aux(3*maxlenmpc+1),const, - & aux(6*maxlenmpc+1),iaux,n,fmpc(ii),iit,idiscon) - elseif(labmpc(ii)(1:3).eq.'GAP') then - call umpc_gap(aux,aux(3*maxlenmpc+1),const, - & aux(6*maxlenmpc+1),iaux,n,fmpc(ii),iit,idiscon) - elseif(labmpc(ii)(1:4).eq.'USER') then - call umpc_user(aux,aux(3*maxlenmpc+1),const, - & aux(6*maxlenmpc+1),iaux,n,fmpc(ii),iit,idiscon) - else - write(*,*) '*ERROR in nonlinmpc: mpc of type',labmpc(ii) - write(*,*) ' is unknown' - stop - endif - index=ipompc(ii) -! - if(iaux(1).ne.nodempc(2,index)) then -! -! dependent MPC has changed -! - idofrem=8*(nodempc(1,index)-1)+nodempc(2,index) - idofins=8*(nodempc(1,index)-1)+iaux(1) - call changedepterm(ikmpc,ilmpc,nmpc,ii,idofrem,idofins) - if(icascade.eq.0) icascade=1 - endif -! - i=0 - do - if(index.eq.0) exit - i=i+1 - if(i.le.n) then -! -! check whether any directions have changed: -! necessitates calling of remastruct -! - if(iaux(i).ne.nodempc(2,index)) then - if(icascade.eq.0) icascade=1 - endif - nodempc(2,index)=iaux(i) - coefmpc(index)=aux(6*maxlenmpc+i) - else - coefmpc(index)=1.d0 -! -! old value of the nonhomogeneous term must be zero -! - vold(nodempc(2,index),nodempc(1,index))=0.d0 - idof=8*(nodempc(1,index)-1)+nodempc(2,index) - call nident(ikboun,idof,nboun,id) - xbounact(ilboun(id))=const - endif - index=nodempc(3,index) - enddo - endif - enddo loop -! -! incompressible material -! - if(.not.isochoric) return -! -! initialization of the mpc's -! - nmpc01=0 - nmpcdif=0 - do i=1,nmpc - if(labmpc(i)(1:9).eq.'ISOCHORIC') then - if(nmpc01.eq.0) nmpc01=i - nmpcdif=i - index=ipompc(i) - do - if(nodempc(3,index).eq.0) then - idof=8*(nodempc(1,index)-1)+nodempc(2,index) - call nident(ikboun,idof,nboun,id) - xbounact(ilboun(id))=0.d0 - exit - endif - coefmpc(index)=0.d0 - index=nodempc(3,index) - enddo - endif - enddo - nmpc0=nmpc01-1 - nmpcdif=nmpcdif-nmpc0 -! - do i=1,ne - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:7).eq.'C3D20RI') then - indexe=ipkon(i) -! - do j=1,20 - node=kon(indexe+j) - do k=1,3 - xlag(k,j)=co(k,node) - xeul(k,j)=xlag(k,j)+vold(k,node) - enddo - enddo -! - do j=1,8 - mpc=0 - node=kon(indexe+j) - label(1:9)='ISOCHORIC' - write(label(10:20),'(i11)') node -c write(*,*) 'nonlinmpclab ',label - call cident20(labmpc(nmpc01),label,nmpcdif,id) - id=id+nmpc0 -c write(*,*) 'nonlinmpclab ',id,label,labmpc(id) - if(id.gt.0) then - if(labmpc(id).eq.label) then - mpc=id - endif - endif - if(mpc.eq.0) cycle -! - xi=coloc(1,j) - et=coloc(2,j) - ze=coloc(3,j) -! - call deuldlag(xi,et,ze,xlag,xeul,xj,a) -! - b(1,1)=a(2,2)*a(3,3)-a(2,3)*a(3,2) - b(1,2)=a(3,1)*a(2,3)-a(2,1)*a(3,3) - b(1,3)=a(2,1)*a(3,2)-a(3,1)*a(2,2) - b(2,1)=a(3,2)*a(1,3)-a(1,2)*a(3,3) - b(2,2)=a(1,1)*a(3,3)-a(3,1)*a(1,3) - b(2,3)=a(3,1)*a(1,2)-a(1,1)*a(3,2) - b(3,1)=a(1,2)*a(2,3)-a(2,2)*a(1,3) - b(3,2)=a(2,1)*a(1,3)-a(1,1)*a(2,3) - b(3,3)=a(1,1)*a(2,2)-a(1,2)*a(2,1) -! - index=ipompc(mpc) - do - if(nodempc(3,index).eq.0) then - coefmpc(index)=1.d0 - idof=8*(nodempc(1,index)-1)+nodempc(2,index) - call nident(ikboun,idof,nboun,id) - xbounact(ilboun(id))=xbounact(ilboun(id))+ - & a(1,1)*b(1,1)+a(1,2)*b(1,2)+a(1,3)*b(1,3) - & -1.d0/xj -c write(*,*) 'nonlinmpcboun ',nodempc(1,index), -c & nodempc(2,index),ilboun(id), -c & xbounact(ilboun(id)) - exit - else - node=nodempc(1,index) - idir=nodempc(2,index) - do k=1,7 - if(kon(indexe+neigh(k,j)).eq.node) then - if(k.eq.1) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index)+ - & 1.5d0*(xi*b(1,1)+et*b(1,2)+ze*b(1,3)) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index)+ - & 1.5d0*(xi*b(2,1)+et*b(2,2)+ze*b(2,3)) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index)+ - & 1.5d0*(xi*b(3,1)+et*b(3,2)+ze*b(3,3)) - endif - elseif(k.eq.2) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index)- - & 2.d0*xi*b(1,1) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index)- - & 2.d0*xi*b(2,1) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index)- - & 2.d0*xi*b(3,1) - endif - elseif(k.eq.3) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index)+ - & 0.5d0*xi*b(1,1) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index)+ - & 0.5d0*xi*b(2,1) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index)+ - & 0.5d0*xi*b(3,1) - endif - elseif(k.eq.4) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index)- - & 2.d0*et*b(1,2) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index)- - & 2.d0*et*b(2,2) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index)- - & 2.d0*et*b(3,2) - endif - elseif(k.eq.5) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index)+ - & 0.5d0*et*b(1,2) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index)+ - & 0.5d0*et*b(2,2) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index)+ - & 0.5d0*et*b(3,2) - endif - elseif(k.eq.6) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index)- - & 2.d0*ze*b(1,3) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index)- - & 2.d0*ze*b(2,3) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index)- - & 2.d0*ze*b(3,3) - endif - elseif(k.eq.7) then - if(idir.eq.1) then - coefmpc(index)=coefmpc(index)+ - & 0.5d0*ze*b(1,3) - elseif(idir.eq.2) then - coefmpc(index)=coefmpc(index)+ - & 0.5d0*ze*b(2,3) - elseif(idir.eq.3) then - coefmpc(index)=coefmpc(index)+ - & 0.5d0*ze*b(3,3) - endif - endif - exit - endif - enddo - endif - index=nodempc(3,index) - enddo -! - enddo - endif - enddo -! - return - end - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/normals.f calculix-ccx-2.3/ccx_2.1/src/normals.f --- calculix-ccx-2.1/ccx_2.1/src/normals.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/normals.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,118 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine normals(inpc,textpart,iponor,xnor,ixfree, - & ipkon,kon,nk,nk_,ne,lakon,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! -! reading the input deck: *NORMAL -! - implicit none -! - character*1 inpc(*) - character*8 lakon(*) - character*132 textpart(16) -! - integer iponor(2,*),ixfree,ipkon(*),kon(*),nk,ipoinpc(0:*), - & nk_,ne,istep,istat,n,ielement,node,j,indexe, - & key,iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - real*8 xnor(*),x,y,z,dd -! - if(istep.gt.0) then - write(*,*) '*ERROR in normals: *NORMAL should be placed' - write(*,*) ' before all step definitions' - stop - endif -! - loop:do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit -! - read(textpart(1)(1:10),'(i10)',iostat=istat) ielement - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:10),'(i10)',iostat=istat) node - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) x - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(n.le.3) then - y=0.d0 - else - read(textpart(4)(1:20),'(f20.0)',iostat=istat) y - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - if(n.le.4) then - z=0.d0 - else - read(textpart(5)(1:20),'(f20.0)',iostat=istat) z - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif -! -! normalizing the normal -! - dd=dsqrt(x*x+y*y+z*z) - x=x/dd - y=y/dd - z=z/dd -! - if(ielement.gt.ne) then - write(*,*) '*ERROR in normals: element number',ielement - write(*,*) ' exceeds ne' - stop - endif -! - indexe=ipkon(ielement) - do j=1,8 - if(kon(indexe+j).eq.node) then - iponor(1,indexe+j)=ixfree - if(lakon(ielement)(1:1).eq.'B') then - xnor(ixfree+4)=x - xnor(ixfree+5)=y - xnor(ixfree+6)=z - ixfree=ixfree+6 - elseif(lakon(ielement)(1:2).ne.'C3') then - xnor(ixfree+1)=x - xnor(ixfree+2)=y - xnor(ixfree+3)=z - ixfree=ixfree+3 - else - write(*,*) '*WARNING in normals: specifying a normal' - write(*,*) ' 3-D element does not make sense' - endif - cycle loop - endif - enddo - write(*,*) '*WARNING: node ',node,' does not belong to' - write(*,*) ' element ',ielement - write(*,*) ' normal definition discarded' -! - enddo loop -! - return - end - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/norshell6.f calculix-ccx-2.3/ccx_2.1/src/norshell6.f --- calculix-ccx-2.1/ccx_2.1/src/norshell6.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/norshell6.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,82 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine norshell6(xi,et,xl,xnor) -! -! calculates the normal on a triangular shell element in a point -! with local coordinates xi and et. The coordinates of the nodes -! belonging to the element are stored in xl -! - implicit none -! - integer i,j,k -! - real*8 shp(4,6),xs(3,2),xl(3,6),xnor(3) -! - real*8 xi,et -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=4.d0*(xi+et)-3.d0 - shp(1,2)=4.d0*xi-1.d0 - shp(1,3)=0.d0 - shp(1,4)=4.d0*(1.d0-2.d0*xi-et) - shp(1,5)=4.d0*et - shp(1,6)=-4.d0*et -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=4.d0*(xi+et)-3.d0 - shp(2,2)=0.d0 - shp(2,3)=4.d0*et-1.d0 - shp(2,4)=-4.d0*xi - shp(2,5)=4.d0*xi - shp(2,6)=4.d0*(1.d0-xi-2.d0*et) -! -! shape functions -! - shp(4,1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et) - shp(4,2)=xi*(2.d0*xi-1.d0) - shp(4,3)=et*(2.d0*et-1.d0) - shp(4,4)=4.d0*xi*(1.d0-xi-et) - shp(4,5)=4.d0*xi*et - shp(4,6)=4.d0*et*(1.d0-xi-et) -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,6 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian determinant -! - xnor(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xnor(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xnor(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/norshell8.f calculix-ccx-2.3/ccx_2.1/src/norshell8.f --- calculix-ccx-2.1/ccx_2.1/src/norshell8.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/norshell8.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine norshell8(xi,et,xl,xnor) -! -! calculates the normal on a quadratic shell element in a point -! with local coordinates xi and et. The coordinates of the nodes -! belonging to the element are stored in xl -! - implicit none -! - integer i,j,k -! - real*8 shp(4,8),xs(3,2),xl(3,8),xnor(3) -! - real*8 xi,et -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=(1.d0-et)*(2.d0*xi+et)/4.d0 - shp(1,2)=(1.d0-et)*(2.d0*xi-et)/4.d0 - shp(1,3)=(1.d0+et)*(2.d0*xi+et)/4.d0 - shp(1,4)=(1.d0+et)*(2.d0*xi-et)/4.d0 - shp(1,5)=-xi*(1.d0-et) - shp(1,6)=(1.d0-et*et)/2.d0 - shp(1,7)=-xi*(1.d0+et) - shp(1,8)=-(1.d0-et*et)/2.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=(1.d0-xi)*(2.d0*et+xi)/4.d0 - shp(2,2)=(1.d0+xi)*(2.d0*et-xi)/4.d0 - shp(2,3)=(1.d0+xi)*(2.d0*et+xi)/4.d0 - shp(2,4)=(1.d0-xi)*(2.d0*et-xi)/4.d0 - shp(2,5)=-(1.d0-xi*xi)/2.d0 - shp(2,6)=-et*(1.d0+xi) - shp(2,7)=(1.d0-xi*xi)/2.d0 - shp(2,8)=-et*(1.d0-xi) -! -! shape functions -! - shp(4,1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0 - shp(4,2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0 - shp(4,3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0 - shp(4,4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0 - shp(4,5)=(1.d0-xi*xi)*(1.d0-et)/2.d0 - shp(4,6)=(1.d0+xi)*(1.d0-et*et)/2.d0 - shp(4,7)=(1.d0-xi*xi)*(1.d0+et)/2.d0 - shp(4,8)=(1.d0-xi)*(1.d0-et*et)/2.d0 -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,8 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian determinant -! - xnor(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xnor(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xnor(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/number.f calculix-ccx-2.3/ccx_2.1/src/number.f --- calculix-ccx-2.1/ccx_2.1/src/number.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/number.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,99 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine number(n,nc,snode,lstnum,e2,adj,xadj,s,q,p) -! -! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) -! - integer nc,lstnum,jstrt,jstop,istop,nbr,nabor,i,j,next,addres,nn, - & node,snode,istrt,maxprt,prty,n,w1,w2,e2,q(nc),xadj(n+1),adj(e2), - & p(n),s(n) -! - parameter(w1=1,w2=2) -! - do 10 i=1,nc - node=q(i) - p(node)=w1*s(node)-w2*(xadj(node+1)-xadj(node)+1) - s(node)=-2 - 10 continue -! - nn=1 - q(nn)=snode - s(snode)=-1 -! - 30 if(nn.gt.0) then -! - addres=1 - maxprt=p(q(1)) - do 35 i=2,nn - prty=p(q(i)) - if(prty.gt.maxprt) then - addres=i - maxprt=prty - endif - 35 continue -! - next=q(addres) -! - q(addres)=q(nn) - nn=nn-1 - istrt=xadj(next) - istop=xadj(next+1)-1 - if(s(next).eq.-1) then -! - do 50 i=istrt,istop -! - nbr=adj(i) - p(nbr)=p(nbr)+w2 -! - if(s(nbr).eq.-2) then - nn=nn+1 - q(nn)=nbr - s(nbr)=-1 - endif - 50 continue - endif -! - lstnum=lstnum+1 - s(next)=lstnum -! - do 80 i=istrt,istop - nbr=adj(i) - if(s(nbr).eq.-1) then -! - p(nbr)=p(nbr)+w2 - s(nbr)=0 -! - jstrt=xadj(nbr) - jstop=xadj(nbr+1)-1 - do 60 j=jstrt,jstop - nabor=adj(j) -! - p(nabor)=p(nabor)+w2 - if(s(nabor).eq.-2) then -! - nn=nn+1 - q(nn)=nabor - s(nabor)=-1 - endif - 60 continue - endif - 80 continue - go to 30 - endif - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/onedint.f calculix-ccx-2.3/ccx_2.1/src/onedint.f --- calculix-ccx-2.1/ccx_2.1/src/onedint.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/onedint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,214 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -C -C 1. TASK INTERPOLATION OF A FUNCTION DEFINED POINT BY POINT -C ********* THE X COORDINATES ARE USER SPECIFIED. -C THE INTERPOLATION PROCESS CAN BE EITHER CONSTANT,LINEAR -c OR EVEN dOUBLE QUADRATIC WITH EXTRAPOLATION USING THE -c POLYNOM HIGHEST ORDER -C thE DOUBLE QUADRATIC INTERPOLATION IS A 3RD ORDER METHOD -c BY WHICH 2 PARABOLS ENCOMPASSING EACH 3 AND 4 sAMPLING POINTS -c ARE DEFINED. -c THE SOLUTION IS A LINEAR COMBINATION OF THE CONCERNED -c PARABOLS VALUES DEPENDING ON THE DEFINITION OF THE ACTUAL -c SAMPLING POINT INTERVAL -C -C -C 2.INPUT CALL A06931(XE,YE,NE,XA,YA,NA,IART,IEXP,IER) -C *********** XE = ABSCISSE VECTOR OF THE SAMPLING POINTS -C YE = ORDINATE VECTOR OF THE SAMPLING POINTS -C NE = LENGHT OF THE SAMPLING POINT VECTOR -C XA = ASCISSE VECTOR OF THE INTERPOLATION POINT(INPUT) -C YA = ORDINATE VECTOR OF THE INTERPOLATION POINT(OUTPUT) -C NA = LENGTH OF THE INTERPOLATION VECTOR c IART = tYPE OF INTERPOLATION -C =0: CONSTANT -C =1: LINEAR -C =2: DOUBLE QUADRATIC -C IEXP = TYPE OF EXTRAPOLATION -C IEXP = 10*IEX1 + IEXN -C IEX1 EXTRAPOLATIONS BEYOND THE -C 1. SAMPLING POINT IN THE VECTOR -C IEXN EXTRAPOLATION BEYOND THE -C LAST SAMPLING POINT IN THE VECTOR -C SELECTION OF THE EXTRAPOLATION TYPE AS -C FOR IART. -C IER = ERROR CODE -C = 0: NORMAL PROCEEDING -C =-1:PROBLEM IN TH EGIVEN VALUES -C PROGRAMM STOPS. -C -C 3.RESTRICTION ABSCISSE VECTOR XE MUST BE STRICTLY MONOTONIC INCREASING SORTED -C *************** AUTOMATIC CONTROL INSIDE TEH SUBROUTINE: -C NE = 0: ERROR INTERRUPTION -C NE = 1: ONLY CONSTANT INTER- EXTRAPOLATION -C NE = 2: MAXIMAL LINEAR INTER- EXTRAPOLATION -C NE = 3: MAXIMAL QUADRATIC INTER- EXTRAPOLATIO -C THE PARAMETER FOR THE TYPE OF EXTRAPOLATION -c MUST NOT BE GREATER THAN THE ONE FOR TH EINTERPOLATION TYPE -C OTHERWISE THE VALUE IS AUTOMATICALLY ADAPTATED -C - SUBROUTINE ONEDINT(XE,YE,NE,XA,YA,NA,IART,IEXP,IER) - implicit none - INTEGER NE,NA,NA1,NE1,IG,IER,IA,IART,IE2,I,IEXP,IE1,L - REAL*8 XE(NE),YE(NE),XA(NA),YA(NA),ZW1,ZW2,XO,YO,RAB,XD,YD, - & XZ,YZ,XU,YU,EQ,EQD,X -C -C INTERPOLATION FUNCTION -C ------------------------ - EQ(X) = YU + YU * (X-XU) / XU + - 1 ((YZ-YU)/(XZ-XU) - YU/XU) * (X-XU) * X / XZ - EQD(X) = YZ * X / XZ + - 1 (YD / XD - YZ / XZ) * X * (X - XZ) / (XD - XZ) -C -C INPUT/DATA TEST,INTERPOLATION DIVERGENCE,EXTRAPOLATION LIMIT -C---------------------------------------------------------------- - NA1 = NA - 1 - IF (NA .LE. 0) GO TO 900 - NE1 = NE - 1 - IF (NE1.lt.0) then - go to 900 - elseif(ne1.eq.0) then - go to 22 - else - go to 18 - endif - 18 DO 20 L = 1,NE1 - 20 IF ((XE(L+1)-XE(L)) .LE. 0) GO TO 900 - 22 IE1 = IEXP / 10 - IE2 = IEXP - 10*IE1 - IA = IART - IF (NE1 .LT. IA) IA = NE1 - IF (IA .LT. IE1) IE1 = IA - IF (IA .LT. IE2) IE2 = IA -C -C SUCCESSIVE PROCESSING THE INTERPOLATION EXIGENCES -C------------------------------------------------------- -C -C ZUR ERHOEHUNG DER NUMERISCHEN GENAUIGKEIT WIRD EINE -C TRANSLATION VON (XO,YO) IN (0,0) DURCHGEFUEHRT. DIES -C BEWIRKT AUSSERDEM EINE BESCHLEUNIGUNG DES VERFAHRENS. -C - DO 100 I = 1,NA - DO 24 L = 1,NE - IF (XA(I) .LT. XE(L)) GO TO 30 - 24 CONTINUE - L = NE - IF ((IE2 - 1).lt.0) then - go to 50 - elseif((ie2-1).eq.0) then - go to 35 - else - go to 70 - endif - 30 IF (L .GT. 1) GO TO 40 - IF ((IE1 - 1).lt.0) then - go to 50 - elseif((ie1-1).eq.0) then - go to 25 - else - go to 70 - endif - 40 IF ((IA-1).lt.0) then - go to 45 - elseif((ia-1).eq.0) then - go to 60 - else - go to 70 - endif -C -C CONSTANT INTERPOLATION -C ----------------------- - 45 L = L - 1 - 50 YA(I) = YE(L) - GO TO 100 -C -C LINEAR EXTRAPOLATION -C ------------------------------ - 25 IF (IA .EQ. 1) GO TO 60 - XO = XE(2) - XU = XE(1) - XO - YO = YE(2) - YU = YE(1) - YO - XZ = XE(3) - XO - YZ = YE(3) - YO - GO TO 38 - 35 IF (IA .EQ. 1) GO TO 60 - XO = XE(NE1) - XZ = XE(NE1-1) - XO - XU = XE(NE) - XO - YO = YE(NE1) - YZ = YE(NE1-1) - YO - YU = YE(NE) - YO -C -C LINEAR EXTRAPOLATION WITH QUADRATIC INTERPOLATION -C ----------------------------------------------------- - 38 RAB = YU / XU + XU * ((YZ-YU) / (XZ-XU) - YU/XU) / XZ - YA(I) = YU + YO + (XA(I) -XU-XO)*RAB - GO TO 100 -C -C LINEAR INTERPOLATION -C --------------------- - 60 IG = L - 1 - IF (IG .LT. 1) IG = 1 - YA(I) = YE(IG) + (XA(I)-XE(IG))*(YE(IG+1)-YE(IG)) - 1 / (XE(IG+1)-XE(IG)) - GO TO 100 - 70 IF (L .GT. 2) GO TO 80 - XO = XE(2) - XU = XE(1) - XO - YO = YE(2) - YU = YE(1) - YO - XZ = XE(3) - XO - YZ = YE(3) - YO - GO TO 85 - 80 IF (L .LT. NE) GO TO 90 - XO = XE(NE1) - XU = XE(NE1-1) - XO - XZ = XE(NE) - XO - YO = YE(NE1) - YU = YE(NE1-1) - YO - YZ = YE(NE) - YO - 85 YA(I) = EQ(XA(I)-XO) + YO - GO TO 100 -C -C DOUBLE QUADRATIC INTERPOLATION -C ---------------------------------- - 90 XO = XE(L-1) - XU = XE(L-2) - XO - XZ = XE(L) - XO - XD = XE(L+1) - XO - YO = YE(L-1) - YU = YE(L-2) - YO - YZ = YE(L) - YO - YD = YE(L+1) - YO - ZW1 = EQ(XA(I)-XO) - ZW2 = EQD(XA(I)-XO) - YA(I) = ZW1 + (ZW2 - ZW1) * (XA(I) - XO)/XZ + YO - 100 CONTINUE -C -C RETURN BY NORMAL PROCEEDING -C ------------------------------- - IER = 0 - RETURN -C -C ERROR RETURN -C ------------ - 900 IER = -1 - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/onf.f calculix-ccx-2.3/ccx_2.1/src/onf.f --- calculix-ccx-2.1/ccx_2.1/src/onf.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/onf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,490 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine onf(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod, - & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern,xstaten, - & nstate_,istep,iinc,iperturb,ener,mi) -! -! stores the results in frd format -! - implicit none -! - character*5 m1 - character*8 lakon(*) - character*80 matname(*) - character*87 filab(*) -! - integer kon(*),inum(*),nk,ne,nmethod,kode,i,j,ipkon(*),indexe, - & one,ielmat(*),nstate_,istep,iinc,ianatyp,iperturb, - & konl(20),jj,mint3d,k,nope,mi(2),n,kflag,iy(3),iflag, - & nktrue,netrue -! - real*8 co(3,*),v(3,*),stn(6,*),een(6,*),t1(*),fn(3,*),time, - & epn(*),enern(*),xstaten(nstate_,*),zero,stnprin(3),str(6), - & str2(6),v1,v2,v3,ener(mi(1),*),xi,et,ze,weight,volume, - & energy,totenergy,xsj,xl(3,20),shp(4,20),tt,cm,cn, - & bb,cc,pi -! - include "gauss.f" -! - data iflag /2/ -! - one=1 - zero=0.d0 - m1=' -1' - pi=4.d0*datan(1.d0) - n=3 - kflag=-1 -! -c open(12,file='beam_520.onf',status='unknown') -c open(13,file='beam.onf',status='unknown') - if(nmethod.eq.1) then - if(iperturb.gt.1) then - ianatyp=5 - else - ianatyp=1 - endif - elseif(nmethod.eq.2) then - ianatyp=2 - elseif(nmethod.eq.3) then - ianatyp=6 - elseif(nmethod.eq.4) then - if(iperturb.gt.1) then - ianatyp=2 - else - ianatyp=4 - endif - endif -! -! calculating the true number of nodes and elements -! - nktrue=0 - do i=1,nk - if(inum(i).ne.0) nktrue=nktrue+1 - enddo - netrue=0 - do i=1,ne - if(ipkon(i).ge.0) netrue=netrue+1 - enddo -! -! storing the frequency and/or the buckling eigenvalue -! - if((nmethod.eq.2).or.(nmethod.eq.3)) then - write(11,'(a5)') m1 - write(11,'(a3)') '500' - write(11,'(i1)') one - write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc - write(11,'(i10)') one - write(11,99) time,zero,zero,zero - endif -! -! storing the displacements of the nodes -! - if(filab(1)(1:4).eq.'U ') then -! - write(11,'(a5)') m1 - write(11,'(a3)') '510' - write(11,'(i1)') one - write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc - write(11,'(i10)') nktrue -! - do i=1,nk - if(inum(i).eq.0) cycle - write(11,100) i,(v(j,i),j=1,3),zero,zero,zero - enddo -! - write(11,'(a5)') m1 - endif -! -! storing the stresses in the nodes -! - if(filab(3)(1:4).eq.'S ') then -! -! calculating the nodal principal stress -! - write(11,'(a5)') m1 - write(11,'(a3)') '520' - write(11,'(i1)') one - write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc - write(11,'(i10)') nktrue -! - do i=1,nk - if(inum(i).eq.0) cycle - do j=1,6 - str(j)=stn(j,i) - enddo - str2(1)=str(1)*str(1)+str(4)*str(4)+str(5)*str(5) - str2(2)=str(4)*str(4)+str(2)*str(2)+str(6)*str(6) - str2(3)=str(5)*str(5)+str(6)*str(6)+str(3)*str(3) -c str2(4)=str(1)*str(4)+str(4)*str(2)+str(5)*str(6) -c str2(5)=str(1)*str(5)+str(4)*str(6)+str(5)*str(3) -c str2(6)=str(4)*str(5)+str(2)*str(6)+str(6)*str(3) - v1=str(1)+str(2)+str(3) - v2=(v1*v1-str2(1)-str2(2)-str2(3))/2.d0 - v3=str(1)*(str(2)*str(3)-str(6)*str(6)) - & -str(4)*(str(4)*str(3)-str(5)*str(6)) - & +str(5)*(str(4)*str(6)-str(5)*str(2)) - bb=v2-v1*v1/3.d0 - cc=-2.d0*v1**3/27.d0+v1*v2/3.d0-v3 - if(dabs(bb).le.1.d-10) then - stnprin(1)=0.d0 - stnprin(2)=0.d0 - stnprin(3)=0.d0 - else - cm=2.d0*dsqrt(-bb/3.d0) - cn=3.d0*cc/(cm*bb) - if(dabs(cn).gt.1.d0) then - if(cn.gt.1.d0) then - cn=1.d0 - else - cn=-1.d0 - endif - endif - tt=datan2(dsqrt(1.d0-cn*cn),cn)/3.d0 - stnprin(1)=cm*dcos(tt) - stnprin(2)=cm*dcos(tt+2.d0*pi/3.d0) - stnprin(3)=cm*dcos(tt+4.d0*pi/3.d0) - endif - do j=1,3 - stnprin(j)=stnprin(j)+v1/3.d0 - enddo - call dsort(stnprin,iy,n,kflag) - write(11,101) i,one,(stnprin(j),j=1,3) - enddo - write(11,'(a5)') m1 -! -! calculating the elemental principal stress -! - write(11,'(a5)') m1 - write(11,'(a3)') '530' - write(11,'(i1)') one - write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc - write(11,'(i10)') netrue -! - do i=1,ne - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - else - nope=6 - endif -! -! calculating the eigenvalues of the mean stress -! tensor. The mean tensor is taken over the nodes -! belonging to the element -! - do j=1,6 - str(j)=0.d0 - do k=1,nope - str(j)=str(j)+stn(j,kon(indexe+k)) - enddo - str(j)=str(j)/nope - enddo - str2(1)=str(1)*str(1)+str(4)*str(4)+str(5)*str(5) - str2(2)=str(4)*str(4)+str(2)*str(2)+str(6)*str(6) - str2(3)=str(5)*str(5)+str(6)*str(6)+str(3)*str(3) -c str2(4)=str(1)*str(4)+str(4)*str(2)+str(5)*str(6) -c str2(5)=str(1)*str(5)+str(4)*str(6)+str(5)*str(3) -c str2(6)=str(4)*str(5)+str(2)*str(6)+str(6)*str(3) - v1=str(1)+str(2)+str(3) - v2=(v1*v1-str2(1)-str2(2)-str2(3))/2.d0 - v3=str(1)*(str(2)*str(3)-str(6)*str(6)) - & -str(4)*(str(4)*str(3)-str(5)*str(6)) - & +str(5)*(str(4)*str(6)-str(5)*str(2)) - bb=v2-v1*v1/3.d0 - cc=-2.d0*v1**3/27.d0+v1*v2/3.d0-v3 - if(dabs(bb).le.1.d-10) then - stnprin(1)=0.d0 - stnprin(2)=0.d0 - stnprin(3)=0.d0 - else - cm=2.d0*dsqrt(-bb/3.d0) - cn=3.d0*cc/(cm*bb) - if(dabs(cn).gt.1.d0) then - if(cn.gt.1.d0) then - cn=1.d0 - else - cn=-1.d0 - endif - endif - tt=datan2(dsqrt(1.d0-cn*cn),cn)/3.d0 - stnprin(1)=cm*dcos(tt) - stnprin(2)=cm*dcos(tt+2.d0*pi/3.d0) - stnprin(3)=cm*dcos(tt+4.d0*pi/3.d0) - endif - call dsort(stnprin,iy,n,kflag) - do j=1,3 - stnprin(j)=stnprin(j)+v1/3.d0 - enddo - write(11,101) i,one,(stnprin(j),j=1,3) - enddo -! - write(11,'(a5)') m1 - endif -! - if(filab(7)(1:4).eq.'ENER') then -! -! calculating the energy -! - write(11,'(a5)') m1 - write(11,'(a3)') '540' - write(11,'(i1)') one - write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc - write(11,'(i10)') netrue -! -! calculating the total energy -! - totenergy=0.d0 - do i=1,ne - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) -! - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - else - nope=6 - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - do k=1,3 - xl(k,j)=co(k,konl(j)) - enddo - enddo -! - if(lakon(i)(4:5).eq.'8R') then - mint3d=1 - elseif((lakon(i)(4:4).eq.'8').or. - & (lakon(i)(4:6).eq.'20R')) then - mint3d=8 - elseif(lakon(i)(4:4).eq.'2') then - mint3d=27 - elseif(lakon(i)(4:5).eq.'10') then - mint3d=4 - elseif(lakon(i)(4:4).eq.'4') then - mint3d=1 - elseif(lakon(i)(4:5).eq.'15') then - mint3d=9 - else - mint3d=2 - endif -! - do jj=1,mint3d - if(lakon(i)(4:5).eq.'8R') then - xi=gauss3d1(1,jj) - et=gauss3d1(2,jj) - ze=gauss3d1(3,jj) - weight=weight3d1(jj) - elseif((lakon(i)(4:4).eq.'8').or. - & (lakon(i)(4:6).eq.'20R')) - & then - xi=gauss3d2(1,jj) - et=gauss3d2(2,jj) - ze=gauss3d2(3,jj) - weight=weight3d2(jj) - elseif(lakon(i)(4:4).eq.'2') then - xi=gauss3d3(1,jj) - et=gauss3d3(2,jj) - ze=gauss3d3(3,jj) - weight=weight3d3(jj) - elseif(lakon(i)(4:5).eq.'10') then - xi=gauss3d5(1,jj) - et=gauss3d5(2,jj) - ze=gauss3d5(3,jj) - weight=weight3d5(jj) - elseif(lakon(i)(4:4).eq.'4') then - xi=gauss3d4(1,jj) - et=gauss3d4(2,jj) - ze=gauss3d4(3,jj) - weight=weight3d4(jj) - elseif(lakon(i)(4:5).eq.'15') then - xi=gauss3d8(1,jj) - et=gauss3d8(2,jj) - ze=gauss3d8(3,jj) - weight=weight3d8(jj) - else - xi=gauss3d7(1,jj) - et=gauss3d7(2,jj) - ze=gauss3d7(3,jj) - weight=weight3d7(jj) - endif -! - if(nope.eq.20) then - if(lakon(i)(7:7).eq.'A') then - call shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) - elseif((lakon(i)(7:7).eq.'E').or. - & (lakon(i)(7:7).eq.'S')) then - call shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) - else - call shape20h(xi,et,ze,xl,xsj,shp,iflag) - endif - elseif(nope.eq.8) then - call shape8h(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.10) then - call shape10tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.4) then - call shape4tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.15) then - call shape15w(xi,et,ze,xl,xsj,shp,iflag) - else - call shape6w(xi,et,ze,xl,xsj,shp,iflag) - endif -! - totenergy=totenergy+weight*ener(jj,i)*xsj - enddo - enddo -! -! calculating the element energy... -! - do i=1,ne - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) -! - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - else - nope=6 - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - do k=1,3 - xl(k,j)=co(k,konl(j)) - enddo - enddo -! - energy=0.d0 - volume=0.d0 -! - if(lakon(i)(4:5).eq.'8R') then - mint3d=1 - elseif((lakon(i)(4:4).eq.'8').or. - & (lakon(i)(4:6).eq.'20R')) then - mint3d=8 - elseif(lakon(i)(4:4).eq.'2') then - mint3d=27 - elseif(lakon(i)(4:5).eq.'10') then - mint3d=4 - elseif(lakon(i)(4:4).eq.'4') then - mint3d=1 - elseif(lakon(i)(4:5).eq.'15') then - mint3d=9 - else - mint3d=2 - endif -! - do jj=1,mint3d - if(lakon(i)(4:5).eq.'8R') then - xi=gauss3d1(1,jj) - et=gauss3d1(2,jj) - ze=gauss3d1(3,jj) - weight=weight3d1(jj) - elseif((lakon(i)(4:4).eq.'8').or. - & (lakon(i)(4:6).eq.'20R')) - & then - xi=gauss3d2(1,jj) - et=gauss3d2(2,jj) - ze=gauss3d2(3,jj) - weight=weight3d2(jj) - elseif(lakon(i)(4:4).eq.'2') then - xi=gauss3d3(1,jj) - et=gauss3d3(2,jj) - ze=gauss3d3(3,jj) - weight=weight3d3(jj) - elseif(lakon(i)(4:5).eq.'10') then - xi=gauss3d5(1,jj) - et=gauss3d5(2,jj) - ze=gauss3d5(3,jj) - weight=weight3d5(jj) - elseif(lakon(i)(4:4).eq.'4') then - xi=gauss3d4(1,jj) - et=gauss3d4(2,jj) - ze=gauss3d4(3,jj) - weight=weight3d4(jj) - elseif(lakon(i)(4:5).eq.'15') then - xi=gauss3d8(1,jj) - et=gauss3d8(2,jj) - ze=gauss3d8(3,jj) - weight=weight3d8(jj) - else - xi=gauss3d7(1,jj) - et=gauss3d7(2,jj) - ze=gauss3d7(3,jj) - weight=weight3d7(jj) - endif -! - if(nope.eq.20) then - if(lakon(i)(7:7).eq.'A') then - call shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) - elseif((lakon(i)(7:7).eq.'E').or. - & (lakon(i)(7:7).eq.'S')) then - call shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) - else - call shape20h(xi,et,ze,xl,xsj,shp,iflag) - endif - elseif(nope.eq.8) then - call shape8h(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.10) then - call shape10tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.4) then - call shape4tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.15) then - call shape15w(xi,et,ze,xl,xsj,shp,iflag) - else - call shape6w(xi,et,ze,xl,xsj,shp,iflag) - endif -! - energy=energy+weight*xsj*ener(jj,i) - volume=volume+weight*xsj - enddo - write(11,102) i,energy,energy/totenergy,energy/volume - enddo - write(11,'(a5)') m1 - endif - 99 format(e12.5,3(",",e12.5)) - 100 format(i10,6(",",e12.5)) - 101 format(i10,",",i5,3(",",e12.5)) - 102 format(i10,3(",",e12.5)) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/opcs.f calculix-ccx-2.3/ccx_2.1/src/opcs.f --- calculix-ccx-2.1/ccx_2.1/src/opcs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/opcs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -C -C-----MATRIX-VECTOR MULTIPLY FOR REAL SPARSE SYMMETRIC MATRICES--------- -C - SUBROUTINE OPcs(n,p,W,U,ad,asd,icol,irow,nzl) - implicit real*8(a-h,o-z) -! -C----------------------------------------------------------------------- - DOUBLE PRECISION U(*),W(*),Asd(*),AD(*),p(*) - INTEGER IROW(*),ICOL(*),n,nzl -C----------------------------------------------------------------------- -C SPARSE MATRIX-VECTOR MULTIPLY FOR LANCZS U = A*W -C SEE USPEC SUBROUTINE FOR DESCRIPTION OF THE ARRAYS THAT DEFINE -C THE MATRIX -c the vector p is not needed but is kept for compatibility reasons -c with the calling program -C----------------------------------------------------------------------- -C -C COMPUTE THE DIAGONAL TERMS - DO 10 I = 1,N - U(I) = AD(I)*W(I) - 10 CONTINUE -C -C COMPUTE BY COLUMN - LLAST = 0 - DO 30 J = 1,NZL -C - IF (ICOL(J).EQ.0) GO TO 30 - LFIRST = LLAST + 1 - LLAST = LLAST + ICOL(J) -C - DO 20 L = LFIRST,LLAST - I = IROW(L) - if(i>n) cycle -C - U(I) = U(I) + Asd(L)*W(J) - U(J) = U(J) + Asd(L)*W(I) -C - 20 CONTINUE -C - 30 CONTINUE -C - RETURN - END - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/openfile.f calculix-ccx-2.3/ccx_2.1/src/openfile.f --- calculix-ccx-2.1/ccx_2.1/src/openfile.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/openfile.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,103 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine openfile(jobname,output) -! - implicit none -! - logical exi - character*3 output - character*132 jobname,fnin,fndat,fnfrd,fnsta,fnonf - integer i -! -! opening the input and output file -! - do i=1,132 - if(jobname(i:i).eq.' ') exit - enddo - i=i-1 - if(i.gt.128) then - write(*,*) '*ERROR in openfile: input file name is too long:' - write(*,'(a132)') jobname(1:132) - write(*,*) ' exceeds 128 characters' - stop - endif -! - fnin=jobname(1:i)//'.inp' - inquire(file=fnin,exist=exi) - if(exi) then - open(1,file=fnin,status='old',err=1) - else - write(*,*) '*ERROR in openfile: input file ',fnin - write(*,*) 'does not exist' - stop - endif -! - fndat=jobname(1:i)//'.dat' - open(5,file=fndat,status='unknown',err=51) - close(5,status='delete',err=52) - open(5,file=fndat,status='unknown',err=51) -c rewind(5) -! - if(output.ne.'onf') then - fnfrd=jobname(1:i)//'.frd' - open(7,file=fnfrd,status='unknown',err=71) - close(7,status='delete',err=72) - open(7,file=fnfrd,status='unknown',err=71) -c rewind(7) - endif -! - fnsta=jobname(1:i)//'.sta' - open(8,file=fnsta,status='unknown',err=81) - close(8,status='delete',err=82) - open(8,file=fnsta,status='unknown',err=81) -c rewind(8) - write(8,100) - write(8,101) - 100 format('SUMMARY OF JOB INFORMATION') - 101 format(' STEP INC ATT ITRS TOT TIME STEP TIME - & INC TIME') -! - if(output.eq.'onf') then - fnonf=jobname(1:i)//'.onf' - open(11,file=fnonf,status='unknown',err=111) - close(11,status='delete',err=112) - open(11,file=fnonf,status='new',err=111) - endif -! - return -! - 1 write(*,*) '*ERROR in openfile: could not open file ',fnin - stop - 51 write(*,*) '*ERROR in openfile: could not open file ',fndat - stop - 52 write(*,*) '*ERROR in openfile: could not delete file ',fndat - stop - 71 write(*,*) '*ERROR in openfile: could not open file ',fnfrd - stop - 72 write(*,*) '*ERROR in openfile: could not delete file ',fnfrd - stop - 81 write(*,*) '*ERROR in openfile: could not open file ',fnsta - stop - 82 write(*,*) '*ERROR in openfile: could not delete file ',fnsta - stop - 111 write(*,*) '*ERROR in openfile: could not open file ',fnonf - stop - 112 write(*,*) '*ERROR in openfile: could not delete file ',fnonf - stop - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/op.f calculix-ccx-2.3/ccx_2.1/src/op.f --- calculix-ccx-2.1/ccx_2.1/src/op.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/op.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -C -C-----MATRIX-VECTOR MULTIPLY FOR REAL SPARSE SYMMETRIC MATRICES--------- -C - SUBROUTINE OP(n,p,W,U,ad,asd,icol,irow,nzl) - implicit real*8(a-h,o-z) -! -C----------------------------------------------------------------------- - DOUBLE PRECISION U(*),W(*),Asd(*),AD(*),p(*) - INTEGER IROW(*),ICOL(*),n,nzl -C----------------------------------------------------------------------- -C SPARSE MATRIX-VECTOR MULTIPLY FOR LANCZS U = A*W -C SEE USPEC SUBROUTINE FOR DESCRIPTION OF THE ARRAYS THAT DEFINE -C THE MATRIX -c the vector p is not needed but is kept for compatibility reasons -c with the calling program -C----------------------------------------------------------------------- -C -C COMPUTE THE DIAGONAL TERMS - DO 10 I = 1,N - U(I) = AD(I)*W(I) - 10 CONTINUE -C -C COMPUTE BY COLUMN - LLAST = 0 - DO 30 J = 1,NZL -C - IF (ICOL(J).EQ.0) GO TO 30 - LFIRST = LLAST + 1 - LLAST = LLAST + ICOL(J) -C - DO 20 L = LFIRST,LLAST - I = IROW(L) -C - U(I) = U(I) + Asd(L)*W(J) - U(J) = U(J) + Asd(L)*W(I) -C - 20 CONTINUE -C - 30 CONTINUE -C - RETURN - END - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/opnonsym.f calculix-ccx-2.3/ccx_2.1/src/opnonsym.f --- calculix-ccx-2.1/ccx_2.1/src/opnonsym.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/opnonsym.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -C -C-----MATRIX-VECTOR MULTIPLY FOR REAL SPARSE NONSYMMETRIC MATRICES--------- -C - SUBROUTINE OPNONSYM(n,p,W,U,ad,asd,jq,irow) - implicit real*8(a-h,o-z) -! -C----------------------------------------------------------------------- - DOUBLE PRECISION U(*),W(*),Asd(*),AD(*),p(*) - INTEGER IROW(*),JQ(*),n -C----------------------------------------------------------------------- -C SPARSE MATRIX-VECTOR MULTIPLY FOR LANCZS U = A*W -C SEE USPEC SUBROUTINE FOR DESCRIPTION OF THE ARRAYS THAT DEFINE -C THE MATRIX -c the vector p is not needed but is kept for compatibility reasons -c with the calling program -C----------------------------------------------------------------------- -C -C COMPUTE THE DIAGONAL TERMS - DO 10 I = 1,N - U(I) = AD(I)*W(I) - 10 CONTINUE -C -C COMPUTE BY COLUMN - LLAST = 0 - DO 30 J = 1,N -C - DO 20 L = JQ(J),JQ(J+1)-1 - I = IROW(L) -C - U(I) = U(I) + Asd(L)*W(J) -C - 20 CONTINUE -C - 30 CONTINUE -C - RETURN - END - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/opnonsymt.f calculix-ccx-2.3/ccx_2.1/src/opnonsymt.f --- calculix-ccx-2.1/ccx_2.1/src/opnonsymt.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/opnonsymt.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -C -C-----MATRIX-VECTOR MULTIPLY FOR REAL SPARSE NONSYMMETRIC MATRICES--------- -C - SUBROUTINE OPNONSYMt(n,p,W,U,ad,asd,jq,irow) - implicit real*8(a-h,o-z) -! -C----------------------------------------------------------------------- - DOUBLE PRECISION U(*),W(*),Asd(*),AD(*),p(*) - INTEGER IROW(*),JQ(*),n -C----------------------------------------------------------------------- -C SPARSE MATRIX-VECTOR MULTIPLY FOR LANCZS U = A*W -C SEE USPEC SUBROUTINE FOR DESCRIPTION OF THE ARRAYS THAT DEFINE -C THE MATRIX -c the vector p is not needed but is kept for compatibility reasons -c with the calling program -C----------------------------------------------------------------------- -C -C COMPUTE THE DIAGONAL TERMS - DO 10 I = 1,N - U(I) = AD(I)*W(I)+U(I) - 10 CONTINUE -C -C COMPUTE BY COLUMN - LLAST = 0 - DO 30 J = 1,N -C - DO 20 L = JQ(J),JQ(J+1)-1 - I = IROW(L) -C - U(j) = U(j) + Asd(L)*W(i) -C - 20 CONTINUE -C - 30 CONTINUE -C - RETURN - END - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/orientations.f calculix-ccx-2.3/ccx_2.1/src/orientations.f --- calculix-ccx-2.1/ccx_2.1/src/orientations.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/orientations.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine orientations(inpc,textpart,orname,orab,norien, - & norien_,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! -! reading the input deck: *ORIENTATION -! - implicit none -! - character*1 inpc(*) - character*80 orname(*) - character*132 textpart(16) -! - integer norien,norien_,istep,istat,n,key,i,iline,ipol,inl, - & ipoinp(2,*),inp(3,*),ipoinpc(0:*) -! - real*8 orab(7,*) -! - if(istep.gt.0) then - write(*,*) '*ERROR in orientations: *ORIENTATION should be' - write(*,*) ' placed before all step definitions' - stop - endif -! - norien=norien+1 - if(norien.gt.norien_) then - write(*,*) '*ERROR in orientations: increase norien_' - stop - endif -! -! rectangular coordinate system: orab(7,norien)=1 -! cylindrical coordinate system: orab(7,norien)=-1 -! default is rectangular -! - orab(7,norien)=1.d0 -! - do i=2,n - if(textpart(i)(1:5).eq.'NAME=') then - orname(norien)=textpart(i)(6:85) - if(textpart(i)(86:86).ne.' ') then - write(*,*) '*ERROR in orientations: name too long' - write(*,*) ' (more than 80 characters)' - write(*,*) ' orientation name:',textpart(i)(1:132) - stop - endif - elseif(textpart(i)(1:7).eq.'SYSTEM=') then -c if(textpart(i)(8:18).eq.'CYLINDRICAL') then - if(textpart(i)(8:8).eq.'C') then - orab(7,norien)=-1.d0 - endif - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*)'*ERROR in orientations: definition of the following' - write(*,*) ' orientation is not complete: ',orname(norien) - stop - endif -! - do i=1,6 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) orab(i,norien) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/orifice.f calculix-ccx-2.3/ccx_2.1/src/orifice.f --- calculix-ccx-2.1/ccx_2.1/src/orifice.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/orifice.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,724 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine orifice(node1,node2,nodem,nelem,lakon,kon,ipkon, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,cp,R,physcon,dvi,numf,set,co,vold,mi) -! -! orifice element -! - implicit none -! - logical identity - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, - & ielprop(*),nodef(4),idirf(4),index,iflag, - & inv,ipkon(*),kon(*),number,kgas,nelemref, - & nodea,nodeb,iaxial,mi(2),i -! - real*4 ofvidg -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R,a,d,xl, - & p1,p2,T1,Aeff,C1,C2,C3,cd,cp,physcon(3),p2p1,km1,dvi, - & kp1,kdkm1,tdkp1,km1dk,x,y,ca1,cb1,ca2,cb2,dT1,alambda, - & rad,beta,reynolds,theta,k_phi,c2u_new,u,pi,xflow_oil, - & ps1pt1,uref,cd_chamf,angle,vid,cdcrit,T2,radius, - & initial_radius,co(3,*),vold(0:mi(2),*),offset, - & x_tab(15), y_tab(15),x_tab2(15),y_tab2(15),curve -! -! - external ofvidg -! - pi=4.d0*datan(1.d0) - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif (iflag.eq.1)then -! - index=ielprop(nelem) - kappa=(cp/(cp-R)) - a=prop(index+1) - d=prop(index+2) - xl=prop(index+3) -! - if(lakon(nelem)(2:5).eq.'ORFL') then - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - iaxial=int(prop(index+3)) - offset=prop(index+4) - radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2)-offset - initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2)-offset - if(iaxial.ne.0) then - A=pi*radius**2/iaxial - else - A=pi*radius**2 - endif - d=2*radius - endif -! - p1=v(2,node1) - p2=v(2,node2) - if(p1.ge.p2) then - inv=1 - T1=v(0,node1)+physcon(1) - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - T1=v(0,node2)+physcon(1) - endif -! - cd=1.d0 -! - p2p1=p2/p1 - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - tdkp1=2.d0/kp1 - C2=tdkp1**kdkm1 - Aeff=A*cd - if(p2p1.gt.C2) then - xflow=inv*p1*Aeff*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa) - & *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(T1) - else - xflow=inv*p1*Aeff*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ - & dsqrt(T1) - endif -! - elseif (iflag.eq.2)then -! - numf=4 - alambda=10000.d0 - index=ielprop(nelem) - kappa=(cp/(cp-R)) - a=prop(index+1) -! - p1=v(2,node1) - p2=v(2,node2) - if(p1.ge.p2) then - inv=1 - xflow=v(1,nodem) - T1=v(0,node1)+physcon(1) - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - xflow=-v(1,nodem) - T1=v(0,node2)+physcon(1) - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 -! -! calculation of the dynamic viscosity -! -! - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif -! - if ((lakon(nelem)(4:5).ne.'BT').and. - & (lakon(nelem)(4:5).ne.'PN').and. - & (lakon(nelem)(4:5).ne.'C1').and. - & (lakon(nelem)(4:5).ne.'FL') ) then - d=prop(index+2) - xl=prop(index+3) - u=prop(index+7) - nelemref=int(prop(index+8)) - if (nelemref.eq.0) then - uref=0.d0 - else -! swirl generating element -! -! preswirl nozzle - if(lakon(nelemref)(2:5).eq.'ORPN') then - uref=prop(ielprop(nelemref)+5) -! -! forced vortex - elseif(lakon(nelemref)(2:5).eq.'VOFO') then - uref=prop(ielprop(nelemref)+7) -! -! free vortex - elseif(lakon(nelemref)(2:5).eq.'VOFR') then - uref=prop(ielprop(nelemref)+9) -! - else - write(*,*) '*ERROR in orifice:' - write(*,*) ' element',nelemref - write(*,*) 'refered by element',nelem - write(*,*) 'is not a preswirl nozzle' - endif - endif - u=u-uref - angle=prop(index+5) -! - endif -! -! calculate the discharge coefficient using Bragg's Method -! "Effect of Compressibility on the discharge coefficient -! of orifices and convergent nozzles" -! journal of mechanical Engineering -! vol2 No 1 1960 -! - if((lakon(nelem)(2:5).eq.'ORBG')) then -! - p2p1=p2/p1 - cdcrit=prop(index+2) -! - call cd_bragg(cdcrit,p2p1,cd) -! - elseif (lakon(nelem)(2:5).eq.'ORMA') then -! -! calculate the discharge coefficient using own table data and -! using Dr.Albers method for rotating cavities -! - call cd_own_albers(p1,p2,xl,d,cd,u,T1,R,kappa) -! -! chamfer correction -! - if(angle.gt.0.d0)then - call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) - cd=cd*cd_chamf - endif -! - elseif (lakon(nelem)(2:5).eq.'ORMM') then -! -! calculate the discharge coefficient using McGreehan and Schotsch method -! - rad=prop(index+4) -! - reynolds=dabs(xflow)*d/(dvi*a) -! - call cd_ms_ms(p1,p2,T1,rad,d,xl,kappa,r,reynolds,u,vid,cd) -! - if (cd.ge.1) then - write(*,*) '' - write(*,*) '**WARNING**' - write(*,*) 'in RESTRICTOR ',nelem - write(*,*) 'Calculation using' - write(*,*) ' McGreehan and Schotsch method:' - write(*,*) ' Cd=',Cd,'>1 !' - write(*,*) 'Calcultion will proceed will Cd=1' - write(*,*) 'l/d=',xl/d,'r/d=',rad/d,'u/vid=',u/vid - cd=1.d0 - endif -! -! chamfer correction -! - if(angle.gt.0.d0) then - call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) - cd=cd*cd_chamf - endif -! - elseif (lakon(nelem)(2:5).eq.'ORPA') then -! -! calculate the discharge coefficient using Parker and Kercher method -! and using Dr. Albers method for rotating cavities -! - rad=prop(index+4) -! - beta=prop(index+6) -! - reynolds=dabs(xflow)*d/(dvi*a) -! - call cd_pk_albers(rad,d,xl,reynolds,p2,p1,beta,kappa, - & cd,u,T1,R) -! -! chamfer correction -! - if(angle.gt.0.d0) then - call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) - cd=cd*cd_chamf - endif -! - elseif (lakon(nelem)(2:5).eq.'ORPM') then -! -! calculate the discharge coefficient using Parker and Kercher method -! and using Mac Grehan and Schotsch method for rotating cavities -! - rad=prop(index+4) -! - beta=prop(index+6) - reynolds=dabs(xflow)*d/(dvi*a) -! - call cd_pk_ms(rad,d,xl,reynolds,p2,p1,beta,kappa,cd, - & u,T1,R) -! -! chamfer correction -! - if(angle.gt.0.d0) then - call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) - cd=cd*cd_chamf - endif -! - elseif (lakon(nelem)(2:5).eq.'ORC1') then -! - d=dsqrt(a*4/Pi) - reynolds=dabs(xflow)*d/(dvi*a) - cd=1.d0 -! - elseif (lakon(nelem)(2:5).eq.'ORBT') then -! -! calculate the discharge coefficient of bleed tappings (OWN tables) -! - ps1pt1=prop(index+2) - curve=int(prop(index+3)) - number=int(prop(index+4)) -! - if(number.ne.0.d0)then - do i=1,number - x_tab(i)=prop(index+2*i+3) - y_tab(i)=prop(index+2*i+4) - enddo - endif -! - call cd_bleedtapping(p2,p1,ps1pt1,number,curve,x_tab,y_tab, - & cd) -! - elseif (lakon(nelem)(2:5).eq.'ORPN') then -! -! calculate the discharge coefficient of preswirl nozzle (OWN tables) -! - d=dsqrt(4*A/pi) - reynolds=dabs(xflow)*d/(dvi*a) - curve=int(prop(index+4)) - number=int(prop(index+6)) - if(number.ne.0.d0)then - do i=1,number - x_tab2(i)=prop(index+2*i+5) - y_tab2(i)=prop(index+2*i+6) - enddo - endif - call cd_preswirlnozzle(p2,p1,number,curve,x_tab2,y_tab2 - & ,cd) -! - theta=prop(index+2) - k_phi=prop(index+3) -! - if(p2/p1.gt.(2/(kappa+1.d0))**(kappa/(kappa-1.d0))) then - c2u_new=k_phi*cd*sin(theta*Pi/180.d0)*r* - & dsqrt(2.d0*kappa/(r*(kappa-1)))* - & dsqrt(T1*(1.d0-(p2/p1)**((kappa-1)/kappa))) -! - else - c2u_new=k_phi*cd*sin(theta*Pi/180.d0)*r* - & dsqrt(2.d0*kappa/(r*(kappa-1)))* - & dsqrt(T1*(1.d0-2/(kappa+1))) - endif - prop(index+5)=c2u_new -! - elseif(lakon(nelem)(2:5).eq.'ORFL') then - nodea=int(prop(index+1)) - nodeb=int(prop(index+2)) - iaxial=int(prop(index+3)) - offset=prop(index+4) - radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- - & co(1,nodea)-vold(1,nodea))**2)-offset -! - initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2)-offset -! - if(iaxial.ne.0) then - A=pi*radius**2/iaxial - else - A=pi*radius**2 - endif - d=2*radius - reynolds=dabs(xflow)*d/(dvi*a) - cd=1.d0 -! - endif -! - if (cd.gt.1.d0) then - Write(*,*) '*WARNING:' - Write(*,*) 'In RESTRICTOR',nelem - write(*,*) 'Cd greater than 1' - write (*,*) 'Calculation will proceed using Cd=1' - cd=1.d0 - endif -! - p2p1=p2/p1 - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - tdkp1=2.d0/kp1 - C2=tdkp1**kdkm1 - Aeff=A*cd - dT1=dsqrt(T1) -! - if(p2p1.gt.C2) then - C1=dsqrt(2.d0*kdkm1/r)*Aeff - km1dk=1.d0/kdkm1 - y=p2p1**km1dk - x=dsqrt(1.d0-y) - ca1=-C1*x/(kappa*p1*y) - cb1=C1*km1dk/(2.d0*p1) - ca2=-ca1*p2p1-xflow*dT1/(p1*p1) - cb2=-cb1*p2p1 - f=xflow*dT1/p1-C1*p2p1**(1.d0/kappa)*x - if(cb2.le.-(alambda+ca2)*x) then - df(1)=-alambda - elseif(cb2.ge.(alambda-ca2)*x) then - df(1)=alambda - else - df(1)=ca2+cb2/x - endif - df(2)=xflow/(2.d0*p1*dT1) - df(3)=inv*dT1/p1 - if(cb1.le.-(alambda+ca1)*x) then - df(4)=-alambda - elseif(cb1.ge.(alambda-ca1)*x) then - df(4)=alambda - else - df(4)=ca1+cb1/x - endif - else - C3=dsqrt(kappa/r)*(tdkp1)**(kp1/(2.d0*km1))*Aeff - f=xflow*dT1/p1-C3 - df(1)=-xflow*dT1/(p1)**2 - df(2)=xflow/(2*p1*dT1) - df(3)=inv*dT1/p1 - df(4)=0.d0 - endif -! -! output -! - elseif (iflag.eq.3) then -! - pi=4.d0*datan(1.d0) - p1=v(2,node1) - p2=v(2,node2) - if(p1.ge.p2) then - inv=1 - xflow=v(1,nodem) - T1=v(0,node1)+physcon(1) - T2=v(0,node2)+physcon(1) - else - inv=-1 - p1=v(2,node2) - p2=v(2,node1) - xflow=-v(1,nodem) - T1=v(0,node2)+physcon(1) - T2=v(0,node1)+physcon(1) - endif -! -! calculation of the dynamic viscosity -! - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif -! - index=ielprop(nelem) - kappa=(cp/(cp-R)) - a=prop(index+1) -! - if ((lakon(nelem)(4:5).ne.'BT').and. - & (lakon(nelem)(4:5).ne.'PN').and. - & (lakon(nelem)(4:5).ne.'C1')) then - d=prop(index+2) - xl=prop(index+3) - u=prop(index+7) - nelemref=int(prop(index+8)) - if (nelemref.eq.0) then - uref=0.d0 - else -! swirl generating element -! -! preswirl nozzle - if(lakon(nelemref)(2:5).eq.'ORPN') then - uref=prop(ielprop(nelemref)+5) -! -! forced vortex - elseif(lakon(nelemref)(2:5).eq.'VOFO') then - uref=prop(ielprop(nelemref)+7) -! -! free vortex - elseif(lakon(nelemref)(2:5).eq.'VOFR') then - uref=prop(ielprop(nelemref)+9) - else - write(*,*) '*ERROR in orifice:' - write(*,*) ' element',nelemref - write(*,*) 'refered by element',nelem - write(*,*) 'is not a preswirl nozzle' - endif - endif - u=u-uref - angle=prop(index+5) -! - endif -! -! calculate the discharge coefficient using Bragg's Method -! "Effect of Compressibility on the discharge coefficient -! of orifices and convergent nozzles" -! journal of mechanical Engineering -! vol2 No 1 1960 -! - if((lakon(nelem)(2:5).eq.'ORBG')) then -! - p2p1=p2/p1 - d=dsqrt(a*4/Pi) - reynolds=dabs(xflow)*d/(dvi*a) - cdcrit=prop(index+2) -! - call cd_bragg(cdcrit,p2p1,cd) -! - elseif (lakon(nelem)(2:5).eq.'ORMA') then -! -! calculate the discharge coefficient using own table data and -! using Dr.Albers method for rotating cavities -! - reynolds=dabs(xflow)*d/(dvi*a) -! - call cd_own_albers(p1,p2,xl,d,cd,u,T1,R,kappa) -! -! chamfer correction -! - if(angle.gt.0.d0)then - call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) - cd=cd*cd_chamf - endif -! - elseif (lakon(nelem)(2:5).eq.'ORMM') then -! -! calculate the discharge coefficient using McGreehan and Schotsch method -! - rad=prop(index+4) -! - reynolds=dabs(xflow)*d/(dvi*a) -! - call cd_ms_ms(p1,p2,T1,rad,d,xl,kappa,r,reynolds,u,vid,cd) -! - if (cd.ge.1) then - write(*,*) '' - write(*,*) '**WARNING**' - write(*,*) 'in RESTRICTOR ',nelem - write(*,*) 'Calculation using' - write(*,*) ' McGreehan and Schotsch method:' - write(*,*) ' Cd=',Cd,'>1 !' - write(*,*) 'Calcultion will proceed will Cd=1' - write(*,*) 'l/d=',xl/d,'r/d=',rad/d,'u/vid=',u/vid - cd=1.d0 - endif -! -! chamfer correction -! - if(angle.gt.0.d0) then - call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) - cd=cd*cd_chamf - endif -! - elseif (lakon(nelem)(2:5).eq.'ORPA') then -! -! calculate the discharge coefficient using Parker and Kercher method -! and using Dr. Albers method for rotating cavities -! - rad=prop(index+4) -! - beta=prop(index+6) -! - reynolds=dabs(xflow)*d/(dvi*a) -! - call cd_pk_albers(rad,d,xl,reynolds,p2,p1,beta,kappa, - & cd,u,T1,R) -! -! chamfer correction -! - if(angle.gt.0.d0) then - call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) - cd=cd*cd_chamf - endif -! - elseif (lakon(nelem)(2:5).eq.'ORPM') then -! -! calculate the discharge coefficient using Parker and Kercher method -! and using Mac Grehan and Schotsch method for rotating cavities -! - rad=prop(index+4) -! - beta=prop(index+6) - reynolds=dabs(xflow)*d/(dvi*a) -! - call cd_pk_ms(rad,d,xl,reynolds,p2,p1,beta,kappa,cd, - & u,T1,R) -! -! chamfer correction -! - if(angle.gt.0.d0) then - call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) - cd=cd*cd_chamf - endif -! - elseif (lakon(nelem)(2:5).eq.'ORC1') then -! - d=dsqrt(a*4/Pi) - reynolds=dabs(xflow)*d/(dvi*a) - cd=1.d0 -! - elseif (lakon(nelem)(2:5).eq.'ORBT') then -! -! calculate the discharge coefficient of bleed tappings (OWN tables) -! - d=dsqrt(A*Pi/4) - reynolds=dabs(xflow)*d/(dvi*a) - ps1pt1=prop(index+2) - curve=int(prop(index+3)) - number=int(prop(index+4)) - if(number.ne.0.d0)then - do i=1,number - x_tab(i)=prop(index+2*i+3) - y_tab(i)=prop(index+2*i+4) - enddo - endif -! - call cd_bleedtapping(p2,p1,ps1pt1,number,curve,x_tab,y_tab, - & cd) -! - elseif (lakon(nelem)(2:5).eq.'ORPN') then -! -! calculate the discharge coefficient of preswirl nozzle (OWN tables) -! - d=dsqrt(4*A/pi) - reynolds=dabs(xflow)*d/(dvi*a) - curve=int(prop(index+4)) - number=int(prop(index+6)) -! - if(number.ne.0.d0)then - do i=1,number - x_tab2(i)=prop(index+2*i+5) - y_tab2(i)=prop(index+2*i+6) - enddo - endif -! - call cd_preswirlnozzle(p2,p1,number,curve,x_tab2,y_tab2,cd) -! - theta=prop(index+2) - k_phi=prop(index+3) -! - if(p2/p1.gt.(2/(kappa+1.d0))**(kappa/(kappa-1.d0))) then - c2u_new=k_phi*cd*sin(theta*Pi/180.d0)*r* - & dsqrt(2.d0*kappa/(r*(kappa-1)))* - & dsqrt(T1*(1.d0-(p2/p1)**((kappa-1)/kappa))) -! - else - c2u_new=k_phi*cd*sin(theta*Pi/180.d0)*r* - & dsqrt(2.d0*kappa/(r*(kappa-1)))* - & dsqrt(T1*(1.d0-2/(kappa+1))) - endif - prop(index+5)=c2u_new - endif -! - if (cd.gt.1.d0) then - Write(*,*) '*WARNING:' - Write(*,*) 'In RESTRICTOR',nelem - write(*,*) 'Cd greater than 1' - write(*,*) 'Calculation will proceed using Cd=1' - cd=1.d0 - endif - xflow_oil=0 -! - write(1,*) '' - write(1,55) 'In line',int(nodem/1000),' from node',node1, - & ' to node', node2,': air massflow rate=',inv*xflow,'kg/s', - & ', oil massflow rate=',xflow_oil,'kg/s' - 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) - - if(inv.eq.1) then - write(1,56)' Inlet node ',node1,': Tt1=',T1, - & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' - - write(1,*)' element R ',set(numf)(1:20) - write(1,57)' Eta= ',dvi,' kg/(m*s), Re=' - & ,reynolds - if(lakon(nelem)(2:5).ne.'ORMA') then - write(1,58)' CD= ',cd - elseif(lakon(nelem)(2:5).eq.'ORMA') then - write(1,59)' CD= ',cd,' C1u= ',uref,'m/s' - endif - - -! special for bleed tappings - if(lakon(nelem)(2:5).eq.'ORBT') then - write(1,60) ' DAB=',(1-P2/P1)/(1-ps1pt1), - & ' ,curve N°',curve -! special for preswirlnozzles - elseif(lakon(nelem)(2:5).eq.'ORPN') then - write(1,61)' C2u= ',c2u_new,'m/s' -! special for recievers - - endif - - write(1,56)' Outlet node ',node2,': Tt2=',T2, - & 'K, Ts2=',T2,'K, Pt2=',P2/1e5,'Bar' -! - else if(inv.eq.-1) then - write(1,56)' Inlet node ',node2,': Tt1=',T1, - & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' - & - write(1,*)' element R ',set(numf)(1:20) - write(1,57)' eta= ',dvi,'kg/(m*s), Re=' - & ,reynolds,', CD=',cd - -! special for bleed tappings - if(lakon(nelem)(2:5).eq.'ORBT') then - write(1,60) ' DAB ',(1-P2/P1)/(1-ps1pt1),' - & , curve N°', curve -! special for preswirlnozzles - elseif(lakon(nelem)(2:5).eq.'ORPN') then - write(1,*) 'u= ',u,'m/s, C2u= ',c2u_new,'m/s' - endif - - write(1,56)' Outlet node ',node1,': Tt2=',T2, - & 'K, Ts2=',T2,'K, Pt2=',P2/1e5, 'Bar' - - endif -! - 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A) - 57 FORMAT(1X,A,G9.4,A,G11.4) - 58 FORMAT(1X,A,f12.5) - 59 FORMAT(1X,A,f12.5,A,f12.5,A) - 60 FORMAT(1X,A,f12.5,A,I2,A) - 61 FORMAT(1X,A,f12.3,A) - - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/orthonl.f calculix-ccx-2.3/ccx_2.1/src/orthonl.f --- calculix-ccx-2.1/ccx_2.1/src/orthonl.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/orthonl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,361 +0,0 @@ - subroutine orthonl(w,vo,elas,s,ii1,jj1,weight) -! -! This routine replaces the following lines in e_c3d.f for -! an orthotropic material -! -! do i1=1,3 -! iii1=ii1+i1-1 -! do j1=1,3 -! jjj1=jj1+j1-1 -! do k1=1,3 -! do l1=1,3 -! s(iii1,jjj1)=s(iii1,jjj1) -! & +anisox(i1,k1,j1,l1)*w(k1,l1) -! do m1=1,3 -! s(iii1,jjj1)=s(iii1,jjj1) -! & +anisox(i1,k1,m1,l1)*w(k1,l1) -! & *vo(j1,m1) -! & +anisox(m1,k1,j1,l1)*w(k1,l1) -! & *vo(i1,m1) -! do n1=1,3 -! s(iii1,jjj1)=s(iii1,jjj1) -! & +anisox(m1,k1,n1,l1) -! & *w(k1,l1)*vo(i1,m1)*vo(j1,n1) -! enddo -! enddo -! enddo -! enddo -! enddo -! enddo -! - integer ii1,jj1 - real*8 w(3,3),vo(3,3),elas(21),s(60,60),weight -! - s(ii1,jj1)=s(ii1,jj1)+((elas( 1)+elas( 1)*vo(1,1) - &+(elas( 1)+elas( 1)*vo(1,1) - &)*vo(1,1)+(elas( 7)*vo(1,2))*vo(1,2) - &+(elas( 8)*vo(1,3)) - &*vo(1,3))*w(1,1) - &+(elas( 2)*vo(1,2)+(elas( 2)*vo(1,2))*vo(1,1)+(elas( 7) - &+elas( 7)*vo(1,1))*vo(1,2) - &)*w(1,2) - &+(elas( 4)*vo(1,3)+(elas( 4)*vo(1,3))*vo(1,1) - &+(elas( 8)+elas( 8)*vo(1,1)) - &*vo(1,3))*w(1,3) - &+(elas( 7)*vo(1,2)+(elas( 7)*vo(1,2))*vo(1,1)+(elas( 2) - &+elas( 2)*vo(1,1))*vo(1,2) - &)*w(2,1) - &+(elas( 7)+elas( 7)*vo(1,1) - &+(elas( 7)+elas( 7)*vo(1,1) - &)*vo(1,1)+(elas( 3)*vo(1,2))*vo(1,2) - &+(elas( 9)*vo(1,3)) - &*vo(1,3))*w(2,2) - &+((elas( 5)*vo(1,3))*vo(1,2) - &+(elas( 9)*vo(1,2)) - &*vo(1,3))*w(2,3) - &+(elas( 8)*vo(1,3)+(elas( 8)*vo(1,3))*vo(1,1) - &+(elas( 4)+elas( 4)*vo(1,1)) - &*vo(1,3))*w(3,1) - &+((elas( 9)*vo(1,3))*vo(1,2) - &+(elas( 5)*vo(1,2)) - &*vo(1,3))*w(3,2) - &+(elas( 8)+elas( 8)*vo(1,1) - &+(elas( 8)+elas( 8)*vo(1,1) - &)*vo(1,1)+(elas( 9)*vo(1,2))*vo(1,2) - &+(elas( 6)*vo(1,3)) - &*vo(1,3))*w(3,3))*weight - s(ii1,jj1+1)=s(ii1,jj1+1)+((elas( 1)*vo(2,1) - &+(elas( 1)*vo(2,1) - &)*vo(1,1)+(elas( 7) - &+elas( 7)*vo(2,2))*vo(1,2) - &+(elas( 8)*vo(2,3)) - &*vo(1,3))*w(1,1) - &+(elas( 2) - &+elas( 2)*vo(2,2)+(elas( 2) - &+elas( 2)*vo(2,2))*vo(1,1)+(elas( 7)*vo(2,1))*vo(1,2) - &)*w(1,2) - &+(elas( 4)*vo(2,3)+(elas( 4)*vo(2,3))*vo(1,1) - &+(elas( 8)*vo(2,1)) - &*vo(1,3))*w(1,3) - &+(elas( 7) - &+elas( 7)*vo(2,2)+(elas( 7) - &+elas( 7)*vo(2,2))*vo(1,1)+(elas( 2)*vo(2,1))*vo(1,2) - &)*w(2,1) - &+(elas( 7)*vo(2,1) - &+(elas( 7)*vo(2,1) - &)*vo(1,1)+(elas( 3) - &+elas( 3)*vo(2,2))*vo(1,2) - &+(elas( 9)*vo(2,3)) - &*vo(1,3))*w(2,2) - &+((elas( 5)*vo(2,3))*vo(1,2) - &+(elas( 9)+elas( 9)*vo(2,2)) - &*vo(1,3))*w(2,3) - &+(elas( 8)*vo(2,3)+(elas( 8)*vo(2,3))*vo(1,1) - &+(elas( 4)*vo(2,1)) - &*vo(1,3))*w(3,1) - &+((elas( 9)*vo(2,3))*vo(1,2) - &+(elas( 5)+elas( 5)*vo(2,2)) - &*vo(1,3))*w(3,2) - &+(elas( 8)*vo(2,1) - &+(elas( 8)*vo(2,1) - &)*vo(1,1)+(elas( 9) - &+elas( 9)*vo(2,2))*vo(1,2) - &+(elas( 6)*vo(2,3)) - &*vo(1,3))*w(3,3))*weight - s(ii1,jj1+2)=s(ii1,jj1+2)+((elas( 1)*vo(3,1) - &+(elas( 1)*vo(3,1) - &)*vo(1,1)+(elas( 7)*vo(3,2))*vo(1,2) - &+(elas( 8)+elas( 8)*vo(3,3)) - &*vo(1,3))*w(1,1) - &+(elas( 2)*vo(3,2) - &+(elas( 2)*vo(3,2))*vo(1,1)+(elas( 7)*vo(3,1))*vo(1,2) - &)*w(1,2) - &+(elas( 4) - &+elas( 4)*vo(3,3)+(elas( 4) - &+elas( 4)*vo(3,3))*vo(1,1) - &+(elas( 8)*vo(3,1)) - &*vo(1,3))*w(1,3) - &+(elas( 7)*vo(3,2)+(elas( 7)*vo(3,2))*vo(1,1) - &+(elas( 2)*vo(3,1))*vo(1,2) - &)*w(2,1) - &+(elas( 7)*vo(3,1) - &+(elas( 7)*vo(3,1) - &)*vo(1,1)+(elas( 3)*vo(3,2))*vo(1,2) - &+(elas( 9)+elas( 9)*vo(3,3)) - &*vo(1,3))*w(2,2) - &+((elas( 5) - &+elas( 5)*vo(3,3))*vo(1,2) - &+(elas( 9)*vo(3,2)) - &*vo(1,3))*w(2,3) - &+(elas( 8) - &+elas( 8)*vo(3,3)+(elas( 8) - &+elas( 8)*vo(3,3))*vo(1,1) - &+(elas( 4)*vo(3,1)) - &*vo(1,3))*w(3,1) - &+((elas( 9) - &+elas( 9)*vo(3,3))*vo(1,2) - &+(elas( 5)*vo(3,2)) - &*vo(1,3))*w(3,2) - &+(elas( 8)*vo(3,1) - &+(elas( 8)*vo(3,1) - &)*vo(1,1)+(elas( 9)*vo(3,2))*vo(1,2) - &+(elas( 6)+elas( 6)*vo(3,3)) - &*vo(1,3))*w(3,3))*weight - s(ii1+1,jj1)=s(ii1+1,jj1)+((elas( 7)*vo(1,2) - &+(elas( 1)+elas( 1)*vo(1,1) - &)*vo(2,1)+(elas( 7)*vo(1,2))*vo(2,2) - &+(elas( 8)*vo(1,3)) - &*vo(2,3))*w(1,1) - &+(elas( 7)+elas( 7)*vo(1,1) - &+(elas( 2)*vo(1,2))*vo(2,1)+(elas( 7) - &+elas( 7)*vo(1,1))*vo(2,2) - &)*w(1,2) - &+((elas( 4)*vo(1,3))*vo(2,1) - &+(elas( 8)+elas( 8)*vo(1,1)) - &*vo(2,3))*w(1,3) - &+(elas( 2)+elas( 2)*vo(1,1) - &+(elas( 7)*vo(1,2))*vo(2,1)+(elas( 2) - &+elas( 2)*vo(1,1))*vo(2,2) - &)*w(2,1) - &+(elas( 3)*vo(1,2)+(elas( 7)+elas( 7)*vo(1,1) - &)*vo(2,1)+(elas( 3)*vo(1,2))*vo(2,2) - &+(elas( 9)*vo(1,3)) - &*vo(2,3))*w(2,2) - &+(elas( 5)*vo(1,3)+(elas( 5)*vo(1,3))*vo(2,2) - &+(elas( 9)*vo(1,2)) - &*vo(2,3))*w(2,3) - &+((elas( 8)*vo(1,3))*vo(2,1) - &+(elas( 4)+elas( 4)*vo(1,1)) - &*vo(2,3))*w(3,1) - &+(elas( 9)*vo(1,3)+(elas( 9)*vo(1,3))*vo(2,2) - &+(elas( 5)*vo(1,2)) - &*vo(2,3))*w(3,2) - &+(elas( 9)*vo(1,2)+(elas( 8)+elas( 8)*vo(1,1) - &)*vo(2,1)+(elas( 9)*vo(1,2))*vo(2,2) - &+(elas( 6)*vo(1,3)) - &*vo(2,3))*w(3,3))*weight - s(ii1+1,jj1+1)=s(ii1+1,jj1+1)+((elas( 7) - &+elas( 7)*vo(2,2)+(elas( 1)*vo(2,1) - &)*vo(2,1)+(elas( 7) - &+elas( 7)*vo(2,2))*vo(2,2) - &+(elas( 8)*vo(2,3)) - &*vo(2,3))*w(1,1) - &+(elas( 7)*vo(2,1) - &+(elas( 2) - &+elas( 2)*vo(2,2))*vo(2,1)+(elas( 7)*vo(2,1))*vo(2,2) - &)*w(1,2) - &+((elas( 4)*vo(2,3))*vo(2,1) - &+(elas( 8)*vo(2,1)) - &*vo(2,3))*w(1,3) - &+(elas( 2)*vo(2,1) - &+(elas( 7) - &+elas( 7)*vo(2,2))*vo(2,1)+(elas( 2)*vo(2,1))*vo(2,2) - &)*w(2,1) - &+(elas( 3) - &+elas( 3)*vo(2,2)+(elas( 7)*vo(2,1) - &)*vo(2,1)+(elas( 3) - &+elas( 3)*vo(2,2))*vo(2,2) - &+(elas( 9)*vo(2,3)) - &*vo(2,3))*w(2,2) - &+(elas( 5)*vo(2,3)+(elas( 5)*vo(2,3))*vo(2,2) - &+(elas( 9)+elas( 9)*vo(2,2)) - &*vo(2,3))*w(2,3) - &+((elas( 8)*vo(2,3))*vo(2,1) - &+(elas( 4)*vo(2,1)) - &*vo(2,3))*w(3,1) - &+(elas( 9)*vo(2,3)+(elas( 9)*vo(2,3))*vo(2,2) - &+(elas( 5)+elas( 5)*vo(2,2)) - &*vo(2,3))*w(3,2) - &+(elas( 9) - &+elas( 9)*vo(2,2)+(elas( 8)*vo(2,1) - &)*vo(2,1)+(elas( 9) - &+elas( 9)*vo(2,2))*vo(2,2) - &+(elas( 6)*vo(2,3)) - &*vo(2,3))*w(3,3))*weight - s(ii1+1,jj1+2)=s(ii1+1,jj1+2)+((elas( 7)*vo(3,2)+(elas( 1)*vo(3,1) - &)*vo(2,1)+(elas( 7)*vo(3,2))*vo(2,2) - &+(elas( 8)+elas( 8)*vo(3,3)) - &*vo(2,3))*w(1,1) - &+(elas( 7)*vo(3,1) - &+(elas( 2)*vo(3,2))*vo(2,1)+(elas( 7)*vo(3,1))*vo(2,2) - &)*w(1,2) - &+((elas( 4) - &+elas( 4)*vo(3,3))*vo(2,1) - &+(elas( 8)*vo(3,1)) - &*vo(2,3))*w(1,3) - &+(elas( 2)*vo(3,1) - &+(elas( 7)*vo(3,2))*vo(2,1)+(elas( 2)*vo(3,1))*vo(2,2) - &)*w(2,1) - &+(elas( 3)*vo(3,2)+(elas( 7)*vo(3,1) - &)*vo(2,1)+(elas( 3)*vo(3,2))*vo(2,2) - &+(elas( 9)+elas( 9)*vo(3,3)) - &*vo(2,3))*w(2,2) - &+(elas( 5) - &+elas( 5)*vo(3,3)+(elas( 5) - &+elas( 5)*vo(3,3))*vo(2,2) - &+(elas( 9)*vo(3,2)) - &*vo(2,3))*w(2,3) - &+((elas( 8) - &+elas( 8)*vo(3,3))*vo(2,1) - &+(elas( 4)*vo(3,1)) - &*vo(2,3))*w(3,1) - &+(elas( 9) - &+elas( 9)*vo(3,3)+(elas( 9) - &+elas( 9)*vo(3,3))*vo(2,2) - &+(elas( 5)*vo(3,2)) - &*vo(2,3))*w(3,2) - &+(elas( 9)*vo(3,2)+(elas( 8)*vo(3,1) - &)*vo(2,1)+(elas( 9)*vo(3,2))*vo(2,2) - &+(elas( 6)+elas( 6)*vo(3,3)) - &*vo(2,3))*w(3,3))*weight - s(ii1+2,jj1)=s(ii1+2,jj1)+((elas( 8)*vo(1,3) - &+(elas( 1)+elas( 1)*vo(1,1) - &)*vo(3,1)+(elas( 7)*vo(1,2))*vo(3,2) - &+(elas( 8)*vo(1,3)) - &*vo(3,3))*w(1,1) - &+((elas( 2)*vo(1,2))*vo(3,1)+(elas( 7) - &+elas( 7)*vo(1,1))*vo(3,2) - &)*w(1,2) - &+(elas( 8)+elas( 8)*vo(1,1) - &+(elas( 4)*vo(1,3))*vo(3,1) - &+(elas( 8)+elas( 8)*vo(1,1)) - &*vo(3,3))*w(1,3) - &+((elas( 7)*vo(1,2))*vo(3,1)+(elas( 2) - &+elas( 2)*vo(1,1))*vo(3,2) - &)*w(2,1) - &+(elas( 9)*vo(1,3)+(elas( 7)+elas( 7)*vo(1,1) - &)*vo(3,1)+(elas( 3)*vo(1,2))*vo(3,2) - &+(elas( 9)*vo(1,3)) - &*vo(3,3))*w(2,2) - &+(elas( 9)*vo(1,2)+(elas( 5)*vo(1,3))*vo(3,2) - &+(elas( 9)*vo(1,2)) - &*vo(3,3))*w(2,3) - &+(elas( 4)+elas( 4)*vo(1,1) - &+(elas( 8)*vo(1,3))*vo(3,1) - &+(elas( 4)+elas( 4)*vo(1,1)) - &*vo(3,3))*w(3,1) - &+(elas( 5)*vo(1,2)+(elas( 9)*vo(1,3))*vo(3,2) - &+(elas( 5)*vo(1,2)) - &*vo(3,3))*w(3,2) - &+(elas( 6)*vo(1,3)+(elas( 8)+elas( 8)*vo(1,1) - &)*vo(3,1)+(elas( 9)*vo(1,2))*vo(3,2) - &+(elas( 6)*vo(1,3)) - &*vo(3,3))*w(3,3))*weight - s(ii1+2,jj1+1)=s(ii1+2,jj1+1)+((elas( 8)*vo(2,3) - &+(elas( 1)*vo(2,1) - &)*vo(3,1)+(elas( 7) - &+elas( 7)*vo(2,2))*vo(3,2) - &+(elas( 8)*vo(2,3)) - &*vo(3,3))*w(1,1) - &+((elas( 2) - &+elas( 2)*vo(2,2))*vo(3,1)+(elas( 7)*vo(2,1))*vo(3,2) - &)*w(1,2) - &+(elas( 8)*vo(2,1) - &+(elas( 4)*vo(2,3))*vo(3,1) - &+(elas( 8)*vo(2,1)) - &*vo(3,3))*w(1,3) - &+((elas( 7) - &+elas( 7)*vo(2,2))*vo(3,1)+(elas( 2)*vo(2,1))*vo(3,2) - &)*w(2,1) - &+(elas( 9)*vo(2,3)+(elas( 7)*vo(2,1) - &)*vo(3,1)+(elas( 3) - &+elas( 3)*vo(2,2))*vo(3,2) - &+(elas( 9)*vo(2,3)) - &*vo(3,3))*w(2,2) - &+(elas( 9) - &+elas( 9)*vo(2,2)+(elas( 5)*vo(2,3))*vo(3,2) - &+(elas( 9)+elas( 9)*vo(2,2)) - &*vo(3,3))*w(2,3) - &+(elas( 4)*vo(2,1) - &+(elas( 8)*vo(2,3))*vo(3,1) - &+(elas( 4)*vo(2,1)) - &*vo(3,3))*w(3,1) - &+(elas( 5) - &+elas( 5)*vo(2,2)+(elas( 9)*vo(2,3))*vo(3,2) - &+(elas( 5)+elas( 5)*vo(2,2)) - &*vo(3,3))*w(3,2) - &+(elas( 6)*vo(2,3)+(elas( 8)*vo(2,1) - &)*vo(3,1)+(elas( 9) - &+elas( 9)*vo(2,2))*vo(3,2) - &+(elas( 6)*vo(2,3)) - &*vo(3,3))*w(3,3))*weight - s(ii1+2,jj1+2)=s(ii1+2,jj1+2)+((elas( 8) - &+elas( 8)*vo(3,3)+(elas( 1)*vo(3,1) - &)*vo(3,1)+(elas( 7)*vo(3,2))*vo(3,2) - &+(elas( 8)+elas( 8)*vo(3,3)) - &*vo(3,3))*w(1,1) - &+((elas( 2)*vo(3,2))*vo(3,1)+(elas( 7)*vo(3,1))*vo(3,2) - &)*w(1,2) - &+(elas( 8)*vo(3,1) - &+(elas( 4) - &+elas( 4)*vo(3,3))*vo(3,1) - &+(elas( 8)*vo(3,1)) - &*vo(3,3))*w(1,3) - &+((elas( 7)*vo(3,2))*vo(3,1)+(elas( 2)*vo(3,1))*vo(3,2) - &)*w(2,1) - &+(elas( 9) - &+elas( 9)*vo(3,3)+(elas( 7)*vo(3,1) - &)*vo(3,1)+(elas( 3)*vo(3,2))*vo(3,2) - &+(elas( 9)+elas( 9)*vo(3,3)) - &*vo(3,3))*w(2,2) - &+(elas( 9)*vo(3,2)+(elas( 5) - &+elas( 5)*vo(3,3))*vo(3,2) - &+(elas( 9)*vo(3,2)) - &*vo(3,3))*w(2,3) - &+(elas( 4)*vo(3,1) - &+(elas( 8) - &+elas( 8)*vo(3,3))*vo(3,1) - &+(elas( 4)*vo(3,1)) - &*vo(3,3))*w(3,1) - &+(elas( 5)*vo(3,2)+(elas( 9) - &+elas( 9)*vo(3,3))*vo(3,2) - &+(elas( 5)*vo(3,2)) - &*vo(3,3))*w(3,2) - &+(elas( 6) - &+elas( 6)*vo(3,3)+(elas( 8)*vo(3,1) - &)*vo(3,1)+(elas( 9)*vo(3,2))*vo(3,2) - &+(elas( 6)+elas( 6)*vo(3,3)) - &*vo(3,3))*w(3,3))*weight -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/orthotropic.f calculix-ccx-2.3/ccx_2.1/src/orthotropic.f --- calculix-ccx-2.1/ccx_2.1/src/orthotropic.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/orthotropic.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,112 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine orthotropic(orthol,anisox) -! -! expands the 9 orthotropic elastic constants into a -! 3x3x3x3 matrix -! - implicit none -! - real*8 orthol(9),anisox(3,3,3,3) -! - anisox(1,1,1,1)=orthol(1) - anisox(1,1,1,2)=0.d0 - anisox(1,1,1,3)=0.d0 - anisox(1,1,2,1)=0.d0 - anisox(1,1,2,2)=orthol(2) - anisox(1,1,2,3)=0.d0 - anisox(1,1,3,1)=0.d0 - anisox(1,1,3,2)=0.d0 - anisox(1,1,3,3)=orthol(4) - anisox(1,2,1,1)=0.d0 - anisox(1,2,1,2)=orthol(7) - anisox(1,2,1,3)=0.d0 - anisox(1,2,2,1)=orthol(7) - anisox(1,2,2,2)=0.d0 - anisox(1,2,2,3)=0.d0 - anisox(1,2,3,1)=0.d0 - anisox(1,2,3,2)=0.d0 - anisox(1,2,3,3)=0.d0 - anisox(1,3,1,1)=0.d0 - anisox(1,3,1,2)=0.d0 - anisox(1,3,1,3)=orthol(8) - anisox(1,3,2,1)=0.d0 - anisox(1,3,2,2)=0.d0 - anisox(1,3,2,3)=0.d0 - anisox(1,3,3,1)=orthol(8) - anisox(1,3,3,2)=0.d0 - anisox(1,3,3,3)=0.d0 - anisox(2,1,1,1)=0.d0 - anisox(2,1,1,2)=orthol(7) - anisox(2,1,1,3)=0.d0 - anisox(2,1,2,1)=orthol(7) - anisox(2,1,2,2)=0.d0 - anisox(2,1,2,3)=0.d0 - anisox(2,1,3,1)=0.d0 - anisox(2,1,3,2)=0.d0 - anisox(2,1,3,3)=0.d0 - anisox(2,2,1,1)=orthol(2) - anisox(2,2,1,2)=0.d0 - anisox(2,2,1,3)=0.d0 - anisox(2,2,2,1)=0.d0 - anisox(2,2,2,2)=orthol(3) - anisox(2,2,2,3)=0.d0 - anisox(2,2,3,1)=0.d0 - anisox(2,2,3,2)=0.d0 - anisox(2,2,3,3)=orthol(5) - anisox(2,3,1,1)=0.d0 - anisox(2,3,1,2)=0.d0 - anisox(2,3,1,3)=0.d0 - anisox(2,3,2,1)=0.d0 - anisox(2,3,2,2)=0.d0 - anisox(2,3,2,3)=orthol(9) - anisox(2,3,3,1)=0.d0 - anisox(2,3,3,2)=orthol(9) - anisox(2,3,3,3)=0.d0 - anisox(3,1,1,1)=0.d0 - anisox(3,1,1,2)=0.d0 - anisox(3,1,1,3)=orthol(8) - anisox(3,1,2,1)=0.d0 - anisox(3,1,2,2)=0.d0 - anisox(3,1,2,3)=0.d0 - anisox(3,1,3,1)=orthol(8) - anisox(3,1,3,2)=0.d0 - anisox(3,1,3,3)=0.d0 - anisox(3,2,1,1)=0.d0 - anisox(3,2,1,2)=0.d0 - anisox(3,2,1,3)=0.d0 - anisox(3,2,2,1)=0.d0 - anisox(3,2,2,2)=0.d0 - anisox(3,2,2,3)=orthol(9) - anisox(3,2,3,1)=0.d0 - anisox(3,2,3,2)=orthol(9) - anisox(3,2,3,3)=0.d0 - anisox(3,3,1,1)=orthol(4) - anisox(3,3,1,2)=0.d0 - anisox(3,3,1,3)=0.d0 - anisox(3,3,2,1)=0.d0 - anisox(3,3,2,2)=orthol(5) - anisox(3,3,2,3)=0.d0 - anisox(3,3,3,1)=0.d0 - anisox(3,3,3,2)=0.d0 - anisox(3,3,3,3)=orthol(6) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/out.f calculix-ccx-2.3/ccx_2.1/src/out.f --- calculix-ccx-2.1/ccx_2.1/src/out.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/out.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine out(co,nk,kon,ipkon,lakon,ne0,v,stn,inum,nmethod, - & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern,xstaten, - & nstate_,istep,iinc,iperturb,ener,mi,output,ithermal,qfn, - & mode,noddiam,trab,inotr,ntrans,orab,ielorien,norien,description, - & ipneigh,neigh,stx,vr,vi,stnr,stni,vmax,stnmax,ngraph,veold,ne, - & cs,set,nset,istartset,iendset,ialset) -! -! stores the results in frd format -! - implicit none -! - character*3 output - character*8 lakon(*) - character*12 description - character*80 matname(*) - character*81 set(*) - character*87 filab(*) -! - integer kon(*),inum(*),nk,ne0,nmethod,kode,ipkon(*),mode,noddiam, - & ielmat(*),nstate_,istep,iinc,iperturb,mi(2),ithermal,inotr(2,*), - & ntrans,ielorien(*),norien,ngraph,ne,nset,istartset(*), - & iendset(*),ialset(*),ipneigh(*),neigh(2,*) -! - real*8 co(3,*),v(0:mi(2),*),stn(6,*),een(6,*),t1(*),fn(0:mi(2),*), - & time,epn(*),enern(*),xstaten(nstate_,*),ener(mi(1),*),qfn(3,*), - & trab(7,*),orab(7,*),vr(0:mi(2),*),vi(0:mi(2),*),stnr(6,*), - & cs(17,*),stni(6,*),pi,vmax(0:3,*),stnmax(0:6,*), - & veold(0:mi(2),*),stx(6,mi(1),*) -! - if((output.eq.'frd').or.(output.eq.'FRD')) then - call frd(co,nk,kon,ipkon,lakon,ne0,v,stn,inum,nmethod, - & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern, - & xstaten,nstate_,istep,iinc,ithermal,qfn,mode,noddiam, - & trab,inotr,ntrans,orab,ielorien,norien,description, - & ipneigh,neigh,mi(1),stx,vr,vi,stnr,stni,vmax, - & stnmax,ngraph,veold,ener,ne,cs,set,nset,istartset, - & iendset,ialset) - else - if(nmethod.ne.0) then - call onf(co,nk,kon,ipkon,lakon,ne0,v,stn,inum,nmethod, - & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern, - & xstaten,nstate_,istep,iinc,iperturb,ener,mi(1)) - endif - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/pardiso.c calculix-ccx-2.3/ccx_2.1/src/pardiso.c --- calculix-ccx-2.1/ccx_2.1/src/pardiso.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pardiso.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,174 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2005 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#ifdef PARDISO - -#include -#include -#include -#include "CalculiX.h" -#include "pardiso.h" - -int *irowpardiso=NULL,*pointers=NULL,iparm[64]; -long int pt[64]; -double *aupardiso=NULL; - -void pardiso_factor(double *ad, double *au, double *adb, double *aub, - double *sigma,int *icol, int *irow, - int *neq, int *nzs){ - - char *env; - int i,j,k,l,maxfct=1,mnum=1,mtype=-2,phase=12,nrhs=1,*perm=NULL, - msglvl=1,error=0; - long long ndim; - double *b=NULL,*x=NULL; - - printf(" Factoring the system of equations using the pardiso solver\n\n"); - - iparm[0]=0; - env=getenv("OMP_NUM_THREADS"); - if(env) { - iparm[2]=atoi(env);} - else{ - iparm[2]=1; - } - - printf(" number of threads =% d\n\n",iparm[2]); - - for(i=0;i<64;i++){pt[i]=0;} - - ndim=*neq+*nzs; - - pointers=NNEW(int,*neq+1); - irowpardiso=NNEW(int,ndim); - aupardiso=NNEW(double,ndim); - - k=ndim; - l=*nzs; - - if(*sigma==0.){ - pointers[*neq]=ndim+1; - for(i=*neq-1;i>=0;--i){ - for(j=0;j=0;--i){ - for(j=0;j -#include -#include -#include "CalculiX.h" - -#define GOOD 0 -#define BAD 1 -#define FALSE 0 -#define TRUE 1 - -/* Prototyping */ - -int cgsolver (double *A, double *x, double *b, int neq, int len, int *ia, - int *iz,double *eps, int *niter, int precFlg); -void PCG (double *A, double *x, double *b, int neq, int len, int *ia, - int *iz,double *eps, int *niter, int precFlg, - double *rho, double *r, double *g, double *C, double *z); -void CG (double *A, double *x, double *b, int neq, int len, int *ia, - int *iz,double *eps, int *niter,double *r, double *p, double *z); -void Scaling (double *A, double *b, int neq, int *ia, int *iz, double *d); -void MatVecProduct (double *A, double *p, int neq, int *ia, int *iz, - double *z); -void PreConditioning (double *A, int neq, int len, int *ia, int *iz, - double alpha, int precFlg,double *C, int *ier); -void Mrhor (double *C, int neq, int *ia, int *iz, double *r, double *rho); -void InnerProduct (double *a, double *b, int n, double *Sum); - -/* ********************************************************************** - -The (preconditioned) conjugate gradient solver - - parameter: - A compact row oriented storage of lower left of matrix A - neq order of A, number of equations - len number of non zero entries in Matrix A - ia column indices of corresponding elements in Matrix A - iz row indices (diagonal elements indices) - x solution vector - b right hand side - eps required accuracy -> residual - niter maximum number of iterations -> number of iterations - precFlg preconditioning flag - -The compact row oriented storage of sparse quadratic matrices is decsribed in -H.R. Schwarz: FORTRAN-Programme zur Methode der finiten Elemente, pp.66-67, -Teubner, 1981 - -********************************************************************** -*/ - -int cgsolver (double *A, double *x, double *b, int neq, int len, - int *ia, int *iz, - double *eps, int *niter, int precFlg) -{ - int i=0; - double *Factor=NULL,*r=NULL,*p=NULL,*z=NULL,*C=NULL,*g=NULL,*rho=NULL; - - /* reduce row and column indices by 1 (FORTRAN->C) */ - - for (i=0; i residual - niter maximum number of iterations -> number of iterations - precFlg preconditioning flag - - The function corresponds to function PACHCG() in H.R. Schwarz: FORTRAN-Pro- - gramme zur Methode der finiten Elemente, p.115, Teubner, 1981 - -********************************************************************** -*/ - -void PCG (double *A, double *x, double *b, int neq, int len, int *ia, - int *iz,double *eps, int *niter, int precFlg, - double *rho, double *r, double *g, double *C, double *z) -{ - int i=0, k=0, ncg=0,iam,ier=0; - double alpha=0.0, ekm1=0.0, rrho=0.0; - double rrho1=0.0, gz=0.0, qk=0.0; - double c1=0.005,qam,err,ram=0; - - - /* initialize result and residual vectors */ - - qam=0.;iam=0; - for (i=0; i1.e-20){qam+=err;iam++;} - } - if(iam>0) qam=qam/iam; - else {*niter=0;return;} - - /* preconditioning */ - - printf("Cholesky preconditioning\n\n"); - - printf("alpha=%f\n",alpha); - PreConditioning(A,neq,len,ia,iz,alpha,precFlg,C,&ier); - while (ier==0) - { - if (alpha<=0.0) alpha=0.005; - alpha += alpha; - printf("alpha=%f\n",alpha); - PreConditioning(A,neq,len,ia,iz,alpha,precFlg,C,&ier); - } - - /* solving the system of equations using the iterative solver */ - - printf("Solving the system of equations using the iterative solver\n\n"); - - /* main iteration loop */ - - for (k=1; k<=*niter; k++, ncg++) - { - - /* solve M rho = r, M=C CT */ - - Mrhor(C,neq,ia,iz,r,rho); - - /* inner product (r,rho) */ - - InnerProduct(r,rho,neq,&rrho); - - /* If working with Penalty-terms for boundary conditions you can get - numerical troubles because RRHO becomes a very large value. - With at least two iterations the result may be better !!! */ - - /* convergency check */ - - printf("iteration= %d, error= %e, limit=%e\n",ncg,ram,c1*qam); - if (k!=1 && (ram<=c1*qam)) break; - if (k!=1) - { - ekm1 = rrho/rrho1; - for (i=0; iram) ram=err; - } - rrho1 = rrho; - } - if(k==*niter){ - printf("*ERROR in PCG: no convergence;"); - FORTRAN(stop,()); - } - *eps = rrho; - *niter = ncg; - - return; -} - - -/* ********************************************************************** - - Scaling the equation system A x + b = 0 - - The equation system is scaled in consideration of keeping the symmetry in - such a way that the diagonal elements of matrix A are 1. This is performed - by the diagonal matrix Ds with the diagonal elements d_i = 1/sqrt(a_ii). - The given equation system Ax+b=0 is transformed into - -1 - - - - Ds A Ds Ds x + Ds b = 0 or A x + b = 0 - _ _ - with the scaled Matrix A= Ds A Ds and the scaled right hand side b= Ds b. - The scaling factor Ds is needed later for backscaling of the solution - vector - _ -1 _ - x = Ds x resp. x = Ds x - - parameter: - A compact row oriented storage of lower left of matrix A - b right hand side - neq order of A, number of equations - ia column indices - iz row indices (diagonal elements indices) - - The function corresponds to function SCALKO() in H.R. Schwarz: FORTRAN-Pro- - gramme zur Methode der finiten Elemente, p.105, Teubner, 1981 - -********************************************************************** -*/ - -void Scaling (double *A, double *b, int neq, int *ia, int *iz, double *d) -{ - int i=0, j=0, jlo=0, jup=0; - - /* extract diagonal vector from matrix A */ - - for (i=0; i Ax+b=0: negative sign) */ - - for (i=0; iia[j]) break; - if (ia[l]0; i--) - { - rho[i] /= C[iz[i]]; - jlo = iz[i-1]+1; /*..first non-zero element in current row...... */ - jup = iz[i]-1; /*..diagonal element in current row............ */ - for (j=jlo; j<=jup; j++) /*..all non-zero off-diagonal element.......... */ - rho[ia[j]] -= C[j]*rho[i]; - } - return; -} -/*--------------------------------------------------------------------------------- */ - - - - -/*--Calculation of the inner product of two (distributed) vectors------------------ */ -/*--------------------------------------------------------------------------------- */ -void InnerProduct (double *a, double *b, int n, double *Sum) -{ - int i=0; -/*..local vectors.................................................................. */ - *Sum=0.; - for (i=0; i residual -- */ -/*-- niter maximum number of iterations -> number of iterations -- */ -/*--------------------------------------------------------------------------------- */ -void CG (double *A, double *x, double *b, int neq, int len, int *ia, int *iz, - double *eps, int *niter, double *r, double *p, double *z) -{ - int i=0, k=0, ncg=0,iam; - double ekm1=0.0,c1=0.005,qam,ram=0.,err; - double rr=0.0, pz=0.0, qk=0.0, rro=0.0; - - - /* solving the system of equations using the iterative solver */ - - printf("Solving the system of equations using the iterative solver\n\n"); - -/*..initialize result, search and residual vectors................................. */ - qam=0.;iam=0; - for (i=0; i1.e-20){qam+=err;iam++;} - } - if(iam>0) qam=qam/neq; - else {*niter=0;return;} - /*else qam=0.01;*/ -/*..main iteration loop............................................................ */ - for (k=1; k<=(*niter); k++, ncg++) - { -/*......inner product rT r......................................................... */ - InnerProduct(r,r,neq,&rr); - printf("iteration= %d, error= %e, limit=%e\n",ncg,ram,c1*qam); -/*......If working with Penalty-terms for boundary conditions you can get nume-.... */ -/*......rical troubles because RR becomes a very large value. With at least two.... */ -/*......iterations the result may be better !!!.................................... */ -/*......convergency check.......................................................... */ - if (k!=1 && (ram<=c1*qam)) break; -/*......new search vector.......................................................... */ - if (k!=1) - { - ekm1 = rr/rro; - for (i=0; iram) ram=err; - } -/*......store previous residual.................................................... */ - rro = rr; - - } - if(k==*niter){ - printf("*ERROR in PCG: no convergence;"); - FORTRAN(stop,()); - } - *eps = rr; /*..return residual............................ */ - *niter = ncg; /*..return number of iterations................ */ -/*..That's it...................................................................... */ - return; -} -/*--------------------------------------------------------------------------------- */ diff -Nru calculix-ccx-2.1/ccx_2.1/src/physicalconstants.f calculix-ccx-2.3/ccx_2.1/src/physicalconstants.f --- calculix-ccx-2.1/ccx_2.1/src/physicalconstants.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/physicalconstants.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,64 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine physicalconstants(inpc,textpart,physcon, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! -! reading the input deck: *PHYSICAL CONSTANTS -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer i,istep,istat,n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*), - & ipoinpc(0:*) -! - real*8 physcon(*) -! - if(istep.gt.0) then - write(*,*) '*ERROR in physicalconstants: *PHYSICAL CONSTANTS' - write(*,*) ' should only be used before the first STEP' - stop - endif -! - do i=2,n - if(textpart(i)(1:13).eq.'ABSOLUTEZERO=') then - read(textpart(i)(14:33),'(f20.0)',iostat=istat) physcon(1) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:16).eq.'STEFANBOLTZMANN=') then - read(textpart(i)(17:36),'(f20.0)',iostat=istat) physcon(2) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:14).eq.'NEWTONGRAVITY=') then - read(textpart(i)(15:24),'(f20.0)',iostat=istat) physcon(3) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/pk_cdc_cl1.f calculix-ccx-2.3/ccx_2.1/src/pk_cdc_cl1.f --- calculix-ccx-2.1/ccx_2.1/src/pk_cdc_cl1.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pk_cdc_cl1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,47 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! cd_compressible for class 1 orifices where r/d=l/d -! - subroutine pk_cdc_cl1(lqd,reynolds,p2p1,beta,kappa,cdc_cl1) -! - implicit none -! - real*8 lqd,reynolds,p2p1,beta,kappa,cdi_noz,cdi_r,cdi_se, - & y0,yg,cdc_cl1,rqd,cdqcv_noz,cdqcv_r -! - rqd=lqd -! cd incompresssible nozzle eq. 4a 4b - call pk_cdi_noz(reynolds,cdi_noz) -! cdr eq.5 - call pk_cdi_r(rqd,reynolds,beta,cdi_r) -! cd incompressible sharp edge eq.3 - call pk_cdi_se(reynolds,beta,cdi_se) -! y0 and yg , eq.15-17 , eq.18 - call pk_y0_yg(p2p1,beta,kappa,y0,yg) -! - cdqcv_noz=cdi_noz/(0.0718d0*cdi_noz+0.9282d0) - cdqcv_r=cdi_r/(0.0718d0*cdi_r+0.9282d0) -! eq.25 - cdc_cl1=cdi_r*((cdqcv_noz-cdqcv_r) - & /(cdqcv_noz-cdi_se/0.971d0) - & *(y0/yg-1d0)+1d0) -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pk_cdc_cl3a.f calculix-ccx-2.3/ccx_2.1/src/pk_cdc_cl3a.f --- calculix-ccx-2.1/ccx_2.1/src/pk_cdc_cl3a.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pk_cdc_cl3a.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! cd compressible for class 3 orifice where, l/d>0 and r/d>0 -!typ a) with 0 <= l/d<=0.28 (eq. 25 modified) -! - subroutine pk_cdc_cl3a(lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3a) -! - implicit none -! - real*8 lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3a,cdi_noz, - & cdi_rl,cdi_se,y0,yg,cdqcv_noz,cdqcv_rl -! -! cd incompressible nozlle eq 4a 4b - call pk_cdi_noz(reynolds,cdi_noz) -! cd incompresible eq.6 - call pk_cdi_rl(lqd,rqd,reynolds,beta,cdi_rl) -! cd incompressible sharp edge eq.3 - call pk_cdi_se(reynolds,beta,cdi_se) -! y0,yg ,eq. 15-17, eq.18 - call pk_y0_yg(p2p1,beta,kappa,y0,yg) -! - cdqcv_noz=cdi_noz/(0.0718d0*cdi_noz+0.9282d0) - cdqcv_rl=cdi_rl/(0.0718d0*cdi_rl+0.9282d0) -! -! eq.26 modified for class 3a -! - cdc_cl3a=cdi_rl*((cdqcv_noz-cdqcv_rl)/(cdqcv_noz-cdi_se/0.971d0) - & *(y0/yg-1.d0)+1.d0) -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pk_cdc_cl3b.f calculix-ccx-2.3/ccx_2.1/src/pk_cdc_cl3b.f --- calculix-ccx-2.1/ccx_2.1/src/pk_cdc_cl3b.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pk_cdc_cl3b.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -!cd compresssible for class3 orifices where l/d>0 and r/d>0 -! typ b) with 0.280 and r/d>0 -! type d) with 0.5<=l/d<=2 (eq. 27) -! - subroutine pk_cdc_cl3d(lqd,rqd,reynolds,p2p1,beta,cdc_cl3d) -! - implicit none -! - real*8 lqd,rqd,reynolds,p2p1,beta,cdc_cl3d,cdi_rl,cdc_cl3_choked, - & jpsqpt,zeta -! - cdc_cl3_choked=1.d0-(0.008d0+0.992d0*exp(-5.5d0*rqd - & -3.5d0*rqd**2.d0))*(1.d0-0.838d0) -! - call pk_cdi_rl(lqd,rqd,reynolds,beta,cdi_rl) -! -! help function for eq 26 - if (p2p1.ge.1d0) then - jpsqpt=1.d0 - elseif(p2p1.ge.0.1d0) then - zeta=(1.d0-p2p1)/0.6d0 - jpsqpt=exp(-4.6d0*zeta**7d0-2.2d0*zeta**1.5d0) - else - jpsqpt=0.d0 - endif -! - cdc_cl3d=cdc_cl3_choked-jpsqpt*(cdc_cl3_choked-cdi_rl) -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pk_cdc_cl3.f calculix-ccx-2.3/ccx_2.1/src/pk_cdc_cl3.f --- calculix-ccx-2.1/ccx_2.1/src/pk_cdc_cl3.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pk_cdc_cl3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! cd compresibble for class 3 orifices where l/d>0 and r/d>0 -! - subroutine pk_cdc_cl3(lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3) -! - implicit none -! - real*8 lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3a,cdc_cl3b, - & cdc_cl3d,cdc_cl3 -! - cdc_cl3a=0.d0 - cdc_cl3b=0.d0 - cdc_cl3d=0.d0 -! - if(lqd.le.0.28d0) then - call pk_cdc_cl3a(lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3a) - cdc_cl3=cdc_cl3a - elseif(lqd.le.0.5d0) then - call pk_cdc_cl3b(lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3b) - cdc_cl3=cdc_cl3b - else - call pk_cdc_cl3d(lqd,rqd,reynolds,p2p1,beta,cdc_cl3d) - cdc_cl3=cdc_cl3d -! - endif -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pk_cdi_noz.f calculix-ccx-2.3/ccx_2.1/src/pk_cdi_noz.f --- calculix-ccx-2.1/ccx_2.1/src/pk_cdi_noz.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pk_cdi_noz.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,75 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -!cd incompressible for ASME nozzles eq 4a 4b - - subroutine pk_cdi_noz(reynolds,cdi_noz) -! - implicit none -! - real*8 reynolds,cdi_noz,ln_reynolds,cdi_noz_lr, - & cdi_noz_hr,e,reynolds_cor -! - if (reynolds.lt.40000d0) then -! -! formerly pk_cdi_noz_lr : for low Reynolds nsumber -! - if (reynolds.eq.0d0) then - reynolds_cor=1.d0 - else - reynolds_cor=reynolds - endif - e=2.718281828459045d0 - ln_reynolds=log(reynolds_cor)/log(e) -! - cdi_noz_lr=0.19436d0+0.152884d0*ln_reynolds - & -0.0097785d0*ln_reynolds**2d0+0.00020903d0 - & *ln_reynolds**3d0 -! - cdi_noz=cdi_noz_lr -! - elseif (reynolds.lt.50000d0) then -! - if (reynolds.eq.0) then - reynolds_cor=1 - else - reynolds_cor=reynolds - endif -! - e=2.718281828459045d0 - ln_reynolds=log(reynolds_cor)/log(e) -! - cdi_noz_lr=0.19436d0+0.152884d0*ln_reynolds - & -0.0097785d0*ln_reynolds**2+0.00020903d0 - & *ln_reynolds**3d0 -! - cdi_noz_hr=0.9975d0-0.00653d0*dsqrt(1000000d0/50000d0) - -! linear interpolation in order to achieve continuity -! - cdi_noz=cdi_noz_lr+(cdi_noz_hr-cdi_noz_lr) - & *(reynolds-40000d0)/(50000d0-40000d0) - else -! -! formerly pk_cdi_noz_hr for high Reynolds numbers -! - cdi_noz=0.9975d0-0.00653d0*dsqrt(1000000d0/reynolds) - endif - - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pk_cdi_r.f calculix-ccx-2.3/ccx_2.1/src/pk_cdi_r.f --- calculix-ccx-2.1/ccx_2.1/src/pk_cdi_r.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pk_cdi_r.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! cd inncompressible fro thin orifices with corner radiusing (eq 5) - - subroutine pk_cdi_r (rqd,reynolds,beta,cdi_r) -! - implicit none -! - real*8 rqd,reynolds,beta,cdi_r,frqd,cdi_se,cdi_noz -! - call pk_cdi_noz(reynolds,cdi_noz) - call pk_cdi_se(reynolds,beta,cdi_se) - - frqd=0.008d0+0.992d0*exp(-5.5d0*rqd-3.5d0*rqd**2.d0) -! - cdi_r=cdi_noz-frqd*(cdi_noz-cdi_se) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pk_cdi_rl.f calculix-ccx-2.3/ccx_2.1/src/pk_cdi_rl.f --- calculix-ccx-2.1/ccx_2.1/src/pk_cdi_rl.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pk_cdi_rl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -!cd incompressible for long orifices (eq.6) -! - subroutine pk_cdi_rl(lqd,rqd,reynolds,beta,cdi_rl) -! - implicit none -! - real*8 lqd,rqd,reynolds,beta,cdi_rl,rqd_cor,lrqd,cdi_r,glrqd -! - rqd_cor=rqd -! - if (rqd_cor.gt.lqd) then - rqd_cor=lqd - endif -! - lrqd=lqd-rqd_cor -! - call pk_cdi_r(rqd_cor,reynolds,beta,cdi_r) -! - glrqd=(1d0+1.298d0*exp(-1.593d0*lrqd**2.33d0)) - & *(0.435d0+0.021d0*lrqd)/(2.298d0*0.435d0) -! - cdi_rl=1.d0-glrqd*(1.d0-cdi_r) -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pk_cdi_se.f calculix-ccx-2.3/ccx_2.1/src/pk_cdi_se.f --- calculix-ccx-2.1/ccx_2.1/src/pk_cdi_se.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pk_cdi_se.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! cd incompressible for sharp edged orifices( eq.3) -! - subroutine pk_cdi_se(reynolds,beta,cdi_se) -! - implicit none -! - real*8 reynolds,beta,cdi_se,reynolds_cor -! - if(reynolds.eq.0d0) then - reynolds_cor=1.d0 - else - reynolds_cor=reynolds - endif -! - cdi_se=0.5959d0+0.0312d0*beta**2.1d0-0.184d0*beta**8.d0 - & +0.09d0*0.4333d0*beta**4.d0 - & /(1.d0-beta**4.d0)-0.0337d0*0.47d0*beta**3.d0+91.71d0 - & *(beta**1.75d0)/(reynolds_cor**0.75d0) -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pk_y0_yg.f calculix-ccx-2.3/ccx_2.1/src/pk_y0_yg.f --- calculix-ccx-2.1/ccx_2.1/src/pk_y0_yg.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pk_y0_yg.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine pk_y0_yg(p2p1,beta,kappa,y0,yg) -! - implicit none -! - real*8 p2p1,beta,kappa,y0,yg,pcrit -! -! adiabatic expansion factor y0 measured (eq.15-17) -! - pcrit=(2.d0/(kappa+1.d0))**(kappa/(kappa-1.d0)) - - if(p2p1.ge.0.63d0) then - y0=1d0-(0.41d0+0.35d0*beta**4.d0)/kappa*(1.d0-p2p1) - else - y0=1d0-(0.41d0+0.35d0*beta**4.d0)/kappa*(1.d0-0.63d0) - & -(0.3475d0+0.1207d0*beta**2.d0-0.3177d0*beta**4.d0) - & *(0.63d0-p2p1) -! - endif -! -! adiabatic expension factor yg isentropic eq 18 -! - if(p2p1.ge.1d0) then - yg=1.d0 -! - elseif (p2p1.ge.pcrit) then - yg=p2p1**(1.d0/kappa)*dsqrt(kappa/(kappa-1.d0) - & *(1.d0-p2p1**((kappa-1.d0)/kappa)))/dsqrt(1.d0-p2p1) -! - else -! critical pressure ratio - yg=(2.d0/(kappa+1.d0))**(1.d0/(kappa-1.d0)) - & *dsqrt(kappa/(kappa+1.d0))/dsqrt(1.d0-p2p1) - endif -! - return -! - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/plane3.f calculix-ccx-2.3/ccx_2.1/src/plane3.f --- calculix-ccx-2.1/ccx_2.1/src/plane3.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/plane3.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine plane3(co,nodep,a,b,c,d) -! -! calculate the equation of the plane through the -! nodes nodep(1),nodep(2) and nodep(3) in the form -! a*x+b*y+c*z+d=0 such that the triangle through the -! nodes nodep(1),nodep(2),nopep(3) is numbered clockwise -! when looking in the direction of vector (a,b,c) -! - implicit none -! - integer nodep(3),i -! - real*8 co(3,*),a,b,c,d,dd,p12(3),p23(3),p31(3) -! -! sides of the triangle -! - do i=1,3 - p12(i)=co(i,nodep(2))-co(i,nodep(1)) - p23(i)=co(i,nodep(3))-co(i,nodep(2)) - p31(i)=co(i,nodep(1))-co(i,nodep(3)) - enddo -! -! normalized vector normal to the triangle: xn = p12 x p23 -! - a=p12(2)*p23(3)-p12(3)*p23(2) - b=p12(3)*p23(1)-p12(1)*p23(3) - c=p12(1)*p23(2)-p12(2)*p23(1) - dd=dsqrt(a*a+b*b+c*c) - a=a/dd - b=b/dd - c=c/dd -! -! determining the inhomogeneous term -! - d=-a*co(1,nodep(1))-b*co(2,nodep(1))-c*co(3,nodep(1)) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/plane4.f calculix-ccx-2.3/ccx_2.1/src/plane4.f --- calculix-ccx-2.1/ccx_2.1/src/plane4.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/plane4.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,90 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine plane4(co,node,nodep,a,b,c,d) -! -! given are 5 nodes: node and nodep(1) up to nodep(4) -! -! first, the node among the nodep's with the largest -! distance from node is eliminated. The remaining nodes -! are stored into noden(1) up to noden(3). -! -! Then, the equation of the plane through the -! nodes noden(1),noden(2) and noden(3) in the form -! a*x+b*y+c*z+d=0 such that the triangle through the -! nodes noden(1),noden(2),nopen(3) is numbered clockwise -! when looking in the direction of vector (a,b,c) -! - implicit none -! - integer nodep(4),i,j,noden(3),node,kflag,idist(4),n -! - real*8 co(3,*),a,b,c,d,dd,p12(3),p23(3),p31(3),dist(4) -! - kflag=2 - n=4 -! -! determining the distance of the nodep's to node -! - do i=1,4 - dist(i)=((co(1,nodep(i))-co(1,node))**2+ - & (co(2,nodep(i))-co(2,node))**2+ - & (co(3,nodep(i))-co(3,node))**2) - idist(i)=nodep(i) -c write(*,*) nodep(i),dist(i) - enddo -! -! sorting the distances -! - call dsort(dist,idist,n,kflag) -! -! storing the 3 closest nodes in noden -! - j=0 - do i=1,4 - if(nodep(i).eq.idist(4)) cycle - j=j+1 - noden(j)=nodep(i) - enddo -c write(*,*) 'noden ',(noden(i),i=1,3) -! -! sides of the triangle -! - do i=1,3 - p12(i)=co(i,noden(2))-co(i,noden(1)) - p23(i)=co(i,noden(3))-co(i,noden(2)) - p31(i)=co(i,noden(1))-co(i,noden(3)) - enddo -! -! normalized vector normal to the triangle: xn = p12 x p23 -! - a=p12(2)*p23(3)-p12(3)*p23(2) - b=p12(3)*p23(1)-p12(1)*p23(3) - c=p12(1)*p23(2)-p12(2)*p23(1) - dd=dsqrt(a*a+b*b+c*c) - a=a/dd - b=b/dd - c=c/dd -! -! determining the inhomogeneous term -! - d=-a*co(1,noden(1))-b*co(2,noden(1))-c*co(3,noden(1)) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/planempc.f calculix-ccx-2.3/ccx_2.1/src/planempc.f --- calculix-ccx-2.1/ccx_2.1/src/planempc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/planempc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,168 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine planempc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, - & ikboun,ilboun,nboun,nboun_,xboun,inode,node,co,typeboun) -! -! generates MPC's for nodes staying on a straight line defined -! by two nodes a and b. The parameter inode indicates how many -! times the present routine was called within the same *MPC -! definition. For inode=1 "node" is node a, for inode=2 "node" -! is node b. Starting with inode=3 MPC's are defined. -! - implicit none -! - character*1 typeboun(*) - character*20 labmpc(*) -! - integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), - & ilmpc(*),node,id,mpcfreeold,j,idof,l,nodeboun(*),nodea,nodeb, - & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,inode,jmax,k,nodec, - & m -! - real*8 coefmpc(3,*),co(3,*),dd,dmax,pac(3),pbc(3),xboun(*) -! - save nodea,nodeb,nodec,jmax -! - if(inode.eq.1) then - nodea=node - return - elseif(inode.eq.2) then - nodeb=node - return - elseif(inode.eq.3) then - nodec=node - do j=1,3 - pac(j)=co(j,nodea)-co(j,nodec) - pbc(j)=co(j,nodeb)-co(j,nodec) - enddo - dmax=abs(pac(2)*pbc(3)-pac(3)*pbc(2)) - jmax=1 - dd=abs(pac(1)*pbc(3)-pac(3)*pbc(1)) - if(dd.gt.dmax) then - dmax=dd - jmax=2 - endif - dd=abs(pac(1)*pbc(2)-pac(2)*pbc(1)) - if(dd.gt.dmax) then - dmax=dd - jmax=3 - endif - return - endif -! - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in planempc: increase nk_' - stop - endif -! - j=jmax - k=j+1 - if(k.gt.3) k=1 - l=k+1 - if(l.gt.3) l=1 -! - idof=8*(node-1)+j - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*WARNING in planempc: DOF for node ',node - write(*,*) ' in direction ',j,' has been used' - write(*,*) ' on the dependent side of another MPC' - write(*,*) ' PLANE constraint cannot be applied' - return - endif - endif - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in planempc: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)='PLANE ' -! - do m=nmpc,id+2,-1 - ikmpc(m)=ikmpc(m-1) - ilmpc(m)=ilmpc(m-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=j - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=k - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=l - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodea - nodempc(2,mpcfree)=j - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodea - nodempc(2,mpcfree)=k - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodea - nodempc(2,mpcfree)=l - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodeb - nodempc(2,mpcfree)=j - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodeb - nodempc(2,mpcfree)=k - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodeb - nodempc(2,mpcfree)=l - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodec - nodempc(2,mpcfree)=j - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodec - nodempc(2,mpcfree)=k - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodec - nodempc(2,mpcfree)=l - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=j - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - idof=8*(nk-1)+j - call nident(ikboun,idof,nboun,id) - nboun=nboun+1 - if(nboun.gt.nboun_) then - write(*,*) '*ERROR in planempc: increase nboun_' - stop - endif - nodeboun(nboun)=nk - ndirboun(nboun)=j - typeboun(nboun)='P' - do m=nboun,id+2,-1 - ikboun(m)=ikboun(m-1) - ilboun(m)=ilboun(m-1) - enddo - ikboun(id+1)=idof - ilboun(id+1)=nboun -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/plastics.f calculix-ccx-2.3/ccx_2.1/src/plastics.f --- calculix-ccx-2.1/ccx_2.1/src/plastics.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/plastics.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,362 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine plastics(inpc,textpart,nelcon,nmat,ntmat_,npmat_, - & plicon,nplicon,plkcon,nplkcon,iplas,iperturb,nstate_, - & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,ipoinpc,ianisoplas) -! -! reading the input deck: *PLASTIC -! - implicit none -! - logical iso -! - character*1 inpc(*) - character*80 matname(*) - character*132 textpart(16) -! - integer nelcon(2,*),nmat,ntmat_,ntmat,npmat_,npmat,istep, - & n,key,i,nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),ncmat_, - & iplas,iperturb(*),istat,nstate_,kin,itemp,ndata,ndatamax,id, - & irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),ipoinpc(0:*), - & ianisoplas -! - real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), - & temperature,plconloc(82),t1l,elcon(0:ncmat_,ntmat_,*) -! - iso=.true. -! - ntmat=0 - npmat=0 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in plastics: *PLASTIC should be placed' - write(*,*) ' before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in plastics: *PLASTIC should be preceded' - write(*,*) ' by a *MATERIAL card' - stop - endif -! - if((nelcon(1,nmat).ne.2).and.(nelcon(1,nmat).ne.9)) then - write(*,*) '*ERROR in plastics: *PLASTIC should be preceded' - write(*,*) ' by an *ELASTIC,TYPE=ISO card or' - write(*,*) ' by an *ELASTIC,TYPE=ORTHO card' - stop - endif -! - iperturb(1)=3 - iperturb(2)=1 -! - if(nelcon(1,nmat).eq.2) then - iplas=1 - nelcon(1,nmat)=-51 - nstate_=max(nstate_,13) - else - ianisoplas=1 - nelcon(1,nmat)=-114 - nstate_=max(nstate_,14) - endif -! - do i=2,n - if(textpart(i)(1:10).eq.'HARDENING=') then - if(textpart(i)(11:19).eq.'KINEMATIC') then - iso=.false. - elseif(textpart(i)(11:18).eq.'COMBINED') then - iso=.false. - elseif(textpart(i)(11:14).eq.'USER') then - if(nelcon(1,nmat).eq.-114) then - write(*,*) '*ERROR in plastics: user defined ' - write(*,*) ' hardening is not allowed for ' - write(*,*) ' elastically anisotropic materials' - stop - endif - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - return - endif - exit - endif - enddo -! - if(iso) then -! -! isotropic hardening coefficients -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(3)(1:20),'(f20.0)',iostat=istat) temperature - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! -! first temperature -! - if(ntmat.eq.0) then - npmat=0 - ntmat=ntmat+1 - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in plastics: increase ntmat_' - stop - endif - nplicon(0,nmat)=ntmat - plicon(0,ntmat,nmat)=temperature -! -! new temperature -! - elseif(plicon(0,ntmat,nmat).ne.temperature) then - npmat=0 - ntmat=ntmat+1 - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in plastics: increase ntmat_' - stop - endif - nplicon(0,nmat)=ntmat - plicon(0,ntmat,nmat)=temperature - endif - do i=1,2 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & plicon(2*npmat+i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - npmat=npmat+1 - if(npmat.gt.npmat_) then - write(*,*) '*ERROR in plastics: increase npmat_' - stop - endif - nplicon(ntmat,nmat)=npmat - enddo - else -! -! kinematic hardening coefficients -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(3)(1:20),'(f20.0)',iostat=istat) temperature - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! -! first temperature -! - if(ntmat.eq.0) then - npmat=0 - ntmat=ntmat+1 - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in plastics: increase ntmat_' - stop - endif - nplkcon(0,nmat)=ntmat - plkcon(0,ntmat,nmat)=temperature -! -! new temperature -! - elseif(plkcon(0,ntmat,nmat).ne.temperature) then - npmat=0 - ntmat=ntmat+1 - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in plastics: increase ntmat_' - stop - endif - nplkcon(0,nmat)=ntmat - plkcon(0,ntmat,nmat)=temperature - endif - do i=1,2 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & plkcon(2*npmat+i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - npmat=npmat+1 - if(npmat.gt.npmat_) then - write(*,*) '*ERROR in plastics: increase npmat_' - stop - endif - nplkcon(ntmat,nmat)=npmat - enddo - endif -! - if(ntmat.eq.0) then - write(*,*) '*ERROR in plastics: *PLASTIC card without data' - stop - endif -! -! elastically anisotropic materials: recasting the input data -! in a format conform to the user routine umat_aniso_plas.f -! - if(nelcon(1,nmat).eq.-114) then - if(matname(nmat)(71:80).ne.' ') then - write(*,*) '*ERROR in plastics: the material name for an' - write(*,*) ' elastically anisotropic material with' - write(*,*) ' isotropic plasticity must not exceed 70' - write(*,*) ' characters' - stop - else - do i=80,11,-1 - matname(nmat)(i:i)=matname(nmat)(i-10:i-10) - enddo -c matname(nmat)(11:80)=matname(nmat)(1:70) - matname(nmat)(1:10)='ANISO_PLAS' - endif -! - if(iso) then -! -! isotropic hardening -! -! interpolating the plastic data at the elastic temperature -! data points -! - ndatamax=0 - do i=1,nelcon(2,nmat) - t1l=elcon(0,i,nmat) -c plconloc(1)=0.d0 -c plconloc(2)=0.d0 -c plconloc(3)=0.d0 -c plconloc(81)=nplicon(1,nmat)+0.5d0 -! - if(nplicon(0,nmat).eq.1) then - id=-1 - else - call ident2(plicon(0,1,nmat),t1l,nplicon(0,nmat), - & 2*npmat_+1,id) - endif -! - if(nplicon(0,nmat).eq.0) then - continue - elseif((nplicon(0,nmat).eq.1).or.(id.eq.0).or. - & (id.eq.nplicon(0,nmat))) then - if(id.le.0) then - itemp=1 - else - itemp=id - endif - kin=0 - call plcopy(plicon,nplicon,plconloc,npmat_,ntmat_, - & nmat,itemp,i,kin) - if((id.eq.0).or.(id.eq.nplicon(0,nmat))) then - endif - else - kin=0 - call plmix(plicon,nplicon,plconloc,npmat_,ntmat_, - & nmat,id+1,t1l,i,kin) - endif -! - ndata=int(plconloc(81)) - if(ndata.eq.1) then - elcon(10,i,nmat)=plconloc(2) - elcon(11,i,nmat)=0.d0 - elcon(12,i,nmat)=0.d0 - elcon(13,i,nmat)=-1.d0 - elcon(14,i,nmat)=1.d0 - else - elcon(10,i,nmat)=plconloc(2) - elcon(11,i,nmat)=(plconloc(4)-plconloc(2))/ - & (plconloc(3)-plconloc(1)) - elcon(12,i,nmat)=0.d0 - elcon(13,i,nmat)=-1.d0 - elcon(14,i,nmat)=1.d0 - endif - ndatamax=max(ndata,ndatamax) - enddo - if(ndatamax.gt.2) then - write(*,*) '*WARNING in plastics: isotropic hardening' - write(*,*) ' curve is possibly nonlinear for' - write(*,*) ' the elastically anisotropic' - write(*,*) ' material ',matname(nmat)(11:80) - endif - else -! -! kinematic hardening -! -! interpolating the plastic data at the elastic temperature -! data points -! - ndatamax=0 - do i=1,nelcon(2,nmat) - t1l=elcon(0,i,nmat) -c plconloc(1)=0.d0 -c plconloc(2)=0.d0 -c plconloc(3)=0.d0 -c plconloc(82)=nplkcon(1,nmat)+0.5d0 -! - if(nplkcon(0,nmat).eq.1) then - id=-1 - else - call ident2(plkcon(0,1,nmat),t1l,nplkcon(0,nmat), - & 2*npmat_+1,id) - endif -! - if(nplkcon(0,nmat).eq.0) then - continue - elseif((nplkcon(0,nmat).eq.1).or.(id.eq.0).or. - & (id.eq.nplkcon(0,nmat))) then - if(id.le.0) then - itemp=1 - else - itemp=id - endif - kin=1 - call plcopy(plkcon,nplkcon,plconloc,npmat_,ntmat_, - & nmat,itemp,i,kin) - if((id.eq.0).or.(id.eq.nplkcon(0,nmat))) then - endif - else - kin=1 - call plmix(plkcon,nplkcon,plconloc,npmat_,ntmat_, - & nmat,id+1,t1l,i,kin) - endif -! - ndata=int(plconloc(82)) - if(ndata.eq.1) then - elcon(10,i,nmat)=plconloc(42) - elcon(11,i,nmat)=0.d0 - elcon(12,i,nmat)=0.d0 - elcon(13,i,nmat)=-1.d0 - elcon(14,i,nmat)=1.d0 - else - elcon(10,i,nmat)=plconloc(42) - elcon(11,i,nmat)=0.d0 - elcon(12,i,nmat)=(plconloc(44)-plconloc(42))/ - & (plconloc(43)-plconloc(41)) - elcon(13,i,nmat)=-1.d0 - elcon(14,i,nmat)=1.d0 - endif - ndatamax=max(ndata,ndatamax) - enddo - if(ndatamax.gt.2) then - write(*,*) '*WARNING in plastics: kinematic hardening' - write(*,*) ' curve is possibly nonlinear for' - write(*,*) ' the elastically anisotropic' - write(*,*) ' material ',matname(nmat)(11:80) - endif - endif - endif -! -c if(nelcon(1,nmat).eq.-114) then -c write(*,*) 'anisotropic elasticity+viscoplasticity' -c do i=1,nelcon(2,nmat) -c write(*,*) (elcon(j,i,nmat),j=0,14) -c enddo -c endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/plcopy.f calculix-ccx-2.3/ccx_2.1/src/plcopy.f --- calculix-ccx-2.1/ccx_2.1/src/plcopy.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/plcopy.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,81 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine plcopy(plcon,nplcon,plconloc,npmat_,ntmat_, - & imat,itemp,nelem,kin) -! -! copies the hardening data for material imat and temperature -! itemp from plcon into plconloc if the number of data points does -! not exceed 20. Else, the equivalent plastic strain range is -! divided into 19 intervals and the values are interpolated. -! Attention: in plcon the odd storage spaces contain the Von -! Mises stress, the even ones the equivalent plastic -! strain. For plconloc, this order is reversed. -! - implicit none -! - integer imat,ndata,ntmat_,npmat_,nplcon(0:ntmat_,*),nelem, - & kin,k,itemp -! - real*8 eplmin,eplmax,depl,epla,plcon(0:2*npmat_,ntmat_,*), - & plconloc(82),dummy -! - ndata=nplcon(itemp,imat) -! - if(ndata.le.20) then - if(kin.eq.0) then - do k=1,ndata - plconloc(2*k-1)=plcon(2*k,itemp,imat) - plconloc(2*k)=plcon(2*k-1,itemp,imat) - enddo - plconloc(81)=real(ndata)+0.5d0 - else - do k=1,ndata - plconloc(39+2*k)=plcon(2*k,itemp,imat) - plconloc(40+2*k)=plcon(2*k-1,itemp,imat) - enddo - plconloc(82)=real(ndata)+0.5d0 - endif - else - if(kin.eq.0) then - eplmin=plcon(2,itemp,imat) - eplmax=plcon(2*nplcon(itemp,imat),itemp,imat)-1.d-10 - depl=(eplmax-eplmin)/19.d0 - do k=1,20 - epla=eplmin+(k-1)*depl - call plinterpol(plcon,nplcon,itemp, - & plconloc(2*k),dummy,npmat_,ntmat_,imat,nelem,epla) - plconloc(2*k-1)=epla - enddo - plconloc(81)=20.5d0 - else - eplmin=plcon(2,itemp,imat) - eplmax=plcon(2*nplcon(itemp,imat),itemp,imat)-1.d-10 - depl=(eplmax-eplmin)/19.d0 - do k=1,20 - epla=eplmin+(k-1)*depl - call plinterpol(plcon,nplcon,itemp, - & plconloc(40+2*k),dummy,npmat_,ntmat_,imat,nelem,epla) - plconloc(39+2*k)=epla - enddo - endif - plconloc(82)=20.5d0 - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/plinterpol.f calculix-ccx-2.3/ccx_2.1/src/plinterpol.f --- calculix-ccx-2.1/ccx_2.1/src/plinterpol.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/plinterpol.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,61 +0,0 @@ -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine plinterpol(plcon,nplcon,itemp,f,df,npmat_,ntmat_, - & imat,nelem,epl) -! - implicit none -! -! interpolation of isotropic or kinematic hardening data -! input: hardening data plcon and nplcon, temperature itemp, -! size parameters npmat_ and ntmat_, material number imat -! and equivalent plastic strain at which the coefficients -! are to be determined -! output: hardening coefficient and its local derivative f and df -! - integer npmat_,ntmat_,nplcon(0:ntmat_,*),itemp,ndata,imat,j, - & nelem -! - real*8 plcon(0:2*npmat_,ntmat_,*),f,df,epl -! - ndata=nplcon(itemp,imat) -! - do j=1,ndata - if(epl.lt.plcon(2*j,itemp,imat)) exit - enddo -! - if((j.eq.1).or.(j.gt.ndata)) then - if(j.eq.1) then - f=plcon(1,itemp,imat) - df=0.d0 - else - f=plcon(2*ndata-1,itemp,imat) - df=0.d0 - endif - write(*,*) '*WARNING in plinterpol: plastic strain ',epl - write(*,*) ' outside material plastic strain range' - write(*,*) ' in element ',nelem,' and material ',imat - write(*,*) ' for temperature ',plcon(0,itemp,imat) - else - df=(plcon(2*j-1,itemp,imat)-plcon(2*j-3,itemp,imat))/ - & (plcon(2*j,itemp,imat)-plcon(2*j-2,itemp,imat)) - f=plcon(2*j-3,itemp,imat)+ - & df*(epl-plcon(2*j-2,itemp,imat)) - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/plmix.f calculix-ccx-2.3/ccx_2.1/src/plmix.f --- calculix-ccx-2.1/ccx_2.1/src/plmix.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/plmix.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,205 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine plmix(plcon,nplcon,plconloc,npmat_,ntmat_, - & imat,j,temp,nelem,kin) -! -! interpolates the hardening data for material imat and temperature -! j and j-1 to obtain data for temperature temp. The data is taken -! from plcon and stored in plconloc. -! The Von Mises stress is interpolated for a given equivalent -! plastic strain. If the equivalent strain data points for -! temperature j and j-1 do not coincide, the union of both is -! taken. If this union exceeds 20 (ierror=1), the equivalent plastic -! strain range is divided into 19 intervals yielding 20 new -! equivalent strain data points, for which the Von Mises stress -! is interpolated. -! Attention: in plcon the odd storage spaces contain the Von -! Mises stress, the even ones the equivalent plastic -! strain. For plconloc, this order is reversed. -! - implicit none -! - integer imat,ndata,ntmat_,npmat_,nplcon(0:ntmat_,*),nelem, - & kin,k,j,k1,k2,ierror,ndata1,ndata2,itemp -! - real*8 eplmin,eplmax,depl,epla,plcon(0:2*npmat_,ntmat_,*), - & plconloc(82),dummy,temp,ep1,ep2,t1,t2,s1,s2,ratio -! - ndata=0 - ierror=0 -! - ndata1=nplcon(j-1,imat) - ndata2=nplcon(j,imat) - t1=plcon(0,j-1,imat) - t2=plcon(0,j,imat) - ratio=(temp-t1)/(t2-t1) -! -! the interval on which the stress interpolation is performed -! is the intersection of the domain of the two curves -! - k1=1 - k2=1 - ep1=plcon(2,j-1,imat) - ep2=plcon(2,j,imat) - if(ep1.gt.ep2) then - do k2=1,ndata2 - ep2=plcon(2*k2,j,imat) - if(ep2.gt.ep1) exit - enddo - if(k2.gt.ndata2) then - write(*,*) '*ERROR in plmix: there exist two temperatures' - write(*,*) ' for which the hardening curves are' - write(*,*) ' disjunct' - stop - endif - elseif(ep2.gt.ep1) then - do k1=1,ndata1 - ep1=plcon(2*k1,j-1,imat) - if(ep1.gt.ep2) exit - enddo - if(k1.gt.ndata1) then - write(*,*) '*ERROR in plmix: there exist two temperatures' - write(*,*) ' for which the hardening curves are' - write(*,*) ' disjunct' - stop - endif - endif -! - do - s1=plcon(2*k1-1,j-1,imat) - s2=plcon(2*k2-1,j,imat) - ep1=plcon(2*k1,j-1,imat) - ep2=plcon(2*k2,j,imat) -! - if(dabs(ep1-ep2).lt.1.d-10) then - if(k2.lt.ndata2) then - k2=k2+1 - elseif(k1.lt.ndata1) then - k1=k1+1 - else - ndata=ndata+1 - if(ndata.gt.20) then - ierror=1 - exit - endif - if(kin.eq.0) then - plconloc(2*ndata-1)=ep1+ratio*(ep2-ep1) - plconloc(2*ndata)=s1+ratio*(s2-s1) - else - plconloc(39+2*ndata)=ep1+ratio*(ep2-ep1) - plconloc(40+2*ndata)=s1+ratio*(s2-s1) - endif - exit - endif - cycle - endif - if(ep1.lt.ep2) then - ndata=ndata+1 - if(ndata.gt.20) then - ierror=1 - exit - endif - call plinterpol(plcon,nplcon,j,s2,dummy,npmat_,ntmat_, - & imat,nelem,ep1) - if(kin.eq.0) then - plconloc(2*ndata-1)=ep1 - plconloc(2*ndata)=s1+ratio*(s2-s1) - else - plconloc(39+2*ndata)=ep1 - plconloc(40+2*ndata)=s1+ratio*(s2-s1) - endif - if(k1.lt.ndata1) then - k1=k1+1 - cycle - else - exit - endif - else - ndata=ndata+1 - if(ndata.gt.20) then - ierror=1 - exit - endif - call plinterpol(plcon,nplcon,j-1,s1,dummy,npmat_,ntmat_, - & imat,nelem,ep2) - if(kin.eq.0) then - plconloc(2*ndata-1)=ep2 - plconloc(2*ndata)=s1+ratio*(s2-s1) - else - plconloc(39+2*ndata)=ep2 - plconloc(40+2*ndata)=s1+ratio*(s2-s1) - endif - if(k2.lt.ndata2) then - k2=k2+1 - cycle - else - exit - endif - endif - enddo -! -! if more than 20 data points result, the interval is divided into -! 19 equidistant intervals -! - if(ierror.eq.0) then - if(kin.eq.0) then - plconloc(81)=real(ndata)+0.5d0 - else - plconloc(82)=real(ndata)+0.5d0 - endif - else - if(kin.eq.0) then - eplmin=max(plcon(2,j-1,imat),plcon(2,j,imat)) - eplmax=min(plcon(2*ndata1,j-1,imat),plcon(2*ndata2,j,imat)) - & -1.d-10 - depl=(eplmax-eplmin)/19.d0 - do k=1,20 - epla=eplmin+(k-1)*depl - itemp=j-1 - call plinterpol(plcon,nplcon,itemp,s1, - & dummy,npmat_,ntmat_,imat,nelem,epla) - itemp=j - call plinterpol(plcon,nplcon,itemp,s2, - & dummy,npmat_,ntmat_,imat,nelem,epla) - plconloc(2*k-1)=epla - plconloc(2*k)=s1+ratio*(s2-s1) - enddo - plconloc(81)=20.5d0 - else - eplmin=max(plcon(2,j-1,imat),plcon(2,j,imat)) - eplmax=min(plcon(2*ndata1,j-1,imat),plcon(2*ndata2,j,imat)) - & -1.d-10 - depl=(eplmax-eplmin)/19.d0 - do k=1,20 - epla=eplmin+(k-1)*depl - itemp=j-1 - call plinterpol(plcon,nplcon,itemp,s1, - & dummy,npmat_,ntmat_,imat,nelem,epla) - itemp=j - call plinterpol(plcon,nplcon,itemp,s2, - & dummy,npmat_,ntmat_,imat,nelem,epla) - plconloc(19+2*k)=epla - plconloc(20+2*k)=s1+ratio*(s2-s1) - enddo - plconloc(82)=20.5d0 - endif - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/polynom.f calculix-ccx-2.3/ccx_2.1/src/polynom.f --- calculix-ccx-2.1/ccx_2.1/src/polynom.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/polynom.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine polynom(x,y,z,p) -! -! calculates the polynomial terms for the Zienkiewicz-Zhu -! stress recovery procedure -! - implicit none -! - real*8 p(20),x,y,z -! - p(1)=1.d0 - p(2)=x - p(3)=y - p(4)=z - p(5)=x*x - p(6)=y*y - p(7)=z*z - p(8)=x*y - p(9)=x*z - p(10)=y*z - p(11)=x*x*y - p(12)=x*y*y - p(13)=x*x*z - p(14)=x*z*z - p(15)=y*y*z - p(16)=y*z*z - p(17)=x*y*z - p(18)=x*x*y*z - p(19)=x*y*y*z - p(20)=x*y*z*z -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/precfd.f calculix-ccx-2.3/ccx_2.1/src/precfd.f --- calculix-ccx-2.1/ccx_2.1/src/precfd.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/precfd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,650 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine precfd(nelemface,sideface,nface,ipoface,nodface, - & ne,ipkon,kon,lakon,ikboun,ilboun,xboun,nboun,nk,isolidsurf, - & nsolidsurf,ifreestream,nfreestream,neighsolidsurf,iponoel,inoel, - & inoelfree,nef,co,ipompc,nodempc,ikmpc,ilmpc,nmpc) -! -! preliminary calculations for cfd applicatons: -! - determining the external faces of the mesh and storing -! them in fields nelemface and sideface -! - determining the nodes belonging to solid surfaces and -! storing them in isolidsurf (in ascending order) -! - determining the nodes belonging to freestream surfaces -! and storing them in ifreestream (in ascending order) -! - determining the fluid elements belonging to a given node -! and storing them in fields iponoel and inoel -! - implicit none -! - logical solidboun,mpcnode -! - character*1 sideface(*) - character*8 lakon(*) -! - integer nelemface(*),nface,ipoface(*),nodface(5,*),nodes(4), - & ne,ipkon(*),kon(*),indexe,ifaceq(8,6),ifacet(6,4),index, - & ifacew(8,5),ithree,ifour,iaux,kflag,nnodes,ikboun(*), - & ilboun(*),nboun,isolidsurf(*),nsolidsurf,ifreestream(*), - & nfreestream,id,nk,node,idof,i,j,k,l,m,neighsolidsurf(*), - & iponoel(*),noden,idn,nope,nodemin,ifree,nef,indexold, - & inoel(3,*),ifreenew,inoelfree,mpc,ikmpc(*),nmpc, - & nodempc(3,*),ipompc(*),ilmpc(*) -! - real*8 xboun(*),dist,distmin,co(3,*) -! -! nodes belonging to the element faces -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ - data ifacew /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! - kflag=1 - ithree=3 - ifour=4 -! -! determining the external element faces of the fluid mesh -! the faces are catalogued by the three lowes nodes numbers -! in ascending order. ipoface(i) points to a face for which -! node i is the lowest node and nodface(1,ipoface(i)) and -! nodface(2,ipoface(i)) are the next lower ones. -! nodface(3,ipoface(i)) contains the element number, -! nodface(4,ipoface(i)) the face number and nodface(5,ipoface(i)) -! is a pointer to the next surface for which node i is the -! lowest node; if there are no more such surfaces the pointer -! has the value zero -! An external element face is one which belongs to one element -! only -! - ifree=1 - do i=1,6*nef-1 - nodface(5,i)=i+1 - enddo - do i=1,ne - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - indexe=ipkon(i) - if((lakon(i)(4:4).eq.'2').or.(lakon(i)(4:4).eq.'8')) then - do j=1,6 - do k=1,4 - nodes(k)=kon(indexe+ifaceq(k,j)) - enddo - call isortii(nodes,iaux,ifour,kflag) - indexold=0 - index=ipoface(nodes(1)) - do -! -! adding a surface which has not been -! catalogued so far -! - if(index.eq.0) then - ifreenew=nodface(5,ifree) - nodface(1,ifree)=nodes(2) - nodface(2,ifree)=nodes(3) - nodface(3,ifree)=i - nodface(4,ifree)=j -c write(*,*) 'new ',i,j - nodface(5,ifree)=ipoface(nodes(1)) - ipoface(nodes(1))=ifree - ifree=ifreenew - exit - endif -! -! removing a surface which has already -! been catalogued -! - if((nodface(1,index).eq.nodes(2)).and. - & (nodface(2,index).eq.nodes(3))) then - if(indexold.eq.0) then - ipoface(nodes(1))=nodface(5,index) - else - nodface(5,indexold)=nodface(5,index) - endif - nodface(5,index)=ifree -c write(*,*) 'freed ', -c & nodface(3,index),nodface(4,index) - ifree=index - exit - endif - indexold=index - index=nodface(5,index) - enddo - enddo - elseif((lakon(i)(4:4).eq.'4').or.(lakon(i)(4:5).eq.'10')) then - do j=1,4 - do k=1,3 - nodes(k)=kon(indexe+ifacet(k,j)) - enddo - call isortii(nodes,iaux,ithree,kflag) - indexold=0 - index=ipoface(nodes(1)) - do -! -! adding a surface which has not been -! catalogues so far -! - if(index.eq.0) then - ifreenew=nodface(5,ifree) - nodface(1,ifree)=nodes(2) - nodface(2,ifree)=nodes(3) - nodface(3,ifree)=i - nodface(4,ifree)=j - nodface(5,ifree)=ipoface(nodes(1)) - ipoface(nodes(1))=ifree - ifree=ifreenew - exit - endif -! -! removing a surface which has already -! been catalogued -! - if((nodface(1,index).eq.nodes(2)).and. - & (nodface(2,index).eq.nodes(3))) then - if(indexold.eq.0) then - ipoface(nodes(1))=nodface(5,index) - else - nodface(5,indexold)=nodface(5,index) - endif - nodface(5,index)=ifree - ifree=index - exit - endif - indexold=index - index=nodface(5,index) - enddo - enddo - else - do j=1,5 - if(j.le.2) then - do k=1,3 - nodes(k)=kon(indexe+ifacew(k,j)) - enddo - call isortii(nodes,iaux,ithree,kflag) - else - do k=1,4 - nodes(k)=kon(indexe+ifacew(k,j)) - enddo - call isortii(nodes,iaux,ifour,kflag) - endif - indexold=0 - index=ipoface(nodes(1)) - do -! -! adding a surface which has not been -! catalogues so far -! - if(index.eq.0) then - ifreenew=nodface(5,ifree) - nodface(1,ifree)=nodes(2) - nodface(2,ifree)=nodes(3) - nodface(3,ifree)=i - nodface(4,ifree)=j - nodface(5,ifree)=ipoface(nodes(1)) - ipoface(nodes(1))=ifree - ifree=ifreenew - exit - endif -! -! removing a surface which has already -! been catalogued -! - if((nodface(1,index).eq.nodes(2)).and. - & (nodface(2,index).eq.nodes(3))) then - if(indexold.eq.0) then - ipoface(nodes(1))=nodface(5,index) - else - nodface(5,indexold)=nodface(5,index) - endif - nodface(5,index)=ifree - ifree=index - exit - endif - indexold=index - index=nodface(5,index) - enddo - enddo - endif - enddo -! -! storing the external faces in nelemface and sideface -! catalogueing the external nodes in isolidsurf and ifreestream -! -! only the nodes which -! - belong to external faces AND -! - in which all velocity components are set to zero -! by SPC boundary conditions -! are considered as solid surface nodes -! -! all other external face nodes are freestream nodes -! - nface=0 - nsolidsurf=0 - nfreestream=0 -! - do m=1,nk - index=ipoface(m) - do - if(index.eq.0) exit - nface=nface+1 - i=nodface(3,index) - j=nodface(4,index) -c write(*,*) 'zu behandeln ',m,i,j -! - nelemface(nface)=i - write(sideface(nface)(1:1),'(i1)') j -! - indexe=ipkon(i) - if((lakon(i)(4:4).eq.'2').or.(lakon(i)(4:4).eq.'8')) then - if(lakon(i)(4:4).eq.'2') then - nnodes=8 - else - nnodes=4 - endif - do k=1,nnodes -c write(*,*) j,k,ifaceq(k,j),indexe - node=kon(indexe+ifaceq(k,j)) - solidboun=.true. - do l=1,3 - idof=8*(node-1)+l - call nident(ikboun,idof,nboun,id) - if(id.le.0) then - solidboun=.false. - exit - elseif(ikboun(id).ne.idof) then - solidboun=.false. - exit - elseif(dabs(xboun(ilboun(id))).gt.1.d-20) then - solidboun=.false. - exit - endif - enddo - if(solidboun) then - call nident(isolidsurf,node,nsolidsurf,id) - if(id.gt.0) then - if(isolidsurf(id).eq.node) cycle - endif - nsolidsurf=nsolidsurf+1 - do l=nsolidsurf,id+2,-1 - isolidsurf(l)=isolidsurf(l-1) - enddo - isolidsurf(id+1)=node - else - call nident(ifreestream,node,nfreestream,id) - if(id.gt.0) then - if(ifreestream(id).eq.node) cycle - endif - nfreestream=nfreestream+1 - do l=nfreestream,id+2,-1 - ifreestream(l)=ifreestream(l-1) - enddo - ifreestream(id+1)=node - endif - enddo - elseif((lakon(i)(4:4).eq.'4').or.(lakon(i)(4:5).eq.'10')) - & then - if(lakon(i)(4:4).eq.'4') then - nnodes=3 - else - nnodes=6 - endif - do k=1,nnodes - node=kon(indexe+ifacet(k,j)) - solidboun=.true. - do l=1,3 - idof=8*(node-1)+l - call nident(ikboun,idof,nboun,id) - if(id.le.0) then - solidboun=.false. - exit - elseif(ikboun(id).ne.idof) then - solidboun=.false. - exit - elseif(dabs(xboun(ilboun(id))).gt.1.d-20) then - solidboun=.false. - exit - endif - enddo - if(solidboun) then - call nident(isolidsurf,node,nsolidsurf,id) - if(id.gt.0) then - if(isolidsurf(id).eq.node) cycle - endif - nsolidsurf=nsolidsurf+1 - do l=nsolidsurf,id+2,-1 - isolidsurf(l)=isolidsurf(l-1) - enddo - isolidsurf(id+1)=node - else - call nident(ifreestream,node,nfreestream,id) - if(id.gt.0) then - if(ifreestream(id).eq.node) cycle - endif - nfreestream=nfreestream+1 - do l=nfreestream,id+2,-1 - ifreestream(l)=ifreestream(l-1) - enddo - ifreestream(id+1)=node - endif - enddo - else - if(lakon(i)(4:4).eq.'6') then - if(j.le.2) then - nnodes=3 - else - nnodes=4 - endif - else - if(j.le.2) then - nnodes=6 - else - nnodes=8 - endif - endif - do k=1,nnodes - node=kon(indexe+ifacew(k,j)) - solidboun=.true. - do l=1,3 - idof=8*(node-1)+l - call nident(ikboun,idof,nboun,id) - if(id.le.0) then - solidboun=.false. - exit - elseif(ikboun(id).ne.idof) then - solidboun=.false. - exit - elseif(dabs(xboun(ilboun(id))).gt.1.d-20) then - solidboun=.false. - exit - endif - enddo - if(solidboun) then - call nident(isolidsurf,node,nsolidsurf,id) - if(id.gt.0) then - if(isolidsurf(id).eq.node) cycle - endif - nsolidsurf=nsolidsurf+1 - do l=nsolidsurf,id+2,-1 - isolidsurf(l)=isolidsurf(l-1) - enddo - isolidsurf(id+1)=node - else - call nident(ifreestream,node,nfreestream,id) - if(id.gt.0) then - if(ifreestream(id).eq.node) cycle - endif - nfreestream=nfreestream+1 - do l=nfreestream,id+2,-1 - ifreestream(l)=ifreestream(l-1) - enddo - ifreestream(id+1)=node - endif - enddo - endif - index=nodface(5,index) - enddo - enddo -! -! all nodes belonging to MPC's are removed from the -! ifreestream stack -! - do i=1,nmpc - index=ipompc(i) - do - if(index.eq.0) exit - node=nodempc(1,index) - call nident(ifreestream,node,nfreestream,id) - if(id.gt.0) then - if(ifreestream(id).eq.node) then - nfreestream=nfreestream-1 - do j=id,nfreestream - ifreestream(j)=ifreestream(j+1) - enddo - endif - endif - index=nodempc(3,index) - enddo - enddo -! -! storing the in-stream neighbors of the solid surface external -! nodes in neighsolidsurf -! - do m=1,nface - i=nelemface(m) - read(sideface(m)(1:1),'(i1)') j - indexe=ipkon(i) -! - if((lakon(i)(4:4).eq.'2').or.(lakon(i)(4:4).eq.'8')) then - if(lakon(i)(4:4).eq.'2') then - nnodes=8 - nope=20 - else - nnodes=4 - nope=8 - endif - do k=1,nnodes - node=kon(indexe+ifaceq(k,j)) -! -! node must belong to solid surface -! - call nident(isolidsurf,node,nsolidsurf,id) - if(id.le.0) then - cycle - elseif(isolidsurf(id).ne.node) then - cycle - endif -! -! check whether neighbor was already found -! - if(neighsolidsurf(id).ne.0) cycle -! - distmin=1.d30 - nodemin=0 -! - do l=1,nope - noden=kon(indexe+l) -! -! node must not belong to solid surface -! - call nident(isolidsurf,noden,nsolidsurf,idn) - if(idn.gt.0) then - if(isolidsurf(idn).eq.noden) cycle - endif - dist=dsqrt((co(1,node)-co(1,noden))**2+ - & (co(2,node)-co(2,noden))**2+ - & (co(3,node)-co(3,noden))**2) - if(dist.lt.distmin) then - distmin=dist - nodemin=noden - endif - enddo - if(nodemin.ne.0) then - neighsolidsurf(id)=nodemin - endif - enddo - elseif((lakon(i)(4:4).eq.'4').or.(lakon(i)(4:5).eq.'10')) - & then - if(lakon(i)(4:4).eq.'4') then - nnodes=3 - nope=4 - else - nnodes=6 - nope=10 - endif - do k=1,nnodes - node=kon(indexe+ifacet(k,j)) -! -! node must belong to solid surface -! - call nident(isolidsurf,node,nsolidsurf,id) - if(id.le.0) then - cycle - elseif(isolidsurf(id).ne.node) then - cycle - endif -! -! check whether neighbor was already found -! - if(neighsolidsurf(id).ne.0) cycle -! - distmin=1.d30 - nodemin=0 -! - do l=1,nope - noden=kon(indexe+l) -! -! node must not belong to solid surface -! - call nident(isolidsurf,noden,nsolidsurf,idn) - if(idn.gt.0) then - if(isolidsurf(idn).eq.noden) cycle - endif - dist=dsqrt((co(1,node)-co(1,noden))**2+ - & (co(2,node)-co(2,noden))**2+ - & (co(3,node)-co(3,noden))**2) - if(dist.lt.distmin) then - distmin=dist - nodemin=noden - endif - enddo - if(nodemin.ne.0) then - neighsolidsurf(id)=nodemin - endif - enddo - else - if(lakon(i)(4:4).eq.'6') then - nope=6 - if(j.le.2) then - nnodes=3 - else - nnodes=4 - endif - else - nope=15 - if(j.le.2) then - nnodes=6 - else - nnodes=8 - endif - endif - do k=1,nnodes - node=kon(indexe+ifacew(k,j)) - ! -! node must belong to solid surface -! - call nident(isolidsurf,node,nsolidsurf,id) - if(id.le.0) then - cycle - elseif(isolidsurf(id).ne.node) then - cycle - endif -! -! check whether neighbor was already found -! - if(neighsolidsurf(id).ne.0) cycle -! - distmin=1.d30 - nodemin=0 -! - do l=1,nope - noden=kon(indexe+l) -! -! node must not belong to solid surface -! - call nident(isolidsurf,noden,nsolidsurf,idn) - if(idn.gt.0) then - if(isolidsurf(idn).eq.noden) cycle - endif - dist=dsqrt((co(1,node)-co(1,noden))**2+ - & (co(2,node)-co(2,noden))**2+ - & (co(3,node)-co(3,noden))**2) - if(dist.lt.distmin) then - distmin=dist - nodemin=noden - endif - enddo - if(nodemin.ne.0) then - neighsolidsurf(id)=nodemin - endif - enddo - endif - enddo -! -! determining the fluid elements belonging to edge nodes of -! the elements -! - inoelfree=1 - do i=1,ne - if(ipkon(i).lt.0) cycle - if(lakon(i)(1:1).ne.'F') cycle - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - nope=15 - endif - indexe=ipkon(i) - do j=1,nope - node=kon(indexe+j) - inoel(1,inoelfree)=i - inoel(2,inoelfree)=j - inoel(3,inoelfree)=iponoel(node) - iponoel(node)=inoelfree - inoelfree=inoelfree+1 - enddo - enddo -! -! sorting nelemface -! - kflag=2 - call isortic(nelemface,sideface,nface,kflag) -! -c write(*,*) 'nfreestream ',nfreestream -c do i=1,nfreestream -c write(*,*) 'nfreestream ',i,ifreestream(i) -c enddo -c write(*,*) 'nsolidsurf ',nsolidsurf -c do i=1,nsolidsurf -c write(*,*) 'nsolidsurf ',i,isolidsurf(i),neighsolidsurf(i) -c enddo -c write(*,*) 'external faces' -c do i=1,nface -c write(*,*) nelemface(i),sideface(i) -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/prediction.c calculix-ccx-2.3/ccx_2.1/src/prediction.c --- calculix-ccx-2.1/ccx_2.1/src/prediction.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/prediction.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,149 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif - - -void prediction(double *uam, int *nmethod, double *bet, double *gam, - double *dtime, - int *ithermal, int *nk, double *veold, double *accold, double *v, - int *iinc, int *idiscon, double *vold, int *nactdof, int *mi){ - - int j,k,mt=mi[1]+1; - double dextrapol,scal1,scal2; - - uam[0]=0.; - uam[1]=0.; - if(*nmethod==4){ - - scal1=0.5*(1.-2.**bet)**dtime**dtime; - scal2=(1.-*gam)**dtime; - - if(*ithermal<2){ - for(k=0;k<*nk;++k){ - for(j=0;juam[0])&&(nactdof[mt*k+j]>0)) {uam[0]=fabs(dextrapol);} - v[mt*k+j]=vold[mt*k+j]+dextrapol; - veold[mt*k+j]=veold[mt*k+j]+scal2*accold[mt*k+j]; - accold[mt*k+j]=0.; - } - } - }else if(*ithermal==2){ - for(k=0;k<*nk;++k){ - for(j=0;j100.) dextrapol=100.*dextrapol/fabs(dextrapol); - if((fabs(dextrapol)>uam[1])&&(nactdof[mt*k]>0)) {uam[1]=fabs(dextrapol);} - v[mt*k]+=dextrapol; - } - }else{ - for(k=0;k<*nk;++k){ - for(j=0;j100.) dextrapol=100.*dextrapol/fabs(dextrapol); - if(j==0){ - if((fabs(dextrapol)>uam[1])&&(nactdof[mt*k]>0)) {uam[1]=fabs(dextrapol);} - }else{ - if((fabs(dextrapol)>uam[0])&&(nactdof[mt*k+j]>0)) {uam[0]=fabs(dextrapol);} - } - v[mt*k+j]=vold[mt*k+j]+dextrapol; - veold[mt*k+j]=veold[mt*k+j]+scal2*accold[mt*k+j]; - accold[mt*k+j]=0.; - } - } - } - } - - /* for the static case: extrapolation of the previous increment - (if any within the same step) */ - - else{ - if(*iinc>1){ - if(*ithermal<2){ - for(k=0;k<*nk;++k){ - for(j=0;juam[0])&&(nactdof[mt*k+j]>0)) {uam[0]=fabs(dextrapol);} - v[mt*k+j]=vold[mt*k+j]+dextrapol; - }else{ - v[mt*k+j]=vold[mt*k+j]; - } - } - } - }else if(*ithermal==2){ - for(k=0;k<*nk;++k){ - for(j=0;j100.) dextrapol=100.*dextrapol/fabs(dextrapol); - if((fabs(dextrapol)>uam[1])&&(nactdof[mt*k]>0)) {uam[1]=fabs(dextrapol);} - v[mt*k]+=dextrapol; - } - } - }else{ - for(k=0;k<*nk;++k){ - for(j=0;j100.) dextrapol=100.*dextrapol/fabs(dextrapol); - if(j==0){ - if((fabs(dextrapol)>uam[1])&&(nactdof[mt*k+j]>0)) {uam[1]=fabs(dextrapol);} - }else{ - if((fabs(dextrapol)>uam[0])&&(nactdof[mt*k+j]>0)) {uam[0]=fabs(dextrapol);} - } - v[mt*k+j]=vold[mt*k+j]+dextrapol; - }else{ - v[mt*k+j]=vold[mt*k+j]; - } - } - } - } - } - else{ - for(k=0;k<*nk;++k){ - for(j=0;j -#include -#include -#include "CalculiX.h" - -void preiter(double *ad, double **aup, double *b, int **icolp, int **irowp, - int *neq, int *nzs, int *isolver, int *iperturb){ - - int precFlg,niter=5000000,ndim,i,j,k,ier,*icol=NULL,*irow=NULL, - *irow_save=NULL,*icol_save=NULL; - double eps=1.e-4,*u=NULL,*au=NULL; - - if(*neq==0) return; - - /* icol(i) = # subdiagonal nonzeros in column i (i=1,neq) - irow(i) = row number of entry i in au (i=1,nzs) - ad(i) = diagonal term in column i of the matrix - au(i) = subdiagonal nonzero term i; the terms are entered - column per column */ - - au=*aup; - irow=*irowp; - icol=*icolp; - - if(*iperturb>1){ - irow_save=NNEW(int,*nzs); - icol_save=NNEW(int,*neq); - for(i=0;i<*nzs;++i){ - irow_save[i]=irow[i]; - } - for(i=0;i<*neq;++i){ - icol_save[i]=icol[i]; - } - } - - if(*isolver==2) {precFlg=0;} - else {precFlg=3;} - - ndim=*neq+*nzs; - - RENEW(au,double,ndim); - RENEW(irow,int,ndim); - RENEW(icol,int,ndim); - - k=*nzs; - for(i=*neq-1;i>=0;--i){ - for(j=0;j1){ - RENEW(irow,int,*nzs); - RENEW(icol,int,*neq); - for(i=0;i<*nzs;++i){ - irow[i]=irow_save[i]; - } - for(i=0;i<*neq;++i){ - icol[i]=icol_save[i]; - } - free(irow_save);free(icol_save); - } - - *aup=au; - *irowp=irow; - *icolp=icol; - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/presgradient.f calculix-ccx-2.3/ccx_2.1/src/presgradient.f --- calculix-ccx-2.1/ccx_2.1/src/presgradient.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/presgradient.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,87 +0,0 @@ - -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine presgradient(iponoel,inoel,sa,sav,nk,dt,shockcoef, - & dtimef,ipkon,kon,lakon,vold,mi) -! -! determining measure for the pressure gradient -! -! Ref: The Finite Element Method for Fluid Dynamics, -! O.C. Zienkiewicz, R.L. Taylor & P. Nithiarasu -! 6th edition (2006) ISBN 0 7506 6322 7 -! p. 61 -! - implicit none -! - character*8 lakon(*) -! - integer iponoel(*),inoel(3,*),nk,i,j,index,indexe,nope, - & ipkon(*),kon(*),node,ielem,mi(2) -! - real*8 sa(*),sav(*),dt(*),shockcoef,dtimef,ca,sum,sumabs,pa, - & vold(0:mi(2),*) -! - ca=shockcoef*dtimef -! - do i=1,nk - if(iponoel(i).le.0) cycle - sum=0.d0 - sumabs=0.d0 - pa=vold(4,i) - index=iponoel(i) - do - ielem=inoel(1,index) - if(ipkon(ielem).lt.0) cycle - if(lakon(ielem)(1:1).ne.'F') cycle - if(lakon(ielem)(4:4).eq.'2') then - nope=20 - elseif(lakon(ielem)(4:4).eq.'8') then - nope=8 - elseif(lakon(ielem)(4:4).eq.'4') then - nope=4 - elseif(lakon(ielem)(4:5).eq.'10') then - nope=10 - elseif(lakon(ielem)(4:4).eq.'6') then - nope=6 - elseif(lakon(ielem)(4:5).eq.'15') then - nope=15 - endif - indexe=ipkon(ielem) - do j=1,nope - node=kon(indexe+j) - sum=sum+pa-vold(4,node) - sumabs=sumabs+dabs(pa-vold(4,node)) - enddo - index=inoel(3,index) - if(index.eq.0) exit - enddo - if(sumabs.lt.1.d-10) then - sum=0.d0 - sumabs=1.d0 - endif -c write(*,*) 'presgradient ',i,dabs(sum),sumabs, -c & dabs(sum)/sumabs - sa(i)=dabs(sum)*ca/(sumabs*dt(i)) - sav(3*i-2)=sa(i) - sav(3*i-1)=sa(i) - sav(3*i)=sa(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/prespooles.c calculix-ccx-2.3/ccx_2.1/src/prespooles.c --- calculix-ccx-2.1/ccx_2.1/src/prespooles.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/prespooles.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,352 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif -#ifdef PARDISO - #include "pardiso.h" -#endif - -void prespooles(double *co, int *nk, int *kon, int *ipkon, char *lakon, - int *ne, - int *nodeboun, int *ndirboun, double *xboun, int *nboun, - int *ipompc, int *nodempc, double *coefmpc, char *labmpc, - int *nmpc, - int *nodeforc, int *ndirforc,double *xforc, int *nforc, - int *nelemload, char *sideload, double *xload, - int *nload, - double *ad, double *au, double *b, int *nactdof, - int **icolp, int *jq, int **irowp, int *neq, int *nzl, - int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, - int *ilboun, - double *elcon, int *nelcon, double *rhcon, int *nrhcon, - double *alcon, int *nalcon, double *alzero, int *ielmat, - int *ielorien, int *norien, double *orab, int *ntmat_, - double *t0, double *t1, double *t1old, - int *ithermal,double *prestr, int *iprestr, - double *vold,int *iperturb, double *sti, int *nzs, - int *kode, double *adb, double *aub, - char *filab, double *eme, - int *iexpl, double *plicon, int *nplicon, double *plkcon, - int *nplkcon, - double *xstate, int *npmat_, char *matname, int *isolver, - int *mi, int *ncmat_, int *nstate_, double *cs, int *mcs, - int *nkon, double *ener, double *xbounold, - double *xforcold, double *xloadold, - char *amname, double *amta, int *namta, - int *nam, int *iamforc, int *iamload, - int *iamt1, int *iamboun, double *ttime, char *output, - char *set, int *nset, int *istartset, - int *iendset, int *ialset, int *nprint, char *prlab, - char *prset, int *nener, double *trab, - int *inotr, int *ntrans, double *fmpc, char *cbody, int *ibody, - double *xbody, int *nbody, double *xbodyold, double *tper){ - - char description[13]=" "; - - int *inum=NULL,k,*icol=NULL,*irow=NULL,ielas,icmd=0,istep=1,iinc=1, - mass[2]={0,0}, stiffness=1, buckling=0, rhsi=1, intscheme=0,*ncocon=NULL, - *nshcon=NULL,mode=-1,noddiam=-1,*ipobody=NULL,inewton=0,coriolis=0,iout, - ifreebody,*itg=NULL,ntg=0,symmetryflag=0,inputformat=0,ngraph=1, - mt=mi[1]+1; - - double *stn=NULL,*v=NULL,*een=NULL,cam[5],*xstiff=NULL,*stiini=NULL, - *f=NULL,*fn=NULL,qa[3],*fext=NULL,*epn=NULL,*xstateini=NULL, - *vini=NULL,*stx=NULL,*enern=NULL,*xbounact=NULL,*xforcact=NULL, - *xloadact=NULL,*t1act=NULL,*ampli=NULL,*xstaten=NULL,*eei=NULL, - *enerini=NULL,*cocon=NULL,*shcon=NULL,*physcon=NULL,*qfx=NULL, - *qfn=NULL,sigma=0.,*cgr=NULL,*xbodyact=NULL,*vr=NULL,*vi=NULL, - *stnr=NULL,*stni=NULL,*vmax=NULL,*stnmax=NULL; - - int *ipneigh=NULL,*neigh=NULL; - -#ifdef SGI - int token; -#endif - - /* dummy arguments for the results call */ - - double *veold=NULL,*accold=NULL,bet,gam,dtime=1.,time=1.,reltime=1.; - - icol=*icolp; - irow=*irowp; - - /* allocating fields for the actual external loading */ - - xbounact=NNEW(double,*nboun); - for(k=0;k<*nboun;++k){xbounact[k]=xbounold[k];} - xforcact=NNEW(double,*nforc); - xloadact=NNEW(double,2**nload); - xbodyact=NNEW(double,7**nbody); - /* copying the rotation axis and/or acceleration vector */ - for(k=0;k<7**nbody;k++){xbodyact[k]=xbody[k];} - if(*ithermal==1){ - t1act=NNEW(double,*nk); - for(k=0;k<*nk;++k){t1act[k]=t1old[k];} - } - - /* assigning the body forces to the elements */ - - if(*nbody>0){ - ifreebody=*ne+1; - ipobody=NNEW(int,2*ifreebody**nbody); - for(k=1;k<=*nbody;k++){ - FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, - iendset,ialset,&inewton,nset,&ifreebody,&k)); - RENEW(ipobody,int,2*(*ne+ifreebody)); - } - RENEW(ipobody,int,2*(ifreebody-1)); - } - - /* allocating a field for the instantaneous amplitude */ - - ampli=NNEW(double,*nam); - - FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc,xloadold,xload, - xloadact,iamload,nload,ibody,xbody,nbody,xbodyold,xbodyact, - t1old,t1,t1act,iamt1,nk,amta, - namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal,nmethod, - xbounold,xboun,xbounact,iamboun,nboun, - nodeboun,ndirboun,nodeforc,ndirforc,&istep,&iinc, - co,vold,itg,&ntg,amname,ikboun,ilboun,nelemload,sideload,mi)); - *ttime=*ttime+*tper; - - /* determining the internal forces and the stiffness coefficients */ - - f=NNEW(double,*neq); - - /* allocating a field for the stiffness matrix */ - - xstiff=NNEW(double,27*mi[0]**ne); - - iout=-1; - v=NNEW(double,mt**nk); -// memset(&vold[0],0.,sizeof(double)*mt**nk); - fn=NNEW(double,mt**nk); - stx=NNEW(double,6*mi[0]**ne); - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1act,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun, - ndirboun,xbounact,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq,veold,accold, - &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, - &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, - sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, - fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - free(v);free(fn);free(stx); - iout=1; - - /* determining the system matrix and the external forces */ - - ad=NNEW(double,*neq); - au=NNEW(double,*nzs); - fext=NNEW(double,*neq); - - FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xbounact,nboun, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, - nforc,nelemload,sideload,xloadact,nload,xbodyact,ipobody, - nbody,cgr,ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, - ikmpc,ilmpc,ikboun,ilboun, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_, - t0,t1act,ithermal,prestr,iprestr,vold,iperturb,sti, - nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, - xstiff,npmat_,&dtime,matname,mi, - ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme,physcon, - shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc,&coriolis, - ibody,xloadold,&reltime,veold)); - - /* determining the right hand side */ - - b=NNEW(double,*neq); - for(k=0;k<*neq;++k){ - b[k]=fext[k]-f[k]; - } - free(fext);free(f); - - if(*nmethod!=0){ - - if(*isolver==0){ -#ifdef SPOOLES - spooles(ad,au,adb,aub,&sigma,b,icol,irow,neq,nzs,&symmetryflag, - &inputformat); -#else - printf("*ERROR in prespooles: the SPOOLES library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if((*isolver==2)||(*isolver==3)){ - preiter(ad,&au,b,&icol,&irow,neq,nzs,isolver,iperturb); - } - else if(*isolver==4){ -#ifdef SGI - token=1; - sgi_main(ad,au,adb,aub,&sigma,b,icol,irow,neq,nzs,token); -#else - printf("*ERROR in prespooles: the SGI library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau(ad,&au,adb,aub,&sigma,b,icol,&irow,neq,nzs); -#else - printf("*ERROR in prespooles: the TAUCS library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_main(ad,au,adb,aub,&sigma,b,icol,irow,neq,nzs); -#else - printf("*ERROR in prespooles: the PARDISO library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - - free(ad);free(au); - - /* calculating the displacements and the stresses and storing */ - /* the results in frd format for each valid eigenmode */ - - v=NNEW(double,mt**nk); - fn=NNEW(double,mt**nk); - stn=NNEW(double,6**nk); - inum=NNEW(int,*nk); - stx=NNEW(double,6*mi[0]**ne); - - if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); - if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); - - eei=NNEW(double,6*mi[0]**ne); - if(*nener==1){ - stiini=NNEW(double,6*mi[0]**ne); - enerini=NNEW(double,mi[0]**ne);} - - FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_,t0,t1act,ithermal, - prestr,iprestr,filab,eme,een,iperturb, - f,fn,nactdof,&iout,qa,vold,b,nodeboun,ndirboun,xbounact,nboun,ipompc, - nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq,veold,accold,&bet, - &gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, - xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, - ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, - xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - nelemload,nload,ikmpc,ilmpc,&istep,&iinc)); - - free(eei); - if(*nener==1){ - free(stiini);free(enerini);} - - memcpy(&vold[0],&v[0],sizeof(double)*mt**nk); - memcpy(&sti[0],&stx[0],sizeof(double)*6*mi[0]**ne); -/* for(k=0;k0){ - frdcyc(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, - fn,ttime,epn,ielmat,matname,cs,mcs,nkon,enern,xstaten, - nstate_,&istep,&iinc,iperturb,ener,mi,output,ithermal, - qfn,ialset,istartset,iendset,trab,inotr,ntrans,orab, - ielorien,norien,sti,veold,&noddiam,set,nset); - } - else{ - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, - fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_,&istep,&iinc, - iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, - set,nset,istartset,iendset,ialset)); - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - } - - free(v);free(stn);free(inum); - free(b);free(stx);free(fn); - - if(strcmp1(&filab[261],"E ")==0) free(een); - if(strcmp1(&filab[522],"ENER")==0) free(enern); - - } - else { - - /* error occurred in mafill: storing the geometry in frd format */ - - ++*kode; - inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, - fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_,&istep,&iinc, - iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, - set,nset,istartset,iendset,ialset)); - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - free(inum);FORTRAN(stop,()); - - } - - /* updating the loading at the end of the step; - important in case the amplitude at the end of the step - is not equal to one */ - - for(k=0;k<*nboun;++k){xbounold[k]=xbounact[k];} - for(k=0;k<*nforc;++k){xforcold[k]=xforcact[k];} - for(k=0;k<2**nload;++k){xloadold[k]=xloadact[k];} - for(k=0;k<7**nbody;k=k+7){xbodyold[k]=xbodyact[k];} - if(*ithermal==1){ - for(k=0;k<*nk;++k){t1old[k]=t1act[k];} - for(k=0;k<*nk;++k){vold[mt*k]=t1act[k];} - } - - free(xbounact);free(xforcact);free(xloadact);free(t1act);free(ampli); - free(xbodyact);if(*nbody>0) free(ipobody);free(xstiff); - - *icolp=icol; - *irowp=irow; - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/pretensionsections.f calculix-ccx-2.3/ccx_2.1/src/pretensionsections.f --- calculix-ccx-2.1/ccx_2.1/src/pretensionsections.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pretensionsections.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,720 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine pretensionsections(inpc,textpart,ipompc,nodempc, - & coefmpc,nmpc,nmpc_,mpcfree,nk,ikmpc,ilmpc, - & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc,lakon, - & kon,ipkon,set,nset,istartset,iendset,ialset,co) -! -! reading the input deck: *PRE-TENSION SECTION -! - implicit none -! - logical twod -! - character*1 inpc(*) - character*8 lakon(*) - character*20 labmpc(*) - character*81 surface,set(*) - character*132 textpart(16) -! - integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,istep,istat, - & n,i,j,key,nk,node,ifacequad(3,4),ifacetria(3,3), - & mpcfreeold,ikmpc(*),ilmpc(*),id,idof,iline,ipol,inl, - & ipoinp(2,*),inp(3,*),ipoinpc(0:*),irefnode,lathyp(3,6),inum, - & jn,jt,jd,iside,nelem,jface,nnodelem,nface,nodef(8),nodel(8), - & ifaceq(8,6),ifacet(6,4),ifacew1(4,5),ifacew2(8,5),indexpret, - & k,ipos,nkold,nope,m,kon(*),ipkon(*),indexe,iset,nset,idir, - & istartset(*),iendset(*),ialset(*),index1 -! - real*8 coefmpc(*),xn(3),xt(3),xd(3),dd,co(3,*) -! -! latin hypercube positions in a 3 x 3 matrix -! - data lathyp /1,2,3,1,3,2,2,1,3,2,3,1,3,1,2,3,2,1/ -! -! nodes per face for hex elements -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ -! -! nodes per face for tet elements -! - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ -! -! nodes per face for linear wedge elements -! - data ifacew1 /1,3,2,0, - & 4,5,6,0, - & 1,2,5,4, - & 2,3,6,5, - & 4,6,3,1/ -! -! nodes per face for quadratic wedge elements -! - data ifacew2 /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! -! nodes per face for quad elements -! - data ifacequad /1,2,5, - & 2,3,6, - & 3,4,7, - & 4,1,8/ -! -! nodes per face for tria elements -! - data ifacetria /1,2,4, - & 2,3,5, - & 3,1,6/ -! - if(istep.gt.0) then - write(*,*) '*ERROR in pretensionsections.f: *EQUATION should' - write(*,*) ' be placed before all step definitions' - stop - endif -! - do i=2,n - if(textpart(i)(1:8).eq.'SURFACE=') then - surface=textpart(i)(9:88) - ipos=index(surface,' ') - surface(ipos:ipos)='T' - elseif(textpart(i)(1:5).eq.'NODE=') then - read(textpart(i)(6:15),'(i10)',iostat=istat) irefnode - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if((irefnode.gt.nk).or.(irefnode.le.0)) then - write(*,*) '*ERROR in pretensionsections.f:' - write(*,*) ' node ',irefnode,' is not defined' - stop - endif - endif - enddo -! -! checking whether the surface exists and is an element face -! surface -! - iset=0 - do i=1,nset - if(set(i).eq.surface) then - iset=i - exit - endif - enddo - if(iset.eq.0) then - write(*,*) '*ERROR in pretensionsections: nonexistent surface' - write(*,*) ' or surface consists of nodes' - call inputerror(inpc,ipoinpc,iline) - endif -! -! reading the normal vector and normalizing -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - do i=1,3 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) xn(i) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) - do i=1,3 - xn(i)=xn(i)/dd - enddo -! -! finding a unit vector xt perpendicular to the normal vector -! using a unit vector in x or in y -! - if(dabs(xn(1)).lt.0.95d0) then - xt(1)=1.d0-xn(1)*xn(1) - xt(2)=-xn(1)*xn(2) - xt(3)=-xn(1)*xn(3) - else - xt(1)=-xn(2)*xn(1) - xt(2)=1.d0-xn(2)*xn(2) - xt(3)=-xn(2)*xn(3) - endif - dd=dsqrt(xt(1)*xt(1)+xt(2)*xt(2)+xt(3)*xt(3)) - do i=1,3 - xt(i)=xt(i)/dd - enddo -! -! xd=xn x xt -! - xd(1)=xn(2)*xt(3)-xn(3)*xt(2) - xd(2)=xn(3)*xt(1)-xn(1)*xt(3) - xd(3)=xn(1)*xt(2)-xn(2)*xt(1) -! -! generating a Latin hypercube -! checking which DOF's of xn, xt and xd are nonzero -! - do inum=1,6 - if((dabs(xn(lathyp(1,inum))).gt.1.d-3).and. - & (dabs(xt(lathyp(2,inum))).gt.1.d-3).and. - & (dabs(xd(lathyp(3,inum))).gt.1.d-3)) exit - enddo - jn=lathyp(1,inum) - jt=lathyp(2,inum) - jd=lathyp(3,inum) -! -! generating the MPCs -! - indexpret=0 - nkold=nk - m=iendset(iset)-istartset(iset)+1 -! -! check whether any MPC was defined in the nodes belonging to -! the pre-tension surface -! -! loop over all element faces belonging to the surface -! - do k=1,m - iside=ialset(istartset(iset)+k-1) - nelem=int(iside/10.d0) - indexe=ipkon(nelem) - jface=iside-10*nelem -! -! nnodelem: #nodes in the face -! the nodes are stored in nodef(*) -! - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(3:4).eq.'D8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - nope=10 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - nope=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(3:4).eq.'D6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - elseif((lakon(nelem)(2:2).eq.'8').or. - & (lakon(nelem)(4:4).eq.'8')) then - nnodelem=3 - nface=4 - nope=8 - if(lakon(nelem)(4:4).eq.'8') then - jface=jface-2 - endif - elseif((lakon(nelem)(2:2).eq.'6').or. - & (lakon(nelem)(4:4).eq.'6')) then - nnodelem=3 - nface=3 - if(lakon(nelem)(4:4).eq.'6') then - jface=jface-2 - endif - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.3) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacetria(i,jface)) - enddo - elseif(nface.eq.4) then - if(nope.eq.8) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacequad(i,jface)) - enddo - else - do i=1,nnodelem - nodef(i)=kon(indexe+ifacet(i,jface)) - enddo - endif - elseif(nface.eq.5) then - if(nope.eq.6) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacew1(i,jface)) - enddo - elseif(nope.eq.15) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacew2(i,jface)) - enddo - endif - elseif(nface.eq.6) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifaceq(i,jface)) - enddo - endif -! -! loop over the nodes belonging to the face -! - do i=1,nnodelem - node=nodef(i) -! - idof=8*(node-1)+jt - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then -! -! MPC was defined in node: error -! - write(*,*) '*ERROR in pretensionsections:' - write(*,*) ' a non-pretension MPC is defined' - write(*,*) ' in node ',node,'.' - write(*,*) ' This is not allowed' - stop - endif - endif - enddo - enddo -! -! loop over all element faces belonging to the surface -! - do k=1,m - twod=.false. - iside=ialset(istartset(iset)+k-1) - nelem=int(iside/10.d0) - indexe=ipkon(nelem) - jface=iside-10*nelem -! -! nnodelem: #nodes in the face -! the nodes are stored in nodef(*) -! - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(3:4).eq.'D8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - nope=10 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - nope=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(3:4).eq.'D6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - elseif((lakon(nelem)(2:2).eq.'8').or. - & (lakon(nelem)(4:4).eq.'8')) then - nnodelem=3 - nface=4 - nope=8 - if(lakon(nelem)(4:4).eq.'8') then - twod=.true. - jface=jface-2 - endif - elseif((lakon(nelem)(2:2).eq.'6').or. - & (lakon(nelem)(4:4).eq.'6')) then - nnodelem=3 - nface=3 - if(lakon(nelem)(4:4).eq.'6') then - twod=.true. - jface=jface-2 - endif - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.3) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacetria(i,jface)) - nodel(i)=ifacetria(i,jface) - enddo - elseif(nface.eq.4) then - if(nope.eq.8) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacequad(i,jface)) - nodel(i)=ifacequad(i,jface) - enddo - else - do i=1,nnodelem - nodef(i)=kon(indexe+ifacet(i,jface)) - nodel(i)=ifacet(i,jface) - enddo - endif - elseif(nface.eq.5) then - if(nope.eq.6) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacew1(i,jface)) - nodel(i)=ifacew1(i,jface) - enddo - elseif(nope.eq.15) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifacew2(i,jface)) - nodel(i)=ifacew2(i,jface) - enddo - endif - elseif(nface.eq.6) then - do i=1,nnodelem - nodef(i)=kon(indexe+ifaceq(i,jface)) - nodel(i)=ifaceq(i,jface) - enddo - endif -! -! loop over the nodes belonging to the face -! - do i=1,nnodelem - node=nodef(i) -! - idof=8*(node-1)+jt - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then -! -! node was already treated: replacing the node -! by the partner node -! -c kon(indexe+nodel(i))=nodempc(1,nodempc(3, -c & nodempc(3,nodempc(3,ipompc(ilmpc(id)))))) - index1=ipompc(ilmpc(id)) - do - if(nodempc(1,index1).ne.node) then - kon(indexe+nodel(i))=nodempc(1,index1) - exit - else - index1=nodempc(3,index1) - endif - enddo -! - cycle - endif - endif -! -! generating a partner node -! - nk=nk+1 -! -! coordinates for the new node -! - do j=1,3 - co(j,nk)=co(j,node) - enddo -! -! updating the topology -! - kon(indexe+nodel(i))=nk -! -! first MPC perpendicular to the normal direction -! - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in equations: increase nmpc_' - stop - endif - ipompc(nmpc)=mpcfree - labmpc(nmpc)=' ' -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - idir=jt - if(dabs(xt(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xt(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xt(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xt(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xt(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xt(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=jt - if(dabs(xt(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=jt - coefmpc(mpcfree)=-xt(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xt(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-xt(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xt(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-xt(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif - nodempc(3,mpcfreeold)=0 -! -! second MPC perpendicular to the normal direction -! - if(.not.twod) then - idof=8*(node-1)+jd - call nident(ikmpc,idof,nmpc,id) -! - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in equations: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - idir=jd - if(dabs(xd(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xd(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xd(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xd(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xd(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xd(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=jd - if(dabs(xd(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-xd(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xd(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-xd(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xd(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-xd(idir) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - endif - nodempc(3,mpcfreeold)=0 - endif -! -! MPC in normal direction -! -! check whether initialized -! - if(indexpret.eq.0) then - idof=8*(node-1)+jn - call nident(ikmpc,idof,nmpc,id) -! - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in equations: increase nmpc_' - stop - endif - labmpc(nmpc)=' ' - ipompc(nmpc)=mpcfree -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - else - nodempc(3,indexpret)=mpcfree - endif -! - idir=jn - if(dabs(xn(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xn(idir) - indexpret=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xn(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xn(idir) - indexpret=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xn(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=xn(idir) - indexpret=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=jn - if(dabs(xn(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-xn(idir) - indexpret=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xn(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-xn(idir) - indexpret=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - idir=idir+1 - if(idir.eq.4) idir=1 - if(dabs(xn(idir)).gt.1.d-10) then - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=idir - coefmpc(mpcfree)=-xn(idir) - indexpret=mpcfree - mpcfree=nodempc(3,mpcfree) - endif -! - enddo - enddo -! - nodempc(3,indexpret)=mpcfree - nodempc(1,mpcfree)=irefnode - nodempc(2,mpcfree)=1 - coefmpc(mpcfree)=1.d0*(nk-nkold) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! -c do i=1,nmpc -c call writempc(ipompc,nodempc,coefmpc,labmpc,i) -c enddo -c do i=1,nmpc -c write(*,*) i,ikmpc(i),ilmpc(i) -c enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/printoutelem.f calculix-ccx-2.3/ccx_2.1/src/printoutelem.f --- calculix-ccx-2.1/ccx_2.1/src/printoutelem.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/printoutelem.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,189 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine printoutelem(prlab,ipkon,lakon,kon,co, - & ener,mi,ii,nelem,energytot,volumetot,enerkintot,nkin,ne, - & stx,nodes) -! -! stores whole element results for element "nelem" in the .dat file -! - implicit none -! - character*6 prlab(*) - character*8 lakon(*) -! - integer ipkon(*),nelem,ii,kon(*),mi(2),nope,indexe,j,k,konl(20), - & mint3d,jj,nener,iflag,nkin,ne,nodes -! - real*8 ener(mi(1),*),energytot,volumetot,energy,volume,co(3,*), - & xl(3,20),xi,et,ze,xsj,shp(4,20),weight,enerkintot,enerkin, - & stx(6,mi(1),*) -! - include "gauss.f" -! - data iflag /2/ -! - if(ipkon(nelem).lt.0) return -! - if((prlab(ii)(1:4).eq.'ELSE').or.(prlab(ii)(1:4).eq.'CELS')) then - nener=1 - else - nener=0 - endif -! - indexe=ipkon(nelem) -! - if(lakon(nelem)(4:4).eq.'2') then - nope=20 - elseif(lakon(nelem)(4:4).eq.'8') then - nope=8 - elseif(lakon(nelem)(4:5).eq.'10') then - nope=10 - elseif(lakon(nelem)(4:4).eq.'4') then - nope=4 - elseif(lakon(nelem)(4:5).eq.'15') then - nope=15 - elseif(lakon(nelem)(4:5).eq.'6') then - nope=6 - else - nope=0 - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - do k=1,3 - xl(k,j)=co(k,konl(j)) - enddo - enddo -! - energy=0.d0 - volume=0.d0 - enerkin=0.d0 -! - if(lakon(nelem)(4:5).eq.'8R') then - mint3d=1 - elseif((lakon(nelem)(4:4).eq.'8').or. - & (lakon(nelem)(4:6).eq.'20R')) then - mint3d=8 - elseif(lakon(nelem)(4:4).eq.'2') then - mint3d=27 - elseif(lakon(nelem)(4:5).eq.'10') then - mint3d=4 - elseif(lakon(nelem)(4:4).eq.'4') then - mint3d=1 - elseif(lakon(nelem)(4:5).eq.'15') then - mint3d=9 - elseif(lakon(nelem)(4:5).eq.'6') then - mint3d=2 - else - if(nener.eq.1)then - energy=ener(1,nelem) - endif - mint3d=0 - endif -! - do jj=1,mint3d - if(lakon(nelem)(4:5).eq.'8R') then - xi=gauss3d1(1,jj) - et=gauss3d1(2,jj) - ze=gauss3d1(3,jj) - weight=weight3d1(jj) - elseif((lakon(nelem)(4:4).eq.'8').or. - & (lakon(nelem)(4:6).eq.'20R')) - & then - xi=gauss3d2(1,jj) - et=gauss3d2(2,jj) - ze=gauss3d2(3,jj) - weight=weight3d2(jj) - elseif(lakon(nelem)(4:4).eq.'2') then - xi=gauss3d3(1,jj) - et=gauss3d3(2,jj) - ze=gauss3d3(3,jj) - weight=weight3d3(jj) - elseif(lakon(nelem)(4:5).eq.'10') then - xi=gauss3d5(1,jj) - et=gauss3d5(2,jj) - ze=gauss3d5(3,jj) - weight=weight3d5(jj) - elseif(lakon(nelem)(4:4).eq.'4') then - xi=gauss3d4(1,jj) - et=gauss3d4(2,jj) - ze=gauss3d4(3,jj) - weight=weight3d4(jj) - elseif(lakon(nelem)(4:5).eq.'15') then - xi=gauss3d8(1,jj) - et=gauss3d8(2,jj) - ze=gauss3d8(3,jj) - weight=weight3d8(jj) - else - xi=gauss3d7(1,jj) - et=gauss3d7(2,jj) - ze=gauss3d7(3,jj) - weight=weight3d7(jj) - endif -! - if(nope.eq.20) then - call shape20h(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.8) then - call shape8h(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.10) then - call shape10tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.4) then - call shape4tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.15) then - call shape15w(xi,et,ze,xl,xsj,shp,iflag) - else - call shape6w(xi,et,ze,xl,xsj,shp,iflag) - endif -! - if(nener.eq.1) energy=energy+weight*xsj*ener(jj,nelem) - if(nkin.eq.1) enerkin=enerkin+weight*xsj*ener(jj,nelem+ne) - volume=volume+weight*xsj - enddo -! - volumetot=volumetot+volume - if(nener.eq.1) energytot=energytot+energy - if(nkin.eq.1) enerkintot=enerkintot+enerkin -! -! writing to file -! - if((prlab(ii)(1:5).eq.'ELSE ').or. - & (prlab(ii)(1:5).eq.'ELSET')) then - write(5,'(i6,1p,1x,e11.4)') nelem,energy - elseif((prlab(ii)(1:5).eq.'CELS ').or. - & (prlab(ii)(1:5).eq.'CELST')) then - write(5,'(i6,1p,1x,e11.4)') nodes,energy - elseif((prlab(ii)(1:5).eq.'CDIS ').or. - & (prlab(ii)(1:5).eq.'CDIST')) then - write(5,'(i6,1p,1x,e11.4,1p,1x,e11.4,1p,1x,e11.4)') nodes, - & stx(1,1,nelem),stx(2,1,nelem),stx(3,1,nelem) - elseif((prlab(ii)(1:5).eq.'CSTR ').or. - & (prlab(ii)(1:5).eq.'CSTRT')) then - write(5,'(i6,1p,1x,e11.4,1p,1x,e11.4,1p,1x,e11.4)') nodes, - & stx(4,1,nelem),stx(5,1,nelem),stx(6,1,nelem) - elseif((prlab(ii)(1:5).eq.'EVOL ').or. - & (prlab(ii)(1:5).eq.'EVOLT')) then - write(5,'(i6,1p,1x,e11.4)') nelem,volume - elseif((prlab(ii)(1:5).eq.'ELKE ').or. - & (prlab(ii)(1:5).eq.'ELKET')) then - write(5,'(i6,1p,1x,e11.4)') nelem,enerkin - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/printout.f calculix-ccx-2.3/ccx_2.1/src/printout.f --- calculix-ccx-2.1/ccx_2.1/src/printout.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/printout.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,437 +0,0 @@ - -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine printout(set,nset,istartset,iendset,ialset,nprint, - & prlab,prset,v,t1,fn,ipkon,lakon,stx,eme,xstate,ener, - & mi,nstate_,ithermal,co,kon,qfx,ttime,trab,inotr,ntrans, - & orab,ielorien,norien,nk,ne,inum,filab,vold,ikin) -! -! stores results in the .dat file -! - implicit none -! - logical force -! - character*1 cflag - character*6 prlab(*) - character*8 lakon(*) - character*80 noset,elset - character*81 set(*),prset(*) - character*87 filab(*) -! - integer nset,istartset(*),iendset(*),ialset(*),nprint,ipkon(*), - & mi(2),nstate_,ii,jj,iset,l,lb,limit,node,ipos,ithermal, - & nelem,kon(*),inotr(2,*),ntrans,ielorien(*),norien,nk,ne, - & inum(*),nfield,ikin,nodes,ne0,nope,mt -! - real*8 v(0:mi(2),*),t1(*),fn(0:mi(2),*),stx(6,mi(1),*), - & eme(6,mi(1),*),xstate(nstate_,mi(1),*),ener(mi(1),*),energytot, - & volumetot,co(3,*),qfx(3,mi(1),*),rftot(0:3),ttime, - & trab(7,*),orab(7,*),vold(0:mi(2),*),enerkintot -! - mt=mi(2)+1 -! -! interpolation in the original nodes of 1d and 2d elements -! - do ii=1,nprint - if((prlab(ii)(1:4).eq.'U ').or. - & ((prlab(ii)(1:4).eq.'NT ').and.(ithermal.gt.1))) then - if(filab(1)(5:5).ne.' ') then - nfield=mt - cflag=' ' - force=.false. - call map3dto1d2d(v,ipkon,inum,kon,lakon,nfield,nk, - & ne,cflag,co,vold,force,mi) - endif - exit - endif - enddo - do ii=1,nprint - if((prlab(ii)(1:4).eq.'NT ').and.(ithermal.le.1)) then - if(filab(2)(5:5).ne.' ') then - nfield=1 - cflag=' ' - force=.false. - call map3dto1d2d(t1,ipkon,inum,kon,lakon,nfield,nk, - & ne,cflag,co,vold,force,mi) - endif - exit - endif - enddo - do ii=1,nprint - if(prlab(ii)(1:2).eq.'RF') then - if(filab(1)(5:5).ne.' ') then - nfield=mt - cflag=' ' - force=.true. - call map3dto1d2d(fn,ipkon,inum,kon,lakon,nfield,nk, - & ne,cflag,co,vold,force,mi) - endif - exit - endif - enddo -! - do ii=1,nprint -! -! nodal values -! - if((prlab(ii)(1:4).eq.'U ').or.(prlab(ii)(1:4).eq.'NT ').or. - & (prlab(ii)(1:4).eq.'RF ').or.(prlab(ii)(1:4).eq.'RFL ').or. - & (prlab(ii)(1:4).eq.'PS ').or.(prlab(ii)(1:4).eq.'PT ').or. - & (prlab(ii)(1:4).eq.'MF ').or.(prlab(ii)(1:4).eq.'V ')) - & then -! - ipos=index(prset(ii),' ') - noset=' ' - noset(1:ipos-1)=prset(ii)(1:ipos-1) -! -! printing the header -! - if(prlab(ii)(1:4).eq.'U ') then - write(5,*) - write(5,100) noset(1:ipos-2),ttime - 100 format(' displacements (vx,vy,vz) for set ',A, - & ' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'NT ') then - write(5,*) - write(5,101) noset(1:ipos-2),ttime - 101 format(' temperatures for set ',A,' and time ',e14.7) - write(5,*) - elseif((prlab(ii)(1:5).eq.'RF ').or. - & (prlab(ii)(1:5).eq.'RF T')) then - write(5,*) - write(5,102) noset(1:ipos-2),ttime - 102 format(' forces (fx,fy,fz) for set ',A, - & ' and time ',e14.7) - write(5,*) - elseif((prlab(ii)(1:5).eq.'RFL ').or. - & (prlab(ii)(1:5).eq.'RFL T')) then - write(5,*) - write(5,103) noset(1:ipos-2),ttime - 103 format(' heat generation for set ',A,' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'PS ') then - write(5,*) - write(5,115) noset(1:ipos-2),ttime - 115 format(' static pressures for set ',A,' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'PT ') then - write(5,*) - write(5,117) noset(1:ipos-2),ttime - 117 format(' total pressures for set ',A,' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'MF ') then - write(5,*) - write(5,118) noset(1:ipos-2),ttime - 118 format(' mass flows for set ',A,' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'V ') then - write(5,*) - write(5,119) noset(1:ipos-2),ttime - 119 format(' velocities (vx,vy,vz) for set ',A, - & ' and time ',e14.7) - write(5,*) - endif -! -! printing the data -! - do iset=1,nset - if(set(iset).eq.prset(ii)) exit - enddo - do jj=0,3 - rftot(jj)=0.d0 - enddo - do jj=istartset(iset),iendset(iset) - if(ialset(jj).lt.0) cycle - if(jj.eq.iendset(iset)) then - node=ialset(jj) - call printoutnode(prlab,v,t1,fn,ithermal,ii,node, - & rftot,trab,inotr,ntrans,co,mi) - elseif(ialset(jj+1).gt.0) then - node=ialset(jj) - call printoutnode(prlab,v,t1,fn,ithermal,ii,node, - & rftot,trab,inotr,ntrans,co,mi) - else - do node=ialset(jj-1)-ialset(jj+1),ialset(jj), - & -ialset(jj+1) - call printoutnode(prlab,v,t1,fn,ithermal,ii,node, - & rftot,trab,inotr,ntrans,co,mi) - enddo - endif - enddo -! -! writing total values to file -! - if((prlab(ii)(1:5).eq.'RF O').or. - & (prlab(ii)(1:5).eq.'RF T')) then - write(5,*) - write(5,104) noset(1:ipos-2),ttime - 104 format(' total force (fx,fy,fz) for set ',A, - & ' and time ',e14.7) - write(5,*) - write(5,'(6x,1p,3(1x,e11.4))') rftot(1),rftot(2),rftot(3) - elseif((prlab(ii)(1:5).eq.'RFL O').or. - & (prlab(ii)(1:5).eq.'RFL T')) then - write(5,*) - write(5,105)noset(1:ipos-2),ttime - 105 format(' total heat generation for set ',A, - & ' and time ',e14.7) - write(5,*) - write(5,'(6x,1p,1x,e11.4)') rftot(0) - endif -! -! integration point values -! - elseif((prlab(ii)(1:4).eq.'S ').or. - & (prlab(ii)(1:4).eq.'E ').or. - & (prlab(ii)(1:4).eq.'PEEQ').or. - & (prlab(ii)(1:4).eq.'ENER').or. - & (prlab(ii)(1:4).eq.'SDV ').or. - & (prlab(ii)(1:4).eq.'HFL ')) then -! - ipos=index(prset(ii),' ') - elset=' ' - elset(1:ipos-1)=prset(ii)(1:ipos-1) -! - limit=1 -! - do l=1,limit -! -! printing the header -! - if(prlab(ii)(1:4).eq.'S ') then - write(5,*) - write(5,106) elset(1:ipos-2),ttime - 106 format(' stresses (elem, integ.pnt.,sxx,syy,szz,sxy,sx - &z,syz) for set ',A,' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'E ') then - write(5,*) - write(5,107) elset(1:ipos-2),ttime - 107 format(' strains (elem, integ.pnt.,exx,eyy,ezz,exy,exz - &,eyz) forset ',A,' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'PEEQ') then - write(5,*) - write(5,108) elset(1:ipos-2),ttime - 108 format(' equivalent plastic strain (elem, integ.pnt.,p - &e)for set ',A,' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'ENER') then - write(5,*) - write(5,109) elset(1:ipos-2),ttime - 109 format(' internal energy density (elem, integ.pnt.,energy) for - &set ',A,' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'SDV ') then - write(5,*) - write(5,111) elset(1:ipos-2),ttime - 111 format - & (' internal state variables (elem, integ.pnt.,values) f - &or set ',A,' and time ',e14.7) - write(5,*) - elseif(prlab(ii)(1:4).eq.'HFL ') then - write(5,*) - write(5,112) elset(1:ipos-2),ttime - 112 format(' heat flux (elem, integ.pnt.,qx,qy,qz) for set - & ',A,' and time ',e14.7) - write(5,*) - endif -! -! printing the data -! - do iset=1,nset - if(set(iset).eq.prset(ii)) exit - enddo - do jj=istartset(iset),iendset(iset) - if(ialset(jj).lt.0) cycle - if(jj.eq.iendset(iset)) then - nelem=ialset(jj) - call printoutint(prlab,ipkon,lakon,stx,eme,xstate, - & ener,mi(1),nstate_,l,lb,ii,nelem,qfx, - & orab,ielorien,norien,co,kon) - elseif(ialset(jj+1).gt.0) then - nelem=ialset(jj) - call printoutint(prlab,ipkon,lakon,stx,eme,xstate, - & ener,mi(1),nstate_,l,lb,ii,nelem,qfx,orab, - & ielorien,norien,co,kon) - else - do nelem=ialset(jj-1)-ialset(jj+1),ialset(jj), - & -ialset(jj+1) - call printoutint(prlab,ipkon,lakon,stx,eme, - & xstate,ener,mi(1),nstate_,l,lb,ii,nelem, - & qfx,orab,ielorien,norien,co,kon) - enddo - endif - enddo -! - enddo -! -! whole element values -! - elseif((prlab(ii)(1:4).eq.'ELSE').or. - & (prlab(ii)(1:4).eq.'ELKE').or. - & (prlab(ii)(1:4).eq.'EVOL').or. - & (prlab(ii)(1:4).eq.'CSTR').or. - & (prlab(ii)(1:4).eq.'CDIS').or. - & (prlab(ii)(1:4).eq.'CELS')) then -! - ipos=index(prset(ii),' ') - elset=' ' - elset(1:ipos-1)=prset(ii)(1:ipos-1) -! -! printing the header -! - if((prlab(ii)(1:5).eq.'ELSE ').or. - & (prlab(ii)(1:5).eq.'ELSET')) then - write(5,*) - write(5,113) elset(1:ipos-2),ttime - 113 format(' internal energy (element, energy) for set ',A, - & ' and time ',e14.7) - write(5,*) - elseif((prlab(ii)(1:5).eq.'ELKE ').or. - & (prlab(ii)(1:5).eq.'ELKET')) then - write(5,*) - write(5,110) elset(1:ipos-2),ttime - 110 format(' kinetic energy (elem, energy) for set ' - & ,A,' and time ',e14.7) - write(5,*) - elseif((prlab(ii)(1:5).eq.'EVOL ').or. - & (prlab(ii)(1:5).eq.'EVOLT')) then - write(5,*) - write(5,114) elset(1:ipos-2),ttime - 114 format(' volume (element, volume) for set ',A, - & ' and time ',e14.7) - write(5,*) - elseif((prlab(ii)(1:5).eq.'CSTR ').or. - & (prlab(ii)(1:5).eq.'CSTRT')) then - write(5,*) - write(5,122) ttime - 122 format(' contact stress (slave node,press,' - & 'tang1,tang2) for all contact elements and time', - & e14.7) - write(5,*) - elseif((prlab(ii)(1:5).eq.'CDIS ').or. - & (prlab(ii)(1:5).eq.'CDIST')) then - write(5,*) - write(5,123) ttime - 123 format(' relative contact displacement (slave node,' - & 'normal,tang1,tang2) for all contact elements and ' - & 'time',e14.7) - write(5,*) - elseif((prlab(ii)(1:5).eq.'CELS ').or. - & (prlab(ii)(1:5).eq.'CELST')) then - write(5,*) - write(5,124) ttime - 124 format(' contact print energy (slave node,energy) for' - & 'all contact elements and time',e14.7) - write(5,*) - endif -! -! printing the data -! - - volumetot=0.d0 - energytot=0.d0 - enerkintot=0.d0 - - if ((prlab(ii)(1:4).eq.'CSTR').or. - & (prlab(ii)(1:4).eq.'CDIS').or. - & (prlab(ii)(1:4).eq.'CELS')) then -! - do jj=ne,1,-1 - if((lakon(jj)(2:2).ne.'S').or. - & (lakon(jj)(7:7).ne.'C')) then - ne0=jj+1 - exit - endif - enddo - do nelem=ne0,ne - read(lakon(nelem)(8:8),'(i1)') nope - nodes=kon(ipkon(nelem)+nope) - call printoutelem(prlab,ipkon,lakon,kon,co, - & ener,mi(1),ii,nelem,energytot,volumetot, - & enerkintot,ikin,ne,stx,nodes) - enddo - else - do iset=1,nset - if(set(iset).eq.prset(ii)) exit - enddo - do jj=istartset(iset),iendset(iset) - if(ialset(jj).lt.0) cycle - if(jj.eq.iendset(iset)) then - nelem=ialset(jj) - call printoutelem(prlab,ipkon,lakon,kon,co, - & ener,mi(1),ii,nelem,energytot,volumetot, - & enerkintot,ikin,ne,stx,nodes) - elseif(ialset(jj+1).gt.0) then - nelem=ialset(jj) - call printoutelem(prlab,ipkon,lakon,kon,co, - & ener,mi(1),ii,nelem,energytot,volumetot, - & enerkintot,ikin,ne,stx,nodes) - else - do nelem=ialset(jj-1)-ialset(jj+1),ialset(jj), - & -ialset(jj+1) - call printoutelem(prlab,ipkon,lakon,kon,co, - & ener,mi(1),ii,nelem,energytot,volumetot, - & enerkintot,ikin,ne,stx,nodes) - enddo - endif - enddo - endif -! -! writing total values to file -! - if((prlab(ii)(1:5).eq.'ELSEO').or. - & (prlab(ii)(1:5).eq.'ELSET')) then - write(5,*) - write(5,116) elset(1:ipos-2),ttime - 116 format(' total internal energy for set ',A,' and time ', - & e14.7) - write(5,*) - write(5,'(6x,1p,1x,e11.4)') energytot - elseif((prlab(ii)(1:5).eq.'ELKEO').or. - & (prlab(ii)(1:5).eq.'ELKET')) then - write(5,*) - write(5,120) elset(1:ipos-2),ttime - 120 format(' total kinetic energy for set ',A,' and time ', - & e14.7) - write(5,*) - write(5,'(6x,1p,1x,e11.4)') enerkintot - elseif((prlab(ii)(1:5).eq.'EVOLO').or. - & (prlab(ii)(1:5).eq.'EVOLT')) then - write(5,*) - write(5,121) elset(1:ipos-2),ttime - 121 format(' total volume for set ',A,' and time ',e14.7) - write(5,*) - write(5,'(6x,1p,1x,e11.4)') volumetot - elseif((prlab(ii)(1:5).eq.'CELSO').or. - & (prlab(ii)(1:5).eq.'CELST')) then - write(5,*) - write(5,125) ttime - 125 format(' total contact spring energy for time ',e14.7) - write(5,*) - write(5,'(6x,1p,1x,e11.4)') energytot -! - endif - endif - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/printoutface.f calculix-ccx-2.3/ccx_2.1/src/printoutface.f --- calculix-ccx-2.1/ccx_2.1/src/printoutface.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/printoutface.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,379 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine printoutface(co,rhcon,nrhcon,ntmat_,vold,shcon,nshcon, - & cocon,ncocon,compressible,istartset,iendset,ipkon,lakon,kon, - & ialset,prset,ttime,nset,set,nprint,prlab,ielmat,mi) -! -! calculation and printout of the lift and drag forces -! - implicit none -! - integer compressible -! - character*8 lakonl,lakon(*) - character*6 prlab(*) - character*80 faset - character*81 set(*),prset(*) -! - integer konl(20),ifaceq(8,6),nelem,ii,nprint,i,j,i1,i2,j1, - & ncocon(2,*),k1,jj,ig,nrhcon(*),nshcon(*),ntmat_,nope,nopes,imat, - & mint2d,ifacet(6,4),ifacew(8,5),iflag,indexe,jface,istartset(*), - & iendset(*),ipkon(*),kon(*),iset,ialset(*),nset,ipos,ielmat(*), - & mi(2) -! - real*8 co(3,*),xl(3,20),shp(4,20),xs2(3,7),dvi,f(3), - & vkl(3,3),rhcon(0:1,ntmat_,*),t(3,3),div,shcon(0:3,ntmat_,*), - & voldl(0:mi(2),20),cocon(0:6,ntmat_,*),xl2(3,8),xsj2(3), - & shp2(7,8), - & vold(0:mi(2),*),xi,et,xsj,temp,xi3d,et3d,ze3d,weight, - & xlocal20(3,9,6),xlocal4(3,1,4),xlocal10(3,3,4),xlocal6(3,1,5), - & xlocal15(3,4,5),xlocal8(3,4,6),xlocal8r(3,1,6),ttime,pres, - & tf(3),tn,tt,dd,coords(3) -! - include "gauss.f" - include "xlocal.f" -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ - data ifacew /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ - data iflag /3/ -! -! initialisierung forces -! - do i=1,3 - f(i)=0.d0 - enddo -! - do ii=1,nprint -! -! total drag -! - if(prlab(ii)(1:4).eq.'DRAG') then -! - ipos=index(prset(ii),' ') - faset=' ' - faset(1:ipos-1)=prset(ii)(1:ipos-1) -! -! printing the header -! - write(5,*) - write(5,120) faset(1:ipos-2),ttime - 120 format(' surface stress vector (tx,ty,tz), normal stress, sh - &ear stress and coordinates for set ',A,' and time ',e14.7) - write(5,*) -! -! printing the data -! - do iset=1,nset - if(set(iset).eq.prset(ii)) exit - enddo -! - do jj=istartset(iset),iendset(iset) -! - jface=ialset(jj) -! - nelem=int(jface/10.d0) - ig=jface-10*nelem - lakonl=lakon(nelem) - indexe=ipkon(nelem) - imat=ielmat(nelem) -! - if(lakonl(4:4).eq.'2') then - nope=20 - nopes=8 - elseif(lakonl(4:4).eq.'8') then - nope=8 - nopes=4 - elseif(lakonl(4:5).eq.'10') then - nope=10 - nopes=6 - elseif(lakonl(4:4).eq.'4') then - nope=4 - nopes=3 - elseif(lakonl(4:5).eq.'15') then - nope=15 - elseif(lakonl(4:4).eq.'6') then - nope=6 - endif -! - if(lakonl(4:5).eq.'8R') then - mint2d=1 - elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R')) - & then - if((lakonl(7:7).eq.'A').or.(lakonl(7:7).eq.'S').or. - & (lakonl(7:7).eq.'E')) then - mint2d=2 - else - mint2d=4 - endif - elseif(lakonl(4:4).eq.'2') then - mint2d=9 - elseif(lakonl(4:5).eq.'10') then - mint2d=3 - elseif(lakonl(4:4).eq.'4') then - mint2d=1 - endif -! -! local topology -! - do i=1,nope - konl(i)=kon(indexe+i) - enddo -! -! computation of the coordinates of the local nodes -! - do i=1,nope - do j=1,3 - xl(j,i)=co(j,konl(i)) - enddo - enddo -! -! temperature, velocity and auxiliary variables -! (rho*energy density, rho*velocity and rho) -! - do i1=1,nope - do i2=0,4 - voldl(i2,i1)=vold(i2,konl(i1)) - enddo - enddo -! -! treatment of wedge faces -! - if(lakonl(4:4).eq.'6') then - mint2d=1 - if(ig.le.2) then - nopes=3 - else - nopes=4 - endif - endif - if(lakonl(4:5).eq.'15') then - if(ig.le.2) then - mint2d=3 - nopes=6 - else - mint2d=4 - nopes=8 - endif - endif -! - if((nope.eq.20).or.(nope.eq.8)) then - do i=1,nopes - do j=1,3 - xl2(j,i)=co(j,konl(ifaceq(i,ig))) - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - do i=1,nopes - do j=1,3 - xl2(j,i)=co(j,konl(ifacet(i,ig))) - enddo - enddo - else - do i=1,nopes - do j=1,3 - xl2(j,i)=co(j,konl(ifacew(i,ig))) - enddo - enddo - endif -! - do i=1,mint2d -! -! local coordinates of the surface integration -! point within the surface local coordinate system -! - if((lakonl(4:5).eq.'8R').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then - xi=gauss2d1(1,i) - et=gauss2d1(2,i) - weight=weight2d1(i) - elseif((lakonl(4:4).eq.'8').or. - & (lakonl(4:6).eq.'20R').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then - xi=gauss2d2(1,i) - et=gauss2d2(2,i) - weight=weight2d2(i) - elseif(lakonl(4:4).eq.'2') then - xi=gauss2d3(1,i) - et=gauss2d3(2,i) - weight=weight2d3(i) - elseif((lakonl(4:5).eq.'10').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then - xi=gauss2d5(1,i) - et=gauss2d5(2,i) - weight=weight2d5(i) - elseif((lakonl(4:4).eq.'4').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then - xi=gauss2d4(1,i) - et=gauss2d4(2,i) - weight=weight2d4(i) - endif -! -! local surface normal -! - if(nopes.eq.8) then - call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.4) then - call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.6) then - call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - endif -! -! global coordinates of the integration point -! - do j1=1,3 - coords(j1)=0.d0 - do i1=1,nopes - coords(j1)=coords(j1)+shp2(4,i1)*xl2(j1,i1) - enddo - enddo -! -! local coordinates of the surface integration -! point within the element local coordinate system -! - if(lakonl(4:5).eq.'8R') then - xi3d=xlocal8r(1,i,ig) - et3d=xlocal8r(2,i,ig) - ze3d=xlocal8r(3,i,ig) - call shape8h(xi3d,et3d,ze3d,xl,xsj,shp,iflag) - elseif(lakonl(4:4).eq.'8') then - xi3d=xlocal8(1,i,ig) - et3d=xlocal8(2,i,ig) - ze3d=xlocal8(3,i,ig) - call shape8h(xi3d,et3d,ze3d,xl,xsj,shp,iflag) - elseif(lakonl(4:6).eq.'20R') then - xi3d=xlocal8(1,i,ig) - et3d=xlocal8(2,i,ig) - ze3d=xlocal8(3,i,ig) - call shape20h(xi3d,et3d,ze3d,xl,xsj,shp,iflag) - elseif(lakonl(4:4).eq.'2') then - xi3d=xlocal20(1,i,ig) - et3d=xlocal20(2,i,ig) - ze3d=xlocal20(3,i,ig) - call shape20h(xi3d,et3d,ze3d,xl,xsj,shp,iflag) - elseif(lakonl(4:5).eq.'10') then - xi3d=xlocal10(1,i,ig) - et3d=xlocal10(2,i,ig) - ze3d=xlocal10(3,i,ig) - call shape10tet(xi3d,et3d,ze3d,xl,xsj,shp,iflag) - elseif(lakonl(4:4).eq.'4') then - xi3d=xlocal4(1,i,ig) - et3d=xlocal4(2,i,ig) - ze3d=xlocal4(3,i,ig) - call shape4tet(xi3d,et3d,ze3d,xl,xsj,shp,iflag) - elseif(lakonl(4:5).eq.'15') then - xi3d=xlocal15(1,i,ig) - et3d=xlocal15(2,i,ig) - ze3d=xlocal15(3,i,ig) - call shape15w(xi3d,et3d,ze3d,xl,xsj,shp,iflag) - elseif(lakonl(4:4).eq.'6') then - xi3d=xlocal6(1,i,ig) - et3d=xlocal6(2,i,ig) - ze3d=xlocal6(3,i,ig) - call shape6w(xi3d,et3d,ze3d,xl,xsj,shp,iflag) - endif -! -! calculating of -! the temperature temp -! the static pressure pres -! the velocity gradient vkl -! in the integration point -! - temp=0.d0 - pres=0.d0 - do i1=1,3 - do j1=1,3 - vkl(i1,j1)=0.d0 - enddo - enddo - do i1=1,nope - temp=temp+shp(4,i1)*voldl(0,i1) - pres=pres+shp(4,i1)*voldl(4,i1) - do j1=1,3 - do k1=1,3 - vkl(j1,k1)=vkl(j1,k1)+shp(k1,i1)*voldl(j1,i1) - enddo - enddo - enddo - if(compressible.eq.1) div=vkl(1,1)+vkl(2,2)+vkl(3,3) -! -! material data (density, dynamic viscosity, heat capacity and -! conductivity) -! -c call materialdata_fl(imat,ntmat_,temp,shcon,nshcon,cp, -c & r,dvi,rhcon,nrhcon,rho,cocon,ncocon,cond) - call materialdata_dvi(imat,ntmat_,temp,shcon,nshcon, - & dvi) -! -! determining the stress -! - do i1=1,3 - do j1=1,3 - t(i1,j1)=vkl(i1,j1)+vkl(j1,i1) - enddo - if(compressible.eq.1) - & t(i1,i1)=t(i1,i1)-2.d0*div/3.d0 - enddo -! - dd=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+ - & xsj2(3)*xsj2(3)) - do i1=1,3 - tf(i1)=dvi*(t(i1,1)*xsj2(1)+t(i1,2)*xsj2(2)+ - & t(i1,3)*xsj2(3))-pres*xsj2(i1) - f(i1)=f(i1)+tf(i1)*weight - tf(i1)=tf(i1)/dd - enddo - tn=(tf(1)*xsj2(1)+tf(2)*xsj2(2)+tf(3)*xsj2(3))/dd - tt=dsqrt((tf(1)-tn*xsj2(1)/dd)**2+ - & (tf(2)-tn*xsj2(2)/dd)**2+ - & (tf(3)-tn*xsj2(3)/dd)**2) - write(5,'(i6,1x,i3,1x,i3,1p,8(1x,e11.4))') nelem,ig,i, - & (tf(i1),i1=1,3),tn,tt,(coords(i1),i1=1,3) -! - enddo - enddo -! - write(5,*) - write(5,121) faset(1:ipos-2),ttime - 121 format(' total surface force (fx,fy,fz) for set ',A, - & ' and time ',e14.7) - write(5,*) - write(5,'(1p,3(1x,e11.4))') (f(j),j=1,3) -! - endif - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/printoutint.f calculix-ccx-2.3/ccx_2.1/src/printoutint.f --- calculix-ccx-2.1/ccx_2.1/src/printoutint.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/printoutint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,275 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine printoutint(prlab,ipkon,lakon,stx,eme,xstate,ener, - & mi,nstate_,l1,lb,ii,nelem,qfx,orab,ielorien,norien,co,kon) -! -! stores integration point results for element "nelem" in the .dat file -! - implicit none -! - character*6 prlab(*) - character*8 lakon(*) -! - integer ipkon(*),mi(2),nstate_,nelem,l,lb,ii,mint3d,j,k,nope, - & ielorien(*),norien,kon(*),konl,indexe,m,iorien,iflag,l1 -! - real*8 stx(6,mi(1),*),eme(6,mi(1),*),xstate(nstate_,mi(1),*), - & ener(mi(1),*),qfx(3,mi(1),*),xi,et,ze,xl(3,20),xsj,shp(4,20), - & coords(3,27),weight,orab(7,*),co(3,*),a(3,3),b(3,3),c(3,3), - & qfxl(3) -! - include "gauss.f" -! - data iflag /1/ -! - if(ipkon(nelem).lt.0) return -! -! check whether transformation is necessary (if orientation -! is applied and output in local system is requested) -! - if((norien.eq.0).or.(prlab(ii)(6:6).eq.'G')) then - iorien=0 - else - iorien=ielorien(nelem) - endif -! - if(lakon(nelem)(4:5).eq.'8R') then - mint3d=1 - elseif((lakon(nelem)(4:4).eq.'8').or. - & (lakon(nelem)(4:6).eq.'20R')) then - mint3d=8 - elseif(lakon(nelem)(4:4).eq.'2') then - mint3d=27 - elseif(lakon(nelem)(4:5).eq.'10') then - mint3d=4 - elseif(lakon(nelem)(4:4).eq.'4') then - mint3d=1 - elseif(lakon(nelem)(4:5).eq.'15') then - mint3d=9 - elseif(lakon(nelem)(4:4).eq.'6') then - mint3d=2 - else - return - endif -! -! calculation of the integration point coordinates for -! output in the local system -! - if(iorien.ne.0) then - if(lakon(nelem)(4:4).eq.'2') then - nope=20 - elseif(lakon(nelem)(4:4).eq.'8') then - nope=8 - elseif(lakon(nelem)(4:5).eq.'10') then - nope=10 - elseif(lakon(nelem)(4:4).eq.'4') then - nope=4 - elseif(lakon(nelem)(4:5).eq.'15') then - nope=15 - elseif(lakon(nelem)(4:4).eq.'6') then - nope=6 - endif -! - indexe=ipkon(nelem) - do j=1,nope - konl=kon(indexe+j) - do k=1,3 - xl(k,j)=co(k,konl) - enddo - enddo -! - do j=1,mint3d - if(lakon(nelem)(4:5).eq.'8R') then - xi=gauss3d1(1,j) - et=gauss3d1(2,j) - ze=gauss3d1(3,j) - weight=weight3d1(j) - elseif((lakon(nelem)(4:4).eq.'8').or. - & (lakon(nelem)(4:6).eq.'20R')) - & then - xi=gauss3d2(1,j) - et=gauss3d2(2,j) - ze=gauss3d2(3,j) - weight=weight3d2(j) - elseif(lakon(nelem)(4:4).eq.'2') then - xi=gauss3d3(1,j) - et=gauss3d3(2,j) - ze=gauss3d3(3,j) - weight=weight3d3(j) - elseif(lakon(nelem)(4:5).eq.'10') then - xi=gauss3d5(1,j) - et=gauss3d5(2,j) - ze=gauss3d5(3,j) - weight=weight3d5(j) - elseif(lakon(nelem)(4:4).eq.'4') then - xi=gauss3d4(1,j) - et=gauss3d4(2,j) - ze=gauss3d4(3,j) - weight=weight3d4(j) - elseif(lakon(nelem)(4:5).eq.'15') then - xi=gauss3d8(1,j) - et=gauss3d8(2,j) - ze=gauss3d8(3,j) - weight=weight3d8(j) - elseif(lakon(nelem)(4:4).eq.'6') then - xi=gauss3d7(1,j) - et=gauss3d7(2,j) - ze=gauss3d7(3,j) - weight=weight3d7(j) - endif -! - if(nope.eq.20) then - call shape20h(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.8) then - call shape8h(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.10) then - call shape10tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.4) then - call shape4tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.15) then - call shape15w(xi,et,ze,xl,xsj,shp,iflag) - else - call shape6w(xi,et,ze,xl,xsj,shp,iflag) - endif -! - do k=1,3 - coords(k,j)=0.d0 - do l=1,nope - coords(k,j)=coords(k,j)+xl(k,l)*shp(4,l) - enddo - enddo - enddo - endif -! - if(prlab(ii)(1:4).eq.'S ') then - if(iorien.eq.0) then - do j=1,mint3d - write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, - & (stx(k,j,nelem),k=1,6) - enddo - else - do j=1,mint3d - call transformatrix(orab(1,iorien),coords(1,j),a) - b(1,1)=stx(1,j,nelem) - b(2,2)=stx(2,j,nelem) - b(3,3)=stx(3,j,nelem) - b(1,2)=stx(4,j,nelem) - b(1,3)=stx(5,j,nelem) - b(2,3)=stx(6,j,nelem) - b(2,1)=b(1,2) - b(3,1)=b(1,3) - b(3,2)=b(2,3) - do k=1,3 - do l=1,3 - c(k,l)=0.d0 - do m=1,3 - c(k,l)=c(k,l)+b(k,m)*a(m,l) - enddo - enddo - enddo - do k=1,3 - do l=k,3 - b(k,l)=0.d0 - do m=1,3 - b(k,l)=b(k,l)+a(m,k)*c(m,l) - enddo - enddo - enddo - write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, - & b(1,1),b(2,2),b(3,3),b(1,2),b(1,3),b(2,3) - enddo - endif - elseif(prlab(ii)(1:4).eq.'E ') then - if(iorien.eq.0) then - do j=1,mint3d - write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, - & (eme(k,j,nelem),k=1,6) - enddo - else - do j=1,mint3d - call transformatrix(orab(1,iorien),coords(1,j),a) - b(1,1)=eme(1,j,nelem) - b(2,2)=eme(2,j,nelem) - b(3,3)=eme(3,j,nelem) - b(1,2)=eme(4,j,nelem) - b(1,3)=eme(5,j,nelem) - b(2,3)=eme(6,j,nelem) - b(2,1)=b(1,2) - b(3,1)=b(1,3) - b(3,2)=b(2,3) - do k=1,3 - do l=1,3 - do m=1,3 - c(k,l)=b(k,m)*a(m,l) - enddo - enddo - enddo - do k=1,3 - do l=k,3 - do m=1,3 - b(k,l)=a(m,k)*c(m,l) - enddo - enddo - enddo - write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, - & b(1,1),b(2,2),b(3,3),b(1,2),b(1,3),b(2,3) - enddo - endif - elseif(prlab(ii)(1:4).eq.'PEEQ') then - do j=1,mint3d - write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, - & xstate(1,j,nelem) - enddo - elseif(prlab(ii)(1:4).eq.'ENER') then - do j=1,mint3d - write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, - & ener(j,nelem) - enddo - elseif(prlab(ii)(1:4).eq.'SDV ') then - if(iorien.ne.0) then - write(*,*) '*WARNING in printoutint: SDV cannot be' - write(*,*) ' printed in the local system' - write(*,*) ' results are in the global system' - endif - do j=1,mint3d - write(5,'(i6,1x,i3,1p,99(1x,e11.4))') nelem,j, - & (xstate(k,j,nelem),k=1,nstate_) - enddo - elseif(prlab(ii)(1:4).eq.'HFL ') then - if(iorien.eq.0) then - do j=1,mint3d - write(5,'(i6,1x,i3,1p,3(1x,e11.4))') nelem,j, - & (qfx(k,j,nelem),k=1,3) - enddo - else - do j=1,mint3d - do k=1,3 - qfxl(k)=qfx(k,j,nelem) - enddo - call transformatrix(orab(1,iorien),coords(1,j),a) - write(5,'(i6,1x,i3,1p,3(1x,e11.4))') nelem,j, - & qfxl(1)*a(1,1)+qfxl(2)*a(2,1)+qfxl(3)*a(3,1), - & qfxl(1)*a(1,2)+qfxl(2)*a(2,2)+qfxl(3)*a(3,2), - & qfxl(1)*a(1,3)+qfxl(2)*a(2,3)+qfxl(3)*a(3,3) - enddo - endif - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/printoutnode.f calculix-ccx-2.3/ccx_2.1/src/printoutnode.f --- calculix-ccx-2.1/ccx_2.1/src/printoutnode.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/printoutnode.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,100 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine printoutnode(prlab,v,t1,fn,ithermal,ii,node, - & rftot,trab,inotr,ntrans,co,mi) -! -! stores results in the .dat file -! - implicit none -! - character*6 prlab(*) -! - integer ithermal,node,ii,j,inotr(2,*),ntrans,mi(2) -! - real*8 v(0:mi(2),*),t1(*),fn(0:mi(2),*),rftot(0:3),trab(7,*), - & co(3,*),a(3,3) -! - if((prlab(ii)(1:4).eq.'U ').or.(prlab(ii)(1:4).eq.'V ')) then - if((ntrans.eq.0).or.(prlab(ii)(6:6).eq.'G')) then - write(5,'(i6,1p,3(1x,e11.4))') node, - & (v(j,node),j=1,3) - elseif(inotr(1,node).eq.0) then - write(5,'(i6,1p,3(1x,e11.4))') node, - & (v(j,node),j=1,3) - else - call transformatrix(trab(1,inotr(1,node)),co(1,node),a) - write(5,'(i6,1p,3(1x,e11.4))') node, - & v(1,node)*a(1,1)+v(2,node)*a(2,1)+v(3,node)*a(3,1), - & v(1,node)*a(1,2)+v(2,node)*a(2,2)+v(3,node)*a(3,2), - & v(1,node)*a(1,3)+v(2,node)*a(2,3)+v(3,node)*a(3,3) - endif - elseif(prlab(ii)(1:4).eq.'NT ') then - if(ithermal.le.1) then - write(5,'(i6,1x,1p,e11.4)') node, - & t1(node) - else - write(5,'(i6,1x,1p,e11.4)') node, - & v(0,node) - endif - elseif(prlab(ii)(1:4).eq.'PS ') then - write(5,'(i6,1x,1p,e11.4)') node, - & v(4,node) - elseif(prlab(ii)(1:4).eq.'PT ') then - write(5,'(i6,1x,1p,e11.4)') node, - & v(2,node) - elseif(prlab(ii)(1:4).eq.'MF ') then - write(5,'(i6,1x,1p,e11.4)') node, - & v(1,node) - elseif(prlab(ii)(1:4).eq.'RF ') then - do j=1,3 - rftot(j)=rftot(j)+fn(j,node) - enddo - if(prlab(ii)(5:5).ne.'O') then - if((ntrans.eq.0).or.(prlab(ii)(6:6).eq.'G')) then - write(5,'(i6,1p,3(1x,e11.4))') node, - & (fn(j,node),j=1,3) - elseif(inotr(1,node).eq.0) then - write(5,'(i6,1p,3(1x,e11.4))') node, - & (fn(j,node),j=1,3) - else - call transformatrix(trab(1,inotr(1,node)),co(1,node),a) - write(5,'(i6,1p,3(1x,e11.4))') node, - & fn(1,node)*a(1,1)+fn(2,node)*a(2,1)+fn(3,node)*a(3,1), - & fn(1,node)*a(1,2)+fn(2,node)*a(2,2)+fn(3,node)*a(3,2), - & fn(1,node)*a(1,3)+fn(2,node)*a(2,3)+fn(3,node)*a(3,3) - endif - endif - elseif(prlab(ii)(1:4).eq.'RFL ') then - rftot(0)=rftot(0)+fn(0,node) - if(prlab(ii)(5:5).ne.'O') then - write(5,'(i6,1p,3(1x,e11.4))') node, - & fn(0,node) - endif - endif -! - flush(5) -! - return - end - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/profil.f calculix-ccx-2.3/ccx_2.1/src/profil.f --- calculix-ccx-2.1/ccx_2.1/src/profil.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/profil.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine profil(n,nnn,e2,adj,xadj,oldpro,newpro, - & oldpro_exp,newpro_exp) -! -! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) -! - integer newpro,i,j,n,jstrt,jstop,oldpro,newmin,oldmin,e2,nnn(n), - & xadj(n+1),adj(e2),inc_oldpro,inc_newpro,oldpro_exp,newpro_exp -! - oldpro=0 - newpro=0 - oldpro_exp=0 - newpro_exp=0 - do 20 i=1,n - jstrt=xadj(i) - jstop=xadj(i+1)-1 - if(jstrt.gt.jstop) cycle - oldmin=adj(jstrt) - newmin=nnn(adj(jstrt)) -! - do 10 j=jstrt+1,jstop - oldmin=min(oldmin,adj(j)) - newmin=min(newmin,nnn(adj(j))) - 10 continue -! - inc_oldpro=dim(i,oldmin) - if(2147483647-oldpro.lt.inc_oldpro) then - oldpro_exp=oldpro_exp+1 - inc_oldpro=inc_oldpro-2147483647 - endif - oldpro=oldpro+inc_oldpro -! - inc_newpro=dim(nnn(i),newmin) - if(2147483647-newpro.lt.inc_newpro) then - newpro_exp=newpro_exp+1 - inc_newpro=inc_newpro-2147483647 - endif - newpro=newpro+inc_newpro - 20 continue -! - inc_oldpro=n - if(2147483647-oldpro.lt.inc_oldpro) then - oldpro_exp=oldpro_exp+1 - inc_oldpro=inc_oldpro-2147483647 - endif - oldpro=oldpro+inc_oldpro -! - inc_newpro=n - if(2147483647-newpro.lt.inc_newpro) then - newpro_exp=newpro_exp+1 - inc_newpro=inc_newpro-2147483647 - endif - newpro=newpro+inc_newpro -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pt2_lim_calc.f calculix-ccx-2.3/ccx_2.1/src/pt2_lim_calc.f --- calculix-ccx-2.1/ccx_2.1/src/pt2_lim_calc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pt2_lim_calc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,115 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! this subroutine solves iteratively the following equation -! to determine the pressure for which section A2 is critical -! - subroutine pt2_lim_calc (pt1,a2,a1,kappa,zeta,pt2_lim) -! - implicit none -! - integer i -! - real*8 pt1,a2,a1,kappa,pt2_lim,x,zeta,f,df,expon1, - & expon2,expon3,cte,a2a1,kp1,km1,delta_x,fact1,fact2,term -! - x=0.999 -! -! x belongs to interval [0;1] -! -! modified 25.11.2007 -! since Pt1/Pt2=(1+0.5(kappa)-M)**(zeta*kappa)/(kappa-1) -! and for zeta1 elements type M_crit=M1=1 -! and for zeta2 elements type M_crit=M2 =1 -! it is not necessary to iteratively solve the flow equation. -! Instead the previous equation is solved to find pt2_crit - if(zeta.ge.0d0) then - kp1=kappa+1d0 - km1=kappa-1d0 - a2a1=a2/a1 - expon1=-0.5d0*kp1/(zeta*kappa) - expon2=-0.5d0*kp1/km1 - cte=a2a1*(0.5*kp1)**expon2 - expon3=-km1/(zeta*kappa) - i=0 -! -! - do - i=i+1 -! - f=x**(-1d0)-cte*x**(expon1) - & *(2d0/km1*(x**expon3-1.d0))**-0.5d0 -! - df=-1.d0/X**2-cte*(x**expon1 - & *(2d0/km1*(x**expon3-1.d0))**-0.5d0) - & *(expon1/X-1d0/km1*expon3*x**(expon3-1d0) - & *(2d0/km1*(x**expon3-1.d0))**(-1.d0)) - - delta_x=-f/df -! - if(( dabs(delta_x/x).le.1.E-8) - & .or.(dabs(delta_x/1d0).le.1.E-10)) then -! - pt2_lim=pt1*X -! - exit - endif - if(i.gt.25)then - pt2_lim=Pt1/(1+0.5*km1)**(zeta*kappa/km1) - exit - endif -! - x=delta_x+x -! - enddo -! - else -! - do - kp1=kappa+1d0 - km1=kappa-1d0 - a2a1=a2/a1 - expon1=kp1/(zeta*kappa) - expon2=km1/(zeta*kappa) - expon3=kp1/km1 - cte=a2a1**2*(0.5*kp1)**-expon3*(2/km1)**-1 - fact1=x**-expon1 - fact2=x**-expon2 - term=fact2-1 -! - f=x**-2-cte*fact1*term**-1 -! - df=-2*x**-3-cte*(x**(-expon1-1)*term**-1) - & *(-expon1+expon2*(X**-expon2)*fact2*term**-1) -! - delta_x=-f/df -! - if(( dabs(delta_x/x).le.1.E-8) - & .or.(dabs(delta_x/1d0).le.1.E-10)) then - pt2_lim=pt1*X - exit - endif -! - x=delta_x+x -! - enddo -! - endif - - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/pt2zpt1_crit.f calculix-ccx-2.3/ccx_2.1/src/pt2zpt1_crit.f --- calculix-ccx-2.1/ccx_2.1/src/pt2zpt1_crit.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/pt2zpt1_crit.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,173 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! calculate the maximal admissible pressure ratio pt2/pt1 -! -! 1) assuming M2=1 for adiabatic respectively M2=1/dsqrt(kappa) for isotherm pipe choking -! M1 is calculated iteratively using a dichotomy scheme -! -! 2)the ratio of the critical pressure ratio Qred_1/Qred_2crit=Pt2/Pt1 -! =D(M1)/D(M2_crit)is computed [D(M)=M*(1+0.5*(kappa-1)*M)**(-0.5*(kappa+1)/(kappa-1))] -! - subroutine pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A, - & iflag,inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) -! - implicit none -! - logical crit -! - integer iflag,inv,icase,i -! - real*8 pt2,pt1,lambda,kappa,l,d,M1,pt2zpt1,pt2zpt1_c, - & km1,kp1,km1zk,kp1zk,Tt1,Tt2,r,A, - & xflow_crit,qred_crit,f1,f2,f3,m1_ac,m1_min,m1_max, - & expon1,qred_max1,lld -! -! useful variables and constants -! - km1=kappa-1.d0 - kp1=kappa+1.d0 - km1zk=km1/kappa - kp1zk=kp1/kappa - lld=lambda*l/d - expon1=-0.5d0*kp1/km1 -! -! adiabatic case -! - if(icase.eq.0) then -! -! computing M1 using dichotomy method -! - i=1 - m1_max=1 - m1_min=0.001d0 - do - i=i+1 - m1_ac=(m1_min+m1_max)*0.5d0 -! - f1=(1.d0-M1_min**2)*(kappa*M1_min**2)**(-1) - & +0.5d0*kp1zk*log((0.5d0*kp1)*M1_min**2 - & *(1+0.5d0*km1*M1_min**2)**(-1))-lld -! - f2=(1.d0-M1_ac**2)*(kappa*M1_ac**2)**(-1) - & +0.5d0*kp1zk*log((0.5d0*kp1)*M1_ac**2 - & *(1+0.5d0*km1*M1_ac**2)**(-1))-lld -! - f3=(1.d0-M1_max**2)*(kappa*M1_max**2)**(-1) - & +0.5d0*kp1zk*log((0.5d0*kp1)*M1_max**2 - & *(1+0.5d0*km1*M1_max**2)**(-1))-lld -! - if(abs(f2).le.1E-6) then - M1=m1_ac - exit - endif - if(i.gt.50) then - M1=M1_ac - exit - endif -! - if((f3.gt.f2).and.(f2.ge.f1)) then - if((f1.lt.0d0).and.(f2.lt.0d0)) then - m1_min=m1_ac - else - m1_max=m1_ac - endif - elseif((f3.lt.f2).and.(f2.le.f1)) then - if((f3.lt.0d0).and.(f2.lt.0d0) )then - m1_max=m1_ac - else - m1_min=m1_ac - endif - endif - enddo -! - Pt2zpt1_c=M1*(0.5d0*kp1)**(0.5*kp1/km1) - & *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1) -! -! isotherm case -! - elseif (icase.eq.1) then -! -! computing M1 using dichotomy method for choked conditions M2=1/dsqrt(kappa) -! (1.d0-kappa*M1**2)/(kappa*M1**2)+log(kappa*M1**2)-lambda*l/d=0 -! - m1_max=1/dsqrt(kappa) - m1_min=0.1d0 - i=1 - do - i=i+1 - m1_ac=(m1_min+m1_max)*0.5d0 -! - f1=(1.d0-kappa*M1_min**2)/(kappa*M1_min**2) - & +log(kappa*M1_min**2)-lambda*l/d -! - f2=(1.d0-kappa*M1_ac**2)/(kappa*M1_ac**2) - & +log(kappa*M1_ac**2)-lambda*l/d -! - f3=(1.d0-kappa*M1_max**2)/(kappa*M1_max**2) - & +log(kappa*M1_max**2)-lambda*l/d -! - if((abs(f2).le.1E-5).or.(i.ge.50)) then - M1=m1_ac - exit - endif -! - if((f3.gt.f2).and.(f2.ge.f1)) then - if((f1.lt.0d0).and.(f2.lt.0d0)) then - m1_min=m1_ac - else - m1_max=m1_ac - endif - elseif((f3.lt.f2).and.(f2.le.f1)) then - if((f3.lt.0d0).and.(f2.lt.0d0) )then - m1_max=m1_ac - else - m1_min=m1_ac - endif - endif - enddo -! -! computing the critical pressure ratio in the isothermal case -! pt=A*dsqrt(kappa)/(xflow*dsqrt(kappa Tt))*M*(1+0.5d0*(kappa-1)M**2)**(-0.5d0*(kappa+1)/(kappa-1)) -! and forming the pressure ratio between inlet and outlet(choked) -! - Pt2zPt1_c=dsqrt(Tt2/Tt1)*M1*dsqrt(kappa)*((1+0.5d0*km1/kappa) - & /(1+0.5d0*km1*M1**2))**(0.5d0*(kappa+1)/km1) -! - endif -! - pt2zpt1=pt2/pt1 - if(Pt2zPt1.le.Pt2zPt1_c) then - crit=.true. - endif -! - if (iflag.eq.1) then - xflow_crit=inv*M1*Pt1*A/dsqrt(Tt1)*dsqrt(kappa/r) - & *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1) - elseif(iflag.eq.2) then - qred_max1=M1*dsqrt(kappa/r) - & *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1) - endif -! - Qred_crit=M1*dsqrt(kappa/r) - & *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1) -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/radcyc.c calculix-ccx-2.3/ccx_2.1/src/radcyc.c --- calculix-ccx-2.1/ccx_2.1/src/radcyc.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/radcyc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,163 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -void radcyc(int *nk,int *kon,int *ipkon,char *lakon,int *ne, - double *cs, int *mcs, int *nkon,int *ialset, int *istartset, - int *iendset,int **kontrip,int *ntri, - double **cop, double **voldp,int *ntrit, int *inocs, - int *mi){ - - /* duplicates triangular faces for cyclic radiation conditions */ - - char *filab=NULL; - - int i,is,nsegments,idtie,nkt,icntrl,imag=0,*kontri=NULL,mt=mi[1]+1, - node,i1,i2,nope,iel,indexe,j,k,ielset,node1,node2,node3,l,jj; - - double *vt=NULL,*fnt=NULL,*stnt=NULL,*eent=NULL,*qfnt=NULL,t[3],theta, - pi,*v=NULL,*fn=NULL,*stn=NULL,*een=NULL,*qfn=NULL,*co=NULL, - *vold=NULL; - - pi=4.*atan(1.); - - kontri=*kontrip;co=*cop;vold=*voldp; - - /* determining the maximum number of sectors */ - - nsegments=1; - for(j=0;j<*mcs;j++){ - if(cs[17*j]>nsegments) nsegments=(int)(cs[17*j]); - } - - /* assigning nodes and elements to sectors */ - - ielset=cs[12]; - if((*mcs!=1)||(ielset!=0)){ - for(i=0;i<*nk;i++) inocs[i]=-1; - } - - for(i=0;i<*mcs;i++){ - is=cs[17*i+4]; - if(is==1) continue; - ielset=cs[17*i+12]; - if(ielset==0) continue; - for(i1=istartset[ielset-1]-1;i10){ - iel=ialset[i1]-1; - if(ipkon[iel]<0) continue; - indexe=ipkon[iel]; - if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; - else {nope=6;} - for(i2=0;i2=ialset[i1-1]-1) break; - if(ipkon[iel]<0) continue; - indexe=ipkon[iel]; - if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; - else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; - else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; - else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; - else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; - else {nope=6;} - for(i2=0;i2 -#include -#include -#include "CalculiX.h" -#ifdef SPOOLES -#include "spooles.h" -#endif -#ifdef SGI -#include "sgi.h" -#endif -#ifdef TAUCS -#include "tau.h" -#endif -#ifdef PARDISO -#include "pardiso.h" -#endif - -void radflowload(int *itg,int *ieg,int *ntg,int *ntr,int *ntm, - double *ac,double *bc,int *nload,char *sideload, - int *nelemload,double *xloadact,char *lakon,int *ipiv, - int *ntmat_,double *vold,double *shcon, - int *nshcon,int *ipkon,int *kon,double *co,double *pmid, - double *e1,double *e2,double *e3,int *iptri,int *kontri, - int *ntri,int *nloadtr,double *tarea,double *tenv, - double *physcon,double *erad,double *f,double *dist, - int *idist,double *area,int *nflow,int *ikboun, - double *xbounact,int *nboun,int *ithermal, - int *iinc,int *iit,double *cs, int *mcs, int *inocs, - int *ntrit,int *nk, double *fenv,int *istep,double *dtime, - double *ttime,double *time,int *ilboun,int *ikforc, - int *ilforc,double *xforcact,int *nforc,double *cam, - int *ielmat,int *nteq,double *prop,int *ielprop,int *nactdog, - int *nacteq,int *nodeboun,int *ndirboun, - int *network, double *rhcon, int *nrhcon, int *ipobody, - int *ibody, double *xbodyact, int *nbody,int *iviewfile, - char *jobnamef, double *ctrl, double *xloadold, - double *reltime, int *nmethod, char *set, int *mi, - int * istartset,int* iendset,int *ialset,int *nset){ - - /* network=0: purely thermal - network=1: general case (temperatures, fluxes and pressures unknown) - network=2: purely aerodynamic, i.e. only fluxes and pressures unknown */ - - int nhrs=1,info=0,i,iin=0,symmetryflag=2,inputformat=2,*icol=NULL, - *irow=NULL,icntrl,icutb=0,iin_abs=0,mt=mi[1]+1; - - double uamt=0,uamf=0,uamp=0,camt[2],camf[2],camp[2],*au=NULL,*adb=NULL, - *aub=NULL,sigma=0.,ramt=0.,ramf=0.,ramp=0.,ram1t=0.,ram1f=0.,ram1p=0., - ram2t=0.,ram2f=0.,ram2p=0.,dtheta=1.,*v=NULL; - - /* check whether there are any gas temperature nodes; this check should - NOT be done on nteq, since also for zero equations the temperature - of the gas nodes with boundary conditions must be stored in v - (in initialgas) */ - - v=NNEW(double,mt**nk); - - if(*ntg!=0) { - icntrl=0; - while(icntrl==0) { - - if(iin==0){ - - for(i=0;i0){ - FORTRAN(dgesv,(nteq,&nhrs,ac,ntm,ipiv,bc,ntm,&info)); - } - - /*spooles(ac,au,adb,aub,&sigma,bc,icol,irow,nteq,ntm, - &symmetryflag,&inputformat);*/ - - if (info!=0) { - printf(" *WARNING in radflowload: singular matrix\n"); - - FORTRAN(mafillgas,(itg,ieg,ntg,ntm,ac,nload,sideload, - nelemload,xloadact,lakon,ntmat_,v, - shcon,nshcon,ipkon,kon,co,nflow,iinc, - istep,dtime,ttime,time, - ielmat,nteq,prop,ielprop,nactdog,nacteq, - physcon,rhcon,nrhcon,ipobody,ibody,xbodyact, - nbody,vold,xloadold,reltime,nmethod,set,mi)); - - FORTRAN(equationcheck,(ac,ntm,nteq,nactdog,itg,ntg,nacteq,network)); - - iin=0; - - } - else { - FORTRAN(resultgas,(itg,ieg,ntg,ntm,bc,nload,sideload,nelemload, - xloadact,lakon,ntmat_,v,shcon,nshcon,ipkon,kon,co, - nflow,iinc,istep,dtime,ttime,time, - ikforc,ilforc,xforcact, - nforc,ielmat,nteq,prop,ielprop,nactdog,nacteq, - &iin,physcon,camt,camf,camp,rhcon,nrhcon,ipobody, - ibody,xbodyact,nbody,&dtheta,vold,xloadold, - reltime,nmethod,set,mi)); - - if(*network!=2){ - ram2t=ram1t; - ram1t=ramt; - ramt=camt[0]; - if (camt[0]>uamt) {uamt=camt[0];} - printf - (" largest increment of gas temperature= %e\n",uamt); - if((int)camt[1]==0){ - printf - (" largest correction to gas temperature= %e\n", - camt[0]); - }else{ - printf - (" largest correction to gas temperature= %e in node %d\n", - camt[0],(int)camt[1]); - } - } - - if(*network!=0){ - ram2f=ram1f; - ram1f=ramf; - ramf=camf[0]; - if (camf[0]>uamf) {uamf=camf[0];} - printf(" largest increment of gas massflow= %e\n",uamf); - if((int)camf[1]==0){ - printf(" largest correction to gas massflow= %e\n", - camf[0]); - }else{ - printf(" largest correction to gas massflow= %e in node %d\n", - camf[0],(int)camf[1]); - } - - ram2p=ram1p; - ram1p=ramp; - ramp=camp[0]; - if (camp[0]>uamp) {uamp=camp[0];} - printf(" largest increment of gas pressure= %e\n",uamp); - if((int)camp[1]==0){ - printf(" largest correction to gas pressure= %e\n", - camp[0]); - }else{ - printf(" largest correction to gas pressure= %e in node %d\n", - camp[0],(int)camp[1]); - } - } - } - - printf("\n"); - - /* for purely thermal calculations no iterations are - deemed necessary */ - - if(*network==0) {icntrl=1;} - else { - checkconvgas (&icutb,&iin,&uamt,&uamf,&uamp, - &ram1t,&ram1f,&ram1p,&ram2t,&ram2f,&ram2p,&ramt,&ramf, - &ramp,&icntrl,&dtheta,ctrl); - } - } - - FORTRAN(flowresult,(ntg,itg,cam,vold,v,nload,sideload, - nelemload,xloadact,nactdog,network,mi)); -#ifdef NETWORKOUT - - /* detailled output file for general and - purely aerodynamic cases */ - - if(*network!=0){ - FORTRAN(flowoutput,(itg,ieg,ntg,ntm,bc,lakon,ntmat_, - v,shcon,nshcon,ipkon,kon,co,nflow, dtime,ttime,time, - ielmat,prop,ielprop,nactdog,nacteq,&iin,physcon, - camt,camf,camp,&uamt,&uamf,&uamp,rhcon,nrhcon, - vold,jobnamef,set,istartset,iendset,ialset,nset,mi)); - } -#endif - } - - if(*ntr>0){ - - FORTRAN(radmatrix, (ntr,ntm,ac,bc,sideload,nelemload,xloadact,lakon, - vold,ipkon,kon,co,pmid,e1,e2,e3,iptri,kontri,ntri, - nloadtr,tarea,tenv,physcon,erad,f,dist,idist,area, - ithermal,iinc,iit,cs,mcs,inocs,ntrit,nk,fenv,istep, - dtime,ttime,time,iviewfile,jobnamef,xloadold, - reltime,nmethod,mi)); - -#ifdef SPOOLES - spooles(ac,au,adb,aub,&sigma,bc,icol,irow,ntr,ntm, - &symmetryflag,&inputformat); -#else - FORTRAN(dgesv,(ntr,&nhrs,ac,ntm,ipiv,bc,ntm,&info)); -#endif - - if (info!=0){ - printf("*ERROR IN RADFLOWLOAD: SINGULAR MATRIX*\n");} - - else{ FORTRAN(radresult, (ntr,xloadact,ntm,bc,nloadtr,tarea, - tenv,physcon,erad,f,fenv));} - } - - free(v); - - return; - -} - diff -Nru calculix-ccx-2.1/ccx_2.1/src/radiate.f calculix-ccx-2.3/ccx_2.1/src/radiate.f --- calculix-ccx-2.1/ccx_2.1/src/radiate.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/radiate.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine radiate(e,sink,temp,kstep,kinc,time,noel,npt, - & coords,jltyp,field,nfield,loadtype,node,area,vold,mi) -! -! user subroutine radiate -! -! -! INPUT: -! -! sink present sink temperature -! temp current temperature value -! kstep step number -! kinc increment number -! time(1) current step time -! time(2) current total time -! noel element number -! npt integration point number -! coords(1..3) global coordinates of the integration point -! jltyp loading face kode: -! 11 = face 1 -! 12 = face 2 -! 13 = face 3 -! 14 = face 4 -! 15 = face 5 -! 16 = face 6 -! field currently not used -! nfield currently not used (value = 1) -! loadtype load type label -! node currently not used -! area area covered by the integration point -! vold(0..4,1..nk) solution field in all nodes -! 0: temperature -! 1: displacement in global x-direction -! 2: displacement in global y-direction -! 3: displacement in global z-direction -! 4: static pressure -! mi(1) max # of integration points per element (max -! over all elements) -! mi(2) max degree of freedomm per node (max over all -! nodes) in fields like v(0:mi(2))... -! -! OUTPUT: -! -! e(1) magnitude of the emissivity -! e(2) not used; please do NOT assign any value -! sink sink temperature (need not be defined -! for cavity radiation) -! - implicit none -! - character*20 loadtype - integer kstep,kinc,noel,npt,jltyp,nfield,node,mi(2) - real*8 e(2),sink,time(2),coords(3),temp,field(nfield),area, - & vold(0:mi(2),*) -! - e(1)=0.72d0 -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/radiates.f calculix-ccx-2.3/ccx_2.1/src/radiates.f --- calculix-ccx-2.1/ccx_2.1/src/radiates.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/radiates.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,332 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine radiates(inpc,textpart,set,istartset,iendset, - & ialset,nset,nelemload,sideload,xload,nload,nload_, - & ielmat,ntmat_,iamload,amname,nam,lakon,ne,radiate_flag, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,physcon,nam_,namtot_, - & namta,amta,ipoinpc) -! -! reading the input deck: *RADIATE -! - implicit none -! - logical radiate_flag,environmentnode -! - character*1 inpc(*) - character*3 cavlabel - character*8 lakon(*) - character*20 sideload(*),label - character*80 amname(*),amplitude - character*81 set(*),elset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),nelemload(2,*), - & ielmat(*),nset,nload,nload_,ntmat_,istep,istat,n,i,j,l,key, - & iamload(2,*),nam,iamptemp,ipos,ne,node,iampradi,iline,ipol, - & inl,ipoinp(2,*),inp(3,*),nam_,namtot,namtot_,namta(3,*), - & idelay1,idelay2,ipoinpc(0:*) -! - real*8 xload(2,*),xmagradi,xmagtemp,physcon(*),amta(2,*) -! - iamptemp=0 - iampradi=0 - idelay1=0 - idelay2=0 - cavlabel=' ' -! - environmentnode=.false. -! - if(istep.lt.1) then - write(*,*) '*ERROR in radiates: *RADIATE should only be used' - write(*,*) ' within a STEP' - stop - endif -! - if(physcon(2).le.0.d0) then - write(*,*) '*ERROR in radiates: *RADIATE card was selected' - write(*,*) ' but no *PHYSICAL CONSTANTS card encountered' - stop - endif -! - do i=2,n - if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.radiate_flag)) then - do j=1,nload - if(sideload(j)(1:1).eq.'R') then - xload(1,j)=0.d0 - endif - enddo - elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then - read(textpart(i)(11:90),'(a80)') amplitude - do j=nam,1,-1 - if(amname(j).eq.amplitude) then - iamptemp=j - exit - endif - enddo - if(j.gt.nam) then - write(*,*)'*ERROR in radiates: nonexistent amplitude' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iamptemp=j - elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN - if(idelay1.ne.0) then - write(*,*) '*ERROR in radiates: the parameter TIME DELAY' - write(*,*) ' is used twice in the same keyword' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - else - idelay1=1 - endif - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in radiates: increase nam_' - stop - endif - amname(nam)=' - & ' - if(iamptemp.eq.0) then - write(*,*) '*ERROR in radiates: time delay must be' - write(*,*) ' preceded by the amplitude parameter' - stop - endif - namta(3,nam)=isign(iamptemp,namta(3,iamptemp)) - iamptemp=nam - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) '*ERROR radiates: increase namtot_' - stop - endif - namta(1,nam)=namtot - namta(2,nam)=namtot - read(textpart(i)(11:30),'(f20.0)',iostat=istat) - & amta(1,namtot) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:19).eq.'RADIATIONAMPLITUDE=') then - read(textpart(i)(20:99),'(a80)') amplitude - do j=nam,1,-1 - if(amname(j).eq.amplitude) then - iampradi=j - exit - endif - enddo - if(j.gt.nam) then - write(*,*)'*ERROR in radiates: nonexistent amplitude' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iampradi=j - elseif(textpart(i)(1:19).eq.'RADIATIONTIMEDELAY=') THEN - if(idelay2.ne.0) then - write(*,*) '*ERROR in radiates: the parameter RADIATION' - write(*,*) ' TIME DELAY is used twice in the' - write(*,*) ' same keyword; ' - call inputerror(inpc,ipoinpc,iline) - stop - else - idelay2=1 - endif - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in radiates: increase nam_' - stop - endif - amname(nam)=' - & ' - if(iampradi.eq.0) then - write(*,*) '*ERROR in radiates: radiation time delay' - write(*,*) ' must be preceded by the radiation' - write(*,*) ' amplitude parameter' - stop - endif - namta(3,nam)=isign(iampradi,namta(3,iampradi)) - iampradi=nam - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) '*ERROR radiates: increase namtot_' - stop - endif - namta(1,nam)=namtot - namta(2,nam)=namtot - read(textpart(i)(20:39),'(f20.0)',iostat=istat) - & amta(1,namtot) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:7).eq.'ENVNODE') THEN - environmentnode=.true. - elseif(textpart(i)(1:7).eq.'CAVITY=') THEN - read(textpart(i)(8:10),'(a3)',iostat=istat) cavlabel - endif - enddo -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return -! - read(textpart(2)(1:20),'(a20)',iostat=istat) label -! - label(18:20)=cavlabel -! -! compatibility with ABAQUS for shells -! - if(label(2:4).eq.'NEG') label(2:4)='1 ' - if(label(2:4).eq.'POS') label(2:4)='2 ' - if(label(2:2).eq.'N') label(2:2)='5' - if(label(2:2).eq.'P') label(2:2)='6' -! -! reference temperature and radiation coefficient -! (for non uniform loading: use user routine radiation.f) -! - if((label(3:4).ne.'NU').and.(label(5:5).ne.'N')) then - if(environmentnode) then - read(textpart(3)(1:10),'(i10)',iostat=istat) node - else - read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagtemp - node=0 - endif - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(4)(1:20),'(f20.0)',iostat=istat) xmagradi - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - else - if(environmentnode) then - read(textpart(3)(1:10),'(i10)',iostat=istat) node - else - read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagtemp - node=0 - endif - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - if(((label(1:2).ne.'R1').and.(label(1:2).ne.'R2').and. - & (label(1:2).ne.'R3').and.(label(1:2).ne.'R4').and. - & (label(1:2).ne.'R5').and.(label(1:2).ne.'R6')).or. - & ((label(3:5).ne.' ').and.(label(3:5).ne.'NU ').and. - & (label(3:5).ne.'CR ').and.(label(3:5).ne.'CRN'))) then - call inputerror(inpc,ipoinpc,iline) - endif -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - if(l.gt.ne) then - write(*,*) '*ERROR in radiates: element ',l - write(*,*) ' is not defined' - stop - endif -! - if((lakon(l)(1:2).eq.'CP').or. - & (lakon(l)(2:2).eq.'A').or. - & (lakon(l)(7:7).eq.'E').or. - & (lakon(l)(7:7).eq.'S').or. - & (lakon(l)(7:7).eq.'A')) then - if(label(1:2).eq.'R1') then - label(1:2)='R3' - elseif(label(1:2).eq.'R2') then - label(1:2)='R4' - elseif(label(1:2).eq.'R3') then - label(1:2)='R5' - elseif(label(1:2).eq.'R4') then - label(1:2)='R6' - elseif(label(1:2).eq.'R5') then - label(1:2)='R1' - elseif(label(1:2).eq.'R6') then - label(1:2)='R2' - endif -c elseif((lakon(l)(1:1).eq.'B').or. -c & (lakon(l)(7:7).eq.'B')) then -c elseif((lakon(l)(1:1).eq.'S').or. -c & (lakon(l)(7:7).eq.'L')) then - endif - call loadaddt(l,label,xmagradi,xmagtemp,nelemload,sideload, - & xload,nload,nload_,iamload,iamptemp,iampradi,nam,node) - else - read(textpart(1)(1:80),'(a80)',iostat=istat) elset - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - do i=1,nset - if(set(i).eq.elset) exit - enddo - if(i.gt.nset) then - elset(ipos:ipos)=' ' - write(*,*) '*ERROR in radiates: element set ',elset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! - l=ialset(istartset(i)) - if((lakon(l)(1:2).eq.'CP').or. - & (lakon(l)(2:2).eq.'A').or. - & (lakon(l)(7:7).eq.'E').or. - & (lakon(l)(7:7).eq.'S').or. - & (lakon(l)(7:7).eq.'A')) then - if(label(1:2).eq.'R1') then - label(1:2)='R3' - elseif(label(1:2).eq.'R2') then - label(1:2)='R4' - elseif(label(1:2).eq.'R3') then - label(1:2)='R5' - elseif(label(1:2).eq.'R4') then - label(1:2)='R6' - elseif(label(1:2).eq.'R5') then - label(1:2)='R1' - elseif(label(1:2).eq.'R6') then - label(1:2)='R2' - endif -c elseif((lakon(l)(1:1).eq.'B').or. -c & (lakon(l)(7:7).eq.'B')) then -c elseif((lakon(l)(1:1).eq.'S').or. -c & (lakon(l)(7:7).eq.'L')) then - endif -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - l=ialset(j) - call loadaddt(l,label,xmagradi,xmagtemp,nelemload, - & sideload,xload,nload,nload_,iamload, - & iamptemp,iampradi,nam,node) - else - l=ialset(j-2) - do - l=l-ialset(j) - if(l.ge.ialset(j-1)) exit - call loadaddt(l,label,xmagradi,xmagtemp,nelemload, - & sideload,xload,nload,nload_,iamload, - & iamptemp,iampradi,nam,node) - enddo - endif - enddo - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/radmatrix.f calculix-ccx-2.3/ccx_2.1/src/radmatrix.f --- calculix-ccx-2.1/ccx_2.1/src/radmatrix.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/radmatrix.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1017 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! -! center of gravity of the projection of the vertices for -! visibility purposes -! exact integration for one triangle: routine cubtri -! if the surfaces are far enough away, one-point integration -! is used -! - subroutine radmatrix(ntr,ntm, - & ac,bc,sideload,nelemload,xloadact,lakon,vold, - & ipkon,kon,co,pmid,e1,e2,e3,iptri, - & kontri,ntri,nloadtr,tarea,tenv,physcon,erad,f, - & dist,idist,area,ithermal,iinc,iit, - & cs,mcs,inocs,ntrit,nk,fenv,istep,dtime,ttime, - & time,iviewfile,jobnamef,xloadold,reltime,nmethod,mi) -! - implicit none -! - logical covered(160,160),exi -! - character*87 label(27) - character*8 lakonl,lakon(*) - character*20 sideload(*) - character*132 jobnamef(*),fnvw -! - integer ntr,nelemload(2,*),nope,nopes,mint2d,i,j,k,l, - & node,ntm,ifaceq(8,6),ifacet(6,4),iviewfile,mi(2), - & ifacew(8,5),nelem,ig,index,konl(20),iflag, - & ipkon(*),kon(*),ncovered,kontri(3,*),iptri(*),nloadtr(*), - & i1,j1,istart,iend,jstart,jend,imin,imid,imax,mcs,inocs(*), - & k1,kflag,idist(*),ndist,i2,i3,ng,idi,idj,ntri, - & ithermal,iinc,iit,ix,iy,ntrit,jj,is,m,jmod,nkt, - & icntrl,imag,nk,istep,jltyp,nfield,nonzero,nmethod, - & limev,ier,nw,idata(1),ncalls,nlabel -! - real*8 ac(ntm,*),bc(ntm,1),xloadact(2,*),h(2),w(239), - & xl2(3,8),coords(3),dxsj2,temp,xi,et,weight,xsj2(3), - & vold(0:mi(2),*),co(3,*),shp2(7,8),xs2(3,7),xn(3),xxn, - & pmid(3,*),e3(4,*),e1(3,*),e2(3,*),p1(3),p2(3),p3(3), - & areamean,tarea(*),tenv(*),x,y,cs(17,*),porigin(3), - & erad(*),fenv(*),e,ec,physcon(*),yymin,yymax,xxmin, - & xxmid,xxmax,dummy,a(3,3),b(3,3),c(3,3),ddd(3),p31(3), - & xx(3),yy(3),ftij,f(ntr,*),dint,dir(3),tl2(8), - & dirloc(3),dist(*),area(*),dd,p21(3),p32(3),pi, - & totarea,fn,stn,qfn,een,t(3),sidemean,tvar(2),field, - & dtime,ttime,time,areaj,xloadold(2,*),reltime,p(3,3), - & fform,ver(2,3),epsabs,epsrel,abserr,vj(3,3),unitvec(3,3), - & rdata(1),vertex(3,3),vertexl(2,3),factor,argument -! - include "gauss.f" -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ - data ifacew /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ - data iflag /2/ -! - common /formfactor/ vj,unitvec,porigin -! - external fform -! - nlabel=27 -! -! factor determines when the numerical integration using cubtri -! is replaced by a simplified formula using only the center -! of gravity of one of the triangles. The integration over the -! other triangle is exact (analytical formula, see -! "Radiosity: a Programmer's Perspective", by Ian Ashdown, Wiley, 1994) -! If the distance between the center of gravity of the triangles -! is larger then factor*the projected sqrt(area) of the triangle on the -! hemisphere, the simplified formula is taken -! - factor=0.d0 -! - pi=4.d0*datan(1.d0) -! - tvar(1)=time - tvar(2)=ttime+dtime -! -! cavity radiation! -! -! the default sink temperature is updated at the start of each -! increment -! - do i=1,ntr - node=nelemload(2,nloadtr(i)) - if(node.ne.0) then - tenv(i)=vold(0,node)-physcon(1) - elseif(iit.le.0) then - tenv(i)=xloadact(2,nloadtr(i))-physcon(1) - endif - enddo -! -! for pure thermal steps the viewfactors have to be -! calculated only once, for thermo-mechanical steps -! (ithermal=3) they are recalculated in each iteration -! unless they are read from file -! - if(((ithermal.eq.3).and.(iviewfile.ge.0)).or.(iit.eq.-1)) then - if(iviewfile.lt.0) then - if(ithermal.eq.3) then - write(*,*) '*WARNING in radmatrix: viewfactors are being' - write(*,*) ' read from file for a thermomechani-' - write(*,*) ' cal calculation: they will not be ' - write(*,*) ' recalculated in every iteration.' - endif -! - write(*,*) 'Reading the viewfactors from file' - write(*,*) -! - if(jobnamef(2)(1:1).eq.' ') then - do i=1,132 - if(jobnamef(1)(i:i).eq.' ') exit - enddo - i=i-1 - fnvw=jobnamef(1)(1:i)//'.vwf' - else - fnvw=jobnamef(2) - endif - inquire(file=fnvw,exist=exi) - if(exi) then - open(10,file=fnvw,status='old',form='unformatted', - & access='sequential',err=10) - else - write(*,*) '*ERROR in radmatrix: viewfactor file ',fnvw - write(*,*) 'does not exist' - stop - endif -! - read(10) nonzero - do k=1,nonzero - read(10) i,j,f(i,j) - enddo - read(10)(fenv(i),i=1,ntr) -! - close(10) - else -! - write(*,*) 'Calculating the viewfactors' - write(*,*) -! - ng=160 - dint=2.d0/ng -! -! updating the displacements for cyclic symmetric structures -! - if(mcs.gt.0) then - nkt=0 - do i=1,mcs - if(int(cs(1,i)).gt.nkt) nkt=int(cs(1,i)) - enddo - nkt=nk*nkt - do i=1,nlabel - do l=1,87 - label(i)(l:l)=' ' - enddo - enddo - label(1)(1:1)='U' - imag=0 - icntrl=2 - call rectcyl(co,vold,fn,stn,qfn,een,cs,nk,icntrl,t, - & label,imag,mi) - - do jj=0,mcs-1 - is=cs(1,jj+1) -! - do i=1,is-1 - do l=1,nk - if(inocs(l).ne.jj) cycle - do m=1,mi(2) - vold(m,l+nk*i)=vold(m,l) - enddo - enddo - enddo - enddo - icntrl=-2 - call rectcyl(co,vold,fn,stn,qfn,een,cs,nkt,icntrl,t, - & label,imag,mi) - endif -! -! calculating the momentaneous center of the triangles, -! area of the triangles and normal to the triangles -! - sidemean=0.d0 - do i=1,ntrit - i1=kontri(1,i) - if(i1.eq.0) cycle - i2=kontri(2,i) - i3=kontri(3,i) - do j=1,3 - p1(j)=co(j,i1)+vold(j,i1) - p2(j)=co(j,i2)+vold(j,i2) - p3(j)=co(j,i3)+vold(j,i3) - pmid(j,i)=(p1(j)+p2(j)+p3(j))/3.d0 - p21(j)=p2(j)-p1(j) - p32(j)=p3(j)-p2(j) - enddo -! -! normal to the triangle -! - e3(1,i)=p21(2)*p32(3)-p32(2)*p21(3) - e3(2,i)=p21(3)*p32(1)-p32(3)*p21(1) - e3(3,i)=p21(1)*p32(2)-p32(1)*p21(2) -! - dd=dsqrt(e3(1,i)*e3(1,i)+e3(2,i)*e3(2,i)+ - & e3(3,i)*e3(3,i)) -! -! check for degenerated triangles -! - if(dd.lt.1.d-20) then - area(i)=0.d0 - cycle - endif -! - do j=1,3 - e3(j,i)=e3(j,i)/dd - enddo -! -! area of the triangle -! - area(i)=dd/2.d0 -! -! unit vector parallel to side 1-2 -! - dd=dsqrt(p21(1)*p21(1)+p21(2)*p21(2)+p21(3)*p21(3)) - sidemean=sidemean+dd - do j=1,3 - e1(j,i)=p21(j)/dd - enddo -! -! unit vector orthogonal to e1 and e3 -! - e2(1,i)=e3(2,i)*e1(3,i)-e3(3,i)*e1(2,i) - e2(2,i)=e3(3,i)*e1(1,i)-e3(1,i)*e1(3,i) - e2(3,i)=e3(1,i)*e1(2,i)-e3(2,i)*e1(1,i) -! -! the fourth component in e3 is the constant term in the -! equation of the triangle plane in the form -! e3(1)*x+e3(2)*y+e3(3)*z+e3(4)=0 -! - e3(4,i)=-(e3(1,i)*p1(1)+e3(2,i)*p1(2) - & +e3(3,i)*p1(3)) - enddo - sidemean=sidemean/ntrit -! -! determine the geometrical factors -! -! initialization of the fields -! - do i=1,ntr - do j=1,ntr - f(i,j)=0.d0 - enddo - enddo -! - do i=1,ntri - if(area(i).lt.1.d-20) cycle -! -! vertices of triangle i in local coordinates -! - i1=kontri(1,i) - if(i1.eq.0) cycle - i2=kontri(2,i) - i3=kontri(3,i) - do j=1,3 - porigin(j)=co(j,i1)+vold(j,i1) - p2(j)=co(j,i2)+vold(j,i2) - p3(j)=co(j,i3)+vold(j,i3) - p21(j)=p2(j)-porigin(j) - p31(j)=p3(j)-porigin(j) - enddo - ver(1,1)=0.d0 - ver(2,1)=0.d0 - ver(1,2)=dsqrt(p21(1)**2+p21(2)**2+p21(3)**2) - ver(2,2)=0.d0 - ver(1,3)=p31(1)*e1(1,i)+p31(2)*e1(2,i)+p31(3)*e1(3,i) - ver(2,3)=p31(1)*e2(1,i)+p31(2)*e2(2,i)+p31(3)*e2(3,i) -! - do k=1,3 - unitvec(k,1)=e1(k,i) - unitvec(k,2)=e2(k,i) - unitvec(k,3)=e3(k,i) - enddo -! -! checking which triangles face triangle i -! - ndist=0 - do j=1,ntrit - if((kontri(1,j).eq.0).or.(area(j).lt.1.d-20)) cycle - if(pmid(1,j)*e3(1,i)+pmid(2,j)*e3(2,i)+ - & pmid(3,j)*e3(3,i)+e3(4,i).le.sidemean/800.d0) cycle - if(pmid(1,i)*e3(1,j)+pmid(2,i)*e3(2,j)+ - & pmid(3,i)*e3(3,j)+e3(4,j).le.sidemean/800.d0) cycle -! - if(j.gt.ntri) then - jmod=mod(j,ntri) - if(jmod.eq.0) jmod=ntri - else - jmod=j - endif -! - call nident(iptri,i,ntr,idi) - call nident(iptri,jmod,ntr,idj) - if(sideload(nloadtr(idi))(18:20).ne. - & sideload(nloadtr(idj))(18:20)) cycle -! - ndist=ndist+1 - dist(ndist)=dsqrt((pmid(1,j)-pmid(1,i))**2+ - & (pmid(2,j)-pmid(2,i))**2+ - & (pmid(3,j)-pmid(3,i))**2) - idist(ndist)=j - enddo - if(ndist.eq.0) cycle -! -! ordering the triangles -! - kflag=2 - call dsort(dist,idist,ndist,kflag) -! -! initializing the coverage matrix -! -c write(*,*) i,(idist(i1),i1=1,ndist) - ncovered=0 - do i1=1,ng - x=((i1-0.5d0)*dint-1.d0)**2 - do j1=1,ng - y=((j1-0.5d0)*dint-1.d0)**2 - if(x+y.gt.1.d0) then - covered(i1,j1)=.true. - ncovered=ncovered+1 - else - covered(i1,j1)=.false. - endif - enddo - enddo -! - do k1=1,ndist - j=idist(k1) -! -! determining the 2-D projection of the vertices -! of triangle j -! - do l=1,3 - do k=1,3 - vertex(k,l)=co(k,kontri(l,j))-pmid(k,i) - enddo - dd=dsqrt(vertex(1,l)**2+vertex(2,l)**2+ - & vertex(3,l)**2) - do k=1,3 - vertex(k,l)=vertex(k,l)/dd - enddo - vertexl(1,l)=vertex(1,l)*e1(1,i)+ - & vertex(2,l)*e1(2,i)+ - & vertex(3,l)*e1(3,i) - vertexl(2,l)=vertex(1,l)*e2(1,i)+ - & vertex(2,l)*e2(2,i)+ - & vertex(3,l)*e2(3,i) - enddo -! -! determining the center of gravity of the projected -! triangle -! - do k=1,2 - dirloc(k)=(vertexl(k,1)+vertexl(k,2)+ - & vertexl(k,3))/3.d0 - enddo -! -! determine the direction vector in global coordinates -! - do k=1,3 - dir(k)=(pmid(k,j)-pmid(k,i))/dist(k1) - enddo -! -! direction vector in local coordinates of triangle i -! - dirloc(3)=dir(1)*e3(1,i)+dir(2)*e3(2,i)+dir(3)*e3(3,i) -! -! check whether this direction was already covered -! - ix=int((dirloc(1)+1.d0)/dint)+1 - iy=int((dirloc(2)+1.d0)/dint)+1 - if(covered(ix,iy)) then -c write(*,*) 'triangle ',j,' was already covered' - cycle - endif -! -! if surfaces are close, numerical integration with -! cubtri is performed -! - if(dist(k1).le.factor*dsqrt(area(i))*dirloc(3)) then -! -! vertices of triangle j -! - do k=1,3 - do l=1,3 - vj(l,k)=co(l,kontri(k,j))+vold(l,kontri(k,j)) - enddo - enddo -! -! formfactor contribution -! - epsrel=0.01d0 - epsabs=0.d0 - limev=100 - nw=239 - ncalls=0 -! -! max 1000 evaluations for nw=239 -! - call cubtri(fform,ver,epsrel,limev,ftij,abserr,ncalls, - & w,nw,idata,rdata,ier) - ftij=ftij/2.d0 -c write(*,*) 'formfactor contri ',i,j,ftij/area(i),ier, -c & abserr,ncalls - endif -! -! updating the coverage matrix -! - do k=1,3 - p(k,1)=co(k,kontri(1,j))+vold(k,kontri(1,j))-pmid(k,i) - enddo - ddd(1)=dsqrt(p(1,1)*p(1,1)+p(2,1)*p(2,1)+p(3,1)*p(3,1)) - do k=1,3 - p1(k)=p(k,1)/ddd(1) - enddo - xx(1)=p1(1)*e1(1,i)+p1(2)*e1(2,i)+p1(3)*e1(3,i) - yy(1)=p1(1)*e2(1,i)+p1(2)*e2(2,i)+p1(3)*e2(3,i) -! - do k=1,3 - p(k,2)=co(k,kontri(2,j))+vold(k,kontri(2,j))-pmid(k,i) - enddo - ddd(2)=dsqrt(p(1,2)*p(1,2)+p(2,2)*p(2,2)+p(3,2)*p(3,2)) - do k=1,3 - p2(k)=p(k,2)/ddd(2) - enddo - xx(2)=p2(1)*e1(1,i)+p2(2)*e1(2,i)+p2(3)*e1(3,i) - yy(2)=p2(1)*e2(1,i)+p2(2)*e2(2,i)+p2(3)*e2(3,i) -! - do k=1,3 - p(k,3)=co(k,kontri(3,j))+vold(k,kontri(3,j))-pmid(k,i) - enddo - ddd(3)=dsqrt(p(1,3)*p(1,3)+p(2,3)*p(2,3)+p(3,3)*p(3,3)) - do k=1,3 - p3(k)=p(k,3)/ddd(3) - enddo - xx(3)=p3(1)*e1(1,i)+p3(2)*e1(2,i)+p3(3)*e1(3,i) - yy(3)=p3(1)*e2(1,i)+p3(2)*e2(2,i)+p3(3)*e2(3,i) -! - if(dabs(xx(2)-xx(1)).lt.1.d-5) xx(2)=xx(1)+1.d-5 - if(dabs(xx(2)-xx(1)).lt.1.d-5) xx(2)=xx(1)+1.d-5 -! -! if the surfaces are far enough away, one-point -! integration is used -! - if(dist(k1).gt.factor*dsqrt(area(i))*dirloc(3)) then - ftij=0.d0 - do k=1,3 - l=k-1 - if(l.lt.1) l=3 - xn(1)=p(2,k)*p(3,l)-p(2,l)*p(3,k) - xn(2)=p(3,k)*p(1,l)-p(3,l)*p(1,k) - xn(3)=p(1,k)*p(2,l)-p(1,l)*p(2,k) - xxn=dsqrt(xn(1)**2+xn(2)**2+xn(3)**2) -! -! argument of dacos must have an absolute value -! smaller than or equal to 1.d0; due to -! round-off the value can slightly exceed one -! and has to be cut-off. -! - argument= - & (p(1,k)*p(1,l)+p(2,k)*p(2,l)+p(3,k)*p(3,l))/ - & (ddd(k)*ddd(l)) - if(dabs(argument).gt.1.d0) then - if(argument.gt.0.d0) then - argument=1.d0 - else - argument=-1.d0 - endif - endif - ftij=ftij+ - & (e3(1,i)*xn(1) - & +e3(2,i)*xn(2) - & +e3(3,i)*xn(3))/xxn - & *dacos(argument) -c & (p(1,k)*p(1,l)+p(2,k)*p(2,l)+p(3,k)*p(3,l))/ -c & (ddd(k)*ddd(l))) - enddo - ftij=ftij*area(i)/2.d0 -c write(*,*) 'formfactor contri: one-point ', -c & i,j,ftij/area(i) - endif -! -! localizing which surface interaction the -! triangle interaction is part of (the modulus is -! necessary for cyclic structures) -! - if(j.gt.ntri) then - jmod=mod(j,ntri) - if(jmod.eq.0) jmod=ntri - else - jmod=j - endif -! - call nident(iptri,i,ntr,idi) - call nident(iptri,jmod,ntr,idj) - f(idi,idj)=f(idi,idj)+ftij -! -! determining maxima and minima -! - xxmin=2.d0 - xxmax=-2.d0 - do k=1,3 - if(xx(k).lt.xxmin) then - xxmin=xx(k) - imin=k - endif - if(xx(k).gt.xxmax) then - xxmax=xx(k) - imax=k - endif - enddo -! - if(((imin.eq.1).and.(imax.eq.2)).or. - & ((imin.eq.2).and.(imax.eq.1))) then - imid=3 - xxmid=xx(3) - elseif(((imin.eq.2).and.(imax.eq.3)).or. - & ((imin.eq.3).and.(imax.eq.2))) then - imid=1 - xxmid=xx(1) - else - imid=2 - xxmid=xx(2) - endif -! -! check for equal x-values -! - if(xxmid-xxmin.lt.1.d-5) then - xxmin=xxmin-1.d-5 - xx(imin)=xxmin - endif - if(xxmax-xxmid.lt.1.d-5) then - xxmax=xxmax+1.d-5 - xx(imax)=xxmax - endif -! -! equation of the straight lines connecting the -! triangle vertices in the local x-y plane -! - a(1,2)=yy(2)-yy(1) - b(1,2)=xx(1)-xx(2) - c(1,2)=yy(1)*xx(2)-xx(1)*yy(2) -! - a(2,3)=yy(3)-yy(2) - b(2,3)=xx(2)-xx(3) - c(2,3)=yy(2)*xx(3)-xx(2)*yy(3) -! - a(3,1)=yy(1)-yy(3) - b(3,1)=xx(3)-xx(1) - c(3,1)=yy(3)*xx(1)-xx(3)*yy(1) -! - a(2,1)=a(1,2) - b(2,1)=b(1,2) - c(2,1)=c(1,2) - a(3,2)=a(2,3) - b(3,2)=b(2,3) - c(3,2)=c(2,3) - a(1,3)=a(3,1) - b(1,3)=b(3,1) - c(1,3)=c(3,1) -! - istart=int((xxmin+1.d0+dint/2.d0)/dint)+1 - iend=int((xxmid+1.d0+dint/2.d0)/dint) - do i1=istart,iend - x=dint*(i1-0.5d0)-1.d0 - yymin=-(a(imin,imid)*x+c(imin,imid))/b(imin,imid) - yymax=-(a(imin,imax)*x+c(imin,imax))/b(imin,imax) - if(yymin.gt.yymax) then - dummy=yymin - yymin=yymax - yymax=dummy - endif - jstart=int((yymin+1.d0+dint/2.d0)/dint)+1 - jend=int((yymax+1.d0+dint/2.d0)/dint) - do j1=jstart,jend - covered(i1,j1)=.true. - enddo - ncovered=ncovered+jend-jstart+1 - enddo -! - istart=int((xxmid+1.d0+dint/2.d0)/dint)+1 - iend=int((xxmax+1.d0+dint/2.d0)/dint) - do i1=istart,iend - x=dint*(i1-0.5d0)-1.d0 - yymin=-(a(imid,imax)*x+c(imid,imax))/b(imid,imax) - yymax=-(a(imin,imax)*x+c(imin,imax))/b(imin,imax) - if(yymin.gt.yymax) then - dummy=yymin - yymin=yymax - yymax=dummy - endif - jstart=int((yymin+1.d0+dint/2.d0)/dint)+1 - jend=int((yymax+1.d0+dint/2.d0)/dint) - do j1=jstart,jend - covered(i1,j1)=.true. - enddo - ncovered=ncovered+jend-jstart+1 - enddo - if(ncovered.eq.ng*ng)exit -! - enddo - enddo -! -! division through total area and through pi -! - do i=1,ntr - totarea=0.d0 - if(i.lt.ntr) then - do j=iptri(i),iptri(i+1)-1 - totarea=totarea+area(j) - enddo - else - do j=iptri(i),ntri - totarea=totarea+area(j) - enddo - endif - totarea=totarea*4.d0*datan(1.d0) - do j=1,ntr - f(i,j)=f(i,j)/totarea - enddo - enddo -! -! checking whether the sum of the viewfactors does not -! exceed 1 -! - do i=1,ntr - fenv(i)=0.d0 - do j=1,ntr - fenv(i)=fenv(i)+f(i,j) - enddo -c write(*,*) nelemload(1,i),',',sideload(i),',',fenv(i), -c & ',',1.d0-fenv(i) - if((fenv(i).gt.1.d0).or.(tenv(i).lt.0)) then - if(fenv(i).gt.0.d0) then - do j=1,ntr - f(i,j)=f(i,j)/fenv(i) - enddo - fenv(i)=1.d0 - else - write(*,*) '*WARNING in radmatrix: viewfactors' - write(*,*) ' for 3D-face''', - & sideload(nloadtr(i)),'''' - write(*,*) ' of element', - & nelemload(1,nloadtr(i)) - write(*,*) ' cannot be scaled since they are' - write(*,*) ' all zero' - write(*,*) - endif - endif - fenv(i)=1.d0-fenv(i) - enddo -! - endif -! - nonzero=0 - do i=1,ntr - do j=1,ntr - if(dabs(f(i,j)).gt.1.d-20) nonzero=nonzero+1 - enddo - enddo -! - if(abs(iviewfile).eq.2) then -! - write(*,*) 'Writing the viewfactors to file' - write(*,*) -! - if(jobnamef(3)(1:1).eq.' ') then - do i=1,132 - if(jobnamef(1)(i:i).eq.' ') exit - enddo - i=i-1 - fnvw=jobnamef(1)(1:i)//'.vwf' - else - fnvw=jobnamef(3) - endif - open(10,file=fnvw,status='unknown',form='unformatted', - & access='sequential',err=10) -! - write(10) nonzero - do i=1,ntr - do j=1,ntr - if(dabs(f(i,j)).gt.1.d-20) write(10) i,j,f(i,j) - enddo - enddo - write(10)(fenv(i),i=1,ntr) - close(10) - endif -! - endif -! -! initialization of ac and bc -! - do i=1,ntr - do j=1,ntr - ac(i,j)=0.d0 - enddo - bc(i,1)=0.d0 - enddo -! -! filling ac and bc -! - do i1=1,ntr - ac(i1,i1)=1.d0 - i=nloadtr(i1) - nelem=nelemload(1,i) - lakonl=lakon(nelem) -! -! calculate the mean temperature of the face -! - read(sideload(i)(2:2),'(i1)') ig -! -! number of nodes and integration points in the face -! - if(lakonl(4:4).eq.'2') then - nope=20 - nopes=8 - elseif(lakonl(4:4).eq.'8') then - nope=8 - nopes=4 - elseif(lakonl(4:5).eq.'10') then - nope=10 - nopes=6 - elseif(lakonl(4:4).eq.'4') then - nope=4 - nopes=3 - elseif(lakonl(4:5).eq.'15') then - nope=15 - else - nope=6 - endif -! - if(lakonl(4:5).eq.'8R') then - mint2d=1 - elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R')) - & then - if(lakonl(7:7).eq.'A') then - mint2d=2 - else - mint2d=4 - endif - elseif(lakonl(4:4).eq.'2') then - mint2d=9 - elseif(lakonl(4:5).eq.'10') then - mint2d=3 - elseif(lakonl(4:4).eq.'4') then - mint2d=1 - endif -! - if(lakonl(4:4).eq.'6') then - mint2d=1 - if(ig.le.2) then - nopes=3 - else - nopes=4 - endif - endif - if(lakonl(4:5).eq.'15') then - if(ig.le.2) then - mint2d=3 - nopes=6 - else - mint2d=4 - nopes=8 - endif - endif -! -! connectivity of the element -! - index=ipkon(nelem) - if(index.lt.0) then - write(*,*) '*ERROR in radflowload: element ',nelem - write(*,*) ' is not defined' - stop - endif - do k=1,nope - konl(k)=kon(index+k) - enddo -! -! coordinates of the nodes belonging to the face -! - if((nope.eq.20).or.(nope.eq.8)) then - do k=1,nopes - tl2(k)=vold(0,konl(ifaceq(k,ig))) -! - do j=1,3 - xl2(j,k)=co(j,konl(ifaceq(k,ig)))+ - & vold(j,konl(ifaceq(k,ig))) - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - do k=1,nopes - tl2(k)=vold(0,konl(ifacet(k,ig))) - do j=1,3 - xl2(j,k)=co(j,konl(ifacet(k,ig)))+ - & vold(j,konl(ifacet(k,ig))) - enddo - enddo - else - do k=1,nopes - tl2(k)=vold(0,konl(ifacew(k,ig))) - do j=1,3 - xl2(j,k)=co(j,konl(ifacew(k,ig)))+ - & vold(j,konl(ifacew(k,ig))) - enddo - enddo - endif -! -! integration to obtain the center of gravity and the mean -! temperature; radiation coefficient -! - areamean=0.d0 - tarea(i1)=0.d0 -! - read(sideload(i)(2:2),'(i1)') jltyp - jltyp=jltyp+10 - if(sideload(i)(5:6).ne.'NU') then - erad(i1)=xloadact(1,i) - else - erad(i1)=0.d0 - endif -! - do l=1,mint2d - if((lakonl(4:5).eq.'8R').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then - xi=gauss2d1(1,l) - et=gauss2d1(2,l) - weight=weight2d1(l) - elseif((lakonl(4:4).eq.'8').or. - & (lakonl(4:6).eq.'20R').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then - xi=gauss2d2(1,l) - et=gauss2d2(2,l) - weight=weight2d2(l) - elseif(lakonl(4:4).eq.'2') then - xi=gauss2d3(1,l) - et=gauss2d3(2,l) - weight=weight2d3(l) - elseif((lakonl(4:5).eq.'10').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then - xi=gauss2d5(1,l) - et=gauss2d5(2,l) - weight=weight2d5(l) - elseif((lakonl(4:4).eq.'4').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then - xi=gauss2d4(1,l) - et=gauss2d4(2,l) - weight=weight2d4(l) - endif -! - if(nopes.eq.8) then - call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.4) then - call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.6) then - call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - endif -! - dxsj2=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+ - & xsj2(3)*xsj2(3)) -! - temp=0.d0 - do j=1,nopes - temp=temp+tl2(j)*shp2(4,j) - enddo -! - tarea(i1)=tarea(i1)+temp*dxsj2*weight - areamean=areamean+dxsj2*weight -! - if(sideload(i)(5:6).eq.'NU') then - areaj=dxsj2*weight - do k=1,3 - coords(k)=0.d0 - enddo - do j=1,nopes - do k=1,3 - coords(k)=coords(k)+xl2(k,j)*shp2(4,j) - enddo - enddo - call radiate(h(1),tenv(i1),temp,istep, - & iinc,tvar,nelem,l,coords,jltyp,field,nfield, - & sideload(i),node,areaj,vold,mi) - if(nmethod.eq.1) h(1)=xloadold(1,i)+ - & (h(1)-xloadold(1,i))*reltime - erad(i1)=erad(i1)+h(1) - endif -! - enddo - tarea(i1)=tarea(i1)/areamean-physcon(1) - if(sideload(i)(5:6).eq.'NU') then - erad(i1)=erad(i1)/mint2d - endif -! -! radiation coefficient -! -! - e=erad(i1) - ec=1.d0-e -! - do j1=1,ntr - ac(i1,j1)=ac(i1,j1)-ec*f(i1,j1) - enddo - bc(i1,1)=physcon(2)*(e*tarea(i1)**4+ - & ec*fenv(i1)*tenv(i1)**4) -! - enddo -! - nonzero=0 - do i=1,ntr - do j=1,ntr - if(dabs(ac(i,j)).gt.1.d-20) nonzero=nonzero+1 - enddo - enddo -! - return -! - 10 write(*,*) '*ERROR in radmatrix: could not open file ',fnvw - stop - end -! -! function to be integrated -! - real*8 function fform(x,y,idata,rdata) -! - implicit none -! - integer k,l,number,idata(1) -! - real*8 pint(3),ddd(3),xn(3),vj(3,3), - & unitvec(3,3),p(3,3),xxn,x,y,porigin(3),rdata(1) -! - common /formfactor/ vj,unitvec,porigin -! - data number /0/ - save number -! - number=number+1 - do k=1,3 - pint(k)=porigin(k)+x*unitvec(k,1)+y*unitvec(k,2) - enddo -! - do k=1,3 - p(k,1)=vj(k,1)-pint(k) - enddo - ddd(1)=dsqrt(p(1,1)*p(1,1)+p(2,1)*p(2,1)+p(3,1)*p(3,1)) -! - do k=1,3 - p(k,2)=vj(k,2)-pint(k) - enddo - ddd(2)=dsqrt(p(1,2)*p(1,2)+p(2,2)*p(2,2)+p(3,2)*p(3,2)) -! - do k=1,3 - p(k,3)=vj(k,3)-pint(k) - enddo - ddd(3)=dsqrt(p(1,3)*p(1,3)+p(2,3)*p(2,3)+p(3,3)*p(3,3)) -! -! calculating the contribution -! - fform=0.d0 - do k=1,3 - l=k-1 - if(l.lt.1) l=3 - xn(1)=p(2,k)*p(3,l)-p(2,l)*p(3,k) - xn(2)=p(3,k)*p(1,l)-p(3,l)*p(1,k) - xn(3)=p(1,k)*p(2,l)-p(1,l)*p(2,k) - xxn=dsqrt(xn(1)**2+xn(2)**2+xn(3)**2) - fform=fform+ - & (unitvec(1,3)*xn(1) - & +unitvec(2,3)*xn(2) - & +unitvec(3,3)*xn(3))/xxn - & *dacos( - & (p(1,k)*p(1,l)+p(2,k)*p(2,l)+p(3,k)*p(3,l))/ - & (ddd(k)*ddd(l))) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/radresult.f calculix-ccx-2.3/ccx_2.1/src/radresult.f --- calculix-ccx-2.1/ccx_2.1/src/radresult.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/radresult.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine radresult(ntr,xloadact,ntm,bc,nloadtr,tarea, - & tenv,physcon,erad,f,fenv) -! - implicit none -! - integer i,j,ntm,ntr,nloadtr(*) -! - real*8 xloadact(2,*), tarea(*),tenv(*), - & erad(*),q,fenv(*),physcon(*),f(ntr,*),bc(ntm,1) -! -! calculating the flux and transforming the flux into an -! equivalent temperature -! - write(*,*) '' - - do i=1,ntr - q=bc(i,1) - do j=1,ntr - if(i.eq.j)cycle - q=q-f(i,j)*bc(j,1) - enddo - q=q-fenv(i)*physcon(2)*tenv(i)**4 - xloadact(2,nloadtr(i))= - & max(tarea(i)**4-q/(erad(i)*physcon(2)),0.d0) -c write(*,*) xloadact(2,nloadtr(i)) - xloadact(2,nloadtr(i))= - & (xloadact(2,nloadtr(i)))**0.25+physcon(1) -c write(*,*) xloadact(2,nloadtr(i)) -c write(*,*) i,bc(i,1),q,xloadact(2,nloadtr(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/ranewr.f calculix-ccx-2.3/ccx_2.1/src/ranewr.f --- calculix-ccx-2.1/ccx_2.1/src/ranewr.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ranewr.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,96 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - REAL FUNCTION RANEWR () -C -C ERZEUGUNG GLEICHVERTEILTER ZUFALLSZAHLEN ZWISCHEN 0 UND 1. -C PORTABLER ZUFALLSZAHLENGENERATOR IN STANDARD F77 -C -C AUTOR: H. PFOERTNER -C -C AENDERUNGSSTAND : -C 26.08.95 EXTERNAL RAEWIN ENGEFUEGT, UM UEBER BLOCKDATA-LINK -C STARTBELEGUNG AUCH OHNE INIRAN-AUFRUF ZU ERZWINGEN -C 07.12.92 BASISVERSION -C -C LITERATUR: WICHMANN AND HILL: APPL. STATIST. (JRSSC), -C (31) 188-190, (1982) -C -C GEDAECHTNIS: -C MUSS VOR DEM ERSTEN AUFRUF VON RANEWR DURCH EINEN AUFRUF VON -C INIRAN VORBELEGT WERDEN. - INTEGER IX, IY, IZ - COMMON /XXXRAN/ IX, IY, IZ -C - EXTERNAL RAEWIN -C -C MODULO-OPERATIONEN - IX = 171 * MOD ( IX, 177) - 2 * ( IX / 177 ) - IY = 172 * MOD ( IY, 176) - 35 * ( IY / 176 ) - IZ = 170 * MOD ( IZ, 178) - 63 * ( IZ / 178 ) -C -C AUF POSITIVEN BEREICH BRINGEN - IF ( IX .LT. 0 ) IX = IX + 30269 - IF ( IY .LT. 0 ) IY = IY + 30307 - IF ( IZ .LT. 0 ) IZ = IZ + 30323 -C -C ZAHL ZWISCHEN 0 UND 1 ERZEUGEN - RANEWR = MOD ( REAL(IX) / 30269.0 - & + REAL(IY) / 30307.0 - & + REAL(IZ) / 30323.0, 1.0 ) -C - RETURN -C ENDE DER FUNCTION RANEWR - END -C ******************************************************************* - SUBROUTINE INIRAN(i1,i2,i3) -C -C STARTBELEGUNG FUER DEN ZUFALLSZAHLENGENERATOR RANEWR -C -C AUTOR: H. PFOERTNER -C -C AENDERUNGSSTAND : -C 07.12.92 BASISVERSION -C -C LITERATUR: WICHMANN AND HILL: APPL. STATIST. (JRSSC), -C (31) 188-190, (1982) -C -C GEDAECHTNIS: - INTEGER IX, IY, IZ - COMMON /XXXRAN/ IX, IY, IZ -C -C VORBELEGUNG - IX = i1 - IY = i2 - IZ = i3 -C - RETURN -C ENDE DES UP. INIRAN - END -C ******************************************************************* - BLOCKDATA RAEWIN -C -C ERZWINGUNG EINER STARTBELEGUNG (Z.B. BEI VERGESSENEM INIRAN-AUFRUF) -C -C HUGO PFOERTNER / OBERHACHING -C 26.08.95 BASISVERSION -C - INTEGER IX, IY, IZ - COMMON /XXXRAN/ IX, IY, IZ - DATA IX, IY, IZ / 1974, 235, 337 / - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/readinput.c calculix-ccx-2.3/ccx_2.1/src/readinput.c --- calculix-ccx-2.1/ccx_2.1/src/readinput.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/readinput.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,369 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include -#include "CalculiX.h" - -void readinput(char *jobnamec, char **inpcp, int *nline, int *nset, - int *ipoinp, int **inpp, int **ipoinpcp, int *ithermal){ - - /* reads and stores the input deck in inpcp; determines the - number of sets */ - - FILE *f1[10]; - - char buff[1320], fninp[132]="", includefn[132]="", *inpc=NULL, - textpart[2112],*set=NULL; - - int i,j,k,n,in=0,nlinemax=100000,irestartread,irestartstep, - icntrl,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat,ntmat,npmat, - norien,nam,nprint,mint,ntrans,ncs,namtot,ncmat,memmpc,ne1d, - ne2d,nflow,*meminset=NULL,*rmeminset=NULL, *inp=NULL,ntie, - nener,nstate,nentries=14,ifreeinp,ikey,lincludefn, - nbody,ncharmax=1000000,*ipoinpc=NULL; - - /* initialization */ - - /* nentries is the number of different keyword cards for which - the input deck order is important, cf keystart.f */ - - inpc=NNEW(char,ncharmax); - ipoinpc=NNEW(int,nlinemax+1); - inp=NNEW(int,3*nlinemax); - *nline=0; - for(i=0;i<2*nentries;i++){ipoinp[i]=0;} - ifreeinp=1; - ikey=0; - - /* opening the input file */ - - strcpy(fninp,jobnamec); - strcat(fninp,".inp"); - if((f1[in]=fopen(fninp,"r"))==NULL){ - printf("*ERROR in read: cannot open file %s\n",fninp); - exit(0); - } - - /* starting to read the input file */ - - do{ - if(fgets(buff,1320,f1[in])==NULL){ - fclose(f1[in]); - if(in!=0){ - in--; - continue; - } - else{break;} - } - - /* storing the significant characters */ - /* get rid of blanks */ - - k=0; - i=-1; - do{ - i++; - if((buff[i]=='\0')||(buff[i]=='\n')||(buff[i]=='\r')||(k==1320)) break; - if((buff[i]==' ')||(buff[i]=='\t')) continue; - buff[k]=buff[i]; - k++; - }while(1); - - /* check for blank lines and comments */ - - if(k==0) continue; - if(strcmp1(&buff[0],"**")==0) continue; - - /* changing to uppercase except include filenames */ - - if(k<15){ - for(j=0;j9){ - printf("*ERROR in read: include statements can \n not be cascaded over more than 9 levels\n"); - } - if((f1[in]=fopen(includefn,"r"))==NULL){ - printf("*ERROR in read: cannot open file %s\n",includefn); - exit(0); - } - continue; - } - - /* adding a line */ - - (*nline)++; - if(*nline>nlinemax){ - nlinemax=(int)(1.1*nlinemax); - RENEW(ipoinpc,int,nlinemax+1); - RENEW(inp,int,3*nlinemax); - } - - /* checking the total number of characters */ - - if(ipoinpc[*nline-1]+k>ncharmax){ - ncharmax=(int)(1.1*ncharmax); - RENEW(inpc,char,ncharmax); - } - - /* copying into inpc */ - - for(j=0;j -#include -#include -#include -#include "CalculiX.h" - -void remastruct(int *ipompc, double **coefmpcp, int **nodempcp, int *nmpc, - int *mpcfree, int *nodeboun, int *ndirboun, int *nboun, - int *ikmpc, int *ilmpc, int *ikboun, int *ilboun, - char *labmpc, int *nk, - int *memmpc_, int *icascade, int *maxlenmpc, - int *kon, int *ipkon, char *lakon, int *ne, int *nnn, - int *nactdof, int *icol, int *jq, int **irowp, int *isolver, - int *neq, int *nzs,int *nmethod, double **fp, - double **fextp, double **bp, double **aux2p, double **finip, - double **fextinip,double **adbp, double **aubp, int *ithermal, - int *iperturb, int *mass, int *mi){ - - /* reconstructs the nonzero locations in the stiffness and mass - matrix after a change in MPC's */ - - int *nodempc=NULL,*npn=NULL,*adj=NULL,*xadj=NULL,*iw=NULL,*mmm=NULL, - *xnpn=NULL,*mast1=NULL,*ipointer=NULL,mpcend,mpcmult, - callfrommain,i,*irow=NULL; - - double *coefmpc=NULL,*f=NULL,*fext=NULL,*b=NULL,*aux2=NULL, - *fini=NULL,*fextini=NULL,*adb=NULL,*aub=NULL; - - nodempc=*nodempcp;coefmpc=*coefmpcp;irow=*irowp; - f=*fp;fext=*fextp;b=*bp;aux2=*aux2p;fini=*finip; - fextini=*fextinip;adb=*adbp;aub=*aubp; - - /* decascading the MPC's */ - - printf(" Decascading the MPC's\n\n"); - - callfrommain=0; - cascade(ipompc,&coefmpc,&nodempc,nmpc, - mpcfree,nodeboun,ndirboun,nboun,ikmpc, - ilmpc,ikboun,ilboun,&mpcend,&mpcmult, - labmpc,nk,memmpc_,icascade,maxlenmpc, - &callfrommain,iperturb,ithermal); - - /* reallocating nodempc and coefmpc */ - - /* RENEW(nodempc,int,3*mpcend); - RENEW(coefmpc,double,mpcend);*/ - - for(i=1;i<=*nk;++i) nnn[i-1]=i; - - /* renumbering the nodes */ - - /*printf(" Renumbering the nodes to decrease the profile:\n"); - - npn=NNEW(int,20**ne+mpcend); - adj=NNEW(int,380**ne+mpcmult); - xadj=NNEW(int,*nk+1); - iw=NNEW(int,4**nk+1); - mmm=NNEW(int,*nk); - xnpn=NNEW(int,*ne+*nmpc+1); - - FORTRAN(renumber,(nk,kon,ipkon,lakon,ne,ipompc,nodempc,nmpc,nnn, - npn,adj,xadj,iw,mmm,xnpn)); - - free(npn);free(adj);free(xadj);free(iw);free(mmm);free(xnpn);*/ - - /* determining the matrix structure */ - - printf(" Determining the structure of the matrix:\n"); - - if(nzs[1]<10) nzs[1]=10; - mast1=NNEW(int,nzs[1]); - ipointer=NNEW(int,4**nk); - RENEW(irow,int,nzs[1]);for(i=0;i -#include -#include -#include -#include "CalculiX.h" - -void remcontmpc(int *nmpc, char *labmpc, int *mpcfree, int *nodempc, - int *ikmpc, int *ilmpc, double *coefmpc, int *ipompc){ - - /* removes the contact MPC's */ - - int i; - - for(i=*nmpc;i>0;i--){ - if(strcmp1(&labmpc[20*(i-1)],"CONTACT")==0){ - FORTRAN(mpcrem,(&i,mpcfree,nodempc,nmpc,ikmpc,ilmpc, - labmpc,coefmpc,ipompc)); - } - } - - return; - -} - diff -Nru calculix-ccx-2.1/ccx_2.1/src/renumber.f calculix-ccx-2.3/ccx_2.1/src/renumber.f --- calculix-ccx-2.1/ccx_2.1/src/renumber.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/renumber.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,140 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine renumber(nk,kon,ipkon,lakon,ne,ipompc,nodempc,nmpc,nnn, - & npn,adj,xadj,iw,mmm,xnpn,inum1,inum2) -! -! renumbers the nodes to reduce the profile length -! - implicit none -! - character*8 lakon(*) -! - integer kon(*),ipompc(*),nodempc(3,*),npn(*),inum1(*),inum2(*), - & nnn(*),iw(*),mmm(*),xnpn(*),adj(*),xadj(*),ipkon(*),node -! - integer nne,inpn,iadj,nk,ne,nmpc,i,j,nterm,e2,oldpro,newpro, - & index,kflag,nope,indexe,oldpro_exp,newpro_exp,nknew -! - kflag=2 - nne=0 - inpn=0 - iadj=0 -! -! taking the elements into account -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - elseif(lakon(i)(1:1).eq.'E') then - read(lakon(i)(8:8),'(i1)') nope - elseif(lakon(i)(1:1).eq.'D') then - cycle - endif -! - nne=nne+1 - xnpn(nne)=inpn+1 - do j=1,nope - node=kon(indexe+j) - npn(inpn+j)=node - inum1(node)=1 - enddo - inpn=inpn+nope - iadj=iadj+nope*(nope-1) - enddo -! -! taking the equations into account -! - do i=1,nmpc - nne=nne+1 - xnpn(nne)=inpn+1 - index=ipompc(i) - nterm=0 - do - nterm=nterm+1 - node=nodempc(1,index) - npn(inpn+nterm)=node - inum1(node)=1 - index=nodempc(3,index) - if(index.eq.0) exit - enddo - inpn=inpn+nterm - iadj=iadj+nterm*(nterm-1) - enddo -! - xnpn(nne+1)=inpn+1 -! -! numbering the node which are really used and changing the -! numbers in npn -! - nknew=0 - do i=1,nk - if(inum1(i).gt.0) then - nknew=nknew+1 - inum1(i)=nknew - endif - enddo - do i=1,inpn - npn(i)=inum1(npn(i)) - enddo -! - call graph(nknew,nne,inpn,npn,xnpn,iadj,adj,xadj) -! - e2=xadj(nknew+1)-1 -! - call label(nknew,e2,adj,xadj,mmm,iw,oldpro,newpro,oldpro_exp, - & newpro_exp) -! - write(*,*) 'old profile = ',oldpro_exp,'*2147483647+',oldpro - write(*,*) 'new profile = ',newpro_exp,'*2147483647+',newpro - write(*,*) -! -! restoring the original numbering -! - do i=1,nk - if(inum1(i).ne.0) then - inum2(inum1(i))=i - endif - enddo - index=0 - do i=1,nk - if(inum1(i).eq.0) then - inum1(i)=i - else - index=index+1 - inum1(i)=inum2(mmm(index)) - endif - enddo -! - call isortii(inum1,nnn,nk,kflag) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/residual.f calculix-ccx-2.3/ccx_2.1/src/residual.f --- calculix-ccx-2.1/ccx_2.1/src/residual.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/residual.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine storeresidual(nactdof,b,fn,filab,ithermal,nk) -! -! This routine is called in case of divergence: -! stores the residual forces in fn and changes the -! file storage labels so that the independent -! variables (displacements and/or temperatures) and -! the corresponding residual forces are stored in the -! frd file -! - implicit none -! - character*87 filab(*) -! - integer nactdof(0:mi(2),*),ithermal,i,j,nk -! - real*8 b(*),fn(0:mi(2),*) -! -! storing the residual forces in field fn -! - do i=1,nk - do j=0,3 - if(nactdof(j,i).gt.0) then - fn(j,i)=b(nactdof(j,i)) - else - fn(j,i)=0.d0 - endif - enddo - enddo -! -! adapting the storage labels -! - if(ithermal.ne.2) then - filab(1)='U ' - else - filab(1)=' ' - endif - if(ithermal.gt.1) then - filab(2)='NT ' - else - filab(2)=' ' - endif - do i=3,10 - filab(i)=' ' - enddo - if(ithermal.ne.2) then - filab(13)='RFRES ' - else - filab(13)=' ' - endif - if(ithermal.gt.1) then - filab(14)='RFLRES' - else - filab(14)=' ' - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/restartread.f calculix-ccx-2.3/ccx_2.1/src/restartread.f --- calculix-ccx-2.1/ccx_2.1/src/restartread.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/restartread.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,414 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine restartread(istep,nset,nload,nforc, nboun,nk,ne, - & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi, - & ntrans,ncs_,namtot_,ncmat_,mpcfree,maxlenmpc, - & ne1d,ne2d,nflow,nlabel,iplas, - & nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset, - & iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun, - & xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, - & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload, - & sideload,xload,elcon,nelcon,rhcon,nrhcon, - & alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab, - & ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold, - & ielmat,matname,prlab,prset,filab,vold,nodebounold, - & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, - & iponor,xnor,knor,thickn,thicke,offset,iponoel,inoel,rig, - & shcon,nshcon,cocon,ncocon,ics,sti, - & ener,xstate,jobnamec,infree,nnn,irestartstep,prestr,iprestr, - & cbody,ibody,xbody,nbody,xbodyold,ttime,qaold,cs,mcs, - & output,physcon,ctrl,typeboun,fmpc,tieset,ntie) -! - implicit none -! - character*1 typeboun(*) - character*3 output - character*6 prlab(*) - character*8 lakon(*) - character*20 labmpc(*),sideload(*) - character*80 orname(*),amname(*),matname(*) - character*81 set(*),prset(*),tieset(3,*),cbody(*) - character*87 filab(*) - character*132 fnrstrt,jobnamec(*) -! - integer istep,nset,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat, - & ntmat_,npmat_,norien,nam,nprint,mi(2),ntrans,ncs_, - & namtot_,ncmat_,mpcfree,ne1d,ne2d,nflow,nlabel,iplas,nkon, - & ithermal,nmethod,iperturb(*),nstate_,istartset(*),iendset(*), - & ialset(*),kon(*),ipkon(*),nodeboun(*),ndirboun(*),iamboun(*), - & ikboun(*),ilboun(*),ipompc(*),nodempc(*),ikmpc(*),ilmpc(*), - & nodeforc(*),ndirforc(*),iamforc(*),ikforc(*),ilforc(*), - & nelemload(*),iamload(*),nelcon(*),mt, - & nrhcon(*),nalcon(*),nplicon(*),nplkcon(*),ielorien(*),inotr(*), - & namta(*),iamt1(*),ielmat(*),nodebounold(*),ndirbounold(*), - & iponor(*),knor(*),iponoel(*),inoel(*),rig(*), - & nshcon(*),ncocon(*),ics(*),infree(*),nnn(*),i,ipos, - & nener,irestartstep,istat,iprestr, - & maxlenmpc,j,mcs,mpcend,ntie,ibody(*),nbody -! - real*8 co(*),xboun(*),coefmpc(*),xforc(*),xload(*),elcon(*), - & rhcon(*),alcon(*),alzero(*),plicon(*),plkcon(*),orab(*), - & trab(*),amta(*),t0(*),t1(*),veold(*), - & vold(*),xbounold(*),xforcold(*),xloadold(*),t1old(*),eme(*), - & xnor(*),thickn(*),thicke(*),offset(*), - & shcon(*),cocon(*),sti(*),ener(*),xstate(*),prestr(*),ttime, - & qaold(2),physcon(*),ctrl(*),cs(17,*),fmpc(*),xbody(*), - & xbodyold(*) -! - ipos=index(jobnamec(1),char(0)) - fnrstrt(1:ipos-1)=jobnamec(1)(1:ipos-1) - fnrstrt(ipos:ipos+3)=".rin" - do i=ipos+4,132 - fnrstrt(i:i)=' ' - enddo -! - open(15,file=fnrstrt,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', - & err=15) -! - do -! - read(15,iostat=istat)istep - if(istat.lt.0) then - write(*,*) '*ERROR in restartread: requested step' - write(*,*) ' is not in the restart file' - stop - endif -! -! set size -! - read(15)nset - read(15)nalset -! -! load size -! - read(15)nload - read(15)nbody - read(15)nforc - read(15)nboun - read(15)nflow -! -! mesh size -! - read(15)nk - read(15)ne - read(15)nkon - read(15)(mi(i),i=1,2) - mt=mi(2)+1 -! -! constraint size -! - read(15)nmpc - read(15)mpcend - read(15)maxlenmpc -! -! material size -! - read(15)nmat - read(15)ntmat_ - read(15)npmat_ - read(15)ncmat_ -! -! transformation size -! - read(15)norien - read(15)ntrans -! -! amplitude size -! - read(15)nam - read(15)namtot_ -! -! print size -! - read(15)nprint - read(15)nlabel -! -! tie size -! - read(15)ntie -! -! cyclic symmetry size -! - read(15)ncs_ - read(15)mcs -! -! 1d and 2d element size -! - read(15)ne1d - read(15)ne2d - read(15)(infree(i),i=1,4) -! -! procedure info -! - read(15)nmethod - read(15)(iperturb(i),i=1,2) - read(15)nener - read(15)iplas - read(15)ithermal - read(15)nstate_ - read(15)iprestr -! - if(istep.eq.irestartstep) exit -! -! skipping the next entries until the requested step is found -! - call skip(nset,nalset,nload,nbody,nforc,nboun,nflow,nk,ne,nkon, - & mi(1),nmpc,mpcend,nmat,ntmat_,npmat_,ncmat_,norien,ntrans, - & nam,nprint,nlabel,ncs_,ne1d,ne2d,infree,nmethod, - & iperturb,nener,iplas,ithermal,nstate_,iprestr,mcs,ntie) -! - enddo -! -! sets -! - read(15)(set(i),i=1,nset) - read(15)(istartset(i),i=1,nset) - read(15)(iendset(i),i=1,nset) - do i=1,nalset - read(15)ialset(i) - enddo -! -! mesh -! - read(15)(co(i),i=1,3*nk) - read(15)(kon(i),i=1,nkon) - read(15)(ipkon(i),i=1,ne) - read(15)(lakon(i),i=1,ne) -! -! single point constraints -! - read(15)(nodeboun(i),i=1,nboun) - read(15)(ndirboun(i),i=1,nboun) - read(15)(typeboun(i),i=1,nboun) - read(15)(xboun(i),i=1,nboun) - read(15)(ikboun(i),i=1,nboun) - read(15)(ilboun(i),i=1,nboun) - if(nam.gt.0) read(15)(iamboun(i),i=1,nboun) - read(15)(nodebounold(i),i=1,nboun) - read(15)(ndirbounold(i),i=1,nboun) - read(15)(xbounold(i),i=1,nboun) -! -! multiple point constraints -! - read(15)(ipompc(i),i=1,nmpc) - read(15)(labmpc(i),i=1,nmpc) - read(15)(ikmpc(i),i=1,nmpc) - read(15)(ilmpc(i),i=1,nmpc) - read(15)(fmpc(i),i=1,nmpc) - read(15)(nodempc(i),i=1,3*mpcend) - read(15)(coefmpc(i),i=1,mpcend) - mpcfree=mpcend+1 -! -! point forces -! - read(15)(nodeforc(i),i=1,2*nforc) - read(15)(ndirforc(i),i=1,nforc) - read(15)(xforc(i),i=1,nforc) - read(15)(ikforc(i),i=1,nforc) - read(15)(ilforc(i),i=1,nforc) - if(nam.gt.0) read(15)(iamforc(i),i=1,nforc) - read(15)(xforcold(i),i=1,nforc) -! -! distributed loads -! - read(15)(nelemload(i),i=1,2*nload) - read(15)(sideload(i),i=1,nload) - read(15)(xload(i),i=1,2*nload) - if(nam.gt.0) read(15)(iamload(i),i=1,2*nload) - read(15)(xloadold(i),i=1,2*nload) - read(15)(cbody(i),i=1,nbody) - read(15)(ibody(i),i=1,3*nbody) - read(15)(xbody(i),i=1,7*nbody) - read(15)(xbodyold(i),i=1,7*nbody) -! -! prestress -! - if(iprestr.gt.0) read(15) (prestr(i),i=1,6*mi(1)*ne) -! -! labels -! - read(15)(prlab(i),i=1,nprint) - read(15)(prset(i),i=1,nprint) - read(15)(filab(i),i=1,nlabel) -! -! elastic constants -! - read(15)(elcon(i),i=1,(ncmat_+1)*ntmat_*nmat) - read(15)(nelcon(i),i=1,2*nmat) -! -! density -! - read(15)(rhcon(i),i=1,2*ntmat_*nmat) - read(15)(nrhcon(i),i=1,nmat) -! -! specific heat -! - read(15)(shcon(i),i=1,3*ntmat_*nmat) - read(15)(nshcon(i),i=1,nmat) -! -! conductivity -! - read(15)(cocon(i),i=1,7*ntmat_*nmat) - read(15)(ncocon(i),i=1,nmat) -! -! expansion coefficients -! - read(15)(alcon(i),i=1,7*ntmat_*nmat) - read(15)(nalcon(i),i=1,2*nmat) - read(15)(alzero(i),i=1,nmat) -! -! physical constants -! - read(15)(physcon(i),i=1,3) -! -! plastic data -! - if(iplas.ne.0)then - read(15)(plicon(i),i=1,(2*npmat_+1)*ntmat_*nmat) - read(15)(nplicon(i),i=1,(ntmat_+1)*nmat) - read(15)(plkcon(i),i=1,(2*npmat_+1)*ntmat_*nmat) - read(15)(nplkcon(i),i=1,(ntmat_+1)*nmat) - endif -! -! material orientation -! - if(norien.ne.0)then - read(15)(orname(i),i=1,norien) - read(15)(orab(i),i=1,7*norien) - read(15)(ielorien(i),i=1,ne) - endif -! -! transformations -! - if(ntrans.ne.0)then - read(15)(trab(i),i=1,7*ntrans) - read(15)(inotr(i),i=1,2*nk) - endif -! -! amplitudes -! - if(nam.gt.0)then - read(15)(amname(i),i=1,nam) - read(15)(namta(i),i=1,3*nam-1) - read(15) namta(3*nam) - read(15)(amta(i),i=1,2*namta(3*nam-1)) - endif -! -! temperatures -! - if(ithermal.gt.0)then - if((ne1d.gt.0).or.(ne2d.gt.0))then - read(15)(t0(i),i=1,3*nk) - read(15)(t1(i),i=1,3*nk) - else - read(15)(t0(i),i=1,nk) - read(15)(t1(i),i=1,nk) - endif - if(nam.gt.0) read(15)(iamt1(i),i=1,nk) - read(15)(t1old(i),i=1,nk) - endif -! -! materials -! - read(15)(matname(i),i=1,nmat) - read(15)(ielmat(i),i=1,ne) -! -! temperature, displacement, static pressure, velocity and acceleration -! - read(15)(vold(i),i=1,mt*nk) - if((nmethod.eq.4).or.((nmethod.eq.1).and.(iperturb(1).ge.2))) then - read(15)(veold(i),i=1,mt*nk) - endif -! -! reordering -! - read(15)(nnn(i),i=1,nk) -! -! 1d and 2d elements -! - if((ne1d.gt.0).or.(ne2d.gt.0))then - read(15)(iponor(i),i=1,2*nkon) - read(15)(xnor(i),i=1,infree(1)-1) - read(15)(knor(i),i=1,infree(2)-1) - read(15)(thicke(i),i=1,2*nkon) - read(15)(offset(i),i=1,2*ne) - read(15)(iponoel(i),i=1,infree(4)) - read(15)(inoel(i),i=1,3*(infree(3)-1)) - read(15)(rig(i),i=1,infree(4)) - endif -! -! tie constraints -! - if(ntie.gt.0) then - read(15)((tieset(i,j),i=1,3),j=1,ntie) - endif -! -! cyclic symmetry -! - if(ncs_.gt.0)then - read(15)(ics(i),i=1,ncs_) - endif - if(mcs.gt.0) then - read(15)((cs(i,j),i=1,17),j=1,mcs) - endif -! -! integration point variables -! - read(15)(sti(i),i=1,6*mi(1)*ne) - read(15)(eme(i),i=1,6*mi(1)*ne) - if(nener.eq.1) then - read(15)(ener(i),i=1,mi(1)*ne) - endif - if(nstate_.gt.0)then - read(15)(xstate(i),i=1,nstate_*mi(1)*ne) - endif -! -! control parameters -! - read(15) (ctrl(i),i=1,27) - read(15) (qaold(i),i=1,2) - read(15) output - read(15) ttime -! - close(15) -! - return -! - 15 write(*,*) '*ERROR in restartread: could not open file ',fnrstrt - stop - end - - - - - - - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/restarts.f calculix-ccx-2.3/ccx_2.1/src/restarts.f --- calculix-ccx-2.1/ccx_2.1/src/restarts.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/restarts.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,121 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine restarts(istep,nset,nload,nforc, nboun,nk,ne, - & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi, - & ntrans,ncs_,namtot_,ncmat_,mpcfree,maxlenmpc, - & ne1d,ne2d,nflow,nlabel,iplas, - & nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset, - & iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun, - & xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, - & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload, - & sideload,xload,elcon,nelcon,rhcon,nrhcon, - & alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab, - & ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold, - & ielmat,matname,prlab,prset,filab,vold,nodebounold, - & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, - & iponor,xnor,knor,thickn,thicke,offset,iponoel,inoel,rig, - & shcon,nshcon,cocon,ncocon,ics,sti, - & ener,xstate,jobnamec,infree,nnn,irstrt,inpc,textpart,istat,n, - & key,prestr,iprestr,cbody,ibody,xbody,nbody,xbodyold, - & ttime,qaold,cs,mcs,output,physcon,ctrl,typeboun,iline,ipol,inl, - & ipoinp,inp,fmpc,tieset,ntie,ipoinpc) -! - implicit none -! - character*1 typeboun(*),inpc(*) - character*3 output - character*6 prlab(*) - character*8 lakon(*) - character*20 labmpc(*),sideload(*) - character*80 orname(*),amname(*),matname(*) - character*81 set(*),prset(*),tieset(3,*),cbody(*) - character*87 filab(*) - character*132 jobnamec(*),textpart(16) -! - integer istep,nset,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat, - & ntmat_,npmat_,norien,nam,nprint,mi(2),ntrans,ncs_, - & namtot_,ncmat_,mpcfree,ne1d,ne2d,nflow,nlabel,iplas,nkon, - & ithermal,nmethod,iperturb(*),nstate_,istartset(*),iendset(*), - & ialset(*),kon(*),ipkon(*),nodeboun(*),ndirboun(*),iamboun(*), - & ikboun(*),ilboun(*),ipompc(*),nodempc(*),ikmpc(*),ilmpc(*), - & nodeforc(*),ndirforc(*),iamforc(*),ikforc(*),ilforc(*), - & nelemload(*),iamload(*),nelcon(*),ipoinpc(0:*), - & nrhcon(*),nalcon(*),nplicon(*),nplkcon(*),ielorien(*),inotr(*), - & namta(*),iamt1(*),ielmat(*),nodebounold(*),ndirbounold(*), - & iponor(*),knor(*),iponoel(*),inoel(*),rig(*), - & nshcon(*),ncocon(*),ics(*),infree(*),nnn(*), - & nener,irestartstep,irestartread,irstrt,istat,n,i,key, - & iprestr,mcs,maxlenmpc,iline,ipol,inl, - & ipoinp(2,*),inp(3,*),ntie,ibody(*),nbody -! - real*8 co(*),xboun(*),coefmpc(*),xforc(*),xload(*),elcon(*), - & rhcon(*),alcon(*),alzero(*),plicon(*),plkcon(*),orab(*), - & trab(*),amta(*),t0(*),t1(*),prestr(*),veold(*), - & vold(*),xbounold(*),xforcold(*),xloadold(*),t1old(*),eme(*), - & xnor(*),thickn(*),thicke(*),offset(*), - & shcon(*),cocon(*),sti(*),ener(*),xstate(*), - & ttime,qaold(2),cs(17,*),physcon(*), - & ctrl(*),fmpc(*),xbody(*),xbodyold(*) -! - irestartread=0 - irestartstep=0 -! - do i=1,n - if(textpart(i)(1:4).eq.'READ') then - irestartread=1 - if(irestartstep.eq.0) irestartstep=1 - elseif(textpart(i)(1:5).eq.'STEP=') then - read(textpart(i)(6:15),'(i10)',iostat=istat) irestartstep - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:5).eq.'WRITE') then - irstrt=1 - elseif(textpart(i)(1:10).eq.'FREQUENCY=') then - read(textpart(i)(11:20),'(i10)',iostat=istat) irstrt - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - enddo -! - if(irestartread.eq.1) then - call restartread(istep,nset,nload,nforc, nboun,nk,ne, - & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi, - & ntrans,ncs_,namtot_,ncmat_,mpcfree,maxlenmpc, - & ne1d,ne2d,nflow,nlabel,iplas, - & nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset, - & iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun, - & xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, - & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload, - & sideload,xload,elcon,nelcon,rhcon,nrhcon, - & alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab, - & ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold, - & ielmat,matname,prlab,prset,filab,vold,nodebounold, - & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, - & iponor,xnor,knor,thickn,thicke,offset,iponoel,inoel,rig, - & shcon,nshcon,cocon,ncocon,ics,sti, - & ener,xstate,jobnamec,infree,nnn,irestartstep,prestr,iprestr, - & cbody,ibody,xbody,nbody,xbodyold,ttime,qaold,cs,mcs, - & output,physcon,ctrl,typeboun,fmpc,tieset,ntie) - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/restartshort.f calculix-ccx-2.3/ccx_2.1/src/restartshort.f --- calculix-ccx-2.1/ccx_2.1/src/restartshort.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/restartshort.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,327 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine restartshort(nset,nload,nbody,nforc,nboun,nk,ne, - & nmpc,nalset,nmat,ntmat,npmat,norien,nam,nprint,mi, - & ntrans,ncs,namtot,ncmat,memmpc,ne1d,ne2d,nflow, - & set,meminset,rmeminset,jobnamec,irestartstep,icntrl,ithermal, - & nener,nstate_,ntie) -! -! istartset := meminset -! iendset := rmeminset -! - implicit none -! - character*81 set(*) - character*132 fnrstrt,jobnamec(*) -! - integer istep,nset,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat, - & ntmat,npmat,norien,nam,nprint,mi(2),ntrans,ncs, - & namtot,ncmat,memmpc,ne1d,ne2d,nflow,infree(4), - & nmethod,iperturb,meminset(*),rmeminset(*), - & i,j,k,ipos,icntrl,nener,irestartstep,im0,im1,im2,mem,iact, - & istat,nkon,nlabel,iplas,ithermal,nstate_,iprestr,maxlenmpc, - & mcs,ntie,nbody -! - if(icntrl.eq.0) then -! -! determining the name of the restart file -! - ipos=index(jobnamec(1),char(0)) - fnrstrt(1:ipos-1)=jobnamec(1)(1:ipos-1) - fnrstrt(ipos:ipos+3)=".rin" - do i=ipos+4,132 - fnrstrt(i:i)=' ' - enddo -! -! opening the restart file -! - open(15,file=fnrstrt,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', - & err=15) -! - do -! - read(15,iostat=istat)istep - if(istat.lt.0) then - write(*,*) '*ERROR in restartshort: requested step' - write(*,*) ' is not in the restart file' - stop - endif -! -! reading the number of sets -! - read(15)nset -! - if(istep.eq.irestartstep) exit -! - read(15)nalset -! -! load size -! - read(15)nload - read(15)nbody - read(15)nforc - read(15)nboun - read(15)nflow -! -! mesh size -! - read(15)nk - read(15)ne - read(15)nkon - read(15)(mi(i),i=1,2) -! -! constraint size -! - read(15)nmpc - read(15)memmpc - read(15)maxlenmpc -! -! material size -! - read(15)nmat - read(15)ntmat - read(15)npmat - read(15)ncmat -! -! transformation size -! - read(15)norien - read(15)ntrans -! -! amplitude size -! - read(15)nam - read(15)namtot -! -! print size -! - read(15)nprint - read(15)nlabel -! -! tie size -! - read(15)ntie -! -! cyclic symmetry size -! - read(15)ncs - read(15)mcs -! -! 1d and 2d element size -! - read(15)ne1d - read(15)ne2d - read(15)(infree(i),i=1,4) -! -! procedure info -! - read(15)nmethod - read(15)iperturb - read(15)nener - read(15)iplas - read(15)ithermal - read(15)nstate_ - read(15)iprestr -! -! skipping the next entries -! - call skip(nset,nalset,nload,nbody, - & nforc,nboun,nflow,nk,ne,nkon, - & mi,nmpc,memmpc,nmat,ntmat,npmat,ncmat,norien, - & ntrans,nam,nprint,nlabel,ncs,ne1d,ne2d,infree, - & nmethod,iperturb,nener,iplas,ithermal,nstate_,iprestr, - & mcs,ntie) -! - enddo -! - close(15) -! - return - endif -! -! determining the name of the restart file -! - ipos=index(jobnamec(1),char(0)) - fnrstrt(1:ipos-1)=jobnamec(1)(1:ipos-1) - fnrstrt(ipos:ipos+3)=".rin" - do i=ipos+4,132 - fnrstrt(i:i)=' ' - enddo -! -! opening the restart file -! - open(15,file=fnrstrt,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', - & err=15) -! - do -! - read(15,iostat=istat)istep - if(istat.lt.0) then - write(*,*) '*ERROR in restartshort: requested step' - write(*,*) ' is not in the restart file' - stop - endif -! -! set size -! - read(15)nset - read(15)nalset -! -! load size -! - read(15)nload - read(15)nbody - read(15)nforc - read(15)nboun - read(15)nflow -! -! mesh size -! - read(15)nk - read(15)ne - read(15)nkon - read(15)(mi(i),i=1,2) -! -! constraint size -! - read(15)nmpc - read(15)memmpc - read(15)maxlenmpc -! -! material size -! - read(15)nmat - read(15)ntmat - read(15)npmat - read(15)ncmat -! -! transformation size -! - read(15)norien - read(15)ntrans -! -! amplitude size -! - read(15)nam - read(15)namtot -! -! print size -! - read(15)nprint - read(15)nlabel -! -! tie size -! - read(15)ntie -! -! cyclic symmetry size -! - read(15)ncs - read(15)mcs -! -! 1d and 2d element size -! - read(15)ne1d - read(15)ne2d - read(15)(infree(i),i=1,4) -! -! procedure info -! - read(15)nmethod - read(15)iperturb - read(15)nener - read(15)iplas - read(15)ithermal - read(15)nstate_ - read(15)iprestr -! - if(istep.eq.irestartstep) exit -! -! skipping the next entries -! - call skip(nset,nalset,nload,nbody,nforc,nboun,nflow,nk,ne,nkon, - & mi,nmpc,memmpc,nmat,ntmat,npmat,ncmat,norien,ntrans, - & nam,nprint,nlabel,ncs,ne1d,ne2d,infree,nmethod, - & iperturb,nener,iplas,ithermal,nstate_,iprestr,mcs,ntie) -! - enddo -! -! sets -! - read(15)(set(i),i=1,nset) -! -! the contents of istartset is temporarily stored in meminset -! - read(15)(meminset(i),i=1,nset) -! -! the contents of iendset is temporarily stored in rmeminset -! - read(15)(rmeminset(i),i=1,nset) -! -! reordering the information of istartset, iendset and ialset -! into meminset and rmeminset -! - iact=0 - do j=1,nalset - if(iact.eq.0) then - do k=1,nset - if(meminset(k).eq.j) then - meminset(k)=0 - mem=0 - iact=1 - exit - endif - enddo - if(k.gt.nset) cycle - endif - mem=mem+1 - im2=im1 - im1=im0 - read(15) im0 - if(im0.gt.0) then - meminset(k)=meminset(k)+1 - else -! -! im0<0 and two elements are already stored -! - meminset(k)=meminset(k)+(im2-im1)/im0-1 - endif - if(rmeminset(k).eq.j) then - iact=0 - rmeminset(k)=mem -! -! make set k ineligible in further iterations -! - meminset(k)=-meminset(k) - endif - enddo -! -! restore the sign of meminset -! - do k=1,nset - meminset(k)=-meminset(k) - enddo -! - close(15) -! - return -! - 15 write(*,*) '*ERROR in restartshort: could not open file ',fnrstrt - stop - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/restartwrite.f calculix-ccx-2.3/ccx_2.1/src/restartwrite.f --- calculix-ccx-2.1/ccx_2.1/src/restartwrite.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/restartwrite.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,420 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine restartwrite(istepnew,nset,nload,nforc, nboun,nk,ne, - & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi, - & ntrans,ncs_,namtot_,ncmat_,mpcend,maxlenmpc, - & ne1d,ne2d,nflow,nlabel,iplas, - & nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset, - & iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun, - & xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, - & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload, - & sideload,xload,elcon,nelcon,rhcon,nrhcon, - & alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab, - & ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold, - & ielmat,matname,prlab,prset,filab,vold,nodebounold, - & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, - & iponor,xnor,knor,thickn,thicke,offset,iponoel,inoel,rig, - & shcon,nshcon,cocon,ncocon,ics,sti, - & ener,xstate,jobnamec,infree,nnn,prestr,iprestr,cbody, - & ibody,xbody,nbody,xbodyold,ttime,qaold,cs,mcs,output, - & physcon,ctrl,typeboun,fmpc,tieset,ntie) -! - implicit none -! - logical op -! - character*1 typeboun(*) - character*3 output - character*6 prlab(*) - character*8 lakon(*) - character*20 labmpc(*),sideload(*) - character*80 orname(*),amname(*),matname(*) - character*81 set(*),prset(*),tieset(3,*),cbody(*) - character*87 filab(*) - character*132 fnrstrt,jobnamec(*) -! - integer nset,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat, - & ntmat_,npmat_,norien,nam,nprint,mi(2),ntrans,ncs_, - & namtot_,ncmat_,mpcend,ne1d,ne2d,nflow,nlabel,iplas,nkon, - & ithermal,nmethod,iperturb(*),nstate_,istartset(*),iendset(*), - & ialset(*),kon(*),ipkon(*),nodeboun(*),ndirboun(*),iamboun(*), - & ikboun(*),ilboun(*),ipompc(*),nodempc(*),ikmpc(*),ilmpc(*), - & nodeforc(*),ndirforc(*),iamforc(*),ikforc(*),ilforc(*), - & nelemload(*),iamload(*),nelcon(*), - & nrhcon(*),nalcon(*),nplicon(*),nplkcon(*),ielorien(*),inotr(*), - & namta(*),iamt1(*),ielmat(*),nodebounold(*),ndirbounold(*), - & iponor(*),knor(*),iponoel(*),inoel(*),rig(*), - & nshcon(*),ncocon(*),ics(*),infree(*),nnn(*),i,ipos, - & nener,iprestr,istepnew,maxlenmpc,mcs,j,ntie, - & ibody(*),nbody,mt -! - real*8 co(*),xboun(*),coefmpc(*),xforc(*),xload(*),elcon(*), - & rhcon(*),alcon(*),alzero(*),plicon(*),plkcon(*),orab(*), - & trab(*),amta(*),t0(*),t1(*),prestr(*),veold(*), - & vold(*),xbounold(*),xforcold(*),xloadold(*),t1old(*),eme(*), - & xnor(*),thickn(*),thicke(*),offset(*), - & shcon(*),cocon(*),sti(*),ener(*),xstate(*), - & qaold(2),cs(17,*),physcon(*),ctrl(*), - & ttime,fmpc(*),xbody(*),xbodyold(*) -! - mt=mi(2)+1 -! - ipos=index(jobnamec(1),char(0)) - fnrstrt(1:ipos-1)=jobnamec(1)(1:ipos-1) - fnrstrt(ipos:ipos+4)=".rout" - do i=ipos+5,132 - fnrstrt(i:i)=' ' - enddo -! -! check whether the restart file exists and is opened -! - inquire(FILE=fnrstrt,OPENED=op,err=152) -! - if(.not.op) then - open(15,file=fnrstrt,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', - & err=151) - endif -! - write(15)istepnew -! -! set size -! - write(15)nset - write(15)nalset -! -! load size -! - write(15)nload - write(15)nbody - write(15)nforc - write(15)nboun - write(15)nflow -! -! mesh size -! - write(15)nk - write(15)ne - write(15)nkon - write(15)(mi(i),i=1,2) -! -! constraint size -! - write(15)nmpc - write(15)mpcend - write(15)maxlenmpc -! -! material size -! - write(15)nmat - write(15)ntmat_ - write(15)npmat_ - write(15)ncmat_ -! -! transformation size -! - write(15)norien - write(15)ntrans -! -! amplitude size -! - write(15)nam - write(15)namtot_ -! -! print size -! - write(15)nprint - write(15)nlabel -! -! tie size -! - write(15)ntie -! -! cyclic symmetry size -! - write(15)ncs_ - write(15)mcs -! -! 1d and 2d element size -! - write(15)ne1d - write(15)ne2d - write(15)(infree(i),i=1,4) -! -! procedure info -! - write(15)nmethod - write(15)(iperturb(i),i=1,2) - write(15)nener - write(15)iplas - write(15)ithermal - write(15)nstate_ - write(15)iprestr -! -! sets -! - write(15)(set(i),i=1,nset) - write(15)(istartset(i),i=1,nset) - write(15)(iendset(i),i=1,nset) -! -! watch out: the statement -! write(15)(ialset(i),i=nalset) (short form) -! needs less space to store than -! do i=1,nalset -! write(15) ialset(i) (long form) -! enddo -! but cannot be accessed by read statements of the form -! do i=1,nalset -! read(15) im0 -! enddo -! as needed in routine restartshort. Therefore the long form -! is used for ialset. -! - do i=1,nalset - write(15) ialset(i) - enddo -! -! mesh -! - write(15)(co(i),i=1,3*nk) - write(15)(kon(i),i=1,nkon) - write(15)(ipkon(i),i=1,ne) - write(15)(lakon(i),i=1,ne) -! -! single point constraints -! - write(15)(nodeboun(i),i=1,nboun) - write(15)(ndirboun(i),i=1,nboun) - write(15)(typeboun(i),i=1,nboun) - write(15)(xboun(i),i=1,nboun) - write(15)(ikboun(i),i=1,nboun) - write(15)(ilboun(i),i=1,nboun) - if(nam.gt.0) write(15)(iamboun(i),i=1,nboun) - write(15)(nodebounold(i),i=1,nboun) - write(15)(ndirbounold(i),i=1,nboun) - write(15)(xbounold(i),i=1,nboun) -! -! multiple point constraints -! - write(15)(ipompc(i),i=1,nmpc) - write(15)(labmpc(i),i=1,nmpc) - write(15)(ikmpc(i),i=1,nmpc) - write(15)(ilmpc(i),i=1,nmpc) - write(15)(fmpc(i),i=1,nmpc) - write(15)(nodempc(i),i=1,3*mpcend) - write(15)(coefmpc(i),i=1,mpcend) -! -! point forces -! - write(15)(nodeforc(i),i=1,2*nforc) - write(15)(ndirforc(i),i=1,nforc) - write(15)(xforc(i),i=1,nforc) - write(15)(ikforc(i),i=1,nforc) - write(15)(ilforc(i),i=1,nforc) - if(nam.gt.0) write(15)(iamforc(i),i=1,nforc) - write(15)(xforcold(i),i=1,nforc) -! -! distributed loads -! - write(15)(nelemload(i),i=1,2*nload) - write(15)(sideload(i),i=1,nload) - write(15)(xload(i),i=1,2*nload) - if(nam.gt.0) write(15)(iamload(i),i=1,2*nload) - write(15)(xloadold(i),i=1,2*nload) - write(15)(cbody(i),i=1,nbody) - write(15)(ibody(i),i=1,3*nbody) - write(15)(xbody(i),i=1,7*nbody) - write(15)(xbodyold(i),i=1,7*nbody) -! -! prestress -! - if(iprestr.gt.0) write(15) (prestr(i),i=1,6*mi(1)*ne) -! -! labels -! - write(15) (prlab(i),i=1,nprint) - write(15) (prset(i),i=1,nprint) - write(15)(filab(i),i=1,nlabel) -! -! elastic constants -! - write(15)(elcon(i),i=1,(ncmat_+1)*ntmat_*nmat) - write(15)(nelcon(i),i=1,2*nmat) -! -! density -! - write(15)(rhcon(i),i=1,2*ntmat_*nmat) - write(15)(nrhcon(i),i=1,nmat) -! -! specific heat -! - write(15)(shcon(i),i=1,3*ntmat_*nmat) - write(15)(nshcon(i),i=1,nmat) -! -! conductivity -! - write(15)(cocon(i),i=1,7*ntmat_*nmat) - write(15)(ncocon(i),i=1,nmat) -! -! expansion coefficients -! - write(15)(alcon(i),i=1,7*ntmat_*nmat) - write(15)(nalcon(i),i=1,2*nmat) - write(15)(alzero(i),i=1,nmat) -! -! physical constants -! - write(15)(physcon(i),i=1,3) -! -! plastic data -! - if(iplas.ne.0)then - write(15)(plicon(i),i=1,(2*npmat_+1)*ntmat_*nmat) - write(15)(nplicon(i),i=1,(ntmat_+1)*nmat) - write(15)(plkcon(i),i=1,(2*npmat_+1)*ntmat_*nmat) - write(15)(nplkcon(i),i=1,(ntmat_+1)*nmat) - endif -! -! material orientation -! - if(norien.ne.0)then - write(15)(orname(i),i=1,norien) - write(15)(orab(i),i=1,7*norien) - write(15)(ielorien(i),i=1,ne) - endif -! -! transformations -! - if(ntrans.ne.0)then - write(15)(trab(i),i=1,7*ntrans) - write(15)(inotr(i),i=1,2*nk) - endif -! -! amplitudes -! - if(nam.gt.0)then - write(15)(amname(i),i=1,nam) - write(15)(namta(i),i=1,3*nam-1) - write(15) namta(3*nam) - write(15)(amta(i),i=1,2*namta(3*nam-1)) - endif -! -! temperatures -! - if(ithermal.gt.0)then - if((ne1d.gt.0).or.(ne2d.gt.0))then - write(15)(t0(i),i=1,3*nk) - write(15)(t1(i),i=1,3*nk) - else - write(15)(t0(i),i=1,nk) - write(15)(t1(i),i=1,nk) - endif - if(nam.gt.0) write(15)(iamt1(i),i=1,nk) - write(15)(t1old(i),i=1,nk) - endif -! -! materials -! - write(15)(matname(i),i=1,nmat) - write(15)(ielmat(i),i=1,ne) -! -! temperature, displacement, static pressure, velocity and acceleration -! - write(15)(vold(i),i=1,mt*nk) - if((nmethod.eq.4).or.((nmethod.eq.1).and.(iperturb(1).ge.2))) then - write(15)(veold(i),i=1,mt*nk) - endif -! -! reordering -! - write(15)(nnn(i),i=1,nk) -! -! 1d and 2d elements -! - if((ne1d.gt.0).or.(ne2d.gt.0))then - write(15)(iponor(i),i=1,2*nkon) - write(15)(xnor(i),i=1,infree(1)-1) - write(15)(knor(i),i=1,infree(2)-1) - write(15)(thicke(i),i=1,2*nkon) - write(15)(offset(i),i=1,2*ne) - write(15)(iponoel(i),i=1,infree(4)) - write(15)(inoel(i),i=1,3*(infree(3)-1)) - write(15)(rig(i),i=1,infree(4)) - endif -! -! tie constraints -! - if(ntie.gt.0) then - write(15)((tieset(i,j),i=1,3),j=1,ntie) - endif -! -! cyclic symmetry -! - if(ncs_.gt.0)then - write(15)(ics(i),i=1,ncs_) - endif - if(mcs.gt.0) then - write(15)((cs(i,j),i=1,17),j=1,mcs) - endif -! -! integration point variables -! - write(15)(sti(i),i=1,6*mi(1)*ne) - write(15)(eme(i),i=1,6*mi(1)*ne) - if(nener.eq.1) then - write(15)(ener(i),i=1,mi(1)*ne) - endif - if(nstate_.gt.0)then - write(15)(xstate(i),i=1,nstate_*mi(1)*ne) - endif -! -! control parameters -! - write(15) (ctrl(i),i=1,27) - write(15) (qaold(i),i=1,2) - write(15) output - write(15) ttime -! - return -! - 151 write(*,*) '*ERROR in restartwrite: could not open file ',fnrstrt - stop -! - 152 write(*,*) '*ERROR in restartwrite: could not inquire file ', - & fnrstrt - stop - end - - - - - - - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/restrictor.f calculix-ccx-2.3/ccx_2.1/src/restrictor.f --- calculix-ccx-2.1/ccx_2.1/src/restrictor.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/restrictor.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1098 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine restrictor(node1,node2,nodem,nelem,lakon,kon,ipkon, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,cp,r,physcon,dvi,numf,set - & ,shcon,nshcon,rhcon,nrhcon,ntmat_,mi) -! -! pressure loss element with partial total head loss -! - implicit none -! - logical identity,crit,isothermal - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, - & ielprop(*),nodef(5),idirf(5),index,iflag, - & inv,ipkon(*),kon(*),kgas,icase,k_oil,nshcon(*), - & nrhcon(*),ntmat_,mi(2) -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,R,d, - & Tt1,Tt2,pt1,pt2,cp,physcon(3),km1,dvi, - & kp1,kdkm1,reynolds,kdkp1, - & pt2pt1,pt1pt2,pt1pt2_crit,qred_crit,qred1,qred2,zeta, - & A1,A2,root, expon1,expon2,expon3,fact1,fact2,sqrt,pi, - & pt2_lim,M2,M1,xflow_oil,T1,T2,phi, - & shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),zeta_phi,Aeff, - & C2,tdkp1 -! - phi=0.d0 - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif (iflag.eq.1)then -! - isothermal=.false. - index=ielprop(nelem) - kappa=(cp/(cp-R)) - kp1=kappa+1d0 - km1=kappa-1d0 -! -! defining surfaces for branches elements -! - if(lakon(nelem)(2:6).eq.'REBRJ') then - if(nelem.eq.int(prop(index+2))) then - A1=prop(index+5) - A2=A1 - elseif(nelem.eq.int(prop(index+3)))then - A1=prop(index+6) - A2=A1 - endif - elseif(lakon(nelem)(2:6).eq.'REBRS') then - if(nelem.eq.int(prop(index+2))) then - A1=prop(index+5) - A2=A1 - elseif(nelem.eq.int(prop(index+3)))then - A1=prop(index+6) - A2=A1 - endif -! -! for other Restrictor elements -! - else if (lakon(nelem)(2:5).eq.'REUS' ) then - A1=prop(index+1) - A2=prop(index+2) - if(A1.gt.A2) then - A1=A2 - endif - else - A1=prop(index+1) - A2=prop(index+2) - endif -! - zeta=1.d0 -! - pt1=v(2,node1) - pt2=v(2,node2) -! - if(pt1.ge.pt2) then - inv=1 - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) - else - inv=-1 - pt1=v(2,node2) - pt2=v(2,node1) - Tt1=v(0,node2)+physcon(1) - Tt2=v(0,node1)+physcon(1) - endif -! - pt1pt2=pt1/pt2 - pt2pt1=1/pt1pt2 - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 -! - if(.not.isothermal) then - pt1pt2_crit=(0.5d0*kp1)**(zeta*kdkm1) - else - pt1pt2_crit=0.5d0*(3*kappa-1)**(zeta*kdkm1) - endif -! - if(pt1pt2.gt.pt1pt2_crit) then - crit=.true. - pt1pt2=pt1pt2_crit - endif -! - if(A1.le.A2) then -! - - Qred1=dsqrt(kappa/R)*pt1pt2**(-0.5d0*kp1/(kappa*zeta)) - & *dsqrt(2.d0/km1*(pt1pt2**(km1/(kappa*zeta))-1d0)) -! - Qred2=pt1pt2*A1/A2*Qred1 -! - if(.not.isothermal) then - Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1) - & **(-0.5d0*kp1/km1) - else - Qred_crit=dsqrt(1/R)*(1+0.5*km1/kappa) - & **(-0.5d0*kp1/km1) - endif -! - if (Qred2.lt.Qred_crit) then - if((Qred1.gt.Qred_crit).or.(pt1pt2.gt.pt1pt2_crit)) then - xflow=inv*A1*pt1*Qred_crit/dsqrt(Tt1) - else - xflow=inv*A1*pt1*Qred1/dsqrt(Tt1) - endif - else - call pt2_lim_calc(pt1,a2,a1,kappa,zeta,pt2_lim) -! - xflow=inv*A2*pt2_lim*Qred_crit/dsqrt(Tt2) -! - endif -! - else - Qred2=dsqrt(kappa/R)*pt1pt2**(-0.5d0*kp1/(kappa*zeta)) - & *dsqrt(2.d0/km1*(pt1pt2**(km1/(kappa*zeta))-1d0)) - Qred1=pt2pt1*A2/A1*Qred2 - Qred_crit=(1.d0+0.5d0*km1)**(-0.5d0*kp1/km1) -! - if(Qred2.gt.Qred_crit) then - xflow=inv*A2*pt2*Qred_crit/dsqrt(Tt2) - else - xflow=inv*A2*pt2*Qred2/dsqrt(Tt2) - endif - endif - - pt2pt1=pt2/pt1 - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - tdkp1=2.d0/kp1 - C2=tdkp1**kdkm1 - if(A1.gt.A2) then - Aeff=A2 - else - Aeff=A1 - endif - if(pt2pt1.gt.C2) then - xflow=inv*pt1*Aeff*dsqrt(2.d0*kdkm1*pt2pt1**(2.d0/kappa) - & *(1.d0-pt2pt1**(1.d0/kdkm1))/r)/dsqrt(Tt1) - else - xflow=inv*pt1*Aeff*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ - & dsqrt(Tt1) - endif -! - elseif (iflag.eq.2)then -! - numf=4 - isothermal=.false. - pi=4.d0*datan(1.d0) - kappa=(cp/(cp-R)) - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - kdkp1=kappa/kp1 - index=ielprop(nelem) -! - pt1=v(2,node1) - pt2=v(2,node2) -! - if(pt1.ge.pt2) then - inv=1 - else - inv=-1 - endif -! -! defining surfaces and oil properties for branches elements -! - xflow_oil=-12345678. - if(lakon(nelem)(2:6).eq.'REBRJ') then - if(nelem.eq.int(prop(index+2))) then - A1=prop(index+5) - A2=A1 - xflow_oil=prop(index+9) - k_oil=int(prop(index+11)) - elseif(nelem.eq.int(prop(index+3)))then - A1=prop(index+6) - A2=A1 - xflow_oil=prop(index+10) - k_oil=int(prop(index+11)) - endif - elseif(lakon(nelem)(2:6).eq.'REBRS') then - if(nelem.eq.int(prop(index+2))) then - A1=prop(index+5) - A2=A1 - if(lakon(nelem)(2:8).eq.'REBRSI1') then - xflow_oil=prop(index+11) - k_oil=int(prop(index+13)) - else - xflow_oil=prop(index+9) - k_oil=int(prop(index+11)) - endif - elseif(nelem.eq.int(prop(index+3)))then - A1=prop(index+6) - A2=A1 - if(lakon(nelem)(2:8).eq.'REBRSI1') then - xflow_oil=prop(index+12) - k_oil=int(prop(index+13)) - else - xflow_oil=prop(index+10) - k_oil=int(prop(index+11)) - endif - endif -! -! for other Restrictor elements -! - - else - if(inv.gt.0.d0) then - A1=prop(index+1) - A2=prop(index+2) - else - A1=prop(index+2) - A2=prop(index+1) - endif -! - if(lakon(nelem)(2:5).eq.'REEL') then - xflow_oil=prop(index+4) - k_oil=int(prop(index+5)) - elseif((lakon(nelem)(2:7).eq.'RELOID').or. - & (lakon(nelem)(2:5).eq.'REUS').or. - & (lakon(nelem)(2:5).eq.'REEN').or. - & (lakon(nelem)(2:5).eq.'REEX').or. - & (lakon(nelem)(2:7).eq.'REWAOR').or. - & (lakon(nelem)(2:7).eq.'RELOLI')) then - xflow_oil=prop(index+5) - k_oil=int(prop(index+6)) - elseif((lakon(nelem)(2:5).eq.'RECO').or. - & (lakon(nelem)(2:7).eq.'REBEMA').or. - & (lakon(nelem)(2:7).eq.'REBEMI').or. - & (lakon(nelem)(2:8).eq.'REBEIDC')) then - xflow_oil=prop(index+6) - k_oil=int(prop(index+7)) - elseif(lakon(nelem)(2:8).eq.'REBEIDR') then - xflow_oil=prop(index+8) - k_oil=int(prop(index+9)) - endif - endif -! - if(pt1.gt.pt2) then - inv=1 - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - icase=0 - call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) - call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 - - elseif(pt1.eq.pt2) then - inv=1 - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) -! - pt2=pt2-0.01*pt2 - icase=0 - call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) - call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! - else - inv=-1 - pt1=v(2,node2) - pt2=v(2,node1) - xflow=-v(1,nodem) - Tt1=v(0,node2)+physcon(1) - Tt2=v(0,node1)+physcon(1) - icase=0 - call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) - call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 - endif - -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 -! -! calculation of the dynamic viscosity -! - if( lakon(nelem)(2:3).eq.'RE') then - icase=0 - endif -! - if (A1.le.A2) then - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif - else - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T2,dvi) - endif - endif -! -! Reynolds number calculation -! - if (lakon(nelem)(2:5).eq.'REBR') then - d=dsqrt(4d0*A1/Pi) - reynolds=dabs(xflow)*d/(dvi*A1) - else - d=prop(index+3) - if(A1.le.A2) then - reynolds=dabs(xflow)*d/(dvi*A1) - else - reynolds=dabs(xflow)*d/(dvi*A2) - endif - endif - - if(xflow_oil.lt.1E-10) then - xflow_oil=0d0 - endif -! -! BEND MILLER with oil -! - if(lakon(nelem)(2:7).eq.'REBEMI') then - if(xflow_oil.ne.0d0) then -! - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) -! - zeta=phi*zeta - else - - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - phi=1.d0 - endif -! -! long orifice idelchick with oil -! - elseif(lakon(nelem)(2:7).eq.'RELOID') then - if(xflow_oil.ne.0d0) then -! - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) - zeta=phi*zeta - - else - - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - phi=1.d0 - endif -! -! every other zeta elements with/without oil -! - else -! - - if(xflow_oil.ne.0d0) then - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - zeta=phi*zeta - else - phi=1.d0 - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - zeta=phi*zeta - endif - endif -! - if(zeta.lt.0) then - pt1=v(2,node1) - pt2=v(2,node2) - xflow=v(1,nodem) - Tt2=v(0,node2) - Tt1=v(0,node1) - call ts_calc(xflow,Tt1,Pt1,kappa,r,A1,T1,icase) - call ts_calc(xflow,Tt2,Pt2,kappa,r,A2,T2,icase) -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! - endif -! - if(.not.isothermal) then - pt1pt2_crit=(0.5d0*kp1)**(zeta*kdkm1) - else - pt1pt2_crit=0.5d0*(3*kappa-1)**(zeta*kdkm1) - endif - pt1pt2=pt1/pt2 -! -! Mach number caclulation -! - M1=dsqrt(2d0/km1*(Tt1/T1-1d0)) - if((1.d0-M1).le.1E-6) then - if(zeta.gt.0d0) then - call limit_case_calc(a2,pt1,Tt2,xflow,zeta,r,kappa, - & pt2_lim,M2) -! - endif - else - M2=dsqrt(2d0/km1*(Tt2/T2-1d0)) - endif -! -! Section A1 smaller than or equal to section A2 -! or for all BRANCHES ELEMENTS -! - if (A1.le.A2) then -! -! definition of the reduced mass flows -! - if(zeta.gt.0) then -! - Qred1=dsqrt(kappa/R)*pt1pt2**(-0.5d0*kp1/(kappa*zeta)) - & *dsqrt(2.d0/km1*(pt1pt2**(km1/(kappa*zeta))-1d0)) -! - elseif(zeta.lt.0d0) then -! - Qred1=dabs(xflow)*dsqrt(Tt1)/(pt1*A1) -! - endif -! - Qred2=pt1pt2*A1/A2*Qred1 -! - if(.not.isothermal) then - Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1) - & **(-0.5d0*kp1/km1) - else - Qred_crit=dsqrt(1/R)*(1+0.5*km1/kappa) - & **(-0.5d0*kp1/km1) - endif -! -! icase zeta greater than zero -! - if(zeta.gt.0) then -! -! definition of the coefficients -! - sqrt=dsqrt(R*Tt1/kappa) - expon1=-0.5d0*kp1/(zeta*kappa) - fact1=pt1pt2**expon1 - expon2=km1/(zeta*kappa) - fact2=pt1pt2**expon2 - expon3=1d0/(zeta*kappa) - root=2d0/km1*(fact2-1d0) -! - if(Qred2.lt.Qred_crit) then -! - if((Qred1.lt.Qred_crit) - & .and.(pt1pt2.lt.pt1pt2_crit))then -! -! section 1 is not critical -! -! residual -! - f=xflow*sqrt/(A1*Pt1)-fact1*dsqrt(root) -! -! pressure node1 -! - df(1)=-xflow*sqrt/(A1*Pt1**2)+ - & fact1/pt1*dsqrt(root) - & *(-expon1-expon3*fact2/root) -! -! temperature node1 -! - df(2)=0.5d0*xflow*dsqrt(R/(kappa*Tt1))/(A1*Pt1) -! -! mass flow -! - df(3)=inv*sqrt/(A1*Pt1) -! -! pressure node2 -! - df(4)=fact1/pt2*dsqrt(root)* - & (expon1+expon3*fact2/root) -! - else -! -! section1 is critical -! - f=xflow*sqrt/(pt1*A1)-dsqrt(R/kappa)*qred_crit -! -! pressure node1 -! - df(1)=-xflow*sqrt/(A1*pt1**2) -! -! temperature node1 -! - df(2)=0.5d0*xflow*dsqrt(R/kappa) - & /(pt1*A1*dsqrt(Tt1)) -! -! mass flow -! - df(3)=inv*sqrt/(A1*pt1) -! -! pressure node2 -! - df(4)=0.d0 -! - endif -! - else -! -! section A2 critical -! - call pt2_lim_calc(pt1,a2,a1,kappa,zeta,pt2_lim) - pt1pt2=pt1/pt2_lim -! - fact1=pt1pt2**expon1 -! - fact2=pt1pt2**expon2 -! - root=2d0/km1*(fact2-1d0) -! - f=xflow*sqrt/(A1*Pt1)-fact1*dsqrt(root) -! -! pressure node1 -! - df(1)=-xflow*sqrt/(A1*Pt1**2)+ - & fact1/pt1*dsqrt(root) - & *(-expon1-expon3*fact2/root) -! -! temperature node1 -! - df(2)=0.5d0*xflow*dsqrt(R/(kappa*Tt1))/(A1*Pt1) -! -! mass flow -! - df(3)=inv*sqrt/(A1*Pt1) -! -! pressure node2 -! - df(4)=0 -! - endif -! -! icase zeta less than zero -! - elseif(zeta.lt.0) then -! - expon1=-kp1/(zeta*kappa) - fact1=pt1pt2**expon1 - expon2=km1/(zeta*kappa) - fact2=pt1pt2**expon2 - expon3=1d0/(zeta*kappa) - root=2d0/km1*(fact2-1d0) -! - if(Qred1.lt.Qred_crit) then -! -! section 1 is not critical -! -! residual -! - f=xflow**2*R*Tt1/(A1**2*Pt1**2*Kappa) - & -fact1*root -! -! pressure node1 -! - df(1)=-2*xflow**2*R*Tt1/(A1**2*Pt1**3*Kappa) - & -1/pt1*fact1*(expon1*root - & +2/(zeta*kappa)*fact2) -! -! temperature node1 -! - df(2)=xflow**2*R/(A1**2*Pt1**2*Kappa) -! -! mass flow -! - df(3)=2*xflow*R*Tt1/(A1**2*Pt1**2*Kappa) -! -! pressure node2 -! - df(4)=-(1/Pt2*fact1) - & *(-expon1*root-2/(zeta*kappa)*fact2) -! -! section1 is critical -! - else -! - f=xflow**2*R*Tt1/(A1**2*Pt1**2*Kappa) - & -R/kappa*qred_crit**2 -! -! pressure node1 -! - df(1)=-2*xflow**2*R*Tt1/(A1**2*pt1**3*kappa) -! -! temperature node1 -! - df(2)=xflow**2*R/(A1**2*Pt1**2*Kappa) -! -! mass flow -! - df(3)=2*xflow*R*Tt1/(A1**2*Pt1**2*Kappa) -! -! pressure node2 -! - df(4)=0.d0 -! - endif -! -! zeta = 0 -! - elseif(zeta.eq.0d0) then -! - f=pt1-pt2 -! - df(1)=1 -! - df(2)=0 -! - df(3)=0 -! - df(4)=-1 -! - endif -! - else -! -! A1 greater than A2 -! - Qred2=dabs(xflow)*dsqrt(Tt2)/(A2*Pt2) -! - Qred1=1/pt1pt2*A2/A1*Qred2 -! - Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1) - & **(-0.5d0*kp1/km1) - -! definition of the coefficients -! - if(zeta.gt.0d0) then -! - sqrt=dsqrt(R*Tt1/kappa) -! - expon1=-0.5d0*kp1/(zeta*kappa) - fact1=pt1pt2**expon1 - expon2=km1/(zeta*kappa) - fact2=pt1pt2**expon2 - expon3=1d0/(zeta*kappa) - root=2d0/km1*(fact2-1d0) -! - if(pt1pt2.ge.pt1pt2_crit) then - pt1pt2=pt1pt2_crit - pt2=pt1/pt1pt2_crit - endif -! - if((Qred2.lt.Qred_crit) - & .and.(pt1/pt2.lt.pt1pt2_crit)) then -! -! section 2 is not critical -! -! residual -! - f=xflow*sqrt/(A2*Pt2)-fact1*dsqrt(root) -! -! pressure node1 -! - df(1)=-fact1/pt1*dsqrt(root) - & *(expon1+0.5*dsqrt(2/km1)*expon2*fact2/root) -! -! temperature node1 -! - df(2)=0.5d0*xflow*sqrt/(A2*Pt2*Tt1) -! -! mass flow -! - df(3)=inv*sqrt/(A2*Pt2) -! -! pressure node2 -! - df(4)=-xflow*sqrt/(A2*Pt2**2) - & -fact1/pt2*dsqrt(root)* - & (-expon1-0.5*dsqrt(2/km1)*expon2*fact2/root) -! - else - write(*,*) - & '*WARNING in restrictor: A1 greater A2 critical' -! -! section2 is critical -! - pt2=pt1/pt1pt2_crit -! - f=xflow*dsqrt(Tt1)/(pt2*A2)-qred_crit -! -! pressure node1 -! - df(1)=0 -! -! temperature node1 -! - df(2)=0.5d0*xflow/(A2*pt2*dsqrt(Tt2)) -! -! mass flow -! - df(3)=inv*dsqrt(Tt1)/(A2*pt2) -! -! pressure node2 -! - df(4)=-xflow*dsqrt(Tt1)/(A2*pt2**2) -! - endif -! - elseif(zeta.eq.0d0) then -! - Qred1=dabs(xflow)*dsqrt(Tt1*kappa/R)/(A1*Pt1) - Qred2=dabs(xflow)*dsqrt(Tt2*kappa/R)/(A2*Pt2) - Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1) - & **(-0.5d0*kp1/km1) -! - f=pt1/pt2-1.d0 -! - df(1)=1/pt2 -! - df(2)=0 -! - df(3)=0 -! - df(4)=-pt1/pt2**2 -! - endif - endif -! - elseif(iflag.eq.3) then -! - isothermal=.false. - pi=4.d0*datan(1.d0) - kappa=(cp/(cp-R)) - km1=kappa-1.d0 - kp1=kappa+1.d0 - kdkm1=kappa/km1 - kdkp1=kappa/kp1 - index=ielprop(nelem) -! - pt1=v(2,node1) - pt2=v(2,node2) - if(pt1.ge.pt2) then - inv=1 - else - inv=-1 - endif -! -! defining surfaces for branches elements -! - if(lakon(nelem)(2:6).eq.'REBRJ') then - if(nelem.eq.int(prop(index+2))) then - A1=prop(index+5) - A2=A1 - xflow_oil=prop(index+9) - k_oil=int(prop(index+11)) - elseif(nelem.eq.int(prop(index+3)))then - A1=prop(index+6) - A2=A1 - xflow_oil=prop(index+10) - k_oil=int(prop(index+11)) - endif - elseif(lakon(nelem)(2:6).eq.'REBRS') then - if(nelem.eq.int(prop(index+2))) then - A1=prop(index+5) - A2=A1 - if(lakon(nelem)(2:8).eq.'REBRSI1') then - xflow_oil=prop(index+11) - k_oil=int(prop(index+13)) - else - xflow_oil=prop(index+9) - k_oil=int(prop(index+11)) - endif - elseif(nelem.eq.int(prop(index+3)))then - A1=prop(index+6) - A2=A1 - if(lakon(nelem)(2:8).eq.'REBRSI1') then - xflow_oil=prop(index+12) - k_oil=int(prop(index+13)) - else - xflow_oil=prop(index+10) - k_oil=int(prop(index+11)) - endif - endif -! -! for other Restrictor elements -! - else - A1=prop(index+1) - A2=prop(index+2) - if(lakon(nelem)(2:5).eq.'REEL') then - xflow_oil=prop(index+4) - k_oil=int(prop(index+5)) - elseif((lakon(nelem)(2:7).eq.'RELOID').or. - & (lakon(nelem)(2:5).eq.'REUS').or. - & (lakon(nelem)(2:5).eq.'REEN').or. - & (lakon(nelem)(2:5).eq.'REEX').or. - & (lakon(nelem)(2:7).eq.'REWAOR').or. - & (lakon(nelem)(2:7).eq.'RELOLI')) then - xflow_oil=prop(index+5) - k_oil=int(prop(index+6)) - elseif((lakon(nelem)(2:5).eq.'RECO').or. - & (lakon(nelem)(2:7).eq.'REBEMA').or. - & (lakon(nelem)(2:7).eq.'REBEMI').or. - & (lakon(nelem)(2:8).eq.'REBEIDC')) then - xflow_oil=prop(index+6) - k_oil=int(prop(index+7)) - elseif(lakon(nelem)(2:7).eq.'REBEIDR') then - xflow_oil=prop(index+8) - k_oil=int(prop(index+9)) - endif - endif -! - if(pt1.ge.pt2) then - inv=1 - xflow=v(1,nodem) - Tt1=v(0,node1)+physcon(1) - Tt2=v(0,node2)+physcon(1) - icase=0 - call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) - call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) -! - else - inv=-1 - pt1=v(2,node2) - pt2=v(2,node1) - xflow=-v(1,nodem) - Tt1=v(0,node2)+physcon(1) - Tt2=v(0,node1)+physcon(1) - icase=0 - call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) - call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) -! - endif -! -! calculation of the dynamic viscosity -! - if( lakon(nelem)(2:3).eq.'RE') then - icase=0 - elseif(lakon(nelem)(2:5).eq.'REEX') then - if(lakon(int(prop(index+4)))(2:6).eq.'GAPFA') then - icase=0 - elseif(lakon(int(prop(index+4)))(2:6).eq.'GAPFI') then - icase=1 - endif - endif -! - if (A1.le.A2) then - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T1,dvi) - endif - else - if(dabs(dvi).lt.1E-30) then - kgas=0 - call dynamic_viscosity(kgas,T2,dvi) - endif - endif -! -! Reynolds number calculation -! - if (lakon(nelem)(2:5).eq.'REBR') then - d=dsqrt(4d0*A1/Pi) - reynolds=dabs(xflow)*d/(dvi*A1) - else - d=prop(index+3) - if(A1.le.A2) then - reynolds=dabs(xflow)*d/(dvi*A1) - else - reynolds=dabs(xflow)*d/(dvi*A2) - endif - endif - - if(xflow_oil.lt.1E-10) then - xflow_oil=0d0 - endif -! -! BEND MILLER with oil -! - if(lakon(nelem)(2:7).eq.'REBEMI') then - if(xflow_oil.ne.0d0) then - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) - - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) -! - zeta_phi=phi*zeta - else -! - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - phi=1.d0 -! - endif -! -! long orifice in a wall with oil after Idelchik -! - elseif(lakon(nelem)(2:7).eq.'RELOID') then - if(xflow_oil.ne.0d0) then - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) -! - zeta_phi=phi*zeta - else -! - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - phi=1.d0 - zeta_phi=phi*zeta - endif -! -! every other zeta elements with/without oil -! - else -! - if(xflow_oil.ne.0) then - call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, - & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, - & shcon,rhcon,ntmat_,mi) -! - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) -! - zeta_phi=phi*zeta - else - phi=1.d0 - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - zeta_phi=phi*zeta - endif - endif -! - if(zeta.le.0) then - pt1=v(2,node1) - pt2=v(2,node2) - xflow=v(1,nodem) - Tt1=v(0,node1) - Tt2=v(0,node2) -! - endif -! - if(.not.isothermal) then - pt1pt2_crit=(0.5d0*kp1)**(zeta*kdkm1) - else - pt1pt2_crit=0.5d0*(3*kappa-1)**(zeta*kdkm1) - endif - pt1pt2=pt1/pt2 -! -! Mach number calculation -! - M1=dsqrt(2d0/km1*(Tt1/T1-1d0)) - if((1.d0-M1).le.1E-6) then - if(zeta.gt.0d0) then - call limit_case_calc(a2,pt1,Tt2,xflow,zeta,r,kappa, - & pt2_lim,M2) -! - endif - else - M2=dsqrt(2d0/km1*(Tt2/T2-1d0)) - endif -! - write(1,*) '' - write(1,55) 'In line',int(nodem/1000),' from node',node1, - & ' to node', node2,': air massflow rate=',xflow,'kg/s' - & , ', oil massflow rate=',xflow_oil,'kg/s' - 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) -! - if(lakon(nelem)(4:5).ne.'BR') then -! -! for restrictors -! - if(inv.eq.1) then - write(1,56)' Inlet node ',node1,': Tt1= ',Tt1, - & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, - & 'Bar, M1= ',M1 - write(1,*)' element F ',set(numf) - & (1:20) - write(1,57)' eta= ',dvi,'kg/(m*s), Re= ' - & ,reynolds,', PHI=',phi,', ZETA= ',zeta, - &', ZETA_PHI= ',zeta_phi - write(1,56)' Outlet node ',node2,': Tt2= ',Tt2, - & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1e5, - & 'Bar, M2= ',M2 -! - else if(inv.eq.-1) then - write(1,56)' Inlet node ',node2,': Tt1= ',Tt1, - & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, - & 'Bar, M1= ',M1 - write(1,*)' element F ',set(numf) - & (1:20) - write(1,57)' eta= ',dvi,'kg/(m*s), Re= ' - & ,reynolds,', PHI= ',phi,', ZETA= ',zeta, - &', ZETA_PHI= ',zeta_phi - write(1,56)' Outlet node ',node1,': Tt2= ',Tt2, - & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1e5, - & 'Bar, M2= ',M2 - endif - else -! -! for branches -! - if(inv.eq.1) then - write(1,56)' Inlet node ',node1,': Tt1= ',Tt1, - & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, - & 'Bar, M1= ',M1 - write(1,*)' element B ',set(numf) - & (1:20) - write(1,57)' Eta= ',dvi,' kg/(m*s), Re= ' - &,reynolds,', PHI= ',phi,', ZETA= ',zeta - write(1,56)' Outlet node ',node2,': Tt2= ',Tt2, - & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1E5, - & 'Bar, M2= ',M2 -! - else if(inv.eq.-1) then - write(1,56)' Inlet node ',node2,': Tt1= ',Tt1, - & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, - & 'Bar, M1= ',M1 - write(1,*)' element B ',set(numf) - & (1:20) - write(1,57)' Eta=',dvi,' kg/(m*s), Re= ' - & ,reynolds,', PHI= ',phi,', ZETA= ',zeta - write(1,56)' Outlet node ',node1,': Tt2= ',Tt2, - & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1E5, - & 'Bar, M2= ',M2 - endif - endif - endif - 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f8.5,A,f8.6) - 57 FORMAT(1X,A,G9.4,A,G11.5,A,f8.4,A,f8.4,A,f8.4) -! - - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/resultgas.f calculix-ccx-2.3/ccx_2.1/src/resultgas.f --- calculix-ccx-2.1/ccx_2.1/src/resultgas.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/resultgas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,965 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! construction of the B matrix -! - subroutine resultgas(itg,ieg,ntg,ntm, - & bc,nload,sideload,nelemload,xloadact,lakon,ntmat_, - & v,shcon,nshcon,ipkon,kon,co,nflow, - & iinc,istep,dtime,ttime,time, - & ikforc,ilforc,xforcact,nforc,ielmat,nteq,prop,ielprop, - & nactdog,nacteq,iin,physcon,camt,camf,camp,rhcon,nrhcon, - & ipobody,ibody,xbodyact,nbody,dtheta,vold,xloadold, - & reltime,nmethod,set,mi) -! - implicit none -! - logical identity - character*8 lakonl,lakon(*) - character*20 sideload(*) - character*81 set(*) -! - integer itg(*),ieg(*),ntg,nteq,nflow,nload,ielmat(*),iflag, - & nelemload(2,*),nope,nopes,mint2d,i,j,k,l,nrhcon(*), - & node,imat,ntmat_,id,ntm,ifaceq(8,6),ifacet(6,4),numf, - & ifacew(8,5),node1,node2,nshcon(*),nelem,ig,index,konl(20), - & ipkon(*),kon(*),idof,mi(2), - & iinc,istep,jltyp,nfield,ikforc(*),ipobody(2,*), - & ilforc(*),nforc,nodem,idirf(5),ieq,nactdog(0:3,*),nbody, - & nacteq(0:3,*),ielprop(*),nodef(5),iin,kflag,ibody(3,*),icase, - & inv, index2,nmethod,nelem0,nodem0,nelem1,nodem1,nelem2, - & nodem2,nelemswirl -! - real*8 bc(ntm),xloadact(2,*),cp,h(2),physcon(*),r,dvi,rho, - & xl2(3,8),coords(3),dxsj2,temp,xi,et,weight,xsj2(3), - & gastemp,v(0:mi(2),*),shcon(0:3,ntmat_,*),co(3,*),shp2(7,8), - & field,prop(*),tg1,tg2,dtime,ttime,time,g(3), - & xforcact(*),areaj,xflow,tvar(2),f,df(5),camt(*),camf(*), - & camp(*),tl2(8), - & rhcon(0:1,ntmat_,*),xbodyact(7,*),sinktemp,kappa,a,T,Tt,Pt, - & dtheta,ts1,ts2,xs2(3,7),xk1,xk2,xdenom1,xdenom2,expon,pt1, - & pt2,dt1,dt2,xcst,xnum1,xnum2,Qred_crit,xflow_crit, - & xflow0,xflow1,reltime, - & xflow2,R1,R2,Rout,Rin,Uout,Uin,heat,pi, - & Cp_cor,U,Ct,vold(0:mi(2),*),xloadold(2,*),omega -! - include "gauss.f" -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ - data ifacew /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ - data iflag /2/ -! - kflag=2 -! - tvar(1)=time - tvar(2)=ttime+dtime -! - pi=4.d0*datan(1.d0) -! -! calculating the maximum change in the solution -! - camt(1)=0.d0 - camf(1)=0.d0 - camp(1)=0.d0 - camt(2)=0.5d0 - camf(2)=0.5d0 - camp(2)=0.5d0 -! - do i=1,ntg - node=itg(i) - do j=0,2 - if(nactdog(j,node).eq.0) cycle - idof=nactdog(j,node) - if(j.eq.0) then - if(dabs(bc(idof)).gt.camt(1)) then - camt(1)=dabs(bc(idof)) - camt(2)=node+0.5d0 - endif - elseif(j.eq.1) then - if(dabs(bc(idof)).gt.camf(1)) then - camf(1)=dabs(bc(idof)) - camf(2)=node+0.5d0 - endif - else - if(dabs(bc(idof)).gt.camp(1)) then - camp(1)=dabs(bc(idof)) - camp(2)=node+0.5d0 - endif - endif - enddo - enddo -! -! updating v -! - do i=1,ntg - node=itg(i) - do j=0,2 - if(nactdog(j,node).eq.0) cycle - v(j,node)=v(j,node)+bc(nactdog(j,node))*dtheta - enddo - enddo -! -! testing the validity of the pressures -! - do i=1,ntg - node=itg(i) - if(v(2,node).lt.0) then - write(*,*) 'wrong pressure node ',node - iin=0 - return - endif - enddo -! -! testing validity of temperatures -! - do i=1,ntg - node=itg(i) - if(v(0,node).lt.0) then - iin=0 - return - endif - enddo -! -! testing the validity of the solution for branches elements -! and restrictor. Since the element properties is dependent on -! - do i=1, nflow - nelem=ieg(i) - if ((lakon(nelem)(4:5).eq.'ATR').or. - & (lakon(nelem)(4:5).eq.'RTA')) then - xflow=v(1,kon(ipkon(nelem)+2)) - if(xflow.lt.0d0)then - Write(*,*)'*WARNING in resultgas.f' - write(*,*)'Element',nelem,'of TYPE ABSOLUTE TO RELATIVE' - write(*,*)'The flow direction is no more conform ' - write(*,*)'to element definition' - write(*,*)'Check the pertinence of the results' - endif - elseif(lakon(nelem)(2:3).eq.'RE') then -! - if(lakon(nelem)(4:5).ne.'BR') then - nodem=kon(ipkon(nelem)+2) - xflow=v(1,nodem) - if (xflow.lt.0) then - Write(*,*)'*WARNING in resultgas.f' - write(*,*)'Element',nelem,'of TYPE RESTRICTOR' - write(*,*)'The flow direction is no more conform ' - write(*,*)'to element definition' - write(*,*)'Check the pertinence of the results' - endif -! - elseif(lakon(nelem)(4:5).eq.'BR') then - index=ielprop(nelem) -! - nelem0=int(prop(index+1)) - nodem0=kon(ipkon(nelem0)+2) - xflow0=v(1,nodem0) -! - nelem1=int(prop(index+2)) - nodem1=kon(ipkon(nelem1)+2) - xflow1=v(1,nodem1) -! - nelem2=int(prop(index+3)) - nodem2=kon(ipkon(nelem2)+2) - xflow2=v(1,nodem2) -! - if((xflow0.lt.0).or.(xflow1.lt.0).or.(xflow2.lt.0)) then - Write(*,*)'*WARNING in resultgas.f' - write(*,*)'Element',nelem,'of TYPE BRANCH' - write(*,*)'The flow direction is no more conform ' - write(*,*)'to element definition' - write(*,*)'Check the pertinence of the results' - endif - endif - endif - enddo -! -! node1 or node2 do not belong to GASPIPE or RESTRICTOR element -! - do i=1,ntg - node=itg(i) - nelem=nactdog(3,node) - if(nelem.le.0) then - v(3,node)=v(0,node) - endif - enddo -! -! iteratively solving Tt=T+0.5*v**2/(2*Cp) to obtain T static -! - do i=1,ntg - node=itg(i) - nelem=nactdog(3,node) -! - if (nelem.gt.0) then -! - nodem=kon(ipkon(nelem)+2) - T=v(3,node) - Tt=v(0,node) - Pt=v(2,node) - xflow=v(1,nodem) -! - icase=0 - inv=1 - imat=ielmat(nelem) - call materialdata_tg(imat,ntmat_,v(3,node), - & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho) -! - index=ielprop(nelem) - kappa=(cp/(cp-R)) -! - if((lakon(nelem)(2:5).eq.'GAPF') - & .or.(lakon(nelem)(2:5).eq.'GAPI'))then - A=prop(index+1) - if((lakon(nelem)(2:6).eq.'GAPFA') - & .or.(lakon(nelem)(2:5).eq.'GAPIA'))then - icase=0 - elseif((lakon(nelem)(2:6).eq.'GAPFI') - & .or.(lakon(nelem)(2:5).eq.'GAPII'))then - icase=1 - endif - elseif(lakon(nelem)(2:3).eq.'OR') then - A=prop(index+1) - icase=0 -! - elseif(lakon(nelem)(2:3).eq.'RE') then - index2=ipkon(nelem) - node1=kon(index2+1) - node2=kon(index2+3) -! - if(lakon(nelem)(4:5).eq.'EX') then - if(lakon(int(prop(index+4)))(2:6).eq.'GAPFA') then - icase=0 - elseif(lakon(int(prop(index+4)))(2:6).eq.'GAPFI')then - icase=1 - endif - else - icase=0 - endif -! -! defining the sections -! - if(lakon(nelem)(4:5).eq.'BE') then - a=prop(index+1) -! - elseif(lakon(nelem)(4:5).eq.'BR') then - if(lakon(nelem)(4:6).eq.'BRJ') then - if(nelem.eq.int(prop(index+2)))then - A=prop(index+5) - elseif(nelem.eq.int(prop(index+3))) then - A=prop(index+6) - endif - elseif(lakon(nelem)(4:6).eq.'BRS') then - if(nelem.eq.int(prop(index+2)))then - A=prop(index+5) - elseif(nelem.eq.int(prop(index+3))) then - A=prop(index+6) - endif - endif -! - else -! - if(node.eq.node1) then - a=prop(index+1) - elseif(node.eq.node2) then - a=prop(index+2) - endif - endif - endif -! - if(xflow.lt.0d0) then - inv=-1 - else - inv=1 - endif -! - if(icase.eq.0) then - Qred_crit=dsqrt(kappa/R)*(1.+0.5*(kappa-1.)) - & **(-0.5d0*(kappa+1.)/(kappa-1.)) - else - Qred_crit=dsqrt(1/R)*(1.+0.5*(kappa-1.)/kappa) - & **(-0.5d0*(kappa+1.)/(kappa-1.)) - endif - xflow_crit=inv*Qred_crit*Pt*A/dsqrt(Tt) -! - call ts_calc(xflow,Tt,Pt,kappa,r,a,T,icase) -! - v(3,node)=T -! - if(dabs(v(1,nodem)).ge.dabs(xflow_crit)) then - v(1,nodem)=xflow_crit - if(icase.eq.1) then -! - if(nactdog(0,node2).ne.0) then - index2=ipkon(nelem) - node1=kon(index2+1) - node2=kon(index2+3) - v(3,node2)=v(3,node1) - v(0,node2)=v(3,node2) - & *(1+0.5d0*(kappa-1)/kappa) - - endif - endif - endif -! - endif -! - enddo -! -! reinitialisation of the Bc matrix -! - do i=1,nteq - bc(i)=0.d0 - enddo -! -! determining the residual -! - do i=1,nflow - nelem=ieg(i) - index=ipkon(nelem) - node1=kon(index+1) - nodem=kon(index+2) - node2=kon(index+3) - xflow=v(1,nodem) -! - if(node1.eq.0) then - tg1=v(0,node2) - tg2=tg1 - ts1=v(3,node2) - ts2=Ts1 - elseif(node2.eq.0) then - tg1=v(0,node1) - tg2=tg1 - ts1=v(3,node1) - ts2=ts1 - else - tg1=v(0,node1) - tg2=v(0,node2) - ts1=v(3,node1) - ts2=v(3,node2) - endif - gastemp=(ts1+ts2)/2.d0 -! - imat=ielmat(nelem) -! - call materialdata_tg(imat,ntmat_,gastemp,shcon,nshcon,cp,r,dvi, - & rhcon,nrhcon,rho) - kappa=Cp/(Cp-R) -! -! Definitions of the constant for isothermal flow elements -! - if((lakon(nelem)(2:6).eq.'GAPFI') - & .or.(lakon(nelem)(2:6).eq.'GAPII')) then - if((node1.ne.0).and.(node2.ne.0)) then - A=prop(ielprop(nelem)+1) - pt1=v(2,node1) - pt2=v(2,node2) -! - if(pt1.ge.pt2)then - if(dabs(tg2/ts2-(1+0.5*(kappa-1)/kappa)).lt.1E-5) then - pt2=dabs(xflow)*dsqrt(Tg2*R)/A - & *(1+0.5*(kappa-1)/kappa) - & **(0.5*(kappa+1)/(kappa-1)) -! - endif - tg1=v(0,node1) - ts1=v(3,node1) - call ts_calc(xflow,Tg1,Pt1,kappa,r,a,Ts1,icase) - call ts_calc(xflow,Tg2,Pt2,kappa,r,a,Ts2,icase) - else - pt1=v(2,node2) - pt2=v(2,node1) - if(v(3,nodem).ge.(pt2/pt1))then - pt2=v(3,nodem)*pt1 - endif -! - tg1=v(0,node2) - call ts_calc(xflow,Tg1,Pt1,kappa,r,a,Ts1,icase) - tg2=v(0,node1) - call ts_calc(xflow,Tg2,Pt2,kappa,r,a,Ts2,icase) - endif -! - dt1=tg1/ts1-1d0 - dt2=tg2/ts2-1d0 - xcst=2.d0*Cp*A**2/(R**2) - expon=2.d0*kappa/(kappa-1.d0) - xk1=pt1**2*(ts1/tg1)**expon - xk2=pt2**2*(ts2/tg2)**expon -! - xnum1=xcst*dt1*xk1-xflow**2*ts1 - xdenom1=xcst*xk1*(1.d0-expon*dt1)/ts1+2.d0*xflow**2 - xnum2=xcst*dt2*xk2-xflow**2*ts2 - xdenom2=xcst*xk2*(1.d0-expon*dt2)/ts2+2.d0*xflow**2 -! - endif - endif -! - if(node1.ne.0) then -! -! energy equation contribution node1 -! - if (nacteq(0,node1).ne.0) then - ieq=nacteq(0,node1) -! - if(nacteq(3,node1).eq.0) then - if (xflow.lt.0d0)then - bc(ieq)=bc(ieq)+cp*(tg1-tg2)*xflow - endif -! - elseif((lakon(nelem)(2:6).eq.'GAPFI') - & .or.(lakon(nelem)(2:6).eq.'GAPII')) then - if((nacteq(3,node1).eq.node2)) then -! - bc(ieq)=(ts2+xnum2/xdenom2-ts1-xnum1/xdenom1) -! - endif - endif - endif -! -! mass equation contribution node1 -! - if (nacteq(1,node1).ne.0) then - ieq=nacteq(1,node1) - bc(ieq)=bc(ieq)-xflow - endif - endif -! - if(node2.ne.0) then -! -! energy equation contribution node2 -! - if (nacteq(0,node2).ne.0) then - ieq=nacteq(0,node2) -! - if(nacteq(3,node2).eq.0) then - if (xflow.gt.0d0)then - bc(ieq)=bc(ieq)-cp*(tg2-tg1)*xflow - endif -! - elseif((lakon(nelem)(2:6).eq.'GAPFI') - & .or. (lakon(nelem)(2:6).eq.'GAPII')) then - if(nacteq(3,node2).eq.node1) then -! - bc(ieq)=(ts2+xnum2/xdenom2-ts1-xnum1/xdenom1) -! - endif - endif - endif -! -! mass equation contribution node2 -! - if (nacteq(1,node2).ne.0) then - ieq=nacteq(1,node2) - bc(ieq)=bc(ieq)+xflow - endif - endif -! -! element equation -! - if (nacteq(2,nodem).ne.0) then - ieq=nacteq (2,nodem) -! -! for liquids: determine the gravity vector -! - if(lakon(nelem)(2:3).eq.'LI') then - do j=1,3 - g(j)=0.d0 - enddo - if(nbody.gt.0) then - index=nelem - do - j=ipobody(1,index) - if(j.eq.0) exit - if(ibody(1,j).eq.2) then - g(1)=g(1)+xbodyact(1,j)*xbodyact(2,j) - g(2)=g(2)+xbodyact(1,j)*xbodyact(3,j) - g(3)=g(3)+xbodyact(1,j)*xbodyact(4,j) - endif - index=ipobody(2,index) - if(index.eq.0) exit - enddo - endif - endif -! - call flux(node1,node2,nodem,nelem,lakon,kon,ipkon, - & nactdog,identity, - & ielprop,prop,kflag,v,xflow,f,nodef,idirf,df, - & cp,r,rho,physcon,g,co,dvi,numf,vold,set,shcon, - & nshcon,rhcon,nrhcon,ntmat_,mi) - bc(ieq)=-f - endif - enddo -! -! convection with the walls -! - do i=1,nload - if(sideload(i)(3:4).eq.'FC') then - nelem=nelemload(1,i) - lakonl=lakon(nelem) - node=nelemload(2,i) - ieq=nacteq(0,node) - if(ieq.eq.0) then - cycle - endif -! - call nident(itg,node,ntg,id) -! -! calculate the area -! - read(sideload(i)(2:2),'(i1)') ig -! -! number of nodes and integration points in the face -! - if(lakonl(4:4).eq.'2') then - nope=20 - nopes=8 - elseif(lakonl(4:4).eq.'8') then - nope=8 - nopes=4 - elseif(lakonl(4:5).eq.'10') then - nope=10 - nopes=6 - elseif(lakonl(4:4).eq.'4') then - nope=4 - nopes=3 - elseif(lakonl(4:5).eq.'15') then - nope=15 - else - nope=6 - endif -! - if(lakonl(4:5).eq.'8R') then - mint2d=1 - elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R')) - & then - if(lakonl(7:7).eq.'A') then - mint2d=2 - else - mint2d=4 - endif - elseif(lakonl(4:4).eq.'2') then - mint2d=9 - elseif(lakonl(4:5).eq.'10') then - mint2d=3 - elseif(lakonl(4:4).eq.'4') then - mint2d=1 - endif -! - if(lakonl(4:4).eq.'6') then - mint2d=1 - if(ig.le.2) then - nopes=3 - else - nopes=4 - endif - endif - if(lakonl(4:5).eq.'15') then - if(ig.le.2) then - mint2d=3 - nopes=6 - else - mint2d=4 - nopes=8 - endif - endif -! -! connectivity of the element -! - index=ipkon(nelem) - if(index.lt.0) then - write(*,*) '*ERROR in radflowload: element ',nelem - write(*,*) ' is not defined' - stop - endif - do k=1,nope - konl(k)=kon(index+k) - enddo -! -! coordinates of the nodes belonging to the face -! - if((nope.eq.20).or.(nope.eq.8)) then - do k=1,nopes - tl2(k)=v(0,konl(ifaceq(k,ig))) - do j=1,3 - xl2(j,k)=co(j,konl(ifaceq(k,ig)))+ - & v(j,konl(ifaceq(k,ig))) - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - do k=1,nopes - tl2(k)=v(0,konl(ifacet(k,ig))) - do j=1,3 - xl2(j,k)=co(j,konl(ifacet(k,ig)))+ - & v(j,konl(ifacet(k,ig))) - enddo - enddo - else - do k=1,nopes - tl2(k)=v(0,konl(ifacew(k,ig))) - do j=1,3 - xl2(j,k)=co(j,konl(ifacew(k,ig)))+ - & v(j,konl(ifacew(k,ig))) - enddo - enddo - endif -! -! integration to obtain the area and the mean -! temperature -! - do l=1,mint2d - if((lakonl(4:5).eq.'8R').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then - xi=gauss2d1(1,l) - et=gauss2d1(2,l) - weight=weight2d1(l) - elseif((lakonl(4:4).eq.'8').or. - & (lakonl(4:6).eq.'20R').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then - xi=gauss2d2(1,l) - et=gauss2d2(2,l) - weight=weight2d2(l) - elseif(lakonl(4:4).eq.'2') then - xi=gauss2d3(1,l) - et=gauss2d3(2,l) - weight=weight2d3(l) - elseif((lakonl(4:5).eq.'10').or. - & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then - xi=gauss2d5(1,l) - et=gauss2d5(2,l) - weight=weight2d5(l) - elseif((lakonl(4:4).eq.'4').or. - & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then - xi=gauss2d4(1,l) - et=gauss2d4(2,l) - weight=weight2d4(l) - endif -! - if(nopes.eq.8) then - call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.4) then - call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) - elseif(nopes.eq.6) then - call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) - endif -! - dxsj2=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+ - & xsj2(3)*xsj2(3)) - areaj=dxsj2*weight -! - temp=0.d0 - do k=1,3 - coords(k)=0.d0 - enddo - do j=1,nopes - temp=temp+tl2(j)*shp2(4,j) - do k=1,3 - coords(k)=coords(k)+xl2(k,j)*shp2(4,j) - enddo - enddo -! - sinktemp=v(0,node) - if(sideload(i)(5:6).ne.'NU') then - h(1)=xloadact(1,i) - else - read(sideload(i)(2:2),'(i1)') jltyp - jltyp=jltyp+10 - call film(h,sinktemp,temp,istep, - & iinc,tvar,nelem,l,coords,jltyp,field,nfield, - & sideload(i),node,areaj,v,mi) - if(nmethod.eq.1) h(1)=xloadold(1,i)+ - & (h(1)-xloadold(1,i))*reltime - endif - if(lakonl(5:7).eq.'0RA') then - bc(ieq)=bc(ieq)+ - & 2.d0*(temp-sinktemp)*h(1)*dxsj2*weight - else - bc(ieq)=bc(ieq)+ - & (temp-sinktemp)*h(1)*dxsj2*weight - endif - enddo - endif - enddo -! -! prescribed heat generation -! - do i=1,ntg - node=itg(i) - idof=8*(node-1) - call nident(ikforc,idof,nforc,id) - if(id.gt.0) then - if(ikforc(id).eq.idof) then - ieq=nacteq(0,node) - bc(ieq)=bc(ieq)+xforcact(ilforc(id)) - cycle - endif - endif - enddo -! -! in the case of forced vortices when, when temperature change -! is required , an additionnal heat input is added in the energy equation for the -! downstream node -! - do i=1,nflow - nelem=ieg(i) - if(lakon(nelem)(2:3).ne.'VO') cycle -! -! free vortex and no temperature change -! - if((lakon(nelem)(2:5).eq.'VOFR').and. - & (prop(ielprop(nelem)+8).eq.0)) cycle -! -! free vortex and temperature change in the absolute system -! - if((lakon(nelem)(2:5).eq.'VOFR').and. - & (prop(ielprop(nelem)+8).eq.1)) cycle -! -! forced vortex and no temperature change -! - if((lakon(nelem)(2:5).eq.'VOFO').and. - & (prop(ielprop(nelem)+6).eq.0)) cycle -! - nodem=kon(ipkon(nelem)+2) - xflow=v(1,nodem) - if(xflow.gt.0d0) then - node1=kon(ipkon(nelem)+1) - node2=kon(ipkon(nelem)+3) - else - node1=kon(ipkon(nelem)+1) - node2=kon(ipkon(nelem)+3) - endif -! - if(xflow.gt.0d0) then - R1=prop(ielprop(nelem)+2) - R2=prop(ielprop(nelem)+1) - if(R1.gt.R2) then - Rout=R2 - Rin=R1 - else - Rout=R2 - Rin=R1 - endif - else - R1=prop(ielprop(nelem)+2) - R2=prop(ielprop(nelem)+1) - if(R1.gt.R2) then - Rout=R1 - Rin=R2 - else - Rout=R1 - Rin=R2 - endif - endif -! -! computing temperature corrected Cp=Cp(T) coefficient -! -! - Tg1=v(0,node1) - Tg2=v(0,node2) - gastemp=(Tg1+Tg2)/2.d0 -! - imat=ielmat(nelem) - call materialdata_tg(imat,ntmat_,gastemp, - & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho) -! - call cp_corrected(cp,Tg1,Tg2,cp_cor) -! - Uout=Pi/30*prop(ielprop(nelem)+5)*Rout - Uin=Pi/30*prop(ielprop(nelem)+5)*Rin -! -! free and forced vortices with temperature -! change in the relative system of coordinates -! - if((lakon(nelem)(2:5).eq.'VOFR') .and. - & (prop(ielprop(nelem)+8).eq.(-1))) then -! - Uout=Pi/30*prop(ielprop(nelem)+7)*Rout - Uin=Pi/30*prop(ielprop(nelem)+7)*Rin -! - heat=0.5d0*Cp/Cp_cor*(Uout**2-Uin**2)*xflow -! - elseif (((lakon(nelem)(2:5).eq.'VOFO') - & .and.(prop(ielprop(nelem)+6).eq.(-1)))) then -! - Uout=Pi/30*prop(ielprop(nelem)+5)*Rout - Uin=Pi/30*prop(ielprop(nelem)+5)*Rin -! - heat=0.5d0*Cp/Cp_cor*(Uout**2-Uin**2)*xflow -! -! forced vortices with temperature change in the absolute system -! - elseif((lakon(nelem)(2:5).eq.'VOFO') - & .and.((prop(ielprop(nelem)+6).eq.1))) then -! - heat=Cp/Cp_cor*(Uout**2-Uin**2)*xflow -! - endif -! -! including the resulting additional heat flux in the energy equation -! - if(xflow.gt.0d0)then - ieq=nacteq(0,node2) - if(nacteq(0,node2).ne.0)then - bc(ieq)=bc(ieq)+heat -! - endif - else - ieq=nacteq(0,node1) - if(nacteq(0,node1).ne.0)then - bc(ieq)=bc(ieq)+heat - endif - endif - enddo -! -! transfer element ABSOLUTE TO RELATIVE / RELATIVE TO ABSOLUTE -! - do i= 1, nflow - nelem=ieg(i) -! - if((lakon(nelem)(2:4).eq.'ATR').or. - & (lakon(nelem)(2:4).eq.'RTA')) then -! - nodem=kon(ipkon(nelem)+2) - xflow=v(1,nodem) - if(xflow.gt.0d0) then - node1=kon(ipkon(nelem)+1) - node2=kon(ipkon(nelem)+3) - else - node1=kon(ipkon(nelem)+1) - node2=kon(ipkon(nelem)+3) - endif -! -! computing temperature corrected Cp=Cp(T) coefficient -! - Tg1=v(0,node1) - Tg2=v(0,node2) - gastemp=(Tg1+Tg2)/2.d0 -! - imat=ielmat(nelem) - call materialdata_tg(imat,ntmat_,gastemp, - & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho) -! - call cp_corrected(cp,Tg1,Tg2,cp_cor) -! - index=ielprop(nelem) - U=prop(index+1) - ct=prop(index+2) -! - if(ct.eq.0) then - nelemswirl=prop(index+3) - index2=ielprop(nelemswirl) -! -! previous element is a preswirl nozzle -! - if(lakon(nelemswirl)(2:5).eq.'ORPN') then - ct=prop(index2+4) -! -! previous element is a forced vortex -! - elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then - ct=prop(index2+7) -! -! previous element is a free vortex -! - elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then - ct=prop(index2+9) - endif - endif -! - if(lakon(nelem)(2:4).eq.'ATR') then - heat=Cp/Cp_cor*(0.5d0*(U**2-2d0*U*Ct)*xflow) -! - elseif(lakon(nelem)(2:4).eq.'RTA') then - heat=Cp/Cp_cor*(-0.5d0*(U**2-2d0*U*Ct)*xflow) - endif -! -! including the resulting additional heat flux in the energy equation -! - if(xflow.gt.0d0)then - ieq=nacteq(0,node2) - if(nacteq(0,node2).ne.0)then - bc(ieq)=bc(ieq)+heat -! - endif - else - ieq=nacteq(0,node1) - if(nacteq(0,node1).ne.0)then - bc(ieq)=bc(ieq)+heat - endif - endif - endif - enddo -! -! in the case of generalized pipes if rotation occurs -! the outlet node temperature will change -! - do i=1,nflow - nelem=ieg(i) -! - if(lakon(nelem)(2:5).eq.'GAPI') then - index=ielprop(nelem) - if((prop(index+8).ne.0).and. - & (prop(index+9).ne.0).and. - & (prop(index+8).ne.0)) then -! - nodem=kon(ipkon(nelem)+2) - xflow=v(1,nodem) - if(xflow.gt.0d0) then - node1=kon(ipkon(nelem)+1) - node2=kon(ipkon(nelem)+3) - else - node1=kon(ipkon(nelem)+1) - node2=kon(ipkon(nelem)+3) - endif - omega=pi/30d0*prop(index+10) - write(*,*) 'icase',icase - rin=prop(index+8) - rout=prop(index+9) - heat=0.5*omega**2*(rout**2-rin**2)*xflow -! -! influence on the temperature of node 2 -! - if(xflow.gt.0d0)then - ieq=nacteq(0,node2) - if(nacteq(0,node2).ne.0)then - bc(ieq)=bc(ieq)+heat - endif - else - ieq=nacteq(0,node1) - if(nacteq(0,node1).ne.0)then - bc(ieq)=bc(ieq)+heat - endif - endif - endif - endif - enddo - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/results.f calculix-ccx-2.3/ccx_2.1/src/results.f --- calculix-ccx-2.1/ccx_2.1/src/results.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/results.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1786 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine results(co,nk,kon,ipkon,lakon,ne,v,stn,inum, - & stx,elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero, - & ielmat,ielorien,norien,orab,ntmat_,t0,t1,ithermal,prestr, - & iprestr,filab,eme,een,iperturb,f,fn, - & nactdof,iout,qa,vold,b,nodeboun,ndirboun, - & xboun,nboun,ipompc,nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq, - & veold,accold,bet,gam,dtime,time,ttime,plicon,nplicon,plkcon, - & nplkcon, - & xstateini,xstiff,xstate,npmat_,epn,matname,mi,ielas,icmd, - & ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, - & xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, - & ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, - & nelemload,nload,ikmpc,ilmpc,istep,iinc) -! -! calculates and prints the displacements, temperatures and forces -! at the nodes and the stress and strain at the reduced integration -! points and at the nodes -! -! iout=-2: v is assumed to be known and is used to -! calculate strains, stresses..., no result output -! corresponds to iout=-1 with in addition the -! calculation of the internal energy density -! iout=-1: v is assumed to be known and is used to -! calculate strains, stresses..., no result output; -! is used to take changes in SPC's and MPC's at the -! start of a new increment or iteration into account -! iout=0: v is calculated from the system solution -! and strains, stresses.. are calculated, no result output -! iout=1: v is calculated from the system solution and strains, -! stresses.. are calculated, requested results output -! iout=2: v is assumed to be known and is used to -! calculate strains, stresses..., requested results output -! - implicit none -! - logical calcul_fn,calcul_f,calcul_cauchy,calcul_qa,cauchy, - & fluid,force,intpointvar -! - character*1 cflag - character*6 prlab(*) - character*8 lakon(*),lakonl - character*20 labmpc(*) - character*80 amat,matname(*) - character*81 set(*),prset(*) - character*87 filab(*) -! - integer kon(*),konl(20),inum(*),iperm(20),ikmpc(*),ilmpc(*), - & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), - & ntmat_,ipkon(*),mi(2), - & nactdof(0:mi(2),*),nodeboun(*),nelemload(2,*), - & ndirboun(*),ipompc(*),nodempc(3,*),ikboun(*),ilboun(*), - & ncocon(2,*),inotr(2,*),iorienglob,iflag,nload,nshcon, - & istep,iinc,mt -! - integer nk,ne,mattyp,ithermal(2),iprestr,i,j,k,m1,m2,jj, - & i1,m3,m4,kk,iener,indexe,nope,norien,iperturb(*),iout, - & nal,icmd,ihyper,nboun,nmpc,nmethod,ist,ndir,node,index, - & neq,kode,imat,mint3d,nfield,ndim,iorien,ielas, - & istiff,ncmat_,nstate_,incrementalmpc,jmin,jmax, - & nset,istartset(*),iendset(*),ialset(*),nprint,ntrans,ikin -! - integer nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ -! - real*8 co(3,*),v(0:mi(2),*),shp(4,20),stiini(6,mi(1),*), - & stx(6,mi(1),*),stn(6,*),xl(3,20),vl(0:mi(2),20),stre(6), - & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*), - & alcon(0:6,ntmat_,*),vini(0:mi(2),*),qfx(3,mi(1),*),qfn(3,*), - & alzero(*),orab(7,*),elas(21),rho,f(*),fn(0:mi(2),*),fnl(3,9), - & skl(3,3),beta(6),q(0:mi(2),20),vkl(0:3,3),cam(5), - & t0(*),t1(*),prestr(6,mi(1),*),eme(6,mi(1),*),een(6,*),ckl(3,3), - & vold(0:mi(2),*),b(*),xboun(*),coefmpc(*),eloc(9), - & veold(0:mi(2),*), - & accold(0:mi(2),*),elconloc(21),eth(6),xkl(3,3), - & voldl(0:mi(2),20),epn(*), - & xikl(3,3),ener(mi(1),*),enern(*),sti(6,mi(1),*),emec(6), - & eei(6,mi(1),*),enerini(mi(1),*),cocon(0:6,ntmat_,*),emec0(6), - & fmpc(*),shcon,sph,c1,vel(1:3,20),veoldl(0:mi(2),20) -! - real*8 e,un,al,um,am1,xi,et,ze,tt,exx,eyy,ezz,exy,exz,eyz, - & xsj,qa(3),vj,t0l,t1l,bet,gam,dtime,forcempc,scal1,scal2,bnac, - & fixed_disp,weight,pgauss(3),vij,coconloc(6),qflux(3),time,ttime, - & t1lold -! - real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), - & xstiff(27,mi(1),*),xstate(nstate_,mi(1),*),plconloc(82), - & vokl(3,3),xstateini(nstate_,mi(1),*),vikl(3,3),trab(7,*), - & xstaten(nstate_,*) -! - include "gauss.f" -! - data iflag /3/ - data iperm /5,6,7,8,1,2,3,4,13,14,15,16,9,10,11,12,17,18,19,20/ -! - mt=mi(2)+1 - fluid=.false. - intpointvar=.true. -! - if(ithermal(1).le.1) then - jmin=1 - jmax=3 - elseif(ithermal(1).eq.2) then - jmin=0 - jmax=min(mi(2),2) - else - jmin=0 - jmax=3 - endif -! - if((iout.ne.2).and.(iout.gt.-1)) then -! - if((nmethod.ne.4).or.(iperturb(1).le.1)) then - if(ithermal(1).ne.2) then - do i=1,nk - do j=1,3 - if(nactdof(j,i).ne.0) then - bnac=b(nactdof(j,i)) - else - bnac=0.d0 - endif -c v(j,i)=vold(j,i)+bnac - v(j,i)=v(j,i)+bnac - if((iperturb(1).ne.0).and.(nmethod.eq.1)) then - if(dabs(bnac).gt.cam(1)) then - cam(1)=dabs(bnac) - cam(4)=i+0.5d0 - endif - endif - enddo - enddo - endif - if(ithermal(1).gt.1) then - do i=1,nk - if(nactdof(0,i).ne.0) then - bnac=b(nactdof(0,i)) - else - bnac=0.d0 - endif -c v(0,i)=vold(0,i)+bnac - v(0,i)=v(0,i)+bnac - if((iperturb(1).ne.0).and.(nmethod.eq.1)) then - if(dabs(bnac).gt.cam(2)) then - cam(2)=dabs(bnac) - cam(5)=i+0.5d0 - endif - endif - enddo - endif -c! -c! extracting the displacement information from the solution -c! -c do i=1,nk -c do j=jmin,jmax -c if(nactdof(j,i).ne.0) then -c v(j,i)=b(nactdof(j,i)) -c else -c v(j,i)=0.d0 -c endif -c enddo -c enddo -c! -c! for static perturbation steps v represents the incremental -c! displacements. For the total displacement vold must be added. -c! -c if((iperturb(1).ne.0).and.(nmethod.eq.1)) then -c if(ithermal(1).ne.2) then -c do i=1,nk -c do j=1,3 -c if(dabs(v(j,i)).gt.cam(1)) then -c cam(1)=dabs(v(j,i)) -c cam(4)=i+0.5d0 -c endif -c v(j,i)=v(j,i)+vold(j,i) -c enddo -c enddo -c endif -c if(ithermal(1).gt.1) then -c do i=1,nk -c if(dabs(v(0,i)).gt.cam(2)) then -c cam(2)=dabs(v(0,i)) -c cam(5)=i+0.5d0 -c endif -c v(0,i)=v(0,i)+vold(0,i) -c enddo -c endif -c! -c! copy pressure and mass flow values -c! -c if(ithermal(1).eq.2) then -c do i=1,nk -c do j=1,min(2,mi(2)) -c v(j,i)=vold(j,i) -c enddo -c enddo -c endif -c endif -! - else -! -! direct integration dynamic step -! b contains the acceleration increment -! - if(ithermal(1).ne.2) then - scal1=bet*dtime*dtime - scal2=gam*dtime - do i=1,nk - do j=1,3 - if(nactdof(j,i).ne.0) then - bnac=b(nactdof(j,i)) - else - bnac=0.d0 - endif -c v(j,i)=vold(j,i)+scal1*bnac - v(j,i)=v(j,i)+scal1*bnac - if(dabs(scal1*bnac).gt.cam(1)) then - cam(1)=dabs(scal1*bnac) - cam(4)=i+0.5d0 - endif - veold(j,i)=veold(j,i)+scal2*bnac - accold(j,i)=accold(j,i)+bnac - enddo - enddo - endif - if(ithermal(1).gt.1) then - do i=1,nk - if(nactdof(0,i).ne.0) then - bnac=b(nactdof(0,i)) - else - bnac=0.d0 - endif -c v(0,i)=vold(0,i)+bnac - v(0,i)=v(0,i)+bnac - if(dabs(bnac).gt.cam(2)) then - cam(2)=dabs(bnac) - cam(5)=i+0.5d0 - endif - if(nactdof(0,i).ne.0) then - cam(3)=max(cam(3),dabs(v(0,i)-vini(0,i))) - endif - veold(0,i)=0.d0 - enddo - endif -c! -c! copy pressure and mass flow values -c! -c if(ithermal(1).eq.2) then -c do i=1,nk -c do j=1,min(mi(2),2) -c v(j,i)=vold(j,i) -c enddo -c enddo -c endif - endif -! - endif -! -! initialization -! - calcul_fn=.false. - calcul_f=.false. - calcul_qa=.false. - calcul_cauchy=.false. -! -! determining which quantities have to be calculated -! - if((iperturb(1).ge.2).or.((iperturb(1).le.0).and.(iout.lt.0))) - & then - if((iout.lt.1).and.(iout.gt.-2)) then - calcul_fn=.true. - calcul_f=.true. - calcul_qa=.true. - elseif((iout.ne.-2).and.(iperturb(2).eq.1)) then - calcul_cauchy=.true. - endif - endif -! - if(iout.gt.0) then - if((filab(5)(1:4).eq.'RF ').or. - & (filab(10)(1:4).eq.'RFL ')) then - calcul_fn=.true. - else - do i=1,nprint - if((prlab(i)(1:4).eq.'RF ').or. - & (prlab(i)(1:4).eq.'RFL ')) then - calcul_fn=.true. - exit - endif - enddo - endif - endif -! -! initializing fn -! - if(calcul_fn) then - do i=1,nk - do j=0,mi(2) - fn(j,i)=0.d0 - enddo - enddo - endif -! -! initializing f -! - if(calcul_f) then - do i=1,neq - f(i)=0.d0 - enddo - endif -! -! SPC's and MPC's have to be taken into account for -! iout=0,1 and -1 -! - if(abs(iout).lt.2) then -! -! inserting the boundary conditions -! - do i=1,nboun - if(ndirboun(i).gt.3) cycle - fixed_disp=xboun(i) - if((nmethod.eq.4).and.(iperturb(1).gt.1)) then - ndir=ndirboun(i) - node=nodeboun(i) - if(ndir.gt.0) then - accold(ndir,node)=(xboun(i)-v(ndir,node))/ - & (bet*dtime*dtime) - veold(ndir,node)=veold(ndir,node)+ - & gam*dtime*accold(ndir,node) - else - veold(ndir,node)=(xboun(i)-v(ndir,node))/dtime - endif - endif - v(ndirboun(i),nodeboun(i))=fixed_disp - enddo -! -! inserting the mpc information -! the parameter incrementalmpc indicates whether the -! incremental displacements enter the mpc or the total -! displacements (incrementalmpc=0) -! -c -c to be checked: should replace the lines underneath do i=1,nmpc -c -c incrementalmpc=iperturb(2) - do i=1,nmpc - if((labmpc(i)(1:20).eq.' ').or. - & (labmpc(i)(1:7).eq.'CONTACT').or. - & (labmpc(i)(1:6).eq.'CYCLIC').or. - & (labmpc(i)(1:9).eq.'SUBCYCLIC')) then - incrementalmpc=0 - else - if((nmethod.eq.2).or.(nmethod.eq.3).or. - & ((iperturb(1).eq.0).and.(nmethod.eq.1))) - & then - incrementalmpc=0 - else - incrementalmpc=1 - endif - endif - ist=ipompc(i) - node=nodempc(1,ist) - ndir=nodempc(2,ist) - if(ndir.eq.0) then - if(ithermal(1).lt.2) cycle - elseif(ndir.gt.3) then - cycle - else - if(ithermal(1).eq.2) cycle - endif - index=nodempc(3,ist) - fixed_disp=0.d0 - if(index.ne.0) then - do - if(incrementalmpc.eq.0) then - fixed_disp=fixed_disp-coefmpc(index)* - & v(nodempc(2,index),nodempc(1,index)) - else - fixed_disp=fixed_disp-coefmpc(index)* - & (v(nodempc(2,index),nodempc(1,index))- - & vold(nodempc(2,index),nodempc(1,index))) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - fixed_disp=fixed_disp/coefmpc(ist) - if(incrementalmpc.eq.1) then - fixed_disp=fixed_disp+vold(ndir,node) - endif - if((nmethod.eq.4).and.(iperturb(1).gt.1)) then - if(ndir.gt.0) then - accold(ndir,node)=(fixed_disp-v(ndir,node))/ - & (bet*dtime*dtime) - veold(ndir,node)=veold(ndir,node)+ - & gam*dtime*accold(ndir,node) - else - veold(ndir,node)=(fixed_disp-v(ndir,node))/dtime - endif - endif - v(ndir,node)=fixed_disp - enddo - endif -! -! check whether there are any strain output requests -! - iener=0 - ikin=0 - if((filab(7)(1:4).eq.'ENER').or.(filab(27)(1:4).eq.'CELS')) then - iener=1 - endif - - do i=1,nprint - if((prlab(i)(1:4).eq.'ENER').or.(prlab(i)(1:4).eq.'ELSE').or. - & (prlab(i)(1:4).eq.'CELS')) then - iener=1 - elseif(prlab(i)(1:4).eq.'ELKE') then - ikin=1 - endif - enddo -! - qa(1)=0.d0 - nal=0 -! -! check whether integration point variables are needed in -! modal dynamics calculations -! - if((nmethod.eq.4).and.(iperturb(1).lt.2)) then - intpointvar=.false. - if((filab(3)(1:4).eq.'S ').or. - & (filab(4)(1:4).eq.'E ').or. - & (filab(5)(1:4).eq.'RF ').or. - & (filab(6)(1:4).eq.'PEEQ').or. - & (filab(7)(1:4).eq.'ENER').or. - & (filab(8)(1:4).eq.'SDV ').or. - & (filab(13)(1:4).eq.'ZZS ').or. - & (filab(18)(1:4).eq.'PHS ').or. - & (filab(20)(1:4).eq.'MAXS').or. - & (filab(26)(1:4).eq.'CONT').or. - & (filab(27)(1:3).eq.'CELS')) intpointvar=.true. - do i=1,nprint - if((prlab(i)(1:4).eq.'S ').or. - & (prlab(i)(1:4).eq.'E ').or. - & (prlab(i)(1:4).eq.'PEEQ').or. - & (prlab(i)(1:4).eq.'ENER').or. - & (prlab(i)(1:4).eq.'SDV ').or. - & (prlab(i)(1:4).eq.'RF ')) then - intpointvar=.true. - exit - endif - enddo - endif -! -! calculation of the stresses in the integration points -! - if(((ithermal(1).le.1).or.(ithermal(1).ge.3)).and. - & (intpointvar)) then -! -c do i=1,nk -c write(*,*) 'results v ',i,(v(j,i),j=1,3) -c enddo -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - imat=ielmat(i) - amat=matname(imat) - if(norien.gt.0) then - iorien=ielorien(i) - else - iorien=0 - endif -! - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - elseif(lakon(i)(1:1).eq.'E') then - read(lakon(i)(8:8),'(i1)') nope -! -! contact area division number -! - if(lakon(i)(7:7).eq.'C') konl(nope+1)=kon(indexe+nope+1) - else - cycle - endif -! - if(lakon(i)(4:5).eq.'8R') then - mint3d=1 - elseif((lakon(i)(4:4).eq.'8').or. - & (lakon(i)(4:6).eq.'20R')) then - mint3d=8 - elseif(lakon(i)(4:4).eq.'2') then - mint3d=27 - elseif(lakon(i)(4:5).eq.'10') then - mint3d=4 - elseif(lakon(i)(4:4).eq.'4') then - mint3d=1 - elseif(lakon(i)(4:5).eq.'15') then - mint3d=9 - elseif(lakon(i)(4:4).eq.'6') then - mint3d=2 - elseif(lakon(i)(1:1).eq.'E') then - mint3d=0 - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - do k=1,3 - xl(k,j)=co(k,konl(j)) - vl(k,j)=v(k,konl(j)) - voldl(k,j)=vold(k,konl(j)) - enddo -c write(*,*) 'noeie',i,konl(j),(vl(k,j),k=1,3) - enddo -! -! check for hyperelastic material -! - if(nelcon(1,imat).lt.0) then - ihyper=1 - else - ihyper=0 - endif -! -! q contains the nodal forces per element; initialisation of q -! - if((iperturb(1).ge.2).or.((iperturb(1).le.0).and.(iout.lt.1))) - & then - do m1=1,nope - do m2=0,mi(2) - q(m2,m1)=fn(m2,konl(m1)) - enddo - enddo - endif -! -! calculating the forces for the contact elements -! - if(mint3d.eq.0) then -! - lakonl=lakon(i) -! -! "normal" spring and dashpot elements -! - if(lakonl(7:7).eq.'A') then - kode=nelcon(1,imat) - t0l=0.d0 - t1l=0.d0 - if(ithermal(1).eq.1) then - t0l=(t0(konl(1))+t0(konl(2)))/2.d0 - t1l=(t1(konl(1))+t1(konl(2)))/2.d0 - elseif(ithermal(1).ge.2) then - t0l=(t0(konl(1))+t0(konl(2)))/2.d0 - t1l=(vold(0,konl(1))+vold(0,konl(2)))/2.d0 - endif - endif -! -! spring elements (including contact springs) -! - if(lakonl(2:2).eq.'S') then -! -! velocity may be needed for contact springs -! - if(lakonl(7:7).eq.'C') then - do j=1,nope - do k=1,3 - veoldl(k,j)=veold(k,konl(j)) - enddo - enddo - endif - call springforc(xl,konl,vl,imat,elcon,nelcon,elas, - & fnl,ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc, - & plicon,nplicon,npmat_,veoldl,ener(1,i),iener, - & stx(1,1,i),mi) - do j=1,nope - do k=1,3 - fn(k,konl(j))=fn(k,konl(j))+fnl(k,j) - enddo - enddo -! -! dashpot elements (including contact dashpots) -! - elseif((nmethod.eq.4).or. - & ((nmethod.eq.1).and.(iperturb(1).ge.2))) then - do j=1,nope - konl(j)=kon(indexe+j) - do k=1,3 - vel(k,j)=veold(k,konl(j)) - enddo - enddo - call dashforc(xl,konl,vl,imat,elcon,nelcon, - & elas,fn,ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode, - & elconloc,plicon,nplicon,npmat_,vel,time,nmethod,mi) - endif - elseif(ikin.eq.1) then - do j=1,nope - do k=1,3 - veoldl(k,j)=veold(k,konl(j)) - enddo - enddo - endif -! - do jj=1,mint3d - if(lakon(i)(4:5).eq.'8R') then - xi=gauss3d1(1,jj) - et=gauss3d1(2,jj) - ze=gauss3d1(3,jj) - weight=weight3d1(jj) - elseif((lakon(i)(4:4).eq.'8').or. - & (lakon(i)(4:6).eq.'20R')) - & then - xi=gauss3d2(1,jj) -c if(nope.eq.20) xi=xi+1.d0 - et=gauss3d2(2,jj) - ze=gauss3d2(3,jj) - weight=weight3d2(jj) - elseif(lakon(i)(4:4).eq.'2') then -c xi=gauss3d3(1,jj)+1.d0 - xi=gauss3d3(1,jj) - et=gauss3d3(2,jj) - ze=gauss3d3(3,jj) - weight=weight3d3(jj) - elseif(lakon(i)(4:5).eq.'10') then - xi=gauss3d5(1,jj) - et=gauss3d5(2,jj) - ze=gauss3d5(3,jj) - weight=weight3d5(jj) - elseif(lakon(i)(4:4).eq.'4') then - xi=gauss3d4(1,jj) - et=gauss3d4(2,jj) - ze=gauss3d4(3,jj) - weight=weight3d4(jj) - elseif(lakon(i)(4:5).eq.'15') then - xi=gauss3d8(1,jj) - et=gauss3d8(2,jj) - ze=gauss3d8(3,jj) - weight=weight3d8(jj) - elseif(lakon(i)(4:4).eq.'6') then - xi=gauss3d7(1,jj) - et=gauss3d7(2,jj) - ze=gauss3d7(3,jj) - weight=weight3d7(jj) - endif -! - if(nope.eq.20) then - if(lakon(i)(7:7).eq.'A') then - call shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) - elseif((lakon(i)(7:7).eq.'E').or. - & (lakon(i)(7:7).eq.'S')) then - call shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) - else - call shape20h(xi,et,ze,xl,xsj,shp,iflag) - endif - elseif(nope.eq.8) then - call shape8h(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.10) then - call shape10tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.4) then - call shape4tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.15) then - call shape15w(xi,et,ze,xl,xsj,shp,iflag) - else - call shape6w(xi,et,ze,xl,xsj,shp,iflag) - endif -! -! vkl(m2,m3) contains the derivative of the m2- -! component of the displacement with respect to -! direction m3 -! - do m2=1,3 - do m3=1,3 - vkl(m2,m3)=0.d0 - enddo - enddo -! - do m1=1,nope - do m2=1,3 - do m3=1,3 - vkl(m2,m3)=vkl(m2,m3)+shp(m3,m1)*vl(m2,m1) - enddo -c write(*,*) 'vnoeie',i,konl(m1),(vkl(m2,k),k=1,3) - enddo - enddo -! -! for frequency analysis or buckling with preload the -! strains are calculated with respect to the deformed -! configuration -! for a linear iteration within a nonlinear increment: -! the tangent matrix is calculated at strain at the end -! of the previous increment -! - if((iperturb(1).eq.1).or.(iperturb(1).eq.-1))then - do m2=1,3 - do m3=1,3 - vokl(m2,m3)=0.d0 - enddo - enddo -! - do m1=1,nope - do m2=1,3 - do m3=1,3 - vokl(m2,m3)=vokl(m2,m3)+ - & shp(m3,m1)*voldl(m2,m1) - enddo - enddo - enddo - endif -! - kode=nelcon(1,imat) -! -! calculating the strain -! -! attention! exy,exz and eyz are engineering strains! -! - exx=vkl(1,1) - eyy=vkl(2,2) - ezz=vkl(3,3) - exy=vkl(1,2)+vkl(2,1) - exz=vkl(1,3)+vkl(3,1) - eyz=vkl(2,3)+vkl(3,2) -! -! for frequency analysis or buckling with preload the -! strains are calculated with respect to the deformed -! configuration -! - if(iperturb(1).eq.1) then - exx=exx+vokl(1,1)*vkl(1,1)+vokl(2,1)*vkl(2,1)+ - & vokl(3,1)*vkl(3,1) - eyy=eyy+vokl(1,2)*vkl(1,2)+vokl(2,2)*vkl(2,2)+ - & vokl(3,2)*vkl(3,2) - ezz=ezz+vokl(1,3)*vkl(1,3)+vokl(2,3)*vkl(2,3)+ - & vokl(3,3)*vkl(3,3) - exy=exy+vokl(1,1)*vkl(1,2)+vokl(1,2)*vkl(1,1)+ - & vokl(2,1)*vkl(2,2)+vokl(2,2)*vkl(2,1)+ - & vokl(3,1)*vkl(3,2)+vokl(3,2)*vkl(3,1) - exz=exz+vokl(1,1)*vkl(1,3)+vokl(1,3)*vkl(1,1)+ - & vokl(2,1)*vkl(2,3)+vokl(2,3)*vkl(2,1)+ - & vokl(3,1)*vkl(3,3)+vokl(3,3)*vkl(3,1) - eyz=eyz+vokl(1,2)*vkl(1,3)+vokl(1,3)*vkl(1,2)+ - & vokl(2,2)*vkl(2,3)+vokl(2,3)*vkl(2,2)+ - & vokl(3,2)*vkl(3,3)+vokl(3,3)*vkl(3,2) - endif -! -c if(iperturb(1).ge.2) then - if(iperturb(2).eq.1) then -! -! Lagrangian strain -! - exx=exx+(vkl(1,1)**2+vkl(2,1)**2+vkl(3,1)**2)/2.d0 - eyy=eyy+(vkl(1,2)**2+vkl(2,2)**2+vkl(3,2)**2)/2.d0 - ezz=ezz+(vkl(1,3)**2+vkl(2,3)**2+vkl(3,3)**2)/2.d0 - exy=exy+vkl(1,1)*vkl(1,2)+vkl(2,1)*vkl(2,2)+ - & vkl(3,1)*vkl(3,2) - exz=exz+vkl(1,1)*vkl(1,3)+vkl(2,1)*vkl(2,3)+ - & vkl(3,1)*vkl(3,3) - eyz=eyz+vkl(1,2)*vkl(1,3)+vkl(2,2)*vkl(2,3)+ - & vkl(3,2)*vkl(3,3) -! - endif -! -! storing the local strains -! - if(iperturb(1).ne.-1) then - eloc(1)=exx - eloc(2)=eyy - eloc(3)=ezz - eloc(4)=exy/2.d0 - eloc(5)=exz/2.d0 - eloc(6)=eyz/2.d0 - else -! -! linear iteration within a nonlinear increment: -! - eloc(1)=vokl(1,1)+ - & (vokl(1,1)**2+vokl(2,1)**2+vokl(3,1)**2)/2.d0 - eloc(2)=vokl(2,2)+ - & (vokl(1,2)**2+vokl(2,2)**2+vokl(3,2)**2)/2.d0 - eloc(3)=vokl(3,3)+ - & (vokl(1,3)**2+vokl(2,3)**2+vokl(3,3)**2)/2.d0 - eloc(4)=(vokl(1,2)+vokl(2,1)+vokl(1,1)*vokl(1,2)+ - & vokl(2,1)*vokl(2,2)+vokl(3,1)*vokl(3,2))/2.d0 - eloc(5)=(vokl(1,3)+vokl(3,1)+vokl(1,1)*vokl(1,3)+ - & vokl(2,1)*vokl(2,3)+vokl(3,1)*vokl(3,3))/2.d0 - eloc(6)=(vokl(2,3)+vokl(3,2)+vokl(1,2)*vokl(1,3)+ - & vokl(2,2)*vokl(2,3)+vokl(3,2)*vokl(3,3))/2.d0 - endif -! -! calculating the deformation gradient (needed to -! convert the element stiffness matrix from spatial -! coordinates to material coordinates -! deformation plasticity) -! - if((kode.eq.-50).or.(kode.le.-100)) then -! -! calculating the deformation gradient -! - xkl(1,1)=vkl(1,1)+1 - xkl(2,2)=vkl(2,2)+1. - xkl(3,3)=vkl(3,3)+1. - xkl(1,2)=vkl(1,2) - xkl(1,3)=vkl(1,3) - xkl(2,3)=vkl(2,3) - xkl(2,1)=vkl(2,1) - xkl(3,1)=vkl(3,1) - xkl(3,2)=vkl(3,2) -! -! calculating the Jacobian -! - vj=xkl(1,1)*(xkl(2,2)*xkl(3,3)-xkl(2,3)*xkl(3,2)) - & -xkl(1,2)*(xkl(2,1)*xkl(3,3)-xkl(2,3)*xkl(3,1)) - & +xkl(1,3)*(xkl(2,1)*xkl(3,2)-xkl(2,2)*xkl(3,1)) -! -! inversion of the deformation gradient (only for -! deformation plasticity) -! - if(kode.eq.-50) then -! - ckl(1,1)=(xkl(2,2)*xkl(3,3)-xkl(2,3)*xkl(3,2))/vj - ckl(2,2)=(xkl(1,1)*xkl(3,3)-xkl(1,3)*xkl(3,1))/vj - ckl(3,3)=(xkl(1,1)*xkl(2,2)-xkl(1,2)*xkl(2,1))/vj - ckl(1,2)=(xkl(1,3)*xkl(3,2)-xkl(1,2)*xkl(3,3))/vj - ckl(1,3)=(xkl(1,2)*xkl(2,3)-xkl(2,2)*xkl(1,3))/vj - ckl(2,3)=(xkl(2,1)*xkl(1,3)-xkl(1,1)*xkl(2,3))/vj - ckl(2,1)=(xkl(3,1)*xkl(2,3)-xkl(2,1)*xkl(3,3))/vj - ckl(3,1)=(xkl(2,1)*xkl(3,2)-xkl(2,2)*xkl(3,1))/vj - ckl(3,2)=(xkl(3,1)*xkl(1,2)-xkl(1,1)*xkl(3,2))/vj -! -! converting the Lagrangian strain into Eulerian -! strain (only for deformation plasticity) -! - cauchy=.false. - call str2mat(eloc,ckl,vj,cauchy) - endif -! - endif -! -! calculating fields for incremental plasticity -! - if(kode.le.-100) then -! -! calculating the deformation gradient at the -! start of the increment -! -! calculating the displacement gradient at the -! start of the increment -! - do m2=1,3 - do m3=1,3 - vikl(m2,m3)=0.d0 - enddo - enddo -! - do m1=1,nope - do m2=1,3 - do m3=1,3 - vikl(m2,m3)=vikl(m2,m3) - & +shp(m3,m1)*vini(m2,konl(m1)) - enddo - enddo - enddo -! -! calculating the deformation gradient of the old -! fields -! - xikl(1,1)=vikl(1,1)+1 - xikl(2,2)=vikl(2,2)+1. - xikl(3,3)=vikl(3,3)+1. - xikl(1,2)=vikl(1,2) - xikl(1,3)=vikl(1,3) - xikl(2,3)=vikl(2,3) - xikl(2,1)=vikl(2,1) - xikl(3,1)=vikl(3,1) - xikl(3,2)=vikl(3,2) -! -! calculating the Jacobian -! - vij=xikl(1,1)*(xikl(2,2)*xikl(3,3) - & -xikl(2,3)*xikl(3,2)) - & -xikl(1,2)*(xikl(2,1)*xikl(3,3) - & -xikl(2,3)*xikl(3,1)) - & +xikl(1,3)*(xikl(2,1)*xikl(3,2) - & -xikl(2,2)*xikl(3,1)) -! -! stresses at the start of the increment -! - do m1=1,6 - stre(m1)=stiini(m1,jj,i) - enddo -! - endif -! -! prestress values -! - if(iprestr.ne.1) then - do kk=1,6 - beta(kk)=0.d0 - enddo - else - do kk=1,6 - beta(kk)=-prestr(kk,jj,i) - enddo - endif -! - if(ithermal(1).ge.1) then -! -! calculating the temperature difference in -! the integration point -! - t0l=0.d0 - t1l=0.d0 - if(ithermal(1).eq.1) then - if(lakon(i)(4:5).eq.'8 ') then - do i1=1,nope - t0l=t0l+t0(konl(i1))/8.d0 - t1l=t1l+t1(konl(i1))/8.d0 - enddo - elseif(lakon(i)(4:6).eq.'20 ') then - call lintemp(t0,t1,konl,nope,jj,t0l,t1l) - else - do i1=1,nope - t0l=t0l+shp(4,i1)*t0(konl(i1)) - t1l=t1l+shp(4,i1)*t1(konl(i1)) - enddo - endif - elseif(ithermal(1).ge.2) then - if(lakon(i)(4:5).eq.'8 ') then - do i1=1,nope - t0l=t0l+t0(konl(i1))/8.d0 - t1l=t1l+vold(0,konl(i1))/8.d0 - enddo - elseif(lakon(i)(4:6).eq.'20 ') then - call lintemp_th(t0,vold,konl,nope,jj,t0l,t1l,mi) - else - do i1=1,nope - t0l=t0l+shp(4,i1)*t0(konl(i1)) - t1l=t1l+shp(4,i1)*vold(0,konl(i1)) - enddo - endif - endif - tt=t1l-t0l - endif -! -! calculating the coordinates of the integration point -! for material orientation purposes (for cylindrical -! coordinate systems) -! - if((iorien.gt.0).or.(kode.le.-100)) then - do j=1,3 - pgauss(j)=0.d0 - do i1=1,nope - pgauss(j)=pgauss(j)+shp(4,i1)*co(j,konl(i1)) - enddo - enddo - endif -! -! material data; for linear elastic materials -! this includes the calculation of the stiffness -! matrix -! - istiff=0 -! - call materialdata_me(elcon,nelcon,rhcon,nrhcon,alcon, - & nalcon,imat,amat,iorien,pgauss,orab,ntmat_, - & elas,rho,i,ithermal,alzero,mattyp,t0l,t1l,ihyper, - & istiff,elconloc,eth,kode,plicon,nplicon, - & plkcon,nplkcon,npmat_,plconloc,mi(1),dtime,i,jj, - & xstiff,ncmat_) -! -! determining the mechanical strain -! - if(ithermal(1).ne.0) then - do m1=1,6 - emec(m1)=eloc(m1)-eth(m1) - emec0(m1)=eme(m1,jj,i) - enddo - else - do m1=1,6 - emec(m1)=eloc(m1) - emec0(m1)=eme(m1,jj,i) - enddo - endif -! -! subtracting the plastic initial strains -! - if(iprestr.eq.2) then - do m1=1,6 - emec(m1)=emec(m1)-prestr(m1,jj,i) - enddo - endif -! -! calculating the local stiffness and stress -! - call mechmodel(elconloc,elas,emec,kode,emec0,ithermal, - & icmd,beta,stre,xkl,ckl,vj,xikl,vij, - & plconloc,xstate,xstateini,ielas, - & amat,t1l,dtime,time,ttime,i,jj,nstate_,mi(1), - & iorien,pgauss,orab,eloc,mattyp,qa(3),istep,iinc) -! - do m1=1,21 - xstiff(m1,jj,i)=elas(m1) - enddo -! - if(iperturb(1).eq.-1) then -! -! if the forced displacements were changed at -! the start of a nonlinear step, the nodal -! forces due do this displacements are -! calculated in a purely linear way, and -! the first iteration is purely linear in order -! to allow the displacements to redistribute -! in a quasi-static way (only applies to -! quasi-static analyses (*STATIC)) -! - eloc(1)=exx-vokl(1,1) - eloc(2)=eyy-vokl(2,2) - eloc(3)=ezz-vokl(3,3) - eloc(4)=exy-(vokl(1,2)+vokl(2,1)) - eloc(5)=exz-(vokl(1,3)+vokl(3,1)) - eloc(6)=eyz-(vokl(2,3)+vokl(3,2)) -! - if(mattyp.eq.1) then - e=elas(1) - un=elas(2) - um=e/(1.d0+un) - al=un*um/(1.d0-2.d0*un) - um=um/2.d0 - am1=al*(eloc(1)+eloc(2)+eloc(3)) - stre(1)=am1+2.d0*um*eloc(1) - stre(2)=am1+2.d0*um*eloc(2) - stre(3)=am1+2.d0*um*eloc(3) - stre(4)=um*eloc(4) - stre(5)=um*eloc(5) - stre(6)=um*eloc(6) - elseif(mattyp.eq.2) then - stre(1)=eloc(1)*elas(1)+eloc(2)*elas(2) - & +eloc(3)*elas(4) - stre(2)=eloc(1)*elas(2)+eloc(2)*elas(3) - & +eloc(3)*elas(5) - stre(3)=eloc(1)*elas(4)+eloc(2)*elas(5) - & +eloc(3)*elas(6) - stre(4)=eloc(4)*elas(7) - stre(5)=eloc(5)*elas(8) - stre(6)=eloc(6)*elas(9) - elseif(mattyp.eq.3) then - stre(1)=eloc(1)*elas(1)+eloc(2)*elas(2)+ - & eloc(3)*elas(4)+eloc(4)*elas(7)+ - & eloc(5)*elas(11)+eloc(6)*elas(16) - stre(2)=eloc(1)*elas(2)+eloc(2)*elas(3)+ - & eloc(3)*elas(5)+eloc(4)*elas(8)+ - & eloc(5)*elas(12)+eloc(6)*elas(17) - stre(3)=eloc(1)*elas(4)+eloc(2)*elas(5)+ - & eloc(3)*elas(6)+eloc(4)*elas(9)+ - & eloc(5)*elas(13)+eloc(6)*elas(18) - stre(4)=eloc(1)*elas(7)+eloc(2)*elas(8)+ - & eloc(3)*elas(9)+eloc(4)*elas(10)+ - & eloc(5)*elas(14)+eloc(6)*elas(19) - stre(5)=eloc(1)*elas(11)+eloc(2)*elas(12)+ - & eloc(3)*elas(13)+eloc(4)*elas(14)+ - & eloc(5)*elas(15)+eloc(6)*elas(20) - stre(6)=eloc(1)*elas(16)+eloc(2)*elas(17)+ - & eloc(3)*elas(18)+eloc(4)*elas(19)+ - & eloc(5)*elas(20)+eloc(6)*elas(21) - endif - endif -! -! updating the internal energy -! - if((iout.gt.0).or.(iout.eq.-2)) then - if(ithermal(1).eq.0) then - do m1=1,6 - eth(m1)=0.d0 - enddo - endif - if(iener.eq.1) then - ener(jj,i)=enerini(jj,i)+ - & ((eloc(1)-eth(1)-eme(1,jj,i))* - & (stre(1)+stiini(1,jj,i))+ - & (eloc(2)-eth(2)-eme(2,jj,i))* - & (stre(2)+stiini(2,jj,i))+ - & (eloc(3)-eth(3)-eme(3,jj,i))* - & (stre(3)+stiini(3,jj,i)))/2.d0+ - & (eloc(4)-eth(4)-eme(4,jj,i))*(stre(4)+stiini(4,jj,i))+ - & (eloc(5)-eth(5)-eme(5,jj,i))*(stre(5)+stiini(5,jj,i))+ - & (eloc(6)-eth(6)-eme(6,jj,i))*(stre(6)+stiini(6,jj,i)) - - endif -! - eme(1,jj,i)=eloc(1)-eth(1) - eme(2,jj,i)=eloc(2)-eth(2) - eme(3,jj,i)=eloc(3)-eth(3) - eme(4,jj,i)=eloc(4)-eth(4) - eme(5,jj,i)=eloc(5)-eth(5) - eme(6,jj,i)=eloc(6)-eth(6) -! - eei(1,jj,i)=eloc(1) - eei(2,jj,i)=eloc(2) - eei(3,jj,i)=eloc(3) - eei(4,jj,i)=eloc(4) - eei(5,jj,i)=eloc(5) - eei(6,jj,i)=eloc(6) - endif -! -! updating the kinetic energy -! - if(ikin.eq.1) then - - call materialdata_rho(rhcon,nrhcon,imat,rho,t1l, - & ntmat_) - do m1=1,3 - vel(m1,1)=0.d0 - do i1= 1,nope - vel(m1,1)=vel(m1,1)+shp(4,i1)*veoldl(m1,i1) - enddo - enddo - ener(jj,i+ne)=rho*(vel(1,1)*vel(1,1)+ - & vel(2,1)*vel(2,1)+ vel(3,1)*vel(3,1))/2.d0 - endif -! - skl(1,1)=stre(1) - skl(2,2)=stre(2) - skl(3,3)=stre(3) - skl(2,1)=stre(4) - skl(3,1)=stre(5) - skl(3,2)=stre(6) -! - stx(1,jj,i)=skl(1,1) - stx(2,jj,i)=skl(2,2) - stx(3,jj,i)=skl(3,3) - stx(4,jj,i)=skl(2,1) - stx(5,jj,i)=skl(3,1) - stx(6,jj,i)=skl(3,2) -! - skl(1,2)=skl(2,1) - skl(1,3)=skl(3,1) - skl(2,3)=skl(3,2) -! -! calculation of the nodal forces -! -c if(iperturb(2).eq.0) then -c do m1=1,3 -c do m2=1,3 -c vkl(m1,m2)=0.d0 -c enddo -c enddo -c endif -! - if(calcul_fn)then -! -! calculating fn using skl -! - do m1=1,nope - do m2=1,3 -! -! linear elastic part -! - do m3=1,3 - fn(m2,konl(m1))=fn(m2,konl(m1))+ - & xsj*skl(m2,m3)*shp(m3,m1)*weight - enddo -! -! nonlinear geometric part -! -c if(iperturb(1).ge.2) then - if(iperturb(2).eq.1) then - do m3=1,3 - do m4=1,3 - fn(m2,konl(m1))=fn(m2,konl(m1))+ - & xsj*skl(m4,m3)*weight* - & (vkl(m2,m4)*shp(m3,m1)+ - & vkl(m2,m3)*shp(m4,m1))/2.d0 - enddo - enddo - endif -! - enddo - enddo - endif -! -! calculation of the Cauchy stresses -! - if(calcul_cauchy) then -! -! changing the displacement gradients into -! deformation gradients -! -c if(kode.ne.-50) then - if((kode.ne.-50).and.(kode.gt.-100)) then - xkl(1,1)=vkl(1,1)+1 - xkl(2,2)=vkl(2,2)+1. - xkl(3,3)=vkl(3,3)+1. - xkl(1,2)=vkl(1,2) - xkl(1,3)=vkl(1,3) - xkl(2,3)=vkl(2,3) - xkl(2,1)=vkl(2,1) - xkl(3,1)=vkl(3,1) - xkl(3,2)=vkl(3,2) -! - vj=xkl(1,1)*(xkl(2,2)*xkl(3,3)-xkl(2,3)*xkl(3,2)) - & -xkl(1,2)*(xkl(2,1)*xkl(3,3)-xkl(2,3)*xkl(3,1)) - & +xkl(1,3)*(xkl(2,1)*xkl(3,2)-xkl(2,2)*xkl(3,1)) - endif -! - do m1=1,3 - do m2=1,m1 - ckl(m1,m2)=0.d0 - do m3=1,3 - do m4=1,3 - ckl(m1,m2)=ckl(m1,m2)+ - & skl(m3,m4)*xkl(m1,m3)*xkl(m2,m4) - enddo - enddo - ckl(m1,m2)=ckl(m1,m2)/vj - enddo - enddo -! - stx(1,jj,i)=ckl(1,1) - stx(2,jj,i)=ckl(2,2) - stx(3,jj,i)=ckl(3,3) - stx(4,jj,i)=ckl(2,1) - stx(5,jj,i)=ckl(3,1) - stx(6,jj,i)=ckl(3,2) - endif -! - enddo -! -! q contains the contributions to the nodal force in the nodes -! belonging to the element at stake from other elements (elements -! already treated). These contributions have to be -! subtracted to get the contributions attributable to the element -! at stake only -! - if(calcul_qa) then - do m1=1,nope - do m2=1,3 - qa(1)=qa(1)+dabs(fn(m2,konl(m1))-q(m2,m1)) - enddo - enddo - nal=nal+3*nope - endif - enddo -! - if(calcul_qa) then - if(nal.gt.0) then - qa(1)=qa(1)/nal - endif - endif -! - endif -! -! calculation of temperatures and thermal flux -! - qa(2)=0.d0 - nal=0 -! -! check whether integration point variables are needed in -! modal dynamics calculations -! - if((nmethod.eq.4).and.(iperturb(1).lt.2)) then - intpointvar=.false. - if((filab(9)(1:4).eq.'HFL ').or. - & (filab(10)(1:4).eq.'RFL ')) intpointvar=.true. - do i=1,nprint - if((prlab(i)(1:4).eq.'HFL ').or. - & (prlab(i)(1:4).eq.'RFL ')) intpointvar=.true. - enddo - endif -! - if((ithermal(1).ge.2).and.(intpointvar)) then -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - imat=ielmat(i) - amat=matname(imat) - if(norien.gt.0) then - iorien=ielorien(i) - else - iorien=0 - endif -! - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - if(lakon(i)(4:5).eq.'8R') then - mint3d=1 - elseif((lakon(i)(4:4).eq.'8').or. - & (lakon(i)(4:6).eq.'20R')) then - if(lakon(i)(6:7).eq.'RA') then - mint3d=4 - else - mint3d=8 - endif - elseif(lakon(i)(4:4).eq.'2') then - mint3d=27 - elseif(lakon(i)(4:5).eq.'10') then - mint3d=4 - elseif(lakon(i)(4:4).eq.'4') then - mint3d=1 - elseif(lakon(i)(4:5).eq.'15') then - mint3d=9 - elseif(lakon(i)(4:4).eq.'6') then - mint3d=2 - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - do k=1,3 - xl(k,j)=co(k,konl(j)) - enddo - vl(0,j)=v(0,konl(j)) - voldl(0,j)=vold(0,konl(j)) - enddo -! -! q contains the nodal forces per element; initialisation of q -! - if((iperturb(1).ge.2).or.((iperturb(1).le.0).and.(iout.lt.1))) - & then - do m1=1,nope - q(0,m1)=fn(0,konl(m1)) - enddo - endif -! - do jj=1,mint3d - if(lakon(i)(4:5).eq.'8R') then - xi=gauss3d1(1,jj) - et=gauss3d1(2,jj) - ze=gauss3d1(3,jj) - weight=weight3d1(jj) - elseif((lakon(i)(4:4).eq.'8').or. - & (lakon(i)(4:6).eq.'20R')) - & then - xi=gauss3d2(1,jj) - et=gauss3d2(2,jj) - ze=gauss3d2(3,jj) - weight=weight3d2(jj) - elseif(lakon(i)(4:4).eq.'2') then - xi=gauss3d3(1,jj) - et=gauss3d3(2,jj) - ze=gauss3d3(3,jj) - weight=weight3d3(jj) - elseif(lakon(i)(4:5).eq.'10') then - xi=gauss3d5(1,jj) - et=gauss3d5(2,jj) - ze=gauss3d5(3,jj) - weight=weight3d5(jj) - elseif(lakon(i)(4:4).eq.'4') then - xi=gauss3d4(1,jj) - et=gauss3d4(2,jj) - ze=gauss3d4(3,jj) - weight=weight3d4(jj) - elseif(lakon(i)(4:5).eq.'15') then - xi=gauss3d8(1,jj) - et=gauss3d8(2,jj) - ze=gauss3d8(3,jj) - weight=weight3d8(jj) - elseif(lakon(i)(4:4).eq.'6') then - xi=gauss3d7(1,jj) - et=gauss3d7(2,jj) - ze=gauss3d7(3,jj) - weight=weight3d7(jj) - endif -! - if(nope.eq.20) then - if(lakon(i)(7:7).eq.'A') then - call shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) - elseif((lakon(i)(7:7).eq.'E').or. - & (lakon(i)(7:7).eq.'S')) then - call shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) - else - call shape20h(xi,et,ze,xl,xsj,shp,iflag) - endif - elseif(nope.eq.8) then - call shape8h(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.10) then - call shape10tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.4) then - call shape4tet(xi,et,ze,xl,xsj,shp,iflag) - elseif(nope.eq.15) then - call shape15w(xi,et,ze,xl,xsj,shp,iflag) - else - call shape6w(xi,et,ze,xl,xsj,shp,iflag) - endif - c1=xsj*weight -! -! vkl(m2,m3) contains the derivative of the m2- -! component of the displacement with respect to -! direction m3 -! - do m3=1,3 - vkl(0,m3)=0.d0 - enddo -! - do m1=1,nope - do m3=1,3 - vkl(0,m3)=vkl(0,m3)+shp(m3,m1)*vl(0,m1) - enddo - enddo -! - kode=ncocon(1,imat) -! -! calculating the temperature difference in -! the integration point -! - t1lold=0.d0 - t1l=0.d0 - if(lakon(i)(4:5).eq.'8 ') then - do i1=1,nope - t1lold=t1lold+vold(0,konl(i1))/8.d0 - t1l=t1l+v(0,konl(i1))/8.d0 - enddo - elseif(lakon(i)(4:6).eq.'20 ') then - call lintemp_th(t0,vold,konl,nope,jj,t0l,t1lold,mi) - call lintemp_th(t0,v,konl,nope,jj,t0l,t1l,mi) - else - do i1=1,nope - t1lold=t1lold+shp(4,i1)*vold(0,konl(i1)) - t1l=t1l+shp(4,i1)*v(0,konl(i1)) - enddo - endif -! -! calculating the coordinates of the integration point -! for material orientation purposes (for cylindrical -! coordinate systems) -! - if((iorien.gt.0).or.(kode.le.-100)) then - do j=1,3 - pgauss(j)=0.d0 - do i1=1,nope - pgauss(j)=pgauss(j)+shp(4,i1)*co(j,konl(i1)) - enddo - enddo - endif -! -! material data; for linear elastic materials -! this includes the calculation of the stiffness -! matrix -! - istiff=0 -! - call materialdata_th(cocon,ncocon,imat,iorien,pgauss,orab, - & ntmat_,coconloc,mattyp,t1l,rhcon,nrhcon,rho,shcon, - & nshcon,sph,xstiff,jj,i,istiff,mi(1)) -! - call thermmodel(amat,i,jj,kode,coconloc,vkl,dtime, - & time,ttime,mi(1),nstate_,xstateini,xstate,qflux,xstiff, - & iorien,pgauss,orab,t1l,t1lold,vold,co,lakon(i),konl, - & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc) -! - qfx(1,jj,i)=qflux(1) - qfx(2,jj,i)=qflux(2) - qfx(3,jj,i)=qflux(3) - if(lakon(i)(6:7).eq.'RA') then - qfx(1,jj+4,i)=qflux(1) - qfx(2,jj+4,i)=qflux(2) - qfx(3,jj+4,i)=qflux(3) - endif -! -! calculation of the nodal flux -! - if(calcul_fn)then -! -! calculating fn using skl -! - if(lakon(i)(6:7).eq.'RA') then - do m1=1,nope - fn(0,konl(m1))=fn(0,konl(m1)) - & -c1*(qflux(1)*(shp(1,m1)+shp(1,iperm(m1))) - & +qflux(2)*(shp(2,m1)+shp(2,iperm(m1))) - & +qflux(3)*(shp(3,m1)+shp(3,iperm(m1)))) - enddo - else - do m1=1,nope - do m3=1,3 - fn(0,konl(m1))=fn(0,konl(m1))- - & c1*qflux(m3)*shp(m3,m1) - enddo - enddo - endif - endif - enddo -! -! q contains the contributions to the nodal force in the nodes -! belonging to the element at stake from other elements (elements -! already treated). These contributions have to be -! subtracted to get the contributions attributable to the element -! at stake only -! - if(calcul_qa) then - do m1=1,nope - qa(2)=qa(2)+dabs(fn(0,konl(m1))-q(0,m1)) - enddo - nal=nal+nope - endif - enddo -! - endif -! - if(calcul_qa) then - if(nal.gt.0) then - qa(2)=qa(2)/nal - endif - endif -! -! subtracting the mpc force (for each linear mpc there is one -! force; the actual force in a node belonging to the mpc is -! obtained by multiplying this force with the nodal coefficient. -! The force has to be subtracted from f, since it does not -! appear on the rhs of the equations system -! - if(calcul_fn)then - do i=1,nmpc - ist=ipompc(i) - node=nodempc(1,ist) - ndir=nodempc(2,ist) - if(ndir.gt.3) cycle - forcempc=fn(ndir,node)/coefmpc(ist) - fmpc(i)=forcempc - fn(ndir,node)=0.d0 - index=nodempc(3,ist) - if(index.eq.0) cycle - do - node=nodempc(1,index) - ndir=nodempc(2,index) - fn(ndir,node)=fn(ndir,node)-coefmpc(index)*forcempc - index=nodempc(3,index) - if(index.eq.0) exit - enddo - enddo - endif -! -! calculating the system force vector -! - if(calcul_f) then - do i=1,nk - do j=0,mi(2) - if(nactdof(j,i).ne.0) then - f(nactdof(j,i))=fn(j,i) - endif - enddo - enddo - endif -! -! adding the mpc force again to fn -! - if(calcul_fn)then - do i=1,nmpc - ist=ipompc(i) - node=nodempc(1,ist) - ndir=nodempc(2,ist) - if(ndir.gt.3) cycle - forcempc=fmpc(i) - fn(ndir,node)=forcempc*coefmpc(ist) - index=nodempc(3,ist) -c - if(labmpc(i)(1:7).eq.'MEANROT') then - if(nodempc(3,nodempc(3,index)).eq.0) cycle - elseif(labmpc(i)(1:5).eq.'RIGID') then - if(nodempc(3,nodempc(3,nodempc(3,nodempc(3,nodempc(3,inde - &x))))).eq.0) cycle - else - if(index.eq.0) cycle - endif -c if(index.eq.0) cycle - do - node=nodempc(1,index) - ndir=nodempc(2,index) - fn(ndir,node)=fn(ndir,node)+coefmpc(index)*forcempc - index=nodempc(3,index) - if(labmpc(i)(1:7).eq.'MEANROT') then - if(nodempc(3,nodempc(3,index)).eq.0) exit - elseif(labmpc(i)(1:5).eq.'RIGID') then - if(nodempc(3,nodempc(3,nodempc(3,nodempc(3,nodempc(3,i - &ndex))))).eq.0) exit - else - if(index.eq.0) exit - endif - enddo - enddo - endif -! -! no print requests -! - if(iout.le.0) return -! -! output in dat file (with *NODE PRINT or *EL PRINT) -! - call printout(set,nset,istartset,iendset,ialset,nprint, - & prlab,prset,v,t1,fn,ipkon,lakon,stx,eei,xstate,ener, - & mi(1),nstate_,ithermal,co,kon,qfx,ttime,trab,inotr,ntrans, - & orab,ielorien,norien,nk,ne,inum,filab,vold,ikin) -! -! interpolation in the original nodes of 1d and 2d elements -! this operation has to be performed in any case since -! the interpolated values may be needed as boundary conditions -! in the next step (e.g. the temperature in a heat transfer -! calculation as boundary condition in a subsequent static -! step) -! - if(filab(1)(5:5).ne.' ') then - nfield=mt - cflag=filab(1)(5:5) - force=.false. - call map3dto1d2d(v,ipkon,inum,kon,lakon,nfield,nk, - & ne,cflag,co,vold,force,mi) - endif -! -! user defined output -! - call uout(v,mi) -! - if((filab(2)(1:4).eq.'NT ').and.(ithermal(1).le.1)) then - if(filab(2)(5:5).eq.'I') then - nfield=1 - cflag=filab(2)(5:5) - force=.false. - call map3dto1d2d(t1,ipkon,inum,kon,lakon,nfield,nk, - & ne,cflag,co,vold,force,mi) - endif - endif -! -! determining the stresses in the nodes for output in frd format -! - if((filab(3)(1:4).eq.'S ').or.(filab(18)(1:4).eq.'PHS ').or. - & (filab(20)(1:4).eq.'MAXS')) then - nfield=6 - ndim=6 - if((norien.gt.0).and.(filab(3)(6:6).eq.'L')) then - iorienglob=1 - else - iorienglob=0 - endif - cflag=filab(3)(5:5) -! - call extrapolate(stx,stn,ipkon,inum,kon,lakon,nfield,nk, - & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, - & nelemload,nload,nodeboun,nboun,fluid,ndirboun,vold, - & ithermal,force) -! - endif -! -! determining the strains in the nodes for output in frd format -! - if(filab(4)(1:4).eq.'E ') then - nfield=6 - ndim=6 - if((norien.gt.0).and.(filab(4)(6:6).eq.'L')) then - iorienglob=1 - else - iorienglob=0 - endif - cflag=filab(4)(5:5) - call extrapolate(eei,een,ipkon,inum,kon,lakon,nfield,nk, - & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, - & nelemload,nload,nodeboun,nboun,fluid,ndirboun,vold, - & ithermal,force) - endif -! -! determining the plastic equivalent strain in the nodes -! for output in frd format -! - if(filab(6)(1:4).eq.'PEEQ') then - nfield=1 - ndim=nstate_ - iorienglob=0 - cflag=filab(6)(5:5) - call extrapolate(xstate,epn,ipkon,inum,kon,lakon,nfield,nk, - & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, - & nelemload,nload,nodeboun,nboun,fluid,ndirboun,vold, - & ithermal,force) - endif -! -! determining the total energy in the nodes -! for output in frd format -! - if(filab(7)(1:4).eq.'ENER') then - nfield=1 - ndim=1 - iorienglob=0 - cflag=filab(7)(5:5) - call extrapolate(ener,enern,ipkon,inum,kon,lakon,nfield,nk, - & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, - & nelemload,nload,nodeboun,nboun,fluid,ndirboun,vold, - & ithermal,force) - endif -! -! determining the internal state variables in the nodes -! for output in frd format -! - if(filab(8)(1:4).eq.'SDV ') then - nfield=nstate_ - ndim=nstate_ - if((norien.gt.0).and.(filab(9)(6:6).eq.'L')) then - write(*,*) '*WARNING in results: SDV variables cannot' - write(*,*) ' be stored in a local frame;' - write(*,*) ' the global frame will be used' - endif - iorienglob=0 - cflag=filab(8)(5:5) - call extrapolate(xstate,xstaten,ipkon,inum,kon,lakon,nfield,nk, - & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, - & nelemload,nload,nodeboun,nboun,fluid,ndirboun,vold, - & ithermal,force) - endif -! -! determining the heat flux in the nodes for output in frd format -! - if((filab(9)(1:4).eq.'HFL ').and.(ithermal(1).gt.1)) then - nfield=3 - ndim=3 - if((norien.gt.0).and.(filab(9)(6:6).eq.'L')) then - iorienglob=1 - else - iorienglob=0 - endif - cflag=filab(9)(5:5) - call extrapolate(qfx,qfn,ipkon,inum,kon,lakon,nfield,nk, - & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, - & nelemload,nload,nodeboun,nboun,fluid,ndirboun,vold, - & ithermal,force) - endif -! -! if no element quantities requested in the nodes: calculate -! inum if nodal quantities are requested: used in subroutine frd -! to determine which nodes are active in the model -! -c if((filab(3)(1:4).ne.'S ').and.(filab(4)(1:4).ne.'E ').and. -c & (filab(6)(1:4).ne.'PEEQ').and.(filab(7)(1:4).ne.'ENER').and. -c & (filab(8)(1:4).ne.'SDV ').and.(filab(9)(1:4).ne.'HFL ').and. -c & (iinc.le.1)) then - if((filab(3)(1:4).ne.'S ').and.(filab(4)(1:4).ne.'E ').and. - & (filab(6)(1:4).ne.'PEEQ').and.(filab(7)(1:4).ne.'ENER').and. - & (filab(8)(1:4).ne.'SDV ').and.(filab(9)(1:4).ne.'HFL ')) then -! - nfield=0 - ndim=0 - iorienglob=0 - cflag=filab(1)(5:5) - call extrapolate(stx,stn,ipkon,inum,kon,lakon,nfield,nk, - & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, - & nelemload,nload,nodeboun,nboun,fluid,ndirboun,vold, - & ithermal,force) - endif -! - if(fluid) then - call fluidextrapolate(v,ipkon,inum,kon,lakon,ne,mi) - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/resultsk.f calculix-ccx-2.3/ccx_2.1/src/resultsk.f --- calculix-ccx-2.1/ccx_2.1/src/resultsk.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/resultsk.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,72 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine resultsk(nk,nactdok,vtu,solk,solt,ipompc,nodempc, - & coefmpc,nmpc) -! -! calculates the turbulence correction (STEP 5) in the nodes -! - implicit none -! - integer ipompc(*),nodempc(3,*),nmpc,nk,nactdok(*),i,ist, - & node,ndir,index -! - real*8 coefmpc(*),solk(*),vtu(2,*),fixed_dispk,fixed_dispt, - & solt(*) -! -! extracting the pressure correction from the solution -! - do i=1,nk - if(nactdok(i).ne.0) then - vtu(1,i)=solk(nactdok(i)) - vtu(2,i)=solt(nactdok(i)) - else - vtu(1,i)=0.d0 - vtu(2,i)=0.d0 - endif - enddo -! -! inserting the mpc information: it is assumed that the -! temperature MPC's also apply to the turbulence -! -c do i=1,nmpc -c ist=ipompc(i) -c node=nodempc(1,ist) -c ndir=nodempc(2,ist) -c if(ndir.ne.0) cycle -c index=nodempc(3,ist) -c fixed_dispk=0.d0 -c fixed_dispt=0.d0 -c if(index.ne.0) then -c do -c fixed_dispk=fixed_dispk-coefmpc(index)* -c & vtu(1,nodempc(1,index)) -c fixed_dispt=fixed_dispt-coefmpc(index)* -c & vtu(2,nodempc(1,index)) -c index=nodempc(3,index) -c if(index.eq.0) exit -c enddo -c endif -c fixed_dispk=fixed_dispk/coefmpc(ist) -c vtu(1,node)=fixed_dispk -c fixed_dispt=fixed_dispt/coefmpc(ist) -c vtu(2,node)=fixed_dispt -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/resultsp.f calculix-ccx-2.3/ccx_2.1/src/resultsp.f --- calculix-ccx-2.1/ccx_2.1/src/resultsp.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/resultsp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine resultsp(nk,nactdoh,v,sol,ipompc,nodempc,coefmpc,nmpc, - & mi) -! -! calculates the pressure correction (STEP 2) in the nodes -! - implicit none -! - integer ipompc(*),nodempc(3,*),nmpc,nk,nactdoh(0:4,*),i,ist, - & node,ndir,index,mi(2) -! - real*8 coefmpc(*),sol(*),v(0:mi(2),*),fixed_disp -! -! extracting the pressure correction from the solution -! - do i=1,nk - if(nactdoh(4,i).ne.0) then - v(4,i)=sol(nactdoh(4,i)) -c write(*,*) 'dpressureee ',i,v(4,i) - else - v(4,i)=0.d0 - endif - enddo -c write(*,*) 'sol307',v(4,307) -! -! inserting the mpc information: it is assumed that the -! temperature MPC's also apply to the pressure -! -c do i=1,nmpc -c ist=ipompc(i) -c node=nodempc(1,ist) -c ndir=nodempc(2,ist) -c if(ndir.ne.0) cycle -c index=nodempc(3,ist) -c fixed_disp=0.d0 -c if(index.ne.0) then -c do -c fixed_disp=fixed_disp-coefmpc(index)* -c & v(4,nodempc(1,index)) -c index=nodempc(3,index) -c if(index.eq.0) exit -c enddo -c endif -c fixed_disp=fixed_disp/coefmpc(ist) -c v(4,node)=fixed_disp -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/resultst.f calculix-ccx-2.3/ccx_2.1/src/resultst.f --- calculix-ccx-2.1/ccx_2.1/src/resultst.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/resultst.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine resultst(nk,nactdoh,v,sol,ipompc,nodempc,coefmpc,nmpc, - & mi) -! -! calculates the energy correction (STEP 4) in the nodes -! - implicit none -! - integer ipompc(*),nodempc(3,*),nmpc,nk,nactdoh(0:4,*),i,j,ist, - & node,ndir,index,mi(2) -! - real*8 coefmpc(*),sol(*),v(0:mi(2),*),fixed_disp -! -! extracting the energy correction from the solution -! - do i=1,nk - if(nactdoh(0,i).ne.0) then - v(0,i)=sol(nactdoh(0,i)) - else - v(0,i)=0.d0 - endif -c write(*,*) 'resultst ',i,nactdoh(0,i),v(0,i) - enddo -c write(*,*) 'sol307',v(0,307) -! -! inserting the mpc information -! -c do i=1,nmpc -c ist=ipompc(i) -c node=nodempc(1,ist) -c ndir=nodempc(2,ist) -c if(ndir.ne.0) cycle -c index=nodempc(3,ist) -c fixed_disp=0.d0 -c if(index.ne.0) then -c do -c fixed_disp=fixed_disp-coefmpc(index)* -c & v(nodempc(2,index),nodempc(1,index)) -c index=nodempc(3,index) -c if(index.eq.0) exit -c enddo -c endif -c fixed_disp=fixed_disp/coefmpc(ist) -c v(ndir,node)=fixed_disp -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/resultsv1.f calculix-ccx-2.3/ccx_2.1/src/resultsv1.f --- calculix-ccx-2.1/ccx_2.1/src/resultsv1.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/resultsv1.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine resultsv1(nk,nactdoh,v,sol,ipompc,nodempc,coefmpc,nmpc, - & mi) -! -! calculates the velocity correction (STEP 1) in the nodes -! - implicit none -! - integer ipompc(*),nodempc(3,*),nmpc,nk,nactdoh(0:4,*),i,j,ist, - & node,ndir,index,mi(2) -! - real*8 coefmpc(*),sol(*),v(0:mi(2),*),fixed_disp -! -! extracting the 1st velocity correction from the solution (STEP 1) -! - do i=1,nk - do j=1,3 - if(nactdoh(j,i).ne.0) then - v(j,i)=sol(nactdoh(j,i)) - else - v(j,i)=0.d0 - endif - enddo -c write(*,*) 'sollll ',i,(v(j,i),j=1,3) - enddo -c write(*,*) 'sol307',v(1,307),v(2,307),v(3,307) -! -! inserting the mpc information -! -c do i=1,nmpc -c ist=ipompc(i) -c node=nodempc(1,ist) -c ndir=nodempc(2,ist) -c index=nodempc(3,ist) -c fixed_disp=0.d0 -c if(index.ne.0) then -c do -c fixed_disp=fixed_disp-coefmpc(index)* -c & v(nodempc(2,index),nodempc(1,index)) -c index=nodempc(3,index) -c if(index.eq.0) exit -c enddo -c endif -c fixed_disp=fixed_disp/coefmpc(ist) -c v(ndir,node)=fixed_disp -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/resultsv2.f calculix-ccx-2.3/ccx_2.1/src/resultsv2.f --- calculix-ccx-2.1/ccx_2.1/src/resultsv2.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/resultsv2.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,66 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine resultsv2(nk,nactdoh,v,sol,ipompc,nodempc,coefmpc,nmpc, - & mi) -! -! calculates the velocity correction (STEP 3) in the nodes -! - implicit none -! - integer ipompc(*),nodempc(3,*),nmpc,nk,nactdoh(0:4,*),i,j,ist, - & node,ndir,index,mi(2) -! - real*8 coefmpc(*),sol(*),v(0:mi(2),*),fixed_disp -! -! extracting the 2nd velocity correction from the solution (STEP 3) -! - do i=1,nk - do j=1,3 - if(nactdoh(j,i).ne.0) then - v(j,i)=v(j,i)+sol(nactdoh(j,i)) -c else -c v(j,i)=0.d0 - endif - enddo -c write(*,*) 'sollll ',i,(v(j,i),j=1,3) - enddo -c write(*,*) 'sol307',v(1,307),v(2,307),v(3,307) -! -! inserting the mpc information -! -c do i=1,nmpc -c ist=ipompc(i) -c node=nodempc(1,ist) -c ndir=nodempc(2,ist) -c index=nodempc(3,ist) -c fixed_disp=0.d0 -c if(index.ne.0) then -c do -c fixed_disp=fixed_disp-coefmpc(index)* -c & v(nodempc(2,index),nodempc(1,index)) -c index=nodempc(3,index) -c if(index.eq.0) exit -c enddo -c endif -c fixed_disp=fixed_disp/coefmpc(ist) -c v(ndir,node)=fixed_disp -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/rhs.f calculix-ccx-2.3/ccx_2.1/src/rhs.f --- calculix-ccx-2.1/ccx_2.1/src/rhs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/rhs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,531 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine rhs(co,nk,kon,ipkon,lakon,ne, - & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - & fext,nactdof,neq,nmethod, - & ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon,alcon, - & nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_,t0,t1,ithermal, - & iprestr,vold,iperturb,iexpl,plicon, - & nplicon,plkcon,nplkcon,npmat_,ttime,time,istep,iinc,dtime, - & physcon,ibody,xloadold,reltime,veold,matname,mi,ikactmech, - & nactmech) -! -! filling the right hand side load vector b -! -! b contains the contributions due to mechanical forces only -! - implicit none -! - character*8 lakon(*) - character*20 sideload(*) - character*80 matname(*) -! - integer kon(*),ipompc(*),nodempc(3,*),ipobody(2,*),nbody, - & nodeforc(2,*),ndirforc(*),nelemload(2,*),ikmpc(*),mi(2), - & ilmpc(*),nactdof(0:mi(2),*),konl(20),nelcon(2,*),ibody(3,*), - & nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*),ipkon(*), - & nk,ne,nmpc,nforc,nload,neq,nmethod,nom,m,idm, - & ithermal,iprestr,iperturb,i,j,k,idist,jj, - & id,ist,index,jdof1,jdof,node1,ntmat_,indexe,nope,norien, - & iexpl,idof1,iinc,istep,icalccg,nplicon(0:ntmat_,*), - & nplkcon(0:ntmat_,*),npmat_,ikactmech(*),nactmech -! - real*8 co(3,*),coefmpc(*),xforc(*),xload(2,*),p1(3,2), - & p2(3,2),fext(*),bodyf(3),elcon(0:21,ntmat_,*), - & rhcon(0:1,ntmat_,*),xloadold(2,*),reltime, - & alcon(0:6,ntmat_,*),alzero(*),orab(7,*),xbody(7,*),cgr(4,*), - & t0(*),t1(*),vold(0:mi(2),*),ff(60),time,ttime,dtime, - & plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), - & om(2),physcon(*),veold(0:mi(2),*) -! - icalccg=0 -! - if((nmethod.eq.4).and.(iperturb.lt.2).and.(nactmech.lt.neq/2))then -! -! modal dynamics: only nonzeros are reset to zero -! - do i=1,nactmech - fext(ikactmech(i)+1)=0.d0 - enddo - else - do i=1,neq - fext(i)=0.d0 - enddo - endif - nactmech=0 -! -! distributed forces (body forces or thermal loads or -! residual stresses or distributed face loads) -! -c if((nbody.ne.0).or.(ithermal.ne.0).or. -c & (iprestr.ne.0).or.(nload.ne.0)) then - if((nbody.ne.0).or.(nload.ne.0)) then - idist=1 - else - idist=0 - endif -! -c if((ithermal.le.1).or.(ithermal.eq.3)) then - if(((ithermal.le.1).or.(ithermal.eq.3)).and.(idist.ne.0)) then -! -! mechanical analysis: loop over all elements -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! -! assigning centrifugal forces -! - if(nbody.gt.0) then - nom=0 - om(1)=0.d0 - om(2)=0.d0 - bodyf(1)=0.d0 - bodyf(2)=0.d0 - bodyf(3)=0.d0 -! - index=i - do - j=ipobody(1,index) - if(j.eq.0) exit - if(ibody(1,j).eq.1) then - nom=nom+1 - if(nom.gt.2) then - write(*,*)'*ERROR in rhs: no more than two centri-' - write(*,*)' fugal loading cards allowed' - stop - endif - om(nom)=xbody(1,j) - p1(1,nom)=xbody(2,j) - p1(2,nom)=xbody(3,j) - p1(3,nom)=xbody(4,j) - p2(1,nom)=xbody(5,j) - p2(2,nom)=xbody(6,j) - p2(3,nom)=xbody(7,j) -! -! assigning gravity forces -! - elseif(ibody(1,j).eq.2) then - bodyf(1)=bodyf(1)+xbody(1,j)*xbody(2,j) - bodyf(2)=bodyf(2)+xbody(1,j)*xbody(3,j) - bodyf(3)=bodyf(3)+xbody(1,j)*xbody(4,j) -! -! assigning newton gravity forces -! - elseif(ibody(1,j).eq.3) then - call newton(icalccg,ne,ipkon,lakon,kon,t0,co,rhcon, - & nrhcon,ntmat_,physcon,i,cgr,bodyf,ielmat,ithermal, - & vold) - endif - index=ipobody(2,index) - if(index.eq.0) exit - enddo - endif -! - if(idist.ne.0) - & call e_c3d_rhs(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody, - & ff,i,nmethod,rhcon,ielmat,ntmat_,vold,iperturb, - & nelemload,sideload,xload,nload,idist,ttime,time,istep, - & iinc,dtime,xloadold,reltime,ipompc,nodempc,coefmpc,nmpc, - & ikmpc,ilmpc,veold,matname,mi) -! -! modal dynamics: location of nonzeros is stored -! - if((nmethod.eq.4).and.(iperturb.lt.2)) then - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdof(k,node1) -! -! distributed forces -! - if(idist.ne.0) then - if(dabs(ff(jj)).lt.1.d-30) cycle - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8+k - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - do - jdof1=nactdof(nodempc(2,index), - & nodempc(1,index)) - if(jdof1.ne.0) then - fext(jdof1)=fext(jdof1) - & -coefmpc(index)*ff(jj)/coefmpc(ist) - call nident(ikactmech,jdof1-1,nactmech, - & idm) - do - if(idm.gt.0) then - if(ikactmech(idm).eq.jdof1-1) exit - endif - nactmech=nactmech+1 - do m=nactmech,idm+2,-1 - ikactmech(m)=ikactmech(m-1) - enddo - ikactmech(idm+1)=jdof1-1 - exit - enddo - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - fext(jdof1)=fext(jdof1)+ff(jj) - call nident(ikactmech,jdof1-1,nactmech, - & idm) - do - if(idm.gt.0) then - if(ikactmech(idm).eq.jdof1-1) exit - endif - nactmech=nactmech+1 - do m=nactmech,idm+2,-1 - ikactmech(m)=ikactmech(m-1) - enddo - ikactmech(idm+1)=jdof1-1 - exit - enddo - endif -! - enddo -! -! other procedures -! - else - do jj=1,3*nope -! - j=(jj-1)/3+1 - k=jj-3*(j-1) -! - node1=kon(indexe+j) - jdof1=nactdof(k,node1) -! -! distributed forces -! - if(idist.ne.0) then - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8+k - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - do - jdof1=nactdof(nodempc(2,index), - & nodempc(1,index)) - if(jdof1.ne.0) then - fext(jdof1)=fext(jdof1) - & -coefmpc(index)*ff(jj)/coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - fext(jdof1)=fext(jdof1)+ff(jj) - endif -! - enddo - endif - enddo -! -c else - elseif((ithermal.eq.2).and.(nload.gt.0)) then -! -! thermal analysis: loop over all elements -! - do i=1,ne -! - if(ipkon(i).lt.0) cycle - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - else - cycle - endif -! - do j=1,nope - konl(j)=kon(indexe+j) - enddo -! - if(nload.gt.0) - & call e_c3d_rhs_th(co,nk,konl,lakon(i), - & ff,i,nmethod,t0,t1,vold,nelemload, - & sideload,xload,nload,idist,dtime, - & ttime,time,istep,iinc,xloadold,reltime, - & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,mi) -! -! modal dynamics: location of nonzeros is stored -! - if((nmethod.eq.4.and.(iperturb.lt.2))) then - do jj=1,nope -! - j=jj -! - node1=kon(indexe+j) - jdof1=nactdof(0,node1) -! -! distributed forces -! - if(idist.ne.0) then - if(dabs(ff(jj)).lt.1.d-30) cycle - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8 - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - do - jdof1=nactdof(nodempc(2,index), - & nodempc(1,index)) - if(jdof1.ne.0) then - fext(jdof1)=fext(jdof1) - & -coefmpc(index)*ff(jj)/coefmpc(ist) - call nident(ikactmech,jdof1-1,nactmech, - & idm) - do - if(idm.gt.0) then - if(ikactmech(idm).eq.jdof1-1) exit - endif - nactmech=nactmech+1 - do m=nactmech,idm+2,-1 - ikactmech(m)=ikactmech(m-1) - enddo - ikactmech(idm+1)=jdof1-1 - exit - enddo - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - fext(jdof1)=fext(jdof1)+ff(jj) - call nident(ikactmech,jdof1-1,nactmech, - & idm) - do - if(idm.gt.0) then - if(ikactmech(idm).eq.jdof1-1) exit - endif - nactmech=nactmech+1 - do m=nactmech,idm+2,-1 - ikactmech(m)=ikactmech(m-1) - enddo - ikactmech(idm+1)=jdof1-1 - exit - enddo - endif -! - enddo -! -! -! other procedures -! - else - do jj=1,nope -! - j=jj -! - node1=kon(indexe+j) - jdof1=nactdof(0,node1) -! -! distributed forces -! - if(idist.ne.0) then - if(jdof1.eq.0) then - if(nmpc.ne.0) then - idof1=(node1-1)*8 - call nident(ikmpc,idof1,nmpc,id) - if((id.gt.0).and.(ikmpc(id).eq.idof1)) then - id=ilmpc(id) - ist=ipompc(id) - index=nodempc(3,ist) - do - jdof1=nactdof(nodempc(2,index), - & nodempc(1,index)) - if(jdof1.ne.0) then - fext(jdof1)=fext(jdof1) - & -coefmpc(index)*ff(jj)/coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - cycle - endif - fext(jdof1)=fext(jdof1)+ff(jj) - endif -! - enddo - endif - enddo -! - endif -! -! point forces -! -! modal dynamics: location of nonzeros is stored -! - if((nmethod.eq.4).and.(iperturb.lt.2)) then - do i=1,nforc - if(ndirforc(i).gt.3) cycle - if(dabs(xforc(i)).lt.1.d-30) cycle - jdof=nactdof(ndirforc(i),nodeforc(1,i)) - if(jdof.ne.0) then - fext(jdof)=fext(jdof)+xforc(i) - call nident(ikactmech,jdof-1,nactmech, - & idm) - do - if(idm.gt.0) then - if(ikactmech(idm).eq.jdof-1) exit - endif - nactmech=nactmech+1 - do m=nactmech,idm+2,-1 - ikactmech(m)=ikactmech(m-1) - enddo - ikactmech(idm+1)=jdof-1 - exit - enddo - else -! -! node is a dependent node of a MPC: distribute -! the forces among the independent nodes -! (proportional to their coefficients) -! - jdof=8*(nodeforc(1,i)-1)+ndirforc(i) - call nident(ikmpc,jdof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.jdof) then - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof=nactdof(nodempc(2,index),nodempc(1,index)) - if(jdof.ne.0) then - fext(jdof)=fext(jdof)- - & coefmpc(index)*xforc(i)/coefmpc(ist) - call nident(ikactmech,jdof-1,nactmech, - & idm) - do - if(idm.gt.0) then - if(ikactmech(idm).eq.jdof-1) exit - endif - nactmech=nactmech+1 - do m=nactmech,idm+2,-1 - ikactmech(m)=ikactmech(m-1) - enddo - ikactmech(idm+1)=jdof-1 - exit - enddo - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - endif - enddo - else -! -! other procedures -! - do i=1,nforc - if(ndirforc(i).gt.3) cycle - jdof=nactdof(ndirforc(i),nodeforc(1,i)) - if(jdof.ne.0) then - fext(jdof)=fext(jdof)+xforc(i) - else -! -! node is a dependent node of a MPC: distribute -! the forces among the independent nodes -! (proportional to their coefficients) -! - jdof=8*(nodeforc(1,i)-1)+ndirforc(i) - call nident(ikmpc,jdof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.jdof) then - ist=ipompc(id) - index=nodempc(3,ist) - if(index.eq.0) cycle - do - jdof=nactdof(nodempc(2,index),nodempc(1,index)) - if(jdof.ne.0) then - fext(jdof)=fext(jdof)- - & coefmpc(index)*xforc(i)/coefmpc(ist) - endif - index=nodempc(3,index) - if(index.eq.0) exit - enddo - endif - endif - endif - enddo - endif -c write(*,*) 'rhs ' -c write(*,'(6(1x,e11.4))') (fext(i),i=1,neq) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/rigidbodies.f calculix-ccx-2.3/ccx_2.1/src/rigidbodies.f --- calculix-ccx-2.1/ccx_2.1/src/rigidbodies.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/rigidbodies.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,340 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine rigidbodies(inpc,textpart,set,istartset,iendset, - & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon,ipkon,kon,nk,nk_, - & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_,iperturb,ne_, - & ctrl,typeboun,istep,istat,n,iline,ipol,inl,ipoinp,inp,co, - & ipoinpc) -! -! reading the input deck: *RIGID BODY -! - implicit none -! - character*1 typeboun(*),inpc(*) - character*8 lakon(*) - character*20 labmpc(*) - character*81 set(*),elset,noset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),ipompc(*),nodempc(3,*), - & nset,nset_,nalset,nalset_,nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), - & ilmpc(*),ipkon(*),kon(*),inoset,ielset,i,node,ielement,id, - & indexe,nope,istep,istat,n,irefnode,irotnode,ne_, - & j,idof,k,nodeboun(*),ndirboun(*),ikboun(*),ilboun(*), - & nboun,nboun_,key,iperturb,ipos,iline,ipol,inl,ipoinp(2,*), - & inp(3,*),ipoinpc(0:*) -! - real*8 coefmpc(3,*),ctrl(*),co(3,*) -! - if(istep.gt.0) then - write(*,*) - & '*ERROR in rigidbodies: *RIGID BODY should be placed' - write(*,*) ' before all step definitions' - stop - endif -! -! the *RIGID BODY option implies a nonlinear geometric -! calculation -! - if(iperturb.eq.1) then - write(*,*) '*ERROR in rigidbodies: the *RIGID BODY option' - write(*,*) ' cannot be used in a perturbation step' - stop - endif -! - elset=' - & ' - noset=' - & ' - irefnode=0 - irotnode=0 -! - do i=2,n - if(textpart(i)(1:6).eq.'ELSET=') then - if(noset(1:1).eq.' ') then - elset(1:80)=textpart(i)(7:86) - ipos=index(elset,' ') - elset(ipos:ipos)='E' - else - write(*,*) '*ERROR in rigidbodies: either NSET or' - write(*,*) ' ELSET can be specified, not both' - stop - endif - elseif(textpart(i)(1:5).eq.'NSET=') then - if(elset(1:1).eq.' ') then - noset(1:80)=textpart(i)(6:85) - ipos=index(noset,' ') - noset(ipos:ipos)='N' - else - write(*,*) '*ERROR in rigidbodies: either NSET or' - write(*,*) ' ELSET can be specified, not both' - stop - endif - elseif(textpart(i)(1:8).eq.'REFNODE=') then - read(textpart(i)(9:18),'(i10)',iostat=istat) irefnode - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(irefnode.gt.nk) then - write(*,*) '*ERROR in rigidbodies: ref node',irefnode - write(*,*) ' has not been defined' - stop - endif - elseif(textpart(i)(1:8).eq.'ROTNODE=') then - read(textpart(i)(9:18),'(i10)',iostat=istat) irotnode - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(irefnode.gt.nk) then - write(*,*) '*ERROR in rigidbodies: rot node',irotnode - write(*,*) ' has not been defined' - stop - endif - endif - enddo -! -! check whether a set was defined -! - if((elset(1:1).eq.' ').and. - & (noset(1:1).eq.' ')) then - write(*,*) '*WARNING in rigidbodies: no set defined' - return - endif -! - inoset=0 - ielset=0 -! -! checking whether the set exists -! - if(noset(1:1).ne.' ') then - do i=1,nset - if(set(i).eq.noset) then - inoset=i - exit - endif - enddo - if(inoset.eq.0) then - write(*,*) '*WARNING in rigidbodies: node set ',noset - write(*,*) ' does not exist' - return - endif - endif -! - if(elset(1:1).ne.' ') then - do i=1,nset - if(set(i).eq.elset) then - ielset=i - exit - endif - enddo - if(ielset.eq.0) then - write(*,*) '*WARNING in rigidbodies: element set ',elset - write(*,*) ' does not exist' - return - endif - endif -! -! check for the existence of irefnode and irotnode; if none were -! defined, new nodes are generated -! - if(irefnode.eq.0) then - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in rigidbodies: increase nk_' - stop - endif - irefnode=nk - endif -! - if(irotnode.eq.0) then - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in rigidbodies: increase nk_' - stop - endif - irotnode=nk - endif -! -! check whether other equations apply to the dependent nodes -! - if(inoset.ne.0) then - do i=istartset(inoset),iendset(inoset) - node=ialset(i) - if(node.gt.nk_) then - write(*,*) '*ERROR in rigidbodies: node ',node - write(*,*) ' belonging to set ',noset - write(*,*) ' has not been defined' - stop - endif - if((node.eq.irefnode).or.(node.eq.irotnode)) cycle - do j=1,3 - idof=8*(node-1)+j - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*WARNING in rigidbodies: dof ',j - write(*,*) ' of node ',node,' belonging' - write(*,*) ' to a rigid body is detected' - write(*,*) ' on the dependent side of ' - write(*,*) ' another equation; no rigid' - write(*,*) ' body constrained applied' - endif - endif - enddo - enddo - endif -! - if(ielset.ne.0) then - do i=istartset(ielset),iendset(ielset) - ielement=ialset(i) - if(ielement.gt.ne_) then - write(*,*) '*ERROR in rigidbodies: element ',ielement - write(*,*) ' belonging to set ',elset - write(*,*) ' has not been defined' - stop - endif - if(ipkon(ielement).lt.0) cycle - indexe=ipkon(ielement) - if(lakon(ielement)(4:4).eq.'2') then - nope=20 - elseif(lakon(ielement)(4:4).eq.'8') then - nope=8 - elseif(lakon(ielement)(4:5).eq.'10') then - nope=10 - elseif(lakon(ielement)(4:4).eq.'4') then - nope=4 - elseif(lakon(ielement)(4:5).eq.'15') then - nope=15 - else - nope=6 - endif - do k=indexe+1,indexe+nope - node=kon(k) - if((node.eq.irefnode).or.(node.eq.irotnode)) cycle - do j=1,3 - idof=8*(node-1)+j - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*)'*WARNING in rigidbodies: dof ',j,'of - &node ',node,' belonging to a' - write(*,*)' rigid body is detected on th - &e dependent side of another' - write(*,*)' equation; no rigid body cons - &trained applied' - endif - endif - enddo - enddo - enddo - endif -! -! generating the equations in basis form -! -! node set -! - if(inoset.ne.0) then - do i=istartset(inoset),iendset(inoset) - node=ialset(i) - if(node.gt.0) then - if((node.eq.irefnode).or.(node.eq.irotnode)) cycle - call rigidmpc(ipompc,nodempc,coefmpc,irefnode,irotnode, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_, - & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_,node, - & typeboun,co) - else - node=ialset(i-2) - do - node=node-ialset(i) - if(node.ge.ialset(i-1)) exit - if((node.eq.irefnode).or.(node.eq.irotnode)) cycle - call rigidmpc(ipompc,nodempc,coefmpc,irefnode, - & irotnode,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun,nboun, - & nboun_,node,typeboun,co) - enddo - endif - enddo - endif -! -! element set -! - if(ielset.ne.0) then - do i=istartset(ielset),iendset(ielset) - ielement=ialset(i) - if(ielement.gt.0) then - if(ipkon(ielement).lt.0) cycle - indexe=ipkon(ielement) - if(lakon(ielement)(4:4).eq.'2') then - nope=20 - elseif(lakon(ielement)(4:4).eq.'8') then - nope=8 - elseif(lakon(ielement)(4:5).eq.'10') then - nope=10 - elseif(lakon(ielement)(4:4).eq.'4') then - nope=4 - elseif(lakon(ielement)(4:5).eq.'15') then - nope=15 - else - nope=6 - endif - do k=indexe+1,indexe+nope - node=kon(k) - if((node.eq.irefnode).or.(node.eq.irotnode)) cycle - call rigidmpc(ipompc,nodempc,coefmpc,irefnode, - & irotnode,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, - & nk,nk_,nodeboun,ndirboun,ikboun,ilboun,nboun, - & nboun_,node,typeboun,co) - enddo - else - ielement=ialset(i-2) - do - ielement=ielement-ialset(i) - if(ielement.ge.ialset(i-1)) exit - if(ipkon(ielement).lt.0) cycle - indexe=ipkon(ielement) - if(lakon(ielement)(4:4).eq.'2') then - nope=20 - elseif(lakon(ielement)(4:4).eq.'8') then - nope=8 - elseif(lakon(ielement)(4:5).eq.'10') then - nope=10 - elseif(lakon(ielement)(4:4).eq.'4') then - nope=4 - elseif(lakon(ielement)(4:5).eq.'15') then - nope=15 - else - nope=6 - endif - do k=indexe+1,indexe+nope - node=kon(k) - if((node.eq.irefnode).or.(node.eq.irotnode)) cycle - call rigidmpc(ipompc,nodempc,coefmpc,irefnode, - & irotnode,labmpc,nmpc,nmpc_,mpcfree,ikmpc, - & ilmpc,nk,nk_,nodeboun,ndirboun,ikboun,ilboun, - & nboun,nboun_,node,typeboun,co) - enddo - enddo - endif - enddo - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/rigidmpc.f calculix-ccx-2.3/ccx_2.1/src/rigidmpc.f --- calculix-ccx-2.1/ccx_2.1/src/rigidmpc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/rigidmpc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,130 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine rigidmpc(ipompc,nodempc,coefmpc,irefnode,irotnode, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, - & ikboun,ilboun,nboun,nboun_,node,typeboun,co) -! -! generates three rigid body MPC's for node "node" about reference -! (translational) node irefnode and rotational node irotnode -! - implicit none -! - character*1 typeboun(*) - character*20 labmpc(*) -! - integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), - & ilmpc(*),node,id,mpcfreeold,j,idof,l,nodeboun(*), - & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,irefnode, - & irotnode -! - real*8 coefmpc(*),co(3,*),e(3,3,3) -! - data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., - & 0.,0.,1.,0.,0.,0.,-1.,0.,0., - & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ -! - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in rigidmpc: increase nk_' - stop - endif - do j=1,3 - idof=8*(node-1)+j - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - cycle - endif - endif - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in rigidmpc: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)='RIGID ' -! - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=j - coefmpc(mpcfree)=1.d0 - mpcfree=nodempc(3,mpcfree) -! -! translation term -! - nodempc(1,mpcfree)=irefnode - nodempc(2,mpcfree)=j - coefmpc(mpcfree)=-1.d0 - mpcfree=nodempc(3,mpcfree) -! -! rotation terms -! - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=1 - coefmpc(mpcfree)=e(j,1,1)*(co(1,irefnode)-co(1,node))+ - & e(j,2,1)*(co(2,irefnode)-co(2,node))+ - & e(j,3,1)*(co(3,irefnode)-co(3,node)) - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=2 - coefmpc(mpcfree)=e(j,1,2)*(co(1,irefnode)-co(1,node))+ - & e(j,2,2)*(co(2,irefnode)-co(2,node))+ - & e(j,3,2)*(co(3,irefnode)-co(3,node)) - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=irotnode - nodempc(2,mpcfree)=3 - coefmpc(mpcfree)=e(j,1,3)*(co(1,irefnode)-co(1,node))+ - & e(j,2,3)*(co(2,irefnode)-co(2,node))+ - & e(j,3,3)*(co(3,irefnode)-co(3,node)) - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=j - coefmpc(mpcfree)=1.d0 - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - idof=8*(nk-1)+j - call nident(ikboun,idof,nboun,id) - nboun=nboun+1 - if(nboun.gt.nboun_) then - write(*,*) '*ERROR in rigidmpc: increase nboun_' - stop - endif - nodeboun(nboun)=nk - ndirboun(nboun)=j - typeboun(nboun)='R' - do l=nboun,id+2,-1 - ikboun(l)=ikboun(l-1) - ilboun(l)=ilboun(l-1) - enddo - ikboun(id+1)=idof - ilboun(id+1)=nboun - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/rimseal_calc.f calculix-ccx-2.3/ccx_2.1/src/rimseal_calc.f --- calculix-ccx-2.1/ccx_2.1/src/rimseal_calc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/rimseal_calc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine rimseal_calc(p1) -! -! rimseal element -! - implicit none -! - real*8 p1 -! - write(*,*) 'p1' - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/rimseal.f calculix-ccx-2.3/ccx_2.1/src/rimseal.f --- calculix-ccx-2.1/ccx_2.1/src/rimseal.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/rimseal.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine rimseal(node1,node2,nodem,nelem,lakon,kon,ipkon, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,cp,R,physcon,dvi,numf,set,mi) -! -! rimseal element -! - implicit none -! - logical identity - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, - & ielprop(*),nodef(4),idirf(4),index,iflag,mi(2), - & inv,ipkon(*),kon(*),kgas,nelem_in,nelem_out, - & element0,node10,node20,node11,node21,node12,node22,node_cav, - & node_main,node_main2,node_in1,node_out1,node_in2,node_out2 -! - - real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R,a,d, - & p1,p2,T1,T2,Aeff,C1,C2,C3,cd,cp,physcon(3),p2p1,km1,dvi, - & kp1,kdkm1,tdkp1,km1dk,x,y,ca1,cb1,ca2,cb2,dT1,alambda, - & reynolds,pi,xflow_oil,s,Tcav,pcav,pmin,pmax, - & Tref,Alpha1, Alpha2, Alpha3, GF,kf,MRTAP_ref_ein, - & MRTAP_ref_aus, m_ref_ein, m_ref_aus,maus_zu_mref, - & mein_zu_mref, A_aus, A_ein, A_ges,m_aus, m_ein, m_sperr -! - pi=4.d0*datan(1.d0) - - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif (iflag.eq.1) then -! - p1=v(2,node1) - call rimseal_calc(p1) - elseif (iflag.eq.2) then -! - elseif (iflag.eq.3) then -! - endif - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/rootls.f calculix-ccx-2.3/ccx_2.1/src/rootls.f --- calculix-ccx-2.1/ccx_2.1/src/rootls.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/rootls.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine rootls(n,root,maxwid,e2,adj,xadj,mask,ls,xls,depth, - & width) -! -! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) -! - integer root,depth,nbr,maxwid,lstrt,lstop,lwdth,node,nc,width,n, - & jstrt,jstop,i,j,e2,xadj(n+1),adj(e2),mask(n),xls(n+1),ls(n) -! - mask(root)=1 - ls(1)=root - nc=1 - width=1 - depth=0 - lstop=0 - lwdth=1 - 10 if(lwdth.gt.0) then -! - lstrt=lstop+1 - lstop=nc - depth=depth+1 - xls(depth)=lstrt -! - do 30 i=lstrt,lstop - node=ls(i) - jstrt=xadj(node) - jstop=xadj(node+1)-1 - do 20 j=jstrt,jstop - nbr=adj(j) - if(mask(nbr).eq.0) then - nc=nc+1 - ls(nc)=nbr - mask(nbr)=1 - endif - 20 continue - 30 continue -! - lwdth=nc-lstop - width=max(lwdth,width) -! - if(width.ge.maxwid) go to 35 - go to 10 - endif - xls(depth+1)=lstop+1 -! - 35 continue - do 40 i=1,nc - mask(ls(i))=0 - 40 continue - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/rs.f calculix-ccx-2.3/ccx_2.1/src/rs.f --- calculix-ccx-2.1/ccx_2.1/src/rs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/rs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,683 +0,0 @@ - double precision function pythag(a,b) - double precision a,b -c -c finds dsqrt(a**2+b**2) without overflow or destructive underflow -c - double precision p,r,s,t,u - p = dmax1(dabs(a),dabs(b)) - if (p .eq. 0.0d0) go to 20 - r = (dmin1(dabs(a),dabs(b))/p)**2 - 10 continue - t = 4.0d0 + r - if (t .eq. 4.0d0) go to 20 - s = r/t - u = 1.0d0 + 2.0d0*s - p = u*p - r = (s/u)**2 * r - go to 10 - 20 pythag = p - return - end - subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr) -c - integer n,nm,ierr,matz - double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n) -c -c this subroutine calls the recommended sequence of -c subroutines from the eigensystem subroutine package (eispack) -c to find the eigenvalues and eigenvectors (if desired) -c of a real symmetric matrix. -c -c on input -c -c nm must be set to the row dimension of the two-dimensional -c array parameters as declared in the calling program -c dimension statement. -c -c n is the order of the matrix a. -c -c a contains the real symmetric matrix. -c -c matz is an integer variable set equal to zero if -c only eigenvalues are desired. otherwise it is set to -c any non-zero integer for both eigenvalues and eigenvectors. -c -c on output -c -c w contains the eigenvalues in ascending order. -c -c z contains the eigenvectors if matz is not zero. -c -c ierr is an integer output variable set equal to an error -c completion code described in the documentation for tqlrat -c and tql2. the normal completion code is zero. -c -c fv1 and fv2 are temporary storage arrays. -c -c questions and comments should be directed to burton s. garbow, -c mathematics and computer science div, argonne national laboratory -c -c this version dated august 1983. -c -c ------------------------------------------------------------------ -c - if (n .le. nm) go to 10 - ierr = 10 * n - go to 50 -c - 10 if (matz .ne. 0) go to 20 -c .......... find eigenvalues only .......... - call tred1(nm,n,a,w,fv1,fv2) -* tqlrat encounters catastrophic underflow on the Vax -* call tqlrat(n,w,fv2,ierr) - call tql1(n,w,fv1,ierr) - go to 50 -c .......... find both eigenvalues and eigenvectors .......... - 20 call tred2(nm,n,a,w,fv1,z) - call tql2(nm,n,w,fv1,z,ierr) - 50 return - end - subroutine tql1(n,d,e,ierr) -c - integer i,j,l,m,n,ii,l1,l2,mml,ierr - double precision d(n),e(n) - double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag -c -c this subroutine is a translation of the algol procedure tql1, -c num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and -c wilkinson. -c handbook for auto. comp., vol.ii-linear algebra, 227-240(1971). -c -c this subroutine finds the eigenvalues of a symmetric -c tridiagonal matrix by the ql method. -c -c on input -c -c n is the order of the matrix. -c -c d contains the diagonal elements of the input matrix. -c -c e contains the subdiagonal elements of the input matrix -c in its last n-1 positions. e(1) is arbitrary. -c -c on output -c -c d contains the eigenvalues in ascending order. if an -c error exit is made, the eigenvalues are correct and -c ordered for indices 1,2,...ierr-1, but may not be -c the smallest eigenvalues. -c -c e has been destroyed. -c -c ierr is set to -c zero for normal return, -c j if the j-th eigenvalue has not been -c determined after 30 iterations. -c -c calls pythag for dsqrt(a*a + b*b) . -c -c questions and comments should be directed to burton s. garbow, -c mathematics and computer science div, argonne national laboratory -c -c this version dated august 1983. -c -c ------------------------------------------------------------------ -c - ierr = 0 - if (n .eq. 1) go to 1001 -c - do 100 i = 2, n - 100 e(i-1) = e(i) -c - f = 0.0d0 - tst1 = 0.0d0 - e(n) = 0.0d0 -c - do 290 l = 1, n - j = 0 - h = dabs(d(l)) + dabs(e(l)) - if (tst1 .lt. h) tst1 = h -c .......... look for small sub-diagonal element .......... - do 110 m = l, n - tst2 = tst1 + dabs(e(m)) - if (tst2 .eq. tst1) go to 120 -c .......... e(n) is always zero, so there is no exit -c through the bottom of the loop .......... - 110 continue -c - 120 if (m .eq. l) go to 210 - 130 if (j .eq. 30) go to 1000 - j = j + 1 -c .......... form shift .......... - l1 = l + 1 - l2 = l1 + 1 - g = d(l) - p = (d(l1) - g) / (2.0d0 * e(l)) - r = pythag(p,1.0d0) - d(l) = e(l) / (p + dsign(r,p)) - d(l1) = e(l) * (p + dsign(r,p)) - dl1 = d(l1) - h = g - d(l) - if (l2 .gt. n) go to 145 -c - do 140 i = l2, n - 140 d(i) = d(i) - h -c - 145 f = f + h -c .......... ql transformation .......... - p = d(m) - c = 1.0d0 - c2 = c - el1 = e(l1) - s = 0.0d0 - mml = m - l -c .......... for i=m-1 step -1 until l do -- .......... - do 200 ii = 1, mml - c3 = c2 - c2 = c - s2 = s - i = m - ii - g = c * e(i) - h = c * p - r = pythag(p,e(i)) - e(i+1) = s * r - s = e(i) / r - c = p / r - p = c * d(i) - s * g - d(i+1) = h + s * (c * g + s * d(i)) - 200 continue -c - p = -s * s2 * c3 * el1 * e(l) / dl1 - e(l) = s * p - d(l) = c * p - tst2 = tst1 + dabs(e(l)) - if (tst2 .gt. tst1) go to 130 - 210 p = d(l) + f -c .......... order eigenvalues .......... - if (l .eq. 1) go to 250 -c .......... for i=l step -1 until 2 do -- .......... - do 230 ii = 2, l - i = l + 2 - ii - if (p .ge. d(i-1)) go to 270 - d(i) = d(i-1) - 230 continue -c - 250 i = 1 - 270 d(i) = p - 290 continue -c - go to 1001 -c .......... set error -- no convergence to an -c eigenvalue after 30 iterations .......... - 1000 ierr = l - 1001 return - end - subroutine tql2(nm,n,d,e,z,ierr) -c - integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr - double precision d(n),e(n),z(nm,n) - double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag -c -c this subroutine is a translation of the algol procedure tql2, -c num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and -c wilkinson. -c handbook for auto. comp., vol.ii-linear algebra, 227-240(1971). -c -c this subroutine finds the eigenvalues and eigenvectors -c of a symmetric tridiagonal matrix by the ql method. -c the eigenvectors of a full symmetric matrix can also -c be found if tred2 has been used to reduce this -c full matrix to tridiagonal form. -c -c on input -c -c nm must be set to the row dimension of two-dimensional -c array parameters as declared in the calling program -c dimension statement. -c -c n is the order of the matrix. -c -c d contains the diagonal elements of the input matrix. -c -c e contains the subdiagonal elements of the input matrix -c in its last n-1 positions. e(1) is arbitrary. -c -c z contains the transformation matrix produced in the -c reduction by tred2, if performed. if the eigenvectors -c of the tridiagonal matrix are desired, z must contain -c the identity matrix. -c -c on output -c -c d contains the eigenvalues in ascending order. if an -c error exit is made, the eigenvalues are correct but -c unordered for indices 1,2,...,ierr-1. -c -c e has been destroyed. -c -c z contains orthonormal eigenvectors of the symmetric -c tridiagonal (or full) matrix. if an error exit is made, -c z contains the eigenvectors associated with the stored -c eigenvalues. -c -c ierr is set to -c zero for normal return, -c j if the j-th eigenvalue has not been -c determined after 30 iterations. -c -c calls pythag for dsqrt(a*a + b*b) . -c -c questions and comments should be directed to burton s. garbow, -c mathematics and computer science div, argonne national laboratory -c -c this version dated august 1983. -c -c ------------------------------------------------------------------ -c - ierr = 0 - if (n .eq. 1) go to 1001 -c - do 100 i = 2, n - 100 e(i-1) = e(i) -c - f = 0.0d0 - tst1 = 0.0d0 - e(n) = 0.0d0 -c - do 240 l = 1, n - j = 0 - h = dabs(d(l)) + dabs(e(l)) - if (tst1 .lt. h) tst1 = h -c .......... look for small sub-diagonal element .......... - do 110 m = l, n - tst2 = tst1 + dabs(e(m)) - if (tst2 .eq. tst1) go to 120 -c .......... e(n) is always zero, so there is no exit -c through the bottom of the loop .......... - 110 continue -c - 120 if (m .eq. l) go to 220 - 130 if (j .eq. 30) go to 1000 - j = j + 1 -c .......... form shift .......... - l1 = l + 1 - l2 = l1 + 1 - g = d(l) - p = (d(l1) - g) / (2.0d0 * e(l)) - r = pythag(p,1.0d0) - d(l) = e(l) / (p + dsign(r,p)) - d(l1) = e(l) * (p + dsign(r,p)) - dl1 = d(l1) - h = g - d(l) - if (l2 .gt. n) go to 145 -c - do 140 i = l2, n - 140 d(i) = d(i) - h -c - 145 f = f + h -c .......... ql transformation .......... - p = d(m) - c = 1.0d0 - c2 = c - el1 = e(l1) - s = 0.0d0 - mml = m - l -c .......... for i=m-1 step -1 until l do -- .......... - do 200 ii = 1, mml - c3 = c2 - c2 = c - s2 = s - i = m - ii - g = c * e(i) - h = c * p - r = pythag(p,e(i)) - e(i+1) = s * r - s = e(i) / r - c = p / r - p = c * d(i) - s * g - d(i+1) = h + s * (c * g + s * d(i)) -c .......... form vector .......... - do 180 k = 1, n - h = z(k,i+1) - z(k,i+1) = s * z(k,i) + c * h - z(k,i) = c * z(k,i) - s * h - 180 continue -c - 200 continue -c - p = -s * s2 * c3 * el1 * e(l) / dl1 - e(l) = s * p - d(l) = c * p - tst2 = tst1 + dabs(e(l)) - if (tst2 .gt. tst1) go to 130 - 220 d(l) = d(l) + f - 240 continue -c .......... order eigenvalues and eigenvectors .......... - do 300 ii = 2, n - i = ii - 1 - k = i - p = d(i) -c - do 260 j = ii, n - if (d(j) .ge. p) go to 260 - k = j - p = d(j) - 260 continue -c - if (k .eq. i) go to 300 - d(k) = d(i) - d(i) = p -c - do 280 j = 1, n - p = z(j,i) - z(j,i) = z(j,k) - z(j,k) = p - 280 continue -c - 300 continue -c - go to 1001 -c .......... set error -- no convergence to an -c eigenvalue after 30 iterations .......... - 1000 ierr = l - 1001 return - end - subroutine tred1(nm,n,a,d,e,e2) -c - integer i,j,k,l,n,ii,nm,jp1 - double precision a(nm,n),d(n),e(n),e2(n) - double precision f,g,h,scale -c -c this subroutine is a translation of the algol procedure tred1, -c num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson. -c handbook for auto. comp., vol.ii-linear algebra, 212-226(1971). -c -c this subroutine reduces a real symmetric matrix -c to a symmetric tridiagonal matrix using -c orthogonal similarity transformations. -c -c on input -c -c nm must be set to the row dimension of two-dimensional -c array parameters as declared in the calling program -c dimension statement. -c -c n is the order of the matrix. -c -c a contains the real symmetric input matrix. only the -c lower triangle of the matrix need be supplied. -c -c on output -c -c a contains information about the orthogonal trans- -c formations used in the reduction in its strict lower -c triangle. the full upper triangle of a is unaltered. -c -c d contains the diagonal elements of the tridiagonal matrix. -c -c e contains the subdiagonal elements of the tridiagonal -c matrix in its last n-1 positions. e(1) is set to zero. -c -c e2 contains the squares of the corresponding elements of e. -c e2 may coincide with e if the squares are not needed. -c -c questions and comments should be directed to burton s. garbow, -c mathematics and computer science div, argonne national laboratory -c -c this version dated august 1983. -c -c ------------------------------------------------------------------ -c - do 100 i = 1, n - d(i) = a(n,i) - a(n,i) = a(i,i) - 100 continue -c .......... for i=n step -1 until 1 do -- .......... - do 300 ii = 1, n - i = n + 1 - ii - l = i - 1 - h = 0.0d0 - scale = 0.0d0 - if (l .lt. 1) go to 130 -c .......... scale row (algol tol then not needed) .......... - do 120 k = 1, l - 120 scale = scale + dabs(d(k)) -c - if (scale .ne. 0.0d0) go to 140 -c - do 125 j = 1, l - d(j) = a(l,j) - a(l,j) = a(i,j) - a(i,j) = 0.0d0 - 125 continue -c - 130 e(i) = 0.0d0 - e2(i) = 0.0d0 - go to 300 -c - 140 do 150 k = 1, l - d(k) = d(k) / scale - h = h + d(k) * d(k) - 150 continue -c - e2(i) = scale * scale * h - f = d(l) - g = -dsign(dsqrt(h),f) - e(i) = scale * g - h = h - f * g - d(l) = f - g - if (l .eq. 1) go to 285 -c .......... form a*u .......... - do 170 j = 1, l - 170 e(j) = 0.0d0 -c - do 240 j = 1, l - f = d(j) - g = e(j) + a(j,j) * f - jp1 = j + 1 - if (l .lt. jp1) go to 220 -c - do 200 k = jp1, l - g = g + a(k,j) * d(k) - e(k) = e(k) + a(k,j) * f - 200 continue -c - 220 e(j) = g - 240 continue -c .......... form p .......... - f = 0.0d0 -c - do 245 j = 1, l - e(j) = e(j) / h - f = f + e(j) * d(j) - 245 continue -c - h = f / (h + h) -c .......... form q .......... - do 250 j = 1, l - 250 e(j) = e(j) - h * d(j) -c .......... form reduced a .......... - do 280 j = 1, l - f = d(j) - g = e(j) -c - do 260 k = j, l - 260 a(k,j) = a(k,j) - f * e(k) - g * d(k) -c - 280 continue -c - 285 do 290 j = 1, l - f = d(j) - d(j) = a(l,j) - a(l,j) = a(i,j) - a(i,j) = f * scale - 290 continue -c - 300 continue -c - return - end - subroutine tred2(nm,n,a,d,e,z) -c - integer i,j,k,l,n,ii,nm,jp1 - double precision a(nm,n),d(n),e(n),z(nm,n) - double precision f,g,h,hh,scale -c -c this subroutine is a translation of the algol procedure tred2, -c num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson. -c handbook for auto. comp., vol.ii-linear algebra, 212-226(1971). -c -c this subroutine reduces a real symmetric matrix to a -c symmetric tridiagonal matrix using and accumulating -c orthogonal similarity transformations. -c -c on input -c -c nm must be set to the row dimension of two-dimensional -c array parameters as declared in the calling program -c dimension statement. -c -c n is the order of the matrix. -c -c a contains the real symmetric input matrix. only the -c lower triangle of the matrix need be supplied. -c -c on output -c -c d contains the diagonal elements of the tridiagonal matrix. -c -c e contains the subdiagonal elements of the tridiagonal -c matrix in its last n-1 positions. e(1) is set to zero. -c -c z contains the orthogonal transformation matrix -c produced in the reduction. -c -c a and z may coincide. if distinct, a is unaltered. -c -c questions and comments should be directed to burton s. garbow, -c mathematics and computer science div, argonne national laboratory -c -c this version dated august 1983. -c -c ------------------------------------------------------------------ -c - do 100 i = 1, n -c - do 80 j = i, n - 80 z(j,i) = a(j,i) -c - d(i) = a(n,i) - 100 continue -c - if (n .eq. 1) go to 510 -c .......... for i=n step -1 until 2 do -- .......... - do 300 ii = 2, n - i = n + 2 - ii - l = i - 1 - h = 0.0d0 - scale = 0.0d0 - if (l .lt. 2) go to 130 -c .......... scale row (algol tol then not needed) .......... - do 120 k = 1, l - 120 scale = scale + dabs(d(k)) -c - if (scale .ne. 0.0d0) go to 140 - 130 e(i) = d(l) -c - do 135 j = 1, l - d(j) = z(l,j) - z(i,j) = 0.0d0 - z(j,i) = 0.0d0 - 135 continue -c - go to 290 -c - 140 do 150 k = 1, l - d(k) = d(k) / scale - h = h + d(k) * d(k) - 150 continue -c - f = d(l) - g = -dsign(dsqrt(h),f) - e(i) = scale * g - h = h - f * g - d(l) = f - g -c .......... form a*u .......... - do 170 j = 1, l - 170 e(j) = 0.0d0 -c - do 240 j = 1, l - f = d(j) - z(j,i) = f - g = e(j) + z(j,j) * f - jp1 = j + 1 - if (l .lt. jp1) go to 220 -c - do 200 k = jp1, l - g = g + z(k,j) * d(k) - e(k) = e(k) + z(k,j) * f - 200 continue -c - 220 e(j) = g - 240 continue -c .......... form p .......... - f = 0.0d0 -c - do 245 j = 1, l - e(j) = e(j) / h - f = f + e(j) * d(j) - 245 continue -c - hh = f / (h + h) -c .......... form q .......... - do 250 j = 1, l - 250 e(j) = e(j) - hh * d(j) -c .......... form reduced a .......... - do 280 j = 1, l - f = d(j) - g = e(j) -c - do 260 k = j, l - 260 z(k,j) = z(k,j) - f * e(k) - g * d(k) -c - d(j) = z(l,j) - z(i,j) = 0.0d0 - 280 continue -c - 290 d(i) = h - 300 continue -c .......... accumulation of transformation matrices .......... - do 500 i = 2, n - l = i - 1 - z(n,l) = z(l,l) - z(l,l) = 1.0d0 - h = d(i) - if (h .eq. 0.0d0) go to 380 -c - do 330 k = 1, l - 330 d(k) = z(k,i) / h -c - do 360 j = 1, l - g = 0.0d0 -c - do 340 k = 1, l - 340 g = g + z(k,i) * z(k,j) -c - do 360 k = 1, l - z(k,j) = z(k,j) - g * d(k) - 360 continue -c - 380 do 400 k = 1, l - 400 z(k,i) = 0.0d0 -c - 500 continue -c - 510 do 520 i = 1, n - d(i) = z(n,i) - z(n,i) = 0.0d0 - 520 continue -c - z(n,n) = 1.0d0 - e(1) = 0.0d0 - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/rubber.f calculix-ccx-2.3/ccx_2.1/src/rubber.f --- calculix-ccx-2.1/ccx_2.1/src/rubber.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/rubber.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,881 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine rubber(elconloc,elas,emec,kode,emec0,didc, - & d2idc2,dibdc,d2ibdc2,dudc,d2udc2,dldc,d2ldc2,dlbdc,d2lbdc2, - & ithermal,icmd,beta,stre) -! -! calculates stiffness and stresses for rubber and elastomeric -! foam materials -! -! icmd=3: stress at mechanical strain -! else: stress and stiffness matrix at mechanical strain -! - implicit none -! - logical ogden,hyperfoam,taylor -! - integer nelconst,kode,kk(84),i,j,k,l,m,nt,icmd,istart,iend, - & nc,n,ithermal,ii,jj,mm,neig -! - real*8 elconloc(*),elas(*),emec(*),emec0(*),didc(3,3,3), - & d2idc2(3,3,3,3,3),dibdc(3,3,3),d2ibdc2(3,3,3,3,3),dudc(3,3), - & d2udc2(3,3,3,3),dldc(3,3,3),d2ldc2(3,3,3,3,3),dlbdc(3,3,3), - & d2lbdc2(3,3,3,3,3),v1,v2,v3,c(3,3),cinv(3,3),d(3,3),djth, - & coef,bb,cc,cm,cn,tt,pi,dd,al(3),v1b,v2b,v3b, - & alb(3),beta(*),v33,v36,all(3),term,stre(*),total,coefa, - & coefb,coefd,coefm,constant(21) -! - data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, - & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, - & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, - & 2,3,2,3/ -c write(*,*) ' emec ' -c write(*,'(4(1x,e19.12))') (emec(i),i=1,6) -! -! copy the elastic constants into a new field, such that -! they can be mixed without influencing the field in the -! calling program -! - do i=1,21 - constant(i)=elconloc(i) - enddo -! -! type of hyperelastic law; taylor stands for everything -! which involves parts of a taylor expansion in terms of the -! reduced Green deformation invariants -! - ogden=.false. - hyperfoam=.false. - taylor=.false. - if((kode.lt.-3).and.(kode.gt.-7)) then - ogden=.true. - elseif((kode.lt.-14).and.(kode.gt.-18)) then - hyperfoam=.true. - else - taylor=.true. - endif -! -c if(icmd.eq.1) then - istart=1 - iend=1 -! -! reclassifying some classes of hyperelastic materials as -! subclasses of the polynomial model -! - if(((kode.lt.-1).and.(kode.gt.-4)).or. - & ((kode.lt.-6).and.(kode.gt.-13)).or. - & (kode.eq.-14)) then - if(kode.eq.-2) then - kode=-7 - nelconst=1 - elseif((kode.eq.-3).or.(kode.eq.-10)) then - constant(3)=constant(2) - constant(2)=0.d0 - kode=-7 - nelconst=1 - elseif(kode.eq.-11) then - constant(7)=constant(4) - constant(6)=constant(3) - constant(5)=0.d0 - constant(4)=0.d0 - constant(3)=constant(2) - constant(2)=0.d0 - kode=-8 - nelconst=2 - elseif((kode.eq.-12).or.(kode.eq.-14)) then - constant(12)=constant(6) - constant(11)=constant(5) - constant(10)=constant(4) - constant(9)=0.d0 - constant(8)=0.d0 - constant(7)=0.d0 - constant(6)=constant(3) - constant(5)=0.d0 - constant(4)=0.d0 - constant(3)=constant(2) - constant(2)=0.d0 - kode=-9 - nelconst=3 - elseif(kode.eq.-7) then - nelconst=1 - elseif(kode.eq.-8) then - nelconst=2 - elseif(kode.eq.-9) then - nelconst=3 - endif - endif -! -! major loop -! - do ii=istart,iend -! -! calculation of the Green deformation tensor for the total -! strain and the thermal strain -! - do i=1,3 - c(i,i)=emec(i)*2.d0+1.d0 - enddo - c(1,2)=2.d0*emec(4) - c(1,3)=2.d0*emec(5) - c(2,3)=2.d0*emec(6) -c write(*,*) ' c ' -c write(*,'(4(1x,e19.12))') (((c(i,j),i=1,3),j=1,3)) -! -! calculation of the invariants of c -! - v1=c(1,1)+c(2,2)+c(3,3) - v2=c(2,2)*c(3,3)+c(1,1)*c(3,3)+c(1,1)*c(2,2)- - & (c(2,3)*c(2,3)+c(1,3)*c(1,3)+c(1,2)*c(1,2)) -c v2=v1*v1 -c do i=1,3 -c v2=v2-c(i,i)*c(i,i) -c enddo -c v2=v2/2.d0 - v3=c(1,1)*(c(2,2)*c(3,3)-c(2,3)*c(2,3)) - & -c(1,2)*(c(1,2)*c(3,3)-c(1,3)*c(2,3)) - & +c(1,3)*(c(1,2)*c(2,3)-c(1,3)*c(2,2)) - v33=v3**(-1.d0/3.d0) - v36=v3**(-1.d0/6.d0) -! -! calculation of the thermal strain jacobian -! (not really needed) -! - djth=1.d0 -! -! inversion of c -! - cinv(1,1)=(c(2,2)*c(3,3)-c(2,3)*c(2,3))/v3 - cinv(2,2)=(c(1,1)*c(3,3)-c(1,3)*c(1,3))/v3 - cinv(3,3)=(c(1,1)*c(2,2)-c(1,2)*c(1,2))/v3 - cinv(1,2)=(c(1,3)*c(2,3)-c(1,2)*c(3,3))/v3 - cinv(1,3)=(c(1,2)*c(2,3)-c(2,2)*c(1,3))/v3 - cinv(2,3)=(c(1,2)*c(1,3)-c(1,1)*c(2,3))/v3 - cinv(2,1)=cinv(1,2) - cinv(3,1)=cinv(1,3) - cinv(3,2)=cinv(2,3) -! -! creation of the delta Dirac matrix d -! - do j=1,3 - do i=1,3 - d(i,j)=0.d0 - enddo - enddo - do i=1,3 - d(i,i)=1.d0 - enddo -! -! derivative of the c-invariants with respect to c(k,l) -! - do l=1,3 - do k=1,l - didc(k,l,1)=d(k,l) - didc(k,l,2)=v1*d(k,l)-c(k,l) - didc(k,l,3)=v3*cinv(k,l) - enddo - enddo -! -! second derivative of the c-invariants w.r.t. c(k,l) -! and c(m,n) -! - if(icmd.ne.3) then - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2idc2(k,l,m,n,1)=0.d0 - d2idc2(k,l,m,n,2)=d(k,l)*d(m,n)- - & (d(k,m)*d(l,n)+d(k,n)*d(l,m))/2.d0 - d2idc2(k,l,m,n,3)=v3*(cinv(m,n)*cinv(k,l)- - & (cinv(k,m)*cinv(n,l)+cinv(k,n)*cinv(m,l))/2.d0) - enddo - endif -! -! derivatives for the reduced invariants used in rubber materials -! - v1b=v1*v33 - v2b=v2*v33*v33 - v3b=dsqrt(v3)/djth -! -! first derivative of the reduced c-invariants w.r.t. c(k,l) -! - do l=1,3 - do k=1,l - if(taylor) then - dibdc(k,l,1)=-v33**4*v1*didc(k,l,3)/3.d0 - & +v33*didc(k,l,1) - dibdc(k,l,2)=-2.d0*v33**5*v2*didc(k,l,3)/3.d0 - & +v33**2*didc(k,l,2) - endif - dibdc(k,l,3)=didc(k,l,3)/(2.d0*dsqrt(v3)*djth) - enddo - enddo -! -! second derivative of the reduced c-invariants w.r.t. c(k,l) -! and c(m,n) -! - if(icmd.ne.3) then - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - if(taylor) then - d2ibdc2(k,l,m,n,1)=4.d0/9.d0*v33**7*v1*didc(k,l,3) - & *didc(m,n,3)-v33**4/3.d0*(didc(m,n,1)*didc(k,l,3) - & +didc(k,l,1)*didc(m,n,3))-v33**4/3.d0*v1* - & d2idc2(k,l,m,n,3)+v33*d2idc2(k,l,m,n,1) - d2ibdc2(k,l,m,n,2)=10.d0*v33**8/9.d0*v2*didc(k,l,3) - & *didc(m,n,3)-2.d0*v33**5/3.d0*(didc(m,n,2) - & *didc(k,l,3) - & +didc(k,l,2)*didc(m,n,3))-2.d0*v33**5/3.d0*v2* - & d2idc2(k,l,m,n,3)+v33**2*d2idc2(k,l,m,n,2) - endif - d2ibdc2(k,l,m,n,3)=-didc(k,l,3)*didc(m,n,3)/ - & (4.d0*djth*v3**1.5d0)+d2idc2(k,l,m,n,3)/ - & (2.d0*dsqrt(v3)*djth) - enddo - endif -! -! calculation of the principal stretches for the Ogden model and -! hyperfoam materials -! - if((ogden).or.(hyperfoam)) then -! -! taking the thermal jacobian into account -! - if((kode.lt.-14).and.(kode.gt.-18)) then - dd=djth**(1.d0/3.d0) - else - dd=1.d0 - endif -! - pi=4.d0*datan(1.d0) -! -! determining the eigenvalues of c (Simo & Hughes) and taking -! the square root to obtain the principal stretches -! -! neig is the number of different eigenvalues -! - neig=3 -! - bb=v2-v1*v1/3.d0 - cc=-2.d0*v1**3/27.d0+v1*v2/3.d0-v3 - if(dabs(bb).le.1.d-10) then - if(dabs(cc).gt.1.d-10) then - al(1)=-cc**(1.d0/3.d0) - else - al(1)=0.d0 - endif - al(2)=al(1) - al(3)=al(1) - neig=1 - else - cm=2.d0*dsqrt(-bb/3.d0) - cn=3.d0*cc/(cm*bb) - if(dabs(cn).gt.1.d0) then - if(cn.gt.1.d0) then - cn=1.d0 - else - cn=-1.d0 - endif - endif - tt=datan2(dsqrt(1.d0-cn*cn),cn)/3.d0 - al(1)=dcos(tt) - al(2)=dcos(tt+2.d0*pi/3.d0) - al(3)=dcos(tt+4.d0*pi/3.d0) -! -! check for two equal eigenvalues -! - if((dabs(al(1)-al(2)).lt.1.d-5).or. - & (dabs(al(1)-al(3)).lt.1.d-5).or. - & (dabs(al(2)-al(3)).lt.1.d-5)) neig=2 - al(1)=cm*al(1) - al(2)=cm*al(2) - al(3)=cm*al(3) - endif - do i=1,3 - al(i)=dsqrt(al(i)+v1/3.d0) - all(i)=(6.d0*al(i)**5-4.d0*v1*al(i)**3+2.d0*al(i)*v2)*dd - enddo -! -! first derivative of the principal stretches w.r.t. c(k,l) -! - if(neig.eq.3) then -! -! three different principal stretches -! - do i=1,3 - do l=1,3 - do k=1,l - dldc(k,l,i)=(al(i)**4*didc(k,l,1) - & -al(i)**2*didc(k,l,2)+didc(k,l,3))/all(i) - enddo - enddo - enddo - elseif(neig.eq.1) then -! -! three equal principal stretches -! - do i=1,3 - do l=1,3 - do k=1,l - dldc(k,l,i)=didc(k,l,1)/(6.d0*al(i)) - enddo - enddo - enddo - else -! -! two equal principal stretches -! - do i=1,3 - do l=1,3 - do k=1,l - dldc(k,l,i)=(dcos(tt+(i-1)*2.d0*pi/3.d0)* - & (2.d0*v1*didc(k,l,1)-3.d0*didc(k,l,2))/ - & (3.d0*dsqrt(v1*v1-3.d0*v2))+didc(k,l,1)/3.d0)/ - & (2.d0*al(i)) - enddo - enddo - enddo - endif -! -! second derivative of the principal stretches w.r.t. c(k,l) -! and c(m,n) -! - if(icmd.ne.3) then - if(neig.eq.3) then -! -! three different principal stretches -! - do i=1,3 - nt=0 - do j=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2ldc2(k,l,m,n,i)=(-30.d0*al(i)**4 - & *dldc(k,l,i)*dldc(m,n,i)+al(i)**4 - & *d2idc2(k,l,m,n,1) - & +4.d0*al(i)**3*(didc(k,l,1)*dldc(m,n,i) - & +didc(m,n,1) - & *dldc(k,l,i))+12.d0*v1*al(i)**2*dldc(k,l,i)* - & dldc(m,n,i)-d2idc2(k,l,m,n,2)*al(i)**2-2.d0 - & *al(i)* - & didc(k,l,2)*dldc(m,n,i)-2.d0*v2*dldc(k,l,i)* - & dldc(m,n,i)-2.d0*al(i)*didc(m,n,2)*dldc(k,l,i) - & +d2idc2(k,l,m,n,3))/all(i) - enddo - enddo - elseif(neig.eq.1) then -! -! three equal principal stretches -! - do i=1,3 - nt=0 - do j=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2ldc2(k,l,m,n,i)=(d2idc2(k,l,m,n,1)/6.d0 - & -dldc(k,l,i)*dldc(m,n,i))/al(i) - enddo - enddo - else -! -! two equal principal stretches -! - do i=1,3 - nt=0 - do j=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2ldc2(k,l,m,n,i)=(dcos(tt+(i-1)*2.d0*pi/3.d0)* - & (-(2.d0*v1*didc(k,l,1)-3.d0*didc(k,l,2))* - & (2.d0*v1*didc(m,n,1)-3.d0*didc(m,n,2))/ - & (6.d0*(v1*v1-3.d0*v2)**1.5)+ - & (2.d0*didc(k,l,1)*didc(m,n,1)+2.d0*v1* - & d2idc2(k,l,m,n,1)-3.d0*d2idc2(k,l,m,n,2))/ - & (3.d0*dsqrt(v1*v1-3.d0*v2))) - & +d2idc2(k,l,m,n,1)/3.d0)/(2.d0*al(i))- - & dldc(k,l,i)*dldc(m,n,i)/al(i) - enddo - enddo - endif - endif -! -! reduced principal stretches (Ogden model) -! - if(ogden) then -! -! calculation of the reduced principal stretches -! - do i=1,3 - alb(i)=al(i)*v36 - enddo -! -! first derivative of the reduced principal stretches -! w.r.t. c(k,l) -! - do i=1,3 - do l=1,3 - do k=1,l - dlbdc(k,l,i)=-v36**7*al(i)*didc(k,l,3)/6.d0 - & +v36*dldc(k,l,i) - enddo - enddo - enddo -! -! second derivative of the reduced principal stretches w.r.t. -! c(k,l) and c(m,n) -! - if(icmd.ne.3) then - do i=1,3 - nt=0 - do j=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2lbdc2(k,l,m,n,i)=7.d0*v36**13*al(i) - & *didc(k,l,3)*didc(m,n,3)/36.d0-v36**7/6.d0 - & *(dldc(m,n,i)*didc(k,l,3)+al(i) - & *d2idc2(k,l,m,n,3)+dldc(k,l,i)*didc(m,n,3)) - & +v36*d2ldc2(k,l,m,n,i) - enddo - enddo - endif -! - endif - endif -! -! calculation of the local stiffness matrix, and, if appropriate, -! the stresses -! -! Polynomial model -! - if((kode.lt.-6).and.(kode.gt.-10)) then -! -! first derivative of U w.r.t. c(k,l) -! - do l=1,3 - do k=1,l - dudc(k,l)=0.d0 - enddo - enddo -! - nc=0 - do m=1,nelconst - do j=0,m - i=m-j - nc=nc+1 - coef=constant(nc) - if(dabs(coef).lt.1.d-20) cycle - do l=1,3 - do k=1,l - total=0.d0 - if(i.gt.0) then - term=dibdc(k,l,1) - if(i.gt.1) term=i*term*(v1b-3.d0)**(i-1) - if(j.gt.0) term=term*(v2b-3.d0)**j - total=total+term - endif - if(j.gt.0) then - term=dibdc(k,l,2) - if(i.gt.0) term=term*(v1b-3.d0)**i - if(j.gt.1) term=j*term*(v2b-3.d0)**(j-1) - total=total+term - endif - dudc(k,l)=dudc(k,l)+total*coef - enddo - enddo - enddo - enddo - do m=1,nelconst - nc=nc+1 - coef=constant(nc) - do l=1,3 - do k=1,l - dudc(k,l)=dudc(k,l)+2.d0*m*(v3b-1.d0)** - & (2*m-1)*dibdc(k,l,3)/coef - enddo - enddo - enddo -! -! tangent stiffness matrix -! second derivative of U w.r.t. c(k,l) and c(m,n) -! - if(icmd.ne.3) then - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2udc2(k,l,m,n)=0.d0 - enddo - nc=0 - do mm=1,nelconst - do j=0,mm - i=mm-j - nc=nc+1 - coef=constant(nc) - if(dabs(coef).lt.1.d-20) cycle - nt=0 - do jj=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - total=0.d0 - if(i.gt.1) then - term=dibdc(k,l,1)*dibdc(m,n,1)*i*(i-1) - if(i.gt.2) term=term*(v1b-3.d0)**(i-2) - if(j.gt.0) term=term*(v2b-3.d0)**j - total=total+term - endif - if((i.gt.0).and.(j.gt.0)) then - term=dibdc(k,l,1)*dibdc(m,n,2)+ - & dibdc(m,n,1)*dibdc(k,l,2) - if(i.gt.1) term=i*term*(v1b-3.d0)**(i-1) - if(j.gt.1) term=j*term*(v2b-3.d0)**(j-1) - total=total+term - endif - if(i.gt.0) then - term=d2ibdc2(k,l,m,n,1) - if(i.gt.1) term=i*term*(v1b-3.d0)**(i-1) - if(j.gt.0) term=term*(v2b-3.d0)**j - total=total+term - endif - if(j.gt.1) then - term=dibdc(k,l,2)*dibdc(m,n,2)*j*(j-1) - if(i.gt.0) term=term*(v1b-3.d0)**i - if(j.gt.2) term=term*(v2b-3.d0)**(j-2) - total=total+term - endif - if(j.gt.0) then - term=d2ibdc2(k,l,m,n,2) - if(i.gt.0) term=term*(v1b-3.d0)**i - if(j.gt.1) term=j*term*(v2b-3.d0)**(j-1) - total=total+term - endif - d2udc2(k,l,m,n)=d2udc2(k,l,m,n)+total*coef - enddo - enddo - enddo -! - do mm=1,nelconst - nc=nc+1 - coef=constant(nc) - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - if(mm.eq.1) then - term=(2.d0*dibdc(k,l,3)*dibdc(m,n,3)+ - & 2.d0*(v3b-1.d0)*d2ibdc2(k,l,m,n,3))/coef - else - term= - & 2.d0*mm*(v3b-1.d0)**(2*mm-2)/coef* - & ((2*mm-1)*dibdc(k,l,3)*dibdc(m,n,3) - & +(v3b-1.d0)*d2ibdc2(k,l,m,n,3)) - endif - d2udc2(k,l,m,n)=d2udc2(k,l,m,n)+term - enddo - enddo - endif - endif -! -! Ogden form -! - if((kode.lt.-3).and.(kode.gt.-7)) then - if(kode.eq.-4) then - nelconst=1 - elseif(kode.eq.-5) then - nelconst=2 - elseif(kode.eq.-6) then - nelconst=3 - endif -! -! first derivative of U w.r.t. c(k,l) -! - do l=1,3 - do k=1,l - dudc(k,l)=0.d0 - enddo - enddo -! - do m=1,nelconst - coefa=constant(2*m) - coefd=constant(2*nelconst+m) - coefm=constant(2*m-1) - do l=1,3 - do k=1,l - term=0.d0 - do i=1,3 - term=term+alb(i)**(coefa-1.d0)*dlbdc(k,l,i) - enddo - dudc(k,l)=dudc(k,l)+2.d0*coefm/coefa - & *term+2.d0*m/coefd* - & (v3b-1.d0)**(2*m-1)*dibdc(k,l,3) - enddo - enddo - enddo -! -! tangent stiffness matrix -! second derivative of U w.r.t. c(k,l) and c(m,n) -! - if(icmd.ne.3) then - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2udc2(k,l,m,n)=0.d0 - enddo - do mm=1,nelconst - coefa=constant(2*mm) - coefd=constant(2*nelconst+mm) - coefm=constant(2*mm-1) - nt=0 - do jj=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - term=0.d0 - do i=1,3 - term=term+alb(i)**(coefa-2.d0)*dlbdc(k,l,i)* - & dlbdc(m,n,i) - enddo - term=term*(coefa-1.d0) - do i=1,3 - term=term+alb(i)**(coefa-1.d0) - & *d2lbdc2(k,l,m,n,i) - enddo - term=term*2.d0*coefm/coefa - d2udc2(k,l,m,n)=d2udc2(k,l,m,n)+term+(2*mm)* - & (2*mm-1)/coefd*(v3b-1.d0)**(2*mm-2)* - & dibdc(k,l,3)*dibdc(m,n,3)+2*mm/coefd - & *(v3b-1.d0)**(2*mm-1)*d2ibdc2(k,l,m,n,3) - enddo - enddo - endif - endif -! -! Arruda-Boyce model -! - if(kode.eq.-1) then - coef=constant(2) -! -! first derivative of U w.r.t. c(k,l) -! - do l=1,3 - do k=1,l - dudc(k,l)=constant(1)*(0.5d0+v1b/(10.d0* - & coef**2)+33.d0*v1b*v1b/(1050.d0* - & coef**4)+76.d0*v1b**3/(7000.d0* - & coef**6)+2595.d0*v1b**4/(673750.d0* - & coef**8))*dibdc(k,l,1)+(v3b-1.d0/v3b) - & *dibdc(k,l,3)/constant(3) - enddo - enddo -! -! tangent stiffness matrix -! second derivative of U w.r.t. c(k,l) and c(m,n) -! - if(icmd.ne.3) then - nt=0 - do jj=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2udc2(k,l,m,n)=constant(1)*(1.d0/(10.d0* - & coef**2)+66.d0*v1b/(1050.d0*coef**4)+228.d0 - & *v1b**2/(7000.d0*coef**6)+10380.d0*v1b**3/ - & (673750.d0*coef**8))*dibdc(k,l,1)*dibdc(m,n,1) - & +constant(1)*(0.5d0+v1b/(10.d0*coef**2) - & +33.d0*v1b**2/ - & (1050.d0*coef**4)+76.d0*v1b**3/(7000.d0*coef**6)+ - & 2595.d0*v1b**4/(673750.d0*coef**8)) - & *d2ibdc2(k,l,m,n,1) - & +(1.d0+1.d0/v3b**2)*dibdc(k,l,3)*dibdc(m,n,3)/ - & constant(3)+(v3b-1.d0/v3b)*d2ibdc2(k,l,m,n,3) - & /constant(3) - enddo - endif - endif -! -! elastomeric foam behavior -! - if((kode.lt.-15).and.(kode.gt.-18)) then - if(kode.eq.-15) then - nelconst=1 - elseif(kode.eq.-16) then - nelconst=2 - elseif(kode.eq.-17) then - nelconst=3 - endif -! -! first derivative of U w.r.t. c(k,l) -! - do l=1,3 - do k=1,l - dudc(k,l)=0.d0 - enddo - enddo -! - do m=1,nelconst - coefa=constant(2*m) - coefb=constant(2*nelconst+m)/(1.d0-2.d0 - & *constant(2*nelconst+m)) - coefm=constant(2*m-1) - do l=1,3 - do k=1,l - term=0.d0 - do i=1,3 - term=term+al(i)**(coefa-1.d0)*dldc(k,l,i) - enddo - dudc(k,l)=dudc(k,l)+2.d0*coefm/coefa - & *(term-v3b**(-coefa*coefb-1.d0)* - & dibdc(k,l,3)) - enddo - enddo - enddo -! -! tangent stiffness matrix -! second derivative of U w.r.t. c(k,l) and c(m,n) -! - if(icmd.ne.3) then - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2udc2(k,l,m,n)=0.d0 - enddo - do mm=1,nelconst - coefa=constant(2*mm) - coefb=constant(2*nelconst+mm)/(1.d0-2.d0 - & *constant(2*nelconst+mm)) - coefm=constant(2*mm-1) - nt=0 - do jj=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - term=0.d0 - do i=1,3 - term=term+(coefa-1.d0)*al(i)**(coefa-2.d0) - & *dldc(k,l,i)*dldc(m,n,i) - & +al(i)**(coefa-1.d0)*d2ldc2(k,l,m,n,i) - enddo - d2udc2(k,l,m,n)=d2udc2(k,l,m,n) - & +2.d0*coefm/ - & coefa*(term+(coefa*coefb+1.d0)*v3b - & **(-coefa*coefb-2.d0)*dibdc(k,l,3) - & *dibdc(m,n,3)-v3b**(-coefa*coefb-1.d0) - & *d2ibdc2(k,l,m,n,3)) - enddo - enddo - endif - endif -! -! storing the stiffness matrix and/or the stress -! - if(icmd.ne.3) then -! -! storing the stiffness matrix -! - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - elas(i)=4.d0*d2udc2(k,l,m,n) - enddo - endif -! -! store the stress at mechanical strain -! - stre(1)=2.d0*dudc(1,1) - stre(2)=2.d0*dudc(2,2) - stre(3)=2.d0*dudc(3,3) - stre(4)=2.d0*dudc(1,2) - stre(5)=2.d0*dudc(1,3) - stre(6)=2.d0*dudc(2,3) -! - enddo -! -c write(*,*) ' al ' -c write(*,'(4(1x,e19.12))') (al(i),i=1,3) -c write(*,*) ' all ' -c write(*,'(4(1x,e19.12))') (all(i),i=1,3) -c write(*,*) ' alb ' -c write(*,'(4(1x,e19.12))') (alb(i),i=1,3) -c write(*,*) ' dldc ' -c write(*,'(4(1x,e19.12))') (((dldc(i,j,k),i=1,3),j=1,3),k=1,3) -c write(*,*) ' d2ldc2 ' -c write(*,'(4(1x,e19.12))') (((((d2ldc2(i,j,k,l,m),i=1,3),j=1,3) -c & ,k=1,3),l=1,3),m=1,3) -c write(*,*) ' dlbdc ' -c write(*,'(4(1x,e19.12))') (((dlbdc(i,j,k),i=1,3),j=1,3),k=1,3) -c write(*,*) ' d2lbdc2 ' -c write(*,'(4(1x,e19.12))') (((((d2lbdc2(i,j,k,l,m),i=1,3),j=1,3) -c & ,k=1,3),l=1,3),m=1,3) -c write(*,*) ' elconloc ' -c write(*,'(4(1x,e19.12))') (elconloc(i),i=1,21) -c write(*,*) ' elas ' -c write(*,'(4(1x,e19.12))') (elas(i),i=1,21) -c write(*,*) ' dudc ' -c write(*,'(4(1x,e19.12))') (((dudc(i,j),i=1,3),j=1,3)) -c write(*,*) ' d2udc2 ' -c write(*,'(4(1x,e19.12))') (((((d2udc2(i,j,k,l),i=1,3),j=1,3) -c & ,k=1,3),l=1,3)) - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/saxpb.f calculix-ccx-2.3/ccx_2.1/src/saxpb.f --- calculix-ccx-2.1/ccx_2.1/src/saxpb.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/saxpb.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine saxpb(a,b,x,n,c) - implicit none - integer k,n - real*8 a(*),b(*),c(*),x -c....vector times scalar added to second vector - do 10 k = 1,n - c(k) = a(k)*x +b(k) -10 continue - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/scavenge_pump.f calculix-ccx-2.3/ccx_2.1/src/scavenge_pump.f --- calculix-ccx-2.1/ccx_2.1/src/scavenge_pump.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/scavenge_pump.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine scavenge_pump(node1,node2,nodem,nelem,lakon,kon,ipkon, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,cp,r,physcon,dvi,numf,set,shcon, - & nshcon,rhcon,nrhcon,ntmat_,mi) -! -! scavenge pump element -! - implicit none -! - logical identity - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),numf,node1,node2,nodem, - & ielprop(*),nodef(5),idirf(5),index,iflag, - & ipkon(*),kon(*),nshcon(*),mi(2), - & nrhcon(*),ntmat_ -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,cp,physcon(*) - & ,dvi,shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),R -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif (iflag.eq.1) then -! - elseif (iflag.eq.2) then -! - elseif (iflag.eq.3) then -! - endif - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/sdvini.f calculix-ccx-2.3/ccx_2.1/src/sdvini.f --- calculix-ccx-2.1/ccx_2.1/src/sdvini.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/sdvini.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine sdvini(statev,coords,nstatv,ncrds,noel,npt, - & layer,kspt) -! -! user subroutine sdvini -! -! -! INPUT: -! -! coords(1..3) global coordinates of the integration point -! nstatv number of internal variables (must be -! defined by the user with the *DEPVAR card) -! ncrds number of coordinates -! noel element number -! npt integration point number -! layer not used -! kspt not used -! -! OUTPUT: -! -! statev(1..nstatv) initial value of the internal state -! variables -! - implicit none -! - integer nstatv,ncrds,noel,npt,layer,kspt,i -! - real*8 statev(nstatv),coords(ncrds) -! -! code for retrieving the internal state variables -! - do i=1,13 - statev(i)=1.d0 - enddo - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/selcycsymmods.f calculix-ccx-2.3/ccx_2.1/src/selcycsymmods.f --- calculix-ccx-2.1/ccx_2.1/src/selcycsymmods.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/selcycsymmods.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,398 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine selcycsymmods(inpc,textpart,cs,ics,tieset,istartset, - & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc,ilmpc, - & mpcfree,mcs,set,nset,labmpc,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,nmethod,key,ipoinpc) -! -! reading the input deck: *SELECT CYCLIC SYMMETRY MODES -! - implicit none -! - character*1 inpc(*) - character*20 labmpc(*) - character*81 set(*),leftset,tieset(3,*) - character*132 textpart(16) -! - integer istep,istat,n,key,i,ns(5),ics(*),istartset(*), - & iendset(*),ialset(*),id,ipompc(*),nodempc(3,*),nmpc,nmpc_, - & ikmpc(*),ilmpc(*),mpcfree,i1(2),i2(2),i3,i4,i5,j,k, - & mpcfreeold,idof,node,ileft,nset,irepeat,ipoinpc(0:*), - & mpc,iline,ipol,inl,ipoinp(2,*),inp(3,*),mcs,lprev,ij,nmethod -! - real*8 coefmpc(*),csab(7),x1(2),x2(2),x3,x4,x5,dd,xn,yn,zn, - & cs(17,*) -! -! irepeat indicates whether the step was preceded by another -! cyclic symmetry step (irepeat=1) or not (irepeat=0) -! - data irepeat /0/ - save irepeat -! - if(istep.eq.0) then - write(*,*)'*ERROR in selcycsymmods:' - write(*,*)' *SELECT CYCLIC SYMMETRY MODES' - write(*,*)' should be placed within a step definition' - stop - endif -! -! check whether in case of cyclic symmetry the frequency procedure -! is chosen -! - if(nmethod.ne.2) then - write(*,*) '*ERROR in selcycsymmods: the only valid procedure' - write(*,*) ' for cyclic symmetry calculations' - write(*,*) ' with nodal diameters is *FREQUENCY' - stop - endif -! - ns(2)=0 - ns(3)=0 -! - do i=2,n - if(textpart(i)(1:5).eq.'NMIN=') then - read(textpart(i)(6:15),'(i10)',iostat=istat) ns(2) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:5).eq.'NMAX=') then - read(textpart(i)(6:15),'(i10)',iostat=istat) ns(3) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - enddo -! -! check the input -! - if(ns(2).lt.0) then - ns(2)=0 - write(*,*) '*WARNING in selcycsymmods: minimum nodal' - write(*,*) ' diameter must be nonnegative' - endif - if(ns(3).lt.ns(2)) then - write(*,*) '*ERROR in selcycsymmods: maximum nodal' - write(*,*) ' diameter should not exceed minimal one' - stop - endif -! -! loop over all cyclic symmetry parts -! - do ij=1,mcs - ns(1)=int(cs(1,ij)) - ns(4)=int(cs(4,ij)) - leftset=tieset(2,int(cs(17,ij))) - lprev=int(cs(14,ij)) - do i=1,7 - csab(i)=cs(5+i,ij) - enddo -! -! check whether cyclic symmetry axis is part of the structure -! - do i=1,nset - if(set(i).eq.leftset) exit - enddo - ileft=i -! -! if this step was preceded by a cyclic symmetry step: -! check for MPC's for nodes on the cyclic symmetry axis -! and delete them -! - if(irepeat.eq.1) then - do i=1,ns(4) - node=ics(lprev+i) - if(node.lt.0) then - node=-node - do k=1,3 - idof=8*(node-1)+k - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) 'removing MPC',node,k - mpc=ilmpc(id) - call mpcrem(mpc,mpcfree,nodempc,nmpc,ikmpc, - & ilmpc,labmpc,coefmpc,ipompc) -c index=ipompc(mpc) -c do -c indexold=index -c index=nodempc(3,index) -c if(index.eq.0) exit -c enddo -c nodempc(3,indexold)=mpcfree -c mpcfree=ipompc(mpc) -c do j=id,nmpc-1 -c ikmpc(j)=ikmpc(j+1) -c ilmpc(j)=ilmpc(j+1) -c enddo -c ikmpc(nmpc)=0 -c ilmpc(nmpc)=0 -c nmpc=nmpc-1 - endif - endif - enddo - endif - enddo - endif -! - do i=1,ns(4) - node=ics(lprev+i) - if(node.lt.0) then - node=-node - if(ns(2).ne.ns(3)) then - if((ns(2).eq.0).or.(ns(2).eq.1)) then - write(*,*) '*ERROR: axis of cyclic symmetry' - write(*,*) ' is part of the structure;' - write(*,*) ' nodal diameters 0, 1, and' - write(*,*) ' those above must be each in' - write(*,*) ' separate steps.' - stop - endif - endif -! -! specifying special MPC's for nodes on the axis -! -! normal along the axis -! - xn=csab(4)-csab(1) - yn=csab(5)-csab(2) - zn=csab(6)-csab(3) - dd=dsqrt(xn*xn+yn*yn+zn*zn) - xn=xn/dd - yn=yn/dd - zn=zn/dd -! -! nodal diameter 0 -! - if(ns(2).eq.0) then - if(dabs(xn).gt.1.d-10) then - i1(1)=2 - i1(2)=3 - i2(1)=1 - i2(2)=1 - x1(1)=xn - x1(2)=xn - x2(1)=-yn - x2(2)=-zn - elseif(dabs(yn).gt.1.d-10) then - i1(1)=1 - i1(2)=3 - i2(1)=2 - i2(2)=2 - x1(1)=yn - x1(2)=yn - x2(1)=-xn - x2(2)=-zn - elseif(dabs(zn).gt.1.d-10) then - i1(1)=1 - i1(2)=2 - i2(1)=3 - i2(2)=3 - x1(1)=zn - x1(2)=zn - x2(1)=-xn - x2(2)=-yn - endif -! -! generating two MPC's expressing that the nodes cannot -! move in planes perpendicular to the cyclic symmetry -! axis -! - do k=1,2 - idof=8*(node-1)+i1(k) - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*ERROR in selcycsymmods:' - write(*,*) ' node',node, - & ' on cyclic symmetry' - write(*,*) ' axis is used in other MPC' - stop - endif - endif - nmpc=nmpc+1 - ipompc(nmpc)=mpcfree - labmpc(nmpc)=' ' -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=i1(k) - coefmpc(mpcfree)=x1(k) - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) '*ERROR in selcycsymmods:' - write(*,*) ' increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=i2(k) - coefmpc(mpcfree)=x2(k) - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) '*ERROR in selcycsymmods:' - write(*,*) ' increase nmpc_' - stop - endif - nodempc(3,mpcfreeold)=0 - enddo - elseif(ns(2).eq.1) then -! -! nodal diameter 1 -! - if(dabs(xn).gt.1.d-10) then - i3=1 - i4=2 - i5=3 - x3=xn - x4=yn - x5=zn - elseif(dabs(yn).gt.1.d-10) then - i3=2 - i4=2 - i5=3 - x3=yn - x4=xn - x5=zn - else - i3=3 - i4=1 - i5=2 - x3=zn - x4=xn - x5=yn - endif -! -! generating one MPC expressing that the nodes should -! not move along the axis -! - idof=8*(node-1)+i3 - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*ERROR in selcycsymmods:' - write(*,*) ' node',node, - & ' on cyclic symmetry' - write(*,*) ' axis is used in other MPC' - stop - endif - endif - nmpc=nmpc+1 - ipompc(nmpc)=mpcfree - labmpc(nmpc)=' ' -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=i3 - coefmpc(mpcfree)=x3 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) '*ERROR in selcycsymmods:' - write(*,*) ' increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=i4 - coefmpc(mpcfree)=x4 - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) '*ERROR in selcycsymmods:' - write(*,*) ' increase nmpc_' - stop - endif - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=i5 - coefmpc(mpcfree)=x5 - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) '*ERROR in selcycsymmods:' - write(*,*) ' increase nmpc_' - stop - endif - nodempc(3,mpcfreeold)=0 - else - do k=1,3 - idof=8*(node-1)+k - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*ERROR in selcycsymmods:' - write(*,*) ' node',node, - & ' on cyclic symmetry' - write(*,*) ' axis is used in other MPC' - stop - endif - endif - nmpc=nmpc+1 - ipompc(nmpc)=mpcfree - labmpc(nmpc)=' ' -! -! updating ikmpc and ilmpc -! - do j=nmpc,id+2,-1 - ikmpc(j)=ikmpc(j-1) - ilmpc(j)=ilmpc(j-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=k - coefmpc(mpcfree)=1.d0 - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - if(mpcfree.eq.0) then - write(*,*) '*ERROR in selcycsymmods:' - write(*,*) ' increase nmpc_' - stop - endif - nodempc(3,mpcfreeold)=0 - enddo - endif - endif - enddo -! - cs(2,ij)=ns(2)+0.5 - cs(3,ij)=ns(3)+0.5 - enddo -! - if(irepeat.eq.0) irepeat=1 -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! -c do j=1,nmpc -c call writempc(ipompc,nodempc,coefmpc,labmpc,j) -c enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/sgi.c calculix-ccx-2.3/ccx_2.1/src/sgi.c --- calculix-ccx-2.1/ccx_2.1/src/sgi.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/sgi.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,130 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#ifdef SGI - -#include -#include -#include -#include "CalculiX.h" -#include "sgi.h" - -int *irowsgi=NULL; -double *ausgi=NULL; - -void sgi_factor(double *ad, double *au, double *adb, double *aub, - double *sigma,int *icol, int *irow, - int *neq, int *nzs, int token){ - - char *oocpath="/yatmp/scr1",*env; - int i,j,k,l,*pointers=NULL,method; - long long ndim; - double ops=0,ooclimit=2000.; - - printf(" Factoring the system of equations using the sgi solver\n\n"); - - env=getenv("CCX_OOC_MEM"); - if(env) ooclimit=atoi(env); - - ndim=*neq+*nzs; - - pointers=NNEW(int,*neq+1); - irowsgi=NNEW(int,ndim); - ausgi=NNEW(double,ndim); - - k=ndim; - l=*nzs; - - if(*sigma==0.){ - pointers[*neq]=ndim; - for(i=*neq-1;i>=0;--i){ - for(j=0;j=0;--i){ - for(j=0;j200000){ - printf(" The out of core solver is used\n\n"); - DPSLDLT_OOCLimit(token,ooclimit); - DPSLDLT_OOCPath(token,oocpath); - DPSLDLT_FactorOOC(token,*neq,pointers,irowsgi,ausgi); - } - else{ - DPSLDLT_Factor(token,*neq,pointers,irowsgi,ausgi); - } - - free(pointers); - - return; -} - -void sgi_solve(double *b,int token){ - - DPSLDLT_Solve(token,b,b); - - return; -} - -void sgi_cleanup(int token){ - - DPSLDLT_Destroy(token); - free(irowsgi); - free(ausgi); - - return; -} - -void sgi_main(double *ad, double *au, double *adb, double *aub, double *sigma, - double *b, int *icol, int *irow, - int *neq, int *nzs, int token){ - - if(*neq==0) return; - - sgi_factor(ad,au,adb,aub,sigma,icol,irow, - neq,nzs,token); - - sgi_solve(b,token); - - sgi_cleanup(token); - - return; -} - -#endif - diff -Nru calculix-ccx-2.1/ccx_2.1/src/sgi.h calculix-ccx-2.3/ccx_2.1/src/sgi.h --- calculix-ccx-2.1/ccx_2.1/src/sgi.h 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/sgi.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -/* CALCULIX - A 3-dimensional finite element program */ -/* Copyright (C) 1998 Guido Dhondt */ -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation; either version 2 of */ -/* the License, or (at your option) any later version. */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include - -void sgi_main(double *ad, double *au, double *adb, double *aub, double *sigma, - double *b, int *icol, int *irow, - int *neq, int *nzs, int token); - -void sgi_factor(double *ad, double *au, double *adb, double *aub, - double *sigma,int *icol, int *irow, - int *neq, int *nzs, int token); - -void sgi_solve(double *b,int token); - -void sgi_cleanup(int token); - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape10tet.f calculix-ccx-2.3/ccx_2.1/src/shape10tet.f --- calculix-ccx-2.1/ccx_2.1/src/shape10tet.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape10tet.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,141 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape10tet(xi,et,ze,xl,xsj,shp,iflag) -! -! shape functions and derivatives for a 10-node quadratic -! isoparametric tetrahedral element. 0<=xi,et,ze<=1,xi+et+ze<=1. -! -! iflag=1: calculate only the value of the shape functions -! iflag=2: calculate the value of the shape functions and -! the Jacobian determinant -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian determinant -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(4,10),xs(3,3),xsi(3,3),xl(3,10),sh(3) -! - real*8 xi,et,ze,xsj,a -! -! shape functions and their glocal derivatives -! -! shape functions -! - a=1.d0-xi-et-ze - shp(4, 1)=(2.d0*a-1.d0)*a - shp(4, 2)=xi*(2.d0*xi-1.d0) - shp(4, 3)=et*(2.d0*et-1.d0) - shp(4, 4)=ze*(2.d0*ze-1.d0) - shp(4, 5)=4.d0*xi*a - shp(4, 6)=4.d0*xi*et - shp(4, 7)=4.d0*et*a - shp(4, 8)=4.d0*ze*a - shp(4, 9)=4.d0*xi*ze - shp(4,10)=4.d0*et*ze -! - if(iflag.eq.1) return -! -! local derivatives of the shape functions: xi-derivative -! - shp(1, 1)=1.d0-4.d0*(1.d0-xi-et-ze) - shp(1, 2)=4.d0*xi-1.d0 - shp(1, 3)=0.d0 - shp(1, 4)=0.d0 - shp(1, 5)=4.d0*(1.d0-2.d0*xi-et-ze) - shp(1, 6)=4.d0*et - shp(1, 7)=-4.d0*et - shp(1, 8)=-4.d0*ze - shp(1, 9)=4.d0*ze - shp(1,10)=0.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2, 1)=1.d0-4.d0*(1.d0-xi-et-ze) - shp(2, 2)=0.d0 - shp(2, 3)=4.d0*et-1.d0 - shp(2, 4)=0.d0 - shp(2, 5)=-4.d0*xi - shp(2, 6)=4.d0*xi - shp(2, 7)=4.d0*(1.d0-xi-2.d0*et-ze) - shp(2, 8)=-4.d0*ze - shp(2, 9)=0.d0 - shp(2,10)=4.d0*ze -! -! local derivatives of the shape functions: zeta-derivative -! - shp(3, 1)=1.d0-4.d0*(1.d0-xi-et-ze) - shp(3, 2)=0.d0 - shp(3, 3)=0.d0 - shp(3, 4)=4.d0*ze-1.d0 - shp(3, 5)=-4.d0*xi - shp(3, 6)=0.d0 - shp(3, 7)=-4.d0*et - shp(3, 8)=4.d0*(1.d0-xi-et-2.d0*ze) - shp(3, 9)=4.d0*xi - shp(3,10)=4.d0*et -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,3 - xs(i,j)=0.d0 - do k=1,10 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian determinant -! - xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) - & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) - & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) -! - if(iflag.eq.2) return -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj - xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj - xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj - xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj - xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj - xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj - xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj - xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj - xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj -! -! computation of the global derivatives of the shape functions -! - do k=1,10 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape15w.f calculix-ccx-2.3/ccx_2.1/src/shape15w.f --- calculix-ccx-2.1/ccx_2.1/src/shape15w.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape15w.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,167 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape15w(xi,et,ze,xl,xsj,shp,iflag) -! -! shape functions and derivatives for a 15-node quadratic -! isoparametric wedge element. 0<=xi,et<=1,-1<=ze<=1,xi+et<=1. -! -! iflag=1: calculate only the value of the shape functions -! iflag=2: calculate the value of the shape functions and -! the Jacobian determinant -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian determinant -! -! -! Copyright (c) 2003 WB -! -! Written February 2003 on the basis of the Guido's shape function files -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(4,15),xs(3,3),xsi(3,3),xl(3,15),sh(3) -! - real*8 xi,et,ze,xsj,a -! -! shape functions and their glocal derivatives -! - a=1.d0-xi-et -! -! shape functions -! - shp(4, 1)=-0.5*a*(1.0-ze)*(2.0*xi+2.0*et+ze) - shp(4, 2)=0.5*xi*(1.0-ze)*(2.0*xi-2.0-ze) - shp(4, 3)=0.5*et*(1.0-ze)*(2.0*et-2.0-ze) - shp(4, 4)=-0.5*a*(1.0+ze)*(2.0*xi+2.0*et-ze) - shp(4, 5)=0.5*xi*(1.0+ze)*(2.0*xi-2.0+ze) - shp(4, 6)=0.5*et*(1.0+ze)*(2.0*et-2.0+ze) - shp(4, 7)=2.0*xi*a*(1.0-ze) - shp(4, 8)=2.0*xi*et*(1.0-ze) - shp(4, 9)=2.0*et*a*(1.0-ze) - shp(4, 10)=2.0*xi*a*(1.0+ze) - shp(4, 11)=2.0*xi*et*(1.0+ze) - shp(4, 12)=2.0*et*a*(1.0+ze) - shp(4, 13)= a*(1.0-ze*ze) - shp(4, 14)=xi*(1.0-ze*ze) - shp(4, 15)=et*(1.0-ze*ze) -! - if(iflag.eq.1) return -! -! local derivatives of the shape functions: xi-derivative -! - shp(1, 1)= 0.5*(1.0-ze)*(4.0*xi+4.0*et+ze-2.0) - shp(1, 2)= 0.5*(1.0-ze)*(4.0*xi-ze-2.0) - shp(1, 3)= 0.d0 - shp(1, 4)= 0.5*(1.0+ze)*(4.0*xi+4.0*et-ze-2.0) - shp(1, 5)= 0.5*(1.0+ze)*(4.0*xi+ze-2.0) - shp(1, 6)= 0.d0 - shp(1, 7)= 2.0*(1.0-ze)*(1.0-2.0*xi-et) - shp(1, 8)= 2.0*et*(1.0-ze) - shp(1, 9)= -2.0*et*(1.0-ze) - shp(1, 10)= 2.0*(1.0+ze)*(1.0-2.0*xi-et) - shp(1, 11)= 2.0*et*(1.0+ze) - shp(1, 12)= -2.0*et*(1.0+ze) - shp(1, 13)= -(1.0-ze*ze) - shp(1, 14)= (1.0-ze*ze) - shp(1, 15)= 0.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2, 1)= 0.5*(1.0-ze)*(4.0*xi+4.0*et+ze-2.0) - shp(2, 2)= 0.d0 - shp(2, 3)= 0.5*(1.0-ze)*(4.0*et-ze-2.0) - shp(2, 4)= 0.5*(1.0+ze)*(4.0*xi+4.0*et-ze-2.0) - shp(2, 5)= 0.d0 - shp(2, 6)= 0.5*(1.0+ze)*(4.0*et+ze-2.0) - shp(2, 7)=-2.0*xi*(1.0-ze) - shp(2, 8)= 2.0*xi*(1.0-ze) - shp(2, 9)= 2.0*(1.0-ze)*(1.0-xi-2.0*et) - shp(2, 10)=-2.0*xi*(1.0+ze) - shp(2, 11)= 2.0*xi*(1.0+ze) - shp(2, 12)= 2.0*(1.0+ze)*(1.0-xi-2.0*et) - shp(2, 13)=-(1.0-ze*ze) - shp(2, 14)= 0.0d0 - shp(2, 15)= (1.0-ze*ze) -! -! local derivatives of the shape functions: zeta-derivative -! - shp(3, 1)= a*(xi+et+ze-0.5) - shp(3, 2)= xi*(-xi+ze+0.5) - shp(3, 3)= et*(-et+ze+0.5) - shp(3, 4)= a*(-xi-et+ze+0.5) - shp(3, 5)= xi*(xi+ze-0.5) - shp(3, 6)= et*(et+ze-0.5) - shp(3, 7)= -2*xi*a - shp(3, 8)= -2*xi*et - shp(3, 9)= -2*et*a - shp(3, 10)= 2*xi*a - shp(3, 11)= 2*xi*et - shp(3, 12)= 2*et*a - shp(3, 13)=-2*a*ze - shp(3, 14)=-2*xi*ze - shp(3, 15)=-2*et*ze -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,3 - xs(i,j)=0.d0 - do k=1,15 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian determinant -! - xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) - & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) - & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) -! - if(iflag.eq.2) return -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj - xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj - xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj - xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj - xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj - xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj - xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj - xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj - xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj -! -! computation of the global derivatives of the shape functions -! - do k=1,15 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape20h_ax.f calculix-ccx-2.3/ccx_2.1/src/shape20h_ax.f --- calculix-ccx-2.1/ccx_2.1/src/shape20h_ax.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape20h_ax.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,246 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) -! -! shape functions and derivatives for a 20-node quadratic -! isoparametric brick element. -1<=xi,et,ze<=1 -! special case: axisymmetric elements -! -! iflag=1: calculate only the value of the shape functions -! iflag=2: calculate the value of the shape functions and -! the Jacobian determinant -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian determinant -! - implicit none -! - integer j,k,iflag -! - real*8 shp(4,20),xs(3,3),xsi(3,3),xl(3,20),shpe(4,20),dd, - & dd1,dd2,dd3 -! - real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr, - & tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr, - & omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr -! -! shape functions and their glocal derivatives -! - omg=1.d0-xi - omh=1.d0-et - omr=1.d0-ze - opg=1.d0+xi - oph=1.d0+et - opr=1.d0+ze - tpgphpr=opg+oph+ze - tmgphpr=omg+oph+ze - tmgmhpr=omg+omh+ze - tpgmhpr=opg+omh+ze - tpgphmr=opg+oph-ze - tmgphmr=omg+oph-ze - tmgmhmr=omg+omh-ze - tpgmhmr=opg+omh-ze - omgopg=omg*opg/4.d0 - omhoph=omh*oph/4.d0 - omropr=omr*opr/4.d0 - omgmopg=(omg-opg)/4.d0 - omhmoph=(omh-oph)/4.d0 - omrmopr=(omr-opr)/4.d0 -! -! shape functions -! - shp(4, 1)=-omg*omh*omr*tpgphpr/8.d0 - shp(4, 2)=-opg*omh*omr*tmgphpr/8.d0 - shp(4, 3)=-opg*oph*omr*tmgmhpr/8.d0 - shp(4, 4)=-omg*oph*omr*tpgmhpr/8.d0 - shp(4, 5)=-omg*omh*opr*tpgphmr/8.d0 - shp(4, 6)=-opg*omh*opr*tmgphmr/8.d0 - shp(4, 7)=-opg*oph*opr*tmgmhmr/8.d0 - shp(4, 8)=-omg*oph*opr*tpgmhmr/8.d0 - shp(4, 9)=omgopg*omh*omr - shp(4,10)=omhoph*opg*omr - shp(4,11)=omgopg*oph*omr - shp(4,12)=omhoph*omg*omr - shp(4,13)=omgopg*omh*opr - shp(4,14)=omhoph*opg*opr - shp(4,15)=omgopg*oph*opr - shp(4,16)=omhoph*omg*opr - shp(4,17)=omropr*omg*omh - shp(4,18)=omropr*opg*omh - shp(4,19)=omropr*opg*oph - shp(4,20)=omropr*omg*oph -! - if(iflag.eq.1) return -! -! local derivatives of the shape functions: xi-derivative -! - shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0 - shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0 - shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0 - shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0 - shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0 - shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0 - shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0 - shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0 - shpe(1, 9)=omgmopg*omh*omr - shpe(1,10)=omhoph*omr - shpe(1,11)=omgmopg*oph*omr - shpe(1,12)=-omhoph*omr - shpe(1,13)=omgmopg*omh*opr - shpe(1,14)=omhoph*opr - shpe(1,15)=omgmopg*oph*opr - shpe(1,16)=-omhoph*opr - shpe(1,17)=-omropr*omh - shpe(1,18)=omropr*omh - shpe(1,19)=omropr*oph - shpe(1,20)=-omropr*oph -! -! local derivatives of the shape functions: eta-derivative -! - shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0 - shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0 - shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0 - shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0 - shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0 - shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0 - shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0 - shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0 - shpe(2, 9)=-omgopg*omr - shpe(2,10)=omhmoph*opg*omr - shpe(2,11)=omgopg*omr - shpe(2,12)=omhmoph*omg*omr - shpe(2,13)=-omgopg*opr - shpe(2,14)=omhmoph*opg*opr - shpe(2,15)=omgopg*opr - shpe(2,16)=omhmoph*omg*opr - shpe(2,17)=-omropr*omg - shpe(2,18)=-omropr*opg - shpe(2,19)=omropr*opg - shpe(2,20)=omropr*omg -! -! local derivatives of the shape functions: zeta-derivative -! - shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0 - shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0 - shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0 - shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0 - shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0 - shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0 - shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0 - shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0 - shpe(3, 9)=-omgopg*omh - shpe(3,10)=-omhoph*opg - shpe(3,11)=-omgopg*oph - shpe(3,12)=-omhoph*omg - shpe(3,13)=omgopg*omh - shpe(3,14)=omhoph*opg - shpe(3,15)=omgopg*oph - shpe(3,16)=omhoph*omg - shpe(3,17)=omrmopr*omg*omh - shpe(3,18)=omrmopr*opg*omh - shpe(3,19)=omrmopr*opg*oph - shpe(3,20)=omrmopr*omg*oph -! -! computation of the local derivative of the global coordinates -! (xs) -! -c do i=1,3 -c do j=1,3 -c xs(i,j)=0.d0 -c do k=1,20 -c xs(i,j)=xs(i,j)+xl(i,k)*shpe(j,k) -c enddo -c enddo -c enddo - do j=1,3 - xs(1,j)=xl(1,1)*(shpe(j,1)+shpe(j,5)) - & +xl(1,2)*(shpe(j,2)+shpe(j,6)) - & +xl(1,3)*(shpe(j,3)+shpe(j,7)) - & +xl(1,4)*(shpe(j,4)+shpe(j,8)) - & +xl(1,9)*(shpe(j,9)+shpe(j,13)) - & +xl(1,10)*(shpe(j,10)+shpe(j,14)) - & +xl(1,11)*(shpe(j,11)+shpe(j,15)) - & +xl(1,12)*(shpe(j,12)+shpe(j,16)) - & +xl(1,17)*shpe(j,17)+xl(1,18)*shpe(j,18) - & +xl(1,19)*shpe(j,19)+xl(1,20)*shpe(j,20) - xs(2,j)=xl(2,1)*(shpe(j,1)+shpe(j,5)+shpe(j,17)) - & +xl(2,2)*(shpe(j,2)+shpe(j,6)+shpe(j,18)) - & +xl(2,3)*(shpe(j,3)+shpe(j,7)+shpe(j,19)) - & +xl(2,4)*(shpe(j,4)+shpe(j,8)+shpe(j,20)) - & +xl(2,9)*(shpe(j,9)+shpe(j,13)) - & +xl(2,10)*(shpe(j,10)+shpe(j,14)) - & +xl(2,11)*(shpe(j,11)+shpe(j,15)) - & +xl(2,12)*(shpe(j,12)+shpe(j,16)) - xs(3,j)=xl(3,1)*(shpe(j,1)-shpe(j,5)) - & +xl(3,2)*(shpe(j,2)-shpe(j,6)) - & +xl(3,3)*(shpe(j,3)-shpe(j,7)) - & +xl(3,4)*(shpe(j,4)-shpe(j,8)) - & +xl(3,9)*(shpe(j,9)-shpe(j,13)) - & +xl(3,10)*(shpe(j,10)-shpe(j,14)) - & +xl(3,11)*(shpe(j,11)-shpe(j,15)) - & +xl(3,12)*(shpe(j,12)-shpe(j,16)) - enddo -! -! computation of the jacobian determinant -! - dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2) - dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3) - dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1) - xsj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3 -c xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) -c & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) -c & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) -! - if(iflag.eq.2) return -! - dd=1.d0/xsj -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=dd1*dd - xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd - xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd - xsi(2,1)=dd2*dd - xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd - xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd - xsi(3,1)=dd3*dd - xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd - xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd -c xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))*dd -c xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd -c xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd -c xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))*dd -c xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd -c xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd -c xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))*dd -c xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd -c xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd -! -! computation of the global derivatives of the shape functions -! - do k=1,20 - do j=1,3 - shp(j,k)=shpe(1,k)*xsi(1,j)+shpe(2,k)*xsi(2,j) - & +shpe(3,k)*xsi(3,j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape20h.f calculix-ccx-2.3/ccx_2.1/src/shape20h.f --- calculix-ccx-2.1/ccx_2.1/src/shape20h.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape20h.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,210 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape20h(xi,et,ze,xl,xsj,shp,iflag) -! -! shape functions and derivatives for a 20-node quadratic -! isoparametric brick element. -1<=xi,et,ze<=1 -! -! iflag=1: calculate only the value of the shape functions -! iflag=2: calculate the value of the shape functions and -! the Jacobian determinant -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian determinant -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(4,20),xs(3,3),xsi(3,3),xl(3,20),shpe(4,20),dd, - & dd1,dd2,dd3 -! - real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr, - & tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr, - & omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr -! -! shape functions and their glocal derivatives -! - omg=1.d0-xi - omh=1.d0-et - omr=1.d0-ze - opg=1.d0+xi - oph=1.d0+et - opr=1.d0+ze - tpgphpr=opg+oph+ze - tmgphpr=omg+oph+ze - tmgmhpr=omg+omh+ze - tpgmhpr=opg+omh+ze - tpgphmr=opg+oph-ze - tmgphmr=omg+oph-ze - tmgmhmr=omg+omh-ze - tpgmhmr=opg+omh-ze - omgopg=omg*opg/4.d0 - omhoph=omh*oph/4.d0 - omropr=omr*opr/4.d0 - omgmopg=(omg-opg)/4.d0 - omhmoph=(omh-oph)/4.d0 - omrmopr=(omr-opr)/4.d0 -! -! shape functions -! - shp(4, 1)=-omg*omh*omr*tpgphpr/8.d0 - shp(4, 2)=-opg*omh*omr*tmgphpr/8.d0 - shp(4, 3)=-opg*oph*omr*tmgmhpr/8.d0 - shp(4, 4)=-omg*oph*omr*tpgmhpr/8.d0 - shp(4, 5)=-omg*omh*opr*tpgphmr/8.d0 - shp(4, 6)=-opg*omh*opr*tmgphmr/8.d0 - shp(4, 7)=-opg*oph*opr*tmgmhmr/8.d0 - shp(4, 8)=-omg*oph*opr*tpgmhmr/8.d0 - shp(4, 9)=omgopg*omh*omr - shp(4,10)=omhoph*opg*omr - shp(4,11)=omgopg*oph*omr - shp(4,12)=omhoph*omg*omr - shp(4,13)=omgopg*omh*opr - shp(4,14)=omhoph*opg*opr - shp(4,15)=omgopg*oph*opr - shp(4,16)=omhoph*omg*opr - shp(4,17)=omropr*omg*omh - shp(4,18)=omropr*opg*omh - shp(4,19)=omropr*opg*oph - shp(4,20)=omropr*omg*oph -! - if(iflag.eq.1) return -! -! local derivatives of the shape functions: xi-derivative -! - shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0 - shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0 - shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0 - shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0 - shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0 - shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0 - shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0 - shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0 - shpe(1, 9)=omgmopg*omh*omr - shpe(1,10)=omhoph*omr - shpe(1,11)=omgmopg*oph*omr - shpe(1,12)=-omhoph*omr - shpe(1,13)=omgmopg*omh*opr - shpe(1,14)=omhoph*opr - shpe(1,15)=omgmopg*oph*opr - shpe(1,16)=-omhoph*opr - shpe(1,17)=-omropr*omh - shpe(1,18)=omropr*omh - shpe(1,19)=omropr*oph - shpe(1,20)=-omropr*oph -! -! local derivatives of the shape functions: eta-derivative -! - shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0 - shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0 - shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0 - shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0 - shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0 - shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0 - shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0 - shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0 - shpe(2, 9)=-omgopg*omr - shpe(2,10)=omhmoph*opg*omr - shpe(2,11)=omgopg*omr - shpe(2,12)=omhmoph*omg*omr - shpe(2,13)=-omgopg*opr - shpe(2,14)=omhmoph*opg*opr - shpe(2,15)=omgopg*opr - shpe(2,16)=omhmoph*omg*opr - shpe(2,17)=-omropr*omg - shpe(2,18)=-omropr*opg - shpe(2,19)=omropr*opg - shpe(2,20)=omropr*omg -! -! local derivatives of the shape functions: zeta-derivative -! - shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0 - shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0 - shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0 - shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0 - shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0 - shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0 - shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0 - shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0 - shpe(3, 9)=-omgopg*omh - shpe(3,10)=-omhoph*opg - shpe(3,11)=-omgopg*oph - shpe(3,12)=-omhoph*omg - shpe(3,13)=omgopg*omh - shpe(3,14)=omhoph*opg - shpe(3,15)=omgopg*oph - shpe(3,16)=omhoph*omg - shpe(3,17)=omrmopr*omg*omh - shpe(3,18)=omrmopr*opg*omh - shpe(3,19)=omrmopr*opg*oph - shpe(3,20)=omrmopr*omg*oph -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,3 - xs(i,j)=0.d0 - do k=1,20 - xs(i,j)=xs(i,j)+xl(i,k)*shpe(j,k) - enddo - enddo - enddo -! -! computation of the jacobian determinant -! - dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2) - dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3) - dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1) - xsj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3 -! - if(iflag.eq.2) return -! - dd=1.d0/xsj -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=dd1*dd - xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd - xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd - xsi(2,1)=dd2*dd - xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd - xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd - xsi(3,1)=dd3*dd - xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd - xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd -! -! computation of the global derivatives of the shape functions -! - do k=1,20 - do j=1,3 - shp(j,k)=shpe(1,k)*xsi(1,j)+shpe(2,k)*xsi(2,j) - & +shpe(3,k)*xsi(3,j) - enddo - enddo -c do k=1,20 -c do j=1,3 -c shp(j,k)=shpe(j,k) -c enddo -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape20h_pl.f calculix-ccx-2.3/ccx_2.1/src/shape20h_pl.f --- calculix-ccx-2.1/ccx_2.1/src/shape20h_pl.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape20h_pl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,244 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) -! -! shape functions and derivatives for a 20-node quadratic -! isoparametric brick element. -1<=xi,et,ze<=1 -! special case: plane stress and plane strain elements -! -! iflag=1: calculate only the value of the shape functions -! iflag=2: calculate the value of the shape functions and -! the Jacobian determinant -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian determinant -! - implicit none -! - integer j,k,iflag -! - real*8 shp(4,20),xs(3,3),xsi(3,3),xl(3,20),shpe(4,20),dd, - & dd1,dd2,dd3 -! - real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr, - & tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr, - & omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr -! -! shape functions and their glocal derivatives -! - omg=1.d0-xi - omh=1.d0-et - omr=1.d0-ze - opg=1.d0+xi - oph=1.d0+et - opr=1.d0+ze - tpgphpr=opg+oph+ze - tmgphpr=omg+oph+ze - tmgmhpr=omg+omh+ze - tpgmhpr=opg+omh+ze - tpgphmr=opg+oph-ze - tmgphmr=omg+oph-ze - tmgmhmr=omg+omh-ze - tpgmhmr=opg+omh-ze - omgopg=omg*opg/4.d0 - omhoph=omh*oph/4.d0 - omropr=omr*opr/4.d0 - omgmopg=(omg-opg)/4.d0 - omhmoph=(omh-oph)/4.d0 - omrmopr=(omr-opr)/4.d0 -! -! shape functions -! - shp(4, 1)=-omg*omh*omr*tpgphpr/8.d0 - shp(4, 2)=-opg*omh*omr*tmgphpr/8.d0 - shp(4, 3)=-opg*oph*omr*tmgmhpr/8.d0 - shp(4, 4)=-omg*oph*omr*tpgmhpr/8.d0 - shp(4, 5)=-omg*omh*opr*tpgphmr/8.d0 - shp(4, 6)=-opg*omh*opr*tmgphmr/8.d0 - shp(4, 7)=-opg*oph*opr*tmgmhmr/8.d0 - shp(4, 8)=-omg*oph*opr*tpgmhmr/8.d0 - shp(4, 9)=omgopg*omh*omr - shp(4,10)=omhoph*opg*omr - shp(4,11)=omgopg*oph*omr - shp(4,12)=omhoph*omg*omr - shp(4,13)=omgopg*omh*opr - shp(4,14)=omhoph*opg*opr - shp(4,15)=omgopg*oph*opr - shp(4,16)=omhoph*omg*opr - shp(4,17)=omropr*omg*omh - shp(4,18)=omropr*opg*omh - shp(4,19)=omropr*opg*oph - shp(4,20)=omropr*omg*oph -! - if(iflag.eq.1) return -! -! local derivatives of the shape functions: xi-derivative -! - shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0 - shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0 - shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0 - shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0 - shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0 - shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0 - shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0 - shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0 - shpe(1, 9)=omgmopg*omh*omr - shpe(1,10)=omhoph*omr - shpe(1,11)=omgmopg*oph*omr - shpe(1,12)=-omhoph*omr - shpe(1,13)=omgmopg*omh*opr - shpe(1,14)=omhoph*opr - shpe(1,15)=omgmopg*oph*opr - shpe(1,16)=-omhoph*opr - shpe(1,17)=-omropr*omh - shpe(1,18)=omropr*omh - shpe(1,19)=omropr*oph - shpe(1,20)=-omropr*oph -! -! local derivatives of the shape functions: eta-derivative -! - shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0 - shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0 - shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0 - shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0 - shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0 - shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0 - shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0 - shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0 - shpe(2, 9)=-omgopg*omr - shpe(2,10)=omhmoph*opg*omr - shpe(2,11)=omgopg*omr - shpe(2,12)=omhmoph*omg*omr - shpe(2,13)=-omgopg*opr - shpe(2,14)=omhmoph*opg*opr - shpe(2,15)=omgopg*opr - shpe(2,16)=omhmoph*omg*opr - shpe(2,17)=-omropr*omg - shpe(2,18)=-omropr*opg - shpe(2,19)=omropr*opg - shpe(2,20)=omropr*omg -! -! local derivatives of the shape functions: zeta-derivative -! - shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0 - shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0 - shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0 - shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0 - shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0 - shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0 - shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0 - shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0 - shpe(3, 9)=-omgopg*omh - shpe(3,10)=-omhoph*opg - shpe(3,11)=-omgopg*oph - shpe(3,12)=-omhoph*omg - shpe(3,13)=omgopg*omh - shpe(3,14)=omhoph*opg - shpe(3,15)=omgopg*oph - shpe(3,16)=omhoph*omg - shpe(3,17)=omrmopr*omg*omh - shpe(3,18)=omrmopr*opg*omh - shpe(3,19)=omrmopr*opg*oph - shpe(3,20)=omrmopr*omg*oph -! -! computation of the local derivative of the global coordinates -! (xs) -! -c do i=1,3 -c do j=1,3 -c xs(i,j)=0.d0 -c do k=1,20 -c xs(i,j)=xs(i,j)+xl(i,k)*shpe(j,k) -c enddo -c enddo -c enddo - do j=1,3 - xs(1,j)=xl(1,1)*(shpe(j,1)+shpe(j,5)+shpe(j,17)) - & +xl(1,2)*(shpe(j,2)+shpe(j,6)+shpe(j,18)) - & +xl(1,3)*(shpe(j,3)+shpe(j,7)+shpe(j,19)) - & +xl(1,4)*(shpe(j,4)+shpe(j,8)+shpe(j,20)) - & +xl(1,9)*(shpe(j,9)+shpe(j,13)) - & +xl(1,10)*(shpe(j,10)+shpe(j,14)) - & +xl(1,11)*(shpe(j,11)+shpe(j,15)) - & +xl(1,12)*(shpe(j,12)+shpe(j,16)) - xs(2,j)=xl(2,1)*(shpe(j,1)+shpe(j,5)+shpe(j,17)) - & +xl(2,2)*(shpe(j,2)+shpe(j,6)+shpe(j,18)) - & +xl(2,3)*(shpe(j,3)+shpe(j,7)+shpe(j,19)) - & +xl(2,4)*(shpe(j,4)+shpe(j,8)+shpe(j,20)) - & +xl(2,9)*(shpe(j,9)+shpe(j,13)) - & +xl(2,10)*(shpe(j,10)+shpe(j,14)) - & +xl(2,11)*(shpe(j,11)+shpe(j,15)) - & +xl(2,12)*(shpe(j,12)+shpe(j,16)) - xs(3,j)=xl(3,1)*(shpe(j,1)-shpe(j,5)) - & +xl(3,2)*(shpe(j,2)-shpe(j,6)) - & +xl(3,3)*(shpe(j,3)-shpe(j,7)) - & +xl(3,4)*(shpe(j,4)-shpe(j,8)) - & +xl(3,9)*(shpe(j,9)-shpe(j,13)) - & +xl(3,10)*(shpe(j,10)-shpe(j,14)) - & +xl(3,11)*(shpe(j,11)-shpe(j,15)) - & +xl(3,12)*(shpe(j,12)-shpe(j,16)) - enddo -! -! computation of the jacobian determinant -! - dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2) - dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3) - dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1) - xsj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3 -c xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) -c & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) -c & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) -! - if(iflag.eq.2) return -! - dd=1.d0/xsj -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=dd1*dd - xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd - xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd - xsi(2,1)=dd2*dd - xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd - xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd - xsi(3,1)=dd3*dd - xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd - xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd -c xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))*dd -c xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd -c xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd -c xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))*dd -c xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd -c xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd -c xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))*dd -c xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd -c xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd -! -! computation of the global derivatives of the shape functions -! - do k=1,20 - do j=1,3 - shp(j,k)=shpe(1,k)*xsi(1,j)+shpe(2,k)*xsi(2,j) - & +shpe(3,k)*xsi(3,j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape3tri.f calculix-ccx-2.3/ccx_2.1/src/shape3tri.f --- calculix-ccx-2.1/ccx_2.1/src/shape3tri.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape3tri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,176 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape3tri(xi,et,xl,xsj,xs,shp,iflag) -! -! shape functions and derivatives for a 3-node linear -! isoparametric triangular element. 0<=xi,et<=1,xi+et<=1 -! -! iflag=2: calculate the value of the shape functions, -! their derivatives w.r.t. the local coordinates -! and the Jacobian vector (local normal to the -! surface) -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian vector (local normal -! to the surface) -! iflag=4: calculate the value of the shape functions, the -! value of their 1st and 2nd order derivatives -! w.r.t. the local coordinates, the Jacobian vector -! (local normal to the surface) -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(7,3),xs(3,7),xsi(2,3),xl(3,3),sh(3),xsj(3) -! - real*8 xi,et -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=-1.d0 - shp(1,2)=1.d0 - shp(1,3)=0.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=-1.d0 - shp(2,2)=0.d0 - shp(2,3)=1.d0 -! -! shape functions -! - shp(4,1)=1.d0-xi-et - shp(4,2)=xi - shp(4,3)=et -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,3 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian vector -! - xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - if(iflag.eq.3) then -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - if(dabs(xsj(3)).gt.1.d-10) then - xsi(1,1)=xs(2,2)/xsj(3) - xsi(2,2)=xs(1,1)/xsj(3) - xsi(1,2)=-xs(1,2)/xsj(3) - xsi(2,1)=-xs(2,1)/xsj(3) - if(dabs(xsj(2)).gt.1.d-10) then - xsi(2,3)=xs(1,1)/(-xsj(2)) - xsi(1,3)=-xs(1,2)/(-xsj(2)) - elseif(dabs(xsj(1)).gt.1.d-10) then - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - else - xsi(2,3)=0.d0 - xsi(1,3)=0.d0 - endif - elseif(dabs(xsj(2)).gt.1.d-10) then - xsi(1,1)=xs(3,2)/(-xsj(2)) - xsi(2,3)=xs(1,1)/(-xsj(2)) - xsi(1,3)=-xs(1,2)/(-xsj(2)) - xsi(2,1)=-xs(3,1)/(-xsj(2)) - if(dabs(xsj(1)).gt.1.d-10) then - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - else - xsi(1,2)=0.d0 - xsi(2,2)=0.d0 - endif - else - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - xsi(1,1)=0.d0 - xsi(2,1)=0.d0 - endif -c xsi(1,1)=xs(2,2)/xsj(3) -c xsi(2,1)=-xs(2,1)/xsj(3) -c xsi(1,2)=-xs(1,2)/xsj(3) -c xsi(2,2)=xs(1,1)/xsj(3) -c xsi(1,3)=-xs(2,2)/xsj(1) -c xsi(2,3)=xs(2,1)/xsj(1) -! -! computation of the global derivatives of the shape functions -! - do k=1,3 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - elseif(iflag.eq.4) then -! -! local 2nd order derivatives of the shape functions: xi,xi-derivative -! - shp(5,1)=0.d0 - shp(5,2)=0.d0 - shp(5,3)=0.d0 -! -! local 2nd order derivatives of the shape functions: xi,eta-derivative -! - shp(6,1)=0.d0 - shp(6,2)=0.d0 - shp(6,3)=0.d0 -! -! local 2nd order derivatives of the shape functions: eta,eta-derivative -! - shp(7,1)=0.d0 - shp(7,2)=0.d0 - shp(7,3)=0.d0 -! -! computation of the local 2nd derivatives of the global coordinates -! (xs) -! - do i=1,3 - do j=5,7 - xs(i,j)=0.d0 - enddo - enddo - endif -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape4q.f calculix-ccx-2.3/ccx_2.1/src/shape4q.f --- calculix-ccx-2.1/ccx_2.1/src/shape4q.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape4q.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,181 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape4q(xi,et,xl,xsj,xs,shp,iflag) -! -! iflag=2: calculate the value of the shape functions, -! their derivatives w.r.t. the local coordinates -! and the Jacobian vector (local normal to the -! surface) -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian vector (local normal -! to the surface) -! iflag=4: calculate the value of the shape functions, the -! value of their 1st and 2nd order derivatives -! w.r.t. the local coordinates, the Jacobian vector -! (local normal to the surface) -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(7,4),xs(3,7),xsi(2,3),xl(3,8),sh(3),xsj(3) -! - real*8 xi,et -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=-(1.d0-et)/4.d0 - shp(1,2)=(1.d0-et)/4.d0 - shp(1,3)=(1.d0+et)/4.d0 - shp(1,4)=-(1.d0+et)/4.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=-(1.d0-xi)/4.d0 - shp(2,2)=-(1.d0+xi)/4.d0 - shp(2,3)=(1.d0+xi)/4.d0 - shp(2,4)=(1.d0-xi)/4.d0 -! -! shape functions -! - shp(4,1)=(1.d0-xi)*(1.d0-et)/4.d0 - shp(4,2)=(1.d0+xi)*(1.d0-et)/4.d0 - shp(4,3)=(1.d0+xi)*(1.d0+et)/4.d0 - shp(4,4)=(1.d0-xi)*(1.d0+et)/4.d0 -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,4 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian vector -! - xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - if(iflag.eq.3) then -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! -c xsi(1,1)=xs(2,2)/xsj(3) -c xsi(2,1)=-xs(2,1)/xsj(3) -c xsi(1,2)=-xs(1,2)/xsj(3) -c xsi(2,2)=xs(1,1)/xsj(3) -c xsi(1,3)=-xs(2,2)/xsj(1) -c xsi(2,3)=xs(2,1)/xsj(1) - if(dabs(xsj(3)).gt.1.d-10) then - xsi(1,1)=xs(2,2)/xsj(3) - xsi(2,2)=xs(1,1)/xsj(3) - xsi(1,2)=-xs(1,2)/xsj(3) - xsi(2,1)=-xs(2,1)/xsj(3) - if(dabs(xsj(2)).gt.1.d-10) then - xsi(2,3)=xs(1,1)/(-xsj(2)) - xsi(1,3)=-xs(1,2)/(-xsj(2)) - elseif(dabs(xsj(1)).gt.1.d-10) then - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - else - xsi(2,3)=0.d0 - xsi(1,3)=0.d0 - endif - elseif(dabs(xsj(2)).gt.1.d-10) then - xsi(1,1)=xs(3,2)/(-xsj(2)) - xsi(2,3)=xs(1,1)/(-xsj(2)) - xsi(1,3)=-xs(1,2)/(-xsj(2)) - xsi(2,1)=-xs(3,1)/(-xsj(2)) - if(dabs(xsj(1)).gt.1.d-10) then - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - else - xsi(1,2)=0.d0 - xsi(2,2)=0.d0 - endif - else - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - xsi(1,1)=0.d0 - xsi(2,1)=0.d0 - endif -! -! computation of the global derivatives of the shape functions -! - do k=1,4 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - elseif(iflag.eq.4) then -! -! local 2nd order derivatives of the shape functions: xi,xi-derivative -! - shp(5,1)=0.d0 - shp(5,2)=0.d0 - shp(5,3)=0.d0 - shp(5,4)=0.d0 -! -! local 2nd order derivatives of the shape functions: xi,eta-derivative -! - shp(6,1)=0.25d0 - shp(6,2)=-0.25d0 - shp(6,3)=0.25d0 - shp(6,4)=-0.25d0 -! -! local 2nd order derivatives of the shape functions: eta,eta-derivative -! - shp(7,1)=0.d0 - shp(7,2)=0.d0 - shp(7,3)=0.d0 - shp(7,4)=0.d0 -! -! computation of the local 2nd derivatives of the global coordinates -! (xs) -! - do i=1,3 - xs(i,5)=0.d0 - xs(i,7)=0.d0 - enddo - do i=1,3 - xs(i,6)=0.d0 - do k=1,4 - xs(i,6)=xs(i,6)+xl(i,k)*shp(6,k) - enddo - enddo - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape4tet.f calculix-ccx-2.3/ccx_2.1/src/shape4tet.f --- calculix-ccx-2.1/ccx_2.1/src/shape4tet.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape4tet.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,116 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape4tet(xi,et,ze,xl,xsj,shp,iflag) -! -! shape functions and derivatives for a 4-node linear -! isoparametric tetrahedral element. 0<=xi,et,ze<=1,xi+et+ze<=1. -! -! iflag=1: calculate only the value of the shape functions -! iflag=2: calculate the value of the shape functions and -! the Jacobian determinant -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian determinant -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(4,4),xs(3,3),xsi(3,3),xl(3,4),sh(3) -! - real*8 xi,et,ze,xsj -! -! shape functions and their glocal derivatives -! -! shape functions -! - shp(4, 1)=1.d0-xi-et-ze - shp(4, 2)=xi - shp(4, 3)=et - shp(4, 4)=ze -! - if(iflag.eq.1) return -! -! local derivatives of the shape functions: xi-derivative -! - shp(1, 1)=-1.d0 - shp(1, 2)=1.d0 - shp(1, 3)=0.d0 - shp(1, 4)=0.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2, 1)=-1.d0 - shp(2, 2)=0.d0 - shp(2, 3)=1.d0 - shp(2, 4)=0.d0 -! -! local derivatives of the shape functions: zeta-derivative -! - shp(3, 1)=-1.d0 - shp(3, 2)=0.d0 - shp(3, 3)=0.d0 - shp(3, 4)=1.d0 -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,3 - xs(i,j)=0.d0 - do k=1,4 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian determinant -! - xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) - & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) - & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) -! - if(iflag.eq.2) return -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj - xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj - xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj - xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj - xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj - xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj - xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj - xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj - xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj -! -! computation of the global derivatives of the shape functions -! - do k=1,4 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape6tri.f calculix-ccx-2.3/ccx_2.1/src/shape6tri.f --- calculix-ccx-2.1/ccx_2.1/src/shape6tri.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape6tri.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,194 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape6tri(xi,et,xl,xsj,xs,shp,iflag) -! -! iflag=2: calculate the value of the shape functions, -! their derivatives w.r.t. the local coordinates -! and the Jacobian vector (local normal to the -! surface) -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian vector (local normal -! to the surface) -! iflag=4: calculate the value of the shape functions, the -! value of their 1st and 2nd order derivatives -! w.r.t. the local coordinates, the Jacobian vector -! (local normal to the surface) -! -! shape functions and derivatives for a 6-node quadratic -! isoparametric triangular element. 0<=xi,et<=1,xi+et<=1 -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(7,6),xs(3,7),xsi(2,3),xl(3,6),sh(3),xsj(3) -! - real*8 xi,et -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=4.d0*(xi+et)-3.d0 - shp(1,2)=4.d0*xi-1.d0 - shp(1,3)=0.d0 - shp(1,4)=4.d0*(1.d0-2.d0*xi-et) - shp(1,5)=4.d0*et - shp(1,6)=-4.d0*et -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=4.d0*(xi+et)-3.d0 - shp(2,2)=0.d0 - shp(2,3)=4.d0*et-1.d0 - shp(2,4)=-4.d0*xi - shp(2,5)=4.d0*xi - shp(2,6)=4.d0*(1.d0-xi-2.d0*et) -! -! shape functions -! - shp(4,1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et) - shp(4,2)=xi*(2.d0*xi-1.d0) - shp(4,3)=et*(2.d0*et-1.d0) - shp(4,4)=4.d0*xi*(1.d0-xi-et) - shp(4,5)=4.d0*xi*et - shp(4,6)=4.d0*et*(1.d0-xi-et) -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,6 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian vector -! - xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - if(iflag.eq.3) then -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! -c xsi(1,1)=xs(2,2)/xsj(3) -c xsi(2,1)=-xs(2,1)/xsj(3) -c xsi(1,2)=-xs(1,2)/xsj(3) -c xsi(2,2)=xs(1,1)/xsj(3) -c xsi(1,3)=-xs(2,2)/xsj(1) -c xsi(2,3)=xs(2,1)/xsj(1) - if(dabs(xsj(3)).gt.1.d-10) then - xsi(1,1)=xs(2,2)/xsj(3) - xsi(2,2)=xs(1,1)/xsj(3) - xsi(1,2)=-xs(1,2)/xsj(3) - xsi(2,1)=-xs(2,1)/xsj(3) - if(dabs(xsj(2)).gt.1.d-10) then - xsi(2,3)=xs(1,1)/(-xsj(2)) - xsi(1,3)=-xs(1,2)/(-xsj(2)) - elseif(dabs(xsj(1)).gt.1.d-10) then - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - else - xsi(2,3)=0.d0 - xsi(1,3)=0.d0 - endif - elseif(dabs(xsj(2)).gt.1.d-10) then - xsi(1,1)=xs(3,2)/(-xsj(2)) - xsi(2,3)=xs(1,1)/(-xsj(2)) - xsi(1,3)=-xs(1,2)/(-xsj(2)) - xsi(2,1)=-xs(3,1)/(-xsj(2)) - if(dabs(xsj(1)).gt.1.d-10) then - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - else - xsi(1,2)=0.d0 - xsi(2,2)=0.d0 - endif - else - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - xsi(1,1)=0.d0 - xsi(2,1)=0.d0 - endif -! -! computation of the global derivatives of the shape functions -! - do k=1,6 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - elseif(iflag.eq.4) then -! -! local 2nd order derivatives of the shape functions: xi,xi-derivative -! - shp(5,1)=4.d0 - shp(5,2)=4.d0 - shp(5,3)=0.d0 - shp(5,4)=-8.d0 - shp(5,5)=0.d0 - shp(5,6)=0.d0 -! -! local 2nd order derivatives of the shape functions: xi,eta-derivative -! - shp(6,1)=4.d0 - shp(6,2)=0.d0 - shp(6,3)=0.d0 - shp(6,4)=-4.d0 - shp(6,5)=4.d0 - shp(6,6)=-4.d0 -! -! local 2nd order derivatives of the shape functions: eta,eta-derivative -! - shp(7,1)=4.d0 - shp(7,2)=0.d0 - shp(7,3)=4.d0 - shp(7,4)=0.d0 - shp(7,5)=0.d0 - shp(7,6)=-8.d0 -! -! computation of the local 2nd derivatives of the global coordinates -! (xs) -! - do i=1,3 - do j=5,7 - xs(i,j)=0.d0 - do k=1,6 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape6w.f calculix-ccx-2.3/ccx_2.1/src/shape6w.f --- calculix-ccx-2.1/ccx_2.1/src/shape6w.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape6w.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,134 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape6w(xi,et,ze,xl,xsj,shp,iflag) -! -! shape functions and derivatives for a 6-node linear -! isoparametric wedge element. 0<=xi,et<=1,xi+et<=1,-1<=ze<=1. -! -! iflag=1: calculate only the value of the shape functions -! iflag=2: calculate the value of the shape functions and -! the Jacobian determinant -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian determinant -! -! -! Copyright (c) 2003 WB -! -! Written January 2003 on the basis of the Guido's shape function files -! - - implicit none -! - integer i,j,k,iflag -! - real*8 shp(4,6),xs(3,3),xsi(3,3),xl(3,6),sh(3) -! - real*8 xi,et,ze,xsj,a -! -! shape functions and their glocal derivatives -! - a=1.d0-xi-et -! -! shape functions -! - shp(4, 1)=0.5d0*a *(1.d0-ze) - shp(4, 2)=0.5d0*xi*(1.d0-ze) - shp(4, 3)=0.5d0*et*(1.d0-ze) - shp(4, 4)=0.5d0*a *(1.d0+ze) - shp(4, 5)=0.5d0*xi*(1.d0+ze) - shp(4, 6)=0.5d0*et*(1.d0+ze) -! - if(iflag.eq.1) return -! -! local derivatives of the shape functions: xi-derivative -! - shp(1, 1)=-0.5d0*(1.d0-ze) - shp(1, 2)= 0.5d0*(1.d0-ze) - shp(1, 3)= 0.d0 - shp(1, 4)=-0.5d0*(1.d0+ze) - shp(1, 5)= 0.5d0*(1.d0+ze) - shp(1, 6)= 0.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2, 1)=-0.5d0*(1.d0-ze) - shp(2, 2)= 0.d0 - shp(2, 3)= 0.5d0*(1.d0-ze) - shp(2, 4)=-0.5d0*(1.d0+ze) - shp(2, 5)= 0.d0 - shp(2, 6)= 0.5d0*(1.d0+ze) - -! -! local derivatives of the shape functions: zeta-derivative -! - shp(3, 1)=-0.5d0*a - shp(3, 2)=-0.5d0*xi - shp(3, 3)=-0.5d0*et - shp(3, 4)= 0.5d0*a - shp(3, 5)= 0.5d0*xi - shp(3, 6)= 0.5d0*et -! -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,3 - xs(i,j)=0.d0 - do k=1,6 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian determinant -! - xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) - & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) - & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) -! - if(iflag.eq.2) return -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj - xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj - xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj - xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj - xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj - xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj - xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj - xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj - xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj -! -! computation of the global derivatives of the shape functions -! - do k=1,6 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape8h.f calculix-ccx-2.3/ccx_2.1/src/shape8h.f --- calculix-ccx-2.1/ccx_2.1/src/shape8h.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape8h.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,139 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape8h(xi,et,ze,xl,xsj,shp,iflag) -! -! shape functions and derivatives for a 8-node linear isoparametric -! solid element -! -! iflag=1: calculate only the value of the shape functions -! iflag=2: calculate the value of the shape functions and -! the Jacobian determinant -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian determinant -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(4,20),xs(3,3),xsi(3,3),xl(3,20),sh(3) -! - real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr -! -! shape functions and their glocal derivatives -! - omg=1.d0-xi - omh=1.d0-et - omr=1.d0-ze - opg=1.d0+xi - oph=1.d0+et - opr=1.d0+ze -! -! shape functions -! - shp(4, 1)=omg*omh*omr/8.d0 - shp(4, 2)=opg*omh*omr/8.d0 - shp(4, 3)=opg*oph*omr/8.d0 - shp(4, 4)=omg*oph*omr/8.d0 - shp(4, 5)=omg*omh*opr/8.d0 - shp(4, 6)=opg*omh*opr/8.d0 - shp(4, 7)=opg*oph*opr/8.d0 - shp(4, 8)=omg*oph*opr/8.d0 -! - if(iflag.eq.1) return -! -! local derivatives of the shape functions: xi-derivative -! - shp(1, 1)=-omh*omr/8.d0 - shp(1, 2)=omh*omr/8.d0 - shp(1, 3)=oph*omr/8.d0 - shp(1, 4)=-oph*omr/8.d0 - shp(1, 5)=-omh*opr/8.d0 - shp(1, 6)=omh*opr/8.d0 - shp(1, 7)=oph*opr/8.d0 - shp(1, 8)=-oph*opr/8.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2, 1)=-omg*omr/8.d0 - shp(2, 2)=-opg*omr/8.d0 - shp(2, 3)=opg*omr/8.d0 - shp(2, 4)=omg*omr/8.d0 - shp(2, 5)=-omg*opr/8.d0 - shp(2, 6)=-opg*opr/8.d0 - shp(2, 7)=opg*opr/8.d0 - shp(2, 8)=omg*opr/8.d0 -! -! local derivatives of the shape functions: zeta-derivative -! - shp(3, 1)=-omg*omh/8.d0 - shp(3, 2)=-opg*omh/8.d0 - shp(3, 3)=-opg*oph/8.d0 - shp(3, 4)=-omg*oph/8.d0 - shp(3, 5)=omg*omh/8.d0 - shp(3, 6)=opg*omh/8.d0 - shp(3, 7)=opg*oph/8.d0 - shp(3, 8)=omg*oph/8.d0 -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,3 - xs(i,j)=0.d0 - do k=1,8 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian determinant -! - xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) - & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) - & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) -! - if(iflag.eq.2) return -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj - xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj - xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj - xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj - xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj - xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj - xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj - xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj - xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj -! -! computation of the global derivatives of the shape functions -! - do k=1,8 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shape8q.f calculix-ccx-2.3/ccx_2.1/src/shape8q.f --- calculix-ccx-2.1/ccx_2.1/src/shape8q.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shape8q.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,200 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shape8q(xi,et,xl,xsj,xs,shp,iflag) -! -! shape functions and derivatives for a 8-node quadratic -! isoparametric quadrilateral element. -1<=xi,et<=1 -! -! iflag=2: calculate the value of the shape functions, -! their derivatives w.r.t. the local coordinates -! and the Jacobian vector (local normal to the -! surface) -! iflag=3: calculate the value of the shape functions, the -! value of their derivatives w.r.t. the global -! coordinates and the Jacobian vector (local normal -! to the surface) -! iflag=4: calculate the value of the shape functions, the -! value of their 1st and 2nd order derivatives -! w.r.t. the local coordinates, the Jacobian vector -! (local normal to the surface) -! - implicit none -! - integer i,j,k,iflag -! - real*8 shp(7,8),xs(3,7),xsi(2,3),xl(3,8),sh(3),xsj(3) -! - real*8 xi,et -! -! shape functions and their glocal derivatives for an element -! described with two local parameters and three global ones. -! -! local derivatives of the shape functions: xi-derivative -! - shp(1,1)=(1.d0-et)*(2.d0*xi+et)/4.d0 - shp(1,2)=(1.d0-et)*(2.d0*xi-et)/4.d0 - shp(1,3)=(1.d0+et)*(2.d0*xi+et)/4.d0 - shp(1,4)=(1.d0+et)*(2.d0*xi-et)/4.d0 - shp(1,5)=-xi*(1.d0-et) - shp(1,6)=(1.d0-et*et)/2.d0 - shp(1,7)=-xi*(1.d0+et) - shp(1,8)=-(1.d0-et*et)/2.d0 -! -! local derivatives of the shape functions: eta-derivative -! - shp(2,1)=(1.d0-xi)*(2.d0*et+xi)/4.d0 - shp(2,2)=(1.d0+xi)*(2.d0*et-xi)/4.d0 - shp(2,3)=(1.d0+xi)*(2.d0*et+xi)/4.d0 - shp(2,4)=(1.d0-xi)*(2.d0*et-xi)/4.d0 - shp(2,5)=-(1.d0-xi*xi)/2.d0 - shp(2,6)=-et*(1.d0+xi) - shp(2,7)=(1.d0-xi*xi)/2.d0 - shp(2,8)=-et*(1.d0-xi) -! -! shape functions -! - shp(4,1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0 - shp(4,2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0 - shp(4,3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0 - shp(4,4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0 - shp(4,5)=(1.d0-xi*xi)*(1.d0-et)/2.d0 - shp(4,6)=(1.d0+xi)*(1.d0-et*et)/2.d0 - shp(4,7)=(1.d0-xi*xi)*(1.d0+et)/2.d0 - shp(4,8)=(1.d0-xi)*(1.d0-et*et)/2.d0 -! -! computation of the local derivative of the global coordinates -! (xs) -! - do i=1,3 - do j=1,2 - xs(i,j)=0.d0 - do k=1,8 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo -! -! computation of the jacobian vector -! - xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) - xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) - xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) -! - if(iflag.eq.3) then -! -! computation of the global derivative of the local coordinates -! (xsi) (inversion of xs) -! - if(dabs(xsj(3)).gt.1.d-10) then - xsi(1,1)=xs(2,2)/xsj(3) - xsi(2,2)=xs(1,1)/xsj(3) - xsi(1,2)=-xs(1,2)/xsj(3) - xsi(2,1)=-xs(2,1)/xsj(3) - if(dabs(xsj(2)).gt.1.d-10) then - xsi(2,3)=xs(1,1)/(-xsj(2)) - xsi(1,3)=-xs(1,2)/(-xsj(2)) - elseif(dabs(xsj(1)).gt.1.d-10) then - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - else - xsi(2,3)=0.d0 - xsi(1,3)=0.d0 - endif - elseif(dabs(xsj(2)).gt.1.d-10) then - xsi(1,1)=xs(3,2)/(-xsj(2)) - xsi(2,3)=xs(1,1)/(-xsj(2)) - xsi(1,3)=-xs(1,2)/(-xsj(2)) - xsi(2,1)=-xs(3,1)/(-xsj(2)) - if(dabs(xsj(1)).gt.1.d-10) then - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - else - xsi(1,2)=0.d0 - xsi(2,2)=0.d0 - endif - else - xsi(1,2)=xs(3,2)/xsj(1) - xsi(2,3)=xs(2,1)/xsj(1) - xsi(1,3)=-xs(2,2)/xsj(1) - xsi(2,2)=-xs(3,1)/xsj(1) - xsi(1,1)=0.d0 - xsi(2,1)=0.d0 - endif -! -! computation of the global derivatives of the shape functions -! - do k=1,8 - do j=1,3 - sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) - enddo - do j=1,3 - shp(j,k)=sh(j) - enddo - enddo -! - elseif(iflag.eq.4) then -! -! local 2nd order derivatives of the shape functions: xi,xi-derivative -! - shp(5,1)=(1.d0-et)/2.d0 - shp(5,2)=(1.d0-et)/2.d0 - shp(5,3)=(1.d0+et)/2.d0 - shp(5,4)=(1.d0+et)/2.d0 - shp(5,5)=-(1.d0-et) - shp(5,6)=0.d0 - shp(5,7)=-(1.d0+et) - shp(5,8)=0.d0 -! -! local 2nd order derivatives of the shape functions: xi,eta-derivative -! - shp(6,1)=(1.d0-2.d0*(xi+et))/4.d0 - shp(6,2)=(-1.d0-2.d0*(xi-et))/4.d0 - shp(6,3)=(1.d0+2.d0*(xi+et))/4.d0 - shp(6,4)=(-1.d0-2.d0*(xi+et))/4.d0 - shp(6,5)=xi - shp(6,6)=-et - shp(6,7)=-xi - shp(6,8)=et -! -! local 2nd order derivatives of the shape functions: eta,eta-derivative -! - shp(7,1)=(1.d0-xi)/2.d0 - shp(7,2)=(1.d0+xi)/2.d0 - shp(7,3)=(1.d0+xi)/2.d0 - shp(7,4)=(1.d0-xi)/2.d0 - shp(7,5)=0.d0 - shp(7,6)=-(1.d0+xi) - shp(7,7)=0.d0 - shp(7,8)=-(1.d0-xi) -! -! computation of the local 2nd derivatives of the global coordinates -! (xs) -! - do i=1,3 - do j=5,7 - xs(i,j)=0.d0 - do k=1,8 - xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) - enddo - enddo - enddo - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/shellsections.f calculix-ccx-2.3/ccx_2.1/src/shellsections.f --- calculix-ccx-2.1/ccx_2.1/src/shellsections.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/shellsections.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,188 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine shellsections(inpc,textpart,set,istartset,iendset, - & ialset,nset,ielmat,matname,nmat,ielorien,orname,norien, - & thicke,kon,ipkon,offset,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,lakon,iaxial,ipoinpc) -! -! reading the input deck: *SHELL SECTION -! - implicit none -! - logical nodalthickness -! - character*1 inpc(*) - character*8 lakon(*) - character*80 matname(*),orname(*),material,orientation - character*81 set(*),elset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),ielmat(*), - & ielorien(*),kon(*),ipkon(*),indexe,irstrt,nset,nmat,norien, - & istep,istat,n,key,i,j,k,l,imaterial,iorientation,ipos, - & iline,ipol,inl,ipoinp(2,*),inp(3,*),iaxial,ipoinpc(0:*) -! - real*8 thicke(2,*),thickness,offset(2,*),offset1 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in shellsections: *SHELL SECTION should' - write(*,*) ' be placed before all step definitions' - stop - endif -! - nodalthickness=.false. - offset1=0.d0 - orientation=' ' - do i=2,n - if(textpart(i)(1:9).eq.'MATERIAL=') then - material=textpart(i)(10:89) - elseif(textpart(i)(1:12).eq.'ORIENTATION=') then - orientation=textpart(i)(13:92) - elseif(textpart(i)(1:6).eq.'ELSET=') then - elset=textpart(i)(7:86) - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - elseif(textpart(i)(1:14).eq.'NODALTHICKNESS') then - nodalthickness=.true. - elseif(textpart(i)(1:7).eq.'OFFSET=') then - read(textpart(i)(8:27),'(f20.0)',iostat=istat) offset1 - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - enddo -! -! check for the existence of the set,the material and orientation -! - do i=1,nmat - if(matname(i).eq.material) exit - enddo - if(i.gt.nmat) then - write(*,*) '*ERROR in shellsections: nonexistent material' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - imaterial=i -! - if(orientation.eq.' ') then - iorientation=0 - else - do i=1,norien - if(orname(i).eq.orientation) exit - enddo - if(i.gt.norien) then - write(*,*)'*ERROR in shellsections: nonexistent orientation' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iorientation=i - endif -! - do i=1,nset - if(set(i).eq.elset) exit - enddo - if(i.gt.nset) then - elset(ipos:ipos)=' ' - write(*,*) '*ERROR in shellsections: element set ',elset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! -! assigning the elements of the set the appropriate material, -! orientation number and offset -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - if(lakon(ialset(j))(1:1).ne.'S') then - write(*,*) '*ERROR in shellsections: *SHELL SECTION can' - write(*,*) ' only be used for shell elements.' - write(*,*) ' Element ',ialset(j),' is not a shell e - &lement.' - stop - endif - ielmat(ialset(j))=imaterial - ielorien(ialset(j))=iorientation - offset(1,ialset(j))=offset1 - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - if(lakon(k)(1:1).ne.'S') then - write(*,*) '*ERROR in shellsections: *SHELL SECTION ca - &n' - write(*,*) ' only be used for shell elements.' - write(*,*) ' Element ',k,' is not a shell elemen - &t.' - stop - endif - ielmat(k)=imaterial - ielorien(k)=iorientation - offset(1,k)=offset1 - enddo - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! -! assigning a thickness to the elements -! -c read(textpart(1)(1:20),'(f20.0)',iostat=istat) thickness -c if(istat.gt.0) then -c write(*,*) -c & '*ERROR in shellsections: shell thickness is lacking' -c call inputerror(inpc,ipoinpc,iline) -c endif -! - if(.not.nodalthickness) then - read(textpart(1)(1:20),'(f20.0)',iostat=istat) thickness - if(istat.gt.0) then - write(*,*) - & '*ERROR in shellsections: shell thickness is lacking' - call inputerror(inpc,ipoinpc,iline) - endif - if(iaxial.ne.0) thickness=thickness/iaxial - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - indexe=ipkon(ialset(j)) - do l=1,8 - thicke(1,indexe+l)=thickness - enddo - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - indexe=ipkon(k) - do l=1,8 - thicke(1,indexe+l)=thickness - enddo - enddo - endif - enddo - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/sigini.f calculix-ccx-2.3/ccx_2.1/src/sigini.f --- calculix-ccx-2.1/ccx_2.1/src/sigini.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/sigini.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine sigini(sigma,coords,ntens,ncrds,noel,npt,layer, - & kspt,lrebar,rebarn) -! -! user subroutine sigini -! -! INPUT: -! -! coords coordinates of the integration point -! ntens number of stresses to be defined -! ncrds number of coordinates -! noel element number -! npt integration point number -! layer currently not used -! kspt currently not used -! lrebar currently not used (value: 0) -! rebarn currently not used -! -! OUTPUT: -! -! sigma(1..ntens) residual stress values in the integration -! point. If ntens=6 the order of the -! components is 11,22,33,12,13,23 -! - implicit none -! - character*80 rebarn - integer ntens,ncrds,noel,npt,layer,kspt,lrebar - real*8 sigma(*),coords(*) -! - sigma(1)=-100.d0*coords(2) - sigma(2)=-100.d0*coords(2) - sigma(3)=-100.d0*coords(2) - sigma(4)=0.d0 - sigma(5)=0.d0 - sigma(6)=0.d0 -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/skip.f calculix-ccx-2.3/ccx_2.1/src/skip.f --- calculix-ccx-2.1/ccx_2.1/src/skip.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/skip.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,180 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine skip(nset,nalset,nload,nbody, - & nforc,nboun,nflow,nk,ne,nkon, - & mi,nmpc,memmpc_,nmat,ntmat_,npmat_,ncmat_,norien,ntrans,nam, - & nprint,nlabel,ncs_,ne1d,ne2d,infree,nmethod, - & iperturb,nener,iplas,ithermal,nstate_,iprestr,mcs,ntie) -! - implicit none -! - integer nset,nalset,nload,nforc,nboun,nflow,nk,ne,nkon,mi(2), - & nmpc,memmpc_,nmat,ntmat_,npmat_,ncmat_,norien,ntrans,nam, - & nprint,nlabel,ncs_,ne1d,ne2d,infree(4),i,mt, - & nmethod,iperturb(*),nener,iplas,ithermal,nstate_,iprestr,i4, - & maxamta,mcs,ntie,nbody -! - character*1 c1 - character*3 c3 - character*4 c4 - character*5 c5 - character*8 c8 - character*20 c20 - character*80 c80 - character*81 c81 - character*87 c87 -! - real*8 r8 -! - mt=mi(2)+1 -! -! skipping the next entries -! - read(15)(c81,i=1,nset) - read(15)(i4,i=1,nset) - read(15)(i4,i=1,nset) - do i=1,nalset - read(15)i4 - enddo - read(15)(r8,i=1,3*nk) - read(15)(i4,i=1,nkon) - read(15)(i4,i=1,ne) - read(15)(c8,i=1,ne) - read(15)(i4,i=1,nboun) - read(15)(i4,i=1,nboun) - read(15)(c1,i=1,nboun) - read(15)(r8,i=1,nboun) - read(15)(i4,i=1,nboun) - read(15)(i4,i=1,nboun) - if(nam.gt.0) read(15)(i4,i=1,nboun) - read(15)(i4,i=1,nboun) - read(15)(i4,i=1,nboun) - read(15)(r8,i=1,nboun) - read(15)(i4,i=1,nmpc) - read(15)(c20,i=1,nmpc) - read(15)(i4,i=1,nmpc) - read(15)(i4,i=1,nmpc) - read(15)(r8,i=1,nmpc) - read(15)(i4,i=1,3*memmpc_) - read(15)(r8,i=1,memmpc_) - read(15)(i4,i=1,nforc) - read(15)(i4,i=1,nforc) - read(15)(r8,i=1,nforc) - read(15)(i4,i=1,nforc) - read(15)(i4,i=1,nforc) - if(nam.gt.0) read(15)(i4,i=1,nforc) - read(15)(r8,i=1,nforc) - read(15)(i4,i=1,2*nload) - read(15)(c5,i=1,nload) - read(15)(r8,i=1,2*nload) - if(nam.gt.0) read(15)(i4,i=1,2*nload) - read(15)(r8,i=1,2*nload) - read(15)(c81,i=1,nbody) - read(15)(i4,i=1,2*nbody) - read(15)(r8,i=1,7*nbody) - read(15)(r8,i=1,7*nbody) - if(iprestr.gt.0) read(15) (r8,i=1,6*mi(1)*ne) -c read(15)(i4,i=1,2*nflow) -c read(15)(r8,i=1,nflow) -c if(nam.gt.0) read(15)(i4,i=1,nflow) -c read(15)(r8,i=1,nflow) - read(15)(c5,i=1,nprint) - read(15)(c81,i=1,nprint) - read(15)(c87,i=1,nlabel) - read(15)(r8,i=1,(ncmat_+1)*ntmat_*nmat) - read(15)(i4,i=1,2*nmat) - read(15)(r8,i=1,2*ntmat_*nmat) - read(15)(i4,i=1,nmat) - read(15)(r8,i=1,2*ntmat_*nmat) - read(15)(i4,i=1,nmat) - read(15)(r8,i=1,7*ntmat_*nmat) - read(15)(i4,i=1,nmat) - read(15)(r8,i=1,7*ntmat_*nmat) - read(15)(i4,i=1,2*nmat) - read(15)(r8,i=1,nmat) - read(15)(r8,i=1,3) - if(iplas.ne.0)then - read(15)(r8,i=1,(2*npmat_+1)*ntmat_*nmat) - read(15)(i4,i=1,(ntmat_+1)*nmat) - read(15)(r8,i=1,(2*npmat_+1)*ntmat_*nmat) - read(15)(i4,i=1,(ntmat_+1)*nmat) - endif - if(norien.ne.0)then - read(15)(c80,i=1,norien) - read(15)(r8,i=1,7*norien) - read(15)(i4,i=1,ne) - endif - if(ntrans.ne.0)then - read(15)(r8,i=1,7*ntrans) - read(15)(i4,i=1,2*nk) - endif - if(nam.gt.0)then - read(15)(c80,i=1,nam) - read(15)(i4,i=1,3*nam-1) - maxamta=2*i4 - read(15)i4 - read(15)(r8,i=1,maxamta) - endif - if(ithermal.gt.0)then - if((ne1d.gt.0).or.(ne2d.gt.0))then - read(15)(r8,i=1,3*nk) - read(15)(r8,i=1,3*nk) - else - read(15)(r8,i=1,nk) - read(15)(r8,i=1,nk) - endif - if(nam.gt.0) read(15)(i4,i=1,nk) - read(15)(r8,i=1,nk) - endif - read(15)(c80,i=1,nmat) - read(15)(i4,i=1,ne) - read(15)(r8,i=1,mt*nk) - if((nmethod.eq.4).or.((nmethod.eq.1).and.(iperturb(1).ge.2))) - & then - read(15)(r8,i=1,mt*nk) - endif - read(15)(i4,i=1,nk) - if((ne1d.gt.0).or.(ne2d.gt.0))then - read(15)(i4,i=1,2*nkon) - read(15)(r8,i=1,infree(1)-1) - read(15)(i4,i=1,infree(2)-1) - read(15)(r8,i=1,2*nkon) - read(15)(r8,i=1,2*ne) - read(15)(i4,i=1,infree(4)) - read(15)(i4,i=1,3*(infree(3)-1)) - read(15)(i4,i=1,infree(4)) - endif - if(ntie.gt.0) then - read(15)(c81,i=1,3*ntie) - endif - if(ncs_.gt.0)then - read(15)(i4,i=1,ncs_) - read(15)(r8,i=1,17*mcs) - endif - read(15)(r8,i=1,6*mi(1)*ne) - read(15)(r8,i=1,6*mi(1)*ne) - if(nener.eq.1) read(15)(r8,i=1,mi(1)*ne) - if(nstate_.gt.0) read(15)(r8,i=1,nstate_*mi(1)*ne) - read(15) (r8,i=1,27) - read(15) (r8,i=1,2) - read(15) c3 - read(15) r8 -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/smooth.f calculix-ccx-2.3/ccx_2.1/src/smooth.f --- calculix-ccx-2.1/ccx_2.1/src/smooth.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/smooth.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine smooth(adb,aub,adl,sol,aux,icol,irow,jq, - & neq,nzl,csmooth) -! -! smoothing the finite element solution -! -! Ref: The Finite Element Method for Fluid Dynamics, -! O.C. Zienkiewicz, R.L. Taylor & P. Nithiarasu -! 6th edition (2006) ISBN 0 7506 6322 7 -! p. 61 -! - implicit none -! - integer icol(*),irow(*),jq(*),neq,nzl,i,j,k -! - real*8 adb(*),aub(*),adl(*),sol(*),aux(*),p,csmooth,c1,c2 -! -! multiplying the original matrix with zero -! diagonal with the actual solution -! - call op(neq,p,sol,aux,adb,aub,icol,irow,nzl) -c call op(neq,p,sol,aux,adl,aub,icol,irow,nzl) -! -! lumping the matrix set (adb,aux) and storing the resulting -! diagonal terms in adl -! - do i=1,neq - adl(i)=adb(i) - enddo -! - do j=1,neq - do k=jq(j),jq(j+1)-1 - i=irow(k) - adl(i)=adl(i)+aub(k) - adl(j)=adl(j)+aub(k) - enddo - enddo -! -! determining the multiplicative constants -! - c2=1.d0+csmooth/2.d0 - c1=1.d0/c2 - c2=csmooth/c2 -! -! smoothing the solution -! - do i=1,neq - sol(i)=c1*sol(i)+c2*aux(i)/adl(i)/2.d0 -c sol(i)=c1*sol(i)+c2*aux(i)/adl(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/smoothshock.f calculix-ccx-2.3/ccx_2.1/src/smoothshock.f --- calculix-ccx-2.1/ccx_2.1/src/smoothshock.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/smoothshock.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine smoothshock(adb,aub,adl,addiv,sol,aux,icol,irow,jq, - & neq,nzl,sa) -! -! smoothing the finite element solution -! -! Ref: The Finite Element Method for Fluid Dynamics, -! O.C. Zienkiewicz, R.L. Taylor & P. Nithiarasu -! 6th edition (2006) ISBN 0 7506 6322 7 -! p. 61 -! - implicit none -! - integer icol(*),irow(*),jq(*),neq,nzl,i,j,k -! - real*8 adb(*),aub(*),adl(*),sol(*),aux(*),p,sa(*),addiv(*) -c! -c! lumping the matrix set (adb,aux) and storing the resulting -c! diagonal terms in adl -c! -c do i=1,neq -c adl(i)=adb(i) -c enddo -c! -c do j=1,neq -c do k=jq(j),jq(j+1)-1 -c i=irow(k) -c adl(i)=adl(i)+aub(k) -c adl(j)=adl(j)+aub(k) -c enddo -c enddo -! -! subtracting the lumped matrix from the diagonal and storing -! it into the lumped matrix storage -! -cg do i=1,neq -cg addiv(i)=adb(i)-adl(i) -cg enddo -! -! multiplying M-ML with the solution -! -cg call op(neq,p,sol,aux,addiv,aub,icol,irow,nzl) - call op(neq,p,sol,aux,adb,aub,icol,irow,nzl) -! -! smoothing the solution -! - do i=1,neq -cg sol(i)=sol(i)+sa(i)*aux(i)/(adb(i)-addiv(i)) - sol(i)=sol(i)+sa(i)*aux(i)*adl(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/solidsections.f calculix-ccx-2.3/ccx_2.1/src/solidsections.f --- calculix-ccx-2.1/ccx_2.1/src/solidsections.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/solidsections.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,302 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine solidsections(inpc,textpart,set,istartset,iendset, - & ialset,nset,ielmat,matname,nmat,ielorien,orname,norien, - & lakon,thicke,kon,ipkon,irstrt,istep,istat,n,iline,ipol,inl, - & ipoinp,inp,cs,mcs,iaxial,ipoinpc) -! -! reading the input deck: *SOLID SECTION -! - implicit none -! - character*1 inpc(*) - character*8 lakon(*) - character*80 matname(*),orname(*),material,orientation - character*81 set(*),elset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),ielmat(*), - & ielorien(*),kon(*),ipkon(*),indexe,irstrt,nset,nmat,norien, - & istep,istat,n,key,i,j,k,l,imaterial,iorientation,ipos, - & iline,ipol,inl,ipoinp(2,*),inp(3,*),mcs,iaxial,ipoinpc(0:*) -! - real*8 thicke(2,*),thickness,pi,cs(17,*) -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in solidsections: *SOLID SECTION should' - write(*,*) ' be placed before all step definitions' - stop - endif -! - orientation=' - & ' - elset=' - & ' - ipos=0 -! - do i=2,n - if(textpart(i)(1:9).eq.'MATERIAL=') then - material=textpart(i)(10:89) - elseif(textpart(i)(1:12).eq.'ORIENTATION=') then - orientation=textpart(i)(13:92) - elseif(textpart(i)(1:6).eq.'ELSET=') then - elset=textpart(i)(7:86) - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - endif - enddo -! -! check for the existence of the set,the material and orientation -! - do i=1,nmat - if(matname(i).eq.material) exit - enddo - if(i.gt.nmat) then - do i=1,nmat - if(matname(i)(1:11).eq.'ANISO_CREEP') then - if(matname(i)(12:20).eq.material(1:9)) exit - elseif(matname(i)(1:10).eq.'ANISO_PLAS') then - if(matname(i)(11:20).eq.material(1:10)) exit - endif - enddo - endif - if(i.gt.nmat) then - write(*,*) '*ERROR in solidsections: nonexistent material' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - imaterial=i -! - if(orientation.eq.' ') then - iorientation=0 - else - do i=1,norien - if(orname(i).eq.orientation) exit - enddo - if(i.gt.norien) then - write(*,*)'*ERROR in solidsections: nonexistent orientation' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iorientation=i - endif -! - if(ipos.eq.0) then - write(*,*) '*ERROR in solidsections: no element set ',elset - write(*,*) ' was been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - do i=1,nset - if(set(i).eq.elset) exit - enddo - if(i.gt.nset) then - elset(ipos:ipos)=' ' - write(*,*) '*ERROR in solidsections: element set ',elset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! -! assigning the elements of the set the appropriate material -! and orientation number -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - if((lakon(ialset(j))(1:1).eq.'B').or. - & (lakon(ialset(j))(1:1).eq.'S')) then - write(*,*) '*ERROR in solidsections: *SOLID SECTION can' - write(*,*) ' not be used for beam or shell elements - &' - write(*,*) ' Faulty element: ',ialset(j) - stop - endif - ielmat(ialset(j))=imaterial - ielorien(ialset(j))=iorientation - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - if((lakon(k)(1:1).eq.'B').or. - & (lakon(k)(1:1).eq.'S')) then - write(*,*) '*ERROR in solidsections: *SOLID SECTION ca - &n' - write(*,*) ' not be used for beam or shell eleme - &nts' - write(*,*) ' Faulty element: ',k - stop - endif - ielmat(k)=imaterial - ielorien(k)=iorientation - enddo - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! -! assigning a thickness to plane stress elements and an angle to -! axisymmetric elements -! - if((key.eq.0).or.(lakon(ialset(istartset(i)))(1:2).eq.'CA')) then - if(key.eq.0) then - read(textpart(1)(1:20),'(f20.0)',iostat=istat) thickness - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! -! for axial symmetric structures: -! thickness for axial symmetric elements: 1 degree -! thickness for plane stress elements: reduced by 360 -! thickness for plane strain elements: reduced by 360 -! - if(iaxial.ne.0) then - if(lakon(ialset(istartset(i)))(1:2).eq.'CA') then - thickness=datan(1.d0)*8.d0/iaxial - elseif(lakon(ialset(istartset(i)))(1:3).eq.'CPS') then - thickness=thickness/iaxial - elseif(lakon(ialset(istartset(i)))(1:3).eq.'CPE') then - thickness=thickness/iaxial - endif - endif - else - thickness=datan(1.d0)*8.d0/iaxial - endif -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - if((lakon(ialset(j))(1:2).eq.'CP').or. - & (lakon(ialset(j))(1:2).eq.'CA')) then - indexe=ipkon(ialset(j)) - do l=1,8 - thicke(1,indexe+l)=thickness - enddo - endif - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - if((lakon(k)(1:2).eq.'CP').or. - & (lakon(k)(1:2).eq.'CA')) then - indexe=ipkon(k) - do l=1,8 - thicke(1,indexe+l)=thickness - enddo - endif - enddo - endif - enddo -! -! defining cyclic symmetric conditions for axisymmetric -! elements (needed for cavity radiation) -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - if(lakon(ialset(j))(1:2).eq.'CA') then - pi=4.d0*datan(1.d0) - if(mcs.gt.1) then - write(*,*) '*ERROR in solidsections: ' - write(*,*) ' axisymmetric elements cannot be - &combined with cyclic symmetry' - stop - elseif(mcs.eq.1) then - if(int(cs(1,1)).ne.int(2.d0*pi/thickness+0.5d0)) - & then - write(*,*) '*ERROR in solidsections: ' - write(*,*) ' it is not allowed to define t - &wo different' - write(*,*) ' angles for an axisymmetric st - &ructure' - stop - else - exit - endif - endif - mcs=1 - cs(1,1)=2.d0*pi/thickness+0.5d0 - cs(2,1)=-0.5d0 - cs(3,1)=-0.5d0 - cs(5,1)=1.5d0 - do k=6,9 - cs(k,1)=0.d0 - enddo - cs(10,1)=1.d0 - cs(11,1)=0.d0 - cs(12,1)=-1.d0 - cs(14,1)=0.5 - cs(15,1)=dcos(thickness) - cs(16,1)=dsin(thickness) - exit - endif - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - if(lakon(ialset(j))(1:2).eq.'CA') then - if(mcs.gt.1) then - write(*,*) '*ERROR in solidsections: ' - write(*,*) ' axisymmetric elements cannot - &be combined with cyclic symmetry' - stop - elseif(mcs.eq.1) then - if(int(cs(1,1)).ne.int(2.d0*pi/thickness+0.5d0)) - & then - write(*,*) '*ERROR in solidsections: ' - write(*,*) ' it is not allowed to defin - &e two different' - write(*,*) ' angles for an axisymmetric - & structure' - stop - else - exit - endif - endif - mcs=1 - cs(1,1)=2.d0*pi/thickness+0.5d0 - cs(2,1)=-0.5d0 - cs(3,1)=-0.5d0 - cs(5,1)=1.5d0 - do k=6,9 - cs(k,1)=0.d0 - enddo - cs(10,1)=1.d0 - cs(11,1)=0.d0 - cs(12,1)=-1.d0 - cs(14,1)=0.5 - cs(15,1)=dcos(thickness) - cs(16,1)=dsin(thickness) - exit - endif - enddo - endif - enddo -! - if(key.eq.0) then - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - endif - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/solveeq.f calculix-ccx-2.3/ccx_2.1/src/solveeq.f --- calculix-ccx-2.1/ccx_2.1/src/solveeq.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/solveeq.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine solveeq(adb,aub,adl,addiv,b,sol,aux,icol,irow,jq, - & neq,nzs,nzl) -! -! solving a system of equations by iteratively solving the -! lumped version -! The diagonal terms f the original system are stored in adb, -! the off-diagonal terms in aub -! Ref: The Finite Element Method for Fluid Dynamics, -! O.C. Zienkiewicz, R.L. Taylor & P. Nithiarasu -! 6th edition (2006) ISBN 0 7506 6322 7 -! p. 61 -! - implicit none -! - integer icol(*),irow(*),jq(*),neq,nzs,nzl,i,j,k,maxit -! - real*8 adb(*),aub(*),adl(*),addiv(*),b(*),sol(*),aux(*),p -! - data maxit /1/ -! -! first iteration -! - do i=1,neq - sol(i)=b(i)*adl(i) - enddo - if(maxit.eq.1) return -! -! iterating maxit times -! - do k=2,maxit -! -! multiplying the difference of the original matrix -! with the lumped matrix with the actual solution -! - call op(neq,p,sol,aux,adb,aub,icol,irow,nzl) -! - do i=1,neq - sol(i)=(b(i)-aux(i))*adl(i) - enddo -! - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/spcmatch.f calculix-ccx-2.3/ccx_2.1/src/spcmatch.f --- calculix-ccx-2.1/ccx_2.1/src/spcmatch.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/spcmatch.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine spcmatch(xboun,nodeboun,ndirboun,nboun,xbounold, - & nodebounold,ndirbounold,nbounold,ikboun,ilboun,vold,reorder, - & nreorder,mi) -! -! matches SPC boundary conditions of one step with those of -! the previous step -! - implicit none -! - integer nodeboun(*),ndirboun(*),nboun,nodebounold(*),ilboun(*), - & ndirbounold(*),nbounold,i,kflag,idof,id,nreorder(*),ikboun(*), - & mi(2) -! - real*8 xboun(*),xbounold(*),vold(0:mi(2),*),reorder(*) -! - kflag=2 -! - do i=1,nboun - nreorder(i)=0 - enddo -! - do i=1,nbounold - idof=8*(nodebounold(i)-1)+ndirbounold(i) - if(nboun.gt.0) then - call nident(ikboun,idof,nboun,id) - else - id=0 - endif - if((id.gt.0).and.(ikboun(id).eq.idof)) then - reorder(ilboun(id))=xbounold(i) - nreorder(ilboun(id))=1 - endif - enddo -! - do i=1,nboun - if(nreorder(i).eq.0) then - if(ndirboun(i).gt.4) then - reorder(i)=0.d0 - else - reorder(i)=vold(ndirboun(i),nodeboun(i)) - endif - endif - enddo -! - do i=1,nboun - xbounold(i)=reorder(i) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/specificgasconstants.f calculix-ccx-2.3/ccx_2.1/src/specificgasconstants.f --- calculix-ccx-2.1/ccx_2.1/src/specificgasconstants.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/specificgasconstants.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine specificgasconstants(inpc,textpart,shcon,nshcon, - & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, - & inp,ipoinpc) -! -! reading the input deck: *SPECIFIC GAS CONSTANT -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nshcon(*),nmat,ntmat_,istep,istat,n,ipoinpc(0:*), - & key,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - real*8 shcon(0:3,ntmat_,*) -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in specificheats: *SPECIFIC GAS CONSTANT' - write(*,*) ' should be placed before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in specificheats: *SPECIFIC GAS CONSTANT' - write(*,*) ' should be preceded by a *MATERIAL card' - stop - endif -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - read(textpart(1)(1:20),'(f20.0)',iostat=istat) - & shcon(3,1,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/specificheats.f calculix-ccx-2.3/ccx_2.1/src/specificheats.f --- calculix-ccx-2.1/ccx_2.1/src/specificheats.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/specificheats.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,69 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine specificheats(inpc,textpart,shcon,nshcon, - & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, - & inp,ipoinpc) -! -! reading the input deck: *SPECIFIC HEAT -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nshcon(*),nmat,ntmat,ntmat_,istep,istat,n,ipoinpc(0:*), - & key,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) -! - real*8 shcon(0:3,ntmat_,*) -! - ntmat=0 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in specificheats: *SPECIFIC HEAT should be' - write(*,*) ' placed before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in specificheats: *SPECIFIC HEAT should be' - write(*,*) ' preceded by a *MATERIAL card' - stop - endif -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - nshcon(nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in specificheats: increase ntmat_' - stop - endif - read(textpart(1)(1:20),'(f20.0)',iostat=istat) - & shcon(1,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) - & shcon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/splitline.f calculix-ccx-2.3/ccx_2.1/src/splitline.f --- calculix-ccx-2.1/ccx_2.1/src/splitline.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/splitline.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,94 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine splitline(text,textpart,n) -! - implicit none -! -! splits an input line (text) in n comma separated fields (textpart) -! -! n = # comma's +1, -! - integer n,i,j,k,ierror -! - character*1 ctext - character*132 text,textpart(16) -! - n=1 - j=0 - do i=1,132 - ctext=text(i:i) - if(ctext.ne.',') then - if(ctext.eq.' ') then -c cycle - exit - else -c if((ichar(ctext).ge.97).and.(ichar(ctext).le.122)) -c & ctext=char(ichar(ctext)-32) - endif - j=j+1 - if(j.le.132) textpart(n)(j:j)=ctext - else - do k=j+1,132 - textpart(n)(k:k)=' ' - enddo - j=0 - n=n+1 - if(n.gt.16) then - ierror=0 - do k=i+1,132 - if(text(k:k).eq.',') cycle - if(text(k:k).eq.' ') then - if(ierror.eq.0) then - exit - else - write(*,*) - & '*ERROR in splitline: there should not' - write(*,*)' be more than 16 entries in a ' - write(*,*) ' line; ' - write(*,'(a132)') text(1:k-1) - stop - endif - endif - ierror=1 - enddo - exit - endif - endif - enddo - if(j.eq.0) then - n=n-1 - else - do k=j+1,132 - textpart(n)(k:k)=' ' - enddo - endif -! -! clearing all textpart fields not used -! - do i=n+1,16 - textpart(i)=' - & - & ' - enddo -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/spooles.c calculix-ccx-2.3/ccx_2.1/src/spooles.c --- calculix-ccx-2.1/ccx_2.1/src/spooles.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/spooles.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,738 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ -/* - * The implementation is derived from the SPOOLES sample described in - * AllInOne.ps - * created -- 98jun04, cca - * - * Converted to something that resembles C and - * support for multithreaded solving added. - * (C) 2003 Manfred Spraul - */ - -#ifdef SPOOLES - -#include -#include -#include -#include -#include "CalculiX.h" -#include "spooles.h" - -#if USE_MT -int num_cpus = -1; -#endif - -#define TUNE_MAXZEROS 1000 -#define TUNE_MAXDOMAINSIZE 800 -#define TUNE_MAXSIZE 64 - -#define RNDSEED 7892713 -#define MAGIC_DTOL 0.0 -#define MAGIC_TAU 100.0 - -/* - * Substeps for solving A X = B: - * - * (1) form Graph object - * (2) order matrix and form front tree - * (3) get the permutation, permute the matrix and - * front tree and get the symbolic factorization - * (4) compute the numeric factorization - * (5) read in right hand side entries - * (6) compute the solution - * - * The ssolve_main functions free the input matrices internally - */ - -static void ssolve_creategraph(Graph ** graph, ETree ** frontETree, - InpMtx * mtxA, int size, FILE * msgFile) -{ - IVL *adjIVL; - int nedges; - - *graph = Graph_new(); - adjIVL = InpMtx_fullAdjacency(mtxA); - nedges = IVL_tsize(adjIVL); - Graph_init2(*graph, 0, size, 0, nedges, size, nedges, adjIVL, - NULL, NULL); - if (DEBUG_LVL > 1) { - fprintf(msgFile, "\n\n graph of the input matrix"); - Graph_writeForHumanEye(*graph, msgFile); - fflush(msgFile); - } - /* (2) order the graph using multiple minimum degree */ - - /*maxdomainsize=neqns/100; */ - /*if (maxdomainsize==0) maxdomainsize=1; */ - /* *frontETree = orderViaMMD(*graph, RNDSEED, DEBUG_LVL, msgFile) ; */ - /* *frontETree = orderViaND(*graph,maxdomainsize,RNDSEED,DEBUG_LVL,msgFile); */ - /* *frontETree = orderViaMS(*graph,maxdomainsize,RNDSEED,DEBUG_LVL,msgFile); */ - - *frontETree = - orderViaBestOfNDandMS(*graph, TUNE_MAXDOMAINSIZE, - TUNE_MAXZEROS, TUNE_MAXSIZE, RNDSEED, - DEBUG_LVL, msgFile); - if (DEBUG_LVL > 1) { - fprintf(msgFile, "\n\n front tree from ordering"); - ETree_writeForHumanEye(*frontETree, msgFile); - fflush(msgFile); - } -} - -static void ssolve_permuteA(IV ** oldToNewIV, IV ** newToOldIV, - IVL ** symbfacIVL, ETree * frontETree, - InpMtx * mtxA, FILE * msgFile, int *symmetryflag) -{ - int *oldToNew; - - *oldToNewIV = ETree_oldToNewVtxPerm(frontETree); - oldToNew = IV_entries(*oldToNewIV); - *newToOldIV = ETree_newToOldVtxPerm(frontETree); - ETree_permuteVertices(frontETree, *oldToNewIV); - InpMtx_permute(mtxA, oldToNew, oldToNew); - if(*symmetryflag!=2) InpMtx_mapToUpperTriangle(mtxA); - InpMtx_changeCoordType(mtxA, INPMTX_BY_CHEVRONS); - InpMtx_changeStorageMode(mtxA, INPMTX_BY_VECTORS); - *symbfacIVL = SymbFac_initFromInpMtx(frontETree, mtxA); - if (DEBUG_LVL > 1) { - fprintf(msgFile, "\n\n old-to-new permutation vector"); - IV_writeForHumanEye(*oldToNewIV, msgFile); - fprintf(msgFile, "\n\n new-to-old permutation vector"); - IV_writeForHumanEye(*newToOldIV, msgFile); - fprintf(msgFile, "\n\n front tree after permutation"); - ETree_writeForHumanEye(frontETree, msgFile); - fprintf(msgFile, "\n\n input matrix after permutation"); - InpMtx_writeForHumanEye(mtxA, msgFile); - fprintf(msgFile, "\n\n symbolic factorization"); - IVL_writeForHumanEye(*symbfacIVL, msgFile); - fflush(msgFile); - } -} - -static void ssolve_postfactor(FrontMtx *frontmtx, FILE *msgFile) -{ - FrontMtx_postProcess(frontmtx, DEBUG_LVL, msgFile); - if (DEBUG_LVL > 1) { - fprintf(msgFile, "\n\n factor matrix after post-processing"); - FrontMtx_writeForHumanEye(frontmtx, msgFile); - fflush(msgFile); - } -} - -static void ssolve_permuteB(DenseMtx *mtxB, IV *oldToNewIV, FILE* msgFile) -{ - DenseMtx_permuteRows(mtxB, oldToNewIV); - if (DEBUG_LVL > 1) { - fprintf(msgFile, - "\n\n right hand side matrix in new ordering"); - DenseMtx_writeForHumanEye(mtxB, msgFile); - fflush(msgFile); - } -} - -static void ssolve_permuteout(DenseMtx *mtxX, IV *newToOldIV, FILE *msgFile) -{ - DenseMtx_permuteRows(mtxX, newToOldIV); - if (DEBUG_LVL > 1) { - fprintf(msgFile, "\n\n solution matrix in original ordering"); - DenseMtx_writeForHumanEye(mtxX, msgFile); - fflush(msgFile); - } -} - - void factor(struct factorinfo *pfi, InpMtx *mtxA, int size, FILE *msgFile, - int *symmetryflag) -{ - Graph *graph; - IVL *symbfacIVL; - Chv *rootchv; - - /* Initialize pfi: */ - pfi->size = size; - pfi->msgFile = msgFile; - pfi->solvemap = NULL; - DVfill(10, pfi->cpus, 0.0); - - /* - * STEP 1 : find a low-fill ordering - * (1) create the Graph object - */ - ssolve_creategraph(&graph, &pfi->frontETree, mtxA, size, pfi->msgFile); - - /* - * STEP 2: get the permutation, permute the matrix and - * front tree and get the symbolic factorization - */ - ssolve_permuteA(&pfi->oldToNewIV, &pfi->newToOldIV, &symbfacIVL, pfi->frontETree, - mtxA, pfi->msgFile, symmetryflag); - - /* - * STEP 3: initialize the front matrix object - */ - { - pfi->frontmtx = FrontMtx_new(); - pfi->mtxmanager = SubMtxManager_new(); - SubMtxManager_init(pfi->mtxmanager, NO_LOCK, 0); - FrontMtx_init(pfi->frontmtx, pfi->frontETree, symbfacIVL, SPOOLES_REAL, - *symmetryflag, FRONTMTX_DENSE_FRONTS, - SPOOLES_PIVOTING, NO_LOCK, 0, NULL, - pfi->mtxmanager, DEBUG_LVL, pfi->msgFile); - } - - /* - * STEP 4: compute the numeric factorization - */ - { - ChvManager *chvmanager; - int stats[20]; - int error; - - chvmanager = ChvManager_new(); - ChvManager_init(chvmanager, NO_LOCK, 1); - IVfill(20, stats, 0); - rootchv = FrontMtx_factorInpMtx(pfi->frontmtx, mtxA, MAGIC_TAU, MAGIC_DTOL, - chvmanager, &error, pfi->cpus, - stats, DEBUG_LVL, pfi->msgFile); - ChvManager_free(chvmanager); - if (DEBUG_LVL > 1) { - fprintf(msgFile, "\n\n factor matrix"); - FrontMtx_writeForHumanEye(pfi->frontmtx, pfi->msgFile); - fflush(msgFile); - } - if (rootchv != NULL) { - fprintf(pfi->msgFile, "\n\n matrix found to be singular\n"); - exit(-1); - } - if (error >= 0) { - fprintf(pfi->msgFile, "\n\nerror encountered at front %d", - error); - exit(-1); - } - } - /* - * STEP 5: post-process the factorization - */ - ssolve_postfactor(pfi->frontmtx, pfi->msgFile); - - /* cleanup: */ - IVL_free(symbfacIVL); - InpMtx_free(mtxA); - Graph_free(graph); -} - -DenseMtx *fsolve(struct factorinfo *pfi, DenseMtx *mtxB) -{ - DenseMtx *mtxX; - /* - * STEP 6: permute the right hand side into the new ordering - */ - { - DenseMtx_permuteRows(mtxB, pfi->oldToNewIV); - if (DEBUG_LVL > 1) { - fprintf(pfi->msgFile, - "\n\n right hand side matrix in new ordering"); - DenseMtx_writeForHumanEye(mtxB, pfi->msgFile); - fflush(pfi->msgFile); - } - } - /* - * STEP 7: solve the linear system - */ - { - mtxX = DenseMtx_new(); - DenseMtx_init(mtxX, SPOOLES_REAL, 0, 0, pfi->size, 1, 1, pfi->size); - DenseMtx_zero(mtxX); - FrontMtx_solve(pfi->frontmtx, mtxX, mtxB, pfi->mtxmanager, pfi->cpus, - DEBUG_LVL, pfi->msgFile); - if (DEBUG_LVL > 1) { - fprintf(pfi->msgFile, "\n\n solution matrix in new ordering"); - DenseMtx_writeForHumanEye(mtxX, pfi->msgFile); - fflush(pfi->msgFile); - } - } - /* - * STEP 8: permute the solution into the original ordering - */ - ssolve_permuteout(mtxX, pfi->newToOldIV, pfi->msgFile); - - /* cleanup: */ - DenseMtx_free(mtxB); - - return mtxX; -} - -#ifdef USE_MT -static void factor_MT(struct factorinfo *pfi, InpMtx *mtxA, int size, FILE *msgFile, int *symmetryflag) -{ - Graph *graph; - IV *ownersIV; - IVL *symbfacIVL; - Chv *rootchv; - - /* Initialize pfi: */ - pfi->size = size; - pfi->msgFile = msgFile; - DVfill(10, pfi->cpus, 0.0); - - /* - * STEP 1 : find a low-fill ordering - * (1) create the Graph object - */ - ssolve_creategraph(&graph, &pfi->frontETree, mtxA, size, msgFile); - - /* - * STEP 2: get the permutation, permute the matrix and - * front tree and get the symbolic factorization - */ - ssolve_permuteA(&pfi->oldToNewIV, &pfi->newToOldIV, &symbfacIVL, pfi->frontETree, - mtxA, msgFile, symmetryflag); - - /* - * STEP 3: Prepare distribution to multiple threads/cpus - */ - { - DV *cumopsDV; - int nfront; - - nfront = ETree_nfront(pfi->frontETree); - - pfi->nthread = num_cpus; - if (pfi->nthread > nfront) - pfi->nthread = nfront; - - cumopsDV = DV_new(); - DV_init(cumopsDV, pfi->nthread, NULL); - ownersIV = ETree_ddMap(pfi->frontETree, SPOOLES_REAL, *symmetryflag, - cumopsDV, 1. / (2. * pfi->nthread)); - if (DEBUG_LVL > 1) { - fprintf(msgFile, - "\n\n map from fronts to threads"); - IV_writeForHumanEye(ownersIV, msgFile); - fprintf(msgFile, - "\n\n factor operations for each front"); - DV_writeForHumanEye(cumopsDV, msgFile); - fflush(msgFile); - } else { - fprintf(msgFile, "\n\n Using %d threads\n", - pfi->nthread); - } - DV_free(cumopsDV); - } - - /* - * STEP 4: initialize the front matrix object - */ - { - pfi->frontmtx = FrontMtx_new(); - pfi->mtxmanager = SubMtxManager_new(); - SubMtxManager_init(pfi->mtxmanager, LOCK_IN_PROCESS, 0); - FrontMtx_init(pfi->frontmtx, pfi->frontETree, symbfacIVL, SPOOLES_REAL, - *symmetryflag, FRONTMTX_DENSE_FRONTS, - SPOOLES_PIVOTING, LOCK_IN_PROCESS, 0, NULL, - pfi->mtxmanager, DEBUG_LVL, pfi->msgFile); - } - - /* - * STEP 5: compute the numeric factorization in parallel - */ - { - ChvManager *chvmanager; - int stats[20]; - int error; - - chvmanager = ChvManager_new(); - ChvManager_init(chvmanager, LOCK_IN_PROCESS, 1); - IVfill(20, stats, 0); - rootchv = FrontMtx_MT_factorInpMtx(pfi->frontmtx, mtxA, MAGIC_TAU, MAGIC_DTOL, - chvmanager, ownersIV, 0, - &error, pfi->cpus, stats, DEBUG_LVL, - pfi->msgFile); - ChvManager_free(chvmanager); - if (DEBUG_LVL > 1) { - fprintf(msgFile, "\n\n factor matrix"); - FrontMtx_writeForHumanEye(pfi->frontmtx, pfi->msgFile); - fflush(pfi->msgFile); - } - if (rootchv != NULL) { - fprintf(pfi->msgFile, "\n\n matrix found to be singular\n"); - exit(-1); - } - if (error >= 0) { - fprintf(pfi->msgFile, "\n\n fatal error at front %d", error); - exit(-1); - } - } - - /* - * STEP 6: post-process the factorization - */ - ssolve_postfactor(pfi->frontmtx, pfi->msgFile); - - /* - * STEP 7: get the solve map object for the parallel solve - */ - { - pfi->solvemap = SolveMap_new(); - SolveMap_ddMap(pfi->solvemap, *symmetryflag, - FrontMtx_upperBlockIVL(pfi->frontmtx), - FrontMtx_lowerBlockIVL(pfi->frontmtx), pfi->nthread, ownersIV, - FrontMtx_frontTree(pfi->frontmtx), RNDSEED, DEBUG_LVL, - pfi->msgFile); - } - - /* cleanup: */ - InpMtx_free(mtxA); - IVL_free(symbfacIVL); - Graph_free(graph); - IV_free(ownersIV); -} - -DenseMtx *fsolve_MT(struct factorinfo *pfi, DenseMtx *mtxB) -{ - DenseMtx *mtxX; - /* - * STEP 8: permute the right hand side into the new ordering - */ - ssolve_permuteB(mtxB, pfi->oldToNewIV, pfi->msgFile); - - - /* - * STEP 9: solve the linear system in parallel - */ - { - mtxX = DenseMtx_new(); - DenseMtx_init(mtxX, SPOOLES_REAL, 0, 0, pfi->size, 1, 1, pfi->size); - DenseMtx_zero(mtxX); - FrontMtx_MT_solve(pfi->frontmtx, mtxX, mtxB, pfi->mtxmanager, - pfi->solvemap, pfi->cpus, DEBUG_LVL, - pfi->msgFile); - if (DEBUG_LVL > 1) { - fprintf(pfi->msgFile, "\n\n solution matrix in new ordering"); - DenseMtx_writeForHumanEye(mtxX, pfi->msgFile); - fflush(pfi->msgFile); - } - } - - /* - * STEP 10: permute the solution into the original ordering - */ - ssolve_permuteout(mtxX, pfi->newToOldIV, pfi->msgFile); - - /* Cleanup */ - DenseMtx_free(mtxB); - - return mtxX; -} - -#endif - -/** - * factor a system of the form (au - sigma * aub) - * -*/ - -FILE *msgFile; -struct factorinfo pfi; - -void spooles_factor(double *ad, double *au, double *adb, double *aub, - double *sigma,int *icol, int *irow, - int *neq, int *nzs, int *symmetryflag, int *inputformat) -{ - int size = *neq; - InpMtx *mtxA; - - printf(" Factoring the system of equations using spooles\n\n"); - -/* if(*neq==0) return;*/ - - if ((msgFile = fopen("spooles.out", "a")) == NULL) { - fprintf(stderr, "\n fatal error in spooles.c" - "\n unable to open file spooles.out\n"); - } - - /* - * Create the InpMtx object from the Calculix matrix - * representation - */ - - { - int row, ipoint, ipo; - int nent,i,j; - - mtxA = InpMtx_new(); - - if((*inputformat==0)||(*inputformat==3)){ - nent = *nzs + *neq; /* estimated # of nonzero entries */ - }else if(*inputformat==1){ - nent=2**nzs+*neq; - }else if(*inputformat==2){ - nent=0; - for(i=0;i<*neq;i++){ - for(j=0;j<*neq;j++){ - if(fabs(ad[i**nzs+j])>1.e-20) nent++; - } - } - } - - InpMtx_init(mtxA, INPMTX_BY_ROWS, SPOOLES_REAL, nent, size); - - if(*inputformat==0){ - ipoint = 0; - - if(*sigma==0.){ - for (row = 0; row < size; row++) { - InpMtx_inputRealEntry(mtxA, row, row, ad[row]); - for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { - int col = irow[ipo] - 1; - InpMtx_inputRealEntry(mtxA, row, col, - au[ipo]); - } - ipoint = ipoint + icol[row]; - } - } - else{ - for (row = 0; row < size; row++) { - InpMtx_inputRealEntry(mtxA, row, row, ad[row]-*sigma*adb[row]); - for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { - int col = irow[ipo] - 1; - InpMtx_inputRealEntry(mtxA, row, col, - au[ipo]-*sigma*aub[ipo]); - } - ipoint = ipoint + icol[row]; - } - } - }else if(*inputformat==1){ - ipoint = 0; - - if(*sigma==0.){ - for (row = 0; row < size; row++) { - InpMtx_inputRealEntry(mtxA, row, row, ad[row]); - for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { - int col = irow[ipo] - 1; - InpMtx_inputRealEntry(mtxA, row, col, - au[ipo]); - InpMtx_inputRealEntry(mtxA, col,row, - au[ipo+*nzs]); - } - ipoint = ipoint + icol[row]; - } - } - else{ - for (row = 0; row < size; row++) { - InpMtx_inputRealEntry(mtxA, row, row, ad[row]-*sigma*adb[row]); - for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { - int col = irow[ipo] - 1; - InpMtx_inputRealEntry(mtxA, row, col, - au[ipo]-*sigma*aub[ipo]); - InpMtx_inputRealEntry(mtxA, col, row, - au[ipo+*nzs]-*sigma*aub[ipo+*nzs]); - } - ipoint = ipoint + icol[row]; - } - } - }else if(*inputformat==2){ - for(i=0;i<*neq;i++){ - for(j=0;j<*neq;j++){ - if(fabs(ad[i**nzs+j])>1.e-20){ - InpMtx_inputRealEntry(mtxA,j,i, - ad[i**nzs+j]); - } - } - } - }else if(*inputformat==3){ - ipoint = 0; - - if(*sigma==0.){ - for (row = 0; row < size; row++) { - InpMtx_inputRealEntry(mtxA, row, row, ad[row]); - for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { - int col = irow[ipo] - 1; - InpMtx_inputRealEntry(mtxA, col, row, - au[ipo]); - } - ipoint = ipoint + icol[row]; - } - } - else{ - for (row = 0; row < size; row++) { - InpMtx_inputRealEntry(mtxA, row, row, ad[row]-*sigma*adb[row]); - for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { - int col = irow[ipo] - 1; - InpMtx_inputRealEntry(mtxA, col, row, - au[ipo]-*sigma*aub[ipo]); - } - ipoint = ipoint + icol[row]; - } - } - } - - InpMtx_changeStorageMode(mtxA, INPMTX_BY_VECTORS); - - if (DEBUG_LVL > 1) { - fprintf(msgFile, "\n\n input matrix"); - InpMtx_writeForHumanEye(mtxA, msgFile); - fflush(msgFile); - } - } - - /* solve it! */ - - -#ifdef USE_MT - /* Rules for parallel solve: - * - if CCX_NPROC is positive, then use CCX_NPROC cpus, unless - * that exceeds the number of cpus in the system. - * - if CCX_NPROC is -1, then use the number of cpus in the system. - * - otherwise use 1 cpu (default). - */ - if (num_cpus < 0) { - int sys_cpus; - char *env; - - num_cpus = 0; -#ifdef _SC_NPROCESSORS_CONF - sys_cpus = sysconf(_SC_NPROCESSORS_CONF); - if (sys_cpus <= 0) - sys_cpus = 1; -#else - sys_cpus = 1; -#endif - env = getenv("CCX_NPROC"); - if (env) - num_cpus = atoi(env); - if (num_cpus > 0) { -// if (num_cpus > sys_cpus) -// num_cpus = sys_cpus; - } else if (num_cpus == -1) { - num_cpus = sys_cpus; - } else { - num_cpus = 1; - } - printf("Using up to %d cpu(s) for spooles.\n", num_cpus); - } - if (num_cpus > 1) { - /* do not use the multithreaded solver unless - * we have multiple threads - avoid the - * locking overhead - */ - factor_MT(&pfi, mtxA, size, msgFile,symmetryflag); - } else { - factor(&pfi, mtxA, size, msgFile,symmetryflag); - } -#else - factor(&pfi, mtxA, size, msgFile,symmetryflag); -#endif -} - -/** - * solve a system of equations with rhs b - * factorization must have been performed before - * using spooles_factor - * -*/ - -void spooles_solve(double *b, int *neq) -{ - /* rhs vector B - * Note that there is only one rhs vector, thus - * a bit simpler that the AllInOne example - */ - int size = *neq; - DenseMtx *mtxB,*mtxX; - - { - int i; - mtxB = DenseMtx_new(); - DenseMtx_init(mtxB, SPOOLES_REAL, 0, 0, size, 1, 1, size); - DenseMtx_zero(mtxB); - for (i = 0; i < size; i++) { - DenseMtx_setRealEntry(mtxB, i, 0, b[i]); - } - if (DEBUG_LVL > 1) { - fprintf(msgFile, "\n\n rhs matrix in original ordering"); - DenseMtx_writeForHumanEye(mtxB, msgFile); - fflush(msgFile); - } - } - -#ifdef USE_MT - if (num_cpus > 1) { - /* do not use the multithreaded solver unless - * we have multiple threads - avoid the - * locking overhead - */ - mtxX=fsolve_MT(&pfi, mtxB); - } else { - mtxX=fsolve(&pfi, mtxB); - } -#else - mtxX=fsolve(&pfi, mtxB); -#endif - - /* convert the result back to Calculix representation */ - { - int i; - for (i = 0; i < size; i++) { - b[i] = DenseMtx_entries(mtxX)[i]; - } - } - /* cleanup */ - DenseMtx_free(mtxX); -} - -void spooles_cleanup() -{ - - FrontMtx_free(pfi.frontmtx); - IV_free(pfi.newToOldIV); - IV_free(pfi.oldToNewIV); - SubMtxManager_free(pfi.mtxmanager); - if (pfi.solvemap) - SolveMap_free(pfi.solvemap); - ETree_free(pfi.frontETree); - fclose(msgFile); -} - - -/** - * spooles: Main interface between Calculix and spooles: - * - * Perform 3 operations: - * 1) factor - * 2) solve - * 3) cleanup - * - */ - -void spooles(double *ad, double *au, double *adb, double *aub, double *sigma, - double *b, int *icol, int *irow, - int *neq, int *nzs, int *symmetryflag, int *inputformat) -{ - - if(*neq==0) return; - - spooles_factor(ad,au,adb,aub,sigma,icol,irow,neq,nzs,symmetryflag, - inputformat); - - spooles_solve(b,neq); - - spooles_cleanup(); - -} - -#endif diff -Nru calculix-ccx-2.1/ccx_2.1/src/spooles.h calculix-ccx-2.3/ccx_2.1/src/spooles.h --- calculix-ccx-2.1/ccx_2.1/src/spooles.h 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/spooles.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -/* CALCULIX - A 3-dimensional finite element program */ -/* Copyright (C) 1998 Guido Dhondt */ -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation; either version 2 of */ -/* the License, or (at your option) any later version. */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#ifndef __CCX_SPOOLES_H -#define __CCX_SPOOLES_H - -/* - * seperated from CalculiX.h: otherwise everyone would have to include - * the spooles header files - */ -#include -#include -#include -#if USE_MT -#include -#endif - -/* increase this for debugging */ -#define DEBUG_LVL 0 - -struct factorinfo -{ - int size; - double cpus[11]; - IV *newToOldIV, *oldToNewIV; - SolveMap *solvemap; - FrontMtx *frontmtx; - SubMtxManager *mtxmanager; - ETree *frontETree; - int nthread; - FILE *msgFile; - -}; - -void spooles_factor(double *ad, double *au, double *adb, double *aub, - double *sigma, int *icol, int *irow, - int *neq, int *nzs, int *symmetryflag, - int *inputformat); - -void spooles_solve(double *b, int *neq); - -void spooles_cleanup(); - -#endif diff -Nru calculix-ccx-2.1/ccx_2.1/src/springforc.f calculix-ccx-2.3/ccx_2.1/src/springforc.f --- calculix-ccx-2.1/ccx_2.1/src/springforc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/springforc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,228 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine springforc(xl,konl,vl,imat,elcon,nelcon, - & elas,fnl,ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc, - & plicon,nplicon,npmat_,veoldl,senergy,iener,cstr,mi,ifricdamp) -! -! calculates the force of the spring -! - implicit none -! - character*8 lakonl -! - integer konl(9),i,j,imat,ncmat_,ntmat_,nope,nterms,iflag,mi(2), - & kode,niso,id,nplicon(0:ntmat_,*),npmat_,nelcon(2,*),iener, - & ifricdamp -! - real*8 xl(3,9),elas(21),ratio(9),t0l,t1l,vr(3),vl(0:mi(2),9), - & pl(3,9),xn(3),al,area,alpha,beta,fnl(3,9),veoldl(0:mi(2),9), - & elcon(0:ncmat_,ntmat_,*),pproj(3),xsj2(3),xs2(3,7),dist, - & shp2(7,8),xi,et,elconloc(21),plconloc(82),xk,fk,dd, - & xiso(20),yiso(20),dd0,plicon(0:2*npmat_,ntmat_,*),fn, - & damp,c0,eta,um,eps,fnd(3,9),fnv(3,9),ver(3),dvernor, - & dampforc,vertan(3),dvertan,fricforc,pi,senergy,cstr(6) -! - data iflag /2/ -! -! actual positions of the nodes belonging to the contact spring -! - do i=1,nope - do j=1,3 - pl(j,i)=xl(j,i)+vl(j,i) - enddo - enddo -! - if(lakonl(7:7).eq.'A') then - dd0=dsqrt((xl(1,2)-xl(1,1))**2 - & +(xl(2,2)-xl(2,1))**2 - & +(xl(3,2)-xl(3,1))**2) - dd=dsqrt((pl(1,2)-pl(1,1))**2 - & +(pl(2,2)-pl(2,1))**2 - & +(pl(3,2)-pl(3,1))**2) - do i=1,3 - xn(i)=(pl(i,2)-pl(i,1))/dd - enddo - al=dd-dd0 -! -! interpolating the material data -! - call materialdata_sp(elcon,nelcon,imat,ntmat_,i,t0l,t1l, - & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) -! -! calculating the spring force and the spring constant -! - if(kode.eq.2)then - xk=elconloc(1) - fk=xk*al - if(iener.eq.1) then - senergy=fk*al/2.d0 - endif - else - niso=int(plconloc(81)) - do i=1,niso - xiso(i)=plconloc(2*i-1) - yiso(i)=plconloc(2*i) - enddo - call ident(xiso,al,niso,id) - if(id.eq.0) then - xk=0.d0 - fk=yiso(1) - if(iener.eq.1) then - senergy=fk*al; - endif - elseif(id.eq.niso) then - xk=0.d0 - fk=yiso(niso) - if(iener.eq.1) then - senergy=yiso(1)*xiso(1) - do i=2,niso - senergy=senergy+(xiso(i)-xiso(i-1))*(yiso(i)+yiso( - & i-1))/2.d0 - enddo - senergy=senergy+(al-xiso(niso))*yiso(niso) - endif - else - xk=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) - fk=yiso(id)+xk*(al-xiso(id)) - if(iener.eq.1) then - senergy=yiso(1)*xiso(1) - do i=2, id - senergy=senergy+(xiso(i)-xiso(i-1))* - & (yiso(i)+yiso(i-1))/2.d0 - enddo - senergy=senergy+(al-xiso(id))*(fk+yiso(id))/2.d0 - endif - endif - endif -! - do i=1,3 - fnl(i,1)=-fk*xn(i) - fnl(i,2)=fk*xn(i) - enddo - return - endif -! - nterms=nope-1 -! -! vector vr connects the dependent node with its projection -! on the independent face -! - do i=1,3 - pproj(i)=pl(i,nope) - enddo -c write(*,*) 'springforc ',(pproj(i),i=1,3) - call attach(pl,pproj,nterms,ratio,dist,xi,et) - do i=1,3 - vr(i)=pl(i,nope)-pproj(i) - enddo -! -! determining the jacobian vector on the surface -! - if(nterms.eq.8) then - call shape8q(xi,et,pl,xsj2,xs2,shp2,iflag) - elseif(nterms.eq.4) then - call shape4q(xi,et,pl,xsj2,xs2,shp2,iflag) - elseif(nterms.eq.6) then - call shape6tri(xi,et,pl,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,pl,xsj2,xs2,shp2,iflag) - endif -! -! normal on the surface -! - area=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+xsj2(3)*xsj2(3)) - do i=1,3 - xn(i)=xsj2(i)/area - enddo -! -! distance from surface along normal -! - dist=vr(1)*xn(1)+vr(2)*xn(2)+vr(3)*xn(3) - if(dist.le.0.d0) cstr(1)=-dist -! -! representative area -! - if(elcon(1,1,imat).gt.0.d0) then -! -! exponential overclosure -! - if(dabs(elcon(2,1,imat)).lt.1.d-30) then - elas(1)=0.d0 - elas(2)=0.d0 - else - if((nterms.eq.8).or.(nterms.eq.4)) then - area=area*4.d0 -c area=area*4.d0/konl(nope+1) - else - area=area/2.d0 -c area=area/2.d0/konl(nope+1) - endif -! - alpha=elcon(2,1,imat)*area - beta=elcon(1,1,imat) - if(-beta*dist.gt.23.d0-dlog(alpha)) then - beta=(dlog(alpha)-23.d0)/dist - endif - elas(1)=dexp(-beta*dist+dlog(alpha)) - elas(2)=-beta*elas(1) - endif - else -! -! linear overclosure -! - elas(1)=-area*elcon(2,1,imat)*dist - elas(2)=-area*elcon(2,1,imat) - endif -! -! forces in the nodes of the contact element -! - do i=1,3 - do j=1,nterms - fnl(i,j)=ratio(j)*elas(1)*xn(i) - enddo - fnl(i,nope)=-elas(1)*xn(i) - enddo - if(iener.eq.1) then - senergy=elas(1)/beta; - endif -c write(*,*) 'springforc ',konl(nope),dist,(-fnl(i,nope),i=1,3) - cstr(4)=elas(1)/area -c write(*,*) 'springforc ',konl(nope),cstr(4) -! -! contact damping -! - if(ncmat_.ge.5) then - damp=elcon(3,1,imat) - if(damp.gt.0.d0) then - ifricdamp=1 - endif - endif -! -! friction -! - if(ncmat_.ge.7) then - um=elcon(6,1,imat) - if(um.gt.0.d0) then - ifricdamp=1 - endif - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/springs.f calculix-ccx-2.3/ccx_2.1/src/springs.f --- calculix-ccx-2.1/ccx_2.1/src/springs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/springs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,188 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine springs(inpc,textpart,nelcon,nmat,ntmat_,npmat_, - & plicon,nplicon, - & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, - & inl,ipoinp,inp,nmat_,set,istartset,iendset,ialset, - & nset,ielmat,ielorien,ipoinpc) -! -! reading the input deck: *SPRING -! - implicit none -! - logical linear -! - character*1 inpc(*) - character*80 matname(*) - character*81 set(*),elset - character*132 textpart(16) -! - integer nelcon(2,*),nmat,ntmat_,ntmat,npmat_,npmat,istep, - & n,key,i,nplicon(0:ntmat_,*),ncmat_,istat,istartset(*), - & iendset(*),irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),nmat_, - & ialset(*),ipos,nset,j,k,ielmat(*),ielorien(*),ipoinpc(0:*) -! - real*8 plicon(0:2*npmat_,ntmat_,*),temperature, - & elcon(0:ncmat_,ntmat_,*) -! - linear=.true. -! - ntmat=0 - npmat=0 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in springs: *SPRING should be placed' - write(*,*) ' before all step definitions' - stop - endif -! - nmat=nmat+1 - if(nmat.gt.nmat_) then - write(*,*) '*ERROR in materials: increase nmat_' - stop - endif - matname(nmat)(1:6)='SPRING' - do i=7,80 - matname(nmat)(i:i)=' ' - enddo -! - do i=2,n - if(textpart(i)(1:9).eq.'NONLINEAR') then - linear=.false. - elseif(textpart(i)(1:6).eq.'ELSET=') then - elset=textpart(i)(7:86) - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - endif - enddo -! - if(linear) then - nelcon(1,nmat)=2 -! -! linear spring -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - ntmat=ntmat+1 - nelcon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in springs: increase ntmat_' - stop - endif - do i=1,2 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - if(textpart(3)(1:1).ne.' ') then - read(textpart(3)(1:20),'(f20.0)',iostat=istat) - & elcon(0,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - else - elcon(0,ntmat,nmat)=0.d0 - endif - enddo - else - nelcon(1,nmat)=-51 -! -! kinematic hardening coefficients -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - read(textpart(3)(1:20),'(f20.0)',iostat=istat) temperature - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! -! first temperature -! - if(ntmat.eq.0) then - npmat=0 - ntmat=ntmat+1 - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in springs: increase ntmat_' - stop - endif - nplicon(0,nmat)=ntmat - plicon(0,ntmat,nmat)=temperature -! -! new temperature -! - elseif(plicon(0,ntmat,nmat).ne.temperature) then - npmat=0 - ntmat=ntmat+1 - if(ntmat.gt.ntmat_) then - write(*,*) '*ERROR in springs: increase ntmat_' - stop - endif - nplicon(0,nmat)=ntmat - plicon(0,ntmat,nmat)=temperature - endif - do i=1,2 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & plicon(2*npmat+i,ntmat,nmat) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - npmat=npmat+1 - if(npmat.gt.npmat_) then - write(*,*) '*ERROR in springs: increase npmat_' - stop - endif - nplicon(ntmat,nmat)=npmat - enddo - endif -! - if(ntmat.eq.0) then - write(*,*) '*ERROR in springs: *SPRING card without data' - stop - endif - do i=1,nset - if(set(i).eq.elset) exit - enddo - if(i.gt.nset) then - elset(ipos:ipos)=' ' - write(*,*) '*ERROR in springs: element set ',elset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! -! assigning the elements of the set the appropriate material -! - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - ielmat(ialset(j))=nmat - ielorien(ialset(j))=0 - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - ielmat(k)=nmat - ielorien(k)=0 - enddo - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/springstiff.f calculix-ccx-2.3/ccx_2.1/src/springstiff.f --- calculix-ccx-2.1/ccx_2.1/src/springstiff.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/springstiff.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,389 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine springstiff(xl,elas,konl,voldl,s,imat,elcon,nelcon, - & ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc,plicon, - & nplicon,npmat_,iperturb) -! -! calculates the stiffness of a spring -! - implicit none -! - character*8 lakonl -! - integer konl(20),i,j,imat,ncmat_,ntmat_,k,l,nope,nterms,iflag, - & i1,kode,niso,id,nplicon(0:ntmat_,*),npmat_,nelcon(2,*), - & iperturb -! - real*8 xl(3,9),elas(21),ratio(9),q(3),dist,shp2(7,9), - & dc(3),s(60,60),voldl(3,9),pl(3,9),xn(3),al,dd, - & c1,c2,c3,c4,alpha,beta,elcon(0:ncmat_,ntmat_,*),xsj2(3), - & xsju(3,3,9),dxsju(3,9),h(3,9),fpu(3,3,9),xi,et, - & xs2(3,7),t0l,t1l,elconloc(21),plconloc(82),xk,fk, - & xiso(20),yiso(20),dd0,plicon(0:2*npmat_,ntmat_,*), - & a11,a12,a22,b1(3,9),b2(3,9),dal(3,3,9),qxxy(3),fnl(3), - & qxyy(3),dxi(3,9),det(3,9),determinant,c11,c12,c22, - & qxyx(3),qyxy(3) -! - data iflag /4/ -! -! actual positions of the nodes belonging to the contact spring -! - if(iperturb.eq.0) then - do i=1,nope - do j=1,3 - pl(j,i)=xl(j,i) - enddo - enddo - else - do i=1,nope - do j=1,3 - pl(j,i)=xl(j,i)+voldl(j,i) - enddo - enddo - endif -! - if(lakonl(7:7).eq.'A') then - dd0=dsqrt((xl(1,2)-xl(1,1))**2 - & +(xl(2,2)-xl(2,1))**2 - & +(xl(3,2)-xl(3,1))**2) - dd=dsqrt((pl(1,2)-pl(1,1))**2 - & +(pl(2,2)-pl(2,1))**2 - & +(pl(3,2)-pl(3,1))**2) - do i=1,3 - xn(i)=(pl(i,2)-pl(i,1))/dd - enddo - al=dd-dd0 -! -! interpolating the material data -! - call materialdata_sp(elcon,nelcon,imat,ntmat_,i,t0l,t1l, - & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) -! -! calculating the spring force and the spring constant -! - if(kode.eq.2)then - xk=elconloc(1) - fk=xk*al - else - niso=int(plconloc(81)) - do i=1,niso - xiso(i)=plconloc(2*i-1) - yiso(i)=plconloc(2*i) - enddo - call ident(xiso,al,niso,id) - if(id.eq.0) then - xk=0.d0 - fk=yiso(1) - elseif(id.eq.niso) then - xk=0.d0 - fk=yiso(niso) - else - xk=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) - fk=yiso(id)+xk*(al-xiso(id)) - endif - endif -! - c1=fk/dd - c2=xk-c1 - do i=1,3 - do j=1,3 - s(i,j)=c2*xn(i)*xn(j) - enddo - s(i,i)=s(i,i)+c1 - enddo - do i=1,3 - do j=1,3 - s(i+3,j)=-s(i,j) - s(i,j+3)=-s(i,j) - s(i+3,j+3)=s(i,j) - enddo - enddo - return - endif -! -! contact springs -! - nterms=nope-1 -! -! vector dc connects the dependent node with its projection -! on the independent face -! - do i=1,3 - q(i)=pl(i,nope) - enddo - call attach(pl,q,nterms,ratio,dist,xi,et) - do i=1,3 - dc(i)=pl(i,nope)-q(i) - enddo -! -! determining the jacobian vector on the surface -! - if(nterms.eq.8) then - call shape8q(xi,et,pl,xsj2,xs2,shp2,iflag) - elseif(nterms.eq.4) then - call shape4q(xi,et,pl,xsj2,xs2,shp2,iflag) - elseif(nterms.eq.6) then - call shape6tri(xi,et,pl,xsj2,xs2,shp2,iflag) - else - call shape3tri(xi,et,pl,xsj2,xs2,shp2,iflag) - endif -! -! dxi(i,j) is the derivative of xi w.r.t. pl(i,j), -! det(i,j) is the derivative of eta w.r.t. pl(i,j) -! -! dxi and det are determined from the orthogonality -! condition -! - a11=-(xs2(1,1)*xs2(1,1)+xs2(2,1)*xs2(2,1)+xs2(3,1)*xs2(3,1)) - & +dc(1)*xs2(1,5)+dc(2)*xs2(2,5)+dc(3)*xs2(3,5) - a12=-(xs2(1,1)*xs2(1,2)+xs2(2,1)*xs2(2,2)+xs2(3,1)*xs2(3,2)) - & +dc(1)*xs2(1,6)+dc(2)*xs2(2,6)+dc(3)*xs2(3,6) - a22=-(xs2(1,2)*xs2(1,2)+xs2(2,2)*xs2(2,2)+xs2(3,2)*xs2(3,2)) - & +dc(1)*xs2(1,7)+dc(2)*xs2(2,7)+dc(3)*xs2(3,7) -! - do i=1,3 - do j=1,nterms - b1(i,j)=shp2(4,j)*xs2(i,1)-shp2(1,j)*dc(i) - b2(i,j)=shp2(4,j)*xs2(i,2)-shp2(2,j)*dc(i) - enddo - b1(i,nope)=-xs2(i,1) - b2(i,nope)=-xs2(i,2) - enddo -! - determinant=a11*a22-a12*a12 - c11=a22/determinant - c12=-a12/determinant - c22=a11/determinant -! - do i=1,3 - do j=1,nope - dxi(i,j)=c11*b1(i,j)+c12*b2(i,j) - det(i,j)=c12*b1(i,j)+c22*b2(i,j) - enddo - enddo -! -! dal(i,j,k) is the derivative of dc(i) w.r.t pl(j,k) -! - do i=1,nope - do j=1,3 - do k=1,3 - dal(j,k,i)=-xs2(j,1)*dxi(k,i)-xs2(j,2)*det(k,i) - enddo - enddo - enddo - do i=1,nterms - do j=1,3 - dal(j,j,i)=dal(j,j,i)-shp2(4,i) - enddo - enddo - do j=1,3 - dal(j,j,nope)=dal(j,j,nope)+1.d0 - enddo -! -! d2q/dxx x dq/dy -! - qxxy(1)=xs2(2,5)*xs2(3,2)-xs2(3,5)*xs2(2,2) - qxxy(2)=xs2(3,5)*xs2(1,2)-xs2(1,5)*xs2(3,2) - qxxy(3)=xs2(1,5)*xs2(2,2)-xs2(2,5)*xs2(1,2) -! -! dq/dx x d2q/dyy -! - qxyy(1)=xs2(2,1)*xs2(3,7)-xs2(3,1)*xs2(2,7) - qxyy(2)=xs2(3,1)*xs2(1,7)-xs2(1,1)*xs2(3,7) - qxyy(3)=xs2(1,1)*xs2(2,7)-xs2(2,1)*xs2(1,7) -! -! Modified by Stefan Sicklinger -! -! dq/dx x d2q/dxy -! - qxyx(1)=xs2(2,1)*xs2(3,6)-xs2(3,1)*xs2(2,6) - qxyx(2)=xs2(3,1)*xs2(1,6)-xs2(1,1)*xs2(3,6) - qxyx(3)=xs2(1,1)*xs2(2,6)-xs2(2,1)*xs2(1,6) -! -! -! d2q/dxy x dq/dy -! - qyxy(1)=xs2(2,6)*xs2(3,2)-xs2(3,6)*xs2(2,2) - qyxy(2)=xs2(3,6)*xs2(1,2)-xs2(1,6)*xs2(3,2) - qyxy(3)=xs2(1,6)*xs2(2,2)-xs2(2,6)*xs2(1,2) -! -! -! End modifications -! -! normal on the surface -! - dd=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+xsj2(3)*xsj2(3)) - do i=1,3 - xn(i)=xsj2(i)/dd - enddo -! -! distance from surface along normal -! - al=dc(1)*xn(1)+dc(2)*xn(2)+dc(3)*xn(3) -c write(*,*) 'springstiff ',al -! -! alpha and beta, taking the representative area into account -! (conversion of pressure into force) -! - if(elcon(1,1,imat).gt.0.d0) then -! -! exponential overclosure -! - if(dabs(elcon(2,1,imat)).lt.1.d-30) then - elas(1)=0.d0 - elas(2)=0.d0 - else - if((nterms.eq.8).or.(nterms.eq.4)) then - alpha=elcon(2,1,imat)*dd*4.d0 -c alpha=elcon(2,1,imat)*dd*4.d0/konl(nope+1) - else - alpha=elcon(2,1,imat)*dd/2.d0 -c alpha=elcon(2,1,imat)*dd/2.d0/konl(nope+1) - endif - beta=elcon(1,1,imat) - if(-beta*al.gt.23.d0-dlog(alpha)) then - beta=(dlog(alpha)-23.d0)/al - endif - elas(1)=dexp(-beta*al+dlog(alpha)) - elas(2)=-beta*elas(1) - endif - else -! -! linear overclosure -! - elas(1)=-dd*elcon(2,1,imat)*dist - elas(2)=-dd*elcon(2,1,imat) - endif -! -! contact force -! - do i=1,3 - fnl(i)=-elas(1)*xn(i) - enddo -! -! derivatives of the jacobian vector w.r.t. the displacement -! vectors -! - do k=1,nterms - xsju(1,1,k)=0.d0 - xsju(2,2,k)=0.d0 - xsju(3,3,k)=0.d0 - xsju(1,2,k)=shp2(1,k)*xs2(3,2)-shp2(2,k)*xs2(3,1) - xsju(2,3,k)=shp2(1,k)*xs2(1,2)-shp2(2,k)*xs2(1,1) - xsju(3,1,k)=shp2(1,k)*xs2(2,2)-shp2(2,k)*xs2(2,1) - xsju(1,3,k)=-xsju(3,1,k) - xsju(2,1,k)=-xsju(1,2,k) - xsju(3,2,k)=-xsju(2,3,k) - enddo - do i=1,3 - do j=1,3 - xsju(i,j,nope)=0.d0 - enddo - enddo -! -! correction due to change of xi and eta -! - do k=1,nope - do i=1,3 - do j=1,3 -! -! modified by Stefan Sicklinger -! - xsju(i,j,k)=xsju(i,j,k)+(qxxy(i)+qxyx(i))*dxi(j,k) - & +(qxyy(i)+qyxy(i))*det(j,k) -c xsju(i,j,k)=xsju(i,j,k)+qxxy(i)*dxi(j,k) -c & +qxyy(i)*det(j,k) - enddo - enddo - enddo -! -! derivatives of the size of the jacobian vector w.r.t. the -! displacement vectors -! - do k=1,nope - do i=1,3 - dxsju(i,k)=xn(1)*xsju(1,i,k)+xn(2)*xsju(2,i,k)+ - & xn(3)*xsju(3,i,k) - enddo -! -! auxiliary variables -! - do i=1,3 - h(i,k)=dc(1)*xsju(1,i,k)+dc(2)*xsju(2,i,k)+ - & dc(3)*xsju(3,i,k)-al*dxsju(i,k) - enddo -! - enddo -! - c1=1.d0/dd - c2=c1*c1 - c3=elas(2)*c2 - c4=elas(1)*c1 -! -! derivatives of the forces w.r.t. the displacement vectors -! - do k=1,nope - do i=1,3 - do j=1,3 - fpu(i,j,k)=-c3*xsj2(i)*(h(j,k) - & +(xsj2(1)*dal(1,j,k)+xsj2(2)*dal(2,j,k)+xsj2(3)*dal(3,j,k))) - & +c4*(xn(i)*dxsju(j,k)-xsju(i,j,k)) - enddo - enddo - enddo -! -! determining the stiffness matrix contributions -! -c do k=1,nterms -c ratio(k)=-ratio(k) -c enddo -c ratio(nope)=1.d0 -! -! complete field shp2 -! - shp2(1,nope)=0.d0 - shp2(2,nope)=0.d0 - shp2(4,nope)=-1.d0 -! - do k=1,nope - do l=1,nope - do i=1,3 - i1=i+(k-1)*3 - do j=1,3 -c s(i1,j+(l-1)*3)=ratio(k)*fpu(i,j,l) - s(i1,j+(l-1)*3)=-shp2(4,k)*fpu(i,j,l) - & -shp2(1,k)*fnl(i)*dxi(j,l) - & -shp2(2,k)*fnl(i)*det(j,l) - enddo - enddo - enddo - enddo -! -! symmetrizing the matrix -! - do j=1,3*nope - do i=1,j-1 - s(i,j)=(s(i,j)+s(j,i))/2.d0 -c write(*,*) 'springstiff stiffness ',i,j,s(i,j) - enddo - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/statics.f calculix-ccx-2.3/ccx_2.1/src/statics.f --- calculix-ccx-2.1/ccx_2.1/src/statics.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/statics.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,215 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine statics(inpc,textpart,nmethod,iperturb,isolver,istep, - & istat,n,tinc,tper,tmin,tmax,idrct,iline,ipol,inl,ipoinp,inp, - & ithermal,cs,ics,tieset,istartset, - & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc, - & ilmpc,mpcfree,mcs,set,nset,labmpc,ipoinpc,iexpl,cfd,ttime, - & iaxial) -! -! reading the input deck: *STATIC -! -! isolver=0: SPOOLES -! 2: iterative solver with diagonal scaling -! 3: iterative solver with Cholesky preconditioning -! 4: sgi solver -! 5: TAUCS -! 7: pardiso -! -! iexpl==0: structure:implicit, fluid:semi-implicit -! iexpl==1: structure:implicit, fluid:explicit -! - implicit none -! - logical timereset -! - character*1 inpc(*) - character*20 labmpc(*),solver - character*81 set(*),tieset(3,*) - character*132 textpart(16) -! - integer nmethod,iperturb,isolver,istep,istat,n,key,i,idrct, - & iline,ipol,inl,ipoinp(2,*),inp(3,*),ithermal,ics(*),iexpl, - & istartset(*),iendset(*),ialset(*),ipompc(*),nodempc(3,*), - & nmpc,nmpc_,ikmpc(*),ilmpc(*),mpcfree,nset,mcs,ipoinpc(0:*), - & cfd,iaxial -! - real*8 tinc,tper,tmin,tmax,cs(17,*),coefmpc(*),ttime -! - idrct=0 - tmin=0.d0 - tmax=0.d0 - timereset=.false. -! - if((iperturb.eq.1).and.(istep.ge.1)) then - write(*,*) '*ERROR in statics: perturbation analysis is' - write(*,*) ' not provided in a *STATIC step. Perform' - write(*,*) ' a genuine nonlinear geometric calculation' - write(*,*) ' instead (parameter NLGEOM)' - stop - endif -! - if(istep.lt.1) then - write(*,*) '*ERROR in statics: *STATIC can only be used' - write(*,*) ' within a STEP' - stop - endif -! -! no heat transfer analysis -! - if(ithermal.gt.1) then - ithermal=1 - endif -! -! default solver -! - if(isolver.eq.0) then - solver(1:7)='SPOOLES' - elseif(isolver.eq.2) then - solver(1:16)='ITERATIVESCALING' - elseif(isolver.eq.3) then - solver(1:17)='ITERATIVECHOLESKY' - elseif(isolver.eq.4) then - solver(1:3)='SGI' - elseif(isolver.eq.5) then - solver(1:5)='TAUCS' - elseif(isolver.eq.7) then - solver(1:7)='PARDISO' - endif -! - do i=2,n - if(textpart(i)(1:7).eq.'SOLVER=') then - read(textpart(i)(8:27),'(a20)') solver - elseif(textpart(i)(1:8).eq.'EXPLICIT') then - iexpl=1 - elseif((textpart(i)(1:6).eq.'DIRECT').and. - & (textpart(i)(1:9).ne.'DIRECT=NO')) then - idrct=1 - elseif(textpart(i)(1:9).eq.'TIMERESET') then - timereset=.true. - endif - enddo -! - if(solver(1:7).eq.'SPOOLES') then - isolver=0 - elseif(solver(1:16).eq.'ITERATIVESCALING') then - isolver=2 - elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then - isolver=3 - elseif(solver(1:3).eq.'SGI') then - isolver=4 - elseif(solver(1:5).eq.'TAUCS') then - isolver=5 - elseif(solver(1:7).eq.'PARDISO') then - isolver=7 - else - write(*,*) '*WARNING in statics: unknown solver;' - write(*,*) ' the default solver is used' - endif -! - nmethod=1 -! -! check for nodes on a cyclic symmetry axis -! - if((mcs.eq.0).or.(iaxial.ne.0)) then - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - else - n=3 - textpart(2)='NMIN=0 - & - & ' - textpart(3)='NMAX=0 - & - & ' - nmethod=2 - call selcycsymmods(inpc,textpart,cs,ics,tieset,istartset, - & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc, - & ilmpc,mpcfree,mcs,set,nset,labmpc,istep,istat,n,iline, - & ipol,inl,ipoinp,inp,nmethod,key,ipoinpc) - nmethod=1 - do i=1,mcs - cs(2,i)=-0.5 - cs(3,i)=-0.5 - enddo - endif -! - if((istat.lt.0).or.(key.eq.1)) then - if((iperturb.ge.2).or.(cfd.eq.1)) then - write(*,*) '*WARNING in statics: a nonlinear geometric analy - &sis is requested' - write(*,*) ' but no time increment nor step is speci - &fied' - write(*,*) ' the defaults (1,1) are used' - tinc=1.d0 - tper=1.d0 - tmin=1.d-5 - tmax=1.d+30 - else - tper=1.d0 - endif - if(timereset)ttime=ttime-tper - return - endif -! - read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) tmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(4)(1:20),'(f20.0)',iostat=istat) tmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! - if(tper.lt.0.d0) then - write(*,*) '*ERROR in statics: step size is negative' - stop - elseif(tper.le.0.d0) then - tper=1.d0 - endif - if(tinc.lt.0.d0) then - write(*,*) '*ERROR in statics: initial increment size is negati - &ve' - stop - elseif(tinc.le.0.d0) then - tinc=tper - endif - if(tinc.gt.tper) then - write(*,*) '*ERROR in statics: initial increment size exceeds s - &tep size' - stop - endif -! - if(idrct.ne.1) then - if(dabs(tmin).lt.1.d-10) then - tmin=min(tinc,1.d-5*tper) - endif - if(dabs(tmax).lt.1.d-10) then - tmax=1.d+30 - endif - endif -! - if(timereset)ttime=ttime-tper -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/steadystate.c calculix-ccx-2.3/ccx_2.1/src/steadystate.c --- calculix-ccx-2.1/ccx_2.1/src/steadystate.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/steadystate.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,1953 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif -#ifdef PARDISO - #include "pardiso.h" -#endif - -void steadystate(double **cop, int *nk, int **konp, int **ipkonp, char **lakonp, int *ne, - int **nodebounp, int **ndirbounp, double **xbounp, int *nboun, - int **ipompcp, int **nodempcp, double **coefmpcp, char **labmpcp, - int *nmpc, int *nodeforc,int *ndirforc,double *xforc, - int *nforc,int *nelemload, char *sideload,double *xload, - int *nload, - int **nactdofp,int *neq, int *nzl,int *icol, int *irow, - int *nmethod, int **ikmpcp, int **ilmpcp, int **ikbounp, - int **ilbounp,double *elcon, int *nelcon, double *rhcon, - int *nrhcon,double *cocon, int *ncocon, - double *alcon, int *nalcon, double *alzero, - int **ielmatp,int **ielorienp, int *norien, double *orab, - int *ntmat_,double **t0p, - double **t1p,int *ithermal,double *prestr, int *iprestr, - double **voldp,int *iperturb, double *sti, int *nzs, - double *tinc, double *tper, double *xmodal, - double *veold, char *amname, double *amta, - int *namta, int *nam, int *iamforc, int *iamload, - int **iamt1p,int *jout, - int *kode, char *filab,double **emep, double *xforcold, - double *xloadold, - double **t1oldp, int **iambounp, double **xbounoldp, int *iexpl, - double *plicon, int *nplicon, double *plkcon,int *nplkcon, - double *xstate, int *npmat_, char *matname, int *mi, - int *ncmat_, int *nstate_, double **enerp, char *jobnamec, - double *ttime, char *set, int *nset, int *istartset, - int *iendset, int *ialset, int *nprint, char *prlab, - char *prset, int *nener, double *trab, - int **inotrp, int *ntrans, double **fmpcp, char *cbody, int *ibody, - double *xbody, int *nbody, double *xbodyold, int *istep, - int *isolver, int *jq, char *output, int *mcs,int *nkon, - int *ics, double *cs, int *mpcend, int **nnnp){ - - char fneig[132]="",description[13]=" ",*lakon=NULL,*labmpc=NULL, - *labmpcold=NULL; - - int nev,i,j,k, *inum=NULL,*ipobody=NULL,inewton=0,nsectors, - iinc=0,l,iout,ielas,icmd,iprescribedboundary,ndata,nmd,nevd, - ndatatot,*iphaseforc=NULL,*iphaseload=NULL,*iphaseboun=NULL, - *isave=NULL,nfour,ii,ir,ic,mode,noddiam=-1,*nm=NULL, - *kon=NULL,*ipkon=NULL,*ielmat=NULL,*ielorien=NULL,*inotr=NULL, - *nodeboun=NULL,*ndirboun=NULL,*iamboun=NULL,*ikboun=NULL, - *ilboun=NULL,*nactdof=NULL,*ipompc=NULL,*nodempc=NULL,*ikmpc=NULL, - *ilmpc=NULL,*ipompcold=NULL,*nodempcold=NULL,*ikmpcold=NULL, - *ilmpcold=NULL,nmpcold,mpcendold,kflag=2,*iamt1=NULL,ifreebody, - *itg=NULL,ntg=0,symmetryflag=0,inputformat=0,dashpot,nrhs=1, - *ipiv=NULL,info,nev2,ngraph,nkg,neg,iflag=1,idummy=1,imax, - nzse[3],*nnn=*nnnp,mt=mi[1]+1,*ikactmech=NULL,nactmech; - - double *d=NULL, *z=NULL,*stiini=NULL,*vini=NULL,*freqnh=NULL, - *xforcact=NULL, *xloadact=NULL,y,*fr=NULL,*fi=NULL,*cc=NULL, - *t1act=NULL, *ampli=NULL, *aa=NULL, *bb=NULL, *vr=NULL,*vi=NULL, - *stn=NULL, *stx=NULL, *een=NULL, *adb=NULL,*xstiff=NULL, - *aub=NULL, *aux=NULL, *bjr=NULL, *bji=NULL,*xbodyr=NULL, - *f=NULL, *fn=NULL, *xbounact=NULL,*epn=NULL,*xstateini=NULL, - *enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL,*qfn=NULL, - *qfx=NULL, *xbodyact=NULL, *cgr=NULL, *au=NULL,*xbodyi=NULL, - time,dtime,reltime,*co=NULL,*xboun=NULL,*xbounold=NULL, - physcon[1],qa[3],cam[5],accold[1],bet,gam,*ad=NULL,sigma=0.,alpham,betam, - fmin,fmax,bias,*freq=NULL,*xforcr=NULL,dd,pi,vreal,constant, - *xforci=NULL,*xloadr=NULL,*xloadi=NULL,*xbounr=NULL,*xbouni=NULL, - *br=NULL,*bi=NULL,*ubr=NULL,*ubi=NULL,*mubr=NULL,*mubi=NULL, - *wsave=NULL,*r=NULL,*xbounacttime=NULL,*btot=NULL,breal,tmin,tmax, - *vold=NULL,*eme=NULL,*ener=NULL,*coefmpc=NULL,*fmpc=NULL, - *coefmpcold=NULL,*t0=NULL,*t1=NULL,*t1old=NULL,*adc=NULL,*auc=NULL, - *am=NULL,*bm=NULL,*zc=NULL,*e=NULL,*stnr=NULL,*stni=NULL, - *vmax=NULL,*stnmax=NULL,*va=NULL,*vp=NULL,*fric=NULL; - - /* dummy arguments for the call of expand*/ - - char* tieset=NULL; - int *jqe=NULL,*icole=NULL,*irowe=NULL,ntie=0; - double *adbe=NULL,*aube=NULL; - - FILE *f1; - - int *ipneigh=NULL,*neigh=NULL; - -#ifdef SGI - int token; -#endif - - co=*cop;kon=*konp;ipkon=*ipkonp;lakon=*lakonp;ielmat=*ielmatp; - ielorien=*ielorienp;inotr=*inotrp;nodeboun=*nodebounp; - ndirboun=*ndirbounp;iamboun=*iambounp;xboun=*xbounp; - xbounold=*xbounoldp;ikboun=*ikbounp;ilboun=*ilbounp;nactdof=*nactdofp; - vold=*voldp;eme=*emep;ener=*enerp;ipompc=*ipompcp;nodempc=*nodempcp; - coefmpc=*coefmpcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; - fmpc=*fmpcp;iamt1=*iamt1p;t0=*t0p;t1=*t1p;t1old=*t1oldp; - - xstiff=NNEW(double,27*mi[0]**ne); - - pi=4.*atan(1.); - iout=1; - - alpham=xmodal[0]; - betam=xmodal[1]; - fmin=2.*pi*xmodal[2]; - fmax=2.*pi*xmodal[3]; - ndata=floor(xmodal[4]); - bias=xmodal[5]; - nfour=floor(xmodal[6]); - if(nfour>0){ - tmin=xmodal[7]; - tmax=xmodal[8]; - } - - /* determining nzl */ - - *nzl=0; - for(i=neq[1];i>0;i--){ - if(icol[i-1]>0){ - *nzl=i; - break; - } - } - - strcpy(fneig,jobnamec); - strcat(fneig,".eig"); - - if((f1=fopen(fneig,"rb"))==NULL){ - printf("*ERROR: cannot open eigenvalue file for reading..."); - exit(0); - } - - nsectors=1; - - if(*mcs==0){ - - nkg=*nk; - neg=*ne; - - if(fread(&nev,sizeof(int),1,f1)!=1){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - d=NNEW(double,nev); - - if(fread(d,sizeof(double),nev,f1)!=nev){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - ad=NNEW(double,neq[1]); - adb=NNEW(double,neq[1]); - au=NNEW(double,nzs[2]); - aub=NNEW(double,nzs[1]); - - if(fread(ad,sizeof(double),neq[1],f1)!=neq[1]){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - if(fread(au,sizeof(double),nzs[2],f1)!=nzs[2]){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - if(fread(adb,sizeof(double),neq[1],f1)!=neq[1]){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - if(fread(aub,sizeof(double),nzs[1],f1)!=nzs[1]){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - - z=NNEW(double,neq[1]*nev); - - if(fread(z,sizeof(double),neq[1]*nev,f1)!=neq[1]*nev){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - } - else{ - nev=0; - do{ - if(fread(&nmd,sizeof(int),1,f1)!=1){ - break; - } - if(fread(&nevd,sizeof(int),1,f1)!=1){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - if(nev==0){ - d=NNEW(double,nevd); - nm=NNEW(int,nevd); - }else{ - RENEW(d,double,nev+nevd); - RENEW(nm,int,nev+nevd); - } - - if(fread(&d[nev],sizeof(double),nevd,f1)!=nevd){ - printf("*ERROR reading the eigenvalue file..."); - exit(0); - } - for(i=nev;insectors) nsectors=(int)(cs[17*i]+0.5); - } - - /* determining the maximum number of sectors to be plotted */ - - ngraph=1; - for(j=0;j<*mcs;j++){ - if(cs[17*j+4]>ngraph) ngraph=(int)(cs[17*j+4]+0.5); - } - nkg=*nk*ngraph; - neg=*ne*ngraph; - - /* allocating field for the expanded structure */ - - RENEW(co,double,3**nk*nsectors); - for(i=3**nk;i<3**nk*nsectors;i++){co[i]=0.;} - if(*ithermal!=0){ - RENEW(t0,double,*nk*nsectors); - RENEW(t1old,double,*nk*nsectors); - RENEW(t1,double,*nk*nsectors); - if(*nam>0) RENEW(iamt1,int,*nk*nsectors); - } - RENEW(nactdof,int,mt**nk*nsectors); - if(*ntrans>0) RENEW(inotr,int,2**nk*nsectors); - RENEW(kon,int,*nkon*nsectors); - RENEW(ipkon,int,*ne*nsectors); - for(i=*ne;i<*ne*nsectors;i++){ipkon[i]=-1;} - RENEW(lakon,char,8**ne*nsectors); - RENEW(ielmat,int,*ne*nsectors); - if(*norien>0) RENEW(ielorien,int,*ne*nsectors); - RENEW(z,double,neq[1]*nev*nsectors/2); - - RENEW(nodeboun,int,*nboun*nsectors); - RENEW(ndirboun,int,*nboun*nsectors); - if(*nam>0) RENEW(iamboun,int,*nboun*nsectors); - RENEW(xboun,double,*nboun*nsectors); - RENEW(xbounold,double,*nboun*nsectors); - RENEW(ikboun,int,*nboun*nsectors); - RENEW(ilboun,int,*nboun*nsectors); - - ipompcold=NNEW(int,*nmpc); - nodempcold=NNEW(int,3**mpcend); - coefmpcold=NNEW(double,*mpcend); - labmpcold=NNEW(char,20**nmpc); - ikmpcold=NNEW(int,*nmpc); - ilmpcold=NNEW(int,*nmpc); - - for(i=0;i<*nmpc;i++){ipompcold[i]=ipompc[i];} - for(i=0;i<3**mpcend;i++){nodempcold[i]=nodempc[i];} - for(i=0;i<*mpcend;i++){coefmpcold[i]=coefmpc[i];} - for(i=0;i<20**nmpc;i++){labmpcold[i]=labmpc[i];} - for(i=0;i<*nmpc;i++){ikmpcold[i]=ikmpc[i];} - for(i=0;i<*nmpc;i++){ilmpcold[i]=ilmpc[i];} - nmpcold=*nmpc; - mpcendold=*mpcend; - - RENEW(ipompc,int,*nmpc*nsectors); - RENEW(nodempc,int,3**mpcend*nsectors); - RENEW(coefmpc,double,*mpcend*nsectors); - RENEW(labmpc,char,20**nmpc*nsectors+1); - RENEW(ikmpc,int,*nmpc*nsectors); - RENEW(ilmpc,int,*nmpc*nsectors); - RENEW(fmpc,double,*nmpc*nsectors); - - expand(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, - ipompc,nodempc,coefmpc,labmpc,nmpc,nodeforc,ndirforc,xforc, - nforc,nelemload,sideload,xload,nload,nactdof,neq, - nmethod,ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, - alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, - t0,ithermal,prestr,iprestr,vold,iperturb,sti,nzs, - adb,aub,filab,eme,plicon,nplicon,plkcon,nplkcon, - xstate,npmat_,matname,mi,ics,cs,mpcend,ncmat_, - nstate_,mcs,nkon,ener,jobnamec,output,set,nset,istartset, - iendset,ialset,nprint,prlab,prset,nener,trab, - inotr,ntrans,ttime,fmpc,&nev,z,iamboun,xbounold, - &nsectors,nm,icol,irow,nzl,nam,ipompcold,nodempcold,coefmpcold, - labmpcold,&nmpcold,xloadold,iamload,t1old,t1,iamt1,xstiff,&icole,&jqe, - &irowe,isolver,nzse,&adbe,&aube,iexpl, - ibody,xbody,nbody,cocon,ncocon,tieset,&ntie,&nnn); - - free(vold);vold=NNEW(double,mt**nk); - RENEW(eme,double,6*mi[0]**ne); - RENEW(xstiff,double,27*mi[0]**ne); - if(*nener==1) RENEW(ener,double,mi[0]**ne); - } - - fclose(f1); - - fric=NNEW(double,nev); - - /* check whether there are dashpot elements */ - - dashpot=0; - for(i=0;i<*ne;i++){ - if(ipkon[i]==-1) continue; - if(strcmp1(&lakon[i*8],"ED")==0){ - dashpot=1;break;} - } - if(dashpot){ - - if(*mcs!=0){ - printf("*ERROR in steadystate: dashpots are not allowed in combination with cyclic symmetry\n"); - FORTRAN(stop,()); - } - /* adc=NNEW(double,neq[1]); - auc=NNEW(double,nzs[1]); - FORTRAN(mafilldm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, - ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, - nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, - adc,auc,nactdof,icol,jq,irow,neq,nzl,nmethod, - ikmpc,ilmpc,ikboun,ilboun, - elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, - ielorien,norien,orab,ntmat_, - t0,t0,ithermal,prestr,iprestr,vold,iperturb,sti, - nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, - xstiff,npmat_,&dtime,matname,mi,ncmat_, - ttime,&time,istep,&iinc,ibody));*/ - - /* zc = damping matrix * eigenmodes */ - - /* zc=NNEW(double,neq[1]*nev); - for(i=0;i=fmin){ - if(e[i]<=fmax){ - for(j=1;j1.e-10){ - iprescribedboundary=1; - break; - } - } - - if((iprescribedboundary)&&(*mcs!=0)){ - printf("*ERROR in steadystate: prescribed boundaries are not allowed in combination with cyclic symmetry\n"); - FORTRAN(stop,()); - } - - /* calculating the damping coefficients = friction coefficient*2*eigenvalue */ - - if(xmodal[10]<0){ - for(i=0;i(1.e-10)){ - fric[i]=(alpham+betam*d[i]*d[i]); - } - else { - printf("*WARNING in dyna: one of the frequencies is zero\n"); - printf(" no Rayleigh mass damping allowed\n"); - fric[i]=0.; - } - } - } - else{ - if(iprescribedboundary){ - printf("*ERROR in steadystate: prescribed boundaries are not allowed in combination with direct modal damping\n"); - FORTRAN(stop,()); - } - - /*copy the damping coefficients for every eigenfrequencie from xmodal[11....] */ - if(nev<(int)xmodal[10]){ - imax=nev; - printf("*WARNING in dyna: too many modal damping coefficients applied\n"); - printf(" damping coefficients corresponding to nonexisting eigenvalues are ignored\n"); - } - else{ - imax=(int)xmodal[10]; - } - for(i=0; i=nsectors){ - iphaseforc[i]=1; - } - } - - iphaseload=NNEW(int,*nload); - for (i=0;i<*nload;i++){ - if(nelemload[2*i+1]>=nsectors){ - iphaseload[i]=1; - } - } - - if(iprescribedboundary){ - iphaseboun=NNEW(int,*nboun); - for (i=0;i<*nboun;i++){ - if(nodeboun[i]>*nk){ - iphaseboun[i]=1; - nodeboun[i]=nodeboun[i]-*nk; - } - } - } - - /* allocating actual loading fields */ - - xforcact=NNEW(double,*nforc); - xforcr=NNEW(double,*nforc); - xforci=NNEW(double,*nforc); - - xloadact=NNEW(double,2**nload); - xloadr=NNEW(double,2**nload); - xloadi=NNEW(double,2**nload); - - xbodyact=NNEW(double,7**nbody); - xbodyr=NNEW(double,7**nbody); - xbodyi=NNEW(double,7**nbody); - /* copying the rotation axis and/or acceleration vector */ - for(k=0;k<7**nbody;k++){xbodyact[k]=xbody[k];} - - xbounact=NNEW(double,*nboun); - - if(*ithermal==1) t1act=NNEW(double,*nk); - - /* assigning the body forces to the elements */ - - if(*nbody>0){ - ifreebody=*ne+1; - ipobody=NNEW(int,2*ifreebody**nbody); - for(k=1;k<=*nbody;k++){ - FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, - iendset,ialset,&inewton,nset,&ifreebody,&k)); - RENEW(ipobody,int,2*(*ne+ifreebody)); - } - RENEW(ipobody,int,2*(ifreebody-1)); - } - - br=NNEW(double,neq[1]); /* load rhs vector */ - bi=NNEW(double,neq[1]); /* load rhs vector */ - - if(iprescribedboundary){ - xbounr=NNEW(double,*nboun); - xbouni=NNEW(double,*nboun); - - fr=NNEW(double,neq[1]); /* force corresponding to real particular solution */ - fi=NNEW(double,neq[1]); /* force corresponding to imaginary particular solution */ - - ubr=NNEW(double,neq[1]); /* real particular solution */ - ubi=NNEW(double,neq[1]); /* imaginary particular solution */ - - mubr=NNEW(double,neq[1]); /* mass times real particular solution */ - mubi=NNEW(double,neq[1]); /* mass times imaginary particular solution */ - } - - bjr=NNEW(double,nev); /* real response modal decomposition */ - bji=NNEW(double,nev); /* imaginary response modal decomposition */ - - ampli=NNEW(double,*nam); /* instantaneous amplitude */ - - aa=NNEW(double,nev); /* modal coefficients of the real loading */ - bb=NNEW(double,nev); /* modal coefficients of the imaginary loading */ - - /* result fields */ - - vr=NNEW(double,mt**nk); - vi=NNEW(double,mt**nk); - fn=NNEW(double,mt**nk); - stn=NNEW(double,6**nk); - inum=NNEW(int,*nk); - stx=NNEW(double,6*mi[0]**ne); - if(*ithermal>1) {qfn=NNEW(double,3**nk);qfx=NNEW(double,3*mi[0]**ne);} - - if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); - if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); - - eei=NNEW(double,6*mi[0]**ne); - if(*nener==1){ - stiini=NNEW(double,6*mi[0]**ne); - enerini=NNEW(double,mi[0]**ne);} - - if(iprescribedboundary){ - - /* LU decomposition of the stiffness matrix */ - - if(*isolver==0){ -#ifdef SPOOLES - spooles_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1], - &symmetryflag,&inputformat); -#else - printf("*ERROR in steadystate: the SPOOLES library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==4){ -#ifdef SGI - token=1; - sgi_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1],token); -#else - printf("*ERROR in steadystate: the SGI library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau_factor(ad,&au,adb,aub,&sigma,icol,&irow,&neq[1],&nzs[1]); -#else - printf("*ERROR in steadystate: the TAUCS library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1]); -#else - printf("*ERROR in steadystate: the PARDISO library is not linked\n\n"); - FORTRAN(stop,()); -#endif - } - } - - for(l=0;l0.){vp[mt*i+j]=90.;} - else{vp[mt*i+j]=-90.;} - } - else{ - vp[mt*i+j]=atan(vi[mt*i+j]/vreal)*constant; - if(vreal<0.) vp[mt*i+j]+=180.; - } - } - } - } - else{ - for(i=0;i<*nk;i++){ - vreal=vr[mt*i]; - va[mt*i]=sqrt(vr[mt*i]*vr[mt*i]+vi[mt*i]*vi[mt*i]); - if(fabs(vreal)<1.e-10){ - if(vi[mt*i]>0){vp[mt*i]=90.;} - else{vp[mt*i]=-90.;} - } - else{ - vp[mt*i]=atan(vi[mt*i]/vreal)*constant; - if(vreal<0.) vp[mt*i]+=180.; - } - } - } - } - - (*kode)++; - mode=0; - - if(strcmp1(&filab[1044],"ZZS")==0){ - neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); - } - FORTRAN(out,(co,&nkg,kon,ipkon,lakon,&neg,vi,stn,inum,nmethod, - kode,filab, - een,t1,fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_,istep, - &iinc, - iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, - trab,inotr,ntrans,orab,ielorien,norien,description, - ipneigh,neigh,stx,va,vp,stnr,stni,vmax,stnmax,&ngraph,veold, - &neg,cs,set,nset,istartset,iendset,ialset)); - if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} - - free(va);free(vp); - - } - - /* restoring the imaginary loading */ - - free(iphaseforc);free(xforcr);free(xforci); - - free(iphaseload);free(xloadr);free(xloadi); - - free(xbodyr);free(xbodyi); - - if(iprescribedboundary){ - for (i=0;i<*nboun;i++){ - if(iphaseboun[i]==1){ - nodeboun[i]=nodeboun[i]+*nk; - } - } - free(iphaseboun); - } - - /* freeing the result fields */ - - free(eei); - if(*nener==1){free(stiini);free(enerini);} - - if(strcmp1(&filab[261],"E ")==0) free(een); - if(strcmp1(&filab[522],"ENER")==0) free(enern); - if(*ithermal>1) {free(qfn);free(qfx);} - - /* updating the loading at the end of the step; - important in case the amplitude at the end of the step - is not equal to one */ - - for(k=0;k<*nboun;++k){xboun[k]=xbounact[k];} - for(k=0;k<*nforc;++k){xforc[k]=xforcact[k];} - for(k=0;k<2**nload;++k){xload[k]=xloadact[k];} - for(k=0;k<7**nbody;k=k+7){xbody[k]=xbodyact[k];} - if(*ithermal==1){ - for(k=0;k<*nk;++k){t1[k]=t1act[k];} - } - - free(fn);free(stn);free(inum);free(stx); - free(br);free(bi);free(bjr);free(bji),free(freq); - free(xforcact);free(xloadact);free(xbounact);free(aa);free(bb); - free(ampli);free(xbodyact);free(vr);free(vi);if(*nbody>0) free(ipobody); - - if(*ithermal==1) free(t1act); - - if(iprescribedboundary){ - if(*isolver==0){ -#ifdef SPOOLES - spooles_cleanup(); -#endif - } - else if(*isolver==4){ -#ifdef SGI - sgi_cleanup(token); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau_cleanup(); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_cleanup(&neq[1]); -#endif - } - free(xbounr);free(xbouni);free(fr);free(fi);free(ubr);free(ubi); - free(mubr);free(mubi); - } - } - - else{ - - /* steady state response to a nonharmonic periodic loading */ - - xforcact=NNEW(double,nfour**nforc); - xloadact=NNEW(double,nfour*2**nload); - xbodyact=NNEW(double,nfour*7**nbody); - xbounact=NNEW(double,nfour**nboun); - xbounacttime=NNEW(double,nfour**nboun); - if(*ithermal==1) t1act=NNEW(double,*nk); - - r=NNEW(double,nfour); - wsave=NNEW(double,2*nfour); - isave=NNEW(int,15); - - /* check for nonzero SPC's */ - - iprescribedboundary=0; - for(i=0;i<*nboun;i++){ - if(fabs(xboun[i])>1.e-10){ - iprescribedboundary=1; - break; - } - } - - if((iprescribedboundary)&&(*mcs!=0)){ - printf("*ERROR in steadystate: prescribed boundaries are not allowed in combination with cyclic symmetry\n"); - FORTRAN(stop,()); - } - - /* calculating the damping coefficients = friction coefficient*2*eigenvalue */ - - if(xmodal[10]<0){ - for(i=0;i(1.e-10)){ - fric[i]=(alpham+betam*d[i]*d[i]); - } - else { - printf("*WARNING in dyna: one of the frequencies is zero\n"); - printf(" no Rayleigh mass damping allowed\n"); - fric[i]=0.; - } - } - } - else{ - if(iprescribedboundary){ - printf("*ERROR in steadystate: prescribed boundaries are not allowed in combination with direct modal damping\n"); - FORTRAN(stop,()); - } - - /*copy the damping coefficients for every eigenfrequencie from xmodal[11....] */ - if(nev<(int)xmodal[10]){ - imax=nev; - printf("*WARNING in dyna: too many modal damping coefficients applied\n"); - printf(" damping coefficients corresponding to nonexisting eigenvalues are ignored\n"); - } - else{ - imax=(int)xmodal[10]; - } - for(i=0; i=fmin){ - if(e[i]<=fmax){ - for(j=1;j0){ - ifreebody=*ne+1; - ipobody=NNEW(int,2*ifreebody**nbody); - for(k=1;k<=*nbody;k++){ - FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, - iendset,ialset,&inewton,nset,&ifreebody,&k)); - RENEW(ipobody,int,2*(*ne+ifreebody)); - } - RENEW(ipobody,int,2*(ifreebody-1)); - } - - br=NNEW(double,neq[1]); /* load rhs vector (real part) */ - bi=NNEW(double,neq[1]); /* load rhs vector (imaginary part) */ - fr=NNEW(double,neq[1]); /* force corresponding to real particular solution */ - ubr=NNEW(double,neq[1]); /* real particular solution */ - mubr=NNEW(double,neq[1]); /* mass times real particular solution */ - btot=NNEW(double,nfour*neq[1]); - - bjr=NNEW(double,nev); /* real response modal decomposition */ - bji=NNEW(double,nev); /* imaginary response modal decomposition */ - - aa=NNEW(double,nev); /* modal coefficients of the real loading */ - bb=NNEW(double,nev); /* modal coefficients of the imaginary loading */ - - /* loop over all Fourier frequencies */ - - freq=NNEW(double,nfour); - - for(l=0;l0.){bi[i]=pi/2.;} - else{bi[i]=-pi/2.;} - } - else{ - bi[i]=atan(bi[i]/breal); - if(breal<0.){bi[i]+=pi;} - } - } - - /* correction for the sinus terms */ - - if((l!=0)&&(2*(int)floor(l/2.+0.1)==l)){ - for(i=0;i0) free(ipobody); - if(iprescribedboundary) free(xbounr); - - - /* result fields */ - - vr=NNEW(double,mt**nk); - fn=NNEW(double,mt**nk); - stn=NNEW(double,6**nk); - inum=NNEW(int,*nk); - stx=NNEW(double,6*mi[0]**ne); - if(*ithermal>1) {qfn=NNEW(double,3**nk);qfx=NNEW(double,3*mi[0]**ne);} - - if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); - if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); - - eei=NNEW(double,6*mi[0]**ne); - if(*nener==1){ - stiini=NNEW(double,6*mi[0]**ne); - enerini=NNEW(double,mi[0]**ne);} - - /* storing the results */ - - for(l=0;l1) {free(qfn);free(qfx);} - - if(strcmp1(&filab[261],"E ")==0) free(een); - if(strcmp1(&filab[522],"ENER")==0) free(enern); - - if(*nener==1){free(stiini);free(enerini);} - - } - free(xforcact);free(xloadact);free(xbodyact);free(xbounact); - free(xbounacttime);free(freqnh); - if(*ithermal==1) free(t1act); - if(iprescribedboundary){ - if(*isolver==0){ -#ifdef SPOOLES - spooles_cleanup(); -#endif - } - else if(*isolver==4){ -#ifdef SGI - sgi_cleanup(token); -#endif - } - else if(*isolver==5){ -#ifdef TAUCS - tau_cleanup(); -#endif - } - else if(*isolver==7){ -#ifdef PARDISO - pardiso_cleanup(&neq[1]); -#endif - } - } - - } - - free(adb);free(aub);free(z);free(d); - - if(*mcs==0){ - free(ad);free(au); - }else{ - *nk/=nsectors; - *ne/=nsectors; - *nboun/=nsectors; - neq[1]=neq[1]*2/nsectors; - - RENEW(co,double,3**nk); - if(*ithermal!=0){ - RENEW(t0,double,*nk); - RENEW(t1old,double,*nk); - RENEW(t1,double,*nk); - if(*nam>0) RENEW(iamt1,int,*nk); - } - RENEW(nactdof,int,mt**nk); - if(*ntrans>0) RENEW(inotr,int,2**nk); - RENEW(kon,int,*nkon); - RENEW(ipkon,int,*ne); - RENEW(lakon,char,8**ne); - RENEW(ielmat,int,*ne); - if(*norien>0) RENEW(ielorien,int,*ne); - RENEW(nodeboun,int,*nboun); - RENEW(ndirboun,int,*nboun); - if(*nam>0) RENEW(iamboun,int,*nboun); - RENEW(xboun,double,*nboun); - RENEW(xbounold,double,*nboun); - RENEW(ikboun,int,*nboun); - RENEW(ilboun,int,*nboun); - - /* recovering the original multiple point constraints */ - - RENEW(ipompc,int,*nmpc); - RENEW(nodempc,int,3**mpcend); - RENEW(coefmpc,double,*mpcend); - RENEW(labmpc,char,20**nmpc+1); - RENEW(ikmpc,int,*nmpc); - RENEW(ilmpc,int,*nmpc); - RENEW(fmpc,double,*nmpc); - - *nmpc=nmpcold; - *mpcend=mpcendold; - for(i=0;i<*nmpc;i++){ipompc[i]=ipompcold[i];} - for(i=0;i<3**mpcend;i++){nodempc[i]=nodempcold[i];} - for(i=0;i<*mpcend;i++){coefmpc[i]=coefmpcold[i];} - for(i=0;i<20**nmpc;i++){labmpc[i]=labmpcold[i];} - for(i=0;i<*nmpc;i++){ikmpc[i]=ikmpcold[i];} - for(i=0;i<*nmpc;i++){ilmpc[i]=ilmpcold[i];} - free(ipompcold);free(nodempcold);free(coefmpcold); - free(labmpcold);free(ikmpcold);free(ilmpcold); - - RENEW(vold,double,mt**nk); - RENEW(eme,double,6*mi[0]**ne); - if(*nener==1)RENEW(ener,double,mi[0]**ne); - -/* distributed loads */ - - for(i=0;i<*nload;i++){ - if(nelemload[2*i]<=*ne*nsectors){ - nelemload[2*i]-=*ne*nelemload[2*i+1]; - }else{ - nelemload[2*i]-=*ne*(nsectors+nelemload[2*i+1]-1); - } - } - - /* sorting the elements with distributed loads */ - - if(*nload>0){ - if(*nam>0){ - FORTRAN(isortiddc2,(nelemload,iamload,xload,xloadold,sideload,nload,&kflag)); - }else{ - FORTRAN(isortiddc1,(nelemload,xload,xloadold,sideload,nload,&kflag)); - } - } - -/* point loads */ - - for(i=0;i<*nforc;i++){ - if(nodeforc[2*i]<=*nk*nsectors){ - nodeforc[2*i]-=*nk*nodeforc[2*i+1]; - }else{ - nodeforc[2*i]-=*nk*(nsectors+nodeforc[2*i+1]-1); - } - } - } - - free(xstiff);free(fric); - - if(dashpot){free(cc);free(am);free(bm);free(ipiv);} - - - *cop=co;*konp=kon;*ipkonp=ipkon;*lakonp=lakon;*ielmatp=ielmat; - *ielorienp=ielorien;*inotrp=inotr;*nodebounp=nodeboun; - *ndirbounp=ndirboun;*iambounp=iamboun;*xbounp=xboun; - *xbounoldp=xbounold;*ikbounp=ikboun;*ilbounp=ilboun;*nactdofp=nactdof; - *voldp=vold;*emep=eme;*enerp=ener;*ipompcp=ipompc;*nodempcp=nodempc; - *coefmpcp=coefmpc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; - *fmpcp=fmpc;*iamt1p=iamt1;*t0p=t0;*t1oldp=t1old;*t1p=t1;*nnnp=nnn; - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/steadystatedynamics.f calculix-ccx-2.3/ccx_2.1/src/steadystatedynamics.f --- calculix-ccx-2.1/ccx_2.1/src/steadystatedynamics.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/steadystatedynamics.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,186 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine steadystatedynamics(inpc,textpart,nmethod, - & iexpl,istep,istat,n,iline,ipol,inl,ipoinp,inp,iperturb,isolver, - & xmodal,cs,mcs,ipoinpc,nforc,nload,nbody,iprestr,t0,t1,ithermal, - & nk) -! -! reading the input deck: *STEADY STATE DYNAMICS -! - implicit none -! - logical cyclicsymmetry -! - character*1 inpc(*) - character*3 harmonic - character*20 solver - character*132 textpart(16) -! - integer nmethod,istep,istat,n,key,iexpl,iline,ipol,inl, - & ipoinp(2,*),inp(3,*),iperturb(2),isolver,i,ndata,nfour,mcs, - & ipoinpc(0:*),nforc,nload,nbody,iprestr,ithermal,j,nk -! - real*8 fmin,fmax,bias,tmin,tmax,xmodal(*),cs(17,*),t0(*),t1(*) -! - iexpl=0 - iperturb(1)=0 - iperturb(2)=0 - harmonic='YES' - cyclicsymmetry=.false. -! - if(istep.lt.1) then - write(*,*) '*ERROR in modaldynamics: *STEADY STATE DYNAMICS' - write(*,*) ' can only be used within a STEP' - stop - endif -! -! default solver -! - if(isolver.eq.0) then - solver(1:7)='SPOOLES' - elseif(isolver.eq.2) then - solver(1:16)='ITERATIVESCALING' - elseif(isolver.eq.3) then - solver(1:17)='ITERATIVECHOLESKY' - elseif(isolver.eq.4) then - solver(1:3)='SGI' - elseif(isolver.eq.5) then - solver(1:5)='TAUCS' - elseif(isolver.eq.7) then - solver(1:7)='PARDISO' - endif -! - do i=2,n - if(textpart(i)(1:7).eq.'SOLVER=') then - read(textpart(i)(8:27),'(a20)') solver - elseif(textpart(i)(1:9).eq.'HARMONIC=') then - read(textpart(i)(10:12),'(a3)') harmonic - elseif(textpart(i)(1:14).eq.'CYCLICSYMMETRY') then - cyclicsymmetry=.true. - endif - enddo -! - if(solver(1:7).eq.'SPOOLES') then - isolver=0 - elseif(solver(1:16).eq.'ITERATIVESCALING') then - write(*,*) '*WARNING in modaldynamics: the iterative scaling' - write(*,*) ' procedure is not available for modal' - write(*,*) ' dynamic calculations; the default solver' - write(*,*) ' is used' - elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then - write(*,*) '*WARNING in modaldynamics: the iterative scaling' - write(*,*) ' procedure is not available for modal' - write(*,*) ' dynamic calculations; the default solver' - write(*,*) ' is used' - elseif(solver(1:3).eq.'SGI') then - isolver=4 - elseif(solver(1:5).eq.'TAUCS') then - isolver=5 - elseif(solver(1:13).eq.'MATRIXSTORAGE') then - isolver=6 - elseif(solver(1:7).eq.'PARDISO') then - isolver=7 - else - write(*,*) '*WARNING in modaldynamics: unknown solver;' - write(*,*) ' the default solver is used' - endif -! - if((isolver.eq.2).or.(isolver.eq.3)) then - write(*,*) '*ERROR in modaldynamics: the default solver ', - & solver - write(*,*) ' cannot be used for modal dynamic' - write(*,*) ' calculations ' - stop - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*) '*ERROR in modaldynamics: definition not complete' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - read(textpart(1)(1:20),'(f20.0)',iostat=istat) fmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - xmodal(3)=fmin - read(textpart(2)(1:20),'(f20.0)',iostat=istat) fmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - xmodal(4)=fmax - read(textpart(3)(1:20),'(i10)',iostat=istat) ndata - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(ndata.lt.2) ndata=20 - xmodal(5)=ndata+0.5 - read(textpart(4)(1:20),'(f20.0)',iostat=istat) bias - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(bias.lt.1.) bias=3. - xmodal(6)=bias -! - if(harmonic.eq.'YES') then - xmodal(7)=-0.5 - else - read(textpart(5)(1:10),'(i10)',iostat=istat) nfour - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(nfour.le.0) nfour=20 - if(n.ge.6) then - read(textpart(6)(1:20),'(f20.0)',iostat=istat) tmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - else - tmin=0.d0 - endif - if(n.ge.7) then - read(textpart(7)(1:20),'(f20.0)',iostat=istat) tmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - else - tmax=1.d0 - endif - xmodal(7)=nfour+0.5 - xmodal(8)=tmin - xmodal(9)=tmax - endif -! -! removing the present loading -! - nforc=0 - nload=0 - nbody=0 - iprestr=0 - if((ithermal.eq.1).or.(ithermal.eq.3)) then - do j=1,nk - t1(j)=t0(j) - enddo - endif -! - nmethod=5 -! -! correction for cyclic symmetric structures: -! if the present step was not preceded by a frequency step -! no nodal diameter has been selected. To make sure that -! mastructcs is called instead of mastruct a fictitious -! minimum nodal diameter is stored -! - if((cyclicsymmetry).and.(mcs.ne.0).and.(cs(2,1)<0.d0)) - & cs(2,1)=0.d0 -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/steps.f calculix-ccx-2.3/ccx_2.1/src/steps.f --- calculix-ccx-2.1/ccx_2.1/src/steps.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/steps.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,138 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine steps(inpc,textpart,iperturb,iprestr,nbody, - & nforc,nload,ithermal,t0,t1,nk,irstrt,istep,istat,n,jmax,ctrl, - & iline,ipol,inl,ipoinp,inp,newstep,ipoinpc,physcon) -! -! reading the input deck: *STEP -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer iperturb(*),nforc,nload,ithermal,nk,istep,istat,n,key, - & i,j,iprestr,jmax(2),irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*), - & newstep,nbody,ipoinpc(0:*) -! - real*8 t0(*),t1(*),ctrl(*),physcon(*) -! - if(newstep.eq.1) then - write(*,*) '*ERROR in steps: *STEP statement detected' - write(*,*) ' within step ',istep - stop - else - newstep=1 - endif -! - if(iperturb(1).lt.2) iperturb(1)=0 - if(irstrt.lt.0) irstrt=0 - istep=istep+1 - jmax(1)=100 - jmax(2)=10000 - physcon(9)=0.5d0 -! - do i=2,n - if(textpart(i)(1:12).eq.'PERTURBATION') then - iperturb(1)=1 - iperturb(2)=1 -! -! removing the present loading (check!!) -! - nforc=0 - iprestr=0 - if((ithermal.eq.1).or.(ithermal.eq.3)) then - do j=1,nk - t1(j)=t0(j) - enddo - endif -! - elseif((textpart(i)(1:6).eq.'NLGEOM').and. - & (textpart(i)(7:9).ne.'=NO')) then -! -! geometrically nonlinear calculations -! - iperturb(2)=1 - if(iperturb(1).eq.0) then - iperturb(1)=2 - elseif(iperturb(1).eq.1) then - write(*,*) '*ERROR in steps: PERTURBATION and NLGEOM' - write(*,*) ' are mutually exclusive; ' - call inputerror(inpc,ipoinpc,iline) - stop - endif -c! -c! to ensure linear calculations for 1d and 2d elements and -c! for nonlinear MPCs, the -c! convergence criteria were set extremely high. If nonlinear -c! calculations are requested, these criteria must be reset -c! -c if(ctrl(19).eq.1.d+30) then -c ctrl(19)=0.005 -c ctrl(20)=0.01 -c endif -! - elseif(textpart(i)(1:4).eq.'INC=') then -! -! maximum number of increments -! - read(textpart(i)(5:14),'(i10)',iostat=istat) jmax(1) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! - elseif(textpart(i)(1:5).eq.'INCF=') then -! -! maximum number of fluid increments -! - read(textpart(i)(6:15),'(i10)',iostat=istat) jmax(2) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:16).eq.'TURBULENCEMODEL=') then -! -! turbulence model -! - if(textpart(i)(17:25).eq.'NONE') then - physcon(9)=0.5d0 - elseif(textpart(i)(17:25).eq.'K-EPSILON') then - physcon(9)=1.5d0 - elseif(textpart(i)(17:23).eq.'K-OMEGA') then - physcon(9)=2.5d0 - elseif(textpart(i)(17:19).eq.'SST') then - physcon(9)=3.5d0 - endif - endif - enddo -c! -c! to ensure linear calculations for 1d and 2d elements and -c! for nonlinear MPCs, the -c! convergence criteria were set extremely high. If nonlinear -c! calculations are requested, these criteria must be reset -c! -c if((iperturb(1).eq.3).and.(ctrl(19).eq.1.d+30)) then -c ctrl(19)=0.005 -c ctrl(20)=0.01 -c endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/stiff2mat.f calculix-ccx-2.3/ccx_2.1/src/stiff2mat.f --- calculix-ccx-2.1/ccx_2.1/src/stiff2mat.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/stiff2mat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,150 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine stiff2mat(elas,ckl,vj,cauchy) -! -! elas(21): stiffness constants in the spatial description, i.e. -! the derivative of the Cauchy stress or the Kirchhoff -! stress with respect to the Eulerian strain -! ckl(3,3): inverse deformation gradient -! vj: Jacobian determinant -! cauchy: logical variable -! if true: elas is written in terms of Cauchy stress -! if false: elas is written in terms of Kirchhoff stress -! -! OUTPUT: -! -! elas(21): stiffness constants in the material description,i.e. -! the derivative of the second Piola-Kirchhoff stress (PK2) -! with respect to the Lagrangian strain -! - implicit none -! - logical cauchy -! - integer kk(84),i,nt,k,l,m,n -! - real*8 elas(21),e(21),ckl(3,3),vj -! - data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, - & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, - & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, - & 2,3,2,3/ -! - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - e(i)=elas(1)*ckl(k,1)*ckl(l,1)*ckl(m,1)*ckl(n,1) - & +elas(2)*(ckl(k,2)*ckl(l,2)*ckl(m,1)*ckl(n,1)+ - & ckl(k,1)*ckl(l,1)*ckl(m,2)*ckl(n,2)) - & +elas(3)*ckl(k,2)*ckl(l,2)*ckl(m,2)*ckl(n,2) - & +elas(4)*(ckl(k,3)*ckl(l,3)*ckl(m,1)*ckl(n,1)+ - & ckl(k,1)*ckl(l,1)*ckl(m,3)*ckl(n,3)) - & +elas(5)*(ckl(k,3)*ckl(l,3)*ckl(m,2)*ckl(n,2)+ - & ckl(k,2)*ckl(l,2)*ckl(m,3)*ckl(n,3)) - & +elas(6)*ckl(k,3)*ckl(l,3)*ckl(m,3)*ckl(n,3) - & +elas(7)*(ckl(k,2)*ckl(l,1)*ckl(m,1)*ckl(n,1)+ - & ckl(k,1)*ckl(l,2)*ckl(m,1)*ckl(n,1)+ - & ckl(k,1)*ckl(l,1)*ckl(m,2)*ckl(n,1)+ - & ckl(k,1)*ckl(l,1)*ckl(m,1)*ckl(n,2)) - & +elas(8)*(ckl(k,2)*ckl(l,2)*ckl(m,2)*ckl(n,1)+ - & ckl(k,2)*ckl(l,2)*ckl(m,1)*ckl(n,2)+ - & ckl(k,2)*ckl(l,1)*ckl(m,2)*ckl(n,2)+ - & ckl(k,1)*ckl(l,2)*ckl(m,2)*ckl(n,2)) - & +elas(9)*(ckl(k,3)*ckl(l,3)*ckl(m,2)*ckl(n,1)+ - & ckl(k,3)*ckl(l,3)*ckl(m,1)*ckl(n,2)+ - & ckl(k,2)*ckl(l,1)*ckl(m,3)*ckl(n,3)+ - & ckl(k,1)*ckl(l,2)*ckl(m,3)*ckl(n,3)) - & +elas(10)*(ckl(k,2)*ckl(l,1)*ckl(m,2)*ckl(n,1)+ - & ckl(k,1)*ckl(l,2)*ckl(m,2)*ckl(n,1)+ - & ckl(k,2)*ckl(l,1)*ckl(m,1)*ckl(n,2)+ - & ckl(k,1)*ckl(l,2)*ckl(m,1)*ckl(n,2)) - & +elas(11)*(ckl(k,3)*ckl(l,1)*ckl(m,1)*ckl(n,1)+ - & ckl(k,1)*ckl(l,3)*ckl(m,1)*ckl(n,1)+ - & ckl(k,1)*ckl(l,1)*ckl(m,3)*ckl(n,1)+ - & ckl(k,1)*ckl(l,1)*ckl(m,1)*ckl(n,3)) - & +elas(12)*(ckl(k,2)*ckl(l,2)*ckl(m,3)*ckl(n,1)+ - & ckl(k,3)*ckl(l,1)*ckl(m,2)*ckl(n,2)+ - & ckl(k,1)*ckl(l,3)*ckl(m,2)*ckl(n,2)+ - & ckl(k,2)*ckl(l,2)*ckl(m,3)*ckl(n,1)) - & +elas(13)*(ckl(k,3)*ckl(l,3)*ckl(m,3)*ckl(n,1)+ - & ckl(k,3)*ckl(l,3)*ckl(m,1)*ckl(n,3)+ - & ckl(k,3)*ckl(l,1)*ckl(m,3)*ckl(n,3)+ - & ckl(k,1)*ckl(l,3)*ckl(m,3)*ckl(n,3)) - & +elas(14)*(ckl(k,3)*ckl(l,1)*ckl(m,2)*ckl(n,1)+ - & ckl(k,1)*ckl(l,3)*ckl(m,2)*ckl(n,1)+ - & ckl(k,2)*ckl(l,1)*ckl(m,3)*ckl(n,1)+ - & ckl(k,1)*ckl(l,2)*ckl(m,3)*ckl(n,1)+ - & ckl(k,3)*ckl(l,1)*ckl(m,1)*ckl(n,2)+ - & ckl(k,1)*ckl(l,3)*ckl(m,1)*ckl(n,2)+ - & ckl(k,2)*ckl(l,1)*ckl(m,1)*ckl(n,3)+ - & ckl(k,1)*ckl(l,2)*ckl(m,1)*ckl(n,3)) - & +elas(15)*(ckl(k,3)*ckl(l,1)*ckl(m,3)*ckl(n,1)+ - & ckl(k,1)*ckl(l,3)*ckl(m,3)*ckl(n,1)+ - & ckl(k,3)*ckl(l,1)*ckl(m,1)*ckl(n,3)+ - & ckl(k,1)*ckl(l,3)*ckl(m,1)*ckl(n,3)) - & +elas(16)*(ckl(k,3)*ckl(l,2)*ckl(m,1)*ckl(n,1)+ - & ckl(k,2)*ckl(l,3)*ckl(m,1)*ckl(n,1)+ - & ckl(k,1)*ckl(l,1)*ckl(m,3)*ckl(n,2)+ - & ckl(k,1)*ckl(l,1)*ckl(m,2)*ckl(n,3)) - & +elas(17)*(ckl(k,3)*ckl(l,2)*ckl(m,2)*ckl(n,2)+ - & ckl(k,2)*ckl(l,3)*ckl(m,2)*ckl(n,2)+ - & ckl(k,2)*ckl(l,2)*ckl(m,3)*ckl(n,2)+ - & ckl(k,2)*ckl(l,2)*ckl(m,2)*ckl(n,3)) - & +elas(18)*(ckl(k,3)*ckl(l,3)*ckl(m,3)*ckl(n,2)+ - & ckl(k,3)*ckl(l,3)*ckl(m,2)*ckl(n,3)+ - & ckl(k,3)*ckl(l,2)*ckl(m,3)*ckl(n,3)+ - & ckl(k,2)*ckl(l,3)*ckl(m,3)*ckl(n,3)) - & +elas(19)*(ckl(k,3)*ckl(l,2)*ckl(m,2)*ckl(n,1)+ - & ckl(k,2)*ckl(l,3)*ckl(m,2)*ckl(n,1)+ - & ckl(k,3)*ckl(l,2)*ckl(m,1)*ckl(n,2)+ - & ckl(k,2)*ckl(l,3)*ckl(m,1)*ckl(n,2)+ - & ckl(k,2)*ckl(l,1)*ckl(m,3)*ckl(n,2)+ - & ckl(k,1)*ckl(l,2)*ckl(m,3)*ckl(n,2)+ - & ckl(k,2)*ckl(l,1)*ckl(m,2)*ckl(n,3)+ - & ckl(k,1)*ckl(l,2)*ckl(m,2)*ckl(n,3)) - & +elas(20)*(ckl(k,3)*ckl(l,2)*ckl(m,3)*ckl(n,1)+ - & ckl(k,2)*ckl(l,3)*ckl(m,3)*ckl(n,1)+ - & ckl(k,3)*ckl(l,1)*ckl(m,3)*ckl(n,2)+ - & ckl(k,1)*ckl(l,3)*ckl(m,3)*ckl(n,2)+ - & ckl(k,3)*ckl(l,2)*ckl(m,1)*ckl(n,3)+ - & ckl(k,2)*ckl(l,3)*ckl(m,1)*ckl(n,3)+ - & ckl(k,3)*ckl(l,1)*ckl(m,2)*ckl(n,3)+ - & ckl(k,1)*ckl(l,3)*ckl(m,2)*ckl(n,3)) - & +elas(21)*(ckl(k,3)*ckl(l,2)*ckl(m,3)*ckl(n,2)+ - & ckl(k,2)*ckl(l,3)*ckl(m,3)*ckl(n,2)+ - & ckl(k,3)*ckl(l,2)*ckl(m,2)*ckl(n,3)+ - & ckl(k,2)*ckl(l,3)*ckl(m,2)*ckl(n,3)) - enddo -! - if(cauchy) then - do i=1,21 - elas(i)=e(i)*vj - enddo - else - do i=1,21 - elas(i)=e(i) - enddo - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/stop.f calculix-ccx-2.3/ccx_2.1/src/stop.f --- calculix-ccx-2.1/ccx_2.1/src/stop.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/stop.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,26 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine stop() -! - implicit none -! - call closefile() -! - stop - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/storecontactdof.c calculix-ccx-2.3/ccx_2.1/src/storecontactdof.c --- calculix-ccx-2.1/ccx_2.1/src/storecontactdof.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/storecontactdof.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,124 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -#ifdef SPOOLES - #include "spooles.h" -#endif -#ifdef SGI - #include "sgi.h" -#endif -#ifdef TAUCS - #include "tau.h" -#endif -#ifdef PARDISO - #include "pardiso.h" -#endif - -void storecontactdof(int *nope,int *nactdof, int *mt, int *konl, int **ikactcontp, - int *nactcont,int *nactcont_, double *bcont, double *fnl, - int *ikmpc, int *nmpc, int *ilmpc,int *ipompc, int *nodempc, - double *coefmpc){ - - int j,j1,jdof,id,k,l,ist,index,node,ndir,*ikactcont=*ikactcontp; - - for(j=0;j<*nope;j++){ - for(j1=0;j1<3;j1++){ - jdof=nactdof[*mt*(konl[j]-1)+j1+1]; - if(jdof!=0){ - - jdof--; - FORTRAN(nident,(ikactcont,&jdof,nactcont,&id)); - do{ - if(id>0){ - if(ikactcont[id-1]==jdof){ - break; - } - } - (*nactcont)++; - if(*nactcont>*nactcont_){ - *nactcont_=(int)(1.1**nactcont_); - RENEW(ikactcont,int,*nactcont_); - } - k=*nactcont-1; - l=k-1; - while(k>id){ - ikactcont[k--]=ikactcont[l--]; - } - ikactcont[id]=jdof; - break; - }while(1); - - bcont[jdof]-=fnl[3*j+j1]; - }else{ - jdof=8*(konl[j]-1)+j1+1; - FORTRAN(nident,(ikmpc,&jdof,nmpc,&id)); - if(id>0){ - if(ikmpc[id-1]==jdof){ - id=ilmpc[id-1]; - ist=ipompc[id-1]; - index=nodempc[3*ist-1]; - if(index==0) continue; - do{ - node=nodempc[3*index-3]; - ndir=nodempc[3*index-2]; - jdof=nactdof[*mt*(node-1)+ndir]; - if(jdof!=0){ - - jdof--; - FORTRAN(nident,(ikactcont,&jdof,nactcont,&id)); - do{ - if(id>0){ - if(ikactcont[id-1]==jdof){ - break; - } - } - (*nactcont)++; - if(*nactcont>*nactcont_){ - *nactcont_=(int)(1.1**nactcont_); - RENEW(ikactcont,int,*nactcont_); - } - k=*nactcont-1; - l=k-1; - while(k>id){ - ikactcont[k--]=ikactcont[l--]; - } - ikactcont[id]=jdof; - break; - }while(1); - - bcont[jdof]+=coefmpc[index-1]* - fnl[3*j+j1]/coefmpc[ist-1]; - } - index=nodempc[3*index-1]; - if(index==0) break; - }while(1); - } - } - } - } - } - - *ikactcontp=ikactcont; - - return; -} - diff -Nru calculix-ccx-2.1/ccx_2.1/src/storeresidual.f calculix-ccx-2.3/ccx_2.1/src/storeresidual.f --- calculix-ccx-2.1/ccx_2.1/src/storeresidual.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/storeresidual.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,127 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine storeresidual(nactdof,b,fn,filab,ithermal,nk,sti,stn, - & ipkon,inum,kon,lakon,ne,mi,orab,ielorien,co,nelemload, - & nload,nodeboun,nboun,itg,ntg,vold,ndirboun) -! -! This routine is called in case of divergence: -! stores the residual forces in fn and changes the -! file storage labels so that the independent -! variables (displacements and/or temperatures) and -! the corresponding residual forces are stored in the -! frd file -! - implicit none -! - logical fluid,force -! - character*1 cflag - character*8 lakon(*) - character*87 filab(*) -! - integer mi(2),nactdof(0:mi(2),*),ithermal(2),i,j,nk, - & nfield,ndim,iorienglob, - & nelemload(2,*),nload,nodeboun(*),nboun,ipkon(*),inum(*),kon(*), - & ne,ielorien,itg(*),ntg,ndirboun(*),mt,nlabel -! - real*8 b(*),fn(0:mi(2),*),sti(6,mi(1),*),stn(6,*),orab(7,*), - & co(3,*),vold(0:mi(2),*) -! - mt=mi(2)+1 -! - nlabel=27 -! -! storing the residual forces in field fn -! - do i=1,nk - do j=0,mi(2) - if(nactdof(j,i).gt.0) then - fn(j,i)=b(nactdof(j,i)) - else - fn(j,i)=0.d0 - endif - enddo - enddo -! -! adapting the storage labels -! - do i=1,nlabel - filab(i)(1:4)=' ' - enddo -! - if(ithermal(1).ne.2) then - filab(1)(1:4)='U ' - filab(5)(1:4)='RF ' - else - filab(1)(1:4)=' ' - filab(5)(1:4)=' ' - endif -! - if(ithermal(1).gt.1) then - filab(2)(1:4)='NT ' - filab(10)(1:4)='RFL ' - filab(14)(1:4)='TT ' - filab(15)(1:4)='MF ' - filab(16)(1:4)='TP ' - filab(17)(1:4)='ST ' - else - filab(2)(1:4)=' ' - filab(10)(1:4)=' ' - filab(14)(1:4)=' ' - filab(15)(1:4)=' ' - filab(16)(1:4)=' ' - filab(17)(1:4)=' ' - endif -! -! calculating inum -! - fluid=.false. - nfield=0 - ndim=0 - iorienglob=0 - cflag=filab(1)(5:5) - call extrapolate(sti,stn,ipkon,inum,kon,lakon,nfield,nk, - & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, - & nelemload,nload,nodeboun,nboun,fluid,ndirboun,vold, - & ithermal,force) -! - if(fluid) then - call fluidextrapolate(vold,ipkon,inum,kon,lakon,ne,mi) - endif -! -! interpolation for 1d/2d elements -! - if(filab(1)(5:5).eq.'I') then - nfield=mt - cflag=filab(1)(5:5) - force=.false. - call map3dto1d2d(vold,ipkon,inum,kon,lakon,nfield,nk, - & ne,cflag,co,vold,force,mi) - endif -! -! marking gas nodes by multiplying inum by -1 -! - do i=1,ntg - inum(itg(i))=-inum(itg(i)) - enddo -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/str2mat.f calculix-ccx-2.3/ccx_2.1/src/str2mat.f --- calculix-ccx-2.1/ccx_2.1/src/str2mat.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/str2mat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine str2mat(str,ckl,vj,cauchy) -! -! converts the stress in spatial coordinates into material coordinates -! or the strain in material coordinates into spatial coordinates. -! -! INPUT: -! -! str(6): Cauchy stress, Kirchhoff stress or Lagrange strain -! component order: 11,22,33,12,13,23 -! ckl(3,3): the inverse deformation gradient -! vj: Jakobian determinant -! cauchy: logical variable -! if true: str contains the Cauchy stress -! if false: str contains the Kirchhoff stress or -! Lagrange strain -! -! OUTPUT: -! -! str(6): Piola-Kirchhoff stress of the second kind (PK2) or -! Euler strain -! - implicit none -! - logical cauchy -! - integer i,m1,m2 -! - real*8 str(6),s(6),ckl(3,3),vj -! - do i=1,6 - if(i.eq.1) then - m1=1 - m2=1 - elseif(i.eq.2) then - m1=2 - m2=2 - elseif(i.eq.3) then - m1=3 - m2=3 - elseif(i.eq.4) then - m1=2 - m2=1 - elseif(i.eq.5) then - m1=3 - m2=1 - else - m1=3 - m2=2 - endif -! - s(i)=(str(1)*ckl(m1,1)*ckl(m2,1)+ - & str(2)*ckl(m1,2)*ckl(m2,2)+ - & str(3)*ckl(m1,3)*ckl(m2,3)+ - & str(4)*(ckl(m1,1)*ckl(m2,2)+ckl(m1,2)*ckl(m2,1))+ - & str(5)*(ckl(m1,1)*ckl(m2,3)+ckl(m1,3)*ckl(m2,1))+ - & str(6)*(ckl(m1,2)*ckl(m2,3)+ckl(m1,3)*ckl(m2,2))) -! - enddo -! - if(cauchy) then - do i=1,6 - str(i)=s(i)*vj - enddo - else - do i=1,6 - str(i)=s(i) - enddo - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/straighteq2d.f calculix-ccx-2.3/ccx_2.1/src/straighteq2d.f --- calculix-ccx-2.1/ccx_2.1/src/straighteq2d.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/straighteq2d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine straighteq2d(col,straight) -! -! calculate the equation of the edges of a triangle with -! (col(1,1),col(2,1)),(col(1,2),col(2,2)),(col(1,3),col(2,3)) -! as vertices. The equation of the edge -! opposite notet(1) is of the form -! straight(1)*x+straight(2)*y+straight(3)=0, such that the -! vector (straight(1),straight(2)) points outwards; for the edge -! opposite of nodet(2) the equation is -! straight(4)*x+straight(5)*y+straight(6)=0 and for the edge -! oppositie of nodet(3) it is -! straight(7)*x+straight(8)*y+straight(8)=0. Here too, the normals -! (straight(4),straight(5)) and (straight(7),straight(8)) point -! outwards of the triangle. -! - implicit none -! - real*8 col(2,3),straight(9),x1,y1,dd -! -! edge opposite of 1 -! - x1=col(1,3)-col(1,2) - y1=col(2,3)-col(2,2) - dd=dsqrt(x1*x1+y1*y1) -! - straight(1)=y1/dd - straight(2)=-x1/dd -! - straight(3)=-(straight(1)*col(1,3)+ - & straight(2)*col(2,3)) -! - if(straight(1)*col(1,1)+straight(2)*col(2,1)+ - & straight(3).gt.0.d0) then - straight(1)=-straight(1) - straight(2)=-straight(2) - straight(3)=-straight(3) - endif -! -! edge opposite of 2 -! - x1=col(1,1)-col(1,3) - y1=col(2,1)-col(2,3) - dd=dsqrt(x1*x1+y1*y1) -! - straight(4)=y1/dd - straight(5)=-x1/dd -! - straight(6)=-(straight(4)*col(1,1)+ - & straight(5)*col(2,1)) -! - if(straight(4)*col(1,2)+straight(5)*col(2,2)+ - & straight(6).gt.0.d0) then - straight(4)=-straight(4) - straight(5)=-straight(5) - straight(6)=-straight(6) - endif -! -! edge opposite of 3 -! - x1=col(1,2)-col(1,1) - y1=col(2,2)-col(2,1) - dd=dsqrt(x1*x1+y1*y1) -! - straight(7)=y1/dd - straight(8)=-x1/dd -! - straight(9)=-(straight(7)*col(1,2)+ - & straight(8)*col(2,2)) -! - if(straight(7)*col(1,3)+straight(8)*col(2,3)+ - & straight(9).gt.0.d0) then - straight(7)=-straight(7) - straight(8)=-straight(8) - straight(9)=-straight(9) - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/straighteq3d.f calculix-ccx-2.3/ccx_2.1/src/straighteq3d.f --- calculix-ccx-2.1/ccx_2.1/src/straighteq3d.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/straighteq3d.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,113 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine straighteq3d(col,straight) -! -! calculate the equation of the planes through the -! edges of a triangle and perpendicular to the triangle together -! with the plane of the triangle itself with -! (col(1,1),col(2,1),col(3,1)),(col(1,2),col(2,2),col(3,2)), -! (col(1,3),col(2,3),col(3,3)) -! as vertices. The equation of the plane through the edge -! opposite nodet(1) is of the form -! straight(1)*x+straight(2)*y+straight(3)*z+straight(4)=0, such that the -! vector (straight(1),straight(2),straight(3)) points outwards; -! for the edge opposite of nodet(2) the equation is -! straight(5)*x+straight(6)*y+straight(7)*z+straight(8)=0 and for the edge -! oppositie of nodet(3) it is -! straight(9)*x+straight(10)*y+straight(11)*z+straight(12)=0. -! Here too, the normals -! (straight(5),straight(6),straight(7)) and -! (straight(9),straight(10),straight(11)) point -! outwards of the triangle. The equation of the triangle plane is -! straight(13)*x+straight(14)*y+straight(15)*z+straight(16)=0 such -! that the triangle is numbered clockwise when looking in the -! direction of vector (straight(13),straight(14),straight(15)). -! - implicit none -! - integer i -! - real*8 col(3,3),straight(16),p12(3),p23(3),p31(3),dd -! -! sides of the triangle -! - do i=1,3 - p12(i)=col(i,2)-col(i,1) - p23(i)=col(i,3)-col(i,2) - p31(i)=col(i,1)-col(i,3) - enddo -! -! normalized vector normal to the triangle: xn = p12 x p23 -! - straight(13)=p12(2)*p23(3)-p12(3)*p23(2) - straight(14)=p12(3)*p23(1)-p12(1)*p23(3) - straight(15)=p12(1)*p23(2)-p12(2)*p23(1) - dd=dsqrt(straight(13)*straight(13)+straight(14)*straight(14)+ - & straight(15)*straight(15)) - do i=13,15 - straight(i)=straight(i)/dd - enddo -! -! p12 x xn -! - straight(9)=p12(2)*straight(15)-p12(3)*straight(14) - straight(10)=p12(3)*straight(13)-p12(1)*straight(15) - straight(11)=p12(1)*straight(14)-p12(2)*straight(13) - dd=dsqrt(straight(9)*straight(9)+straight(10)*straight(10)+ - & straight(11)*straight(11)) - do i=9,11 - straight(i)=straight(i)/dd - enddo -! -! p23 x xn -! - straight(1)=p23(2)*straight(15)-p23(3)*straight(14) - straight(2)=p23(3)*straight(13)-p23(1)*straight(15) - straight(3)=p23(1)*straight(14)-p23(2)*straight(13) - dd=dsqrt(straight(1)*straight(1)+straight(2)*straight(2)+ - & straight(3)*straight(3)) - do i=1,3 - straight(i)=straight(i)/dd - enddo -! -! p31 x xn -! - straight(5)=p31(2)*straight(15)-p31(3)*straight(14) - straight(6)=p31(3)*straight(13)-p31(1)*straight(15) - straight(7)=p31(1)*straight(14)-p31(2)*straight(13) - dd=dsqrt(straight(5)*straight(5)+straight(6)*straight(6)+ - & straight(7)*straight(7)) - do i=5,7 - straight(i)=straight(i)/dd - enddo -! -! determining the inhomogeneous terms -! - straight(12)=-straight(9)*col(1,1)-straight(10)*col(2,1)- - & straight(11)*col(3,1) - straight(4)=-straight(1)*col(1,2)-straight(2)*col(2,2)- - & straight(3)*col(3,2) - straight(8)=-straight(5)*col(1,3)-straight(6)*col(2,3)- - & straight(7)*col(3,3) - straight(16)=-straight(13)*col(1,1)-straight(14)*col(2,1)- - & straight(15)*col(3,1) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/straightmpc.f calculix-ccx-2.3/ccx_2.1/src/straightmpc.f --- calculix-ccx-2.1/ccx_2.1/src/straightmpc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/straightmpc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,134 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine straightmpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, - & ikboun,ilboun,nboun,nboun_,xboun,inode,node,co,typeboun) -! -! generates MPC's for nodes staying on a straight line defined -! by two nodes a and b. The parameter inode indicates how many -! times the present routine was called within the same *MPC -! definition. For inode=1 "node" is node a, for inode=2 "node" -! is node b. Starting with inode=3 MPC's are defined. -! - implicit none -! - character*1 typeboun(*) - character*20 labmpc(*) -! - integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), - & ilmpc(*),node,id,mpcfreeold,j,idof,l,nodeboun(*),nodea,nodeb, - & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,inode,jmax,k -! - real*8 coefmpc(3,*),co(3,*),dd,dmax,xboun(*) -! - save nodea,nodeb,jmax -! - if(inode.eq.1) then - nodea=node - return - elseif(inode.eq.2) then - nodeb=node - dmax=0.d0 - do k=1,3 - dd=abs((co(k,nodea)-co(k,nodeb))) - if(dd.gt.dmax) then - dmax=dd - jmax=k - endif - enddo - return - endif -! - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in straightmpc: increase nk_' - stop - endif - do j=1,3 - if(j.eq.jmax) cycle - idof=8*(node-1)+j - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*WARNING in straightmpc: DOF for node ',node - write(*,*) ' in direction ',j,' has been used' - write(*,*) ' on the dependent side of another MPC' - write(*,*) ' STRAIGHT constraint cannot be applied' - cycle - endif - endif - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in straightmpc: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)='STRAIGHT ' -! - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc -! - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=j - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=node - nodempc(2,mpcfree)=jmax - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodea - nodempc(2,mpcfree)=j - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodea - nodempc(2,mpcfree)=jmax - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodeb - nodempc(2,mpcfree)=j - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nodeb - nodempc(2,mpcfree)=jmax - mpcfree=nodempc(3,mpcfree) - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=j - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - idof=8*(nk-1)+j - call nident(ikboun,idof,nboun,id) - nboun=nboun+1 - if(nboun.gt.nboun_) then - write(*,*) '*ERROR in straightmpc: increase nboun_' - stop - endif - nodeboun(nboun)=nk - ndirboun(nboun)=j - typeboun(nboun)='S' - do l=nboun,id+2,-1 - ikboun(l)=ikboun(l-1) - ilboun(l)=ilboun(l-1) - enddo - ikboun(id+1)=idof - ilboun(id+1)=nboun - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/strcmp1.c calculix-ccx-2.3/ccx_2.1/src/strcmp1.c --- calculix-ccx-2.1/ccx_2.1/src/strcmp1.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/strcmp1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,50 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -int strcmp1(const char *s1, const char *s2) -{ - int a,b; - - do { - a=*s1++; - b=*s2++; - -/* the statement if((a=='\0')||(b=='\0')) has been treated separately - in order to avoid the first field (s1) to be defined one longer - than required; s1 is assumed to be a variable field, s2 is - assumed to be a fixed string */ - - if(b=='\0'){ - a='\0'; - b='\0'; - break; - } - if(a=='\0'){ - a='\0'; - b='\0'; - break; - } - }while(a==b); - return(a-b); -} - diff -Nru calculix-ccx-2.1/ccx_2.1/src/strcpy1.c calculix-ccx-2.3/ccx_2.1/src/strcpy1.c --- calculix-ccx-2.1/ccx_2.1/src/strcpy1.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/strcpy1.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,43 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include -#include "CalculiX.h" - -int strcpy1(char *s1, const char *s2, int length) -{ - int b,i,blank=0; - - for(i=0;i nk' - else - nalset=nalset+1 - iendset(nset)=nalset - endif - endif - enddo -! - else -! -! element surface -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - if(nalset+1.gt.nalset_) then - write(*,*) '*ERROR in surfaces: increase nalset_' - stop - endif -! - read(textpart(2)(1:20),'(a20)',iostat=istat) label -! - if(label(2:4).eq.'NEG') then - label(2:4)='1 ' - elseif(label(2:4).eq.'POS') then - label(2:4)='2 ' - endif - if(label(2:2).eq.'N') then - label(2:2)='5' - elseif(label(2:2).eq.'P') then - label(2:2)='6' - endif -! - if((label(1:2).ne.'S1').and.(label(1:2).ne.'S2').and. - & (label(1:2).ne.'S3').and.(label(1:2).ne.'S4').and. - & (label(1:2).ne.'S5').and.(label(1:2).ne.'S6')) then - call inputerror(inpc,ipoinpc,iline) - endif -! - read(textpart(1)(1:10),'(i10)',iostat=istat)l - if(istat.gt.0) then - elset=textpart(1)(1:80) - elset(81:81)=' ' - ipos=index(elset,' ') - elset(ipos:ipos)='E' - do i=1,nset - if(set(i).eq.elset) then - do j=istartset(i),iendset(i) - l=ialset(j) - if(l.gt.0) then - kstart=kend - kend=l - nalset=nalset+1 - if(nalset.gt.nalset_) then - write(*,*) - & '*ERROR in surfaces: increase nalset_' - stop - endif - newlabel=label - if((lakon(l)(1:2).eq.'CP').or. - & (lakon(l)(2:2).eq.'A')) then - if(label(1:2).eq.'S1') then - newlabel(1:2)='S3' - elseif(label(1:2).eq.'S2') then - newlabel(1:2)='S4' - elseif(label(1:2).eq.'S3') then - newlabel(1:2)='S5' - elseif(label(1:2).eq.'S4') then - newlabel(1:2)='S6' - elseif(label(1:2).eq.'S5') then - newlabel(1:2)='S1' - elseif(label(1:2).eq.'S6') then - newlabel(1:2)='S2' - endif - endif - read(newlabel(2:2),'(i1)',iostat=istat) iside - ialset(nalset)=iside+10*l - else - kstart=kstart+1 - nalset=nalset-1 - do l=kstart,kend - nalset=nalset+1 - if(nalset.gt.nalset_) then - write(*,*) - & '*ERROR in surfaces: increase nalset_' - stop - endif - newlabel=label - if((lakon(l)(1:2).eq.'CP').or. - & (lakon(l)(2:2).eq.'A')) then - if(label(1:2).eq.'S1') then - newlabel(1:2)='S3' - elseif(label(1:2).eq.'S2') then - newlabel(1:2)='S4' - elseif(label(1:2).eq.'S3') then - newlabel(1:2)='S5' - elseif(label(1:2).eq.'S4') then - newlabel(1:2)='S6' - elseif(label(1:2).eq.'S5') then - newlabel(1:2)='S1' - elseif(label(1:2).eq.'S6') then - newlabel(1:2)='S2' - endif - endif - read(newlabel(2:2),'(i1)',iostat=istat) - & iside - ialset(nalset)=iside+10*l - enddo - endif - enddo - iendset(nset)=nalset - exit - endif - enddo - if(i.gt.nset) then - elset(ipos:ipos)=' ' - write(*,*) '*ERROR in surfaces: element set ',elset - write(*,*) ' does not exist' - stop - endif - else - if(l.gt.ne) then - write(*,*) '*WARNING in surfaces: value ', - & ialset(nalset+1) - write(*,*) ' in set ',set(nset),' > ne' - else - newlabel=label - if((lakon(l)(1:2).eq.'CP').or. - & (lakon(l)(2:2).eq.'A')) then - if(label(1:2).eq.'S1') then - newlabel(1:2)='S3' - elseif(label(1:2).eq.'S2') then - newlabel(1:2)='S4' - elseif(label(1:2).eq.'S3') then - newlabel(1:2)='S5' - elseif(label(1:2).eq.'S4') then - newlabel(1:2)='S6' - elseif(label(1:2).eq.'S5') then - newlabel(1:2)='S1' - elseif(label(1:2).eq.'S6') then - newlabel(1:2)='S2' - endif - endif - read(newlabel(2:2),'(i1)',iostat=istat) iside - nalset=nalset+1 - ialset(nalset)=iside+10*l - iendset(nset)=nalset - endif - endif - enddo - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/tau.c calculix-ccx-2.3/ccx_2.1/src/tau.c --- calculix-ccx-2.1/ccx_2.1/src/tau.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/tau.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,190 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#ifdef TAUCS - -#include -#include -#include -#include "CalculiX.h" -#include "tau.h" -#include - -taucs_ccs_matrix aa[1]; -void* F=NULL; -char* taufactor[]={ "taucs.factor.LLT=true","taucs.factor.mf=true", - "taucs.factor.ordering=amd",NULL }; -char* taufactorooc[]={ "taucs.factor.LLT=true","taucs.ooc=true", - "taucs.ooc.basename=/home/guido/scratch/scratch", - "taucs.ooc.memory=500000000.0",NULL }; -char* tausolve[]={ "taucs.factor=false",NULL }; -char* tausolveooc[]={"taucs.factor=false",NULL }; -int *irowtau=NULL,*pointtau=NULL; -double *autau=NULL; -int* perm; - - -void tau_factor(double *ad, double **aup, double *adb, double *aub, - double *sigma,int *icol, int **irowp, - int *neq, int *nzs){ - - int i,j,k,l,*irow=NULL; - long long ndim; - double *au=NULL; - double memory_mb = -1.0; - int mb = -1; - int ret; - - printf(" Factoring the system of equations using TAUCS\n\n"); - - taucs_logfile("stdout"); - - au=*aup; - irow=*irowp; - - ndim=*neq+*nzs; - - autau= NNEW(double,ndim); - irowtau=NNEW(int,ndim); - pointtau=NNEW(int,*neq+1); - - k=ndim; - l=*nzs; - - if(*sigma==0.){ - pointtau[*neq]=ndim; - for(i=*neq-1;i>=0;--i){ - for(j=0;j=0;--i){ - for(j=0;jn = *neq; - aa->m = *neq; - aa->flags = TAUCS_SYMMETRIC | TAUCS_LOWER | TAUCS_DOUBLE; - aa->colptr = pointtau; - aa->rowind = irowtau; - aa->values.d = autau; - - if(*neq<50000){ - taucs_linsolve(aa,&F,0,NULL,NULL,taufactor,NULL); - } - else{ - /*ret = taucs_linsolve(aa,&F,0,NULL,NULL,taufactorooc,NULL);*/ - - if (mb > 0) - memory_mb = (double) mb; - else - memory_mb = ((double) (-mb)) * taucs_available_memory_size()/1048576.0; - - F = taucs_io_create_multifile("~/scratch/scratch"); - - ret = taucs_ooc_factor_llt(aa,F,memory_mb*1048576.0); - - printf(" Return Code from Factoring %d\n\n",ret); - } - - *aup=au; - *irowp=irow; - - return; -} - -void tau_solve(double *b,int *neq){ - - int i; - /*static int j;*/ - double *x=NULL; - int ret; - - x=NNEW(double,*neq); - - if(*neq<150){ - taucs_linsolve(aa,&F,1,x,b,tausolve,NULL); - } - else{ - /*ret = taucs_linsolve(aa,&F,1,x,b,tausolveooc,NULL);*/ - - ret = taucs_ooc_solve_llt(F, x, b); - - printf(" Return Code from Solving %d\n\n",ret); - - taucs_io_delete(F); - } - - for(i=0;i<=*neq-1;++i){ - b[i]=x[i]; - } - free(x);/* - if (mb > 0) - memory_mb = (double) mb; - else - memory_mb = ((double) (-mb)) * taucs_available_memory_size()/1048576.0; - */ - /*j++;printf("%d\n",j);*/ - - return; -} - -void tau_cleanup(){ - - /*taucs_linsolve(NULL,&F,0,NULL,NULL,NULL,NULL);*/ - free(pointtau); - free(irowtau); - free(autau); - - return; -} - -void tau(double *ad, double **aup, double *adb, double *aub, double *sigma, - double *b, int *icol, int **irowp, - int *neq, int *nzs){ - - if(*neq==0) return; - - - tau_factor(ad,aup,adb,aub,sigma,icol,irowp, - neq,nzs); - - tau_solve(b,neq); - - tau_cleanup(); - - - return; -} - -#endif diff -Nru calculix-ccx-2.1/ccx_2.1/src/tau.h calculix-ccx-2.3/ccx_2.1/src/tau.h --- calculix-ccx-2.1/ccx_2.1/src/tau.h 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/tau.h 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -/* CALCULIX - A 3-dimensional finite element program */ -/* Copyright (C) 1998 Guido Dhondt */ -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation; either version 2 of */ -/* the License, or (at your option) any later version. */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -void tau(double *ad, double **aup, double *adb, double *aubp, double *sigma, - double *b, int *icol, int **irowp, - int *neq, int *nzs); - -void tau_factor(double *ad, double **aup, double *adb, double *aub, - double *sigma,int *icol, int **irowp, - int *neq, int *nzs); - -void tau_solve(double *b,int *neq); - -void tau_cleanup(); - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/temperatures.f calculix-ccx-2.3/ccx_2.1/src/temperatures.f --- calculix-ccx-2.1/ccx_2.1/src/temperatures.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/temperatures.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,218 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine temperatures(inpc,textpart,set,istartset,iendset, - & ialset,nset,t0,t1,nk,ithermal,iamt1,amname,nam,inoelfree,nk_, - & nmethod,temp_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & nam_,namtot_,namta,amta,ipoinpc) -! -! reading the input deck: *TEMPERATURE -! - implicit none -! - logical temp_flag,user -! - character*1 inpc(*) - character*80 amname(*),amplitude - character*81 set(*),noset - character*132 textpart(16) -! - integer istartset(*),iendset(*),ialset(*),iamt1(*),nmethod, - & nset,nk,ithermal,istep,istat,n,key,i,j,k,l,nam,ipoinpc(0:*), - & iamplitude,ipos,inoelfree,nk_,iline,ipol,inl,ipoinp(2,*), - & inp(3,*),nam_,namtot,namtot_,namta(3,*),idelay -! - real*8 t0(*),t1(*),temperature,tempgrad1,tempgrad2,amta(2,*) -! - iamplitude=0 - idelay=0 - user=.false. -! - if(nmethod.eq.3) then - write(*,*) '*ERROR in temperatures: temperature' - write(*,*) ' loading is not allowed in a linear' - write(*,*) ' buckling step; perform a static' - write(*,*) ' nonlinear calculation instead' - stop - endif -! - if(istep.lt.1) then - write(*,*) '*ERROR in temperatures: *TEMPERATURE' - write(*,*) ' should only be used within a STEP' - stop - endif -! - if(ithermal.ne.1) then - write(*,*) '*ERROR in temperatures: a *TEMPERATURE' - write(*,*) ' card is detected but no thermal' - write(*,*) ' *INITIAL CONDITIONS are given' - stop - endif -! - do i=2,n - if((textpart(i).eq.'OP=NEW').and.(.not.temp_flag)) then - do j=1,nk - t1(j)=t0(j) - enddo - elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then - read(textpart(i)(11:90),'(a80)') amplitude - do j=nam,1,-1 - if(amname(j).eq.amplitude) then - iamplitude=j - exit - endif - enddo - if(j.gt.nam) then - write(*,*)'*ERROR in temperatures: nonexistent amplitude' - write(*,*) ' ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - iamplitude=j - elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN - if(idelay.ne.0) then - write(*,*) '*ERROR in temperatures: the parameter TIME' - write(*,*) ' DELAY is used twice in the same' - write(*,*) ' keyword; ' - call inputerror(inpc,ipoinpc,iline) - stop - else - idelay=1 - endif - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in temperatures: increase nam_' - stop - endif - amname(nam)=' - & ' - if(iamplitude.eq.0) then - write(*,*) '*ERROR in temperatures: time delay must be' - write(*,*) ' preceded by the amplitude parameter' - stop - endif - namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) - iamplitude=nam - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) '*ERROR temperatures: increase namtot_' - stop - endif - namta(1,nam)=namtot - namta(2,nam)=namtot - read(textpart(i)(11:30),'(f20.0)',iostat=istat) - & amta(1,namtot) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:4).eq.'USER') then - user=.true. - endif - enddo -! - if(user.and.(iamplitude.ne.0)) then - write(*,*) '*WARNING: no amplitude definition is allowed' - write(*,*) ' for temperatures defined by a' - write(*,*) ' user routine' - iamplitude=0 - endif -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - read(textpart(2)(1:20),'(f20.0)',iostat=istat) temperature - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! -! dummy temperature consisting of the first primes -! - if(user) temperature=1.2357111317d0 -! - if(inoelfree.ne.0) then - tempgrad1=0.d0 - tempgrad2=0.d0 - if(n.gt.2) then - read(textpart(3)(1:20),'(f20.0)',iostat=istat) tempgrad1 - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - if(n.gt.3) then - read(textpart(4)(1:20),'(f20.0)',iostat=istat) tempgrad2 - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - endif - endif -! - read(textpart(1)(1:10),'(i10)',iostat=istat) l - if(istat.eq.0) then - if(l.gt.nk) then - write(*,*) '*ERROR in temperatures: node ',l - write(*,*) ' exceeds the largest defined ', - & 'node number' - stop - endif - t1(l)=temperature - if(nam.gt.0) iamt1(l)=iamplitude - if(inoelfree.ne.0) then - t1(nk_+l)=tempgrad1 - t1(2*nk_+l)=tempgrad2 - endif - else - read(textpart(1)(1:80),'(a80)',iostat=istat) noset - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - do i=1,nset - if(set(i).eq.noset) exit - enddo - if(i.gt.nset) then - noset(ipos:ipos)=' ' - write(*,*) '*ERROR in temperatures: node set ',noset - write(*,*) ' has not yet been defined. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - t1(ialset(j))=temperature - if(nam.gt.0) iamt1(ialset(j))=iamplitude - if(inoelfree.ne.0) then - t1(nk_+ialset(j))=tempgrad1 - t1(2*nk_+ialset(j))=tempgrad2 - endif - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - t1(k)=temperature - if(nam.gt.0) iamt1(k)=iamplitude - if(inoelfree.ne.0) then - t1(nk_+k)=tempgrad1 - t1(2*nk_+k)=tempgrad2 - endif - enddo - endif - enddo - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/temploaddiff.f calculix-ccx-2.3/ccx_2.1/src/temploaddiff.f --- calculix-ccx-2.1/ccx_2.1/src/temploaddiff.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/temploaddiff.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,377 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine temploaddiff(xforcold,xforc,xforcact,iamforc,nforc, - & xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, - & xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk, - & amta,namta,nam,ampli,time,reltime,ttime,dtime,ithermal,nmethod, - & xbounold,xboun,xbounact,iamboun,nboun, - & nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, - & co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload,mi, - & xforcdiff,xloaddiff,xbodydiff,t1diff,xboundiff,icorrect, - & iprescribedboundary) -! -! calculates the loading at a given time and the difference with -! the last call of temploaddiff: is needed in the modal dynamic -! procedure (dyna.c, dynacont.c; speeds up the calculation) -! - implicit none -! - logical gasnode -! - character*20 sideload(*) - character*80 amname(*) -! - integer iamforc(*),iamload(2,*),iamt1(*),nelemload(2,*), - & nam,i,istart,iend,id,nforc,nload,nk,namta(3,*),ithermal, - & nmethod,iamt1i,iamboun(*),nboun,iamforci,iambouni, - & iamloadi1,iamloadi2,ibody(3,*),itg(*),ntg,idof, - & nbody,iambodyi,nodeboun(*),ndirboun(*),nodeforc(2,*), - & ndirforc(*),istep,iinc,msecpt,node,j,ikboun(*),ilboun(*), - & ipresboun,mi(2),icorrect,iprescribedboundary -! - real*8 xforc(*),xforcact(*),xload(2,*),xloadact(2,*), - & t1(*),t1act(*),amta(2,*),ampli(*),time,xforcdiff(*), - & xforcold(*),xloadold(2,*),t1old(*),reltime,xloaddiff(2,*), - & xbounold(*),xboun(*),xbounact(*),ttime,dtime,reftime, - & xbody(7,*),xbodyold(7,*),xbodydiff(7,*),t1diff(*), - & xbodyact(7,*),co(3,*),vold(0:mi(2),*),abqtime(2),coords(3), - & xboundiff(*) -! - data msecpt /1/ -! -! if an amplitude is active, the loading is scaled according to -! the actual time. If no amplitude is active, then the load is -! - scaled according to the relative time for a static step -! - applied as a step loading for a dynamic step -! -! calculating all amplitude values for the current time -! - do i=1,nam - if(namta(3,i).lt.0) then - reftime=ttime+dtime - else - reftime=time - endif - if(abs(namta(3,i)).ne.i) then - reftime=reftime-amta(1,namta(1,i)) - istart=namta(1,abs(namta(3,i))) - iend=namta(2,abs(namta(3,i))) - if(istart.eq.0) then - call uamplitude(reftime,amname(namta(3,i)),ampli(i)) - cycle - endif - else - istart=namta(1,i) - iend=namta(2,i) - if(istart.eq.0) then - call uamplitude(reftime,amname(i),ampli(i)) - cycle - endif - endif - call identamta(amta,reftime,istart,iend,id) - if(id.lt.istart) then - ampli(i)=amta(2,istart) - elseif(id.eq.iend) then - ampli(i)=amta(2,iend) - else - ampli(i)=amta(2,id)+(amta(2,id+1)-amta(2,id)) - & *(reftime-amta(1,id))/(amta(1,id+1)-amta(1,id)) - endif - enddo -! -! scaling the boundary conditions -! - if(iprescribedboundary.eq.1) then - do i=1,nboun - if((xboun(i).lt.1.2357111318d0).and. - & (xboun(i).gt.1.2357111316d0)) then -! -! user subroutine for boundary conditions -! - node=nodeboun(i) -! -! check whether node is a gasnode -! - gasnode=.false. - call nident(itg,node,ntg,id) - if(id.gt.0) then - if(itg(id).eq.node) then - gasnode=.true. - endif - endif -! - abqtime(1)=time - abqtime(2)=ttime+dtime -! -! a gasnode cannot move (displacement DOFs are used -! for other purposes, e.g. mass flow and pressure) -! - if(gasnode) then - do j=1,3 - coords(j)=co(j,node) - enddo - else - do j=1,3 - coords(j)=co(j,node)+vold(j,node) - enddo - endif -! - if(icorrect.eq.0) then - xboundiff(i)=xbounact(i) - else - xboundiff(i)=xbounact(i)-xboundiff(i) - endif - if(ndirboun(i).eq.0) then - call utemp(xbounact(i),msecpt,istep,iinc,abqtime,node, - & coords,vold,mi) - else - call uboun(xbounact(i),istep,iinc,abqtime,node, - & ndirboun(i),coords,vold,mi) - endif - xboundiff(i)=xbounact(i)-xboundiff(i) - cycle - endif -! - if(nam.gt.0) then - iambouni=iamboun(i) - else - iambouni=0 - endif -! - if(icorrect.eq.0) then - xboundiff(i)=xbounact(i) - else - xboundiff(i)=xbounact(i)-xboundiff(i) - endif - if(iambouni.gt.0) then - xbounact(i)=xboun(i)*ampli(iambouni) - elseif(nmethod.eq.1) then - xbounact(i)=xbounold(i)+ - & (xboun(i)-xbounold(i))*reltime - else - xbounact(i)=xboun(i) - endif - xboundiff(i)=xbounact(i)-xboundiff(i) - enddo - endif -! -! scaling the loading -! - do i=1,nforc - if(ndirforc(i).eq.0) then - if((xforc(i).lt.1.2357111318d0).and. - & (xforc(i).gt.1.2357111316d0)) then -! -! user subroutine for the concentrated heat flux -! - node=nodeforc(1,i) -! -! check whether node is a gasnode -! - gasnode=.false. - call nident(itg,node,ntg,id) - if(id.gt.0) then - if(itg(id).eq.node) then - gasnode=.true. - endif - endif -! - abqtime(1)=time - abqtime(2)=ttime+dtime -! -! a gasnode cannot move (displacement DOFs are used -! for other purposes, e.g. mass flow and pressure) -! - if(gasnode) then - do j=1,3 - coords(j)=co(j,node) - enddo - else - do j=1,3 - coords(j)=co(j,node)+vold(j,node) - enddo - endif -! - if(icorrect.eq.0) then - xforcdiff(i)=xforcact(i) - else - xforcdiff(i)=xforcact(i)-xforcdiff(i) - endif - call cflux(xforcact(i),msecpt,istep,iinc,abqtime,node, - & coords,vold,mi) - xforcdiff(i)=xforcact(i)-xforcdiff(i) - cycle - endif - endif - if(nam.gt.0) then - iamforci=iamforc(i) - else - iamforci=0 - endif -! - if(icorrect.eq.0) then - xforcdiff(i)=xforcact(i) - else - xforcdiff(i)=xforcact(i)-xforcdiff(i) - endif - if(iamforci.gt.0) then - xforcact(i)=xforc(i)*ampli(iamforci) - elseif(nmethod.eq.1) then - xforcact(i)=xforcold(i)+ - & (xforc(i)-xforcold(i))*reltime - else - xforcact(i)=xforc(i) - endif - xforcdiff(i)=xforcact(i)-xforcdiff(i) - enddo -! - do i=1,nload - ipresboun=0 -! -! check for pressure boundary conditions -! - if(sideload(i)(3:4).eq.'NP') then - node=nelemload(2,i) - idof=8*(node-1)+2 - call nident(ikboun,idof,nboun,id) - if(id.gt.0) then - if(ikboun(id).eq.idof) then - ipresboun=1 - if(icorrect.eq.0) then - xloaddiff(1,i)=xloadact(1,i) - else - xloaddiff(1,i)=xloadact(1,i)-xloaddiff(1,i) - endif - xloadact(1,i)=xbounact(ilboun(id)) - xloaddiff(1,i)=xloadact(1,i)-xloaddiff(1,i) - endif - endif - endif -! - if(ipresboun.eq.0) then - if(nam.gt.0) then - iamloadi1=iamload(1,i) - iamloadi2=iamload(2,i) - else - iamloadi1=0 - iamloadi2=0 - endif -! - if(icorrect.eq.0) then - xloaddiff(1,i)=xloadact(1,i) - else - xloaddiff(1,i)=xloadact(1,i)-xloaddiff(1,i) - endif - if(iamloadi1.gt.0) then - xloadact(1,i)=xload(1,i)*ampli(iamloadi1) - elseif(nmethod.eq.1) then - xloadact(1,i)=xloadold(1,i)+ - & (xload(1,i)-xloadold(1,i))*reltime - else - xloadact(1,i)=xload(1,i) - endif - xloaddiff(1,i)=xloadact(1,i)-xloaddiff(1,i) -! - if(icorrect.eq.0) then - xloaddiff(2,i)=xloadact(1,i) - else - xloaddiff(2,i)=xloadact(2,i)-xloaddiff(2,i) - endif - if(iamloadi2.gt.0) then - xloadact(2,i)=xload(2,i)*ampli(iamloadi2) - elseif(nmethod.eq.1) then - xloadact(2,i)=xload(2,i) - else - xloadact(2,i)=xload(2,i) - endif - xloaddiff(2,i)=xloadact(2,i)-xloaddiff(2,i) - endif - enddo -! - do i=1,nbody - if(nam.gt.0) then - iambodyi=ibody(2,i) - else - iambodyi=0 - endif -! - if(icorrect.eq.0) then - xbodydiff(1,i)=xbodyact(1,i) - else - xbodydiff(1,i)=xbodyact(1,i)-xbodydiff(1,i) - endif - if(iambodyi.gt.0) then - xbodyact(1,i)=xbody(1,i)*ampli(iambodyi) - elseif(nmethod.eq.1) then - xbodyact(1,i)=xbodyold(1,i)+ - & (xbody(1,i)-xbodyold(1,i))*reltime - else - xbodyact(1,i)=xbody(1,i) - endif - xbodydiff(1,i)=xbodyact(1,i)-xbodydiff(1,i) - enddo -! -! scaling the temperatures -! set inactive for modal dynamics calculations -! -c if(ithermal.eq.1) then -c do i=1,nk -c if((t1(i).lt.1.2357111318d0).and. -c & (t1(i).gt.1.2357111316d0)) then -c! -c abqtime(1)=time -c abqtime(2)=ttime+dtime -c! -c do j=1,3 -c coords(j)=co(j,i)+vold(j,i) -c enddo -c if(icorrect.eq.0) then -c t1diff(i)=t1act(i) -c else -c t1diff(i)=t1act(i)-t1diff(i) -c endif -c call utemp(t1act(i),msecpt,istep,iinc,abqtime,i, -c & coords,vold,mi) -c t1diff(i)=t1act(i)-t1diff(i) -c cycle -c endif -c if(nam.gt.0) then -c iamt1i=iamt1(i) -c else -c iamt1i=0 -c endif -c! -c if(icorrect.eq.0) then -c t1diff(i)=t1act(i) -c else -c t1diff(i)=t1act(i)-t1diff(i) -c endif -c if(iamt1i.gt.0) then -c t1act(i)=t1(i)*ampli(iamt1i) -c elseif(nmethod.eq.1) then -c t1act(i)=t1old(i)+(t1(i)-t1old(i))*reltime -c else -c t1act(i)=t1(i) -c endif -c t1diff(i)=t1act(i)-t1diff(i) -c enddo -c endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/tempload.f calculix-ccx-2.3/ccx_2.1/src/tempload.f --- calculix-ccx-2.1/ccx_2.1/src/tempload.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/tempload.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,318 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine tempload(xforcold,xforc,xforcact,iamforc,nforc, - & xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, - & xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk, - & amta,namta,nam,ampli,time,reltime,ttime,dtime,ithermal,nmethod, - & xbounold,xboun,xbounact,iamboun,nboun, - & nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, - & co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload,mi) -! -! calculates the loading at a given time -! - implicit none -! - logical gasnode -! - character*20 sideload(*) - character*80 amname(*) -! - integer iamforc(*),iamload(2,*),iamt1(*),nelemload(2,*), - & nam,i,istart,iend,id,nforc,nload,nk,namta(3,*),ithermal, - & nmethod,iamt1i,iamboun(*),nboun,iamforci,iambouni, - & iamloadi1,iamloadi2,ibody(3,*),itg(*),ntg,idof, - & nbody,iambodyi,nodeboun(*),ndirboun(*),nodeforc(2,*), - & ndirforc(*),istep,iinc,msecpt,node,j,ikboun(*),ilboun(*), - & ipresboun,mi(2) -! - real*8 xforc(*),xforcact(*),xload(2,*),xloadact(2,*), - & t1(*),t1act(*),amta(2,*),ampli(*),time, - & xforcold(*),xloadold(2,*),t1old(*),reltime, - & xbounold(*),xboun(*),xbounact(*),ttime,dtime,reftime, - & xbody(7,*),xbodyold(7,*), - & xbodyact(7,*),co(3,*),vold(0:mi(2),*),abqtime(2),coords(3) -! - data msecpt /1/ -! -! if an amplitude is active, the loading is scaled according to -! the actual time. If no amplitude is active, then the load is -! - scaled according to the relative time for a static step -! - applied as a step loading for a dynamic step -! -! calculating all amplitude values for the current time -! - do i=1,nam - if(namta(3,i).lt.0) then - reftime=ttime+dtime - else - reftime=time - endif - if(abs(namta(3,i)).ne.i) then - reftime=reftime-amta(1,namta(1,i)) - istart=namta(1,abs(namta(3,i))) - iend=namta(2,abs(namta(3,i))) - if(istart.eq.0) then - call uamplitude(reftime,amname(namta(3,i)),ampli(i)) - cycle - endif - else - istart=namta(1,i) - iend=namta(2,i) - if(istart.eq.0) then - call uamplitude(reftime,amname(i),ampli(i)) - cycle - endif - endif - call identamta(amta,reftime,istart,iend,id) - if(id.lt.istart) then - ampli(i)=amta(2,istart) - elseif(id.eq.iend) then - ampli(i)=amta(2,iend) - else - ampli(i)=amta(2,id)+(amta(2,id+1)-amta(2,id)) - & *(reftime-amta(1,id))/(amta(1,id+1)-amta(1,id)) - endif - enddo -! -! scaling the boundary conditions -! - do i=1,nboun -c if((ithermal.le.1).and.(ndirboun(i).eq.0)) cycle -c if((ithermal.eq.2).and.(ndirboun(i).gt.0).and. -c & (ndirboun(i).le.3)) cycle - if((xboun(i).lt.1.2357111318d0).and. - & (xboun(i).gt.1.2357111316d0)) then -! -! user subroutine for boundary conditions -! - node=nodeboun(i) -! -! check whether node is a gasnode -! - gasnode=.false. - call nident(itg,node,ntg,id) - if(id.gt.0) then - if(itg(id).eq.node) then - gasnode=.true. - endif - endif -! - abqtime(1)=time - abqtime(2)=ttime+dtime -! -! a gasnode cannot move (displacement DOFs are used -! for other purposes, e.g. mass flow and pressure) -! - if(gasnode) then - do j=1,3 - coords(j)=co(j,node) - enddo - else - do j=1,3 - coords(j)=co(j,node)+vold(j,node) - enddo - endif -! - if(ndirboun(i).eq.0) then - call utemp(xbounact(i),msecpt,istep,iinc,abqtime,node, - & coords,vold,mi) - else - call uboun(xbounact(i),istep,iinc,abqtime,node, - & ndirboun(i),coords,vold,mi) - endif - cycle - endif -! - if(nam.gt.0) then - iambouni=iamboun(i) - else - iambouni=0 - endif - if(iambouni.gt.0) then - xbounact(i)=xboun(i)*ampli(iambouni) - elseif(nmethod.eq.1) then - xbounact(i)=xbounold(i)+ - & (xboun(i)-xbounold(i))*reltime - else - xbounact(i)=xboun(i) - endif - enddo -! -! scaling the loading -! - do i=1,nforc - if(ndirforc(i).eq.0) then - if((xforc(i).lt.1.2357111318d0).and. - & (xforc(i).gt.1.2357111316d0)) then -! -! user subroutine for the concentrated heat flux -! - node=nodeforc(1,i) -! -! check whether node is a gasnode -! - gasnode=.false. - call nident(itg,node,ntg,id) - if(id.gt.0) then - if(itg(id).eq.node) then - gasnode=.true. - endif - endif -! - abqtime(1)=time - abqtime(2)=ttime+dtime -! -! a gasnode cannot move (displacement DOFs are used -! for other purposes, e.g. mass flow and pressure) -! - if(gasnode) then - do j=1,3 - coords(j)=co(j,node) - enddo - else - do j=1,3 - coords(j)=co(j,node)+vold(j,node) - enddo - endif -! - call cflux(xforcact(i),msecpt,istep,iinc,abqtime,node, - & coords,vold,mi) - cycle - endif - endif - if(nam.gt.0) then - iamforci=iamforc(i) - else - iamforci=0 - endif - if(iamforci.gt.0) then - xforcact(i)=xforc(i)*ampli(iamforci) - elseif(nmethod.eq.1) then - xforcact(i)=xforcold(i)+ - & (xforc(i)-xforcold(i))*reltime - else - xforcact(i)=xforc(i) - endif - enddo -! - do i=1,nload - ipresboun=0 -! -! check for pressure boundary conditions -! - if(sideload(i)(3:4).eq.'NP') then - node=nelemload(2,i) - idof=8*(node-1)+2 - call nident(ikboun,idof,nboun,id) - if(id.gt.0) then - if(ikboun(id).eq.idof) then - ipresboun=1 - xloadact(1,i)=xbounact(ilboun(id)) - endif - endif - endif -! - if(ipresboun.eq.0) then - if(nam.gt.0) then - iamloadi1=iamload(1,i) - iamloadi2=iamload(2,i) - else - iamloadi1=0 - iamloadi2=0 - endif - if(iamloadi1.gt.0) then - xloadact(1,i)=xload(1,i)*ampli(iamloadi1) - elseif(nmethod.eq.1) then - xloadact(1,i)=xloadold(1,i)+ - & (xload(1,i)-xloadold(1,i))*reltime - else - xloadact(1,i)=xload(1,i) - endif - if(iamloadi2.gt.0) then - xloadact(2,i)=xload(2,i)*ampli(iamloadi2) - elseif(nmethod.eq.1) then - xloadact(2,i)=xload(2,i) - else - xloadact(2,i)=xload(2,i) - endif - endif - enddo -! - do i=1,nbody - if(nam.gt.0) then - iambodyi=ibody(2,i) - else - iambodyi=0 - endif - if(iambodyi.gt.0) then - xbodyact(1,i)=xbody(1,i)*ampli(iambodyi) - elseif(nmethod.eq.1) then - xbodyact(1,i)=xbodyold(1,i)+ - & (xbody(1,i)-xbodyold(1,i))*reltime - else - xbodyact(1,i)=xbody(1,i) - endif - enddo -! -! scaling the temperatures -! - if(ithermal.eq.1) then - do i=1,nk - if((t1(i).lt.1.2357111318d0).and. - & (t1(i).gt.1.2357111316d0)) then -! - abqtime(1)=time - abqtime(2)=ttime+dtime -! - do j=1,3 - coords(j)=co(j,i)+vold(j,i) - enddo - call utemp(t1act(i),msecpt,istep,iinc,abqtime,i, - & coords,vold,mi) - cycle - endif - if(nam.gt.0) then - iamt1i=iamt1(i) - else - iamt1i=0 - endif - if(iamt1i.gt.0) then - t1act(i)=t1(i)*ampli(iamt1i) - elseif(nmethod.eq.1) then - t1act(i)=t1old(i)+(t1(i)-t1old(i))*reltime - else - t1act(i)=t1(i) - endif - enddo - endif -c write(*,*) 'nboun' -c do i=1,nboun -c write(*,'(i7,1x,e11.4,1x,e11.4)') i,xbounact(i),xboun(i) -c enddo -c write(*,*) 'nforc' -c do i=1,nforc -c write(*,'(i7,1x,e11.4,1x,e11.4)') i,xforcact(i),xforc(i) -c enddo -c write(*,*) 'nload' -c do i=1,nload -c write(*,'(i7,1x,e11.4,1x,e11.4)') i,xloadact(1,i),xload(1,i) -c enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/temploadmodal.f calculix-ccx-2.3/ccx_2.1/src/temploadmodal.f --- calculix-ccx-2.1/ccx_2.1/src/temploadmodal.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/temploadmodal.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,92 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine temploadmodal(amta,namta,nam,ampli,time,ttime,dtime, - & xbounold,xboun,xbounact,iamboun,nboun,nodeboun,ndirboun, - & amname) -! -! calculates the SPC boundary conditions at a given time for -! a modal dynamic procedure; used to calculate the velocity and -! acceleration by use of finite differences -! - implicit none -! - character*80 amname(*) -! - integer nam,i,istart,iend,id,namta(3,*), - & iamboun(*),nboun,iambouni,nodeboun(*),ndirboun(*) -! - real*8 amta(2,*),ampli(*),time, - & xbounold(*),xboun(*),xbounact(*),ttime,dtime,reftime -! -! if an amplitude is active, the loading is scaled according to -! the actual time. If no amplitude is active, then the load is -! applied as a step loading -! -! calculating all amplitude values for the current time -! - do i=1,nam - if(namta(3,i).lt.0) then - reftime=ttime+dtime - else - reftime=time - endif - if(abs(namta(3,i)).ne.i) then - reftime=reftime-amta(1,namta(1,i)) - istart=namta(1,abs(namta(3,i))) - iend=namta(2,abs(namta(3,i))) - if(istart.eq.0) then - call uamplitude(reftime,amname(namta(3,i)),ampli(i)) - cycle - endif - else - istart=namta(1,i) - iend=namta(2,i) - if(istart.eq.0) then - call uamplitude(reftime,amname(i),ampli(i)) - cycle - endif - endif - call identamta(amta,reftime,istart,iend,id) - if(id.lt.istart) then - ampli(i)=amta(2,istart) - elseif(id.eq.iend) then - ampli(i)=amta(2,iend) - else - ampli(i)=amta(2,id)+(amta(2,id+1)-amta(2,id)) - & *(reftime-amta(1,id))/(amta(1,id+1)-amta(1,id)) - endif - enddo -! -! scaling the boundary conditions -! - do i=1,nboun - if(nam.gt.0) then - iambouni=iamboun(i) - else - iambouni=0 - endif - if(iambouni.gt.0) then - xbounact(i)=xboun(i)*ampli(iambouni) - else - xbounact(i)=xboun(i) - endif - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/thermmodel.f calculix-ccx-2.3/ccx_2.1/src/thermmodel.f --- calculix-ccx-2.1/ccx_2.1/src/thermmodel.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/thermmodel.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,164 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine thermmodel(amat,iel,iint,kode,coconloc,vkl, - & dtime,time,ttime,mi,nstate_,xstateini,xstate,qflux,xstiff, - & iorien,pgauss,orab,t1l,t1lold,vold,co,lakonl,konl, - & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc) -! - character*8 lakonl - character*80 amat -! - integer iel,iint,kode,mi(2),nstate_,iorien,ntgrd,ncoconst, - & layer,kspt,kstep,kinc,kal(2,6),konl(20),ipompc(*), - & nodempc(3,*),nmpc,ikmpc(*),ilmpc(*) -! - real*8 coconloc(*),vkl(0:3,3),dtime,time,ttime,cond(6), - & xstateini(nstate_,mi(1),*),xstate(nstate_,mi(1),*),qflux(3), - & pgauss(3),orab(7,*),abqtime(2),u,dudt,dudg(3),dfdt(3), - & dfdg(3,3),dtemp,dtemdx(3),predef(1),dpred(1),pnewdt, - & skl(3,3),t1lold,xstiff(27,mi(1),*),xa(3,3),vold(0:mi(2),*), - & co(3,*),coefmpc(*) -! - data kal /1,1,2,2,3,3,1,2,1,3,2,3/ -! - if(kode.eq.1) then -! -! linear isotropic -! - do i=1,3 - cond(i)=coconloc(1) - enddo - do i=4,6 - cond(i)=0.d0 - enddo -! - do i=1,3 - qflux(i)=-coconloc(1)*vkl(0,i) - enddo -! - elseif((kode.eq.3).or.(kode.eq.6)) then - if((kode.eq.3).and.(iorien.eq.0)) then -! -! orthotropic -! - do i=1,3 - cond(i)=coconloc(i) - enddo - do i=4,6 - cond(i)=0.d0 - enddo -! - do i=1,3 - qflux(i)=-coconloc(i)*vkl(0,i) - enddo -! - else - if(iorien.ne.0) then -! -! transformation due to special orientation -! -! calculating the transformation matrix -! - call transformatrix(orab(1,iorien),pgauss,skl) -! -! modifying the conductivity constants -! - if(kode.eq.3) then - do j=4,6 - coconloc(j)=0.d0 - enddo - endif -! - xa(1,1)=coconloc(1) - xa(1,2)=coconloc(4) - xa(1,3)=coconloc(5) - xa(2,1)=coconloc(4) - xa(2,2)=coconloc(2) - xa(2,3)=coconloc(6) - xa(3,1)=coconloc(5) - xa(3,2)=coconloc(6) - xa(3,3)=coconloc(3) -! - do jj=1,6 - coconloc(jj)=0.d0 - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - coconloc(jj)=coconloc(jj)+ - & xa(j3,j4)*skl(j1,j3)*skl(j2,j4) - enddo - enddo - enddo - endif -! -! anisotropy -! - do i=1,6 - cond(i)=coconloc(i) - enddo -! - qflux(1)=-coconloc(1)*vkl(0,1)-coconloc(4)*vkl(0,2)- - & coconloc(5)*vkl(0,3) - qflux(2)=-coconloc(4)*vkl(0,1)-coconloc(2)*vkl(0,2)- - & coconloc(6)*vkl(0,3) - qflux(3)=-coconloc(5)*vkl(0,1)-coconloc(6)*vkl(0,2)- - & coconloc(3)*vkl(0,3) -! - endif - else -! -! user material -! - ncoconst=-kode-100 -! - do i=1,nstate_ - xstate(i,iint,iel)=xstateini(i,iint,iel) - enddo -! - abqtime(1)=time-dtime - abqtime(2)=ttime-dtime -! - ntgrd=3 - dtemp=t1l-t1lold - do i=1,3 - dtemdx(i)=vkl(0,i) - enddo -! - call umatht(u,dudt,dudg,qflux,dfdt,dfdg,xstate,t1lold,dtemp, - & dtemdx,abqtime,dtime,predef,dpred,amat,ntgrd,nstate_, - & coconloc,ncoconst,pgauss,pnewdt,iel,iint,layer,kspt, - & kstep,kinc,vold,co,lakonl,konl, - & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,mi) -! - cond(1)=dfdg(1,1) - cond(2)=dfdg(2,2) - cond(3)=dfdg(3,3) - cond(4)=dfdg(1,2) - cond(5)=dfdg(1,3) - cond(6)=dfdg(2,3) -! - endif -! - do i=1,6 - xstiff(21+i,iint,iel)=cond(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/tiedcontact.c calculix-ccx-2.3/ccx_2.1/src/tiedcontact.c --- calculix-ccx-2.1/ccx_2.1/src/tiedcontact.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/tiedcontact.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,188 +0,0 @@ -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -#include -#include "CalculiX.h" - -void tiedcontact(int *ntie, char *tieset, int *nset, char *set, - int *istartset, int *iendset, int *ialset, - char *lakon, int *ipkon, int *kon, - double *tietol, - int *nmpc, int *mpcfree, int *memmpc_, - int **ipompcp, char **labmpcp, int **ikmpcp, int **ilmpcp, - double **fmpcp, int **nodempcp, double **coefmpcp, - int *ithermal, double *co, double *vold, int *cfd, - int *nmpc_, int *mi){ - - char kind[2]="T",*labmpc=NULL; - - int *itietri=NULL,*koncont=NULL,nconf,i,j,k,*nx=NULL, - *ny=NULL,*nz=NULL,*ifaceslave=NULL,*istartfield=NULL, - *iendfield=NULL,*ifield=NULL,ntrimax,index,indexold, - smallsliding,ncont,ncone,nterms,*ipompc=NULL,*ikmpc=NULL, - *ilmpc=NULL,*nodempc=NULL,ismallsliding=0,neq,neqterms, - nmpctied,mortar=0; - - double *xo=NULL,*yo=NULL,*zo=NULL,*x=NULL,*y=NULL,*z=NULL, - *cg=NULL,*straight=NULL,*fmpc=NULL,*coefmpc=NULL; - - ipompc=*ipompcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; - fmpc=*fmpcp;nodempc=*nodempcp;coefmpc=*coefmpcp; - - /* identifying the slave surfaces as nodal or facial surfaces */ - - ifaceslave=NNEW(int,*ntie); - - FORTRAN(identifytiedface,(tieset,ntie,set,nset,ifaceslave)); - - /* determining the number of triangles of the triangulation - of the master surface and the number of entities on the - slave side */ - - FORTRAN(allocont,(&ncont,ntie,tieset,nset,set,istartset,iendset, - ialset,lakon,&ncone,tietol,&ismallsliding,kind,&mortar)); - - if(ncont==0) return; - - /* allocation of space for the triangulation; - koncont(1..3,i): nodes belonging to triangle i - koncont(4,i): face label to which the triangle belongs = - 10*element+side number */ - - itietri=NNEW(int,2**ntie); - koncont=NNEW(int,4*ncont); - - /* triangulation of the master surface */ - - FORTRAN(triangucont,(&ncont,ntie,tieset,nset,set,istartset,iendset, - ialset,itietri,lakon,ipkon,kon,koncont,kind)); - - /* allocation of space for the center of gravity of the triangles - and the 4 describing planes */ - - cg=NNEW(double,3*ncont); - straight=NNEW(double,16*ncont); - - FORTRAN(updatecont,(koncont,&ncont,co,vold,cg,straight,mi)); - - /* determining the nodes belonging to the slave face surfaces */ - - istartfield=NNEW(int,*ntie); - iendfield=NNEW(int,*ntie); - ifield=NNEW(int,8*ncone); - - FORTRAN(nodestiedface,(tieset,ntie,ipkon,kon, - lakon,set,istartset,iendset,ialset, - nset,ifaceslave,istartfield,iendfield,ifield,&nconf,&ncone)); - - /* determining the maximum number of equations neq */ - - if(*cfd==1){ - if(ithermal[1]<=1){ - neq=4; - }else{ - neq=5; - } - }else{ - if(ithermal[1]<=1){ - neq=3; - }else if(ithermal[1]==2){ - neq=1; - }else{ - neq=4; - } - } - neq*=(ncone+nconf); - - /* reallocating the MPC fields for the new MPC's - ncone: number of MPC'S due to nodal slave surfaces - nconf: number of MPC's due to facal slave surfaces */ - - RENEW(ipompc,int,*nmpc_+neq); - RENEW(labmpc,char,20*(*nmpc_+neq)+1); - RENEW(ikmpc,int,*nmpc_+neq); - RENEW(ilmpc,int,*nmpc_+neq); - RENEW(fmpc,double,*nmpc_+neq); - - /* determining the maximum number of terms; - expanding nodempc and coefmpc to accommodate - those terms */ - - neqterms=9*neq; - index=*memmpc_; - (*memmpc_)+=neqterms; - RENEW(nodempc,int,3**memmpc_); - RENEW(coefmpc,double,*memmpc_); - for(k=index;k<*memmpc_;k++){ - nodempc[3*k-1]=k+1; - } - nodempc[3**memmpc_-1]=0; - - /* determining the size of the auxiliary fields */ - - ntrimax=0; - for(i=0;i<*ntie;i++){ - if(itietri[2*i+1]-itietri[2*i]+1>ntrimax) - ntrimax=itietri[2*i+1]-itietri[2*i]+1; - } - xo=NNEW(double,ntrimax); - yo=NNEW(double,ntrimax); - zo=NNEW(double,ntrimax); - x=NNEW(double,ntrimax); - y=NNEW(double,ntrimax); - z=NNEW(double,ntrimax); - nx=NNEW(int,ntrimax); - ny=NNEW(int,ntrimax); - nz=NNEW(int,ntrimax); - - /* generating the tie MPC's */ - - FORTRAN(gentiedmpc,(tieset,ntie,itietri,ipkon,kon, - lakon,set,istartset,iendset,ialset,cg,straight, - koncont,co,xo,yo,zo,x,y,z,nx,ny,nz,nset, - ifaceslave,istartfield,iendfield,ifield, - ipompc,nodempc,coefmpc,nmpc,&nmpctied,mpcfree,ikmpc,ilmpc, - labmpc,ithermal,tietol,cfd,&ncont)); - - (*nmpc_)+=nmpctied; - - free(xo);free(yo);free(zo);free(x);free(y);free(z);free(nx); - free(ny);free(nz); - - free(ifaceslave);free(istartfield);free(iendfield);free(ifield); - free(itietri);free(koncont);free(cg);free(straight); - - /* reallocating the MPC fields */ - - /* RENEW(ipompc,int,nmpc_); - RENEW(labmpc,char,20*nmpc_+1); - RENEW(ikmpc,int,nmpc_); - RENEW(ilmpc,int,nmpc_); - RENEW(fmpc,double,nmpc_);*/ - - *ipompcp=ipompc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; - *fmpcp=fmpc;*nodempcp=nodempc;*coefmpcp=coefmpc; - - /* for(i=0;i<*nmpc;i++){ - j=i+1; - FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); - }*/ - - return; -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/tiefaccont.f calculix-ccx-2.3/ccx_2.1/src/tiefaccont.f --- calculix-ccx-2.1/ccx_2.1/src/tiefaccont.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/tiefaccont.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,305 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine tiefaccont(lakon,ipkon,kon,ntie,tieset,nset,set, - & istartset,iendset,ialset,itiefac,islavsurf,islavnode, - & imastnode,nslavnode,nmastnode,nslavs,nmasts,ifacecount, - & ipe,ime,imastop,ncont,koncont,iponoels,inoels,ifreenoels, - & ifreeme) -! -! Catalogueing the slave faces (itieface, islavsurf) -! the slave nodes (islavnode, nslavnode) -! the master nodes (imastnode, nmastnode) -! the opposite trangles in the triangulation -! (imastop) -! the slave faces to which the slave nodes -! belong -! -! Authors: Li,Yang; Rakotonanahary, Samoela; -! - implicit none -! - character*8 lakon(*) - character*81 tieset(3,*),slavset,mastset,set(*) -! - logical exist -! - integer ntie,i,j,k,l,nset,istartset(*),iendset(*),ialset(*), - & ifaces,nelems,jfaces,ifacem,nelemm,nslavs,nmasts, - & jfacem,indexe,nopes,nopem,ipkon(*),kon(*),id, - & ifaceq(8,6),ifacet(6,4),ifacew1(4,5),ifacew2(8,5),node, - & itiefac(2,*),islavsurf(2,*),islavnode(*),imastnode(*), - & nslavnode(ntie+1),nmastnode(ntie+1),ifacecount,islav,imast, - & ipe(*),ime(4,*),imastop(3,*),ipos,node1,node2,index1, - & index1old,ifreeme,ncont,koncont(4,*),iponoels(*), - & inoels(3,*),ifreenoels,ifreenoelold -! -! nslavnode: num of slave nodes -! islavnode: all slave nodes, tie by tie, ordered within one tie constraint -! nmastnode: num of master nodes -! imastnode: all master nodes, tie by tie, ordered within one tie constraint -! islavsurf: all slave faces -! itiefac: pointer into field islavsurf -! -! nodes per face for hex elements -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ -! -! nodes per face for tet elements -! - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ -! -! nodes per face for linear wedge elements -! - data ifacew1 /1,3,2,0, - & 4,5,6,0, - & 1,2,5,4, - & 2,3,6,5, - & 4,6,3,1/ -! -! nodes per face for quadratic wedge elements -! - data ifacew2 /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! - ifacecount=0 - nslavs=0 - nmasts=0 - ifreenoels=0 -! -! counters for new fields islavsurf and itiefac -! - PRINT *, "Tiefiaccont..." - do i=1,ntie -! -! check for contact conditions -! - if(tieset(1,i)(81:81).eq.'C') then - slavset=tieset(2,i) -! -! check whether facial slave surface; -! - ipos=index(slavset,' ') - if(slavset(ipos:ipos).eq.'S') then - nslavnode(i+1)=nslavnode(i) - nmastnode(i+1)=nmastnode(i) - cycle - endif -! - mastset=tieset(3,i) -! -! determining the slave surface -! - do j=1,nset - if(set(j).eq.slavset) exit - enddo - if(j.gt.nset) then - write(*,*) '*ERROR in tiefaccont: slave surface' - write(*,*) ' does not exist' - stop - endif - islav=j - nslavnode(i)=nslavs -! - itiefac(1,i)=ifacecount+1 - do j=istartset(islav),iendset(islav) - if(ialset(j).gt.0) then -! -! put all the num, made of element num and face num -! of slave face, into islavsurf(1,*) -! - ifacecount=ifacecount+1 - islavsurf(1,ifacecount)=ialset(j) -! -! Decide islavnode, and nslavnode -! - ifaces = ialset(j) - nelems = int(ifaces/10) - jfaces = ifaces - nelems*10 - indexe = ipkon(nelems) -! - if(lakon(nelems)(4:4).eq.'2') then - nopes=8 - elseif(lakon(nelems)(4:4).eq.'8') then - nopes=4 - elseif(lakon(nelems)(4:5).eq.'10') then - nopes=6 - elseif(lakon(nelems)(4:4).eq.'4') then - nopes=3 - endif -! - if(lakon(nelems)(4:4).eq.'6') then - if(jfaces.le.2) then - nopes=3 - else - nopes=4 - endif - endif - if(lakon(nelems)(4:5).eq.'15') then - if(jfaces.le.2) then - nopes=6 - else - nopes=8 - endif - endif -! - do l=1,nopes - if((lakon(nelems)(4:4).eq.'2').or. - & (lakon(nelems)(4:4).eq.'8')) then - node=kon(indexe+ifaceq(l,jfaces)) - elseif((lakon(nelems)(4:4).eq.'4').or. - & (lakon(nelems)(4:5).eq.'10')) then - node=kon(indexe+ifacet(l,jfaces)) - elseif(lakon(nelems)(4:4).eq.'6') then - node=kon(indexe+ifacew1(l,jfaces)) - elseif(lakon(nelems)(4:5).eq.'15') then - node=kon(indexe+ifacew2(l,jfaces)) - endif - call nident(islavnode(nslavnode(i)+1),node, - & nslavs-nslavnode(i),id) - exist=.FALSE. - if(id.gt.0) then - if(islavnode(nslavnode(i)+id).eq.node) then - exist=.TRUE. - endif - endif - if(.not.exist) then - nslavs=nslavs+1 - do k=nslavs,id+2,-1 - islavnode(k)=islavnode(k-1) - enddo - islavnode(id+1)=node - endif -! -! filling fields iponoels and inoels -! - ifreenoelold=iponoels(node) - ifreenoels=ifreenoels+1 - iponoels(node)=ifreenoels - inoels(1,ifreenoels)=ifacecount - inoels(2,ifreenoels)=l - inoels(3,ifreenoels)=ifreenoelold - enddo -! - endif - enddo - nslavnode(ntie+1)=nslavs - itiefac(2,i)=ifacecount -! -! determining the master surface -! - do j=1,nset - if(set(j).eq.mastset) exit - enddo - if(j.gt.nset) then - write(*,*) '*ERROR in tiefaccont: master surface' - write(*,*) ' does not exist' - stop - endif - imast=j - nmastnode(i)=nmasts -! - do j=istartset(imast),iendset(imast) - if(ialset(j).gt.0) then -! -! Decide imastnode, and nmastnode -! - ifacem = ialset(j) - nelemm = int(ifacem/10) - jfacem = ifacem - nelemm*10 - indexe = ipkon(nelemm) -! - if(lakon(nelemm)(4:4).eq.'2') then - nopem=8 - elseif(lakon(nelemm)(4:4).eq.'8') then - nopem=4 - elseif(lakon(nelemm)(4:5).eq.'10') then - nopem=6 - elseif(lakon(nelemm)(4:4).eq.'4') then - nopem=3 - endif -! - if(lakon(nelemm)(4:4).eq.'6') then - if(jfacem.le.2) then - nopem=3 - else - nopem=4 - endif - endif - if(lakon(nelemm)(4:5).eq.'15') then - if(jfacem.le.2) then - nopem=6 - else - nopem=8 - endif - endif -! - do l=1,nopem - if((lakon(nelemm)(4:4).eq.'2').or. - & (lakon(nelemm)(4:4).eq.'8')) then - node=kon(indexe+ifaceq(l,jfacem)) - elseif((lakon(nelemm)(4:4).eq.'4').or. - & (lakon(nelemm)(4:5).eq.'10')) then - node=kon(indexe+ifacet(l,jfacem)) - elseif(lakon(nelemm)(4:4).eq.'6') then - node=kon(indexe+ifacew1(l,jfacem)) - elseif(lakon(nelemm)(4:5).eq.'15') then - node=kon(indexe+ifacew2(l,jfacem)) - endif - call nident(imastnode(nmastnode(i)+1),node, - & nmasts-nmastnode(i),id) - exist=.FALSE. - if(id.gt.0) then - if(imastnode(nmastnode(i)+id).eq.node) then - exist=.TRUE. - endif - endif - if(exist) cycle - nmasts=nmasts+1 - do k=nmasts,id+2,-1 - imastnode(k)=imastnode(k-1) - enddo - imastnode(id+1)=node - enddo -! - endif - enddo - nmastnode(ntie+1)=nmasts -! - else -! -! no contact tie -! - nslavnode(i+1)=nslavnode(i) - nmastnode(i+1)=nmastnode(i) - endif - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/ties.f calculix-ccx-2.3/ccx_2.1/src/ties.f --- calculix-ccx-2.1/ccx_2.1/src/ties.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ties.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,124 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine ties(inpc,textpart,tieset,tietol,istep, - & istat,n,iline,ipol,inl,ipoinp,inp,ntie,ntie_,ipoinpc) -! -! reading the input deck: *TIE -! - implicit none -! - logical multistage,tied -! - character*1 inpc(*) - character*81 tieset(3,*) - character*132 textpart(16) -! - integer istep,istat,n,i,key,ipos,iline,ipol,inl,ipoinp(2,*), - & inp(3,*),ntie,ntie_,ipoinpc(0:*) -! - real*8 tietol(*) -! - multistage=.false. - tied=.true. -! - if(istep.gt.0) then - write(*,*) '*ERROR in ties: *TIE should' - write(*,*) ' be placed before all step definitions' - stop - endif -! - ntie=ntie+1 - if(ntie.gt.ntie_) then - write(*,*) '*ERROR in ties: increase ntie_' - stop - endif -! - tietol(ntie)=-1.d0 -! - do i=2,n - if(textpart(i)(1:18).eq.'POSITIONTOLERANCE=') then - read(textpart(i)(19:38),'(f20.0)',iostat=istat) tietol(ntie) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:5).eq.'NAME=') then - read(textpart(i)(6:85),'(a80)',iostat=istat) - & tieset(1,ntie)(1:80) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:14).eq.'CYCLICSYMMETRY') then - tied=.false. - elseif(textpart(i)(1:10).eq.'MULTISTAGE') then - multistage=.true. - tied=.false. - endif - enddo - if(tieset(1,ntie)(1:1).eq.' ') then - write(*,*) '*ERROR in ties: tie name is lacking' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*)'*ERROR in ties: definition of the tie' - write(*,*) ' is not complete.' - stop - endif -! - if ( multistage ) then - tieset(1,ntie)(81:81)='M' - elseif(tied) then - tieset(1,ntie)(81:81)='T' - endif -! - if(tied) then -! -! slave surface can be nodal or facial -! - tieset(2,ntie)(1:80)=textpart(1)(1:80) - tieset(2,ntie)(81:81)=' ' -! -! master surface must be facial -! - tieset(3,ntie)(1:80)=textpart(2)(1:80) - tieset(3,ntie)(81:81)=' ' - ipos=index(tieset(3,ntie),' ') - tieset(3,ntie)(ipos:ipos)='T' - else -! -! slave and master surface must be nodal -! - tieset(2,ntie)(1:80)=textpart(1)(1:80) - tieset(2,ntie)(81:81)=' ' - ipos=index(tieset(2,ntie),' ') - tieset(2,ntie)(ipos:ipos)='S' -! - tieset(3,ntie)(1:80)=textpart(2)(1:80) - tieset(3,ntie)(81:81)=' ' - ipos=index(tieset(3,ntie),' ') - tieset(3,ntie)(ipos:ipos)='S' - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/timepointss.f calculix-ccx-2.3/ccx_2.1/src/timepointss.f --- calculix-ccx-2.1/ccx_2.1/src/timepointss.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/timepointss.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,149 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine timepointss(inpc,textpart,amname,amta,namta,nam, - & nam_,namtot_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, - & ipoinpc) -! -! reading the input deck: *AMPLITUDE -! - implicit none -! - character*1 inpc(*) - character*80 amname(*) - character*132 textpart(16) -! - integer namta(3,*),nam,nam_,istep,istat,n,key,i,namtot, - & namtot_,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),ipos, - & ipoinpc(0:*),nttp -! - logical igen -! -! - real*8 amta(2,*),x,tpmin,tpmax,tpinc -! - igen=.false. - - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*) '*ERROR in timepointss: *AMPLITUDE should be' - write(*,*) ' placed before all step definitions' - stop - endif -! - nam=nam+1 - if(nam.gt.nam_) then - write(*,*) '*ERROR in timepointss: increase nam_' - stop - endif - namta(3,nam)=nam - amname(nam)=' - & ' -! - do i=2,n - if(textpart(i)(1:5).eq.'NAME=') then - amname(nam)=textpart(i)(6:85) - if(textpart(i)(86:86).ne.' ') then - write(*,*) - & '*ERROR in timepointss: amplitude name too long' - write(*,*) ' (more than 80 characters)' - write(*,*) ' amplitude name:',textpart(i)(1:132) - stop - endif - elseif(textpart(i)(1:14).eq.'TIME=TOTALTIME') then - namta(3,nam)=-nam - elseif(textpart(i)(1:8).eq.'GENERATE') then - igen=.true. - endif - enddo -! - if(amname(nam).eq.' - & ') then - write(*,*) '*ERROR in timepointss: Amplitude has no name' - call inputerror(inpc,ipoinpc,iline) - endif -! - if(nam.eq.1) then - namtot=0 - else - namtot=namta(2,nam-1) - endif - namta(1,nam)=namtot+1 -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) exit - if(.not.igen)then - do i=1,8 - if(textpart(i)(1:1).ne.' ') then - namtot=namtot+1 - if(namtot.gt.namtot_) then - write(*,*) - & '*ERROR in timepointss: increase namtot_' - stop - endif - read(textpart(i),'(f20.0)',iostat=istat) x - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - amta(1,namtot)=x - namta(2,nam)=namtot - else - exit - endif - enddo - else -c if((textpart(1)(1:1).ne.' ').and. -c & (textpart(2)(1:1).ne.' ').and. -c & (textpart(3)(1:1).ne.' ')) then -c - read(textpart(1)(1:20),'(f20.0)',iostat=istat) tpmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) tpmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) tpinc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - - nttp=INT((tpmax-tpmin)/tpinc) - - if(namtot+2+nttp.gt.namtot_) then - write(*,*) '*ERROR in timepoints: increase namtot_' - stop - endif - amta(1,namtot+1)=tpmin - do i=1,nttp - amta(1,namtot+1+i)=tpmin+(i*tpinc) - enddo - namtot=namtot+2+nttp - amta(1,namtot)=tpmax - namta(2,nam)=namtot -c else -c exit -c endif - endif - enddo -! - if(namta(1,nam).gt.namta(2,nam)) then - ipos=index(amname(nam),' ') - write(*,*) '*WARNING in timepointss: *TIME POINTS definition ', - & amname(nam)(1:ipos-1) - write(*,*) ' has no data points' - nam=nam-1 - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/TODO calculix-ccx-2.3/ccx_2.1/src/TODO --- calculix-ccx-2.1/ccx_2.1/src/TODO 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/TODO 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -=================================================== -Things which might be useful if built into CalculiX Version 2.1 -=================================================== - -- gap/contact elements - -- incompressible elements - -- tension-only material diff -Nru calculix-ccx-2.1/ccx_2.1/src/transformatrix.f calculix-ccx-2.3/ccx_2.1/src/transformatrix.f --- calculix-ccx-2.1/ccx_2.1/src/transformatrix.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/transformatrix.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,141 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine transformatrix(xab,p,a) -! -! determines the transformation matrix a in a point p for a carthesian -! (xab(7)>0) or cylindrical transformation (xab(7)<0) -! - implicit none -! - integer j -! - real*8 xab(7),p(3),a(3,3),e1(3),e2(3),e3(3),dd -! - if(xab(7).gt.0) then -! -! carthesian transformation -! - e1(1)=xab(1) - e1(2)=xab(2) - e1(3)=xab(3) -! - e2(1)=xab(4) - e2(2)=xab(5) - e2(3)=xab(6) -! - dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3)) - do j=1,3 - e1(j)=e1(j)/dd - enddo -! - dd=e1(1)*e2(1)+e1(2)*e2(2)+e1(3)*e2(3) - do j=1,3 - e2(j)=e2(j)-dd*e1(j) - enddo -! - dd=dsqrt(e2(1)*e2(1)+e2(2)*e2(2)+e2(3)*e2(3)) - do j=1,3 - e2(j)=e2(j)/dd - enddo -! - e3(1)=e1(2)*e2(3)-e2(2)*e1(3) - e3(2)=e1(3)*e2(1)-e1(1)*e2(3) - e3(3)=e1(1)*e2(2)-e2(1)*e1(2) -! - else -! -! cylindrical coordinate system in point p -! - e1(1)=p(1)-xab(1) - e1(2)=p(2)-xab(2) - e1(3)=p(3)-xab(3) -! - e3(1)=xab(4)-xab(1) - e3(2)=xab(5)-xab(2) - e3(3)=xab(6)-xab(3) -! - dd=dsqrt(e3(1)*e3(1)+e3(2)*e3(2)+e3(3)*e3(3)) -! - do j=1,3 - e3(j)=e3(j)/dd - enddo -! - dd=e1(1)*e3(1)+e1(2)*e3(2)+e1(3)*e3(3) -! - do j=1,3 - e1(j)=e1(j)-dd*e3(j) - enddo -! - dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3)) -! -! check whether p belongs to the cylindrical coordinate axis -! if so, an arbitrary vector perpendicular to the axis can -! be taken -! - if(dd.lt.1.d-10) then -c write(*,*) '*WARNING in transformatrix: point on axis' - if(dabs(e3(1)).gt.1.d-10) then - e1(2)=1.d0 - e1(3)=0.d0 - e1(1)=-e3(2)/e3(1) - elseif(dabs(e3(2)).gt.1.d-10) then - e1(3)=1.d0 - e1(1)=0.d0 - e1(2)=-e3(3)/e3(2) - else - e1(1)=1.d0 - e1(2)=0.d0 - e1(3)=-e3(1)/e3(3) - endif - dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3)) - endif -! - do j=1,3 - e1(j)=e1(j)/dd - enddo -! - e2(1)=e3(2)*e1(3)-e1(2)*e3(3) - e2(2)=e3(3)*e1(1)-e1(3)*e3(1) - e2(3)=e3(1)*e1(2)-e1(1)*e3(2) -! - endif -! -! finding the transformation matrix -! - do j=1,3 - a(j,1)=e1(j) - a(j,2)=e2(j) - a(j,3)=e3(j) - enddo -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/transforms.f calculix-ccx-2.3/ccx_2.1/src/transforms.f --- calculix-ccx-2.1/ccx_2.1/src/transforms.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/transforms.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,109 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine transforms(inpc,textpart,trab,ntrans,ntrans_, - & inotr,set,istartset,iendset,ialset,nset,istep,istat, - & n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! -! reading the input deck: *TRANSFORM -! - implicit none -! - real*8 trab(7,*) -! - character*1 inpc(*) - character*81 set(*),noset - character*132 textpart(16) -! - integer ntrans,ntrans_,istep,istat,n,key,i,j,k,inotr(2,*), - & istartset(*),iendset(*),ialset(*),nset,ipos,iline,ipol, - & inl,ipoinp(2,*),inp(3,*),ipoinpc(0:*) -! - if(istep.gt.0) then - write(*,*) '*ERROR in transforms: *TRANSFORM should be' - write(*,*) ' placed before all step definitions' - stop - endif -! - ntrans=ntrans+1 - if(ntrans.gt.ntrans_) then - write(*,*) '*ERROR in transforms: increase ntrans_' - stop - endif -! -! rectangular coordinate system: trab(7,norien)=1 -! cylindrical coordinate system: trab(7,norien)=-1 -! default is rectangular -! - trab(7,ntrans)=1.d0 -! - do i=2,n - if(textpart(i)(1:5).eq.'NSET=') then - noset=textpart(i)(6:85) - noset(81:81)=' ' - ipos=index(noset,' ') - noset(ipos:ipos)='N' - elseif(textpart(i)(1:5).eq.'TYPE=') then - if(textpart(i)(6:6).eq.'C') then - trab(7,ntrans)=-1.d0 - endif - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*)'*ERROR in transforms: definition of a' - write(*,*) ' transformation is not complete' - call inputerror(inpc,ipoinpc,iline) - stop - endif -! - do i=1,6 - read(textpart(i)(1:20),'(f20.0)',iostat=istat) trab(i,ntrans) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo -! - do i=1,nset - if(set(i).eq.noset) exit - enddo - if(i.gt.nset) then - noset(ipos:ipos)=' ' - write(*,*) '*ERROR in transforms: node set ',noset - write(*,*) ' has not yet been defined.' - stop - endif - do j=istartset(i),iendset(i) - if(ialset(j).gt.0) then - inotr(1,ialset(j))=ntrans - else - k=ialset(j-2) - do - k=k-ialset(j) - if(k.ge.ialset(j-1)) exit - inotr(1,k)=ntrans - enddo - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/treattriangle.f calculix-ccx-2.3/ccx_2.1/src/treattriangle.f --- calculix-ccx-2.1/ccx_2.1/src/treattriangle.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/treattriangle.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,276 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine treattriangle(inodesin,nnodesin,inodesout, - & nnodesout,nopes,slavstraight,xn,co,xl2,ipe,ime,iactiveline, - & nactiveline,intersec,xntersec,ifreeintersec,itri,koncont, - & itriacornerl,nintpoint,pslavsurf,ncont,imastsurf,pmastsurf, - & pneigh,nnodelem,vold,mi,pnodesin) -! -! cuts a triangle of the master surface with a slave surface -! -! - integer inodesin(*),nnodesin,nvertex,lvertex(13),inodesout(*), - & nnodesout,nopes,ipe(*),ime(4,*),iactiveline(3,*),nactiveline, - & intersec(2,*),ifreeintersec,itri,koncont(4,*),itriacornerl(4), - & i,j,k,nintpoint,ncont,idin,imastsurf(*),nnodelem,mi(2) -! - real*8 pvertex(3,13),pnodesin(3,*),slavstraight(20),xn(3), - & co(3,*),xilm,etlm, - & xl2(3,*),xntersec(3,*),p(3,3),p1(3),p2(3),pslavsurf(3,*), - & ratio(8),dist,xil,etl,area,areax,areay,areaz,pmastsurf(2,*), - & pneigh(3,8),vold(0:mi(2),*) -! - include "gauss.f" -! -! - nvertex=0 -! - node1=koncont(1,itri) - node2=koncont(2,itri) - node3=koncont(3,itri) -! -! check whether node 1 lies inside S -! - call checktriavertex(inodesin,nnodesin,node1,nvertex,pvertex, - & lvertex,pnodesin,inodesout,nnodesout,nopes,slavstraight, - & xn,co,xl2,vold,mi) -! -! intersections of line node1-node2 with the edges of S -! -! test pour idin -! - if (node1.lt.node2) then - call nident(inodesin,node1,nnodesin,idin) - if (idin.gt.0) then - if (inodesin(idin).ne.node1) then - idin=0 - endif - endif - else - call nident(inodesin,node2,nnodesin,idin) - if (idin.gt.0) then - if (inodesin(idin).ne.node2) then - idin=0 - endif - endif - endif -! -! - call checktriaedge(node1,node2,ipe,ime,iactiveline, - & nactiveline,intersec,xntersec,nvertex,pvertex,lvertex, - & ifreeintersec,xn,co,nopes,xl2,itri,idin,vold,mi) -! -! if there are intersections, check whether the S-vertex at -! the end of an intersected S-edge must be included -! - call checkslavevertex(lvertex,nvertex,pvertex, - & itriacornerl,xl2) -! -! check whether node 2 lies inside S -! - - call checktriavertex(inodesin,nnodesin,node2,nvertex,pvertex, - & lvertex,pnodesin,inodesout,nnodesout,nopes,slavstraight, - & xn,co,xl2,vold,mi) -! -! intersections of line node2-node3 with the edges of S -! -! test pour idin -! - if (node2.lt.node3) then - call nident(inodesin,node2,nnodesin,idin) - if (idin.gt.0) then - if (inodesin(idin).ne.node2) then - idin=0 - endif - endif - else - call nident(inodesin,node3,nnodesin,idin) - if (idin.gt.0) then - if (inodesin(idin).ne.node3) then - idin=0 - endif - endif - endif -! - call checktriaedge(node2,node3,ipe,ime,iactiveline, - & nactiveline,intersec,xntersec,nvertex,pvertex,lvertex, - & ifreeintersec,xn,co,nopes,xl2,itri,idin,vold,mi) -! -! if there are intersections, check whether the S-vertex at -! the end of an intersected S-edge must be included -! - call checkslavevertex(lvertex,nvertex,pvertex, - & itriacornerl,xl2) -! -! -! check whether node 3 lies inside S -! - call checktriavertex(inodesin,nnodesin,node3,nvertex,pvertex, - & lvertex,pnodesin,inodesout,nnodesout,nopes,slavstraight, - & xn,co,xl2,vold,mi) -! -! intersections of line node3-node1 with the edges of S -! -! test pour idin -! - if (node3.lt.node1) then - call nident(inodesin,node3,nnodesin,idin) - if (idin.gt.0) then - if (inodesin(idin).ne.node3) then - idin=0 - endif - endif - else - call nident(inodesin,node1,nnodesin,idin) - if (idin.gt.0) then - if (inodesin(idin).ne.node1) then - idin=0 - endif - endif - endif -! - call checktriaedge(node3,node1,ipe,ime,iactiveline, - & nactiveline,intersec,xntersec,nvertex,pvertex,lvertex, - & ifreeintersec,xn,co,nopes,xl2,itri,idin,vold,mi) -! -! if there are intersections, check whether the S-vertex at -! the end of an intersected S-edge must be included -! - call checkslavevertex(lvertex,nvertex,pvertex, - & itriacornerl,xl2) -! -! check if all the intern salve vertexes have been treated -! - ilast=itriacornerl(1) - do nodel=4,1,-1 - if(itriacornerl(nodel).eq.1) then - if(ilast.eq.2) then - nvertex=nvertex+1 - do i=1,3 - pvertex(i,nvertex)=xl2(i,nodel) - enddo - lvertex(nvertex)=0 - itriacornerl(nodel)=2 - else - ilast=itriacornerl(nodel) - endif - else - ilast=itriacornerl(nodel) - endif - enddo -! -! check if there is always a slave node with value 1 -! - do nodel=4,1,-1 - if(itriacornerl(nodel).eq.1) then - nvertex=nvertex+1 - do i=1,3 - pvertex(i,nvertex)=xl2(i,nodel) - enddo - lvertex(nvertex)=0 - itriacornerl(nodel)=2 - endif - enddo -! -! generating integration points on the slave surface S -! - do k=1,nvertex-2 - p1(1)=pvertex(1,1+k)-pvertex(1,1) - p1(2)=pvertex(2,1+k)-pvertex(2,1) - p1(3)=pvertex(3,1+k)-pvertex(3,1) - p2(1)=pvertex(1,2+k)-pvertex(1,1) - p2(2)=pvertex(2,2+k)-pvertex(2,1) - p2(3)=pvertex(3,2+k)-pvertex(3,1) - areax=((p1(2)*p2(3))-(p2(2)*p1(3)))**2 - areay=(-(p1(1)*p2(3))+(p2(1)*p1(3)))**2 - areaz=((p1(1)*p2(2))-(p2(1)*p1(2)))**2 - if ((areax.gt.0d0).or.(areay.gt.0d0).or.(areaz.gt.0d0)) then - area=dsqrt(areax+areay+areaz)/2. -c WRITE(*,*) "A ",area, "itri",itri,"boucle k",k - if (area.lt.1d-4) cycle - else - cycle - endif -! 7 points scheme -! -! center -! - do i=1,1 - do j=1,3 - p(j,i)=pvertex(j,1)*1/3+ - & pvertex(j,1+k)*1/3+ - & pvertex(j,2+k)*1/3 -! - enddo -! - call attach(xl2,p(1,i),nopes,ratio,dist,xil,etl) - call attach(pneigh,p(1,i),nnodelem,ratio,dist,xilm,etlm) - nintpoint=nintpoint+1 - pslavsurf(1,nintpoint)=xil - pslavsurf(2,nintpoint)=etl - pslavsurf(3,nintpoint)=area*weight2d7(1) - pmastsurf(1,nintpoint)=xilm - pmastsurf(2,nintpoint)=etlm - imastsurf(nintpoint)=koncont(4,itri) -! - enddo -! -! first 3 points -! - do i=1,3 - do j=1,3 - p(j,i)=pvertex(j,1)*gauss2d71(1,i)+ - & pvertex(j,1+k)*gauss2d71(2,i)+ - & pvertex(j,2+k)*(1.d0-gauss2d71(1,i)-gauss2d71(2,i)) -! - enddo -! - call attach(xl2,p(1,i),nopes,ratio,dist,xil,etl) - call attach(pneigh,p(1,i),nnodelem,ratio,dist,xilm,etlm) - nintpoint=nintpoint+1 - pslavsurf(1,nintpoint)=xil - pslavsurf(2,nintpoint)=etl - pslavsurf(3,nintpoint)=area*weight2d7(2) - pmastsurf(1,nintpoint)=xilm - pmastsurf(2,nintpoint)=etlm - imastsurf(nintpoint)=koncont(4,itri) - enddo -! last three points - do i=1,3 - do j=1,3 - p(j,i)=pvertex(j,1)*gauss2d72(1,i)+ - & pvertex(j,1+k)*gauss2d72(2,i)+ - & pvertex(j,2+k)*(1.d0-gauss2d72(1,i)-gauss2d72(2,i)) -! - enddo -! - call attach(xl2,p(1,i),nopes,ratio,dist,xil,etl) - call attach(pneigh,p(1,i),nnodelem,ratio,dist,xilm,etlm) - nintpoint=nintpoint+1 - pslavsurf(1,nintpoint)=xil - pslavsurf(2,nintpoint)=etl - pslavsurf(3,nintpoint)=area*weight2d7(3) - pmastsurf(1,nintpoint)=xilm - pmastsurf(2,nintpoint)=etlm - imastsurf(nintpoint)=koncont(4,itri) - enddo - enddo - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/trianeighbor.f calculix-ccx-2.3/ccx_2.1/src/trianeighbor.f --- calculix-ccx-2.1/ccx_2.1/src/trianeighbor.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/trianeighbor.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,97 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine trianeighbor(ipe,ime,imastop,ncont,koncont, - & ifreeme) -! -! Catalogueing the neighboring triangles for a given master -! triangle -! -! Authors: Li,Yang; Rakotonanahary, Samoela; -! - implicit none -! - integer j,k,node,ipe(*),ime(4,*),imastop(3,*),ipos,node1,node2, - & index1,index1old,ifreeme,ncont,koncont(4,*) -! -! catalogueing the edges in the triangulation -! determining neighboring triangles -! - ifreeme=0 - do j=1,ncont - do k=1,3 - node1=koncont(k,j) - if(k.eq.3) then - node2=koncont(1,j) - else - node2=koncont(k+1,j) - endif -! - if(k.eq.1) then - ipos=3 - else - ipos=k-1 - endif -! -! making sure that node1 < node2 -! - if(node1.gt.node2) then - node=node1 - node1=node2 - node2=node - endif - if(ipe(node1).eq.0) then - ifreeme=ifreeme+1 - ipe(node1)=ifreeme - ime(1,ifreeme)=node2 - ime(2,ifreeme)=j - ime(3,ifreeme)=ipos - else - index1=ipe(node1) - if(ime(1,index1).eq.node2) then - imastop(ipos,j)=ime(2,index1) - imastop(ime(3,index1),ime(2,index1))=j - cycle - endif -! - index1old=index1 - index1=ime(4,index1) - do - if(index1.eq.0) then - ifreeme=ifreeme+1 - ime(4,index1old)=ifreeme - ime(1,ifreeme)=node2 - ime(2,ifreeme)=j - ime(3,ifreeme)=ipos - exit - endif - if(ime(1,index1).eq.node2) then - imastop(ipos,j)=ime(2,index1) - imastop(ime(3,index1),ime(2,index1))=j -c ime(4,index1old)=ime(4,index1) - exit - endif - index1old=index1 - index1=ime(4,index1) - enddo - endif - enddo - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/triangucont.f calculix-ccx-2.3/ccx_2.1/src/triangucont.f --- calculix-ccx-2.1/ccx_2.1/src/triangucont.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/triangucont.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,341 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine triangucont(ncont,ntie,tieset,nset,set,istartset, - & iendset,ialset,itietri,lakon,ipkon,kon,koncont,kind) -! -! generate a triangulation of the contact master surfaces -! - implicit none -! - character*1 kind - character*8 lakon(*) - character*81 tieset(3,*),rightset,set(*) -! - integer ncont,ntie,i,j,k,l,nset,istartset(*),iendset(*),ialset(*), - & iright,itietri(2,ntie),nelem,jface,indexe,ipkon(*),nope,m, - & ifaceq(8,6),ifacet(6,4),ifacew1(4,5),ifacew2(8,5),node, - & ntrifac,itrifac3(3,1),itrifac4(3,2),itrifac6(3,4),itrifac8(3,6), - & itrifac(3,6),nnodelem,nface,nodef(8),kon(*),koncont(4,*) -! -! nodes per face for hex elements -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ -! -! nodes per face for tet elements -! - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ -! -! nodes per face for linear wedge elements -! - data ifacew1 /1,3,2,0, - & 4,5,6,0, - & 1,2,5,4, - & 2,3,6,5, - & 4,6,3,1/ -! -! nodes per face for quadratic wedge elements -! - data ifacew2 /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! -! triangulation for three-node face -! - data itrifac3 /1,2,3/ -! -! triangulation for four-node face -! - data itrifac4 /1,2,4,2,3,4/ -! -! triangulation for six-node face -! - data itrifac6 /1,4,6,4,2,5,6,5,3,4,5,6/ -! -! triangulation for eight-node face -! - data itrifac8 /1,5,8,5,2,6,7,6,3,8,7,4,8,5,7,5,6,7/ -! - ncont=0 -! - do i=1,ntie -! -! check for contact conditions -! - if(tieset(1,i)(81:81).eq.kind) then - rightset=tieset(3,i) -! -! determining the master surface -! - do j=1,nset - if(set(j).eq.rightset) exit - enddo - if(j.gt.nset) then - write(*,*) '*ERROR in triangucont: master surface', - & rightset - write(*,*) ' does not exist' - stop - endif - iright=j -! - itietri(1,i)=ncont+1 -! - do j=istartset(iright),iendset(iright) - if(ialset(j).gt.0) then -c if(j.gt.istartset(iright)) then -c if(ialset(j).eq.ialset(j-1)) cycle -c endif -! - nelem=int(ialset(j)/10.d0) - jface=ialset(j)-10*nelem -! - indexe=ipkon(nelem) -! - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(4:4).eq.'8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.4) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacet(k,jface)) - enddo - elseif(nface.eq.5) then - if(nope.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew1(k,jface)) - enddo - elseif(nope.eq.15) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew2(k,jface)) - enddo - endif - elseif(nface.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifaceq(k,jface)) - enddo - endif -! -! number of triangles -! - if(nnodelem.eq.3) then - ntrifac=1 - do l=1,ntrifac - do k=1,3 - itrifac(k,l)=itrifac3(k,l) - enddo - enddo - elseif(nnodelem.eq.4) then - ntrifac=2 - do l=1,ntrifac - do k=1,3 - itrifac(k,l)=itrifac4(k,l) - enddo - enddo - elseif(nnodelem.eq.6) then - ntrifac=4 - do l=1,ntrifac - do k=1,3 - itrifac(k,l)=itrifac6(k,l) - enddo - enddo - elseif(nnodelem.eq.8) then - ntrifac=6 - do l=1,ntrifac - do k=1,3 - itrifac(k,l)=itrifac8(k,l) - enddo - enddo - endif -! -! storing the topology of the triangles -! - do l=1,ntrifac -! - ncont=ncont+1 - do k=1,3 - node=nodef(itrifac(k,l)) - koncont(k,ncont)=node - enddo -! - koncont(4,ncont)=ialset(j) -! - enddo -! - else - m=ialset(j-2) - do - m=m-ialset(j) - if(m.ge.ialset(j-1)) exit -! - nelem=int(m/10.d0) - jface=m-10*nelem -! - indexe=ipkon(nelem) -! - if(lakon(nelem)(4:4).eq.'2') then - nnodelem=8 - nface=6 - elseif(lakon(nelem)(4:4).eq.'8') then - nnodelem=4 - nface=6 - elseif(lakon(nelem)(4:5).eq.'10') then - nnodelem=6 - nface=4 - elseif(lakon(nelem)(4:4).eq.'4') then - nnodelem=3 - nface=4 - elseif(lakon(nelem)(4:5).eq.'15') then - if(jface.le.2) then - nnodelem=6 - else - nnodelem=8 - endif - nface=5 - nope=15 - elseif(lakon(nelem)(4:4).eq.'6') then - if(jface.le.2) then - nnodelem=3 - else - nnodelem=4 - endif - nface=5 - nope=6 - else - cycle - endif -! -! determining the nodes of the face -! - if(nface.eq.4) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacet(k,jface)) - enddo - elseif(nface.eq.5) then - if(nope.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew1(k,jface)) - enddo - elseif(nope.eq.15) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifacew2(k,jface)) - enddo - endif - elseif(nface.eq.6) then - do k=1,nnodelem - nodef(k)=kon(indexe+ifaceq(k,jface)) - enddo - endif -! -! number of triangles -! - if(nnodelem.eq.3) then - ntrifac=1 - do l=1,ntrifac - do k=1,3 - itrifac(k,l)=itrifac3(k,l) - enddo - enddo - elseif(nnodelem.eq.4) then - ntrifac=2 - do l=1,ntrifac - do k=1,3 - itrifac(k,l)=itrifac4(k,l) - enddo - enddo - elseif(nnodelem.eq.6) then - ntrifac=4 - do l=1,ntrifac - do k=1,3 - itrifac(k,l)=itrifac6(k,l) - enddo - enddo - elseif(nnodelem.eq.8) then - ntrifac=6 - do l=1,ntrifac - do k=1,3 - itrifac(k,l)=itrifac8(k,l) - enddo - enddo - endif -! -! storing the topology of the triangles -! - do l=1,ntrifac -! - ncont=ncont+1 - do k=1,3 - node=nodef(itrifac(k,l)) - koncont(k,ncont)=node - enddo -! - koncont(4,ncont)=m -! - enddo -! - enddo - endif - enddo -! - itietri(2,i)=ncont -! - endif - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/triangulate.f calculix-ccx-2.3/ccx_2.1/src/triangulate.f --- calculix-ccx-2.1/ccx_2.1/src/triangulate.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/triangulate.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,302 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine triangulate(ics,rcs0,zcs0,ncsnodes, - & rcscg,rcs0cg,zcscg,zcs0cg,nrcg,nzcg,jcs,kontri,straight, - & ne,ipkon,kon,lakon,lcs,netri,ifacetet,inodface) -! -! generate a triangulation of the independent side (= right side) -! -! the element faces of the independent side are identified and -! triangulated. The nodes belonging to the faces are stored in -! field inodface, face after face. For a triangle i the value -! ifacetet(i) points to the last node in field inodface of the -! face the triangle belongs to. -! - implicit none -! - character*8 lakon(*) -! - integer jcs(*),l,j,ics(*),nodef(8),ifacetet(*), - & nrcg(*),node,ncsnodes,id,ifaceq(8,6),ifacet(6,4), - & ifacew1(4,5),iface(8,6),nodelem(20),nnodelem,nzcg(*), - & itrifac3(3,1),itrifac4(3,2),itrifac6(3,4),itrifac8(3,6), - & itrifac(3,6),ifacew2(8,5),lcs(*),inodface(*),nnodface, - & k,kflag,i,ne,ipkon(*),kon(*),indexe,nope,nface,nodface,jface, - & netri,ntrifac,kontri(3,*) -! - real*8 straight(9,*),zcscg(*),rcscg(*),zcs0cg(*), - & rcs0cg(*),cgl(2),col(2,3),rcs0(*),zcs0(*) -! -! nodes per face for hex elements -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ -! -! nodes per face for tet elements -! - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ -! -! nodes per face for linear wedge elements -! - data ifacew1 /1,3,2,0, - & 4,5,6,0, - & 1,2,5,4, - & 2,3,6,5, - & 4,6,3,1/ -! -! nodes per face for quadratic wedge elements -! - data ifacew2 /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ -! -! triangulation for three-node face -! - data itrifac3 /1,2,3/ -! -! triangulation for four-node face -! - data itrifac4 /1,2,4,2,3,4/ -! -! triangulation for six-node face -! - data itrifac6 /1,4,6,4,2,5,6,5,3,4,5,6/ -! -! triangulation for eight-node face -! - data itrifac8 /1,5,8,5,2,6,7,6,3,8,7,4,8,5,7,5,6,7/ -! -! pointer into field inodface -! - nnodface=0 -! -! sort the nodes on the right hand side -! - do j=1,ncsnodes - jcs(j)=abs(ics(j)) - lcs(j)=j - enddo -! - kflag=2 - call isortii(jcs,lcs,ncsnodes,kflag) -! - netri=0 -! -! check the elements adjacent to the right nodes -! - do i=1,ne - indexe=ipkon(i) - if(lakon(i)(4:4).eq.'2') then - nope=20 - nface=6 - nodface=8 - elseif(lakon(i)(4:4).eq.'8') then - nope=8 - nface=6 - nodface=4 - elseif(lakon(i)(4:5).eq.'10') then - nope=10 - nface=4 - nodface=6 - elseif(lakon(i)(4:4).eq.'4') then - nope=4 - nface=4 - nodface=3 - elseif(lakon(i)(4:5).eq.'15') then - nope=15 - nface=5 - nodface=8 - elseif(lakon(i)(4:4).eq.'6') then - nope=6 - nface=5 - nodface=4 - else - cycle - endif -! -! check which nodes of the element belong to the right set -! - nnodelem=0 - do j=1,nope - nodelem(j)=0 - node=kon(indexe+j) - call nident(jcs,node,ncsnodes,id) - if(id.le.0) cycle - if(jcs(id).ne.node) cycle - nodelem(j)=node - nnodelem=nnodelem+1 - enddo - if(nnodelem.eq.0) cycle -! - if(nface.eq.4) then - do j=1,nface - do k=1,nodface - iface(k,j)=ifacet(k,j) - enddo - enddo - elseif(nface.eq.5) then - if(nope.eq.6) then - do j=1,nface - do k=1,nodface - iface(k,j)=ifacew1(k,j) - enddo - enddo - elseif(nope.eq.15) then - do j=1,nface - do k=1,nodface - iface(k,j)=ifacew2(k,j) - enddo - enddo - endif - elseif(nface.eq.6) then - do j=1,nface - do k=1,nodface - iface(k,j)=ifaceq(k,j) - enddo - enddo - endif -! -! check which face of the element belongs to the right side -! - jface=0 - loop: do j=1,nface - do k=1,nodface - if(iface(k,j).eq.0) then - nnodelem=k-1 - exit - endif - if(nodelem(iface(k,j)).eq.0) cycle loop - enddo - jface=j - exit - enddo loop - if(jface.eq.0) cycle -! -! store the node numbers in a local face field -! - do k=1,nnodelem - nodef(k)=nodelem(iface(k,jface)) - inodface(nnodface+k)=nodef(k) - enddo - nnodface=nnodface+nnodelem -! -! number of triangles -! - if(nnodelem.eq.3) then - ntrifac=1 - do j=1,ntrifac - do k=1,3 - itrifac(k,j)=itrifac3(k,j) - enddo - enddo - elseif(nnodelem.eq.4) then - ntrifac=2 - do j=1,ntrifac - do k=1,3 - itrifac(k,j)=itrifac4(k,j) - enddo - enddo - elseif(nnodelem.eq.6) then - ntrifac=4 - do j=1,ntrifac - do k=1,3 - itrifac(k,j)=itrifac6(k,j) - enddo - enddo - elseif(nnodelem.eq.8) then - ntrifac=6 - do j=1,ntrifac - do k=1,3 - itrifac(k,j)=itrifac8(k,j) - enddo - enddo - endif -! - do j=1,ntrifac -! -! new triangle -! - netri=netri+1 - do l=1,2 - cgl(l)=0.d0 - enddo - do k=1,3 - node=nodef(itrifac(k,j)) - kontri(k,netri)=node - call nident(jcs,node,ncsnodes,id) - col(1,k)=rcs0(lcs(id)) - col(2,k)=zcs0(lcs(id)) - do l=1,2 - cgl(l)=cgl(l)+col(l,k) - enddo - enddo -! -! center of gravity of the triangle -! -c write(*,*) netri,zcs0(101) - rcscg(netri)=cgl(1)/3.d0 -c write(*,*) netri,zcs0(101),rcscg(netri) - zcscg(netri)=cgl(2)/3.d0 -c write(*,*) 'triangle ',netri,(kontri(k,netri),k=1,3) -c write(*,*) col(1,1),col(2,1) -c write(*,*) col(1,2),col(2,2) -c write(*,*) col(1,3),col(2,3) -c write(*,*) rcscg(netri),zcscg(netri) -! -! determining the equations of the straight lines bordering -! the triangle -! - call straighteq2d(col,straight(1,netri)) -! - ifacetet(netri)=nnodface -! - enddo - enddo -! - if(netri.eq.0) then - write(*,*) '*ERROR in triangulate: no faces found on the' - write(*,*) ' independent side' - stop - endif -! -! initialization of near2d -! - do i=1,netri - nrcg(i)=i - nzcg(i)=i - rcs0cg(i)=rcscg(i) - zcs0cg(i)=zcscg(i) - enddo -! - kflag=2 - call dsort(rcscg,nrcg,netri,kflag) - call dsort(zcscg,nzcg,netri,kflag) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/ts_calc.f calculix-ccx-2.3/ccx_2.1/src/ts_calc.f --- calculix-ccx-2.1/ccx_2.1/src/ts_calc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ts_calc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,116 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine ts_calc(xflow,Tt,Pt,kappa,r,a,Ts,icase) -! -! this subroutine solves the implicit equation -! f=xflow*dsqrt(Tt)/(a*Pt)-C*(TtdT)**expon*(Ttdt-1)**0.5d0 -! - implicit none -! - integer inv,icase,i -! - real*8 xflow,Tt,Pt,Ts,kappa,r,f,df,a,expon,Ts_old,C,TtzTs, - & deltaTs,TtzTs_crit, Qred_crit,Qred,h1,h2,h3 - expon=-0.5d0*(kappa+1.d0)/(kappa-1.d0) -! - C=dsqrt(2.d0/r*kappa/(kappa-1.d0)) -! -! f=xflow*dsqrt(Tt)/(a*Pt)-C*(TtdT)**expon*(Ttdt-1)**0.5d0 -! -! df=-C*Ttdt**expon*(expon/Ts*(TtdT-1)**0.5d0 -! & -0.5d0*TtdT/Ts*(TtdT-1.d0)**(-0.5d0)) -! - Ts_old=Tt -! -! - if(xflow.lt.0d0) then - inv=-1 - else - inv=1 - endif -! - if(dabs(xflow).le.1e-9) then - Ts=Tt - return - endif -! - Qred=abs(xflow)*dsqrt(Tt)/(a*Pt) -! -! optimised estimate of T static -! - Ts=Tt/(1+(Qred**2/C**2)) -! -! adiabatic -! - if(icase.eq.0) then -! - TtzTs_crit=(kappa+1.d0)/2.d0 -! -! isothermal -! - else -! - TtzTs_crit=(1d0+(kappa-1.d0)/(2.d0*kappa)) -! - endif -! - Qred_crit=C*(TtzTs_crit)**expon*(Ttzts_crit-1.d0)**0.5d0 -! -! xflow_crit=inv*Qred_crit/dsqrt(Tt)*A*Pt -! - if(Qred.ge.Qred_crit) then -! - Ts=Tt/TtzTs_crit -! - return -! - endif - i=0 -! - do - i=i+1 - Ttzts=Tt/Ts - h1=Ttzts-1.d0 - h2=dsqrt(h1) - h3=Ttzts**expon -! - f=C*h2*h3 -! - df=f*(expon+0.5d0*Ttzts/h1)/Ts -! - f=Qred-f - deltaTs=-f/df -! - Ts=Ts+deltaTs -! - if( (((dabs(Ts-Ts_old)/ts_old).le.1.E-8)) - & .or.((dabs(Ts-Ts_old)).le.1.E-10)) then - exit - else if(i.gt.20) then - Ts=0.9*Tt - exit - endif - Ts_old=Ts - enddo -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/twodint.f calculix-ccx-2.3/ccx_2.1/src/twodint.f --- calculix-ccx-2.1/ccx_2.1/src/twodint.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/twodint.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,229 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -C -C 1.TASK INTERPOLATION OF A TWO DIMENSIONAL FUNCTION DEFINED POINT BY POINT -C ********* THE X COORDINATES ARE USER SPECIFIED. -c THE INTERPOLATION TYPE CAN BE INDEPENDANTLY CHOSEN IN THE TWO DIRECTIONS -C EITHER CONSTANT, LINEAR OR DOUBLE QUADRATIC. -C BEYOND THE FIELD OF INTERPOLATION AN EXTRAOLATION IS CARRIED OUT. -C FOR ALL FOUR EXTRAPOLATION DIRECTIONS DIFFERENT EXTRAPOLATION METHOD -C (C ONSTANT,LINEAR,QUADRATIC) CAN BE CHOSEN, WHICH ORDER MUST NOT BE HIGHER -C THAN THE IONTERPOLATION ORDER -C -C 2.UP-AUFRUF CALL TWODINT(T,LSP,IART,XA,YA,ZA,NA,IEXP,IER) -C *********** T = MATRIX OF THE SAMPLE POINTS FORMATED AS FOLLOW -C T(1,1) = NX + NY * 0.001 -C NX = NUMBER OF LINES T -C NY = NUMBER OF COLUMNS T -C T(1,2) ... T(1,NY) -C VECTOR OF THE Y COORDINATES OF THE T MATRIX -C T(2,1) ... T(NX,1) -C VECTOR OF THE X COORDINATES OF THE T MATRIX -C REST OF T-MATRIX: -C POINT(X,Y) OF THE T MATRIX -C -C LSP = COLUMN STEPOF T -C IART = TYPE OF INTERPOLATION -C IART = INTX * 10 + INTY -C INTX INTERPOLATION TYPE IN X-DIRECTION -C INTY INTERPOLATION TYPE IN Y-DIRECTION -C XA = VECTOR OF THE X COORDINATES OF THE VALUE TO BE INTERPOLATED -C YA = VECTOR OF THE Y COORDINATES OF THE VALUE TO BE INTERPOLATED -C ZA = VECTOR OF THE INTERPOLATED VALUES -C NA = ACTUAL LENGTH OF THE 3 PREVIOUS VECTORS -C IEXP = TWO ELEMENT VECTOR CONTRAINING THE TYPE OF EXTRAPOLATION -C CHOSEN BEYOND THE INTERPOLATION DOMAIN -C IEXP(1): EXTRAPOLATION IN X-DIRECTION -C IEXP(1) = IEXPX1 * 10 + IEXPXN -C IEXPX1: EXTRAPOLATION BENEATH THE FIRST POINT -C IEXPXN: EXTRAPOLATION BEYOND THE LAST POINT -C IEXP(2): EXTRAPOLATION IN Y-DIRECTION -C IEXP(2) = IEXPY1 * 10 + IEXPYN -C SAME METHOD AS FOR IEXP(1): -C IER = ERROR CODE -C IER = 0: NORMAL PROCEEDING -C IER = -1: ERROR INPUTDATA -C -C REMARK: CHOICE OF THE INTER- EXTRAPOLATION TYPE IART AND IEXP - -C -------- ASSIGNEMENT OF INTX,INTY,IEXPX1, -C IEXPXN,IEXPY1,IEXPYN: -C = 0 : CONSTANT -C = 1 : LINEAR -C = 2 : DOUBLE QUADRATIC FROM -C THE SECOND UNTIL PENULTIMATE -C INTERVAL IN THE INTERPOLATION MATRIX T,OTHERWISE QUADRATIC -C -C 3.RESTRICTIONS THE SAMPLING POINT VECTORS (X UND Y COORDINATES -C *************** OF THE MATRICX T MUST BE STRICTLY MONOTONIC INCREASING SORTED -C THE PARAMETER FOR THE TYPE OF EXTRAPOLATION -c MUST NOT BE GREATER THAN THE ONE FOR TH EINTERPOLATION TYPE -C OTHERWISE THE VALUE IS AUTOMATICALLY ADAPTATED -C IF THE NUMBER OF THE SAMPLING POINTS FOR THE REQUIRED TYPE OF INTERPOLATION IS TOO SMALL, -C THE DEGREE OF INTERPOLATION WILL BE ACCORDINGLY ADAPTATED -C -C 4.USED UP'S ONEDINT (ONE DIMENSIONAL INTERPOLATION ANALOG TO THIS PROGRAMM) -C - - SUBROUTINE TWODINT (T,LSP,IART,XA,YA,ZA,NA,IEXP,IER) - IMPLICIT NONE - INTEGER IEXP(2),IYU,IYO,IXU,IXO,IDX,IDY,LL,INPY,IEXPX1,IEXPXN, - & IEXPY1,IEXPYN,LX,LY,INPX,IART,LSP,IER,NX,NY,L,NA - REAL*8 T(LSP,1),XA(1),YA(1),ZA(1) - REAL*8 Z1(4),Z2(4) -C ENTRY ZWEINT (T,LSP,IART,XA,YA,ZA,NA,IEXP,IER) - IER = 0 - NX = T(1,1) - NY = (T(1,1)-NX)*1000 + 0.1 -C -C TESTING INPUT -C-------------- - IF ((NX-2).lt.0) then - go to 900 - elseif((nx-2).eq.0) then - go to 30 - else - go to 10 - endif - 10 DO 20 L = 3,NX - 20 IF ((T(L,1)-T(L-1,1)) .LE. 0) GO TO 900 - 30 IF ((NY-2).lt.0) then - go to 900 - elseif((ny-2).eq.0) then - go to 60 - else - go to 40 - endif - 40 DO 50 L = 3,NY - 50 IF ((T(1,L)-T(1,L-1)) .LE. 0) GO TO 900 - 60 IF (NA .LE. 0) GO TO 900 -C -C DEFINING THE CONTROL VALUES -C--------------------------- - 100 INPX = IART/10 - INPY = IART - INPX*10 + 0.1 - IEXPX1 = IEXP(1)/10 - IEXPXN = IEXP(1) - IEXPX1*10 - IEXPY1 = IEXP(2)/10 - IEXPYN = IEXP(2) - IEXPY1*10 - IF (NX-2 .LT. INPX) INPX = NX - 2 - IF (NY-2 .LT. INPY) INPY = NY - 2 - IF (IEXPX1 .GT. INPX) IEXPX1 = INPX - IF (IEXPXN .GT. INPX) IEXPXN = INPX - IF (IEXPY1 .GT. INPY) IEXPY1 = INPY - IF (IEXPYN .GT. INPY) IEXPYN = INPY -C -C SUCCESSIVE PROCESSING THE INTERPOLATION EXIGENCES -C------------------------------------------------------- - DO 400 L = 1,NA - LX = 2 -C -C SETTING REFERENCE POINTS (LX,LY) -C--------------------------------- - 200 IF (XA(L) .LT. T(LX,1)) GO TO 220 - LX = LX + 1 - IF ((LX-NX).le.0) then - go to 200 - else - go to 210 - endif - 210 LX = NX - 220 DO 230 LY = 2,NY - 230 IF (YA(L) .LT. T(1,LY)) GO TO 235 - LY = NY - 235 IYU = LY - INPY - IYO = LY + INPY - 1 - IF (IYU .GE. 2) GO TO 240 - IYU = 2 - IYO = IYU + INPY - 240 IF (IYO .GT. NY) IYO = NY - IXU = LX - INPX - IXO = LX + INPX - 1 - IF (IXU .GE. 2) GO TO 245 - IXU = 2 - IXO = IXU + INPX - 245 IF (IXO .GT. NX) IXO = NX - IDX = IXO - IXU + 1 - IF (IXU .LT. IXO) GO TO 270 - IF (IYU .LT. IYO) GO TO 250 -C -C CONSTANT INTERPOLATION -C------------------------ - IF (LX .GT. 2 .AND. XA(L) .LT. T(NX,1)) LX = LX - 1 - IF (LY .GT. 2 .AND. YA(L) .LT. T(1,NY)) LY = LY - 1 - ZA(L) = T(LX,LY) - GO TO 400 -C -C LINEAR AND QUADRATIC INTERPOLATION USING ONEDINT (ONEDIMENSIONAL) -C--------------------------------------------------------------------- -C -C INTERPOLATION ONLY IN Y-DIRECTION -C - 250 IDY = 0 - DO 260 LL = IYU,IYO - IDY = IDY + 1 - Z1(IDY) = T(1,LL) - 260 Z2(IDY) = T(LX,LL) - GO TO 300 -C -C INTERPOLATION ONLY IN X-DIRECTION -C - 270 IF (IYU .LT. IYO) GO TO 280 - CALL ONEDINT(T(IXU,1),T(IXU,LY),IDX,XA(L),ZA(L),1,INPX,IEXP(1), - 1 IER) - IF (IER.eq.0) then - go to 400 - else - go to 900 - endif -C -C 1.INTERPOLATION STEP IN X-DIRECTION -C - 280 IDY = 0 - DO 290 LL = IYU,IYO - IDY = IDY + 1 - Z1(IDY) = T(1,LL) - CALL ONEDINT (T(IXU,1),T(IXU,LL),IDX,XA(L),Z2(IDY),1,INPX, - 1 IEXP(1),IER) - IF (IER.eq.0) then - go to 290 - else - go to 900 - endif - 290 CONTINUE -C -C 1.OR 2.INTERPOLATION STEP IN Y-DIRECTION -C - 300 CALL ONEDINT (Z1,Z2,IDY,YA(L),ZA(L),1,INPY,IEXP(2),IER) - IF (IER.eq.0) then - go to 400 - else - go to 900 - endif -C -C RETURN BY NORMAL PROCEEDING -C-------------------------------- - 400 CONTINUE - IER = 0 - RETURN -C -C ERROR RETURN -C------------- - 900 IER = -1 - RETURN - END diff -Nru calculix-ccx-2.1/ccx_2.1/src/two_phase_flow.f calculix-ccx-2.3/ccx_2.1/src/two_phase_flow.f --- calculix-ccx-2.1/ccx_2.1/src/two_phase_flow.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/two_phase_flow.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,267 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow_air, - & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,v, - & dvi_air,cp,r,k_oil,phi,lambda,nshcon,nrhcon,shcon - & ,rhcon,ntmat_,mi) -! -! two phase flow correlations -! - implicit none -! - character*8 lakon(*) -! - integer nelem,ielprop(*),index,mi(2), - & ipkon(*),kon(*),icase,kgas,k_oil,mtlog,ier,nshcon(*), - & nrhcon(*),ntmat_ -! - real*8 prop(*),v(0:mi(2),*),kappa,R,a,d,l, - & T1,T2,Tt1,Tt2,pt1,pt2,cp,dvi_air,dvi_oil, - & reynolds,lambda,ks,form_fact,f, - & l_neg,xflow_air,xflow_oil,A1,A2, - & rho_air,rho_oil,nue_air,nue_oil,zeta,reynolds_h,mpg, - & xp,xpm2,xpmini,isothermal,dvi_h,zeta_h,auxphi, - & rad,theta,phi,phizeta,x, - & rho_q,p1,shcon(0:3,ntmat_,*), - & rhcon(0:1,ntmat_,*),cp_oil,r_oil -! - parameter ( xpmini=1.E10) -! -! this subroutine enables to take in account the existence of -! 2 phase flows (air /oil) in some flow elements. -! -! the 2 following tables are used in Lockhart Martinelli Method. -! See table p.44 -! - real*8 TX(17),TF(17) - data TX - & /0.01d0,0.02d0,0.04d0,0.07d0, - & 0.10d0,0.20d0,0.40d0,0.70d0, - & 1.00d0,2.00d0,4.00d0,7.00d0, - & 10.0d0,20.0d0,40.0d0,70.0d0, - & 100.d0/ -! - data TF - & /1.28d0,1.37d0,1.54d0,1.71d0, - & 1.85d0,2.23d0,2.83d0,3.53d0, - & 4.20d0,6.20d0,9.50d0,13.7d0, - & 17.5d0,29.5d0,51.5d0,82.0d0, - & 111.d0/ -! - index=ielprop(nelem) - Tt2=Tt2 - pt2=pt2 - T2=t2 -! - if((lakon(nelem)(2:5).eq.'GAPF') - & .or.(lakon(nelem)(2:5).eq.'GAPI')) then - A=prop(index+1) - d=prop(index+2) - l=prop(index+3) - ks=prop(index+4) - form_fact=prop(index+5) - endif - - if(xflow_oil.eq.0) then - write(*,*) '*WARNING:in two_phase_flow' - write(*,*) 'massflow oil for element',nelem,'in null' - write(*,*) 'Calculation proceeds without oil correction' - phi=1.d0 - endif -! - - xflow_air=dabs(xflow_air) - kappa=Cp/(Cp-R) -! -! First case: -! the element is a restrictor of type -! THICK-WALLED ORIFICE IN LARGE WALL (L/DH > 0.015) -! I.E. IDL'CHIK (SECTION IV PAGE 144)! -! and -! Second case: -! the element is a restrictor of type -! SMOOTH BENDS B.H.R.A HANDBOOK (Miller) -! -! Two phase flow correlations are taken from: -! H.Zimmermann, A.Kammerer, R.Fischer and D. Rebhan -! "Two phase flow correlations in Air/Oil systems of -! Aero Engines." -! ASME 91-GT-54 -! - if((lakon(nelem)(2:7).eq.'RELOID').or. - & (lakon(nelem)(2:7).eq.'REBEMI')) then -! - icase=0 - - A1=prop(index+1) - A2=prop(index+2) - call ts_calc(xflow_air,Tt1,Pt1,kappa,r,A1,T1,icase) - - d=dsqrt(A1*4/(4.d0*datan(1.d0))) -! -! calculating the dynamic viscosity, the kinematic viscosity and -! the density of air -! - kgas=0 -! - P1=Pt1*(T1/Tt1)**(kappa/kappa-1) - rho_air=P1/(R*T1) - nue_air=dvi_air/rho_air -! -! calculating the dynamic viscosity, the kinematic viscosity and -! the density of oil -! - call materialdata_tg(k_oil,ntmat_,T1,shcon,nshcon,cp_oil,r_oil, - & dvi_oil,rhcon,nrhcon,rho_oil) -! - if(xflow_oil.eq.0) then -! -! pure air - call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,Kappa,v,mi) - lambda=zeta - return - else -! -! air/oil mixture for orifice or bend -! For Bend see section 4.2.1 -! For orifices see 4.2.3 - - mpg = xflow_air +xflow_oil - xp=xflow_air/mpg - if(mpg.gt.xflow_air*xpmini) then - xpm2=xpmini**2 - else - xpm2=(mpg/xflow_air)**2 - endif -! - rho_q=rho_oil/rho_air -! -! homogene dynamic viscosity (mass flow rate averaged) - dvi_h=dvi_oil*dvi_air/((dvi_oil-dvi_air)*xp+dvi_air) -! -! homogene reynolds number - reynolds_h=mpg*d/(A1*dvi_h) -! - call zeta_calc(nelem,prop,ielprop,lakon,reynolds_h,zeta_h, - & isothermal,kon,ipkon,R,Kappa,v,mi) -! -! orifice in a wall - if(lakon(nelem)(2:7).eq.'RELOID') then - - auxphi=(1.d0+xp*(rho_q**(1.d0/6.d0)-1.d0)) - & *(1.d0+xp*(rho_q**(5.d0/6.d0)-1.d0)) -! -! bend - elseif(lakon(nelem)(2:7).eq.'REBEMI') then -! -! radius of the bend - rad=prop(index+4) -! angle of the bend - theta=prop(index+5) -! - f=(1.d0+2.2d0*theta/90.d0/(zeta_h*(2.d0+rad/d))) - & *xp*(1.d0-xp)+xp**2 -! - auxphi=1.d0+(rho_q-1.d0)*f - endif -! - phi=1/rho_q*auxphi*xpm2 - phizeta=zeta_h/rho_q*auxphi*xpm2 - lambda=zeta_h -! - endif - -! Third case: -! the element is a pipe -! the zeta coefficient is corrected according to -! Lockhart Martinelli Method -! Reference: R.W. Lockhart and R.C. Martinelli -! University of California, BErkeley, California -! "Proposed correlation of data for -! isothermal two-phase two-component -! flow in pipes" -! Chemical Engineering Progress vol.45, N°1 -! - elseif(((lakon(nelem)(2:5).eq.'GAPF') - & .or. (lakon(nelem)(2:5).eq.'GAPI')) - & .or.((lakon(nelem)(2:7).ne.'REBEMI') - & .and.(lakon(nelem)(2:7)).ne.'RELOID'))then -! - if((lakon(nelem)(2:6).eq.'GAPFA') - & .or.(lakon(nelem)(2:6).eq.'GAPIA'))then - icase=0 - elseif((lakon(nelem)(2:6).eq.'GAPFI') - & .or.(lakon(nelem)(2:6).eq.'GAPII'))then - icase=1 - else - icase=0 - endif -! - if((lakon(nelem)(2:3).eq.'RE').and. - & (lakon(nelem)(4:5).ne.'BR')) then - a=min(prop(index+1),prop(index+2)) - endif -! - call ts_calc(xflow_air,Tt1,Pt1,kappa,r,a,T1,icase) -! -! calculating kinematic viscosity and density for air -! - P1=Pt1*(T1/Tt1)**(kappa/kappa-1) - rho_air=P1/(R*T1) - nue_air=dvi_air/rho_air -! -! calculation of the dynamic viscosity for oil -! - call materialdata_tg(k_oil,ntmat_,T1,shcon,nshcon,cp_oil,r_oil, - & dvi_oil,rhcon,nrhcon,rho_oil) -! - nue_oil=dvi_oil/rho_oil -! -! Definition of the two phase flow modulus as defined in table 1 -! - x=dabs(xflow_oil/xflow_air)*(rho_air/rho_oil)**(0.553d0) - & *(nue_oil/nue_air)**(0.111d0) -! - mtlog=17 -! Interpolating x in the table - call onedint(TX,TF,mtlog,x,phi,1,2,11,IER) -! - if((lakon(nelem)(2:4).eq.'GAP'))then -! -! Computing the friction coefficient -! - reynolds=dabs(xflow_air)*d/(dvi_air*a) -! - if(reynolds.lt.100.d0) then - reynolds= 100.d0 - endif -! - call friction_coefficient(l_neg,d,ks,reynolds,form_fact, - & lambda) - else - lambda=0 - endif - endif -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/uamplitude.f calculix-ccx-2.3/ccx_2.1/src/uamplitude.f --- calculix-ccx-2.1/ccx_2.1/src/uamplitude.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/uamplitude.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine uamplitude(time,name,amplitude) -! -! user subroutine uamplitude: user defined amplitude definition -! -! INPUT: -! -! name amplitude name -! time time at which the amplitude is to be -! evaluated -! -! OUTPUT: -! -! amplitude value of the amplitude at time -! - implicit none -! - character*80 name -! - real*8 time,amplitude -! - if(name(1:9).eq.'QUADRATIC') then - amplitude=time**2 - else - write(*,*) '*ERROR in uamplitude: unknown amplitude' - stop - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/uboun.f calculix-ccx-2.3/ccx_2.1/src/uboun.f --- calculix-ccx-2.1/ccx_2.1/src/uboun.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/uboun.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine uboun(boun,kstep,kinc,time,node,idof,coords,vold,mi) -! -! user subroutine uboun -! -! -! INPUT: -! -! kstep step number -! kinc increment number -! time(1) current step time -! time(2) current total time -! node node number -! idof degree of freedom -! coords (1..3) global coordinates of the node -! vold(0..4,1..nk) solution field in all nodes -! 0: temperature -! 1: displacement in global x-direction -! (or mass flow rate for fluid nodes) -! 2: displacement in global y-direction -! 3: displacement in global z-direction -! 4: static pressure -! mi(1) max # of integration points per element (max -! over all elements) -! mi(2) max degree of freedomm per node (max over all -! nodes) in fields like v(0:mi(2))... -! -! OUTPUT: -! -! boun boundary value for degree of freedom idof -! in node "node" -! - implicit none -! - integer kstep,kinc,node,idof,mi(2) - real*8 boun,time(2),coords(3),vold(0:mi(2),*) -! - boun=10.d0 -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/u_calloc.c calculix-ccx-2.3/ccx_2.1/src/u_calloc.c --- calculix-ccx-2.1/ccx_2.1/src/u_calloc.c 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/u_calloc.c 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ - -/* CalculiX - A 3-dimensional finite element program */ -/* Copyright (C) 1998-2007 Guido Dhondt */ - -/* This program is free software; you can redistribute it and/or */ -/* modify it under the terms of the GNU General Public License as */ -/* published by the Free Software Foundation(version 2); */ -/* */ - -/* This program is distributed in the hope that it will be useful, */ -/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ -/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ -/* GNU General Public License for more details. */ - -/* You should have received a copy of the GNU General Public License */ -/* along with this program; if not, write to the Free Software */ -/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ - -#include -#include -/* - Diehl program -*/ - -void *u_calloc(size_t num,size_t size){ - - void *a; - if(num==0){ - a=NULL; - return(a); - } - - a=calloc(num,size); - if(a==NULL){ - printf("*ERROR in u_calloc: error allocating memory\n"); - printf("num=%ld,size=%ld\n",num,size); - exit(16); - } - else { - return(a); - } -} diff -Nru calculix-ccx-2.1/ccx_2.1/src/ucreep.f calculix-ccx-2.3/ccx_2.1/src/ucreep.f --- calculix-ccx-2.1/ccx_2.1/src/ucreep.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ucreep.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine ucreep(amat,iel,iint,t1l,epini,ep,dtime,svm,dsvm) -! -! INPUT: -! -! amat: material name -! iel: element number -! iint: integration point number -! t1l: temperature -! epini: equivalent creep strain at the start -! of the increment -! ep: present equivalent creep strain; values of ep < epini -! are equivalent to ep=epini. -! dtime: time increment -! -! OUTPUT: -! -! svm: present Von Mises stress -! dsvm: derivative of the Von Mises true stress with respect -! to the present equivalent creep strain. -! Numerically: change the present equivalent -! strain with a small amount, calculate the amount -! of change this causes in the present Von Mises -! true stress, and divide the latter amount through the -! former amount. -! - implicit none -! - character*80 amat - real*8 t1l,epini,ep,dtime,svm,dsvm -! - integer iel,iint - if(ep.le.epini) then - svm=0.d0 - dsvm=1.d10 - else - svm=((ep-epini)/(dtime*1.d-10))**0.2d0 - dsvm=((ep-epini)/(dtime*1.d-10))**(-0.8d0)/(5.d-10*dtime) - endif -! - RETURN - end - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/ufaceload.f calculix-ccx-2.3/ccx_2.1/src/ufaceload.f --- calculix-ccx-2.1/ccx_2.1/src/ufaceload.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/ufaceload.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,54 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine ufaceload(co,ipkon,kon,lakon, - & nelemload,sideload,nload) -! -! -! INPUT: -! -! co(0..3,1..nk) coordinates of the nodes -! ipkon(*) element topology pointer into field kon -! kon(*) topology vector of all elements -! lakon(*) vector with elements labels -! nelemload(1..2,*) 1: elements faces of which are loaded -! 2: nodes for environmental temperatures -! sideload(*) load label -! nload number of facial distributed loads -! -! user routine called at the start of each step; possible use: -! calculation of the area of sets of elements for -! further use to calculate film or radiation coefficients. -! The areas can be shared using common blocks. -! - implicit none -! - character*8 lakon(*) - character*20 sideload(*) -! - integer nelemload(2,*),nload,kon(*),ipkon(*) -! - real*8 co(3,*) -! -! enter code here -! - return - end - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/uhardening.f calculix-ccx-2.3/ccx_2.1/src/uhardening.f --- calculix-ccx-2.1/ccx_2.1/src/uhardening.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/uhardening.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,53 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine uhardening(amat,iel,iint,t1l,epini,ep,dtime,fiso,dfiso, - & fkin,dfkin) -! -! hardening user subroutine -! -! INPUT: -! -! amat: material name (maximum 20 characters) -! iel: element number -! iint: integration point number -! t1l: temperature at the end of the increment -! epini: equivalent irreversible strain at the start -! of the increment -! ep: present equivalent irreversible strain -! dtime: time increment -! -! OUTPUT: -! -! fiso: present isotropic hardening Von Mises stress -! dfiso: present isotropic hardening tangent (derivative -! of the Von Mises stress with respect to the -! equivalent irreversible strain) -! fkin: present kinematic hardening Von Mises stress -! dfkin: present kinematic hardening tangent (derivative -! of the Von Mises stress with respect to the -! equivalent irreversible strain) -! - implicit none -! - character*80 amat - integer iel,iint - real*8 t1l,epini,ep,dtime,fiso,dfiso,fkin,dfkin -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_abaqus.f calculix-ccx-2.3/ccx_2.1/src/umat_abaqus.f --- calculix-ccx-2.1/ccx_2.1/src/umat_abaqus.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_abaqus.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,351 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_abaqus(amat,iel,iint,kode,elconloc,emec,emec0, - & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi,nstate_,xstateini,xstate,stre,stiff, - & iorien,pgauss,orab,kstep,kinc) -! -! calculates stiffness and stresses for a nonlinear material -! defined by an ABAQUS umat routine -! -! icmd=3: calcutates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! 3: calculate only stress -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! -! This routine allows for the use of an ABAQUS umat user subroutine -! in CalculiX. -! -! Note that the following fields are not supported -! so far: sse,spd,scd,rpl,ddsddt,drplde,drpldt,predef, -! dpred,drot,pnewdt,celent,layer,kspt -! -! Furthermore, the following fields have a different meaning in -! ABAQUS and CalculiX: -! -! stran: in CalculiX: Lagrangian strain tensor -! in ABAQUS: logarithmic strain tensor -! dstran: in CalculiX: Lagrangian strain increment tensor -! in ABAQUS: logarithmic strain increment tensor -! temp: in CalculiX: temperature at the end of the increment -! in ABAQUS: temperature at the start of the increment -! dtemp: in CalculiX: zero -! in ABAQUS: temperature increment -! -! Because of this, this routine should only be used for small -! deformations and small rotations (in that case all strain -! measures basically reduce to the infinitesimal strain). -! - implicit none -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),i,iorien, - & ndi,nshr,ntens,nprops,layer,kspt,kstep,kinc,kal(2,6),kel(4,21), - & j1,j2,j3,j4,j5,j6,j7,j8,jj -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), - & time,ttime,skl(3,3),xa(3,3),ya(3,3,3,3),xstate(nstate_,mi(1),*), - & xstateini(nstate_,mi(1),*) -! - real*8 ddsdde(6,6),sse,spd,scd,rpl,ddsddt(6),drplde(6), - & drpldt,stran(6),dstran(6),abqtime(2),predef,temp,dtemp, - & dpred,drot(3,3),celent,pnewdt -! - data kal /1,1,2,2,3,3,1,2,1,3,2,3/ -! - data kel /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, - & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3, - & 3,3,1,3,1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3, - & 1,2,2,3,1,3,2,3,2,3,2,3/ -! - data drot /1.d0,0.d0,0.d0,0.d0,1.d0,0.d0,0.d0,0.d0,1.d0/ -! -! calculating the mechanical strain -! - do i=1,6 - stran(i)=emec0(i) - dstran(i)=emec(i)-emec0(i) - enddo -! - ntens=6 -! - do i=1,nstate_ - xstate(i,iint,iel)=xstateini(i,iint,iel) - enddo -! - abqtime(1)=time-dtime - abqtime(2)=ttime -! - temp=t1l - dtemp=0.d0 -! - ndi=3 - nshr=3 - ntens=ndi+nshr -! - nprops=-kode-100 -c nprops=21 -! -! taking local material orientations into account -! - if(iorien.ne.0) then - call transformatrix(orab(1,iorien),pgauss,skl) -! -! rotating the stress into the local system -! - xa(1,1)=stre(1) - xa(1,2)=stre(4) - xa(1,3)=stre(5) - xa(2,1)=stre(4) - xa(2,2)=stre(2) - xa(2,3)=stre(6) - xa(3,1)=stre(5) - xa(3,2)=stre(6) - xa(3,3)=stre(3) -! - do jj=1,6 - stre(jj)=0.d0 - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - stre(jj)=stre(jj)+ - & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) - enddo - enddo - enddo -! -! rotating the strain into the local system -! - xa(1,1)=stran(1) - xa(1,2)=stran(4) - xa(1,3)=stran(5) - xa(2,1)=stran(4) - xa(2,2)=stran(2) - xa(2,3)=stran(6) - xa(3,1)=stran(5) - xa(3,2)=stran(6) - xa(3,3)=stran(3) -! - do jj=1,6 - stran(jj)=0.d0 - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - stran(jj)=stran(jj)+ - & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) - enddo - enddo - enddo -! -! rotating the strain increment into the local system -! - xa(1,1)=dstran(1) - xa(1,2)=dstran(4) - xa(1,3)=dstran(5) - xa(2,1)=dstran(4) - xa(2,2)=dstran(2) - xa(2,3)=dstran(6) - xa(3,1)=dstran(5) - xa(3,2)=dstran(6) - xa(3,3)=dstran(3) -! - do jj=1,6 - dstran(jj)=0.d0 - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - dstran(jj)=dstran(jj)+ - & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) - enddo - enddo - enddo - endif -! - call umat(stre,xstate(1,iint,iel),ddsdde,sse,spd,scd,rpl,ddsddt, - & drplde,drpldt,stran,dstran,abqtime,dtime,temp,dtemp,predef, - & dpred,amat,ndi,nshr,ntens,nstate_,elconloc,nprops,pgauss,drot, - & pnewdt,celent,xokl,xkl,iel,iint,layer,kspt,kstep,kinc) -! -! taking local material orientations into account -! - if(iorien.ne.0) then -! -! rotating the stress into the global system -! - xa(1,1)=stre(1) - xa(1,2)=stre(4) - xa(1,3)=stre(5) - xa(2,1)=stre(4) - xa(2,2)=stre(2) - xa(2,3)=stre(6) - xa(3,1)=stre(5) - xa(3,2)=stre(6) - xa(3,3)=stre(3) -! - do jj=1,6 - stre(jj)=0.d0 - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - stre(jj)=stre(jj)+ - & xa(j3,j4)*skl(j1,j3)*skl(j2,j4) - enddo - enddo - enddo - endif -! -! calculate the stiffness matrix -! - if(icmd.ne.3) then - stiff(1)=ddsdde(1,1) - stiff(2)=ddsdde(1,2) - stiff(3)=ddsdde(2,2) - stiff(4)=ddsdde(1,3) - stiff(5)=ddsdde(2,3) - stiff(6)=ddsdde(3,3) - stiff(7)=ddsdde(1,4) - stiff(8)=ddsdde(2,4) - stiff(9)=ddsdde(3,4) - stiff(10)=ddsdde(4,4) - stiff(11)=ddsdde(1,5) - stiff(12)=ddsdde(2,5) - stiff(13)=ddsdde(3,5) - stiff(14)=ddsdde(4,5) - stiff(15)=ddsdde(5,5) - stiff(16)=ddsdde(1,6) - stiff(17)=ddsdde(2,6) - stiff(18)=ddsdde(3,6) - stiff(19)=ddsdde(4,6) - stiff(20)=ddsdde(5,6) - stiff(21)=ddsdde(6,6) -! - if(iorien.ne.0) then -! -! rotating the stiffness coefficients into the global system -! - call anisotropic(stiff,ya) -! - do jj=1,21 - j1=kel(1,jj) - j2=kel(2,jj) - j3=kel(3,jj) - j4=kel(4,jj) - stiff(jj)=0.d0 - do j5=1,3 - do j6=1,3 - do j7=1,3 - do j8=1,3 - stiff(jj)=stiff(jj)+ya(j5,j6,j7,j8)* - & skl(j1,j5)*skl(j2,j6)*skl(j3,j7)*skl(j4,j8) - enddo - enddo - enddo - enddo - enddo - endif - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_abaqusnl.f calculix-ccx-2.3/ccx_2.1/src/umat_abaqusnl.f --- calculix-ccx-2.1/ccx_2.1/src/umat_abaqusnl.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_abaqusnl.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,616 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_abaqusnl(amat,iel,iint,kode,elconloc,emec,emec0, - & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi,nstate_,xstateini,xstate,stre,stiff, - & iorien,pgauss,orab,kstep,kinc) -! -! calculates stiffness and stresses for a nonlinear material -! defined by an ABAQUS umat routine -! -! icmd=3: calcutates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! 3: calculate only stress -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! -! This routine allows for the use of an ABAQUS umat user subroutine -! in CalculiX. -! -! Note that the following fields are not supported -! so far: sse,spd,scd,rpl,ddsddt,drplde,drpldt,predef, -! dpred,pnewdt,celent,layer,kspt -! -! Furthermore, the following fields have a different meaning in -! ABAQUS and CalculiX: -! -! temp: in CalculiX: temperature at the end of the increment -! in ABAQUS: temperature at the start of the increment -! dtemp: in CalculiX: zero -! in ABAQUS: temperature increment -! - implicit none -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),i,iorien, - & ndi,nshr,ntens,nprops,layer,kspt,kstep,kinc,kal(2,6),kel(4,21), - & j1,j2,j3,j4,j5,j6,j7,j8,jj,n,ier,j,matz -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), - & time,ttime,skl(3,3),xa(3,3),ya(3,3,3,3),xstate(nstate_,mi(1),*), - & xstateini(nstate_,mi(1),*),w(3),fv1(3),fv2(3),d(6), - & v1,v2,v3,c(6),r(3,3),r0(3,3),eln0(6),eln(6),e(3,3),tkl(3,3), - & u(6),c2(6),dd,um1(3,3),z(3,3),u0(3,3) -! - real*8 ddsdde(6,6),sse,spd,scd,rpl,ddsddt(6),drplde(6), - & drpldt,stran(6),dstran(6),abqtime(2),predef,temp,dtemp, - & dpred,drot(3,3),celent,pnewdt -! - data kal /1,1,2,2,3,3,1,2,1,3,2,3/ -! - data kel /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, - & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3, - & 3,3,1,3,1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3, - & 1,2,2,3,1,3,2,3,2,3,2,3/ -! - data d /1.d0,1.d0,1.d0,0.d0,0.d0,0.d0/ -! -! calculating the logarithmic mechanical strain at the -! start of the increment -! - e(1,1)=emec0(1) - e(2,2)=emec0(2) - e(3,3)=emec0(3) - e(1,2)=emec0(4) - e(1,3)=emec0(5) - e(2,3)=emec0(6) - e(2,1)=emec0(4) - e(3,1)=emec0(5) - e(3,2)=emec0(6) -! -! calculating the eigenvalues and eigenvectors -! - n=3 - matz=1 -! - call rs(n,n,e,w,matz,z,fv1,fv2,ier) -! - if(ier.ne.0) then - write(*,*) ' - & *ERROR calculating the eigenvalues/vectors in umat_abaqusnl' - stop - endif -! -! calculating the principal stretches at the start of the increment -! - do i=1,3 - w(i)=dsqrt(2.d0*w(i)+1.d0) - enddo -! -! calculating the invariants at the start of the increment -! - v1=w(1)+w(2)+w(3) - v2=w(1)*w(2)+w(2)*w(3)+w(3)*w(1) - v3=w(1)*w(2)*w(3) -! -! calculating the right Cauchy-Green tensor at the start of the -! increment -! - do i=1,3 - c(i)=2.d0*emec0(i)+1.d0 - enddo - do i=4,6 - c(i)=2.d0*emec0(i) - enddo -! -! calculating the square of the right Cauchy-Green tensor at the -! start of the increment -! - c2(1)=c(1)*c(1)+c(4)*c(4)+c(5)*c(5) - c2(2)=c(4)*c(4)+c(2)*c(2)+c(6)*c(6) - c2(3)=c(5)*c(5)+c(6)*c(6)+c(3)*c(3) - c2(4)=c(1)*c(4)+c(4)*c(2)+c(5)*c(6) - c2(5)=c(1)*c(5)+c(4)*c(6)+c(5)*c(3) - c2(6)=c(4)*c(5)+c(2)*c(6)+c(6)*c(3) -! -! calculating the right stretch tensor at the start of the increment -! (cf. Simo and Hughes, Computational Inelasticity) -! - dd=v1*v2-v3 - do i=1,6 - u(i)=(-c2(i)+(v1*v1-v2)*c(i)+v1*v3*d(i))/dd - enddo -! - u0(1,1)=u(1) - u0(2,2)=u(2) - u0(3,3)=u(3) - u0(1,2)=u(4) - u0(1,3)=u(5) - u0(2,3)=u(6) - u0(2,1)=u(4) - u0(3,1)=u(5) - u0(3,2)=u(6) -! -! calculating the inverse of the right stretch tensor at the start -! of the increment -! - um1(1,1)=(c(1)-v1*u(1)+v2)/v3 - um1(2,2)=(c(2)-v1*u(2)+v2)/v3 - um1(3,3)=(c(3)-v1*u(3)+v2)/v3 - um1(1,2)=(c(4)-v1*u(4))/v3 - um1(1,3)=(c(5)-v1*u(5))/v3 - um1(2,3)=(c(6)-v1*u(6))/v3 - um1(2,1)=um1(1,2) - um1(3,1)=um1(1,3) - um1(3,2)=um1(2,3) -! -! calculation of the local rotation tensor at the start of the -! increment -! - do i=1,3 - do j=1,3 - r0(i,j)=xokl(i,1)*um1(1,j)+xokl(i,2)*um1(2,j)+ - & xokl(i,3)*um1(3,j) - enddo - enddo -! -! calculating the logarithmic strain at the start of the increment -! - do i=1,3 - w(i)=log(w(i)) - enddo -! -! logarithmic strain in global coordinates at the start of the -! increment -! - eln0(1)=z(1,1)*z(1,1)*w(1)+z(1,2)*z(1,2)*w(2)+ - & z(1,3)*z(1,3)*w(3) - eln0(2)=z(2,1)*z(2,1)*w(1)+z(2,2)*z(2,2)*w(2)+ - & z(2,3)*z(2,3)*w(3) - eln0(3)=z(3,1)*z(3,1)*w(1)+z(3,2)*z(3,2)*w(2)+ - & z(3,3)*z(3,3)*w(3) - eln0(4)=z(1,1)*z(2,1)*w(1)+z(1,2)*z(2,2)*w(2)+ - & z(1,3)*z(2,3)*w(3) - eln0(5)=z(1,1)*z(3,1)*w(1)+z(1,2)*z(3,2)*w(2)+ - & z(1,3)*z(3,3)*w(3) - eln0(6)=z(2,1)*z(3,1)*w(1)+z(2,2)*z(3,2)*w(2)+ - & z(2,3)*z(3,3)*w(3) -! -! calculating the logarithmic mechanical strain at the -! end of the increment -! - e(1,1)=emec(1) - e(2,2)=emec(2) - e(3,3)=emec(3) - e(1,2)=emec(4) - e(1,3)=emec(5) - e(2,3)=emec(6) - e(2,1)=emec(4) - e(3,1)=emec(5) - e(3,2)=emec(6) -! -! calculating the eigenvalues and eigenvectors -! - call rs(n,n,e,w,matz,z,fv1,fv2,ier) -! - if(ier.ne.0) then - write(*,*) ' - & *ERROR calculating the eigenvalues/vectors in umat_abaqusnl' - stop - endif -! -! calculating the principal stretches at the end of the increment -! - do i=1,3 - w(i)=dsqrt(2.d0*w(i)+1.d0) - enddo -! -! calculating the invariants at the end of the increment -! - v1=w(1)+w(2)+w(3) - v2=w(1)*w(2)+w(2)*w(3)+w(3)*w(1) - v3=w(1)*w(2)*w(3) -! -! calculating the right Cauchy-Green tensor at the end of the -! increment -! - do i=1,3 - c(i)=2.d0*emec0(i)+1.d0 - enddo - do i=4,6 - c(i)=2.d0*emec0(i) - enddo -! -! calculating the square of the right Cauchy-Green tensor at the -! end of the increment -! - c2(1)=c(1)*c(1)+c(4)*c(4)+c(5)*c(5) - c2(2)=c(4)*c(4)+c(2)*c(2)+c(6)*c(6) - c2(3)=c(5)*c(5)+c(6)*c(6)+c(3)*c(3) - c2(4)=c(1)*c(4)+c(4)*c(2)+c(5)*c(6) - c2(5)=c(1)*c(5)+c(4)*c(6)+c(5)*c(3) - c2(6)=c(4)*c(5)+c(2)*c(6)+c(6)*c(3) -! -! calculating the right stretch tensor at the end of the increment -! (cf. Simo and Hughes, Computational Inelasticity) -! - dd=v1*v2-v3 - do i=1,6 - u(i)=(-c2(i)+(v1*v1-v2)*c(i)+v1*v3*d(i))/dd - enddo -! -! calculating the inverse of the right stretch tensor at the end -! of the increment -! - um1(1,1)=(c(1)-v1*u(1)+v2)/v3 - um1(2,2)=(c(2)-v1*u(2)+v2)/v3 - um1(3,3)=(c(3)-v1*u(3)+v2)/v3 - um1(1,2)=(c(4)-v1*u(4))/v3 - um1(1,3)=(c(5)-v1*u(5))/v3 - um1(2,3)=(c(6)-v1*u(6))/v3 - um1(2,1)=um1(1,2) - um1(3,1)=um1(1,3) - um1(3,2)=um1(2,3) -! -! calculation of the local rotation tensor at the end of the -! increment -! - do i=1,3 - do j=1,3 - r(i,j)=xokl(i,1)*um1(1,j)+xokl(i,2)*um1(2,j)+ - & xokl(i,3)*um1(3,j) - enddo - enddo -! -! calculating the logarithmic strain at the end of the increment -! Elog=Z.ln(w).Z^T -! - do i=1,3 - w(i)=log(w(i)) - enddo -! -! logarithmic strain in global coordinates at the end of the -! increment -! - eln(1)=z(1,1)*z(1,1)*w(1)+z(1,2)*z(1,2)*w(2)+ - & z(1,3)*z(1,3)*w(3) - eln(2)=z(2,1)*z(2,1)*w(1)+z(2,2)*z(2,2)*w(2)+ - & z(2,3)*z(2,3)*w(3) - eln(3)=z(3,1)*z(3,1)*w(1)+z(3,2)*z(3,2)*w(2)+ - & z(3,3)*z(3,3)*w(3) - eln(4)=z(1,1)*z(2,1)*w(1)+z(1,2)*z(2,2)*w(2)+ - & z(1,3)*z(2,3)*w(3) - eln(5)=z(1,1)*z(3,1)*w(1)+z(1,2)*z(3,2)*w(2)+ - & z(1,3)*z(3,3)*w(3) - eln(6)=z(2,1)*z(3,1)*w(1)+z(2,2)*z(3,2)*w(2)+ - & z(2,3)*z(3,3)*w(3) -c write(*,*) 'iel', iel -c write(*,*) 'emec',(emec(i),i=1,6) -c write(*,*) 'eln',(eln(i),i=1,6) -c write(*,*) 'r0',((r0(i,j),j=1,3),i=1,3) -c write(*,*) 'r',((r(i,j),j=1,3),i=1,3) -! -! calculating the incremental rotation tensor -! drot=r.r0^T -! - do i=1,3 - do j=1,3 - drot(i,j)=r(i,1)*r0(j,1)+r(i,2)*r0(j,2)+r(i,3)*r0(j,3) - enddo - enddo -! - ntens=6 -! - do i=1,nstate_ - xstate(i,iint,iel)=xstateini(i,iint,iel) - enddo -! - abqtime(1)=time-dtime - abqtime(2)=ttime -! - temp=t1l - dtemp=0.d0 -! - ndi=3 - nshr=3 - ntens=ndi+nshr -! - nprops=-kode-100 -! -! taking local material orientations into account -! - if(iorien.ne.0) then - call transformatrix(orab(1,iorien),pgauss,skl) -! -! rotating the strain at the start of the increment -! into the local system: Elog'=T^T.Elog.T -! - xa(1,1)=eln0(1) - xa(1,2)=eln0(4) - xa(1,3)=eln0(5) - xa(2,1)=eln0(4) - xa(2,2)=eln0(2) - xa(2,3)=eln0(6) - xa(3,1)=eln0(5) - xa(3,2)=eln0(6) - xa(3,3)=eln0(3) -! - do jj=1,6 - stran(jj)=0.d0 - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - stran(jj)=stran(jj)+ - & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) - enddo - enddo - enddo -! -! rotating the strain at the end of the increment -! into the local system -! - xa(1,1)=eln(1) - xa(1,2)=eln(4) - xa(1,3)=eln(5) - xa(2,1)=eln(4) - xa(2,2)=eln(2) - xa(2,3)=eln(6) - xa(3,1)=eln(5) - xa(3,2)=eln(6) - xa(3,3)=eln(3) -! - do jj=1,6 - dstran(jj)=-stran(jj) - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - dstran(jj)=dstran(jj)+ - & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) - enddo - enddo - enddo - else - do jj=1,6 - stran(jj)=eln0(jj) - dstran(jj)=eln(jj)-eln0(jj) - enddo - endif -! -! rotating the stress into the local system -! s'=J^(-1).U.S.U^T (no orientation card) or -! s'=J^(-1).U.T^T.S.T.U^T (orientation card) -! - if(iorien.ne.0) then - do i=1,3 - do j=1,3 - tkl(i,j)=u0(i,1)*skl(j,1)+u0(i,2)*skl(j,2)+ - & u0(i,3)*skl(j,3) - enddo - enddo - else - do i=1,3 - do j=1,3 - tkl(i,j)=u0(i,j) - enddo - enddo - endif -! - xa(1,1)=stre(1) - xa(1,2)=stre(4) - xa(1,3)=stre(5) - xa(2,1)=stre(4) - xa(2,2)=stre(2) - xa(2,3)=stre(6) - xa(3,1)=stre(5) - xa(3,2)=stre(6) - xa(3,3)=stre(3) -! - do jj=1,6 - stre(jj)=0.d0 - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - stre(jj)=stre(jj)+ - & xa(j3,j4)*tkl(j1,j3)*tkl(j2,j4) - enddo - enddo - stre(jj)=stre(jj)/voj - enddo -! - call umat(stre,xstate(1,iint,iel),ddsdde,sse,spd,scd,rpl,ddsddt, - & drplde,drpldt,stran,dstran,abqtime,dtime,temp,dtemp,predef, - & dpred,amat,ndi,nshr,ntens,nstate_,elconloc,nprops,pgauss,drot, - & pnewdt,celent,xokl,xkl,iel,iint,layer,kspt,kstep,kinc) -! -! rotating the stress into the global system -! S=J.U^(-1).s'.U^(-T) (no orientation card) or -! S=J.T.U^(-1).s'.U^(-T).T^T (orientation card) -! - if(iorien.ne.0) then - do i=1,3 - do j=1,3 - tkl(i,j)=skl(i,1)*um1(1,j)+skl(i,2)*um1(2,j)+ - & skl(i,3)*um1(3,j) - enddo - enddo - else - do i=1,3 - do j=1,3 - tkl(i,j)=um1(i,j) - enddo - enddo - endif -! - xa(1,1)=stre(1) - xa(1,2)=stre(4) - xa(1,3)=stre(5) - xa(2,1)=stre(4) - xa(2,2)=stre(2) - xa(2,3)=stre(6) - xa(3,1)=stre(5) - xa(3,2)=stre(6) - xa(3,3)=stre(3) -! - do jj=1,6 - stre(jj)=0.d0 - j1=kal(1,jj) - j2=kal(2,jj) - do j3=1,3 - do j4=1,3 - stre(jj)=stre(jj)+ - & xa(j3,j4)*tkl(j1,j3)*tkl(j2,j4) - enddo - enddo - stre(jj)=stre(jj)*vj - enddo -! -! calculate the stiffness matrix -! - if(icmd.ne.3) then - stiff(1)=ddsdde(1,1) - stiff(2)=ddsdde(1,2) - stiff(3)=ddsdde(2,2) - stiff(4)=ddsdde(1,3) - stiff(5)=ddsdde(2,3) - stiff(6)=ddsdde(3,3) - stiff(7)=ddsdde(1,4) - stiff(8)=ddsdde(2,4) - stiff(9)=ddsdde(3,4) - stiff(10)=ddsdde(4,4) - stiff(11)=ddsdde(1,5) - stiff(12)=ddsdde(2,5) - stiff(13)=ddsdde(3,5) - stiff(14)=ddsdde(4,5) - stiff(15)=ddsdde(5,5) - stiff(16)=ddsdde(1,6) - stiff(17)=ddsdde(2,6) - stiff(18)=ddsdde(3,6) - stiff(19)=ddsdde(4,6) - stiff(20)=ddsdde(5,6) - stiff(21)=ddsdde(6,6) -! -! rotating the stiffness coefficients into the global system -! - call anisotropic(stiff,ya) -! - do jj=1,21 - j1=kel(1,jj) - j2=kel(2,jj) - j3=kel(3,jj) - j4=kel(4,jj) - stiff(jj)=0.d0 - do j5=1,3 - do j6=1,3 - do j7=1,3 - do j8=1,3 - stiff(jj)=stiff(jj)+ya(j5,j6,j7,j8)* - & tkl(j1,j5)*tkl(j2,j6)*tkl(j3,j7)*tkl(j4,j8) - enddo - enddo - enddo - enddo - enddo - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_aniso_creep.f calculix-ccx-2.3/ccx_2.1/src/umat_aniso_creep.f --- calculix-ccx-2.1/ccx_2.1/src/umat_aniso_creep.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_aniso_creep.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1189 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_aniso_creep(amat,iel,iint,kode,elconloc,emec, - & emec0,beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas, - & mi,nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, - & orab) -! -! calculates stiffness and stresses for a user defined material -! law -! -! icmd=3: calculates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account: for -! creep this does not make sense. -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! 3: calculate only stress -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! Notice that the matrix is an integral part of the -! fourth order material tensor, i.e. the Voigt notation -! is not used. -! - implicit none -! - logical interval,cauchy,exitcriterion -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien -! - integer i,j,ipiv(6),info,neq,lda,ldb,j1,j2,j3,j4,j5,j6,j7,j8, - & nrhs,iplas,kel(4,21),iloop,leximp,lend,layer,kspt,kstep, - & kinc,ii -! - real*8 ep0(6),epqini,ep(6),b,Pn(6),dg,ddg,c(21),x(21),cm1(21), - & stri(6),htri,sg(6),r(13),ee(6),dd,gl(6,6),gr(6,6),c0,c1,c2, - & skl(3,3),gcreep,gm1,ya(3,3,3,3),dsg,detc,strinv, - & depq,svm,dsvm,dg1,dg2,fu,fu1,fu2,expon,ec(2), - & timeabq(2),r1(13),ep1(6),gl1(6,6),sg1(6),ckl(3,3) -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), - & time,ttime,decra(5),deswa(5),serd,esw(2),p,predef(1),dpred(1), - & dtemp -! - real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) -! - data kel /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, - & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3, - & 3,3,1,3,1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3, - & 1,2,2,3,1,3,2,3,2,3,2,3/ -! - data leximp /1/ - data lend /3/ -! - if(ithermal.eq.0) then - write(*,*)'*ERROR in umat_aniso_creep: no temperature defined;' - write(*,*) ' a creep calculation without temperature' - write(*,*) ' does not make sense' - write(*,*) - stop - endif -! - iloop=0 - exitcriterion=.false. -! - c0=dsqrt(2.d0/3.d0) - c1=2.d0/3.d0 - c2=-1.d0/3.d0 -! -! elastic constants -! - if(iorien.gt.0) then -! - call transformatrix(orab(1,iorien),pgauss,skl) -! - call orthotropic(elconloc,ya) -! - do j=1,21 - j1=kel(1,j) - j2=kel(2,j) - j3=kel(3,j) - j4=kel(4,j) - c(j)=0.d0 - do j5=1,3 - do j6=1,3 - do j7=1,3 - do j8=1,3 - c(j)=c(j)+ya(j5,j6,j7,j8)* - & skl(j1,j5)*skl(j2,j6)*skl(j3,j7)*skl(j4,j8) - enddo - enddo - enddo - enddo - enddo -! - else - do i=1,9 - c(i)=elconloc(i) - enddo - endif -! -! state variables -! -! equivalent plastic strain -! - epqini=xstateini(1,iint,iel) -! -! plastic strain -! - do i=1,6 - ep0(i)=xstateini(1+i,iint,iel) - enddo -c!start -c! inverse deformation gradient -c! -c ckl(1,1)=(xkl(2,2)*xkl(3,3)-xkl(2,3)*xkl(3,2))/vj -c ckl(2,2)=(xkl(1,1)*xkl(3,3)-xkl(1,3)*xkl(3,1))/vj -c ckl(3,3)=(xkl(1,1)*xkl(2,2)-xkl(1,2)*xkl(2,1))/vj -c ckl(1,2)=(xkl(1,3)*xkl(3,2)-xkl(1,2)*xkl(3,3))/vj -c ckl(1,3)=(xkl(1,2)*xkl(2,3)-xkl(2,2)*xkl(1,3))/vj -c ckl(2,3)=(xkl(2,1)*xkl(1,3)-xkl(1,1)*xkl(2,3))/vj -c ckl(2,1)=(xkl(3,1)*xkl(2,3)-xkl(2,1)*xkl(3,3))/vj -c ckl(3,1)=(xkl(2,1)*xkl(3,2)-xkl(2,2)*xkl(3,1))/vj -c ckl(3,2)=(xkl(3,1)*xkl(1,2)-xkl(1,1)*xkl(3,2))/vj -c! -c! converting the Lagrangian strain into Eulerian -c! strain -c! -c cauchy=.false. -c call str2mat(emec,ckl,vj,cauchy) -c!end -! elastic strains -! - do i=1,6 - ee(i)=emec(i)-ep0(i) - enddo -! -! global trial stress tensor -! - if(iorien.gt.0) then - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ - & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) - & -beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ - & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) - & -beta(2) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ - & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) - & -beta(3) - stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ - & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) - & -beta(4) - stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ - & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) - & -beta(5) - stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ - & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) - & -beta(6) - else - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) - stri(4)=2.d0*c(7)*ee(4)-beta(4) - stri(5)=2.d0*c(8)*ee(5)-beta(5) - stri(6)=2.d0*c(9)*ee(6)-beta(6) - endif -! -! stress radius (only deviatoric part of stress enters) -! - strinv=(stri(1)+stri(2)+stri(3))/3.d0 - do i=1,3 - sg(i)=stri(i)-strinv - enddo - do i=4,6 - sg(i)=stri(i) - enddo - dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ - & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) -! -! evaluation of the yield surface -! - ec(1)=epqini -! - htri=dsg -! -! check whether plasticity occurs -! -c if(htri.gt.0.d0) then - if(htri.gt.1.d-10) then - iplas=1 - else - iplas=0 - endif -! - if((iplas.eq.0).or.(ielas.eq.1)) then -! -! elastic stress -! - do i=1,6 - stre(i)=stri(i) - enddo -! -! elastic stiffness -! - if(icmd.ne.3) then - if(iorien.gt.0) then - do i=1,21 - stiff(i)=c(i) - enddo - else - stiff(1)=c(1) - stiff(2)=c(2) - stiff(3)=c(3) - stiff(4)=c(4) - stiff(5)=c(5) - stiff(6)=c(6) - stiff(7)=0.d0 - stiff(8)=0.d0 - stiff(9)=0.d0 - stiff(10)=c(7) - stiff(11)=0.d0 - stiff(12)=0.d0 - stiff(13)=0.d0 - stiff(14)=0.d0 - stiff(15)=c(8) - stiff(16)=0.d0 - stiff(17)=0.d0 - stiff(18)=0.d0 - stiff(19)=0.d0 - stiff(20)=0.d0 - stiff(21)=c(9) - endif - endif -! - return - endif -! -! plastic deformation -! - neq=6 - nrhs=1 - lda=6 - ldb=6 -! -! initializing the state variables -! - do i=1,6 - ep(i)=ep0(i) - enddo - dg=0.d0 -! -! determining the inverse of c -! - if(iorien.gt.0) then -! -! solve gl:C=gr -! - gl(1,1)=c(1) - gl(1,2)=c(2) - gl(2,2)=c(3) - gl(1,3)=c(4) - gl(2,3)=c(5) - gl(3,3)=c(6) - gl(1,4)=c(7) - gl(2,4)=c(8) - gl(3,4)=c(9) - gl(4,4)=c(10) - gl(1,5)=c(11) - gl(2,5)=c(12) - gl(3,5)=c(13) - gl(4,5)=c(14) - gl(5,5)=c(15) - gl(1,6)=c(16) - gl(2,6)=c(17) - gl(3,6)=c(18) - gl(4,6)=c(19) - gl(5,6)=c(20) - gl(6,6)=c(21) - do i=1,6 - do j=1,i-1 - gl(i,j)=gl(j,i) - enddo - enddo - do i=1,6 - do j=1,6 - gr(i,j)=0.d0 - enddo - gr(i,i)=1.d0 - enddo - nrhs=6 - call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif - nrhs=1 - cm1(1)=gr(1,1) - cm1(2)=gr(1,2) - cm1(3)=gr(2,2) - cm1(4)=gr(1,3) - cm1(5)=gr(2,3) - cm1(6)=gr(3,3) - cm1(7)=gr(1,4)/2.d0 - cm1(8)=gr(2,4)/2.d0 - cm1(9)=gr(3,4)/2.d0 - cm1(10)=gr(4,4)/4.d0 - cm1(11)=gr(1,5)/2.d0 - cm1(12)=gr(2,5)/2.d0 - cm1(13)=gr(3,5)/2.d0 - cm1(14)=gr(4,5)/4.d0 - cm1(15)=gr(5,5)/4.d0 - cm1(16)=gr(1,6)/2.d0 - cm1(17)=gr(2,6)/2.d0 - cm1(18)=gr(3,6)/2.d0 - cm1(19)=gr(4,6)/4.d0 - cm1(20)=gr(5,6)/4.d0 - cm1(21)=gr(6,6)/4.d0 - else - detc=c(1)*(c(3)*c(6)-c(5)*c(5))- - & c(2)*(c(2)*c(6)-c(4)*c(5))+ - & c(4)*(c(2)*c(5)-c(4)*c(3)) - cm1(1)=(c(3)*c(6)-c(5)*c(5))/detc - cm1(2)=(c(5)*c(4)-c(2)*c(6))/detc - cm1(3)=(c(1)*c(6)-c(4)*c(4))/detc - cm1(4)=(c(2)*c(5)-c(3)*c(4))/detc - cm1(5)=(c(2)*c(4)-c(1)*c(5))/detc - cm1(6)=(c(1)*c(3)-c(2)*c(2))/detc - cm1(7)=1.d0/(4.d0*c(7)) - cm1(8)=1.d0/(4.d0*c(8)) - cm1(9)=1.d0/(4.d0*c(9)) - endif -! -! first attempt: root search with Newton-Raphson -! - loop: do -! - iloop=iloop+1 -! -! elastic strains -! - do i=1,6 - ee(i)=emec(i)-ep(i) - enddo -! -! global trial stress tensor -! - if(iorien.gt.0) then - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ - & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) - & -beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ - & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) - & -beta(2) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ - & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) - & -beta(3) - stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ - & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) - & -beta(4) - stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ - & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) - & -beta(5) - stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ - & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) - & -beta(6) - else - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) - stri(4)=2.d0*c(7)*ee(4)-beta(4) - stri(5)=2.d0*c(8)*ee(5)-beta(5) - stri(6)=2.d0*c(9)*ee(6)-beta(6) - endif -! -! stress radius (only deviatoric part of stress enters) -! - strinv=(stri(1)+stri(2)+stri(3))/3.d0 - do i=1,3 - sg(i)=stri(i)-strinv - enddo - do i=4,6 - sg(i)=stri(i) - enddo - dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ - & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) -! -! evaluation of the yield surface -! - ec(1)=epqini - decra(1)=c0*dg - call creep(decra,deswa,xstateini(1,iint,iel),serd,ec, - & esw,p,svm,t1l,dtemp,predef,dpred,timeabq,dtime, - & amat,leximp,lend,pgauss,nstate_,iel,iint,layer,kspt, - & kstep,kinc) -! -! if the creep routine returns an increased value of decra(1) -! it means that there is a lower cut-off for decra(1); -! if the routine stays in a range lower than this cut-off, -! it will never leave it and the exit conditions are -! assumed to be satisfied. -! - if(decra(1).gt.c0*dg) then - dg=decra(1)/c0 - if(iloop.gt.1) exitcriterion=.true. - endif -! - htri=dsg-c0*svm -! - do i=1,6 - sg(i)=sg(i)/dsg - enddo -! -! determining the residual matrix -! - do i=1,6 - r(i)=ep0(i)-ep(i)+dg*sg(i) - enddo -! -! check convergence -! - if(exitcriterion) exit - if((dabs(htri).le.1.d-3).and. - & ((iloop.gt.1).and.((dabs(ddg).lt.1.d-10).or. - & (dabs(ddg).lt.1.d-3*dabs(dg))))) then - dd=0.d0 - do i=1,6 - dd=dd+r(i)*r(i) - enddo - dd=sqrt(dd) - if(dd.le.1.d-10) then - exit - endif - endif -! -! determining b.x -! - b=dg/dsg -! - x(1)=b*(c1-sg(1)*sg(1)) - x(2)=b*(c2-sg(1)*sg(2)) - x(3)=b*(c1-sg(2)*sg(2)) - x(4)=b*(c2-sg(1)*sg(3)) - x(5)=b*(c2-sg(2)*sg(3)) - x(6)=b*(c1-sg(3)*sg(3)) - x(7)=-b*sg(1)*sg(4) - x(8)=-b*sg(2)*sg(4) - x(9)=-b*sg(3)*sg(4) - x(10)=b*(.5d0-sg(4)*sg(4)) - x(11)=-b*sg(1)*sg(5) - x(12)=-b*sg(2)*sg(5) - x(13)=-b*sg(3)*sg(5) - x(14)=-b*sg(4)*sg(5) - x(15)=b*(.5d0-sg(5)*sg(5)) - x(16)=-b*sg(1)*sg(6) - x(17)=-b*sg(2)*sg(6) - x(18)=-b*sg(3)*sg(6) - x(19)=-b*sg(4)*sg(6) - x(20)=-b*sg(5)*sg(6) - x(21)=b*(.5d0-sg(6)*sg(6)) -! -! filling the LHS -! - if(iorien.gt.0) then - gl(1,1)=cm1(1)+x(1) - gl(1,2)=cm1(2)+x(2) - gl(2,2)=cm1(3)+x(3) - gl(1,3)=cm1(4)+x(4) - gl(2,3)=cm1(5)+x(5) - gl(3,3)=cm1(6)+x(6) - gl(1,4)=cm1(7)+x(7) - gl(2,4)=cm1(8)+x(8) - gl(3,4)=cm1(9)+x(9) - gl(4,4)=cm1(10)+x(10) - gl(1,5)=cm1(11)+x(11) - gl(2,5)=cm1(12)+x(12) - gl(3,5)=cm1(13)+x(13) - gl(4,5)=cm1(14)+x(14) - gl(5,5)=cm1(15)+x(15) - gl(1,6)=cm1(16)+x(16) - gl(2,6)=cm1(17)+x(17) - gl(3,6)=cm1(18)+x(18) - gl(4,6)=cm1(19)+x(19) - gl(5,6)=cm1(20)+x(20) - gl(6,6)=cm1(21)+x(21) - do i=1,6 - do j=1,i-1 - gl(i,j)=gl(j,i) - enddo - enddo - else - gl(1,1)=cm1(1)+x(1) - gl(1,2)=cm1(2)+x(2) - gl(2,2)=cm1(3)+x(3) - gl(1,3)=cm1(4)+x(4) - gl(2,3)=cm1(5)+x(5) - gl(3,3)=cm1(6)+x(6) - gl(1,4)=x(7) - gl(2,4)=x(8) - gl(3,4)=x(9) - gl(4,4)=cm1(7)+x(10) - gl(1,5)=x(11) - gl(2,5)=x(12) - gl(3,5)=x(13) - gl(4,5)=x(14) - gl(5,5)=cm1(8)+x(15) - gl(1,6)=x(16) - gl(2,6)=x(17) - gl(3,6)=x(18) - gl(4,6)=x(19) - gl(5,6)=x(20) - gl(6,6)=cm1(9)+x(21) - do i=1,6 - do j=1,i-1 - gl(i,j)=gl(j,i) - enddo - enddo - endif -! -! filling the RHS -! - do i=1,6 - gr(i,1)=sg(i) - enddo -! -! solve gl:(P:n)=gr -! - call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! - do i=1,6 - Pn(i)=gr(i,1) - enddo -! -! calculating the creep contribution -! - gcreep=c1/decra(5) -! -! calculating the correction to the consistency parameter -! - gm1=Pn(1)*sg(1)+Pn(2)*sg(2)+Pn(3)*sg(3)+ - & (Pn(4)*sg(4)+Pn(5)*sg(5)+Pn(6)*sg(6)) - gm1=1.d0/(gm1+gcreep) - ddg=gm1*(htri-(Pn(1)*r(1)+Pn(2)*r(2)+Pn(3)*r(3)+ - & (Pn(4)*r(4)+Pn(5)*r(5)+Pn(6)*r(6)))) -c if((iel.eq.380).and.(iint.eq.1)) then -c write(*,*) 'depq,svm ',decra(1),svm -c write(*,*) 'dg,ddg,gm1 ',dg,ddg,gm1 -c endif -! -! updating the residual matrix -! - do i=1,6 - r(i)=r(i)+ddg*sg(i) - enddo -! -! update the plastic strain -! - gr(1,1)=r(1) - gr(2,1)=r(2) - gr(3,1)=r(3) - gr(4,1)=r(4) - gr(5,1)=r(5) - gr(6,1)=r(6) -! - call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! - if(iorien.gt.0) then - ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+cm1(4)*gr(3,1)+ - & (cm1(7)*gr(4,1)+cm1(11)*gr(5,1)+cm1(16)*gr(6,1)) - ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+cm1(5)*gr(3,1)+ - & (cm1(8)*gr(4,1)+cm1(12)*gr(5,1)+cm1(17)*gr(6,1)) - ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+cm1(6)*gr(3,1)+ - & (cm1(9)*gr(4,1)+cm1(13)*gr(5,1)+cm1(18)*gr(6,1)) - ep(4)=ep(4)+cm1(7)*gr(1,1)+cm1(8)*gr(2,1)+cm1(9)*gr(3,1)+ - & (cm1(10)*gr(4,1)+cm1(14)*gr(5,1)+cm1(19)*gr(6,1)) - ep(5)=ep(5)+cm1(11)*gr(1,1)+cm1(12)*gr(2,1)+cm1(13)*gr(3,1)+ - & (cm1(14)*gr(4,1)+cm1(15)*gr(5,1)+cm1(20)*gr(6,1)) - ep(6)=ep(6)+cm1(16)*gr(1,1)+cm1(17)*gr(2,1)+cm1(18)*gr(3,1)+ - & (cm1(19)*gr(4,1)+cm1(20)*gr(5,1)+cm1(21)*gr(6,1)) - else - ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+cm1(4)*gr(3,1) - ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+cm1(5)*gr(3,1) - ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+cm1(6)*gr(3,1) - ep(4)=ep(4)+cm1(7)*gr(4,1) - ep(5)=ep(5)+cm1(8)*gr(5,1) - ep(6)=ep(6)+cm1(9)*gr(6,1) - endif -! -! update the consistency parameter -! - dg=dg+ddg -! -! end of major loop -! - if((iloop.gt.15).or.(dg.le.0.d0)) then -c write(*,*) dg,iloop,dsg,svm,iel,iint - iloop=1 - dg=0.d0 - do i=1,6 - ep(i)=ep0(i) - enddo -! -c write(*,*) 'second attempt' -! -! second attempt: root search through interval division -! - do -! -! elastic strains -! - do i=1,6 - ee(i)=emec(i)-ep(i) - enddo -! -! global trial stress tensor -! - if(iorien.gt.0) then - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ - & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) - & -beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ - & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) - & -beta(2) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ - & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) - & -beta(3) - stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ - & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) - & -beta(4) - stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ - & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) - & -beta(5) - stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ - & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) - & -beta(6) - else - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) - stri(4)=2.d0*c(7)*ee(4)-beta(4) - stri(5)=2.d0*c(8)*ee(5)-beta(5) - stri(6)=2.d0*c(9)*ee(6)-beta(6) - endif -! -! stress radius (only deviatoric part of stress enters) -! - strinv=(stri(1)+stri(2)+stri(3))/3.d0 - do i=1,3 - sg(i)=stri(i)-strinv - enddo - do i=4,6 - sg(i)=stri(i) - enddo - dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ - & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) -! -! evaluation of the yield surface -! - ec(1)=epqini - decra(1)=c0*dg - call creep(decra,deswa,xstateini(1,iint,iel),serd,ec, - & esw,p,svm,t1l,dtemp,predef,dpred,timeabq,dtime, - & amat,leximp,lend,pgauss,nstate_,iel,iint,layer,kspt, - & kstep,kinc) - if(decra(1).gt.c0*dg) then -c write(*,*) 'dg was changed from ',dg, -c & ' to ',decra(1)/c0 - dg=decra(1)/c0 - if(abs(iloop).gt.2) exitcriterion=.true. - endif -! -! needed in case decra(1) was changed in subroutine creep, -! for instance because it is too small -! - dg=decra(1)/c0 -! - htri=dsg-c0*svm -! - do i=1,6 - sg(i)=sg(i)/dsg - enddo -! -! determining the residual matrix -! - do i=1,6 - r(i)=ep0(i)-ep(i)+dg*sg(i) - enddo -! -! check convergence -! - if(exitcriterion) exit loop - if((dabs(htri).le.1.d-3).and. - & ((iloop.gt.2).and.((dabs(ddg).lt.1.d-10).or. - & (dabs(ddg).lt.1.d-3*dabs(dg))))) then - dd=0.d0 - do i=1,6 - dd=dd+r(i)*r(i) - enddo - dd=sqrt(dd) - if(dd.le.1.d-10) then - exit loop - endif - endif - if(iloop.gt.100) then - write(*,*) - & '*ERROR: no convergence in umat_aniso_creep' - write(*,*) ' iloop>100' - write(*,*) 'htri,dd ',htri,dd - exit loop - endif -! -! determining b.x -! - b=dg/dsg -! - x(1)=b*(c1-sg(1)*sg(1)) - x(2)=b*(c2-sg(1)*sg(2)) - x(3)=b*(c1-sg(2)*sg(2)) - x(4)=b*(c2-sg(1)*sg(3)) - x(5)=b*(c2-sg(2)*sg(3)) - x(6)=b*(c1-sg(3)*sg(3)) - x(7)=-b*sg(1)*sg(4) - x(8)=-b*sg(2)*sg(4) - x(9)=-b*sg(3)*sg(4) - x(10)=b*(.5d0-sg(4)*sg(4)) - x(11)=-b*sg(1)*sg(5) - x(12)=-b*sg(2)*sg(5) - x(13)=-b*sg(3)*sg(5) - x(14)=-b*sg(4)*sg(5) - x(15)=b*(.5d0-sg(5)*sg(5)) - x(16)=-b*sg(1)*sg(6) - x(17)=-b*sg(2)*sg(6) - x(18)=-b*sg(3)*sg(6) - x(19)=-b*sg(4)*sg(6) - x(20)=-b*sg(5)*sg(6) - x(21)=b*(.5d0-sg(6)*sg(6)) -! -! filling the LHS -! - if(iorien.gt.0) then - gl(1,1)=cm1(1)+x(1) - gl(1,2)=cm1(2)+x(2) - gl(2,2)=cm1(3)+x(3) - gl(1,3)=cm1(4)+x(4) - gl(2,3)=cm1(5)+x(5) - gl(3,3)=cm1(6)+x(6) - gl(1,4)=cm1(7)+x(7) - gl(2,4)=cm1(8)+x(8) - gl(3,4)=cm1(9)+x(9) - gl(4,4)=cm1(10)+x(10) - gl(1,5)=cm1(11)+x(11) - gl(2,5)=cm1(12)+x(12) - gl(3,5)=cm1(13)+x(13) - gl(4,5)=cm1(14)+x(14) - gl(5,5)=cm1(15)+x(15) - gl(1,6)=cm1(16)+x(16) - gl(2,6)=cm1(17)+x(17) - gl(3,6)=cm1(18)+x(18) - gl(4,6)=cm1(19)+x(19) - gl(5,6)=cm1(20)+x(20) - gl(6,6)=cm1(21)+x(21) - do i=1,6 - do j=1,i-1 - gl(i,j)=gl(j,i) - enddo - enddo - else - gl(1,1)=cm1(1)+x(1) - gl(1,2)=cm1(2)+x(2) - gl(2,2)=cm1(3)+x(3) - gl(1,3)=cm1(4)+x(4) - gl(2,3)=cm1(5)+x(5) - gl(3,3)=cm1(6)+x(6) - gl(1,4)=x(7) - gl(2,4)=x(8) - gl(3,4)=x(9) - gl(4,4)=cm1(7)+x(10) - gl(1,5)=x(11) - gl(2,5)=x(12) - gl(3,5)=x(13) - gl(4,5)=x(14) - gl(5,5)=cm1(8)+x(15) - gl(1,6)=x(16) - gl(2,6)=x(17) - gl(3,6)=x(18) - gl(4,6)=x(19) - gl(5,6)=x(20) - gl(6,6)=cm1(9)+x(21) - do i=1,6 - do j=1,i-1 - gl(i,j)=gl(j,i) - enddo - enddo - endif -! -! filling the RHS -! - do i=1,6 - gr(i,1)=sg(i) - enddo -! -! solve gl:(P:n)=gr -! - call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! - do i=1,6 - Pn(i)=gr(i,1) - enddo -! -! calculating the creep contribution -! - gcreep=c1/decra(5) -! -! calculating the correction to the consistency parameter -! - gm1=Pn(1)*sg(1)+Pn(2)*sg(2)+Pn(3)*sg(3)+ - & (Pn(4)*sg(4)+Pn(5)*sg(5)+Pn(6)*sg(6)) - gm1=1.d0/(gm1+gcreep) - fu=(htri-(Pn(1)*r(1)+Pn(2)*r(2)+Pn(3)*r(3)+ - & (Pn(4)*r(4)+Pn(5)*r(5)+Pn(6)*r(6)))) -! - if(iloop.eq.1) then -c write(*,*) 'iloop,dg,fu ',iloop,dg,fu - dg1=0.d0 - fu1=fu - iloop=2 - dg=1.d-10 - ddg=dg - do i=1,6 - ep1(i)=ep(i) - r1(i)=r(i) - sg1(i)=sg(i) - do j=1,6 - gl1(i,j)=gl(i,j) - enddo - enddo - elseif((iloop.eq.2).or.(iloop.lt.0)) then - if(fu*fu1.lt.0.d0) then -c write(*,*) 'iloop,dg,fu ',iloop,dg,fu - if(iloop.eq.2) then - iloop=3 - else - iloop=-iloop+1 - endif - fu2=fu - dg2=dg - dg=(dg1+dg2)/2.d0 - ddg=(dg2-dg1)/2.d0 - do i=1,6 - ep(i)=ep1(i) - r(i)=r1(i) - sg(i)=sg1(i) - do j=1,6 - gl(i,j)=gl1(i,j) - enddo - enddo - else -c write(*,*) 'iloop,dg,fu ',iloop,dg,fu -c dg1=dg -c fu1=fu - if(iloop.eq.2) then - if(dabs(fu).gt.dabs(fu1)) exitcriterion=.true. - dg1=dg - fu1=fu - ddg=dg*9.d0 - dg=dg*10.d0 - else - dg1=dg - fu1=fu - dg=dg+ddg - iloop=iloop-1 - endif - if(dg.gt.10.1d0) then - write(*,*) - & '*ERROR: no convergence in umat_aniso_creep' - write(*,*) ' dg>10.' - stop - endif - do i=1,6 - ep1(i)=ep(i) - r1(i)=r(i) - sg1(i)=sg(i) - do j=1,6 - gl1(i,j)=gl(i,j) - enddo - enddo - endif - else -c write(*,*) 'iloop,dg,fu ',iloop,dg,fu - if(fu*fu1.ge.0.d0) then - dg1=dg - fu1=fu - dg=(dg1+dg2)/2.d0 - ddg=(dg2-dg1)/2.d0 - do i=1,6 - ep1(i)=ep(i) - r1(i)=r(i) - sg1(i)=sg(i) - do j=1,6 - gl1(i,j)=gl(i,j) - enddo - enddo - iloop=-iloop-1 - else - dg2=dg - fu2=fu - dg=(dg1+dg2)/2.d0 - ddg=(dg2-dg1)/2.d0 - do i=1,6 - ep(i)=ep1(i) - r(i)=r1(i) - sg(i)=sg1(i) - do j=1,6 - gl(i,j)=gl1(i,j) - enddo - enddo - iloop=iloop+1 - endif - endif -! -! updating the residual matrix -! - do i=1,6 - r(i)=r(i)+ddg*sg(i) - enddo -! -! update the plastic strain -! - gr(1,1)=r(1) - gr(2,1)=r(2) - gr(3,1)=r(3) - gr(4,1)=r(4) - gr(5,1)=r(5) - gr(6,1)=r(6) -! - call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb, - & info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! - if(iorien.gt.0) then - ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+ - & cm1(4)*gr(3,1)+ - & (cm1(7)*gr(4,1)+cm1(11)*gr(5,1)+ - & cm1(16)*gr(6,1)) - ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+ - & cm1(5)*gr(3,1)+ - & (cm1(8)*gr(4,1)+cm1(12)*gr(5,1)+ - & cm1(17)*gr(6,1)) - ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1) - & +cm1(6)*gr(3,1)+ - & (cm1(9)*gr(4,1)+cm1(13)*gr(5,1)+ - & cm1(18)*gr(6,1)) - ep(4)=ep(4)+cm1(7)*gr(1,1)+cm1(8)*gr(2,1)+ - & cm1(9)*gr(3,1)+ - & (cm1(10)*gr(4,1)+cm1(14)*gr(5,1)+ - & cm1(19)*gr(6,1)) - ep(5)=ep(5)+cm1(11)*gr(1,1)+cm1(12)*gr(2,1)+ - & cm1(13)*gr(3,1)+ - & (cm1(14)*gr(4,1)+cm1(15)*gr(5,1)+ - & cm1(20)*gr(6,1)) - ep(6)=ep(6)+cm1(16)*gr(1,1)+cm1(17)*gr(2,1)+ - & cm1(18)*gr(3,1)+ - & (cm1(19)*gr(4,1)+cm1(20)*gr(5,1)+ - & cm1(21)*gr(6,1)) - else - ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+ - & cm1(4)*gr(3,1) - ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+ - & cm1(5)*gr(3,1) - ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+ - & cm1(6)*gr(3,1) - ep(4)=ep(4)+cm1(7)*gr(4,1) - ep(5)=ep(5)+cm1(8)*gr(5,1) - ep(6)=ep(6)+cm1(9)*gr(6,1) - endif -! -! end of major loop -! - enddo -! - endif -! - enddo loop -! -! storing the stress -! - do i=1,6 - stre(i)=stri(i) - enddo -! -! converting the stress into the material frame of -! reference -! -c cauchy=.true. -c call str2mat(stre,ckl,vj,cauchy) -! -! calculating the tangent stiffness matrix -! - if(icmd.ne.3) then -! -! determining p -! - gr(1,1)=1.d0 - gr(1,2)=0. - gr(2,2)=1.d0 - gr(1,3)=0. - gr(2,3)=0. - gr(3,3)=1.d0 - gr(1,4)=0. - gr(2,4)=0. - gr(3,4)=0. - gr(4,4)=1.d0 - gr(1,5)=0. - gr(2,5)=0. - gr(3,5)=0. - gr(4,5)=0. - gr(5,5)=1.d0 - gr(1,6)=0. - gr(2,6)=0. - gr(3,6)=0. - gr(4,6)=0. - gr(5,6)=0. - gr(6,6)=1.d0 - do i=1,6 - do j=1,i-1 - gr(i,j)=gr(j,i) - enddo - enddo - nrhs=6 -! - call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! - stiff(1)=gr(1,1)-gm1*Pn(1)*Pn(1) - stiff(2)=gr(1,2)-gm1*Pn(1)*Pn(2) - stiff(3)=gr(2,2)-gm1*Pn(2)*Pn(2) - stiff(4)=gr(1,3)-gm1*Pn(1)*Pn(3) - stiff(5)=gr(2,3)-gm1*Pn(2)*Pn(3) - stiff(6)=gr(3,3)-gm1*Pn(3)*Pn(3) - stiff(7)=(gr(1,4)-gm1*Pn(1)*Pn(4))/2.d0 - stiff(8)=(gr(2,4)-gm1*Pn(2)*Pn(4))/2.d0 - stiff(9)=(gr(3,4)-gm1*Pn(3)*Pn(4))/2.d0 - stiff(10)=(gr(4,4)-gm1*Pn(4)*Pn(4))/4.d0 - stiff(11)=(gr(1,5)-gm1*Pn(1)*Pn(5))/2.d0 - stiff(12)=(gr(2,5)-gm1*Pn(2)*Pn(5))/2.d0 - stiff(13)=(gr(3,5)-gm1*Pn(3)*Pn(5))/2.d0 - stiff(14)=(gr(4,5)-gm1*Pn(4)*Pn(5))/4.d0 - stiff(15)=(gr(5,5)-gm1*Pn(5)*Pn(5))/4.d0 - stiff(16)=(gr(1,6)-gm1*Pn(1)*Pn(6))/2.d0 - stiff(17)=(gr(2,6)-gm1*Pn(2)*Pn(6))/2.d0 - stiff(18)=(gr(3,6)-gm1*Pn(3)*Pn(6))/2.d0 - stiff(19)=(gr(4,6)-gm1*Pn(4)*Pn(6))/4.d0 - stiff(20)=(gr(5,6)-gm1*Pn(5)*Pn(6))/4.d0 - stiff(21)=(gr(6,6)-gm1*Pn(6)*Pn(6))/4.d0 -c!start -c! conversion of the stiffness matrix from spatial coordinates -c! coordinates into material coordinates -c! -c call stiff2mat(stiff,ckl,vj,cauchy) -c!end - endif -! -! updating the state variables -! - xstate(1,iint,iel)=epqini+c0*dg - do i=1,6 - xstate(1+i,iint,iel)=ep(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_aniso_plas.f calculix-ccx-2.3/ccx_2.1/src/umat_aniso_plas.f --- calculix-ccx-2.1/ccx_2.1/src/umat_aniso_plas.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_aniso_plas.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1097 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_aniso_plas(amat,iel,iint,kode,elconloc,emec, - & emec0,beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas, - & mi,nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, - & orab) -! -! calculates stiffness and stresses for a user defined material -! law -! -! icmd=3: calcutates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! 3: calculate only stress -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! Notice that the matrix is an integral part of the -! fourth order material tensor, i.e. the Voigt notation -! is not used. -! - implicit none -! - logical creep -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien -! - integer i,j,ipiv(6),info,neq,lda,ldb,j1,j2,j3,j4,j5,j6,j7,j8, - & nrhs,iplas,kel(4,21) -! - real*8 ep0(6),al10,al20(6),eeq,ep(6),al1,b,Pn(6),QSn(6), - & al2(6),dg,ddg,ca,cn,c(21),r0,x(21),cm1(21),h1,h2, - & q1,q2(6),stri(6),htri,sg(6),r(13),au1(21),au2(21), - & ee(6),dd,gl(6,6),gr(6,6),c0,c1,c2,c3,c4,c5,c6, - & skl(3,3),gcreep,gm1,ya(3,3,3,3),d1,d2,dsg,detc,strinv -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), - & time,ttime -! - real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) -! - data kel /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, - & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3, - & 3,3,1,3,1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3, - & 1,2,2,3,1,3,2,3,2,3,2,3/ -! - c0=dsqrt(2.d0/3.d0) - c1=2.d0/3.d0 - c2=-1.d0/3.d0 -! -! elastic constants -! - if(iorien.gt.0) then -! - call transformatrix(orab(1,iorien),pgauss,skl) -! - call orthotropic(elconloc,ya) -! - do j=1,21 - j1=kel(1,j) - j2=kel(2,j) - j3=kel(3,j) - j4=kel(4,j) - c(j)=0.d0 - do j5=1,3 - do j6=1,3 - do j7=1,3 - do j8=1,3 - c(j)=c(j)+ya(j5,j6,j7,j8)* - & skl(j1,j5)*skl(j2,j6)*skl(j3,j7)*skl(j4,j8) - enddo - enddo - enddo - enddo - enddo -! - else - do i=1,9 - c(i)=elconloc(i) - enddo - endif -! -! state variables -! -! equivalent plastic strain -! - eeq=xstateini(1,iint,iel) -! -! plastic strain -! - do i=1,6 - ep0(i)=xstateini(1+i,iint,iel) - enddo -! -! isotropic hardening variable -! - al10=xstateini(8,iint,iel) -! -! kinematic hardening variable -! - do i=1,6 - al20(i)=xstateini(8+i,iint,iel) - enddo -! - if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) 'element, int.point,kstep,kinc ',iel,iint - endif -! -! elastic strains -! - do i=1,6 - ee(i)=emec(i)-ep0(i) - enddo - if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) 'emec ',(emec(i),i=1,6) -c write(*,*) 'ep0 ',(ep0(i),i=1,6) -c write(*,*) 'ee ',(ee(i),i=1,6) - endif -! -! (visco)plastic constants -! - r0=elconloc(10) - d1=elconloc(11) - d2=elconloc(12) - ca=c0/(elconloc(13)*ttime**elconloc(15)*dtime) - cn=elconloc(14) -! - if(ca.lt.0.d0) then - creep=.false. - else - creep=.true. - endif -! - h1=d1 - h2=2.d0*d2/3.d0 -! -! stress state variables q1 and q2 -! - q1=-d1*al10 - do i=1,6 - q2(i)=-d2*al20(i) - enddo - if((iint.eq.1).and.(iel.eq.1)) then -c write(*,200) q1 -c 200 format('q10 ',/,(6(1x,e11.4))) -c write(*,201) (q2(i),i=1,6) -c 201 format('q20 ',/,(6(1x,e11.4))) - endif -! -! global trial stress tensor -! - if(iorien.gt.0) then - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ - & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) - & -beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ - & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) - & -beta(2) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ - & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) - & -beta(3) - stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ - & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) - & -beta(4) - stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ - & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) - & -beta(5) - stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ - & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) - & -beta(6) - else - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) - stri(4)=2.d0*c(7)*ee(4)-beta(4) - stri(5)=2.d0*c(8)*ee(5)-beta(5) - stri(6)=2.d0*c(9)*ee(6)-beta(6) - endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) 'stri ',(stri(i),i=1,6) -c endif -! -! stress radius (only deviatoric part of stress enters) -! -c do i=1,6 -c sgold(i)=0.d0 -c enddo - strinv=(stri(1)+stri(2)+stri(3))/3.d0 - do i=1,3 - sg(i)=stri(i)-strinv+q2(i) - enddo - do i=4,6 - sg(i)=stri(i)+q2(i) - enddo - dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ - & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) -! -! evaluation of the yield surface -! - htri=dsg+c0*(q1-r0) -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) 'htri ',htri -c endif -! -! check whether plasticity occurs -! - if(htri.gt.0.d0) then - iplas=1 - else - iplas=0 - endif -! - if((iplas.eq.0).or.(ielas.eq.1)) then -! -! elastic stress -! - do i=1,6 - stre(i)=stri(i) - enddo -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) ' stress ' -c write(*,'(6(1x,e11.4))') (stre(i),i=1,6) -c endif -! -! elastic stiffness -! - if(icmd.ne.3) then - if(iorien.gt.0) then - do i=1,21 - stiff(i)=c(i) - enddo - else - stiff(1)=c(1) - stiff(2)=c(2) - stiff(3)=c(3) - stiff(4)=c(4) - stiff(5)=c(5) - stiff(6)=c(6) - stiff(7)=0.d0 - stiff(8)=0.d0 - stiff(9)=0.d0 - stiff(10)=c(7) - stiff(11)=0.d0 - stiff(12)=0.d0 - stiff(13)=0.d0 - stiff(14)=0.d0 - stiff(15)=c(8) - stiff(16)=0.d0 - stiff(17)=0.d0 - stiff(18)=0.d0 - stiff(19)=0.d0 - stiff(20)=0.d0 - stiff(21)=c(9) - endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) 'stiffness ' -c write(*,'(6(1x,e11.4))') (stiff(i),i=1,21) -c endif - endif -! - return - endif -! -! plastic deformation -! - neq=6 - nrhs=1 - lda=6 - ldb=6 -! -! initializing the state variables -! - do i=1,6 - ep(i)=ep0(i) - enddo - al1=al10 - do i=1,6 - al2(i)=al20(i) - enddo - dg=0.d0 - ddg=0.d0 -! -! determining the inverse of c -! - if(iorien.gt.0) then -! -! solve gl:C=gr -! - gl(1,1)=c(1) - gl(1,2)=c(2) - gl(2,2)=c(3) - gl(1,3)=c(4) - gl(2,3)=c(5) - gl(3,3)=c(6) - gl(1,4)=c(7) - gl(2,4)=c(8) - gl(3,4)=c(9) - gl(4,4)=c(10) - gl(1,5)=c(11) - gl(2,5)=c(12) - gl(3,5)=c(13) - gl(4,5)=c(14) - gl(5,5)=c(15) - gl(1,6)=c(16) - gl(2,6)=c(17) - gl(3,6)=c(18) - gl(4,6)=c(19) - gl(5,6)=c(20) - gl(6,6)=c(21) - do i=1,6 - do j=1,i-1 - gl(i,j)=gl(j,i) - enddo - enddo - do i=1,6 - do j=4,6 - gl(i,j)=2.d0*gl(i,j) - enddo - enddo - do i=1,6 - do j=1,6 - gr(i,j)=0.d0 - enddo - if(i.le.3) then - gr(i,i)=1.d0 - else - gr(i,i)=0.5d0 - endif - enddo - nrhs=6 - call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif - nrhs=1 - cm1(1)=gr(1,1) - cm1(2)=gr(1,2) - cm1(3)=gr(2,2) - cm1(4)=gr(1,3) - cm1(5)=gr(2,3) - cm1(6)=gr(3,3) - cm1(7)=gr(1,4) - cm1(8)=gr(2,4) - cm1(9)=gr(3,4) - cm1(10)=gr(4,4) - cm1(11)=gr(1,5) - cm1(12)=gr(2,5) - cm1(13)=gr(3,5) - cm1(14)=gr(4,5) - cm1(15)=gr(5,5) - cm1(16)=gr(1,6) - cm1(17)=gr(2,6) - cm1(18)=gr(3,6) - cm1(19)=gr(4,6) - cm1(20)=gr(5,6) - cm1(21)=gr(6,6) - else - detc=c(1)*(c(3)*c(6)-c(5)*c(5))- - & c(2)*(c(2)*c(6)-c(4)*c(5))+ - & c(4)*(c(2)*c(5)-c(4)*c(3)) - cm1(1)=(c(3)*c(6)-c(5)*c(5))/detc - cm1(2)=(c(5)*c(4)-c(2)*c(6))/detc - cm1(3)=(c(1)*c(6)-c(4)*c(4))/detc - cm1(4)=(c(2)*c(5)-c(3)*c(4))/detc - cm1(5)=(c(2)*c(4)-c(1)*c(5))/detc - cm1(6)=(c(1)*c(3)-c(2)*c(2))/detc - cm1(7)=1.d0/(4.d0*c(7)) - cm1(8)=1.d0/(4.d0*c(8)) - cm1(9)=1.d0/(4.d0*c(9)) - endif -! -! loop -! - if((iint.eq.1).and.(iel.eq.1)) then -c write(*,202) dg -c 202 format('dg ',/,(6(1x,e11.4))) - endif - do -! -! elastic strains -! - do i=1,6 - ee(i)=emec(i)-ep(i) - enddo -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,605) (emec(i),i=1,6) -c 605 format('emec ',/,(6(1x,e11.4))) -c endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,606) (ep(i),i=1,6) -c 606 format('ep ',/,(6(1x,e11.4))) -c endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,607) (ee(i),i=1,6) -c 607 format('ee ',/,(6(1x,e11.4))) -c endif -! -! stress state variables q1 and q2 -! - q1=-d1*al1 - do i=1,6 - q2(i)=-d2*al2(i) - enddo -! -! global trial stress tensor -! - if(iorien.gt.0) then - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ - & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) - & -beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ - & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) - & -beta(2) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ - & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) - & -beta(3) - stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ - & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) - & -beta(4) - stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ - & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) - & -beta(5) - stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ - & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) - & -beta(6) - else - stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) - stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) - stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) - stri(4)=2.d0*c(7)*ee(4)-beta(4) - stri(5)=2.d0*c(8)*ee(5)-beta(5) - stri(6)=2.d0*c(9)*ee(6)-beta(6) - endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,805) (stri(i),i=1,6) -c 805 format('stri ',/,(6(1x,e11.4))) -c endif -! -! stress radius (only deviatoric part of stress enters) -! - strinv=(stri(1)+stri(2)+stri(3))/3.d0 - do i=1,3 - sg(i)=stri(i)-strinv+q2(i) - enddo - do i=4,6 - sg(i)=stri(i)+q2(i) - enddo - dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ - & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) -! -! evaluation of the yield surface -! -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,611) dsg,q1,r0,c0 -c 611 format('dsg,q1,r0,c0,al1,d1 ',/,(6(1x,e11.4))) -c write(*,612) (q2(i),i=1,6) -c 612 format('q2 ',/,(6(1x,e11.4))) -c endif - if(creep) then - htri=dsg+c0*(q1-r0-(ca*dg)**(1.d0/cn)) - else - htri=dsg+c0*(q1-r0) - endif -! - do i=1,6 - sg(i)=sg(i)/dsg - enddo -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,905) (sg(i),i=1,6) -c 905 format('sg ',/,(6(1x,e11.4))) -c endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,203) htri -c 203 format('htri ',/,(6(1x,e11.4))) -c endif -! -! determining the residual matrix -! - do i=1,6 - r(i)=ep0(i)-ep(i)+dg*sg(i) - enddo - r(7)=al10-al1+dg*c0 - do i=1,6 - r(7+i)=al20(i)-al2(i)+dg*sg(i) - enddo -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,205) (r(i),i=1,13) -c 205 format('r ',/,(6(1x,e11.4))) -c endif -! -! check convergence -! - if((htri.le.1.d-5).or.(dabs(ddg).lt.1.d-3*dabs(dg))) then - dd=0.d0 - do i=1,13 - dd=dd+r(i)*r(i) - enddo - dd=sqrt(dd) - if(dd.le.1.d-10) then -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) 'CONVERGENCE!' -c endif - exit - endif - endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) 'no convergence' -c endif -! -! determining b.x -! - b=dg/dsg -! - x(1)=b*(c1-sg(1)*sg(1)) - x(2)=b*(c2-sg(1)*sg(2)) - x(3)=b*(c1-sg(2)*sg(2)) - x(4)=b*(c2-sg(1)*sg(3)) - x(5)=b*(c2-sg(2)*sg(3)) - x(6)=b*(c1-sg(3)*sg(3)) - x(7)=-b*sg(1)*sg(4) - x(8)=-b*sg(2)*sg(4) - x(9)=-b*sg(3)*sg(4) - x(10)=b*(.5d0-sg(4)*sg(4)) - x(11)=-b*sg(1)*sg(5) - x(12)=-b*sg(2)*sg(5) - x(13)=-b*sg(3)*sg(5) - x(14)=-b*sg(4)*sg(5) - x(15)=b*(.5d0-sg(5)*sg(5)) - x(16)=-b*sg(1)*sg(6) - x(17)=-b*sg(2)*sg(6) - x(18)=-b*sg(3)*sg(6) - x(19)=-b*sg(4)*sg(6) - x(20)=-b*sg(5)*sg(6) - x(21)=b*(.5d0-sg(6)*sg(6)) -! - do i=1,21 - au1(i)=h2*x(i) - enddo - au1(1)=au1(1)+1.d0 - au1(3)=au1(3)+1.d0 - au1(6)=au1(6)+1.d0 - au1(10)=au1(10)+.5d0 - au1(15)=au1(15)+.5d0 - au1(21)=au1(21)+.5d0 -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,811) (au1(i),i=1,21) -c 811 format('au1 ',/,(6(1x,e11.4))) -c endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,811) (cm1(i),i=1,21) -c 812 format('cm1 ',/,(6(1x,e11.4))) -c endif -! -! filling the LHS -! - if(iorien.gt.0) then - gl(1,1)=au1(1)*cm1(1)+au1(2)*cm1(2)+au1(4)*cm1(4)+ - & 2.d0*(au1(7)*cm1(7)+au1(11)*cm1(11)+au1(16)*cm1(16))+ - & x(1) - gl(1,2)=au1(1)*cm1(2)+au1(2)*cm1(3)+au1(4)*cm1(5)+ - & 2.d0*(au1(7)*cm1(8)+au1(11)*cm1(12)+au1(16)*cm1(17))+ - & x(2) - gl(2,2)=au1(2)*cm1(2)+au1(3)*cm1(3)+au1(5)*cm1(5)+ - & 2.d0*(au1(8)*cm1(8)+au1(12)*cm1(12)+au1(17)*cm1(17))+ - & x(3) - gl(1,3)=au1(1)*cm1(4)+au1(2)*cm1(5)+au1(4)*cm1(6)+ - & 2.d0*(au1(7)*cm1(9)+au1(11)*cm1(13)+au1(16)*cm1(18))+ - & x(4) - gl(2,3)=au1(2)*cm1(4)+au1(3)*cm1(5)+au1(5)*cm1(6)+ - & 2.d0*(au1(8)*cm1(9)+au1(12)*cm1(13)+au1(17)*cm1(18))+ - & x(5) - gl(3,3)=au1(4)*cm1(4)+au1(5)*cm1(5)+au1(6)*cm1(6)+ - & 2.d0*(au1(9)*cm1(9)+au1(13)*cm1(13)+au1(18)*cm1(18))+ - & x(6) - gl(1,4)=au1(1)*cm1(7)+au1(2)*cm1(8)+au1(4)*cm1(9)+ - & 2.d0*(au1(7)*cm1(10)+au1(11)*cm1(14)+au1(16)*cm1(19))+ - & x(7) - gl(2,4)=au1(2)*cm1(7)+au1(3)*cm1(8)+au1(5)*cm1(9)+ - & 2.d0*(au1(8)*cm1(10)+au1(12)*cm1(14)+au1(17)*cm1(19))+ - & x(8) - gl(3,4)=au1(4)*cm1(7)+au1(5)*cm1(8)+au1(6)*cm1(9)+ - & 2.d0*(au1(9)*cm1(10)+au1(13)*cm1(14)+au1(18)*cm1(19))+ - & x(9) - gl(4,4)=au1(7)*cm1(7)+au1(8)*cm1(8)+au1(9)*cm1(9)+ - & 2.d0*(au1(10)*cm1(10)+au1(14)*cm1(14)+au1(19)*cm1(19))+ - & x(10) - gl(1,5)=au1(1)*cm1(11)+au1(2)*cm1(12)+au1(4)*cm1(13)+ - & 2.d0*(au1(7)*cm1(14)+au1(11)*cm1(15)+au1(16)*cm1(20))+ - & x(11) - gl(2,5)=au1(2)*cm1(11)+au1(3)*cm1(12)+au1(5)*cm1(13)+ - & 2.d0*(au1(8)*cm1(14)+au1(12)*cm1(15)+au1(17)*cm1(20))+ - & x(12) - gl(3,5)=au1(4)*cm1(11)+au1(5)*cm1(12)+au1(6)*cm1(13)+ - & 2.d0*(au1(9)*cm1(14)+au1(13)*cm1(15)+au1(18)*cm1(20))+ - & x(13) - gl(4,5)=au1(7)*cm1(11)+au1(8)*cm1(12)+au1(9)*cm1(13)+ - & 2.d0*(au1(10)*cm1(14)+au1(14)*cm1(15)+au1(19)*cm1(20))+ - & x(14) - gl(5,5)=au1(11)*cm1(11)+au1(12)*cm1(12)+au1(13)*cm1(13)+ - & 2.d0*(au1(14)*cm1(14)+au1(15)*cm1(15)+au1(20)*cm1(20))+ - & x(15) - gl(1,6)=au1(1)*cm1(16)+au1(2)*cm1(17)+au1(4)*cm1(18)+ - & 2.d0*(au1(7)*cm1(19)+au1(11)*cm1(20)+au1(16)*cm1(21))+ - & x(16) - gl(2,6)=au1(2)*cm1(16)+au1(3)*cm1(17)+au1(5)*cm1(18)+ - & 2.d0*(au1(8)*cm1(19)+au1(12)*cm1(20)+au1(17)*cm1(21))+ - & x(17) - gl(3,6)=au1(4)*cm1(16)+au1(5)*cm1(17)+au1(6)*cm1(18)+ - & 2.d0*(au1(9)*cm1(19)+au1(13)*cm1(20)+au1(18)*cm1(21))+ - & x(18) - gl(4,6)=au1(7)*cm1(16)+au1(8)*cm1(17)+au1(9)*cm1(18)+ - & 2.d0*(au1(10)*cm1(19)+au1(14)*cm1(20)+au1(19)*cm1(21))+ - & x(19) - gl(5,6)=au1(11)*cm1(16)+au1(12)*cm1(17)+au1(13)*cm1(18)+ - & 2.d0*(au1(14)*cm1(19)+au1(15)*cm1(20)+au1(20)*cm1(21))+ - & x(20) - gl(6,6)=au1(16)*cm1(16)+au1(17)*cm1(17)+au1(18)*cm1(18)+ - & 2.d0*(au1(19)*cm1(19)+au1(20)*cm1(20)+au1(21)*cm1(21))+ - & x(21) - do i=1,6 - do j=1,i-1 - gl(i,j)=gl(j,i) - enddo - enddo - do i=1,6 - do j=4,6 - gl(i,j)=2.d0*gl(i,j) - enddo - enddo - else - gl(1,1)=au1(1)*cm1(1)+au1(2)*cm1(2)+au1(4)*cm1(4)+x(1) - gl(1,2)=au1(1)*cm1(2)+au1(2)*cm1(3)+au1(4)*cm1(5)+x(2) - gl(2,2)=au1(2)*cm1(2)+au1(3)*cm1(3)+au1(5)*cm1(5)+x(3) - gl(1,3)=au1(1)*cm1(4)+au1(2)*cm1(5)+au1(4)*cm1(6)+x(4) - gl(2,3)=au1(2)*cm1(4)+au1(3)*cm1(5)+au1(5)*cm1(6)+x(5) - gl(3,3)=au1(4)*cm1(4)+au1(5)*cm1(5)+au1(6)*cm1(6)+x(6) - gl(1,4)=2.d0*au1(7)*cm1(7)+x(7) - gl(2,4)=2.d0*au1(8)*cm1(7)+x(8) - gl(3,4)=2.d0*au1(9)*cm1(7)+x(9) - gl(4,4)=2.d0*au1(10)*cm1(7)+x(10) - gl(1,5)=2.d0*au1(11)*cm1(8)+x(11) - gl(2,5)=2.d0*au1(12)*cm1(8)+x(12) - gl(3,5)=2.d0*au1(13)*cm1(8)+x(13) - gl(4,5)=2.d0*au1(14)*cm1(8)+x(14) - gl(5,5)=2.d0*au1(15)*cm1(8)+x(15) - gl(1,6)=2.d0*au1(16)*cm1(9)+x(16) - gl(2,6)=2.d0*au1(17)*cm1(9)+x(17) - gl(3,6)=2.d0*au1(18)*cm1(9)+x(18) - gl(4,6)=2.d0*au1(19)*cm1(9)+x(19) - gl(5,6)=2.d0*au1(20)*cm1(9)+x(20) - gl(6,6)=2.d0*au1(21)*cm1(9)+x(21) - do i=1,6 - do j=1,i-1 - gl(i,j)=gl(j,i) - enddo - enddo - do i=1,6 - do j=4,6 - gl(i,j)=2.d0*gl(i,j) - enddo - enddo - endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,813) ((gl(i,j),j=1,6),i=1,6) -c 813 format('gl ',/,(6(1x,e11.4))) -c endif -! -! filling the RHS -! - do i=1,6 - gr(i,1)=sg(i) - enddo -! -! solve gl:(P:n)=gr -! - call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! - do i=1,6 - Pn(i)=gr(i,1) - enddo -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,411) (Pn(i),i=1,6) -c 411 format('Pn ',/,(6(1x,e11.4))) -c endif -! -c c3=-1.d0/(a+b) - c3=-h2/(1.d0+b*h2) - QSn(1)=c3*(x(1)*Pn(1)+x(2)*Pn(2)+x(4)*Pn(3)+ - & 2.d0*(x(7)*Pn(4)+x(11)*Pn(5)+x(16)*Pn(6)))+sg(1)*h2 - QSn(2)=c3*(x(2)*Pn(1)+x(3)*Pn(2)+x(5)*Pn(3)+ - & 2.d0*(x(8)*Pn(4)+x(12)*Pn(5)+x(17)*Pn(6)))+sg(2)*h2 - QSn(3)=c3*(x(4)*Pn(1)+x(5)*Pn(2)+x(6)*Pn(3)+ - & 2.d0*(x(9)*Pn(4)+x(13)*Pn(5)+x(18)*Pn(6)))+sg(3)*h2 - QSn(4)=c3*(x(7)*Pn(1)+x(8)*Pn(2)+x(9)*Pn(3)+ - & 2.d0*(x(10)*Pn(4)+x(14)*Pn(5)+x(19)*Pn(6)))+sg(4)*h2 - QSn(5)=c3*(x(11)*Pn(1)+x(12)*Pn(2)+x(13)*Pn(3)+ - & 2.d0*(x(14)*Pn(4)+x(15)*Pn(5)+x(20)*Pn(6)))+sg(5)*h2 - QSn(6)=c3*(x(16)*Pn(1)+x(17)*Pn(2)+x(18)*Pn(3)+ - & 2.d0*(x(19)*Pn(4)+x(20)*Pn(5)+x(21)*Pn(6)))+sg(6)*h2 -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,412) (QSn(i),i=1,6) -c 412 format('QSn ',/,(6(1x,e11.4))) -c endif -! -! calculating the creep contribution -! - if(creep) then - if(dg.gt.0.d0) then - gcreep=c0*ca/cn*(dg*ca)**(1.d0/cn-1.d0) - else -! -! for gamma ein default of 1.d-10 is taken to -! obtain a finite gradient -! - gcreep=c0*ca/cn*(1.d-10*ca)**(1.d0/cn-1.d0) - endif - endif -! -! calculating the correction to the consistency parameter -! - gm1=Pn(1)*sg(1)+Pn(2)*sg(2)+Pn(3)*sg(3)+ - & 2.d0*(Pn(4)*sg(4)+Pn(5)*sg(5)+Pn(6)*sg(6))+ - & c1*h1+ - & QSn(1)*sg(1)+QSn(2)*sg(2)+QSn(3)*sg(3)+ - & 2.d0*(QSn(4)*sg(4)+QSn(5)*sg(5)+QSn(6)*sg(6)) - if(creep) then - gm1=1.d0/(gm1+gcreep) - else - gm1=1.d0/gm1 - endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,512) gm1 -c 512 format('gm1 ',/,(6(1x,e11.4))) -c endif - ddg=gm1*(htri-(Pn(1)*r(1)+Pn(2)*r(2)+Pn(3)*r(3)+ - & 2.d0*(Pn(4)*r(4)+Pn(5)*r(5)+Pn(6)*r(6))+ - & c0*h1*r(7)+ - & QSn(1)*r(8)+QSn(2)*r(9)+QSn(3)*r(10)+ - & 2.d0*(QSn(4)*r(11)+QSn(5)*r(12)+QSn(6)*r(13)))) -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,313) ddg -c 313 format('ddg ',/,(6(1x,e11.4))) -c endif -! -! updating the residual matrix -! - do i=1,6 - r(i)=r(i)+ddg*sg(i) - enddo - r(7)=r(7)+ddg*c0 - do i=1,6 - r(7+i)=r(7+i)+ddg*sg(i) - enddo -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,210) (r(i),i=1,13) -c 210 format('r up ',/,(6(1x,e11.4))) -c endif -! -! update the plastic strain -! - gr(1,1)=au1(1)*r(1)+au1(2)*r(2)+au1(4)*r(3)+ - & 2.d0*(au1(7)*r(4)+au1(11)*r(5)+au1(16)*r(6)) - & -h2*(x(1)*r(8)+x(2)*r(9)+x(4)*r(10)+ - & 2.d0*(x(7)*r(11)+x(11)*r(12)+x(16)*r(13))) - gr(2,1)=au1(2)*r(1)+au1(3)*r(2)+au1(5)*r(3)+ - & 2.d0*(au1(8)*r(4)+au1(12)*r(5)+au1(17)*r(6)) - & -h2*(x(2)*r(8)+x(3)*r(9)+x(5)*r(10)+ - & 2.d0*(x(8)*r(11)+x(12)*r(12)+x(17)*r(13))) - gr(3,1)=au1(4)*r(1)+au1(5)*r(2)+au1(6)*r(3)+ - & 2.d0*(au1(9)*r(4)+au1(13)*r(5)+au1(18)*r(6)) - & -h2*(x(4)*r(8)+x(5)*r(9)+x(6)*r(10)+ - & 2.d0*(x(9)*r(11)+x(13)*r(12)+x(18)*r(13))) - gr(4,1)=au1(7)*r(1)+au1(8)*r(2)+au1(9)*r(3)+ - & 2.d0*(au1(10)*r(4)+au1(14)*r(5)+au1(19)*r(6)) - & -h2*(x(7)*r(8)+x(8)*r(9)+x(9)*r(10)+ - & 2.d0*(x(10)*r(11)+x(14)*r(12)+x(19)*r(13))) - gr(5,1)=au1(11)*r(1)+au1(12)*r(2)+au1(13)*r(3)+ - & 2.d0*(au1(14)*r(4)+au1(15)*r(5)+au1(20)*r(6)) - & -h2*(x(11)*r(8)+x(12)*r(9)+x(13)*r(10)+ - & 2.d0*(x(14)*r(11)+x(15)*r(12)+x(20)*r(13))) - gr(6,1)=au1(16)*r(1)+au1(17)*r(2)+au1(18)*r(3)+ - & 2.d0*(au1(19)*r(4)+au1(20)*r(5)+au1(21)*r(6)) - & -h2*(x(16)*r(8)+x(17)*r(9)+x(18)*r(10)+ - & 2.d0*(x(19)*r(11)+x(20)*r(12)+x(21)*r(13))) -! - call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! - if(iorien.gt.0) then - ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+cm1(4)*gr(3,1)+ - & 2.d0*(cm1(7)*gr(4,1)+cm1(11)*gr(5,1)+cm1(16)*gr(6,1)) - ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+cm1(5)*gr(3,1)+ - & 2.d0*(cm1(8)*gr(4,1)+cm1(12)*gr(5,1)+cm1(17)*gr(6,1)) - ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+cm1(6)*gr(3,1)+ - & 2.d0*(cm1(9)*gr(4,1)+cm1(13)*gr(5,1)+cm1(18)*gr(6,1)) - ep(4)=ep(4)+cm1(7)*gr(1,1)+cm1(8)*gr(2,1)+cm1(9)*gr(3,1)+ - & 2.d0*(cm1(10)*gr(4,1)+cm1(14)*gr(5,1)+cm1(19)*gr(6,1)) - ep(5)=ep(5)+cm1(11)*gr(1,1)+cm1(12)*gr(2,1)+cm1(13)*gr(3,1)+ - & 2.d0*(cm1(14)*gr(4,1)+cm1(15)*gr(5,1)+cm1(20)*gr(6,1)) - ep(6)=ep(6)+cm1(16)*gr(1,1)+cm1(17)*gr(2,1)+cm1(18)*gr(3,1)+ - & 2.d0*(cm1(19)*gr(4,1)+cm1(20)*gr(5,1)+cm1(21)*gr(6,1)) - else - ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+cm1(4)*gr(3,1) - ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+cm1(5)*gr(3,1) - ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+cm1(6)*gr(3,1) - ep(4)=ep(4)+2.d0*cm1(7)*gr(4,1) - ep(5)=ep(5)+2.d0*cm1(8)*gr(5,1) - ep(6)=ep(6)+2.d0*cm1(9)*gr(6,1) - endif -! -! update the isotropic hardening variable -! - al1=al1+r(7) -! -! update the kinematic hardening variables -! -c c4=a/(a+b) -c c6=b/(a+b) - c4=1.d0/(1.d0+b*h2) - c6=c4*b*h2 - c5=c6/3.d0 - au2(1)=c4+c5+c6*sg(1)*sg(1) - au2(2)=c5+c6*sg(1)*sg(2) - au2(3)=c4+c5+c6*sg(2)*sg(2) - au2(4)=c5+c6*sg(1)*sg(3) - au2(5)=c5+c6*sg(2)*sg(3) - au2(6)=c4+c5+c6*sg(3)*sg(3) - au2(7)=c6*sg(1)*sg(4) - au2(8)=c6*sg(2)*sg(4) - au2(9)=c6*sg(3)*sg(4) - au2(10)=c4/2.d0+c6*sg(4)*sg(4) - au2(11)=c6*sg(1)*sg(5) - au2(12)=c6*sg(2)*sg(5) - au2(13)=c6*sg(3)*sg(5) - au2(14)=c6*sg(4)*sg(5) - au2(15)=c4/2.d0+c6*sg(5)*sg(5) - au2(16)=c6*sg(1)*sg(6) - au2(17)=c6*sg(2)*sg(6) - au2(18)=c6*sg(3)*sg(6) - au2(19)=c6*sg(4)*sg(6) - au2(20)=c6*sg(5)*sg(6) - au2(21)=c4/2.d0+c6*sg(6)*sg(6) -! - al2(1)=al2(1)+au2(1)*r(8)+au2(2)*r(9)+au2(4)*r(10)+ - & 2.d0*(au2(7)*r(11)+au2(11)*r(12)+au2(16)*r(13)) - & -c4*(x(1)*gr(1,1)+x(2)*gr(2,1)+x(4)*gr(3,1)+ - & 2.d0*(x(7)*gr(4,1)+x(11)*gr(5,1)+x(16)*gr(6,1))) - al2(2)=al2(2)+au2(2)*r(8)+au2(3)*r(9)+au2(5)*r(10)+ - & 2.d0*(au2(8)*r(11)+au2(12)*r(12)+au2(17)*r(13)) - & -c4*(x(2)*gr(1,1)+x(3)*gr(2,1)+x(5)*gr(3,1)+ - & 2.d0*(x(8)*gr(4,1)+x(12)*gr(5,1)+x(17)*gr(6,1))) - al2(3)=al2(3)+au2(4)*r(8)+au2(5)*r(9)+au2(6)*r(10)+ - & 2.d0*(au2(9)*r(11)+au2(13)*r(12)+au2(18)*r(13)) - & -c4*(x(4)*gr(1,1)+x(5)*gr(2,1)+x(6)*gr(3,1)+ - & 2.d0*(x(9)*gr(4,1)+x(13)*gr(5,1)+x(18)*gr(6,1))) - al2(4)=al2(4)+au2(7)*r(8)+au2(8)*r(9)+au2(9)*r(10)+ - & 2.d0*(au2(10)*r(11)+au2(14)*r(12)+au2(19)*r(13)) - & -c4*(x(7)*gr(1,1)+x(8)*gr(2,1)+x(9)*gr(3,1)+ - & 2.d0*(x(10)*gr(4,1)+x(14)*gr(5,1)+x(19)*gr(6,1))) - al2(5)=al2(5)+au2(11)*r(8)+au2(12)*r(9)+au2(13)*r(10)+ - & 2.d0*(au2(14)*r(11)+au2(15)*r(12)+au2(20)*r(13)) - & -c4*(x(11)*gr(1,1)+x(12)*gr(2,1)+x(13)*gr(3,1)+ - & 2.d0*(x(14)*gr(4,1)+x(15)*gr(5,1)+x(20)*gr(6,1))) - al2(6)=al2(6)+au2(16)*r(8)+au2(17)*r(9)+au2(18)*r(10)+ - & 2.d0*(au2(19)*r(11)+au2(20)*r(12)+au2(21)*r(13)) - & -c4*(x(16)*gr(1,1)+x(17)*gr(2,1)+x(18)*gr(3,1)+ - & 2.d0*(x(19)*gr(4,1)+x(20)*gr(5,1)+x(21)*gr(6,1))) -! -! update the consistency parameter -! - dg=dg+ddg -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) 'ep ',(ep(i),i=1,6) -c write(*,211) al1 -c 211 format('al1new ',/,(6(1x,e11.4))) -c write(*,212) (al2(i),i=1,6) -c 212 format('al2new ',/,(6(1x,e11.4))) -c write(*,213) dg -c 213 format('dg ',/,(6(1x,e11.4))) -c endif -! -! end of major loop -! - enddo -! -! storing the stress -! - do i=1,6 - stre(i)=stri(i) - enddo -! -! calculating the tangent stiffness matrix -! - if(icmd.ne.3) then -! -! determining p -! - gr(1,1)=au1(1) - gr(1,2)=au1(2) - gr(2,2)=au1(3) - gr(1,3)=au1(4) - gr(2,3)=au1(5) - gr(3,3)=au1(6) - gr(1,4)=au1(7) - gr(2,4)=au1(8) - gr(3,4)=au1(9) - gr(4,4)=au1(10) - gr(1,5)=au1(11) - gr(2,5)=au1(12) - gr(3,5)=au1(13) - gr(4,5)=au1(14) - gr(5,5)=au1(15) - gr(1,6)=au1(16) - gr(2,6)=au1(17) - gr(3,6)=au1(18) - gr(4,6)=au1(19) - gr(5,6)=au1(20) - gr(6,6)=au1(21) - do i=1,6 - do j=1,i-1 - gr(i,j)=gr(j,i) - enddo - enddo - nrhs=6 -! - call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,714) ((gr(i,j),j=1,6),i=1,6) -c 714 format('gr ',/,(6(1x,e11.4))) -c endif - stiff(1)=gr(1,1)-gm1*Pn(1)*Pn(1) - stiff(2)=gr(1,2)-gm1*Pn(1)*Pn(2) - stiff(3)=gr(2,2)-gm1*Pn(2)*Pn(2) - stiff(4)=gr(1,3)-gm1*Pn(1)*Pn(3) - stiff(5)=gr(2,3)-gm1*Pn(2)*Pn(3) - stiff(6)=gr(3,3)-gm1*Pn(3)*Pn(3) - stiff(7)=gr(1,4)-gm1*Pn(1)*Pn(4) - stiff(8)=gr(2,4)-gm1*Pn(2)*Pn(4) - stiff(9)=gr(3,4)-gm1*Pn(3)*Pn(4) - stiff(10)=gr(4,4)-gm1*Pn(4)*Pn(4) - stiff(11)=gr(1,5)-gm1*Pn(1)*Pn(5) - stiff(12)=gr(2,5)-gm1*Pn(2)*Pn(5) - stiff(13)=gr(3,5)-gm1*Pn(3)*Pn(5) - stiff(14)=gr(4,5)-gm1*Pn(4)*Pn(5) - stiff(15)=gr(5,5)-gm1*Pn(5)*Pn(5) - stiff(16)=gr(1,6)-gm1*Pn(1)*Pn(6) - stiff(17)=gr(2,6)-gm1*Pn(2)*Pn(6) - stiff(18)=gr(3,6)-gm1*Pn(3)*Pn(6) - stiff(19)=gr(4,6)-gm1*Pn(4)*Pn(6) - stiff(20)=gr(5,6)-gm1*Pn(5)*Pn(6) - stiff(21)=gr(6,6)-gm1*Pn(6)*Pn(6) -! -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) 'stiffness ' -c write(*,'(6(1x,e11.4))') (stiff(i),i=1,21) -c endif - endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,311) q1 -c 311 format('q1new ',/,(6(1x,e11.4))) -c write(*,312) (q2(i),i=1,6) -c 312 format('q2new ',/,(6(1x,e11.4))) -c endif -c if((iint.eq.1).and.(iel.eq.1)) then -c write(*,*) ' stress ' -c write(*,'(6(1x,e11.4))') (stri(i),i=1,6) -c write(*,214) dg,dtime -c 214 format('dg ',/,(6(1x,e11.4))) -c endif -! -! updating the state variables -! - xstate(1,iint,iel)=eeq+c0*dg - do i=1,6 - xstate(1+i,iint,iel)=ep(i) - enddo - xstate(8,iint,iel)=al1 - do i=1,6 - xstate(8+i,iint,iel)=al2(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_elastic_fiber.f calculix-ccx-2.3/ccx_2.1/src/umat_elastic_fiber.f --- calculix-ccx-2.1/ccx_2.1/src/umat_elastic_fiber.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_elastic_fiber.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,390 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_elastic_fiber - & (amat,iel,iint,kode,elconloc,emec,emec0, - & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi, - & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) -! -! calculates stiffness and stresses for a user defined material -! law -! -! icmd=3: calcutates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! 3: calculate only stress -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! Notice that the matrix is an integral part of the -! fourth order material tensor, i.e. the Voigt notation -! is not used. -! - implicit none -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),nfiber,i, - & j,k,l,m,n,ioffset,nt,kk(84),iorien -! - real*8 elconloc(21),stiff(21),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,c(3,3),a(3),pgauss(3), - & orab(7,*),skl(3,3),aa(3),emec(6),time,ttime -! - real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*), - & constant(21),dd,dm(3,3,4),djdc(3,3,4),d2jdc2(3,3,3,3,4), - & v1,v1b,v3,v3bi,v4(4),v4br(4),djbdc(3,3,4),d2jbdc2(3,3,3,3,4), - & didc(3,3,3),d2idc2(3,3,3,3,3),dibdc(3,3,3),d2ibdc2(3,3,3,3,3), - & dudc(3,3),d2udc2(3,3,3,3),v33,cinv(3,3),xk1,xk2,d(3,3),term -! - data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, - & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, - & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, - & 2,3,2,3/ -! -! calculating the transformation matrix -! - if(iorien.gt.0) then - call transformatrix(orab(1,iorien),pgauss,skl) - endif -! -! # of fibers -! - nfiber=(-kode-102)/4 - do i=1,-kode-100 - constant(i)=elconloc(i) - enddo - if(dabs(constant(2)).lt.1.d-10) then - constant(2)=1.d0/(20.d0*constant(1)) - endif -! -! calculation of the Green deformation tensor for the -! mechanical strain -! - do i=1,3 - c(i,i)=emec(i)*2.d0+1.d0 - enddo - c(1,2)=2.d0*emec(4) - c(1,3)=2.d0*emec(5) - c(2,3)=2.d0*emec(6) -! -! creation of the delta Dirac matrix d -! - do i=1,3 - d(i,i)=1.d0 - enddo - d(1,2)=0.d0 - d(1,3)=0.d0 - d(2,3)=0.d0 -! -! calculation of the structural tensors -! - do k=1,nfiber - ioffset=4*k-1 - a(1)=constant(ioffset) - a(2)=constant(ioffset+1) - dd=a(1)*a(1)+a(2)*a(2) - if(dd.gt.1.d0) then - write(*,*) '*ERROR in umat_el_fiber: components of' - write(*,*) ' direction vector ',k,' are too big' - stop - endif - a(3)=dsqrt(1.d0-dd) -! -! check for local coordinate systems -! - if(iorien.gt.0) then - do j=1,3 - aa(j)=a(j) - enddo - do j=1,3 - a(j)=skl(j,1)*aa(1)+skl(j,2)*aa(2)+skl(j,3)*aa(3) - enddo - endif -! - do j=1,3 - do i=1,j - dm(i,j,k)=a(i)*a(j) - enddo - enddo - enddo -! -! calculation of the invariants -! - v1=c(1,1)+c(2,2)+c(3,3) - v3=c(1,1)*(c(2,2)*c(3,3)-c(2,3)*c(2,3)) - & -c(1,2)*(c(1,2)*c(3,3)-c(1,3)*c(2,3)) - & +c(1,3)*(c(1,2)*c(2,3)-c(1,3)*c(2,2)) - do j=1,nfiber - v4(j)=dm(1,1,j)*c(1,1)+dm(2,2,j)*c(2,2)+dm(3,3,j)*c(3,3)+ - & 2.d0*(dm(1,2,j)*c(1,2)+dm(1,3,j)*c(1,3)+dm(2,3,j)*c(2,3)) - enddo -! - v33=v3**(-1.d0/3.d0) -! -! inversion of c -! - cinv(1,1)=(c(2,2)*c(3,3)-c(2,3)*c(2,3))/v3 - cinv(2,2)=(c(1,1)*c(3,3)-c(1,3)*c(1,3))/v3 - cinv(3,3)=(c(1,1)*c(2,2)-c(1,2)*c(1,2))/v3 - cinv(1,2)=(c(1,3)*c(2,3)-c(1,2)*c(3,3))/v3 - cinv(1,3)=(c(1,2)*c(2,3)-c(2,2)*c(1,3))/v3 - cinv(2,3)=(c(1,2)*c(1,3)-c(1,1)*c(2,3))/v3 - cinv(2,1)=cinv(1,2) - cinv(3,1)=cinv(1,3) - cinv(3,2)=cinv(2,3) -! -! first derivative of the invariants with respect to c(k,l) -! - do l=1,3 - do k=1,l - didc(k,l,1)=d(k,l) - didc(k,l,3)=v3*cinv(k,l) - do j=1,nfiber - djdc(k,l,j)=dm(k,l,j) - enddo - enddo - enddo -! -! second derivative of the invariants w.r.t. c(k,l) -! and c(m,n) -! - if(icmd.ne.3) then - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2idc2(k,l,m,n,1)=0.d0 - d2idc2(k,l,m,n,3)=v3*(cinv(m,n)*cinv(k,l)- - & (cinv(k,m)*cinv(n,l)+cinv(k,n)*cinv(m,l))/2.d0) - do j=1,nfiber - d2jdc2(k,l,m,n,j)=0.d0 - enddo - enddo - endif -! -! derivatives for the reduced invariants -! - v1b=v1*v33 - v3bi=1.d0/dsqrt(v3) - do j=1,nfiber - v4br(j)=v4(j)*v33-1.d0 - enddo -! -! first derivative of the reduced c-invariants w.r.t. c(k,l) -! - do l=1,3 - do k=1,l - dibdc(k,l,1)=-v33**4*v1*didc(k,l,3)/3.d0 - & +v33*didc(k,l,1) - do j=1,nfiber - djbdc(k,l,j)=-v33**4*v4(j)*didc(k,l,3)/3.d0 - & +v33*djdc(k,l,j) - enddo - enddo - enddo -! -! second derivative of the reduced c-invariants w.r.t. c(k,l) -! and c(m,n) -! - if(icmd.ne.3) then - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - d2ibdc2(k,l,m,n,1)=4.d0/9.d0*v33**7*v1*didc(k,l,3) - & *didc(m,n,3)-v33**4/3.d0*(didc(m,n,1)*didc(k,l,3) - & +didc(k,l,1)*didc(m,n,3))-v33**4/3.d0*v1* - & d2idc2(k,l,m,n,3)+v33*d2idc2(k,l,m,n,1) - do j=1,nfiber - d2jbdc2(k,l,m,n,j)=4.d0/9.d0*v33**7*v4(j)*didc(k,l,3) - & *didc(m,n,3)-v33**4/3.d0*(djdc(m,n,j)*didc(k,l,3) - & +djdc(k,l,j)*didc(m,n,3))-v33**4/3.d0*v4(j)* - & d2idc2(k,l,m,n,3)+v33*d2jdc2(k,l,m,n,j) - enddo - enddo - endif -! -! calculation of the stress -! the anisotropy is only taken into account for v4br(j)>=0 -! - do l=1,3 - do k=1,l - dudc(k,l)=constant(1)*dibdc(k,l,1)+ - & (1.d0-v3bi)*didc(k,l,3)/constant(2) - do j=1,nfiber - if(v4br(j).lt.0.d0) cycle - if(xk2*v4br(j)**2.gt.227.d0) then - write(*,*) '*ERROR in umat_elastic_fiber' - write(*,*) ' fiber extension is too large' - write(*,*) ' for exponential function' - stop - endif - ioffset=4*j - xk1=constant(ioffset+1) - xk2=constant(ioffset+2) - dudc(k,l)=dudc(k,l)+xk1*v4br(j)* - & dexp(xk2*v4br(j)**2)*djbdc(k,l,j) - enddo - enddo - enddo -! -! calculation of the stiffness matrix -! the anisotropy is only taken into account for v4br(j)>=0 -! - if(icmd.ne.3) then - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - term=constant(1)*d2ibdc2(k,l,m,n,1)+ - & v3bi**3*didc(k,l,3)*didc(m,n,3)/(2.d0*constant(2)) - & +(1.d0-v3bi)*d2idc2(k,l,m,n,3)/constant(2) - do j=1,nfiber - if(v4br(j).lt.0.d0) cycle - ioffset=4*j - xk1=constant(ioffset+1) - xk2=constant(ioffset+2) - term=term+xk1*dexp(xk2*v4br(j)**2)* - & (djbdc(k,l,j)*djbdc(m,n,j)*(1.d0+2.d0*xk2*v4br(j)**2)+ - & v4br(j)*d2jbdc2(k,l,m,n,j)) - enddo - d2udc2(k,l,m,n)=term - enddo - endif -! -! storing the stiffness matrix and/or the stress -! - if(icmd.ne.3) then -! -! storing the stiffness matrix -! - nt=0 - do i=1,21 - k=kk(nt+1) - l=kk(nt+2) - m=kk(nt+3) - n=kk(nt+4) - nt=nt+4 - stiff(i)=4.d0*d2udc2(k,l,m,n) - enddo - endif -! -! store the stress at mechanical strain -! - stre(1)=2.d0*dudc(1,1) - stre(2)=2.d0*dudc(2,2) - stre(3)=2.d0*dudc(3,3) - stre(4)=2.d0*dudc(1,2) - stre(5)=2.d0*dudc(1,3) - stre(6)=2.d0*dudc(2,3) -! - return - end - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat.f calculix-ccx-2.3/ccx_2.1/src/umat.f --- calculix-ccx-2.1/ccx_2.1/src/umat.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,89 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat(stress,statev,ddsdde,sse,spd,scd, - & rpl,ddsddt,drplde,drpldt, - & stran,dstran,time,dtime,temp,dtemp,predef,dpred,cmname, - & ndi,nshr,ntens,nstatv,props,nprops,coords,drot,pnewdt, - & celent,dfgrd0,dfgrd1,noel,npt,layer,kspt,kstep,kinc) -! -! here, an ABAQUS umat routine can be inserted -! -! note that reals should be double precision (REAL*8) -! - implicit none -! - character*80 cmname -! - integer ndi,nshr,ntens,nstatv,nprops,noel,npt,layer,kspt, - & kstep,kinc -! - real*8 stress(ntens),statev(nstatv), - & ddsdde(ntens,ntens),ddsddt(ntens),drplde(ntens), - & stran(ntens),dstran(ntens),time(2),celent, - & props(nprops),coords(3),drot(3,3),dfgrd0(3,3),dfgrd1(3,3), - & sse,spd,scd,rpl,drpldt,dtime,temp,dtemp,predef,dpred, - & pnewdt -! -! START EXAMPLE LINEAR ELASTIC MATERIAL -! - integer i,j - real*8 e,un,al,um,am1,am2 -! -c write(*,*) 'noel,npt ',noel,npt -c write(*,*) 'stress ',(stress(i),i=1,6) -c write(*,*) 'stran ',(stran(i),i=1,6) -c write(*,*) 'dstran ',(dstran(i),i=1,6) -c write(*,*) 'drot ',((drot(i,j),i=1,3),j=1,3) - e=props(1) - un=props(2) - al=un*e/(1.d0+un)/(1.d0-2.d0*un) - um=e/2.d0/(1.d0+un) - am1=al+2.d0*um - am2=2.d0*um -! -! stress -! - stress(1)=stress(1)+am1*dstran(1)+al*(dstran(2)+dstran(3)) - stress(2)=stress(2)+am1*dstran(2)+al*(dstran(1)+dstran(3)) - stress(3)=stress(3)+am1*dstran(3)+al*(dstran(1)+dstran(2)) - stress(4)=stress(4)+am2*dstran(4) - stress(5)=stress(5)+am2*dstran(5) - stress(6)=stress(6)+am2*dstran(6) -! -! stiffness -! - do i=1,6 - do j=i,6 - ddsdde(i,j)=0.d0 - enddo - enddo - ddsdde(1,1)=al+2.d0*um - ddsdde(1,2)=al - ddsdde(2,2)=al+2.d0*um - ddsdde(1,3)=al - ddsdde(2,3)=al - ddsdde(3,3)=al+2.d0*um - ddsdde(4,4)=um - ddsdde(5,5)=um - ddsdde(6,6)=um -! -! END EXAMPLE LINEAR ELASTIC MATERIAL -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_gurson.f calculix-ccx-2.3/ccx_2.1/src/umat_gurson.f --- calculix-ccx-2.1/ccx_2.1/src/umat_gurson.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_gurson.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,523 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_gurson(amat,iel,iint,kode,elconloc,emec,emec0, - & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi,nstate_,xstateini,xstate,stre,stiff, - & iorien,pgauss,orab) -! -! calculates stiffness and stresses for a Gurson-type material -! law -! -! icmd=3: calcutates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! 3: calculate only stress -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! Notice that the matrix is an integral part of the -! fourth order material tensor, i.e. the Voigt notation -! is not used. -! - implicit none -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien, - & i,j,n,nrhs,lda,ldb,ipiv(7),info -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), - & time,ttime,xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*), - & um,un,aa,f,um2,dg,ddg,ep(6),s(6),de(6),h,r(7),rg,residual, - & dij(6,6),a(4,4),constant,constant1,constant2,fv(4),bb(4,2), - & ra(4),fa(4),gg,tan(6,6),hv(4),cg,ak,ehydro,af(7),ar(7),edev(6), - & ainv(6,6),acp(6,6),d,al,dij4(4,4),xd(6),s23,s32,c1,c2,c3,fc,ff, - & fn,en,sn,r0,um3,q0,f0,el(6),p,ds,xn(6),svm,svm2,dp,dsvm,dei,den, - & aki,arg,cco,sco,c1c2,c1c2f,c1c2fp,q2,q3,q4,depr,devm,dhs,dhss, - & dhsq,dhp,dhpp,dhpq,dhpf,dhq,dhf,b11,b12,b21,b22,q,ep0(6),fnsn, - & eplm -! - data dij /1.d0,0.d0,0.d0,0.d0,0.d0,0.d0, - & 0.d0,1.d0,0.d0,0.d0,0.d0,0.d0, - & 0.d0,0.d0,1.d0,0.d0,0.d0,0.d0, - & 0.d0,0.d0,0.d0,.5d0,0.d0,0.d0, - & 0.d0,0.d0,0.d0,0.d0,.5d0,0.d0, - & 0.d0,0.d0,0.d0,0.d0,0.d0,.5d0/ - data dij4 /1.d0,0.d0,0.d0,0.d0, - & 0.d0,1.d0,0.d0,0.d0, - & 0.d0,0.d0,1.d0,0.d0, - & 0.d0,0.d0,0.d0,1.d0/ - data xd /1.d0,1.d0,1.d0,0.d0,0.d0,0.d0/ -! - s23=dsqrt(2.d0/3.d0) - s32=dsqrt(1.5d0) -! -! material constants -! - um=elconloc(1) - un=elconloc(2) - c1=elconloc(3) - c2=elconloc(4) - c3=elconloc(5) - fc=elconloc(6) - ff=elconloc(7) - fn=elconloc(8) - en=elconloc(9) - sn=elconloc(10) - r0=elconloc(11) -! - um2=2.d0*um - um3=1.d0/(3.d0*um) -! -! internal variables at the start of the increment -! -! yield stress of the fully dense material -! - q0=xstateini(1,iint,iel) -! -! plastic strain -! - do i=1,6 - ep0(i)=xstateini(1+i,iint,iel) - enddo -! -! void volume fraction -! - f0=xstateini(8,iint,iel) -! -! elastic strain in the assumption that no plasticity -! occurs in the present increment -! - do i=1,6 - el(i)=emec(i)-ep0(i) - enddo -! -! hydrostatic strain -! - ehydro=(el(1)+el(2)+el(3))/3.d0 -! -! deviatoric strain -! - do i=1,3 - edev(i)=el(i)-ehydro - enddo - do i=4,6 - edev(i)=el(i) - enddo -! -! deviatoric trial stress -! - do i=1,6 - s(i)=um2*edev(i) - enddo -! -! trial pressure -! - ak=3.d0*(2.d0*um*(1.d0+un))/(3.d0*(1.d0-2.d0*un)) - p=ak*ehydro -! -! radial vector -! - ds=dsqrt(s(1)*s(1)+s(2)*s(2)+s(3)*s(3)+ - & 2.d0*(s(4)*s(4)+s(5)*s(5)+s(6)*s(6))) - do i=1,6 - xn(i)=s(i)/ds - enddo -! -! von Mises stress -! - svm=s32*ds -! -! yield criterion -! - h=(svm*svm)/(q0*q0)+2.d0*c1*f0*dcosh(3.d0*p*c2/(2.d0*q0)) - & -(1.d0+c3*f0*f0) -! - if(h.le.0.d0) then - do i=1,3 - stre(i)=s(i)+ak*ehydro - enddo - do i=4,6 - stre(i)=s(i) - enddo -! - if(icmd.ne.3) then - al=2.d0*un*um/(1.d0-2.d0*un) - stiff(1)=al+2.d0*um - stiff(2)=al - stiff(3)=al+2.d0*um - stiff(4)=al - stiff(5)=al - stiff(6)=al+2.d0*um - stiff(7)=0.d0 - stiff(8)=0.d0 - stiff(9)=0.d0 - stiff(10)=um - stiff(11)=0.d0 - stiff(12)=0.d0 - stiff(13)=0.d0 - stiff(14)=0.d0 - stiff(15)=um - stiff(16)=0.d0 - stiff(17)=0.d0 - stiff(18)=0.d0 - stiff(19)=0.d0 - stiff(20)=0.d0 - stiff(21)=um - endif -! - return - endif -! -! plasticity; initialization of the fields -! - dg=0.d0 - ddg=0.d0 - dp=0.d0 - dsvm=0.d0 - q=q0 - f=f0 -! -! total strain increment -! - do i=1,6 - de(i)=emec(i)-emec0(i) - enddo - dei=de(1)+de(2)+de(3) - den=de(1)*xn(1)+de(2)*xn(2)+de(3)*xn(3)+ - & 2.d0*(de(4)*xn(4)+de(5)*xn(5)+de(6)*xn(6)) -! -! auxiliary variables -! - aki=1.d0/ak - fnsn=fn/(sn*dsqrt(8.d0*datan(1.d0))) -! -! starting the loop to determine the consistency parameter -! - do -! -! inverse of the tangent hardening modulus (to complete!) -! - d=1. - eplm=1. -! -! void nucleation constant -! - aa=fnsn*dexp(-((eplm-en)/sn)**2/2.d0) -! -! auxiliary variables -! - arg=3.d0*c2*p/(2.d0*q) - cco=dcosh(arg) - sco=dsinh(arg) - c1c2=c1*c2 - c1c2f=c1c2*f - q2=q*q -! - depr=dei+dp*aki - devm=dsvm*um3-s23*den - svm2=svm*svm -! -! determining the residuals -! - r(1)=-depr+dg*3.d0*c1c2f*sco/q - r(2)=-devm+dg*2.d0*svm/q2 - r(3)=(1-f)*d*q*(q0-q)+devm*svm-depr*p - r(4)=f0-f+(1.d0-f)*depr-aa*d*(q-q0) -! - rg=(svm2)/q2+2.d0*c1*f*cco+1.d0+c3*f*f -! -! check convergence -! - residual=r(1)*r(1)+r(2)*r(2)+r(3)*r(3)+r(4)*r(4)+rg*rg - if((residual.le.1.d-10).or.(dabs(ddg).lt.1.d-3*dabs(dg))) exit -! -! auxiliary variables -! - c1c2fp=c1c2f*p - q3=q2*q - q4=q3*q -! -! derivatives of the yield function -! - dhs=2.d0*svm/q2 - dhss=2.d0/q2 - dhsq=-4.d0*svm/q -! - dhp=3.d0*c1c2f*sco/q - dhpp=9.d0*c1c2f*c2*cco/(2.d0*q2) - dhpq=-3.d0*c1c2f*sco/q2-9.d0*c1c2fp*c2*cco/(2.d0*q3) - dhpf=3.d0*c1c2*sco/q -! - dhq=-2.d0*svm2/q3-3.d0*c1c2fp*sco/q2 -! - dhf=2.d0*c1*cco+2.d0*c3*f -! - a(1,1)=dg*dhpp-1.d0*aki - a(1,2)=0.d0 - a(1,3)=dg*dhpq - a(4,4)=dg*dhpf - a(2,1)=0.d0 - a(2,2)=dg*dhss+um3 - a(2,3)=dg*dhsq - a(2,4)=0.d0 - a(3,1)=-2.d0*p*aki - a(3,2)=-2.d0*svm*um3 - a(3,3)=-(1.d0-f)*d*(2.d0*q-q0) - a(3,4)=d*q*(q-q0) - a(4,1)=-f*aki - a(4,2)=0.d0 - a(4,3)=-aa*d - a(4,4)=-depr-1.d0 -! -! copying a -! - do i=1,7 - do j=1,7 - ainv(i,j)=a(j,i) - acp(i,j)=a(i,j) - enddo - enddo -! -! vector f -! - fv(1)=dhp - fv(2)=dhs - fv(3)=0.d0 - fv(4)=0.d0 -! -! solving for A:R and A:F -! - do i=1,4 - bb(i,1)=r(i) - bb(i,2)=fv(i) - enddo - n=4 - nrhs=2 - lda=4 - ldb=4 - call dgesv(n,nrhs,a,lda,ipiv,bb,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in umat_gurson:' - write(*,*) ' singular system of equations' - stop - endif - do i=1,4 - ra(i)=bb(i,1) - fa(i)=bb(i,2) - enddo -! -! determination of vector field h and the constant cg -! - hv(1)=dhp - hv(2)=dhs - hv(3)=dhq - hv(4)=dhf - cg=0.d0 -! -! calculating ddg -! - gg=(hv(1)*af(1)+hv(2)*af(2)+hv(3)*af(3)+hv(4)*af(4))-cg - ddg=(rg-(hv(1)*ar(1)+hv(2)*ar(2)+hv(3)*ar(3)+hv(4)*ar(4)))/gg -! - dg=dg+ddg -! -! update p,svm,q and f -! - dp=-ar(1)-ddg*af(1) - p=p+dp - dsvm=-ar(2)-ddg*af(2) - svm=svm+dsvm - q=q-ar(3)-ddg*af(3) - f=f-ar(4)-ddg*af(4) -! - enddo -! -! convergence: calculate the plastic strain -! - devm=s23*dei-dsvm*um3 - depr=dei+dp*aki - constant1=s32*devm - constant2=depr/3.d0 - do i=1,6 - ep(i)=ep0(i)+constant1*xn(i) - enddo - do i=1,3 - ep(i)=ep(i)+constant2 - enddo -! - if(icmd.ne.3) then -! -! tangent matrix -! - nrhs=1 - call dgesv(n,nrhs,ainv,lda,ipiv,hv,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in umat_gurson:' - write(*,*) ' singular system of equations' - stop - endif -! - do i=1,2 - do j=1,2 - tan(i,j)=acp(i,1)*(dij4(1,j)-fv(1)*hv(j)/gg)+ - & acp(i,2)*(dij4(2,j)-fv(2)*hv(j)/gg)+ - & acp(i,3)*(dij4(3,j)-fv(3)*hv(j)/gg)+ - & acp(i,4)*(dij4(4,j)-fv(4)*hv(j)/gg) - enddo - enddo -! - constant=s23*svm+um2/ds - b11=-tan(1,1)-constant/3.d0 - b12=-s23*tan(1,2) - b21=s23*tan(2,1) - b22=s23*s23*tan(2,2)-constant -! - do i=1,6 - do j=1,6 - tan(i,j)=dij(i,j)*constant+b11*xd(i)*xd(j)+ - & b12*xn(i)*xd(j)+b21*xd(i)*xn(j)+ - & b22*xn(i)*xn(j) - enddo - enddo -! -! symmatrizing the stiffness matrix -! - stiff(1)=tan(1,1) - stiff(2)=(tan(1,2)+tan(2,1))/2.d0 - stiff(3)=tan(2,2) - stiff(4)=(tan(1,3)+tan(3,1))/2.d0 - stiff(5)=(tan(2,3)+tan(3,2))/2.d0 - stiff(6)=tan(3,3) - stiff(7)=(tan(1,4)+tan(4,1))/2.d0 - stiff(8)=(tan(2,4)+tan(4,2))/2.d0 - stiff(9)=(tan(3,4)+tan(4,3))/2.d0 - stiff(10)=tan(4,4) - stiff(11)=(tan(1,5)+tan(5,1))/2.d0 - stiff(12)=(tan(2,5)+tan(5,2))/2.d0 - stiff(13)=(tan(3,5)+tan(5,3))/2.d0 - stiff(14)=(tan(4,5)+tan(5,4))/2.d0 - stiff(15)=tan(5,5) - stiff(16)=(tan(1,6)+tan(6,1))/2.d0 - stiff(17)=(tan(2,6)+tan(6,2))/2.d0 - stiff(18)=(tan(3,6)+tan(6,3))/2.d0 - stiff(19)=(tan(4,6)+tan(6,4))/2.d0 - stiff(20)=(tan(5,6)+tan(6,5))/2.d0 - stiff(21)=tan(6,6) -! - endif -! -! internal variables at the end of the increment -! -! yield stress of the fully dense material -! - xstate(1,iint,iel)=q -! -! plastic strain -! - do i=1,6 - xstate(1+i,iint,iel)=ep(i) - enddo -! -! void volume fraction -! - xstate(8,iint,iel)=f -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/umatht.f calculix-ccx-2.3/ccx_2.1/src/umatht.f --- calculix-ccx-2.1/ccx_2.1/src/umatht.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umatht.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,311 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umatht(u,dudt,dudg,flux,dfdt,dfdg, - & statev,temp,dtemp,dtemdx,time,dtime,predef,dpred, - & cmname,ntgrd,nstatv,props,nprops,coords,pnewdt, - & noel,npt,layer,kspt,kstep,kinc,vold,co,lakonl,konl, - & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,mi) -! -! heat transfer material subroutine -! -! INPUT: -! -! statev(nstatv) internal state variables at the start -! of the increment -! temp temperature at the start of the increment -! dtemp increment of temperature -! dtemdx(ntgrd) current values of the spatial gradients of the -! temperature -! time(1) step time at the beginning of the increment -! time(2) total time at the beginning of the increment -! dtime time increment -! predef not used -! dpred not used -! cmname material name -! ntgrd number of spatial gradients of temperature -! nstatv number of internal state variables as defined -! on the *DEPVAR card -! props(nprops) user defined constants defined by the keyword -! card *USER MATERIAL,TYPE=THERMAL -! nprops number of user defined constants, as specified -! on the *USER MATERIAL,TYPE=THERMAL card -! coords global coordinates of the integration point -! pnewd not used -! noel element number -! npt integration point number -! layer not used -! kspt not used -! kstep not used -! kinc not used -! vold(0..4,1..nk) solution field in all nodes -! 0: temperature -! 1: displacement in global x-direction -! 2: displacement in global y-direction -! 3: displacement in global z-direction -! 4: static pressure -! co(3,1..nk) coordinates of all nodes -! 1: coordinate in global x-direction -! 2: coordinate in global y-direction -! 3: coordinate in global z-direction -! lakonl element label -! konl(1..20) nodes belonging to the element -! ipompc(1..nmpc)) ipompc(i) points to the first term of -! MPC i in field nodempc -! nodempc(1,*) node number of a MPC term -! nodempc(2,*) coordinate direction of a MPC term -! nodempc(3,*) if not 0: points towards the next term -! of the MPC in field nodempc -! if 0: MPC definition is finished -! coefmpc(*) coefficient of a MPC term -! nmpc number of MPC's -! ikmpc(1..nmpc) ordered global degrees of freedom of the MPC's -! the global degree of freedom is -! 8*(node-1)+direction of the dependent term of -! the MPC (direction = 0: temperature; -! 1-3: displacements; 4: static pressure; -! 5-7: rotations) -! ilmpc(1..nmpc) ilmpc(i) is the MPC number corresponding -! to the reference number in ikmpc(i) -! mi(1) max # of integration points per element (max -! over all elements) -! mi(2) max degree of freedomm per node (max over all -! nodes) in fields like v(0:mi(2))... -! -! OUTPUT: -! -! u not used -! dudt not used -! dudg(ntgrd) not used -! flux(ntgrd) heat flux at the end of the increment -! dfdt(ntgrd) not used -! dfdg(ntgrd,ntgrd) variation of the heat flux with respect to the -! spatial temperature gradient -! statev(nstatv) internal state variables at the end of the -! increment -! - implicit none -! - character*8 lakonl - character*80 cmname -! - integer ntgrd,nstatv,nprops,noel,npt,layer,kspt,kstep,kinc, - & konl(20),ipompc(*),nodempc(3,*),nmpc,ikmpc(*),ilmpc(*),mi(2) -! - real*8 u,dudt,dudg(ntgrd),flux(ntgrd),dfdt(ntgrd), - & statev(nstatv),pnewdt,temp,dtemp,dtemdx(ntgrd),time(2),dtime, - & predef,dpred,props(nprops),coords(3),dfdg(ntgrd,ntgrd), - & vold(0:mi(2),*),co(3,*),coefmpc(*) -! -! the code starting here up to the end of the file serves as -! an example for combined mechanical-lubrication problems. -! Please replace it by your own code for your concrete application. -! - integer ifaceq(8,6),ifacet(6,4),ifacew(8,5),ig,nelem,nopes, - & iflag,i,j,nope,node,idof,id -! - real*8 xl21(3,8),xi,et,al,rho,um,h,pnode1(3),pnode2(3), - & ratio(8),dist,xl22(3,8) -! - data ifaceq /4,3,2,1,11,10,9,12, - & 5,6,7,8,13,14,15,16, - & 1,2,6,5,9,18,13,17, - & 2,3,7,6,10,19,14,18, - & 3,4,8,7,11,20,15,19, - & 4,1,5,8,12,17,16,20/ - data ifacet /1,3,2,7,6,5, - & 1,2,4,5,9,8, - & 2,3,4,6,10,9, - & 1,4,3,8,10,7/ - data ifacew /1,3,2,9,8,7,0,0, - & 4,5,6,10,11,12,0,0, - & 1,2,5,4,7,14,10,13, - & 2,3,6,5,8,15,11,14, - & 4,6,3,1,12,15,9,13/ - data iflag /2/ -! - nelem=noel - i=npt -! - if(lakonl(4:4).eq.'2') then - nope=20 - nopes=8 - elseif(lakonl(4:4).eq.'8') then - nope=8 - nopes=4 - elseif(lakonl(4:5).eq.'10') then - nope=10 - nopes=6 - elseif(lakonl(4:4).eq.'4') then - nope=4 - nopes=3 - elseif(lakonl(4:5).eq.'15') then - nope=15 - elseif(lakonl(4:4).eq.'6') then - nope=6 - endif -! -! treatment of wedge faces -! - if(lakonl(4:4).eq.'6') then - if(ig.le.2) then - nopes=3 - else - nopes=4 - endif - endif - if(lakonl(4:5).eq.'15') then - if(ig.le.2) then - nopes=6 - else - nopes=8 - endif - endif -! -! first side of the oil film -! - ig=1 -! - if((nope.eq.20).or.(nope.eq.8)) then - do i=1,nopes - node=konl(ifaceq(i,ig)) - idof=8*(node-1)+4 - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in umatht: node ',node - write(*,*) ' is not connected to the structure' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - do j=1,3 - xl21(j,i)=co(j,node)+ - & vold(j,node) - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - write(*,*) '*ERROR in umatht: tetrahedral elements' - write(*,*) ' are not allowed' - stop - else - do i=1,nopes - node=konl(ifacew(i,ig)) - idof=8*(node-1)+4 - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in umatht: node ',node - write(*,*) ' is not connected to the structure' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - do j=1,3 - xl21(j,i)=co(j,node)+ - & vold(j,node) - enddo - enddo - endif -! -! projecting the integration point on the first side of the -! oil film -! - do j=1,3 - pnode1(j)=coords(j) - enddo -! - call attach(xl21,pnode1,nopes,ratio,dist,xi,et) -! -! second side of the oil film -! - ig=2 -! - if((nope.eq.20).or.(nope.eq.8)) then - do i=1,nopes - node=konl(ifaceq(i,ig)) - idof=8*(node-1)+4 - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in umatht: node ',node - write(*,*) ' is not connected to the structure' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - do j=1,3 - xl22(j,i)=co(j,node)+ - & vold(j,node) - enddo - enddo - elseif((nope.eq.10).or.(nope.eq.4)) then - write(*,*) '*ERROR in umatht: tetrahedral elements' - write(*,*) ' are not allowed' - stop - else - do i=1,nopes - node=konl(ifacew(i,ig)) - idof=8*(node-1)+4 - call nident(ikmpc,idof,nmpc,id) - if((id.eq.0).or.(ikmpc(id).ne.idof)) then - write(*,*) '*ERROR in umatht: node ',node - write(*,*) ' is not connected to the structure' - stop - endif - node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) - do j=1,3 - xl22(j,i)=co(j,node)+ - & vold(j,node) - enddo - enddo - endif -! -! projecting the integration point on the second side of the -! oil film -! - do j=1,3 - pnode2(j)=coords(j) - enddo -! - call attach(xl22,pnode2,nopes,ratio,dist,xi,et) -! -! calculating the thickness of the oil film -! - h=dsqrt((pnode1(1)-pnode2(1))**2+ - & (pnode1(2)-pnode2(2))**2+ - & (pnode1(3)-pnode2(3))**2) -! -! density, viscosity (oil, SI units, 290 K) -! - rho=890.d-9 - um=1.d-6 -! - al=(h**3)*rho/(12.d0*um) -! -! filling the tangent matrix -! - do i=1,3 - do j=1,3 - dfdg(i,j)=0.d0 - enddo - dfdg(i,i)=al - enddo -! -! determining the equivalent flux -! - do j=1,ntgrd - flux(j)=-al*dtemdx(j) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_iso_creep.f calculix-ccx-2.3/ccx_2.1/src/umat_iso_creep.f --- calculix-ccx-2.1/ccx_2.1/src/umat_iso_creep.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_iso_creep.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,297 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_iso_creep(amat,iel,iint,kode,elconloc,emec, - & emec0,beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas, - & mi,nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, - & orab) -! -! calculates stiffness and stresses for an elastically isotropic -! material with isotropic creep -! -! icmd=3: calculates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! at mechanical strain -! 3: calculate only stress at mechanical strain -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! Notice that the matrix is an integral part of the -! fourth order material tensor, i.e. the Voigt notation -! is not used. -! - implicit none -! -! - character*20 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien -! - integer i -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), - & time,ttime,arg -! - real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) -! - real*8 c1,c2,c3,ep0(6),eei(6),e,un,al,am1,um2,ep(6),dg, - & ddg,stri(6),p,eeq0,eeq,um,dstri,c4,c5,f,df -! - INTEGER LEXIMP,LEND,NSTATV,KSPT,KSTEP,KINC,LAYER - REAL*8 DECRA(5),DESWA,STATEV,SERD,EC0,ESW0,DTEMP,PREDEF,DPRED, - & DUMMY,COORDS -! - data c1 /0.8164965809277260d0/ - data c2 /0.6666666666666666d0/ - data leximp /1/ -! -! state variables -! - eeq0=xstateini(1,iint,iel) - do i=1,6 - ep0(i)=xstateini(i+1,iint,iel) - enddo -! -! elastic strains -! - do i=1,6 - eei(i)=emec(i)-ep0(i) - enddo -! -! elastic constants -! - e=elconloc(1) - un=elconloc(2) -! - um2=e/(1.d0+un) - al=un*um2/(1.d0-2.d0*un) - am1=al+um2 - um=um2/2.d0 -! - if(ielas.eq.1) then -! - stre(1)=am1*eei(1)+al*(eei(2)+eei(3)) - stre(2)=am1*eei(2)+al*(eei(1)+eei(3)) - stre(3)=am1*eei(3)+al*(eei(1)+eei(2)) - stre(4)=um2*eei(4) - stre(5)=um2*eei(5) - stre(6)=um2*eei(6) -! - if(icmd.ne.3) then - stiff(1)=am1 - stiff(2)=al - stiff(3)=am1 - stiff(4)=al - stiff(5)=al - stiff(6)=am1 - stiff(7)=0.d0 - stiff(8)=0.d0 - stiff(9)=0.d0 - stiff(10)=um - stiff(11)=0.d0 - stiff(12)=0.d0 - stiff(13)=0.d0 - stiff(14)=0.d0 - stiff(15)=um - stiff(16)=0.d0 - stiff(17)=0.d0 - stiff(18)=0.d0 - stiff(19)=0.d0 - stiff(20)=0.d0 - stiff(21)=um - endif - return - endif -! -! creep -! - stri(1)=am1*eei(1)+al*(eei(2)+eei(3)) - stri(2)=am1*eei(2)+al*(eei(1)+eei(3)) - stri(3)=am1*eei(3)+al*(eei(1)+eei(2)) - stri(4)=um2*eei(4) - stri(5)=um2*eei(5) - stri(6)=um2*eei(6) -! - p=-(stri(1)+stri(2)+stri(3))/3.d0 - do i=1,3 - stri(i)=stri(i)+p - enddo -! - dstri=dsqrt(stri(1)*stri(1)+stri(2)*stri(2)+stri(3)*stri(3)+ - & 2.d0*(stri(4)*stri(4)+stri(5)*stri(5)+stri(6)*stri(6))) -! -! unit trial vector -! - do i=1,6 - stri(i)=stri(i)/dstri - enddo -! - dg=0.d0 - eeq=eeq0+c1*dg -! -! determination of the consistency parameter -! - do - arg=(dstri-um2*dg)/c1 - call CREEP( DECRA, DESWA, STATEV, SERD, EC0, ESW0, p, arg, - & t1l, DTEMP, PREDEF, DPRED, DUMMY, dtime, amat, - & leximp, LEND, COORDS, NSTATV, iel, iint, LAYER, - & KSPT, KSTEP, KINC ) - f=decra(1) - df=decra(5) - ddg=(c1*f-c2*dg)/(um2*df+c2) - dg=dg+ddg - eeq=eeq0+c1*dg - if((ddg.lt.dg*1.d-4).or.(ddg.lt.1.d-10)) exit - enddo -! - do i=1,6 - ep(i)=dg*stri(i) - eei(i)=eei(i)-ep(i) - ep(i)=ep0(i)+ep(i) - enddo -! -! stress values -! - stre(1)=am1*eei(1)+al*(eei(2)+eei(3)) - stre(2)=am1*eei(2)+al*(eei(1)+eei(3)) - stre(3)=am1*eei(3)+al*(eei(1)+eei(2)) - stre(4)=um2*eei(4) - stre(5)=um2*eei(5) - stre(6)=um2*eei(6) -! -! stiffness matrix -! - if(icmd.ne.3) then -! - c3=um2*um2 - c4=c3*dg/dstri - c3=c4-c3*df/(um2*df+c2) - c5=c4/3.d0 -! - stiff(1)=am1+c3*stri(1)*stri(1)+c5-c4 - stiff(2)=al+c3*stri(1)*stri(2)+c5 - stiff(3)=am1+c3*stri(2)*stri(2)+c5-c4 - stiff(4)=al+c3*stri(1)*stri(3)+c5 - stiff(5)=al+c3*stri(2)*stri(3)+c5 - stiff(6)=am1+c3*stri(3)*stri(3)+c5-c4 - stiff(7)=0.d0+c3*stri(1)*stri(4) - stiff(8)=0.d0+c3*stri(2)*stri(4) - stiff(9)=0.d0+c3*stri(3)*stri(4) - stiff(10)=um+c3*stri(4)*stri(4)-c4/2.d0 - stiff(11)=0.d0+c3*stri(1)*stri(5) - stiff(12)=0.d0+c3*stri(2)*stri(5) - stiff(13)=0.d0+c3*stri(3)*stri(5) - stiff(14)=0.d0+c3*stri(4)*stri(5) - stiff(15)=um+c3*stri(5)*stri(5)-c4/2.d0 - stiff(16)=0.d0+c3*stri(1)*stri(6) - stiff(17)=0.d0+c3*stri(2)*stri(6) - stiff(18)=0.d0+c3*stri(3)*stri(6) - stiff(19)=0.d0+c3*stri(4)*stri(6) - stiff(20)=0.d0+c3*stri(5)*stri(6) - stiff(21)=um+c3*stri(6)*stri(6)-c4/2.d0 - endif -! -! state variables -! - xstate(1,iint,iel)=eeq - do i=1,6 - xstate(i+1,iint,iel)=ep(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_lin_iso_el.f calculix-ccx-2.3/ccx_2.1/src/umat_lin_iso_el.f --- calculix-ccx-2.1/ccx_2.1/src/umat_lin_iso_el.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_lin_iso_el.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,173 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_lin_iso_el(amat,iel,iint,kode,elconloc,emec,emec0, - & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi, - & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) -! -! calculates stiffness and stresses for a user defined material -! law -! -! icmd=3: calcutates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! 3: calculate only stress -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! Notice that the matrix is an integral part of the -! fourth order material tensor, i.e. the Voigt notation -! is not used. -! - implicit none -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), - & time,ttime -! - real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) -! - real*8 e,un,al,um,am1,am2 -! -! insert here code to calculate the stresses -! - e=elconloc(1) - un=elconloc(2) - al=un*e/(1.d0+un)/(1.d0-2.d0*un) - um=e/2.d0/(1.d0+un) - am1=al+2.d0*um - am2=2.d0*um -! - stre(1)=am1*emec(1)+al*(emec(2)+emec(3))-beta(1) - stre(2)=am1*emec(2)+al*(emec(1)+emec(3))-beta(2) - stre(3)=am1*emec(3)+al*(emec(1)+emec(2))-beta(3) - stre(4)=am2*emec(4)-beta(4) - stre(5)=am2*emec(5)-beta(5) - stre(6)=am2*emec(6)-beta(6) -! - if(icmd.ne.3) then -! -! insert here code to calculate the stiffness matrix -! - stiff(1)=al+2.d0*um - stiff(2)=al - stiff(3)=al+2.d0*um - stiff(4)=al - stiff(5)=al - stiff(6)=al+2.d0*um - stiff(7)=0.d0 - stiff(8)=0.d0 - stiff(9)=0.d0 - stiff(10)=um - stiff(11)=0.d0 - stiff(12)=0.d0 - stiff(13)=0.d0 - stiff(14)=0.d0 - stiff(15)=um - stiff(16)=0.d0 - stiff(17)=0.d0 - stiff(18)=0.d0 - stiff(19)=0.d0 - stiff(20)=0.d0 - stiff(21)=um - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_main.f calculix-ccx-2.3/ccx_2.1/src/umat_main.f --- calculix-ccx-2.1/ccx_2.1/src/umat_main.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_main.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,108 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_main(amat,iel,iint,kode,elconloc,emec,emec0, - & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi, - & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, - & orab,pnewdt,istep,iinc) -! -! calculates stiffness and stresses for a user defined material -! law -! - implicit none -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien, - & istep,iinc -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xikl(3,3),vij,pgauss(3),orab(7,*), - & time,ttime,pnewdt -! - real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) -! - if(amat(1:8).eq.'ABAQUSNL') then -! - call umat_abaqusnl(amat(9:80),iel,iint,kode,elconloc,emec, - & emec0,beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi(1),nstate_,xstateini,xstate,stre,stiff, - & iorien,pgauss,orab,istep,iinc) -! - elseif(amat(1:6).eq.'ABAQUS') then -! - call umat_abaqus(amat(7:80),iel,iint,kode,elconloc,emec, - & emec0,beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi(1),nstate_,xstateini,xstate,stre,stiff, - & iorien,pgauss,orab,istep,iinc) -! - elseif(amat(1:10).eq.'ANISO_PLAS') then -! - call umat_aniso_plas(amat(11:80), - & iel,iint,kode,elconloc,emec,emec0, - & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi(1), - & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) -! - elseif(amat(1:11).eq.'ANISO_CREEP') then -! - call umat_aniso_creep(amat(12:80), - & iel,iint,kode,elconloc,emec,emec0, - & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi(1), - & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) -! - elseif(amat(1:13).eq.'ELASTIC_FIBER') then -! - call umat_elastic_fiber(amat(14:80), - & iel,iint,kode,elconloc,emec,emec0, - & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi(1), - & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) -! - elseif(amat(1:10).eq.'LIN_ISO_EL') then -! - call umat_lin_iso_el(amat(11:80), - & iel,iint,kode,elconloc,emec,emec0, - & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi(1), - & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) -! - elseif(amat(1:14).eq.'SINGLE_CRYSTAL') then -! - call umat_single_crystal(amat(15:80), - & iel,iint,kode,elconloc,emec, - & emec0,beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi(1), - & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) -! - elseif(amat(1:4).eq.'USER') then -! - call umat_user(amat(5:80),iel,iint,kode,elconloc,emec,emec0, - & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi(1),nstate_,xstateini,xstate,stre,stiff, - & iorien,pgauss,orab,pnewdt) - else - write(*,*) '*ERROR in umat: no user material subroutine' - write(*,*) ' defined for material ',amat - stop - endif -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_single_crystal.f calculix-ccx-2.3/ccx_2.1/src/umat_single_crystal.f --- calculix-ccx-2.1/ccx_2.1/src/umat_single_crystal.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_single_crystal.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1422 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_single_crystal(amat,iel,iint,kode,elconloc,emec, - & emec0,beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas, - & mi,nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, - & orab) -! -! calculates stiffness and stresses for a user defined material -! law -! -! icmd=3: calcutates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! 3: calculate only stress -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! Notice that the matrix is an integral part of the -! fourth order material tensor, i.e. the Voigt notation -! is not used. -! - implicit none -! - logical active(18),convergence,creep -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien -! - integer index(18),i,j,k,l,ipiv(18),info,ichange,neq,lda,ldb, - & nrhs,iplas,icounter -! - real*8 ep0(6),al10(18),al20(18),dg0(18),ep(6),al1(18), - & al2(18),dg(18),ddg(18),xm(6,18),h(18,18),ck(18),cn(18), - & c(18),d(18),phi(18),delta(18),r0(18),q(18),b(18),cphi(18), - & q1(18),q2(18),stri(6),htri(18),sg(18),r(42),xmc(6,18),aux(18), - & t(42),gl(18,18),gr(18,18),ee(6),c1111,c1122,c1212,dd, - & skl(3,3),xmtran(3,3),ddsdde(6,6),xx(6,18) -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), - & elas(21),time,ttime -! - real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) -! - save ep0,al10,al20,dg0,xx,h -! -! -! crystallographic slip planes: -! -! 1. n=1,1,1 l=1,-1,0 -! 2. n=1,1,1 l=1,0,-1 -! 3. n=1,1,1 l=0,1,-1 -! 4. n=1,-1,1 l=0,1,1 -! 5. n=1,-1,1 l=1,0,-1 -! 6. n=1,-1,1 l=1,1,0 -! 7. n=1,-1,-1 l=0,1,-1 -! 8. n=1,-1,-1 l=1,0,1 -! 9. n=1,-1,-1 l=1,1,0 -! 10. n=1,1,-1 l=0,1,1 -! 11. n=1,1,-1 l=1,0,1 -! 12. n=1,1,-1 l=1,-1,0 -! 13. n=1,0,0 l=0,1,1 -! 14. n=1,0,0 l=0,1,-1 -! 15. n=0,1,0 l=1,0,1 -! 16. n=0,1,0 l=1,0,-1 -! 17. n=0,0,1 l=1,1,0 -! 18. n=0,0,1 l=1,-1,0 -! - data xm - & /0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.2041241452319E+00,-0.2041241452319E+00, - & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, - & 0.2041241452319E+00, 0.0000000000000E+00,-0.2041241452319E+00, - & 0.0000000000000E+00, 0.4082482904639E+00,-0.4082482904639E+00, - & 0.2041241452319E+00,-0.2041241452319E+00, 0.0000000000000E+00, - & 0.0000000000000E+00,-0.4082482904639E+00, 0.4082482904639E+00, - & 0.2041241452319E+00, 0.2041241452319E+00, 0.0000000000000E+00, - & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, - & -0.2041241452319E+00, 0.0000000000000E+00, 0.2041241452319E+00, - & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.2041241452319E+00, 0.2041241452319E+00, - & 0.0000000000000E+00,-0.4082482904639E+00, 0.4082482904639E+00, - & 0.2041241452319E+00,-0.2041241452319E+00, 0.0000000000000E+00, - & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, - & -0.2041241452319E+00, 0.0000000000000E+00,-0.2041241452319E+00, - & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, - & 0.0000000000000E+00,-0.2041241452319E+00,-0.2041241452319E+00, - & 0.0000000000000E+00, 0.4082482904639E+00,-0.4082482904639E+00, - & 0.2041241452319E+00, 0.2041241452319E+00, 0.0000000000000E+00, - & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, - & 0.2041241452319E+00, 0.0000000000000E+00, 0.2041241452319E+00, - & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, - & 0.0000000000000E+00,-0.2041241452319E+00, 0.2041241452319E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.3535533905933E+00, 0.3535533905933E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.3535533905933E+00,-0.3535533905933E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.3535533905933E+00, 0.0000000000000E+00, 0.3535533905933E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.3535533905933E+00, 0.0000000000000E+00,-0.3535533905933E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.3535533905933E+00, 0.3535533905933E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.3535533905933E+00,-0.3535533905933E+00/ -! - data xx - & /0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.2041241452319E+00,-0.2041241452319E+00, - & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, - & 0.2041241452319E+00, 0.0000000000000E+00,-0.2041241452319E+00, - & 0.0000000000000E+00, 0.4082482904639E+00,-0.4082482904639E+00, - & 0.2041241452319E+00,-0.2041241452319E+00, 0.0000000000000E+00, - & 0.0000000000000E+00,-0.4082482904639E+00, 0.4082482904639E+00, - & 0.2041241452319E+00, 0.2041241452319E+00, 0.0000000000000E+00, - & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, - & -0.2041241452319E+00, 0.0000000000000E+00, 0.2041241452319E+00, - & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.2041241452319E+00, 0.2041241452319E+00, - & 0.0000000000000E+00,-0.4082482904639E+00, 0.4082482904639E+00, - & 0.2041241452319E+00,-0.2041241452319E+00, 0.0000000000000E+00, - & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, - & -0.2041241452319E+00, 0.0000000000000E+00,-0.2041241452319E+00, - & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, - & 0.0000000000000E+00,-0.2041241452319E+00,-0.2041241452319E+00, - & 0.0000000000000E+00, 0.4082482904639E+00,-0.4082482904639E+00, - & 0.2041241452319E+00, 0.2041241452319E+00, 0.0000000000000E+00, - & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, - & 0.2041241452319E+00, 0.0000000000000E+00, 0.2041241452319E+00, - & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, - & 0.0000000000000E+00,-0.2041241452319E+00, 0.2041241452319E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.3535533905933E+00, 0.3535533905933E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.3535533905933E+00,-0.3535533905933E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.3535533905933E+00, 0.0000000000000E+00, 0.3535533905933E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.3535533905933E+00, 0.0000000000000E+00,-0.3535533905933E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.3535533905933E+00, 0.3535533905933E+00, - & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, - & 0.0000000000000E+00, 0.3535533905933E+00,-0.3535533905933E+00/ -! - data h - & /0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00, 0.1E+01,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00, - & -0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00, - & -0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00, 0.1E+01,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.1E+01,-0.1E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00, - & 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00, - & -0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00, - & -0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, - & 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, - & -0.1E+00, 0.1E+01/ -! -! elastic constants -! - c1111=elconloc(1) - c1122=elconloc(2) - c1212=elconloc(3) -! - if(iorien.gt.0) then - call transformatrix(orab(1,iorien),pgauss,skl) - do k=1,18 - do i=1,3 - do j=i,3 - xmtran(i,j)=skl(i,1)*skl(j,1)*xx(1,k)+ - & skl(i,2)*skl(j,2)*xx(2,k)+ - & skl(i,3)*skl(j,3)*xx(3,k)+ - & (skl(i,1)*skl(j,2)+ - & skl(i,2)*skl(j,1))*xx(4,k)+ - & (skl(i,1)*skl(j,3)+ - & skl(i,3)*skl(j,1))*xx(5,k)+ - & (skl(i,2)*skl(j,3)+ - & skl(i,3)*skl(j,2))*xx(6,k) - enddo - enddo - xm(1,k)=xmtran(1,1) - xm(2,k)=xmtran(2,2) - xm(3,k)=xmtran(3,3) - xm(4,k)=xmtran(1,2) - xm(5,k)=xmtran(1,3) - xm(6,k)=xmtran(2,3) - enddo -! - elas( 1)= - & skl(1,1)*skl(1,1)*skl(1,1)*skl(1,1)*c1111+ - & skl(1,1)*skl(1,1)*skl(1,2)*skl(1,2)*c1122+ - & skl(1,1)*skl(1,1)*skl(1,3)*skl(1,3)*c1122+ - & skl(1,1)*skl(1,2)*skl(1,1)*skl(1,2)*c1212+ - & skl(1,1)*skl(1,2)*skl(1,2)*skl(1,1)*c1212+ - & skl(1,1)*skl(1,3)*skl(1,1)*skl(1,3)*c1212+ - & skl(1,1)*skl(1,3)*skl(1,3)*skl(1,1)*c1212+ - & skl(1,2)*skl(1,1)*skl(1,1)*skl(1,2)*c1212+ - & skl(1,2)*skl(1,1)*skl(1,2)*skl(1,1)*c1212+ - & skl(1,2)*skl(1,2)*skl(1,1)*skl(1,1)*c1122+ - & skl(1,2)*skl(1,2)*skl(1,2)*skl(1,2)*c1111+ - & skl(1,2)*skl(1,2)*skl(1,3)*skl(1,3)*c1122+ - & skl(1,2)*skl(1,3)*skl(1,2)*skl(1,3)*c1212+ - & skl(1,2)*skl(1,3)*skl(1,3)*skl(1,2)*c1212+ - & skl(1,3)*skl(1,1)*skl(1,1)*skl(1,3)*c1212+ - & skl(1,3)*skl(1,1)*skl(1,3)*skl(1,1)*c1212+ - & skl(1,3)*skl(1,2)*skl(1,2)*skl(1,3)*c1212+ - & skl(1,3)*skl(1,2)*skl(1,3)*skl(1,2)*c1212+ - & skl(1,3)*skl(1,3)*skl(1,1)*skl(1,1)*c1122+ - & skl(1,3)*skl(1,3)*skl(1,2)*skl(1,2)*c1122+ - & skl(1,3)*skl(1,3)*skl(1,3)*skl(1,3)*c1111 - elas( 2)= - & skl(1,1)*skl(1,1)*skl(2,1)*skl(2,1)*c1111+ - & skl(1,1)*skl(1,1)*skl(2,2)*skl(2,2)*c1122+ - & skl(1,1)*skl(1,1)*skl(2,3)*skl(2,3)*c1122+ - & skl(1,1)*skl(1,2)*skl(2,1)*skl(2,2)*c1212+ - & skl(1,1)*skl(1,2)*skl(2,2)*skl(2,1)*c1212+ - & skl(1,1)*skl(1,3)*skl(2,1)*skl(2,3)*c1212+ - & skl(1,1)*skl(1,3)*skl(2,3)*skl(2,1)*c1212+ - & skl(1,2)*skl(1,1)*skl(2,1)*skl(2,2)*c1212+ - & skl(1,2)*skl(1,1)*skl(2,2)*skl(2,1)*c1212+ - & skl(1,2)*skl(1,2)*skl(2,1)*skl(2,1)*c1122+ - & skl(1,2)*skl(1,2)*skl(2,2)*skl(2,2)*c1111+ - & skl(1,2)*skl(1,2)*skl(2,3)*skl(2,3)*c1122+ - & skl(1,2)*skl(1,3)*skl(2,2)*skl(2,3)*c1212+ - & skl(1,2)*skl(1,3)*skl(2,3)*skl(2,2)*c1212+ - & skl(1,3)*skl(1,1)*skl(2,1)*skl(2,3)*c1212+ - & skl(1,3)*skl(1,1)*skl(2,3)*skl(2,1)*c1212+ - & skl(1,3)*skl(1,2)*skl(2,2)*skl(2,3)*c1212+ - & skl(1,3)*skl(1,2)*skl(2,3)*skl(2,2)*c1212+ - & skl(1,3)*skl(1,3)*skl(2,1)*skl(2,1)*c1122+ - & skl(1,3)*skl(1,3)*skl(2,2)*skl(2,2)*c1122+ - & skl(1,3)*skl(1,3)*skl(2,3)*skl(2,3)*c1111 - elas( 3)= - & skl(2,1)*skl(2,1)*skl(2,1)*skl(2,1)*c1111+ - & skl(2,1)*skl(2,1)*skl(2,2)*skl(2,2)*c1122+ - & skl(2,1)*skl(2,1)*skl(2,3)*skl(2,3)*c1122+ - & skl(2,1)*skl(2,2)*skl(2,1)*skl(2,2)*c1212+ - & skl(2,1)*skl(2,2)*skl(2,2)*skl(2,1)*c1212+ - & skl(2,1)*skl(2,3)*skl(2,1)*skl(2,3)*c1212+ - & skl(2,1)*skl(2,3)*skl(2,3)*skl(2,1)*c1212+ - & skl(2,2)*skl(2,1)*skl(2,1)*skl(2,2)*c1212+ - & skl(2,2)*skl(2,1)*skl(2,2)*skl(2,1)*c1212+ - & skl(2,2)*skl(2,2)*skl(2,1)*skl(2,1)*c1122+ - & skl(2,2)*skl(2,2)*skl(2,2)*skl(2,2)*c1111+ - & skl(2,2)*skl(2,2)*skl(2,3)*skl(2,3)*c1122+ - & skl(2,2)*skl(2,3)*skl(2,2)*skl(2,3)*c1212+ - & skl(2,2)*skl(2,3)*skl(2,3)*skl(2,2)*c1212+ - & skl(2,3)*skl(2,1)*skl(2,1)*skl(2,3)*c1212+ - & skl(2,3)*skl(2,1)*skl(2,3)*skl(2,1)*c1212+ - & skl(2,3)*skl(2,2)*skl(2,2)*skl(2,3)*c1212+ - & skl(2,3)*skl(2,2)*skl(2,3)*skl(2,2)*c1212+ - & skl(2,3)*skl(2,3)*skl(2,1)*skl(2,1)*c1122+ - & skl(2,3)*skl(2,3)*skl(2,2)*skl(2,2)*c1122+ - & skl(2,3)*skl(2,3)*skl(2,3)*skl(2,3)*c1111 - elas( 4)= - & skl(1,1)*skl(1,1)*skl(3,1)*skl(3,1)*c1111+ - & skl(1,1)*skl(1,1)*skl(3,2)*skl(3,2)*c1122+ - & skl(1,1)*skl(1,1)*skl(3,3)*skl(3,3)*c1122+ - & skl(1,1)*skl(1,2)*skl(3,1)*skl(3,2)*c1212+ - & skl(1,1)*skl(1,2)*skl(3,2)*skl(3,1)*c1212+ - & skl(1,1)*skl(1,3)*skl(3,1)*skl(3,3)*c1212+ - & skl(1,1)*skl(1,3)*skl(3,3)*skl(3,1)*c1212+ - & skl(1,2)*skl(1,1)*skl(3,1)*skl(3,2)*c1212+ - & skl(1,2)*skl(1,1)*skl(3,2)*skl(3,1)*c1212+ - & skl(1,2)*skl(1,2)*skl(3,1)*skl(3,1)*c1122+ - & skl(1,2)*skl(1,2)*skl(3,2)*skl(3,2)*c1111+ - & skl(1,2)*skl(1,2)*skl(3,3)*skl(3,3)*c1122+ - & skl(1,2)*skl(1,3)*skl(3,2)*skl(3,3)*c1212+ - & skl(1,2)*skl(1,3)*skl(3,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(1,1)*skl(3,1)*skl(3,3)*c1212+ - & skl(1,3)*skl(1,1)*skl(3,3)*skl(3,1)*c1212+ - & skl(1,3)*skl(1,2)*skl(3,2)*skl(3,3)*c1212+ - & skl(1,3)*skl(1,2)*skl(3,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(1,3)*skl(3,1)*skl(3,1)*c1122+ - & skl(1,3)*skl(1,3)*skl(3,2)*skl(3,2)*c1122+ - & skl(1,3)*skl(1,3)*skl(3,3)*skl(3,3)*c1111 - elas( 5)= - & skl(2,1)*skl(2,1)*skl(3,1)*skl(3,1)*c1111+ - & skl(2,1)*skl(2,1)*skl(3,2)*skl(3,2)*c1122+ - & skl(2,1)*skl(2,1)*skl(3,3)*skl(3,3)*c1122+ - & skl(2,1)*skl(2,2)*skl(3,1)*skl(3,2)*c1212+ - & skl(2,1)*skl(2,2)*skl(3,2)*skl(3,1)*c1212+ - & skl(2,1)*skl(2,3)*skl(3,1)*skl(3,3)*c1212+ - & skl(2,1)*skl(2,3)*skl(3,3)*skl(3,1)*c1212+ - & skl(2,2)*skl(2,1)*skl(3,1)*skl(3,2)*c1212+ - & skl(2,2)*skl(2,1)*skl(3,2)*skl(3,1)*c1212+ - & skl(2,2)*skl(2,2)*skl(3,1)*skl(3,1)*c1122+ - & skl(2,2)*skl(2,2)*skl(3,2)*skl(3,2)*c1111+ - & skl(2,2)*skl(2,2)*skl(3,3)*skl(3,3)*c1122+ - & skl(2,2)*skl(2,3)*skl(3,2)*skl(3,3)*c1212+ - & skl(2,2)*skl(2,3)*skl(3,3)*skl(3,2)*c1212+ - & skl(2,3)*skl(2,1)*skl(3,1)*skl(3,3)*c1212+ - & skl(2,3)*skl(2,1)*skl(3,3)*skl(3,1)*c1212+ - & skl(2,3)*skl(2,2)*skl(3,2)*skl(3,3)*c1212+ - & skl(2,3)*skl(2,2)*skl(3,3)*skl(3,2)*c1212+ - & skl(2,3)*skl(2,3)*skl(3,1)*skl(3,1)*c1122+ - & skl(2,3)*skl(2,3)*skl(3,2)*skl(3,2)*c1122+ - & skl(2,3)*skl(2,3)*skl(3,3)*skl(3,3)*c1111 - elas( 6)= - & skl(3,1)*skl(3,1)*skl(3,1)*skl(3,1)*c1111+ - & skl(3,1)*skl(3,1)*skl(3,2)*skl(3,2)*c1122+ - & skl(3,1)*skl(3,1)*skl(3,3)*skl(3,3)*c1122+ - & skl(3,1)*skl(3,2)*skl(3,1)*skl(3,2)*c1212+ - & skl(3,1)*skl(3,2)*skl(3,2)*skl(3,1)*c1212+ - & skl(3,1)*skl(3,3)*skl(3,1)*skl(3,3)*c1212+ - & skl(3,1)*skl(3,3)*skl(3,3)*skl(3,1)*c1212+ - & skl(3,2)*skl(3,1)*skl(3,1)*skl(3,2)*c1212+ - & skl(3,2)*skl(3,1)*skl(3,2)*skl(3,1)*c1212+ - & skl(3,2)*skl(3,2)*skl(3,1)*skl(3,1)*c1122+ - & skl(3,2)*skl(3,2)*skl(3,2)*skl(3,2)*c1111+ - & skl(3,2)*skl(3,2)*skl(3,3)*skl(3,3)*c1122+ - & skl(3,2)*skl(3,3)*skl(3,2)*skl(3,3)*c1212+ - & skl(3,2)*skl(3,3)*skl(3,3)*skl(3,2)*c1212+ - & skl(3,3)*skl(3,1)*skl(3,1)*skl(3,3)*c1212+ - & skl(3,3)*skl(3,1)*skl(3,3)*skl(3,1)*c1212+ - & skl(3,3)*skl(3,2)*skl(3,2)*skl(3,3)*c1212+ - & skl(3,3)*skl(3,2)*skl(3,3)*skl(3,2)*c1212+ - & skl(3,3)*skl(3,3)*skl(3,1)*skl(3,1)*c1122+ - & skl(3,3)*skl(3,3)*skl(3,2)*skl(3,2)*c1122+ - & skl(3,3)*skl(3,3)*skl(3,3)*skl(3,3)*c1111 - elas( 7)= - & skl(1,1)*skl(1,1)*skl(1,1)*skl(2,1)*c1111+ - & skl(1,1)*skl(1,1)*skl(1,2)*skl(2,2)*c1122+ - & skl(1,1)*skl(1,1)*skl(1,3)*skl(2,3)*c1122+ - & skl(1,1)*skl(1,2)*skl(1,1)*skl(2,2)*c1212+ - & skl(1,1)*skl(1,2)*skl(1,2)*skl(2,1)*c1212+ - & skl(1,1)*skl(1,3)*skl(1,1)*skl(2,3)*c1212+ - & skl(1,1)*skl(1,3)*skl(1,3)*skl(2,1)*c1212+ - & skl(1,2)*skl(1,1)*skl(1,1)*skl(2,2)*c1212+ - & skl(1,2)*skl(1,1)*skl(1,2)*skl(2,1)*c1212+ - & skl(1,2)*skl(1,2)*skl(1,1)*skl(2,1)*c1122+ - & skl(1,2)*skl(1,2)*skl(1,2)*skl(2,2)*c1111+ - & skl(1,2)*skl(1,2)*skl(1,3)*skl(2,3)*c1122+ - & skl(1,2)*skl(1,3)*skl(1,2)*skl(2,3)*c1212+ - & skl(1,2)*skl(1,3)*skl(1,3)*skl(2,2)*c1212+ - & skl(1,3)*skl(1,1)*skl(1,1)*skl(2,3)*c1212+ - & skl(1,3)*skl(1,1)*skl(1,3)*skl(2,1)*c1212+ - & skl(1,3)*skl(1,2)*skl(1,2)*skl(2,3)*c1212+ - & skl(1,3)*skl(1,2)*skl(1,3)*skl(2,2)*c1212+ - & skl(1,3)*skl(1,3)*skl(1,1)*skl(2,1)*c1122+ - & skl(1,3)*skl(1,3)*skl(1,2)*skl(2,2)*c1122+ - & skl(1,3)*skl(1,3)*skl(1,3)*skl(2,3)*c1111 - elas( 8)= - & skl(2,1)*skl(2,1)*skl(1,1)*skl(2,1)*c1111+ - & skl(2,1)*skl(2,1)*skl(1,2)*skl(2,2)*c1122+ - & skl(2,1)*skl(2,1)*skl(1,3)*skl(2,3)*c1122+ - & skl(2,1)*skl(2,2)*skl(1,1)*skl(2,2)*c1212+ - & skl(2,1)*skl(2,2)*skl(1,2)*skl(2,1)*c1212+ - & skl(2,1)*skl(2,3)*skl(1,1)*skl(2,3)*c1212+ - & skl(2,1)*skl(2,3)*skl(1,3)*skl(2,1)*c1212+ - & skl(2,2)*skl(2,1)*skl(1,1)*skl(2,2)*c1212+ - & skl(2,2)*skl(2,1)*skl(1,2)*skl(2,1)*c1212+ - & skl(2,2)*skl(2,2)*skl(1,1)*skl(2,1)*c1122+ - & skl(2,2)*skl(2,2)*skl(1,2)*skl(2,2)*c1111+ - & skl(2,2)*skl(2,2)*skl(1,3)*skl(2,3)*c1122+ - & skl(2,2)*skl(2,3)*skl(1,2)*skl(2,3)*c1212+ - & skl(2,2)*skl(2,3)*skl(1,3)*skl(2,2)*c1212+ - & skl(2,3)*skl(2,1)*skl(1,1)*skl(2,3)*c1212+ - & skl(2,3)*skl(2,1)*skl(1,3)*skl(2,1)*c1212+ - & skl(2,3)*skl(2,2)*skl(1,2)*skl(2,3)*c1212+ - & skl(2,3)*skl(2,2)*skl(1,3)*skl(2,2)*c1212+ - & skl(2,3)*skl(2,3)*skl(1,1)*skl(2,1)*c1122+ - & skl(2,3)*skl(2,3)*skl(1,2)*skl(2,2)*c1122+ - & skl(2,3)*skl(2,3)*skl(1,3)*skl(2,3)*c1111 - elas( 9)= - & skl(3,1)*skl(3,1)*skl(1,1)*skl(2,1)*c1111+ - & skl(3,1)*skl(3,1)*skl(1,2)*skl(2,2)*c1122+ - & skl(3,1)*skl(3,1)*skl(1,3)*skl(2,3)*c1122+ - & skl(3,1)*skl(3,2)*skl(1,1)*skl(2,2)*c1212+ - & skl(3,1)*skl(3,2)*skl(1,2)*skl(2,1)*c1212+ - & skl(3,1)*skl(3,3)*skl(1,1)*skl(2,3)*c1212+ - & skl(3,1)*skl(3,3)*skl(1,3)*skl(2,1)*c1212+ - & skl(3,2)*skl(3,1)*skl(1,1)*skl(2,2)*c1212+ - & skl(3,2)*skl(3,1)*skl(1,2)*skl(2,1)*c1212+ - & skl(3,2)*skl(3,2)*skl(1,1)*skl(2,1)*c1122+ - & skl(3,2)*skl(3,2)*skl(1,2)*skl(2,2)*c1111+ - & skl(3,2)*skl(3,2)*skl(1,3)*skl(2,3)*c1122+ - & skl(3,2)*skl(3,3)*skl(1,2)*skl(2,3)*c1212+ - & skl(3,2)*skl(3,3)*skl(1,3)*skl(2,2)*c1212+ - & skl(3,3)*skl(3,1)*skl(1,1)*skl(2,3)*c1212+ - & skl(3,3)*skl(3,1)*skl(1,3)*skl(2,1)*c1212+ - & skl(3,3)*skl(3,2)*skl(1,2)*skl(2,3)*c1212+ - & skl(3,3)*skl(3,2)*skl(1,3)*skl(2,2)*c1212+ - & skl(3,3)*skl(3,3)*skl(1,1)*skl(2,1)*c1122+ - & skl(3,3)*skl(3,3)*skl(1,2)*skl(2,2)*c1122+ - & skl(3,3)*skl(3,3)*skl(1,3)*skl(2,3)*c1111 - elas(10)= - & skl(1,1)*skl(2,1)*skl(1,1)*skl(2,1)*c1111+ - & skl(1,1)*skl(2,1)*skl(1,2)*skl(2,2)*c1122+ - & skl(1,1)*skl(2,1)*skl(1,3)*skl(2,3)*c1122+ - & skl(1,1)*skl(2,2)*skl(1,1)*skl(2,2)*c1212+ - & skl(1,1)*skl(2,2)*skl(1,2)*skl(2,1)*c1212+ - & skl(1,1)*skl(2,3)*skl(1,1)*skl(2,3)*c1212+ - & skl(1,1)*skl(2,3)*skl(1,3)*skl(2,1)*c1212+ - & skl(1,2)*skl(2,1)*skl(1,1)*skl(2,2)*c1212+ - & skl(1,2)*skl(2,1)*skl(1,2)*skl(2,1)*c1212+ - & skl(1,2)*skl(2,2)*skl(1,1)*skl(2,1)*c1122+ - & skl(1,2)*skl(2,2)*skl(1,2)*skl(2,2)*c1111+ - & skl(1,2)*skl(2,2)*skl(1,3)*skl(2,3)*c1122+ - & skl(1,2)*skl(2,3)*skl(1,2)*skl(2,3)*c1212+ - & skl(1,2)*skl(2,3)*skl(1,3)*skl(2,2)*c1212+ - & skl(1,3)*skl(2,1)*skl(1,1)*skl(2,3)*c1212+ - & skl(1,3)*skl(2,1)*skl(1,3)*skl(2,1)*c1212+ - & skl(1,3)*skl(2,2)*skl(1,2)*skl(2,3)*c1212+ - & skl(1,3)*skl(2,2)*skl(1,3)*skl(2,2)*c1212+ - & skl(1,3)*skl(2,3)*skl(1,1)*skl(2,1)*c1122+ - & skl(1,3)*skl(2,3)*skl(1,2)*skl(2,2)*c1122+ - & skl(1,3)*skl(2,3)*skl(1,3)*skl(2,3)*c1111 - elas(11)= - & skl(1,1)*skl(1,1)*skl(1,1)*skl(3,1)*c1111+ - & skl(1,1)*skl(1,1)*skl(1,2)*skl(3,2)*c1122+ - & skl(1,1)*skl(1,1)*skl(1,3)*skl(3,3)*c1122+ - & skl(1,1)*skl(1,2)*skl(1,1)*skl(3,2)*c1212+ - & skl(1,1)*skl(1,2)*skl(1,2)*skl(3,1)*c1212+ - & skl(1,1)*skl(1,3)*skl(1,1)*skl(3,3)*c1212+ - & skl(1,1)*skl(1,3)*skl(1,3)*skl(3,1)*c1212+ - & skl(1,2)*skl(1,1)*skl(1,1)*skl(3,2)*c1212+ - & skl(1,2)*skl(1,1)*skl(1,2)*skl(3,1)*c1212+ - & skl(1,2)*skl(1,2)*skl(1,1)*skl(3,1)*c1122+ - & skl(1,2)*skl(1,2)*skl(1,2)*skl(3,2)*c1111+ - & skl(1,2)*skl(1,2)*skl(1,3)*skl(3,3)*c1122+ - & skl(1,2)*skl(1,3)*skl(1,2)*skl(3,3)*c1212+ - & skl(1,2)*skl(1,3)*skl(1,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(1,1)*skl(1,1)*skl(3,3)*c1212+ - & skl(1,3)*skl(1,1)*skl(1,3)*skl(3,1)*c1212+ - & skl(1,3)*skl(1,2)*skl(1,2)*skl(3,3)*c1212+ - & skl(1,3)*skl(1,2)*skl(1,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(1,3)*skl(1,1)*skl(3,1)*c1122+ - & skl(1,3)*skl(1,3)*skl(1,2)*skl(3,2)*c1122+ - & skl(1,3)*skl(1,3)*skl(1,3)*skl(3,3)*c1111 - elas(12)= - & skl(2,1)*skl(2,1)*skl(1,1)*skl(3,1)*c1111+ - & skl(2,1)*skl(2,1)*skl(1,2)*skl(3,2)*c1122+ - & skl(2,1)*skl(2,1)*skl(1,3)*skl(3,3)*c1122+ - & skl(2,1)*skl(2,2)*skl(1,1)*skl(3,2)*c1212+ - & skl(2,1)*skl(2,2)*skl(1,2)*skl(3,1)*c1212+ - & skl(2,1)*skl(2,3)*skl(1,1)*skl(3,3)*c1212+ - & skl(2,1)*skl(2,3)*skl(1,3)*skl(3,1)*c1212+ - & skl(2,2)*skl(2,1)*skl(1,1)*skl(3,2)*c1212+ - & skl(2,2)*skl(2,1)*skl(1,2)*skl(3,1)*c1212+ - & skl(2,2)*skl(2,2)*skl(1,1)*skl(3,1)*c1122+ - & skl(2,2)*skl(2,2)*skl(1,2)*skl(3,2)*c1111+ - & skl(2,2)*skl(2,2)*skl(1,3)*skl(3,3)*c1122+ - & skl(2,2)*skl(2,3)*skl(1,2)*skl(3,3)*c1212+ - & skl(2,2)*skl(2,3)*skl(1,3)*skl(3,2)*c1212+ - & skl(2,3)*skl(2,1)*skl(1,1)*skl(3,3)*c1212+ - & skl(2,3)*skl(2,1)*skl(1,3)*skl(3,1)*c1212+ - & skl(2,3)*skl(2,2)*skl(1,2)*skl(3,3)*c1212+ - & skl(2,3)*skl(2,2)*skl(1,3)*skl(3,2)*c1212+ - & skl(2,3)*skl(2,3)*skl(1,1)*skl(3,1)*c1122+ - & skl(2,3)*skl(2,3)*skl(1,2)*skl(3,2)*c1122+ - & skl(2,3)*skl(2,3)*skl(1,3)*skl(3,3)*c1111 - elas(13)= - & skl(3,1)*skl(3,1)*skl(1,1)*skl(3,1)*c1111+ - & skl(3,1)*skl(3,1)*skl(1,2)*skl(3,2)*c1122+ - & skl(3,1)*skl(3,1)*skl(1,3)*skl(3,3)*c1122+ - & skl(3,1)*skl(3,2)*skl(1,1)*skl(3,2)*c1212+ - & skl(3,1)*skl(3,2)*skl(1,2)*skl(3,1)*c1212+ - & skl(3,1)*skl(3,3)*skl(1,1)*skl(3,3)*c1212+ - & skl(3,1)*skl(3,3)*skl(1,3)*skl(3,1)*c1212+ - & skl(3,2)*skl(3,1)*skl(1,1)*skl(3,2)*c1212+ - & skl(3,2)*skl(3,1)*skl(1,2)*skl(3,1)*c1212+ - & skl(3,2)*skl(3,2)*skl(1,1)*skl(3,1)*c1122+ - & skl(3,2)*skl(3,2)*skl(1,2)*skl(3,2)*c1111+ - & skl(3,2)*skl(3,2)*skl(1,3)*skl(3,3)*c1122+ - & skl(3,2)*skl(3,3)*skl(1,2)*skl(3,3)*c1212+ - & skl(3,2)*skl(3,3)*skl(1,3)*skl(3,2)*c1212+ - & skl(3,3)*skl(3,1)*skl(1,1)*skl(3,3)*c1212+ - & skl(3,3)*skl(3,1)*skl(1,3)*skl(3,1)*c1212+ - & skl(3,3)*skl(3,2)*skl(1,2)*skl(3,3)*c1212+ - & skl(3,3)*skl(3,2)*skl(1,3)*skl(3,2)*c1212+ - & skl(3,3)*skl(3,3)*skl(1,1)*skl(3,1)*c1122+ - & skl(3,3)*skl(3,3)*skl(1,2)*skl(3,2)*c1122+ - & skl(3,3)*skl(3,3)*skl(1,3)*skl(3,3)*c1111 - elas(14)= - & skl(1,1)*skl(2,1)*skl(1,1)*skl(3,1)*c1111+ - & skl(1,1)*skl(2,1)*skl(1,2)*skl(3,2)*c1122+ - & skl(1,1)*skl(2,1)*skl(1,3)*skl(3,3)*c1122+ - & skl(1,1)*skl(2,2)*skl(1,1)*skl(3,2)*c1212+ - & skl(1,1)*skl(2,2)*skl(1,2)*skl(3,1)*c1212+ - & skl(1,1)*skl(2,3)*skl(1,1)*skl(3,3)*c1212+ - & skl(1,1)*skl(2,3)*skl(1,3)*skl(3,1)*c1212+ - & skl(1,2)*skl(2,1)*skl(1,1)*skl(3,2)*c1212+ - & skl(1,2)*skl(2,1)*skl(1,2)*skl(3,1)*c1212+ - & skl(1,2)*skl(2,2)*skl(1,1)*skl(3,1)*c1122+ - & skl(1,2)*skl(2,2)*skl(1,2)*skl(3,2)*c1111+ - & skl(1,2)*skl(2,2)*skl(1,3)*skl(3,3)*c1122+ - & skl(1,2)*skl(2,3)*skl(1,2)*skl(3,3)*c1212+ - & skl(1,2)*skl(2,3)*skl(1,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(2,1)*skl(1,1)*skl(3,3)*c1212+ - & skl(1,3)*skl(2,1)*skl(1,3)*skl(3,1)*c1212+ - & skl(1,3)*skl(2,2)*skl(1,2)*skl(3,3)*c1212+ - & skl(1,3)*skl(2,2)*skl(1,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(2,3)*skl(1,1)*skl(3,1)*c1122+ - & skl(1,3)*skl(2,3)*skl(1,2)*skl(3,2)*c1122+ - & skl(1,3)*skl(2,3)*skl(1,3)*skl(3,3)*c1111 - elas(15)= - & skl(1,1)*skl(3,1)*skl(1,1)*skl(3,1)*c1111+ - & skl(1,1)*skl(3,1)*skl(1,2)*skl(3,2)*c1122+ - & skl(1,1)*skl(3,1)*skl(1,3)*skl(3,3)*c1122+ - & skl(1,1)*skl(3,2)*skl(1,1)*skl(3,2)*c1212+ - & skl(1,1)*skl(3,2)*skl(1,2)*skl(3,1)*c1212+ - & skl(1,1)*skl(3,3)*skl(1,1)*skl(3,3)*c1212+ - & skl(1,1)*skl(3,3)*skl(1,3)*skl(3,1)*c1212+ - & skl(1,2)*skl(3,1)*skl(1,1)*skl(3,2)*c1212+ - & skl(1,2)*skl(3,1)*skl(1,2)*skl(3,1)*c1212+ - & skl(1,2)*skl(3,2)*skl(1,1)*skl(3,1)*c1122+ - & skl(1,2)*skl(3,2)*skl(1,2)*skl(3,2)*c1111+ - & skl(1,2)*skl(3,2)*skl(1,3)*skl(3,3)*c1122+ - & skl(1,2)*skl(3,3)*skl(1,2)*skl(3,3)*c1212+ - & skl(1,2)*skl(3,3)*skl(1,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(3,1)*skl(1,1)*skl(3,3)*c1212+ - & skl(1,3)*skl(3,1)*skl(1,3)*skl(3,1)*c1212+ - & skl(1,3)*skl(3,2)*skl(1,2)*skl(3,3)*c1212+ - & skl(1,3)*skl(3,2)*skl(1,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(3,3)*skl(1,1)*skl(3,1)*c1122+ - & skl(1,3)*skl(3,3)*skl(1,2)*skl(3,2)*c1122+ - & skl(1,3)*skl(3,3)*skl(1,3)*skl(3,3)*c1111 - elas(16)= - & skl(1,1)*skl(1,1)*skl(2,1)*skl(3,1)*c1111+ - & skl(1,1)*skl(1,1)*skl(2,2)*skl(3,2)*c1122+ - & skl(1,1)*skl(1,1)*skl(2,3)*skl(3,3)*c1122+ - & skl(1,1)*skl(1,2)*skl(2,1)*skl(3,2)*c1212+ - & skl(1,1)*skl(1,2)*skl(2,2)*skl(3,1)*c1212+ - & skl(1,1)*skl(1,3)*skl(2,1)*skl(3,3)*c1212+ - & skl(1,1)*skl(1,3)*skl(2,3)*skl(3,1)*c1212+ - & skl(1,2)*skl(1,1)*skl(2,1)*skl(3,2)*c1212+ - & skl(1,2)*skl(1,1)*skl(2,2)*skl(3,1)*c1212+ - & skl(1,2)*skl(1,2)*skl(2,1)*skl(3,1)*c1122+ - & skl(1,2)*skl(1,2)*skl(2,2)*skl(3,2)*c1111+ - & skl(1,2)*skl(1,2)*skl(2,3)*skl(3,3)*c1122+ - & skl(1,2)*skl(1,3)*skl(2,2)*skl(3,3)*c1212+ - & skl(1,2)*skl(1,3)*skl(2,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(1,1)*skl(2,1)*skl(3,3)*c1212+ - & skl(1,3)*skl(1,1)*skl(2,3)*skl(3,1)*c1212+ - & skl(1,3)*skl(1,2)*skl(2,2)*skl(3,3)*c1212+ - & skl(1,3)*skl(1,2)*skl(2,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(1,3)*skl(2,1)*skl(3,1)*c1122+ - & skl(1,3)*skl(1,3)*skl(2,2)*skl(3,2)*c1122+ - & skl(1,3)*skl(1,3)*skl(2,3)*skl(3,3)*c1111 - elas(17)= - & skl(2,1)*skl(2,1)*skl(2,1)*skl(3,1)*c1111+ - & skl(2,1)*skl(2,1)*skl(2,2)*skl(3,2)*c1122+ - & skl(2,1)*skl(2,1)*skl(2,3)*skl(3,3)*c1122+ - & skl(2,1)*skl(2,2)*skl(2,1)*skl(3,2)*c1212+ - & skl(2,1)*skl(2,2)*skl(2,2)*skl(3,1)*c1212+ - & skl(2,1)*skl(2,3)*skl(2,1)*skl(3,3)*c1212+ - & skl(2,1)*skl(2,3)*skl(2,3)*skl(3,1)*c1212+ - & skl(2,2)*skl(2,1)*skl(2,1)*skl(3,2)*c1212+ - & skl(2,2)*skl(2,1)*skl(2,2)*skl(3,1)*c1212+ - & skl(2,2)*skl(2,2)*skl(2,1)*skl(3,1)*c1122+ - & skl(2,2)*skl(2,2)*skl(2,2)*skl(3,2)*c1111+ - & skl(2,2)*skl(2,2)*skl(2,3)*skl(3,3)*c1122+ - & skl(2,2)*skl(2,3)*skl(2,2)*skl(3,3)*c1212+ - & skl(2,2)*skl(2,3)*skl(2,3)*skl(3,2)*c1212+ - & skl(2,3)*skl(2,1)*skl(2,1)*skl(3,3)*c1212+ - & skl(2,3)*skl(2,1)*skl(2,3)*skl(3,1)*c1212+ - & skl(2,3)*skl(2,2)*skl(2,2)*skl(3,3)*c1212+ - & skl(2,3)*skl(2,2)*skl(2,3)*skl(3,2)*c1212+ - & skl(2,3)*skl(2,3)*skl(2,1)*skl(3,1)*c1122+ - & skl(2,3)*skl(2,3)*skl(2,2)*skl(3,2)*c1122+ - & skl(2,3)*skl(2,3)*skl(2,3)*skl(3,3)*c1111 - elas(18)= - & skl(3,1)*skl(3,1)*skl(2,1)*skl(3,1)*c1111+ - & skl(3,1)*skl(3,1)*skl(2,2)*skl(3,2)*c1122+ - & skl(3,1)*skl(3,1)*skl(2,3)*skl(3,3)*c1122+ - & skl(3,1)*skl(3,2)*skl(2,1)*skl(3,2)*c1212+ - & skl(3,1)*skl(3,2)*skl(2,2)*skl(3,1)*c1212+ - & skl(3,1)*skl(3,3)*skl(2,1)*skl(3,3)*c1212+ - & skl(3,1)*skl(3,3)*skl(2,3)*skl(3,1)*c1212+ - & skl(3,2)*skl(3,1)*skl(2,1)*skl(3,2)*c1212+ - & skl(3,2)*skl(3,1)*skl(2,2)*skl(3,1)*c1212+ - & skl(3,2)*skl(3,2)*skl(2,1)*skl(3,1)*c1122+ - & skl(3,2)*skl(3,2)*skl(2,2)*skl(3,2)*c1111+ - & skl(3,2)*skl(3,2)*skl(2,3)*skl(3,3)*c1122+ - & skl(3,2)*skl(3,3)*skl(2,2)*skl(3,3)*c1212+ - & skl(3,2)*skl(3,3)*skl(2,3)*skl(3,2)*c1212+ - & skl(3,3)*skl(3,1)*skl(2,1)*skl(3,3)*c1212+ - & skl(3,3)*skl(3,1)*skl(2,3)*skl(3,1)*c1212+ - & skl(3,3)*skl(3,2)*skl(2,2)*skl(3,3)*c1212+ - & skl(3,3)*skl(3,2)*skl(2,3)*skl(3,2)*c1212+ - & skl(3,3)*skl(3,3)*skl(2,1)*skl(3,1)*c1122+ - & skl(3,3)*skl(3,3)*skl(2,2)*skl(3,2)*c1122+ - & skl(3,3)*skl(3,3)*skl(2,3)*skl(3,3)*c1111 - elas(19)= - & skl(1,1)*skl(2,1)*skl(2,1)*skl(3,1)*c1111+ - & skl(1,1)*skl(2,1)*skl(2,2)*skl(3,2)*c1122+ - & skl(1,1)*skl(2,1)*skl(2,3)*skl(3,3)*c1122+ - & skl(1,1)*skl(2,2)*skl(2,1)*skl(3,2)*c1212+ - & skl(1,1)*skl(2,2)*skl(2,2)*skl(3,1)*c1212+ - & skl(1,1)*skl(2,3)*skl(2,1)*skl(3,3)*c1212+ - & skl(1,1)*skl(2,3)*skl(2,3)*skl(3,1)*c1212+ - & skl(1,2)*skl(2,1)*skl(2,1)*skl(3,2)*c1212+ - & skl(1,2)*skl(2,1)*skl(2,2)*skl(3,1)*c1212+ - & skl(1,2)*skl(2,2)*skl(2,1)*skl(3,1)*c1122+ - & skl(1,2)*skl(2,2)*skl(2,2)*skl(3,2)*c1111+ - & skl(1,2)*skl(2,2)*skl(2,3)*skl(3,3)*c1122+ - & skl(1,2)*skl(2,3)*skl(2,2)*skl(3,3)*c1212+ - & skl(1,2)*skl(2,3)*skl(2,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(2,1)*skl(2,1)*skl(3,3)*c1212+ - & skl(1,3)*skl(2,1)*skl(2,3)*skl(3,1)*c1212+ - & skl(1,3)*skl(2,2)*skl(2,2)*skl(3,3)*c1212+ - & skl(1,3)*skl(2,2)*skl(2,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(2,3)*skl(2,1)*skl(3,1)*c1122+ - & skl(1,3)*skl(2,3)*skl(2,2)*skl(3,2)*c1122+ - & skl(1,3)*skl(2,3)*skl(2,3)*skl(3,3)*c1111 - elas(20)= - & skl(1,1)*skl(3,1)*skl(2,1)*skl(3,1)*c1111+ - & skl(1,1)*skl(3,1)*skl(2,2)*skl(3,2)*c1122+ - & skl(1,1)*skl(3,1)*skl(2,3)*skl(3,3)*c1122+ - & skl(1,1)*skl(3,2)*skl(2,1)*skl(3,2)*c1212+ - & skl(1,1)*skl(3,2)*skl(2,2)*skl(3,1)*c1212+ - & skl(1,1)*skl(3,3)*skl(2,1)*skl(3,3)*c1212+ - & skl(1,1)*skl(3,3)*skl(2,3)*skl(3,1)*c1212+ - & skl(1,2)*skl(3,1)*skl(2,1)*skl(3,2)*c1212+ - & skl(1,2)*skl(3,1)*skl(2,2)*skl(3,1)*c1212+ - & skl(1,2)*skl(3,2)*skl(2,1)*skl(3,1)*c1122+ - & skl(1,2)*skl(3,2)*skl(2,2)*skl(3,2)*c1111+ - & skl(1,2)*skl(3,2)*skl(2,3)*skl(3,3)*c1122+ - & skl(1,2)*skl(3,3)*skl(2,2)*skl(3,3)*c1212+ - & skl(1,2)*skl(3,3)*skl(2,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(3,1)*skl(2,1)*skl(3,3)*c1212+ - & skl(1,3)*skl(3,1)*skl(2,3)*skl(3,1)*c1212+ - & skl(1,3)*skl(3,2)*skl(2,2)*skl(3,3)*c1212+ - & skl(1,3)*skl(3,2)*skl(2,3)*skl(3,2)*c1212+ - & skl(1,3)*skl(3,3)*skl(2,1)*skl(3,1)*c1122+ - & skl(1,3)*skl(3,3)*skl(2,2)*skl(3,2)*c1122+ - & skl(1,3)*skl(3,3)*skl(2,3)*skl(3,3)*c1111 - elas(21)= - & skl(2,1)*skl(3,1)*skl(2,1)*skl(3,1)*c1111+ - & skl(2,1)*skl(3,1)*skl(2,2)*skl(3,2)*c1122+ - & skl(2,1)*skl(3,1)*skl(2,3)*skl(3,3)*c1122+ - & skl(2,1)*skl(3,2)*skl(2,1)*skl(3,2)*c1212+ - & skl(2,1)*skl(3,2)*skl(2,2)*skl(3,1)*c1212+ - & skl(2,1)*skl(3,3)*skl(2,1)*skl(3,3)*c1212+ - & skl(2,1)*skl(3,3)*skl(2,3)*skl(3,1)*c1212+ - & skl(2,2)*skl(3,1)*skl(2,1)*skl(3,2)*c1212+ - & skl(2,2)*skl(3,1)*skl(2,2)*skl(3,1)*c1212+ - & skl(2,2)*skl(3,2)*skl(2,1)*skl(3,1)*c1122+ - & skl(2,2)*skl(3,2)*skl(2,2)*skl(3,2)*c1111+ - & skl(2,2)*skl(3,2)*skl(2,3)*skl(3,3)*c1122+ - & skl(2,2)*skl(3,3)*skl(2,2)*skl(3,3)*c1212+ - & skl(2,2)*skl(3,3)*skl(2,3)*skl(3,2)*c1212+ - & skl(2,3)*skl(3,1)*skl(2,1)*skl(3,3)*c1212+ - & skl(2,3)*skl(3,1)*skl(2,3)*skl(3,1)*c1212+ - & skl(2,3)*skl(3,2)*skl(2,2)*skl(3,3)*c1212+ - & skl(2,3)*skl(3,2)*skl(2,3)*skl(3,2)*c1212+ - & skl(2,3)*skl(3,3)*skl(2,1)*skl(3,1)*c1122+ - & skl(2,3)*skl(3,3)*skl(2,2)*skl(3,2)*c1122+ - & skl(2,3)*skl(3,3)*skl(2,3)*skl(3,3)*c1111 - endif -! - do i=1,6 - ep0(i)=xstateini(i,iint,iel) - enddo - do i=1,18 - q1(i)=xstateini(6+i,iint,iel) - q2(i)=xstateini(24+i,iint,iel) - dg0(i)=xstateini(42+i,iint,iel) - enddo -! -! elastic strains -! - do i=1,6 - ee(i)=emec(i)-ep0(i) - enddo -! -! (visco)plastic constants: octahedral slip system -! - do i=1,12 - ck(i)=elconloc(4) - cn(i)=elconloc(5) - c(i)=elconloc(6) - d(i)=elconloc(7) - phi(i)=elconloc(8) - delta(i)=elconloc(9) - r0(i)=elconloc(10) - q(i)=elconloc(11) - b(i)=elconloc(12) - enddo -! -! (visco)plastic constants: cubic slip system -! - do i=13,18 - ck(i)=elconloc(13) - cn(i)=elconloc(14) - c(i)=elconloc(15) - d(i)=elconloc(16) - phi(i)=elconloc(17) - delta(i)=elconloc(18) - r0(i)=elconloc(19) - q(i)=elconloc(20) - b(i)=elconloc(21) - enddo -! -! stress state variables q1 and q2 -! - do i=1,18 - al10(i)=-q1(i)/(b(i)*q(i)) - al20(i)=-q2(i)/c(i) - enddo -! -! global trial stress tensor -! - if(iorien.gt.0) then - stri(1)=elas(1)*ee(1)+elas(2)*ee(2)+elas(4)*ee(3)+ - & 2.d0*(elas(7)*ee(4)+elas(11)*ee(5)+elas(16)*ee(6)) - & -beta(1) - stri(2)=elas(2)*ee(1)+elas(3)*ee(2)+elas(5)*ee(3)+ - & 2.d0*(elas(8)*ee(4)+elas(12)*ee(5)+elas(17)*ee(6)) - & -beta(2) - stri(3)=elas(4)*ee(1)+elas(5)*ee(2)+elas(6)*ee(3)+ - & 2.d0*(elas(9)*ee(4)+elas(13)*ee(5)+elas(18)*ee(6)) - & -beta(3) - stri(4)=elas(7)*ee(1)+elas(8)*ee(2)+elas(9)*ee(3)+ - & 2.d0*(elas(10)*ee(4)+elas(14)*ee(5)+elas(19)*ee(6)) - & -beta(4) - stri(5)=elas(11)*ee(1)+elas(12)*ee(2)+elas(13)*ee(3)+ - & 2.d0*(elas(14)*ee(4)+elas(15)*ee(5)+elas(20)*ee(6)) - & -beta(5) - stri(6)=elas(16)*ee(1)+elas(17)*ee(2)+elas(18)*ee(3)+ - & 2.d0*(elas(19)*ee(4)+elas(20)*ee(5)+elas(21)*ee(6)) - & -beta(6) - else - stri(1)=c1111*ee(1)+c1122*(ee(2)+ee(3))-beta(1) - stri(2)=c1111*ee(2)+c1122*(ee(1)+ee(3))-beta(2) - stri(3)=c1111*ee(3)+c1122*(ee(1)+ee(2))-beta(3) - stri(4)=2.d0*c1212*ee(4)-beta(4) - stri(5)=2.d0*c1212*ee(5)-beta(5) - stri(6)=2.d0*c1212*ee(6)-beta(6) - endif -! -! stress radius in each slip plane -! - do i=1,18 - sg(i)=xm(1,i)*stri(1)+xm(2,i)*stri(2)+xm(3,i)*stri(3)+ - & 2.d0*(xm(4,i)*stri(4)+xm(5,i)*stri(5)+xm(6,i)*stri(6))+q2(i) - enddo -! -! evaluation of the yield surface -! - do i=1,18 - htri(i)=dabs(sg(i))-r0(i) - do j=1,18 - htri(i)=htri(i)+h(i,j)*q1(j) - enddo - enddo -! -! check whether plasticity occurs -! - iplas=0 - do i=1,18 - if(htri(i).gt.0.d0) then - iplas=1 - go to 8 - endif - enddo - 8 continue -! - if((iplas.eq.0).or.(ielas.eq.1)) then -! -! elastic stress -! - do i=1,6 - stre(i)=stri(i) - enddo -! -! elastic stiffness -! - if(icmd.ne.3) then - if(iorien.gt.0) then - do i=1,21 - stiff(i)=elas(i) - enddo - else - stiff(1)=c1111 - stiff(2)=c1122 - stiff(3)=c1111 - stiff(4)=c1122 - stiff(5)=c1122 - stiff(6)=c1111 - stiff(7)=0.d0 - stiff(8)=0.d0 - stiff(9)=0.d0 - stiff(10)=c1212 - stiff(11)=0.d0 - stiff(12)=0.d0 - stiff(13)=0.d0 - stiff(14)=0.d0 - stiff(15)=c1212 - stiff(16)=0.d0 - stiff(17)=0.d0 - stiff(18)=0.d0 - stiff(19)=0.d0 - stiff(20)=0.d0 - stiff(21)=c1212 - endif - endif -! - return - endif -! -! plastic deformation -! - creep=.true. - nrhs=1 - lda=18 - ldb=18 -! -! determining the active slip planes -! - do i=1,18 - if(htri(i).gt.0.d0) then - active(i)=.true. - else - active(i)=.false. - endif - enddo -! -! initializing the state variables -! - do i=1,6 - ep(i)=ep0(i) - enddo - do i=1,18 - al1(i)=al10(i) - al2(i)=al20(i) -c dg0(i)=xstateini(42+i,iint,iel) -c dg(i)=xstate(42+i,iint,iel)-dg0(i) - dg(i)=0.d0 - enddo -! -! major loop -! - icounter=0 - do - icounter=icounter+1 - if(icounter.gt.100) then - write(*,*) '*ERROR in umat_single_crystal: no convergence' - stop - endif -! -! elastic strains -! - do i=1,6 - ee(i)=emec(i)-ep(i) - enddo -! -! stress state variables q1 and q2 -! - do i=1,18 - q1(i)=-b(i)*q(i)*al1(i) - q2(i)=-c(i)*al2(i) - enddo -! -! global trial stress tensor -! - if(iorien.gt.0) then - stri(1)=elas(1)*ee(1)+elas(2)*ee(2)+elas(4)*ee(3)+ - & 2.d0*(elas(7)*ee(4)+elas(11)*ee(5)+elas(16)*ee(6)) - & -beta(1) - stri(2)=elas(2)*ee(1)+elas(3)*ee(2)+elas(5)*ee(3)+ - & 2.d0*(elas(8)*ee(4)+elas(12)*ee(5)+elas(17)*ee(6)) - & -beta(2) - stri(3)=elas(4)*ee(1)+elas(5)*ee(2)+elas(6)*ee(3)+ - & 2.d0*(elas(9)*ee(4)+elas(13)*ee(5)+elas(18)*ee(6)) - & -beta(3) - stri(4)=elas(7)*ee(1)+elas(8)*ee(2)+elas(9)*ee(3)+ - & 2.d0*(elas(10)*ee(4)+elas(14)*ee(5)+elas(19)*ee(6)) - & -beta(4) - stri(5)=elas(11)*ee(1)+elas(12)*ee(2)+elas(13)*ee(3)+ - & 2.d0*(elas(14)*ee(4)+elas(15)*ee(5)+elas(20)*ee(6)) - & -beta(5) - stri(6)=elas(16)*ee(1)+elas(17)*ee(2)+elas(18)*ee(3)+ - & 2.d0*(elas(19)*ee(4)+elas(20)*ee(5)+elas(21)*ee(6)) - & -beta(6) - else - stri(1)=c1111*ee(1)+c1122*(ee(2)+ee(3))-beta(1) - stri(2)=c1111*ee(2)+c1122*(ee(1)+ee(3))-beta(2) - stri(3)=c1111*ee(3)+c1122*(ee(1)+ee(2))-beta(3) - stri(4)=2.d0*c1212*ee(4)-beta(4) - stri(5)=2.d0*c1212*ee(5)-beta(5) - stri(6)=2.d0*c1212*ee(6)-beta(6) - endif -! -! stress radius in each slip plane -! - do i=1,18 - sg(i)=xm(1,i)*stri(1)+xm(2,i)*stri(2)+xm(3,i)*stri(3)+ - & 2.d0*(xm(4,i)*stri(4)+xm(5,i)*stri(5)+xm(6,i)*stri(6)) - & +q2(i) - enddo -! -! evaluation of the yield surface -! - do i=1,18 - htri(i)=dabs(sg(i))-r0(i)-ck(i)*(dg(i)/dtime)**(1.d0/cn(i)) - do j=1,18 - htri(i)=htri(i)+h(i,j)*q1(j) - enddo - enddo -! -! replace sg(i) by sgn(sg(i)) -! - do i=1,18 - if(sg(i).lt.0.d0) then - sg(i)=-1.d0 - else - sg(i)=1.d0 - endif - enddo -! -! determining the effect of the accumulated plasticity -! - do i=1,18 - cphi(i)=phi(i)+(1.d0-phi(i))*exp(-delta(i)*(dg0(i)+dg(i))) - enddo -! -! minor loop -! - do -! -! determining the residual matrix -! - do i=1,6 - r(i)=ep0(i)-ep(i) - enddo - do i=1,18 - r(5+2*i)=al10(i)-al1(i) - r(6+2*i)=al20(i)-al2(i) - enddo - do i=1,18 - if(active(i)) then - do j=1,6 - r(j)=r(j)+xm(j,i)*sg(i)*dg(i) - enddo - r(5+2*i)=r(5+2*i)+(1.d0-b(i)*al1(i))*dg(i) - r(6+2*i)=r(6+2*i)+(cphi(i)*sg(i)-d(i)*al2(i))*dg(i) - endif - enddo -! -! check convergence -! - convergence=.true. - do i=1,18 - if(.not.active(i)) cycle - if(htri(i).gt.1.d-5) then - convergence=.false. - go to 9 - endif - enddo - 9 continue - if(convergence) then - dd=0.d0 - do i=1,6 - dd=dd+r(i)*r(i) - enddo - do i=1,18 - if(.not.active(i)) cycle - dd=dd+r(5+2*i)*r(5+2*i)+r(6+2*i)*r(6+2*i) - enddo - dd=sqrt(dd) - if(dd.gt.1.d-10) then - convergence=.false. - else - go to 12 - endif - endif -! -! compute xmc=c:xm -! - do i=1,18 - if(iorien.gt.0) then - xmc(1,i)=elas(1)*xm(1,i)+elas(2)*xm(2,i)+ - & elas(4)*xm(3,i)+2.d0*(elas(7)*xm(4,i)+ - & elas(11)*xm(5,i)+elas(16)*xm(6,i)) - xmc(2,i)=elas(2)*xm(1,i)+elas(3)*xm(2,i)+ - & elas(5)*xm(3,i)+2.d0*(elas(8)*xm(4,i)+ - & elas(12)*xm(5,i)+elas(17)*xm(6,i)) - xmc(3,i)=elas(4)*xm(1,i)+elas(5)*xm(2,i)+ - & elas(6)*xm(3,i)+2.d0*(elas(9)*xm(4,i)+ - & elas(13)*xm(5,i)+elas(18)*xm(6,i)) - xmc(4,i)=elas(7)*xm(1,i)+elas(8)*xm(2,i)+ - & elas(9)*xm(3,i)+2.d0*(elas(10)*xm(4,i)+ - & elas(14)*xm(5,i)+elas(19)*xm(6,i)) - xmc(5,i)=elas(11)*xm(1,i)+elas(12)*xm(2,i)+ - & elas(13)*xm(3,i)+2.d0*(elas(14)*xm(4,i)+ - & elas(15)*xm(5,i)+elas(20)*xm(6,i)) - xmc(6,i)=elas(16)*xm(1,i)+elas(17)*xm(2,i)+ - & elas(18)*xm(3,i)+2.d0*(elas(19)*xm(4,i)+ - & elas(20)*xm(5,i)+elas(21)*xm(6,i)) - else - xmc(1,i)=c1111*xm(1,i)+c1122*(xm(2,i)+xm(3,i)) - xmc(2,i)=c1111*xm(2,i)+c1122*(xm(1,i)+xm(3,i)) - xmc(3,i)=c1111*xm(3,i)+c1122*(xm(1,i)+xm(2,i)) - xmc(4,i)=2.d0*c1212*xm(4,i) - xmc(5,i)=2.d0*c1212*xm(5,i) - xmc(6,i)=2.d0*c1212*xm(6,i) - endif - enddo -! -! indexing the active slip planes -! - do i=1,18 - if(active(i)) then - index(i)=1.d0 - else - index(i)=0.d0 - endif - enddo - neq=0 - do i=1,18 - if(index(i).eq.1) then - neq=neq+1 - index(i)=neq - endif - enddo -! -! filling the LHS -! - do 1 i=1,18 - if(.not.active(i)) go to 1 - aux(i)=(q(i)+q1(i))/(1.d0/b(i)+dg(i)) - 1 continue -! - do 2 i=1,18 - if(.not.active(i)) go to 2 - do 3 j=1,18 - if(.not.active(j)) go to 3 - if(i.ne.j) then - gl(index(i),index(j))=(xm(1,i)*xmc(1,j)+ - & xm(2,i)*xmc(2,j)+xm(3,i)*xmc(3,j)+2.d0* - & (xm(4,i)*xmc(4,j)+xm(5,i)*xmc(5,j)+ - & xm(6,i)*xmc(6,j))) - & *sg(i)*sg(j)+h(i,j)*aux(j) - else - gl(index(i),index(j))=(xm(1,i)*xmc(1,j)+ - & xm(2,i)*xmc(2,j)+xm(3,i)*xmc(3,j)+2.d0* - & (xm(4,i)*xmc(4,j)+xm(5,i)*xmc(5,j)+ - & xm(6,i)*xmc(6,j))) - & +h(i,j)*aux(j)+(cphi(j)*c(j)+d(j)*q2(j)*sg(j)) - & /(1.d0+dg(j)*d(j)) - endif - 3 continue - if(creep)then - if(dg(i).gt.0.d0) then - gl(index(i),index(i))=gl(index(i),index(i))+ - & (dg(i)/dtime)**(1.d0/cn(i)-1.d0)*ck(i)/ - & (cn(i)*dtime) - else -! -! for gamma ein default of 1.d-10 is taken to -! obtain a finite gradient -! - gl(index(i),index(i))=gl(index(i),index(i))+ - & (1.d-10/dtime)**(1.d0/cn(i)-1.d0)*ck(i)/ - & (cn(i)*dtime) - endif - endif - 2 continue -! -! filling the RHS -! - do 4 i=1,18 - if(.not.active(i)) go to 4 - do j=1,6 - t(j)=xmc(j,i)*sg(i) - enddo - do j=1,18 - t(5+2*j)=h(i,j)*q(j)/(1.d0/b(j)+dg(j)) - t(6+2*j)=0.d0 - enddo - t(6+2*i)=c(i)*sg(i)/(1.d0+dg(i)*d(i)) - if(creep) then - gr(index(i),1)=htri(i) - else - gr(index(i),1)=htri(i) - & +ck(i)*(dg(i)/dtime)**(1.d0/cn(i)) - endif - do j=1,42 - gr(index(i),1)=gr(index(i),1)-t(j)*r(j) - enddo - gr(index(i),1)=gr(index(i),1) - & -t(4)*r(4)-t(5)*r(5)-t(6)*r(6) - 4 continue -! -! solve gl*ddg=gr -! - call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! - do i=1,18 - if(active(i)) then - ddg(i)=gr(index(i),1) - else - ddg(i)=0.d0 - endif - enddo -! -! check whether active slip planes have changed -! - ichange=0 - do 5 i=1,18 - if(.not.active(i)) go to 5 - if(dg(i)+ddg(i).lt.0.d0) then - active(i)=.false. - dg(i)=0.d0 - al1(i)=al10(i) - al2(i)=al20(i) - ichange=1 - endif - 5 continue - if(ichange.eq.0) then - go to 13 - endif -! -! end of minor loop -! - enddo - 13 continue -! -! updating the residual matrix -! - do i=1,18 - if(active(i)) then - do j=1,6 - r(j)=r(j)+xm(j,i)*sg(i)*ddg(i) - enddo - r(5+2*i)=r(5+2*i)+(1.d0-b(i)*al1(i))*ddg(i) - r(6+2*i)=r(6+2*i)+(cphi(i)*sg(i)-d(i)*al2(i))*ddg(i) - endif - enddo -! -! update the state variables -! - do i=1,6 - ep(i)=ep(i)+r(i) - enddo - do i=1,18 - if(active(i)) then - al1(i)=al1(i)+r(5+2*i)/(1.d0+b(i)*dg(i)) - al2(i)=al2(i)+r(6+2*i)/(1.d0+d(i)*dg(i)) - endif - enddo - do i=1,18 - if(active(i)) then - dg(i)=dg(i)+ddg(i) - endif - enddo -! -! end of major loop -! - enddo - 12 continue -! -! inversion of G -! - do i=1,neq - do j=1,neq - gr(i,j)=0.d0 - enddo - gr(i,i)=1.d0 - enddo - nrhs=neq - call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) - if(info.ne.0) then - write(*,*) '*ERROR in sc.f: linear equation solver' - write(*,*) ' exited with error: info = ',info - stop - endif -! -! storing the stress -! - do i=1,6 - stre(i)=stri(i) - enddo -! -! calculating the tangent stiffness matrix -! - if(icmd.ne.3) then - if(iorien.gt.0) then - ddsdde(1,1)=elas(1) - ddsdde(1,2)=elas(2) - ddsdde(1,3)=elas(4) - ddsdde(1,4)=elas(7) - ddsdde(1,5)=elas(11) - ddsdde(1,6)=elas(16) - ddsdde(2,1)=elas(2) - ddsdde(2,2)=elas(3) - ddsdde(2,3)=elas(5) - ddsdde(2,4)=elas(8) - ddsdde(2,5)=elas(12) - ddsdde(2,6)=elas(17) - ddsdde(3,1)=elas(4) - ddsdde(3,2)=elas(5) - ddsdde(3,3)=elas(6) - ddsdde(3,4)=elas(9) - ddsdde(3,5)=elas(13) - ddsdde(3,6)=elas(18) - ddsdde(4,1)=elas(7) - ddsdde(4,2)=elas(8) - ddsdde(4,3)=elas(9) - ddsdde(4,4)=elas(10) - ddsdde(4,5)=elas(14) - ddsdde(4,6)=elas(19) - ddsdde(5,1)=elas(11) - ddsdde(5,2)=elas(12) - ddsdde(5,3)=elas(13) - ddsdde(5,4)=elas(14) - ddsdde(5,5)=elas(15) - ddsdde(5,6)=elas(20) - ddsdde(6,1)=elas(16) - ddsdde(6,2)=elas(17) - ddsdde(6,3)=elas(18) - ddsdde(6,4)=elas(19) - ddsdde(6,5)=elas(20) - ddsdde(6,6)=elas(21) - else - do i=1,6 - do j=1,6 - ddsdde(i,j)=0.d0 - enddo - enddo - do i=1,3 - ddsdde(i,i)=c1111 - enddo - do i=1,3 - do j=i+1,3 - ddsdde(i,j)=c1122 - enddo - do j=1,i-1 - ddsdde(i,j)=c1122 - enddo - ddsdde(i+3,i+3)=c1212 - enddo - endif - do 6 i=1,18 - if(.not.active(i)) go to 6 - do 7 j=1,18 - if(.not.active(j)) go to 7 - do k=1,6 - do l=1,6 - ddsdde(k,l)=ddsdde(k,l)- - & gr(index(i),index(j))*xmc(k,i)*sg(i)*xmc(l,j)*sg(j) - enddo - enddo - 7 continue - 6 continue -! -! symmatrizing the stiffness matrix -! - stiff(1)=ddsdde(1,1) - stiff(2)=(ddsdde(1,2)+ddsdde(2,1))/2.d0 - stiff(3)=ddsdde(2,2) - stiff(4)=(ddsdde(1,3)+ddsdde(3,1))/2.d0 - stiff(5)=(ddsdde(2,3)+ddsdde(3,2))/2.d0 - stiff(6)=ddsdde(3,3) - stiff(7)=(ddsdde(1,4)+ddsdde(4,1))/2.d0 - stiff(8)=(ddsdde(2,4)+ddsdde(4,2))/2.d0 - stiff(9)=(ddsdde(3,4)+ddsdde(4,3))/2.d0 - stiff(10)=ddsdde(4,4) - stiff(11)=(ddsdde(1,5)+ddsdde(5,1))/2.d0 - stiff(12)=(ddsdde(2,5)+ddsdde(5,2))/2.d0 - stiff(13)=(ddsdde(3,5)+ddsdde(5,3))/2.d0 - stiff(14)=(ddsdde(4,5)+ddsdde(5,4))/2.d0 - stiff(15)=ddsdde(5,5) - stiff(16)=(ddsdde(1,6)+ddsdde(6,1))/2.d0 - stiff(17)=(ddsdde(2,6)+ddsdde(6,2))/2.d0 - stiff(18)=(ddsdde(3,6)+ddsdde(6,3))/2.d0 - stiff(19)=(ddsdde(4,6)+ddsdde(6,4))/2.d0 - stiff(20)=(ddsdde(5,6)+ddsdde(6,5))/2.d0 - stiff(21)=ddsdde(6,6) -! - endif -! -! updating the state variables -! - do i=1,6 - xstate(i,iint,iel)=ep(i) - enddo - do i=1,18 - xstate(6+i,iint,iel)=q1(i) - xstate(24+i,iint,iel)=q2(i) - xstate(42+i,iint,iel)=dg0(i)+dg(i) - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umat_user.f calculix-ccx-2.3/ccx_2.1/src/umat_user.f --- calculix-ccx-2.1/ccx_2.1/src/umat_user.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umat_user.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,146 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umat_user(amat,iel,iint,kode,elconloc,emec,emec0, - & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, - & icmd,ielas,mi,nstate_,xstateini,xstate,stre,stiff, - & iorien,pgauss,orab,pnewdt) -! -! calculates stiffness and stresses for a user defined material -! law -! -! icmd=3: calcutates stress at mechanical strain -! else: calculates stress at mechanical strain and the stiffness -! matrix -! -! INPUT: -! -! amat material name -! iel element number -! iint integration point number -! -! kode material type (-100-#of constants entered -! under *USER MATERIAL): can be used for materials -! with varying number of constants -! -! elconloc(21) user defined constants defined by the keyword -! card *USER MATERIAL (max. 21, actual # = -! -kode-100), interpolated for the -! actual temperature t1l -! -! emec(6) Lagrange mechanical strain tensor (component order: -! 11,22,33,12,13,23) at the end of the increment -! (thermal strains are subtracted) -! emec0(6) Lagrange mechanical strain tensor at the start of the -! increment (thermal strains are subtracted) -! beta(6) residual stress tensor (the stress entered under -! the keyword *INITIAL CONDITIONS,TYPE=STRESS) -! -! xokl(3,3) deformation gradient at the start of the increment -! voj Jacobian at the start of the increment -! xkl(3,3) deformation gradient at the end of the increment -! vj Jacobian at the end of the increment -! -! ithermal 0: no thermal effects are taken into account -! 1: thermal effects are taken into account (triggered -! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) -! t1l temperature at the end of the increment -! dtime time length of the increment -! time step time at the end of the current increment -! ttime total time at the start of the current increment -! -! icmd not equal to 3: calculate stress and stiffness -! 3: calculate only stress -! ielas 0: no elastic iteration: irreversible effects -! are allowed -! 1: elastic iteration, i.e. no irreversible -! deformation allowed -! -! mi(1) max. # of integration points per element in the -! model -! nstate_ max. # of state variables in the model -! -! xstateini(nstate_,mi(1),# of elements) -! state variables at the start of the increment -! xstate(nstate_,mi(1),# of elements) -! state variables at the end of the increment -! -! stre(6) Piola-Kirchhoff stress of the second kind -! at the start of the increment -! -! iorien number of the local coordinate axis system -! in the integration point at stake (takes the value -! 0 if no local system applies) -! pgauss(3) global coordinates of the integration point -! orab(7,*) description of all local coordinate systems. -! If a local coordinate system applies the global -! tensors can be obtained by premultiplying the local -! tensors with skl(3,3). skl is determined by calling -! the subroutine transformatrix: -! call transformatrix(orab(1,iorien),pgauss,skl) -! -! -! OUTPUT: -! -! xstate(nstate_,mi(1),# of elements) -! updated state variables at the end of the increment -! stre(6) Piola-Kirchhoff stress of the second kind at the -! end of the increment -! stiff(21): consistent tangent stiffness matrix in the material -! frame of reference at the end of the increment. In -! other words: the derivative of the PK2 stress with -! respect to the Lagrangian strain tensor. The matrix -! is supposed to be symmetric, only the upper half is -! to be given in the same order as for a fully -! anisotropic elastic material (*ELASTIC,TYPE=ANISO). -! Notice that the matrix is an integral part of the -! fourth order material tensor, i.e. the Voigt notation -! is not used. -! pnewdt to be specified by the user if the material -! routine is unable to return the stiffness matrix -! and/or the stress due to divergence within the -! routine. pnewdt is the factor by which the time -! increment is to be multiplied in the next -! trial and should exceed zero but be less than 1. -! Default is -1 indicating that the user routine -! has converged. -! - implicit none -! - character*80 amat -! - integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien -! - real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), - & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), - & time,ttime,pnewdt -! - real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) -! -! insert here code to calculate the stresses -! - if(icmd.ne.3) then -! -! insert here code to calculate the stiffness matrix -! - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/umpc_dist.f calculix-ccx-2.3/ccx_2.1/src/umpc_dist.f --- calculix-ccx-2.1/ccx_2.1/src/umpc_dist.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umpc_dist.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,221 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umpc_dist(x,u,f,a,jdof,n,force,iit,idiscon) -! -! updates the coefficients in a dist mpc (name DIST) -! -! a dist mpc specifies that the distance between two nodes -! a and b must not exceed value d -! -! input nodes: a,a,a,b,b,b,c -! -! node c is a fictitious node. The value d must be assigned -! to the first coordinate of node c by means of a *NODE card; -! the other coordinates of the node can be arbitrary. -! -! A value of zero must be assigned to the first DOF of node c by using -! a *BOUNDARY card. The second DOF of node c is not constrained and is -! used when the distance between nodes a and b is less than d: in -! that case there is no constraint at all. -! -! INPUT: -! -! x(3,n) Carthesian coordinates of the nodes in the -! user mpc. -! u(3,n) Actual displacements of the nodes in the -! user mpc. -! jdof Actual degrees of freedom of the mpc terms -! n number of terms in the user mpc -! force Actual value of the mpc force -! iit iteration number -! -! OUTPUT: -! -! f Actual value of the mpc. If the mpc is -! exactly satisfied, this value is zero -! a(n) coefficients of the linearized mpc -! jdof Corrected degrees of freedom of the mpc terms -! idiscon 0: no discontinuity -! 1: discontinuity -! If a discontinuity arises the previous -! results are not extrapolated at the start of -! a new increment -! - implicit none -! - integer jdof(*),n,iit,ifix,idiscon -! - real*8 x(3,*),u(3,*),f,a(*),dist(3),force -! -c write(*,*) (jdof(i),i=1,7) - if(jdof(7).eq.1) then - ifix=1 - else - ifix=0 - jdof(7)=2 - endif -! - dist(1)=x(1,1)+u(1,1)-x(1,4)-u(1,4) - dist(2)=x(2,1)+u(2,1)-x(2,4)-u(2,4) - dist(3)=x(3,1)+u(3,1)-x(3,4)-u(3,4) -! - f=dist(1)**2+dist(2)**2+dist(3)**2-x(1,7)**2 -! -c write(*,*) 'mpcforc=, f= ',force,f -! - a(7)=-1. -! -! only one change per increment is allowed -! (change= from free to linked or vice versa) -! ifix=0: free -! ifix=1: linked -! - if(ifix.eq.0) then -! -! previous state: free -! - if(f.lt.0) then -! -! new state: free -! - f=0.d0 - elseif(iit.le.1) then -! -! new state: linked -! - write(*,*) 'switch to linked' - write(*,*) - jdof(7)=1 - idiscon=1 - else -! -! new state: free -! - f=0.d0 - endif - else -! -! previous state: linked -! - if(force.le.0.d0) then -! -! new state: linked -! - elseif(iit.le.1) then -! -! new state: free -! - write(*,*) 'switch to free' - write(*,*) - jdof(7)=2 - f=0.d0 - idiscon=1 - else -! -! new state: linked -! - endif - endif -! - if(dabs(dist(jdof(1))).gt.1.d-10) then - a(1)=2.d0*dist(jdof(1)) - if(jdof(1).eq.1) then - jdof(2)=2 - jdof(3)=3 - elseif(jdof(1).eq.2) then - jdof(2)=3 - jdof(3)=1 - else - jdof(2)=1 - jdof(3)=2 - endif - a(2)=2.d0*dist(jdof(2)) - a(3)=2.d0*dist(jdof(3)) - else - if(jdof(1).eq.3) then - jdof(1)=1 - else - jdof(1)=jdof(1)+1 - endif - if(dabs(dist(jdof(1))).gt.1.d-10) then - a(1)=2.d0*dist(jdof(1)) - if(jdof(1).eq.1) then - jdof(2)=2 - jdof(3)=3 - elseif(jdof(1).eq.2) then - jdof(2)=3 - jdof(3)=1 - else - jdof(2)=1 - jdof(3)=2 - endif - a(2)=2.d0*dist(jdof(2)) - a(3)=2.d0*dist(jdof(3)) - else - if(jdof(1).eq.3) then - jdof(1)=1 - else - jdof(1)=jdof(1)+1 - endif - if(dabs(dist(jdof(1))).gt.1.d-10) then - a(1)=2.d0*dist(jdof(1)) - if(jdof(1).eq.1) then - jdof(2)=2 - jdof(3)=3 - elseif(jdof(1).eq.2) then - jdof(2)=3 - jdof(3)=1 - else - jdof(2)=1 - jdof(3)=2 - endif - a(2)=2.d0*dist(jdof(2)) - a(3)=2.d0*dist(jdof(3)) - endif - endif - endif -! - a(4)=-2.d0*dist(1) - a(5)=-2.d0*dist(2) - a(6)=-2.d0*dist(3) - jdof(4)=1 - jdof(5)=2 - jdof(6)=3 -! -c write(*,*) 'jdof,a' -c do i=1,7 -c write(*,*) jdof(i),a(i) -c enddo -c write(*,*) 'f ',f -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/umpc_gap.f calculix-ccx-2.3/ccx_2.1/src/umpc_gap.f --- calculix-ccx-2.1/ccx_2.1/src/umpc_gap.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umpc_gap.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,219 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umpc_gap(x,u,f,a,jdof,n,force,iit,idiscon) -! -! updates the coefficients in a gap mpc (name GAP) -! -! a gap MPC is triggered by a *GAP definition applied to -! a GAPUNI element. The gap direction is stored in -! x(1..3,7), the clearance in x(1,8), which is also the -! constant term -! -! INPUT: -! -! x(3,n) Carthesian coordinates of the nodes in the -! user mpc. -! u(3,n) Actual displacements of the nodes in the -! user mpc. -! jdof Actual degrees of freedom of the mpc terms -! n number of terms in the user mpc -! force Actual value of the mpc force -! iit iteration number -! -! OUTPUT: -! -! f Actual value of the mpc. If the mpc is -! exactly satisfied, this value is zero -! a(n) coefficients of the linearized mpc -! jdof Corrected degrees of freedom of the mpc terms -! idiscon 0: no discontinuity -! 1: discontinuity -! If a discontinuity arises the previous -! results are not extrapolated at the start of -! a new increment -! - implicit none -! - integer jdof(*),n,iit,ifix,idiscon -! - real*8 x(3,*),u(3,*),f,a(*),dist(3),xn(3),force -! -c write(*,*) (jdof(i),i=1,7) - if(jdof(7).eq.1) then - ifix=1 - else - ifix=0 - jdof(7)=2 - endif -! - dist(1)=u(1,4)-u(1,1) - dist(2)=u(2,4)-u(2,1) - dist(3)=u(3,4)-u(3,1) -! -! gap direction -! - xn(1)=x(1,7) - xn(2)=x(2,7) - xn(3)=x(3,7) -! - f=dist(1)*xn(1)+dist(2)*xn(2)+dist(3)*xn(3)+x(1,8) -! -c write(*,*) 'dist,xn',dist(1),dist(2),dist(3),xn(1),xn(2),xn(3) -c write(*,*) 'mpcforc=, f= ',force,f -! - a(7)=-1. -! -! only one change per increment is allowed -! (change= from free to linked or vice versa) -! ifix=0: free -! ifix=1: linked -! - if(ifix.eq.0) then -! -! previous state: free -! - if(f.gt.0) then -! -! new state: free -! - f=0.d0 - elseif(iit.le.1) then -! -! new state: linked -! - write(*,*) 'switch to linked' - write(*,*) - jdof(7)=1 - idiscon=1 - else -! -! new state: free -! - f=0.d0 - endif - else -! -! previous state: linked -! - if(force.ge.0.d0) then -! -! new state: linked -! - elseif(iit.le.1) then -! -! new state: free -! - write(*,*) 'switch to free' - write(*,*) - jdof(7)=2 - f=0.d0 - idiscon=1 - else -! -! new state: linked -! - endif - endif -! - if(dabs(xn(jdof(1))).gt.1.d-10) then - a(1)=-xn(jdof(1)) - if(jdof(1).eq.1) then - jdof(2)=2 - jdof(3)=3 - elseif(jdof(1).eq.2) then - jdof(2)=3 - jdof(3)=1 - else - jdof(2)=1 - jdof(3)=2 - endif - a(2)=-xn(jdof(2)) - a(3)=-xn(jdof(3)) - else - if(jdof(1).eq.3) then - jdof(1)=1 - else - jdof(1)=jdof(1)+1 - endif - if(dabs(xn(jdof(1))).gt.1.d-10) then - a(1)=-xn(jdof(1)) - if(jdof(1).eq.1) then - jdof(2)=2 - jdof(3)=3 - elseif(jdof(1).eq.2) then - jdof(2)=3 - jdof(3)=1 - else - jdof(2)=1 - jdof(3)=2 - endif - a(2)=-xn(jdof(2)) - a(3)=-xn(jdof(3)) - else - if(jdof(1).eq.3) then - jdof(1)=1 - else - jdof(1)=jdof(1)+1 - endif - if(dabs(xn(jdof(1))).gt.1.d-10) then - a(1)=-xn(jdof(1)) - if(jdof(1).eq.1) then - jdof(2)=2 - jdof(3)=3 - elseif(jdof(1).eq.2) then - jdof(2)=3 - jdof(3)=1 - else - jdof(2)=1 - jdof(3)=2 - endif - a(2)=-xn(jdof(2)) - a(3)=-xn(jdof(3)) - endif - endif - endif -! - a(4)=xn(1) - a(5)=xn(2) - a(6)=xn(3) - jdof(4)=1 - jdof(5)=2 - jdof(6)=3 -! -c write(*,*) 'jdof,a' -c do i=1,7 -c write(*,*) jdof(i),a(i) -c enddo -c write(*,*) 'f ',f -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/umpc_mean_rot.f calculix-ccx-2.3/ccx_2.1/src/umpc_mean_rot.f --- calculix-ccx-2.1/ccx_2.1/src/umpc_mean_rot.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umpc_mean_rot.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,199 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umpc_mean_rot(x,u,f,a,jdof,n,force,iit,idiscon) -! -! updates the coefficients in a mean rotation mpc -! -! INPUT: -! -! x(3,n) Carthesian coordinates of the nodes in the -! user mpc. -! u(3,n) Actual displacements of the nodes in the -! user mpc. -! jdof Actual degrees of freedom of the mpc terms -! n number of terms in the user mpc -! force Actual value of the mpc force -! iit iteration number -! -! OUTPUT: -! -! f Actual value of the mpc. If the mpc is -! exactly satisfied, this value is zero -! a(n) coefficients of the linearized mpc -! jdof Corrected degrees of freedom of the mpc terms -! idiscon 0: no discontinuity -! 1: discontinuity -! If a discontinuity arises the previous -! results are not extrapolated at the start of -! a new increment -! - implicit none -! - integer jdof(*),n,nkn,i,j,k,imax,iit,idiscon -! - real*8 x(3,*),u(3,*),f,a(*),aa(3),cgx(3),cgu(3),pi(3), - & xi(3),dd,al,a1,amax,c1,c2,c3,c4,c9,c10,force -! - nkn=(n-1)/3 - if(3*nkn.ne.n-1) then - write(*,*) - & '*ERROR in meanrotmpc: MPC has wrong number of terms' - stop - endif -! -! normal along the rotation axis -! - dd=0.d0 - do i=1,3 - aa(i)=x(i,n) - dd=dd+aa(i)**2 - enddo - dd=dsqrt(dd) - if(dd.lt.1.d-10) then - write(*,*) - & '*ERROR in meanrotmpc: rotation vector has zero length' - stop - endif - do i=1,3 - aa(i)=aa(i)/dd - enddo -! -! finding the center of gravity of the position and the -! displacements of the nodes involved in the MPC -! - do i=1,3 - cgx(i)=0.d0 - cgu(i)=0.d0 - enddo -! - do i=1,nkn -c write(*,*) 'x,u' -c write(*,101) (x(j,3*i-2),j=1,3),(u(j,3*i-2),j=1,3) -c 101 format(6(1x,e11.4)) - do j=1,3 - cgx(j)=cgx(j)+x(j,3*i-2) - cgu(j)=cgu(j)+u(j,3*i-2) - enddo - enddo -! - do i=1,3 - cgx(i)=cgx(i)/nkn - cgu(i)=cgu(i)/nkn - enddo -c write(*,*) 'cgx ',(cgx(i),i=1,3) -c write(*,*) 'cgu ',(cgu(i),i=1,3) -! -! initializing a -! - do i=1,n - a(i)=0.d0 - enddo -! -! calculating the partial derivatives and storing them in a -! - f=0.d0 - do i=1,nkn -! -! relative positions -! - do j=1,3 - pi(j)=x(j,3*i-2)-cgx(j) - xi(j)=u(j,3*i-2)-cgu(j)+pi(j) - enddo -! - c1=pi(1)*pi(1)+pi(2)*pi(2)+pi(3)*pi(3) - if(c1.lt.1.d-20) then - write(*,*) '*WARNING in meanrotmpc: node on rotation axis' - cycle - endif - c3=xi(1)*xi(1)+xi(2)*xi(2)+xi(3)*xi(3) - c2=dsqrt(c1*c3) -! - al=(aa(1)*pi(2)*xi(3)+aa(2)*pi(3)*xi(1)+aa(3)*pi(1)*xi(2) - & -aa(3)*pi(2)*xi(1)-aa(1)*pi(3)*xi(2)-aa(2)*pi(1)*xi(3)) - & /c2 -! - f=f+dasin(al) -c write(*,*) 'f ',dasin(al) -! - do j=1,3 - if(j.eq.1) then - c4=aa(2)*pi(3)-aa(3)*pi(2) - elseif(j.eq.2) then - c4=aa(3)*pi(1)-aa(1)*pi(3) - else - c4=aa(1)*pi(2)-aa(2)*pi(1) - endif - c9=(c4/c2-al*xi(j)/c3)/dsqrt(1.d0-al*al) -! - do k=1,nkn - if(i.eq.k) then - c10=c9*(1.d0-1.d0/real(nkn)) - else - c10=-c9/real(nkn) - endif - a(k*3-3+j)=a(k*3-3+j)+c10 - enddo - enddo - enddo - a(n)=-nkn - f=f-nkn*u(1,n) -! -! assigning the degrees of freedom -! - do i=1,nkn - jdof(i*3-2)=1 - jdof(i*3-1)=2 - jdof(i*3)=3 - enddo - jdof(n)=1 -! -! looking for the maximum tangent to decide which DOF should be -! taken to be the dependent one -! - if(dabs(a(1)).lt.1.d-5) then - amax=0.d0 - do i=1,3 - if(dabs(a(i)).gt.amax) then - amax=abs(a(i)) - imax=i - endif - enddo -c write(*,*) 'a(1),a(2),a(3) ',a(1),a(2),a(3) -c write(*,*) 'jdof ',jdof(1),jdof(2),jdof(3) -! - jdof(1)=imax - a1=a(1) - a(1)=a(imax) - do i=2,3 - if(i.eq.imax) then - jdof(i)=1 - a(i)=a1 - write(*,*) '*INFO: DOF in umpc_mean_rot changed' -c stop - else - jdof(i)=i - endif - enddo - endif -c write(*,*) 'a(1),a(2),a(3) ',a(1),a(2),a(3) -c write(*,*) 'jdof ',jdof(1),jdof(2),jdof(3) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/umpc_user.f calculix-ccx-2.3/ccx_2.1/src/umpc_user.f --- calculix-ccx-2.1/ccx_2.1/src/umpc_user.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/umpc_user.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,67 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine umpc_user(x,u,f,a,jdof,n,force,iit,idiscon) -! -! updates the coefficients in a user mpc -! -! INPUT: -! -! x(3,n) Carthesian coordinates of the nodes in the -! user mpc. -! u(3,n) Actual displacements of the nodes in the -! user mpc. -! jdof Actual degrees of freedom of the mpc terms -! n number of terms in the user mpc -! force Actual value of the mpc force -! iit iteration number -! -! OUTPUT: -! -! f Actual value of the mpc. If the mpc is -! exactly satisfied, this value is zero -! a(n) coefficients of the linearized mpc -! jdof Corrected degrees of freedom of the mpc terms -! idiscon 0: no discontinuity -! 1: discontinuity -! If a discontinuity arises the previous -! results are not extrapolated at the start of -! a new increment -! - implicit none -! - integer jdof(*),n,iit,idiscon -! - real*8 x(3,*),u(3,*),f,a(*),force -! -! - return - end - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/uncouptempdisps.f calculix-ccx-2.3/ccx_2.1/src/uncouptempdisps.f --- calculix-ccx-2.1/ccx_2.1/src/uncouptempdisps.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/uncouptempdisps.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,190 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine uncouptempdisps(inpc,textpart,nmethod,iperturb,isolver, - & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline,ipol, - & inl,ipoinp,inp,ipoinpc,alpha,ctrl) -! -! reading the input deck: *COUPLED TEMPERATURE-DISPLACEMENT -! -! isolver=0: SPOOLES -! 2: iterative solver with diagonal scaling -! 3: iterative solver with Cholesky preconditioning -! 4: sgi solver -! 5: TAUCS -! 7: pardiso -! - implicit none -! - character*1 inpc(*) - character*20 solver - character*132 textpart(16) -! - integer nmethod,iperturb,isolver,istep,istat,n,key,i,idrct, - & ithermal,iline,ipol,inl,ipoinp(2,*),inp(3,*),ipoinpc(0:*) -! - real*8 tinc,tper,tmin,tmax,alpha,ctrl(*) -! - idrct=0 - alpha=-0.05d0 - tmin=0.d0 - tmax=0.d0 - nmethod=4 -! - if(iperturb.eq.0) then - iperturb=2 - elseif((iperturb.eq.1).and.(istep.gt.1)) then - write(*,*) '*ERROR in couptempdisps: perturbation analysis is' - write(*,*) ' not provided in a *HEAT TRANSFER step.' - stop - endif -! - if(istep.lt.1) then - write(*,*) '*ERROR in couptempdisps: *HEAT TRANSFER can only ' - write(*,*) ' be used within a STEP' - stop - endif -! -! default solver -! - if(isolver.eq.0) then - solver(1:7)='SPOOLES' - elseif(isolver.eq.2) then - solver(1:16)='ITERATIVESCALING' - elseif(isolver.eq.3) then - solver(1:17)='ITERATIVECHOLESKY' - elseif(isolver.eq.4) then - solver(1:3)='SGI' - elseif(isolver.eq.5) then - solver(1:5)='TAUCS' - elseif(isolver.eq.7) then - solver(1:7)='PARDISO' - endif -! - do i=2,n - if(textpart(i)(1:6).eq.'ALPHA=') then - read(textpart(i)(7:26),'(f20.0)',iostat=istat) alpha - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - if(alpha.lt.-1.d0/3.d0) then - write(*,*) '*WARNING in dynamics: alpha is smaller' - write(*,*) ' than -1/3 and is reset to -1/3' - alpha=-1.d0/3.d0 - elseif(alpha.gt.0.d0) then - write(*,*) '*WARNING in dynamics: alpha is greater' - write(*,*) ' than 0 and is reset to 0' - alpha=0.d0 - endif - elseif(textpart(i)(1:7).eq.'SOLVER=') then - read(textpart(i)(8:27),'(a20)') solver - elseif((textpart(i)(1:6).eq.'DIRECT').and. - & (textpart(i)(1:9).ne.'DIRECT=NO')) then - idrct=1 - elseif(textpart(i)(1:11).eq.'STEADYSTATE') then - nmethod=1 - elseif(textpart(i)(1:7).eq.'DELTMX=') then - read(textpart(i)(8:27),'(f20.0)',iostat=istat) ctrl(27) - endif - enddo - if(nmethod.eq.1) ctrl(27)=1.d30 -! - if((ithermal.eq.0).and.(nmethod.ne.1).and. - & (nmethod.ne.2).and.(iperturb.ne.0)) then - write(*,*) '*ERROR in couptempdisps: please define initial ' - write(*,*) ' conditions for the temperature' - stop - else - ithermal=4 - endif -! - if(solver(1:7).eq.'SPOOLES') then - isolver=0 - elseif(solver(1:16).eq.'ITERATIVESCALING') then - isolver=2 - elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then - isolver=3 - elseif(solver(1:3).eq.'SGI') then - isolver=4 - elseif(solver(1:5).eq.'TAUCS') then - isolver=5 - elseif(solver(1:7).eq.'PARDISO') then - isolver=7 - else - write(*,*) '*WARNING in couptempdisps: unknown solver;' - write(*,*) ' the default solver is used' - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - if(iperturb.ge.2) then - write(*,*) '*WARNING in couptempdisps: a nonlinear geometric - & analysis is requested' - write(*,*) ' but no time increment nor step is speci - &fied' - write(*,*) ' the defaults (1,1) are used' - tinc=1.d0 - tper=1.d0 - tmin=1.d-5 - tmax=1.d+30 - endif - return - endif -! - read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) tmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(4)(1:20),'(f20.0)',iostat=istat) tmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! - if(tinc.le.0.d0) then - write(*,*) '*ERROR in couptempdisps: initial increment size is - &negative' - endif - if(tper.le.0.d0) then - write(*,*) '*ERROR in couptempdisps: step size is negative' - endif - if(tinc.gt.tper) then - write(*,*) '*ERROR in couptempdisps: initial increment size exc - &eeds step size' - endif -! - if(idrct.ne.1) then - if(dabs(tmin).lt.1.d-10) then - tmin=min(tinc,1.d-5*tper) - endif - if(dabs(tmax).lt.1.d-10) then - tmax=1.d+30 - endif - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/uout.f calculix-ccx-2.3/ccx_2.1/src/uout.f --- calculix-ccx-2.1/ccx_2.1/src/uout.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/uout.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine uout(v,mi) -! -! This routine allows the user to write user-defined output -! to file. The output can be brought into the routine by commons -! (FORTRAN77) or modules (FORTRAN90). The file management must -! be taken care of by the user. -! -! INPUT: -! -! v solution vector -! mi(1) max # of integration points per element (max -! over all elements) -! mi(2) max degree of freedomm per node (max over all -! nodes) in fields like v(0:mi(2))... -! -! OUTPUT: none -! - implicit none -! - integer mi(2) -! - real*8 v(0:mi(2),*) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/updatecfd.f calculix-ccx-2.3/ccx_2.1/src/updatecfd.f --- calculix-ccx-2.1/ccx_2.1/src/updatecfd.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/updatecfd.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,261 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine updatecfd(vold,voldaux,v,nk, - & ielmat,ntmat_,shcon,nshcon,rhcon,nrhcon,iout, - & nmethod,convergence,physcon,iponoel,inoel,ithermal, - & nactdoh,iit,compressible,ismooth,voldtu,vtu,turbulent, - & inomat,nodeboun,ndirboun,nboun,mi,shockscale) -! -! calculates -! vold (temperature,velocity and pressure) -! voldaux (volumetric energy density, volumetric momentum -! density and density) -! at the nodes -! -! prints if iout=1 -! - implicit none -! - integer convergence,compressible -! - integer nrhcon(*),ntmat_,nactdoh(0:4,*),iit,turbulent, - & nshcon(*),ielmat(*),nk,ithermal,i,j,k,index,iout, - & nmethod,imat,nelem,iponoel(*),inoel(3,*),ismooth, - & inomat(*),node,nodeboun(*),ndirboun(*),nboun,mi(2) -! - real*8 v(0:mi(2),*),vold(0:mi(2),*),voldaux(0:4,*), - & rhcon(0:1,ntmat_,*),rho,c1,vmax(0:4),dummy,press, - & voldmax(0:4),cp,r,temp,temp0,c2,c3,tempnew,vel2, - & shcon(0:3,ntmat_,*),drho,dtemp,physcon(*),dpress, - & voldtu(2,*),vtu(2,*),shockscale -! - if(ismooth.eq.0) then -! -! updates the volumetric energy density (only if ithermal>1), -! the volumetric momentum density and the static pressure -! - do j=0,4 - vmax(j)=0.d0 - voldmax(j)=0.d0 - enddo -! -! volumetric energy density -! - if(ithermal.gt.1) then - do i=1,nk - vmax(0)=vmax(0)+v(0,i)**2 - voldmax(0)=voldmax(0)+voldaux(0,i)**2 - voldaux(0,i)=voldaux(0,i)+v(0,i) - enddo -! -! subtracting the boundary conditions -! - do i=1,nboun - if(ndirboun(i).eq.0) then - vmax(0)=vmax(0)-v(0,nodeboun(i))**2 - endif - enddo -! - endif -! -! volumetric momentum density -! - do i=1,nk - do j=1,3 - vmax(j)=vmax(j)+v(j,i)**2 - voldmax(j)=voldmax(j)+voldaux(j,i)**2 - voldaux(j,i)=voldaux(j,i)+v(j,i) - enddo - enddo -! -! volumetric turbulent density -! - if(turbulent.ne.0) then - do i=1,nk - voldtu(1,i)=voldtu(1,i)+vtu(1,i) - voldtu(2,i)=voldtu(2,i)+vtu(2,i) - enddo - endif - endif -! -! calculate the static temperature and the density -! - if(ithermal.gt.1) then -! - do i=1,nk - if((compressible.eq.0).or.(ismooth.gt.0)) then - if(inomat(i).eq.0) cycle - imat=inomat(i) - temp=vold(0,i) - endif -! - if(compressible.eq.1) then -! -! gas: density was calculated -! - if(ismooth.eq.0) then - vmax(4)=vmax(4)+v(4,i)**2 - voldmax(4)=voldmax(4)+voldaux(4,i)**2 - voldaux(4,i)=voldaux(4,i)+v(4,i) - cycle - endif - rho=voldaux(4,i) - c1=(voldaux(0,i)-(voldaux(1,i)**2+voldaux(2,i)**2+ - & voldaux(3,i)**2)/(2.d0*rho))/rho -! -! temperature has to be calculated -! - temp0=temp - j=0 - do - call materialdata_cp_sec(imat,ntmat_,temp,shcon, - & nshcon,cp,physcon) - r=shcon(3,1,imat) -c call materialdata_tg_sec(imat,ntmat_,temp, -c & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,dummy, -c & physcon) - temp=max(c1/(cp-r),1.d-2)+physcon(1) - j=j+1 - if(dabs(temp-temp0).lt.1.d-4*temp) then - vold(0,i)=temp - exit - endif - if(j.gt.100) then - stop - endif - temp0=temp - enddo -! -! determining the pressure (gas equation) -! - vold(4,i)=rho*r*(temp-physcon(1)) -! -! determining the Mach number -! - if(ismooth.eq.2) then - vel2=vold(1,i)**2+vold(2,i)**2+vold(3,i)**2 - v(0,i)=cp/(cp-r) - v(1,i)=dsqrt((vold(1,i)**2+vold(2,i)**2+vold(3,i)**2) - & /(v(0,i)*r*(temp-physcon(1)))) - endif -! - else -! -! thermal liquid: pressure was calculated -! - vmax(4)=vmax(4)+v(4,i)**2 - voldmax(4)=voldmax(4)+vold(4,i)**2 - vold(4,i)=vold(4,i)+v(4,i) - c1=voldaux(0,i) - c2=(voldaux(1,i)**2+voldaux(2,i)**2+voldaux(3,i)**2)/2.d0 - temp0=temp - j=0 -! -! iterating to find the temperature -! - do - call materialdata_cp_sec(imat,ntmat_,temp,shcon, - & nshcon,cp,physcon) - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) -c temp=max((c1-c2/rho)/(rho*cp),1.d-2)+physcon(1) - temp=(c1-c2/rho)/(rho*cp)+physcon(1) - j=j+1 - if((dabs(temp-temp0).lt.1.d-4*dabs(temp)).or. - & (dabs(temp-temp0).lt.1.d-10)) then - vold(0,i)=temp - exit - endif - if(j.gt.100) then - write(*,*) - & '*ERROR in updatecfd: too many iterations' - stop - endif - temp0=temp - enddo - endif -! -! calculating the velocity -! - do k=1,3 - if(nactdoh(k,i).ne.0) then - vold(k,i)=voldaux(k,i)/rho - endif - enddo - enddo - else -! -! athermal liquid calculation -! - do i=1,nk - if(inomat(i).eq.0) cycle - imat=inomat(i) - temp=vold(0,i) - call materialdata_rho(rhcon,nrhcon,imat,rho, - & temp,ntmat_) -! - vmax(4)=vmax(4)+v(4,i)**2 - voldmax(4)=voldmax(4)+vold(4,i)**2 - vold(4,i)=vold(4,i)+v(4,i) - voldaux(4,i)=rho -! -! storing the density -! calculating the velocity -! - do k=1,3 - vold(k,i)=voldaux(k,i)/rho - enddo - enddo - endif -! -! for steady state calculations: check convergence -! - if(ismooth.eq.0) then - convergence=0 - do i=0,4 - vmax(i)=dsqrt(vmax(i)) - voldmax(i)=dsqrt(voldmax(i)) - enddo - if(nmethod.eq.1) then - if(((dabs(vmax(0)).lt.1.d-8*dabs(voldmax(0))).or. - & (dabs(voldmax(0)).lt.1.d-10)).and. - & ((dabs(vmax(1)).lt.1.d-8*dabs(voldmax(1))).or. - & (dabs(voldmax(1)).lt.1.d-10)).and. - & ((dabs(vmax(2)).lt.1.d-8*dabs(voldmax(2))).or. - & (dabs(voldmax(2)).lt.1.d-10)).and. - & ((dabs(vmax(3)).lt.1.d-8*dabs(voldmax(3))).or. - & (dabs(voldmax(3)).lt.1.d-10)).and. - & ((dabs(vmax(4)).lt.1.d-8*dabs(voldmax(4))).or. - & (dabs(voldmax(4)).lt.1.d-10)).and. - & (iit.gt.1)) convergence=1 - endif - write(*,*) 'rho*totenergy ',vmax(0),voldmax(0),iit - write(*,*) 'rho*vx ',vmax(1),voldmax(1) - write(*,*) 'rho*vy ',vmax(2),voldmax(2) - write(*,*) 'rho*vz ',vmax(3),voldmax(3) - write(*,*) 'pressure(fluids)/density(gas) ',vmax(4),voldmax(4) - shockscale=((vmax(0)**2+vmax(1)**2+vmax(2)**2+vmax(3)**2+ - & vmax(4)**2)/(voldmax(0)**2+voldmax(1)**2+ - & voldmax(2)**2+voldmax(3)**2+voldmax(4)**2))** - & (1.d0/20.d0) - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/updatecont.f calculix-ccx-2.3/ccx_2.1/src/updatecont.f --- calculix-ccx-2.1/ccx_2.1/src/updatecont.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/updatecont.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine updatecont(koncont,ncont,co,vold,cg,straight,mi) -! -! update geometric date of the contact master surface triangulation -! - implicit none -! - integer koncont(4,*),ncont,i,j,k,node,mi(2) -! - real*8 co(3,*),vold(0:mi(2),*),cg(3,*),straight(16,*),col(3,3) -! - do i=1,ncont - do j=1,3 - node=koncont(j,i) - do k=1,3 - col(k,j)=co(k,node)+vold(k,node) - enddo - enddo -! -! center of gravity of the triangles -! - do k=1,3 - cg(k,i)=col(k,1) - enddo - do j=2,3 - do k=1,3 - cg(k,i)=cg(k,i)+col(k,j) - enddo - enddo - do k=1,3 - cg(k,i)=cg(k,i)/3.d0 - enddo -! -! calculating the equation of the triangle plane and the planes -! perpendicular on it and through the triangle edges -! - call straighteq3d(col,straight(1,i)) -! - enddo -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/usermaterials.f calculix-ccx-2.3/ccx_2.1/src/usermaterials.f --- calculix-ccx-2.1/ccx_2.1/src/usermaterials.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/usermaterials.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,162 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine usermaterials(inpc,textpart,elcon,nelcon, - & nmat,ntmat_,ncmat_,iperturb,iumat,irstrt,istep,istat,n, - & iline,ipol,inl,ipoinp,inp,cocon,ncocon,ipoinpc) -! -! reading the input deck: *USER MATERIAL -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer nelcon(2,*),nmat,ntmat,ntmat_,istep,istat,ncocon(2,*), - & n,key,i,ncmat_,nconstants,imax,isum,j,iperturb(*),iumat, - & irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),imech,ipoinpc(0:*) -! - real*8 elcon(0:ncmat_,ntmat_,*),cocon(0:6,ntmat_,*) -! - iperturb(1)=3 - iperturb(2)=0 - ntmat=0 - iumat=1 -! - if((istep.gt.0).and.(irstrt.ge.0)) then - write(*,*)'*ERROR in usermaterials: *USER MATERIAL should be' - write(*,*) ' placed before all step definitions' - stop - endif -! - if(nmat.eq.0) then - write(*,*) '*ERROR in usermaterials: *USER MATERIAL should be' - write(*,*) ' preceded by a *MATERIAL card' - stop - endif -! - imech=1 -! - do i=2,n - if(textpart(i)(1:10).eq.'CONSTANTS=') then - read(textpart(i)(11:20),'(i10)',iostat=istat) nconstants - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - elseif(textpart(i)(1:12).eq.'TYPE=THERMAL') then - imech=0 - endif - enddo -! - if(imech.eq.1) then -! -! mechanical user material -! -c if(nconstants.gt.21) then -c write(*,*) '*ERROR in usermaterials: number of' -c write(*,*) ' mechanical constants cannot exceed 21' -c write(*,*) ' change the source code or' -c write(*,*) ' contact the author' -c stop -c endif - nelcon(1,nmat)=-100-nconstants -! - do - isum=0 - do j=1,(nconstants)/8+1 - if(j.eq.1) then - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - nelcon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) - & '*ERROR in usermaterials: increase ntmat_' - stop - endif - else - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - write(*,*) - & '*ERROR in usermaterials: anisotropic definition' - write(*,*) ' is not complete. ' - call inputerror(inpc,ipoinpc,iline) - stop - endif - endif - imax=8 - if(8*j.gt.nconstants+1) then - imax=nconstants-8*j+9 - endif - do i=1,imax - if(isum+i.le.nconstants) then - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(isum+i,ntmat,nmat) - else - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & elcon(0,ntmat,nmat) - endif - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - isum=isum+imax -! - enddo - enddo -! - else -! -! thermal user material -! - if(nconstants.gt.6) then - write(*,*) '*ERROR in usermaterials: number of' - write(*,*) ' thermal constants cannot exceed 6' - write(*,*) ' change the source code or' - write(*,*) ' contact the author' - stop - endif - ncocon(1,nmat)=-100-nconstants -! - do - call getnewline(inpc,textpart,istat,n,key,iline,ipol, - & inl,ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) return - ntmat=ntmat+1 - ncocon(2,nmat)=ntmat - if(ntmat.gt.ntmat_) then - write(*,*) - & '*ERROR in usermaterials: increase ntmat_' - stop - endif -! - do i=1,nconstants+1 - if(i.le.nconstants) then - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & cocon(i,ntmat,nmat) - else - read(textpart(i)(1:20),'(f20.0)',iostat=istat) - & cocon(0,ntmat,nmat) - endif - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo - enddo -! - endif -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/usermpc.f calculix-ccx-2.3/ccx_2.1/src/usermpc.f --- calculix-ccx-2.1/ccx_2.1/src/usermpc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/usermpc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,307 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine usermpc(ipompc,nodempc,coefmpc, - & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, - & ikboun,ilboun,nboun,nboun_,inode,node,co,label,typeboun, - & iperturb) -! -! initializes mpc fields for a user MPC -! - implicit none -! - character*1 typeboun(*) - character*20 labmpc(*),label -! - integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), - & ilmpc(*),node,id,mpcfreeold,idof,l,nodeboun(*),iperturb(2), - & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,inode,nodevector, - & index,index1,node1,i,j,imax,nkn,idofrem,idofins -! - real*8 coefmpc(*),co(3,*),aa(3),dd,cgx(3),pi(3),c1,c4,c9, - & c10,a(3),a1,amax -! - save nodevector -! - if(node.ne.0) then - if(inode.eq.1) then -! -! define a new MPC -! default for the dependent DOF direction is 1 -! - idof=8*(node-1)+1 -! - call nident(ikmpc,idof,nmpc,id) - if(id.gt.0) then - if(ikmpc(id).eq.idof) then - write(*,*) '*WARNING in usermpc: DOF for node ',node - write(*,*) ' in direction 1 has been used' - write(*,*) ' on the dependent side of another' - write(*,*) ' MPC. ',label - write(*,*) ' constraint cannot be applied' - return - endif - endif - nmpc=nmpc+1 - if(nmpc.gt.nmpc_) then - write(*,*) '*ERROR in usermpc: increase nmpc_' - stop - endif -! - ipompc(nmpc)=mpcfree - labmpc(nmpc)=label -! - do l=nmpc,id+2,-1 - ikmpc(l)=ikmpc(l-1) - ilmpc(l)=ilmpc(l-1) - enddo - ikmpc(id+1)=idof - ilmpc(id+1)=nmpc - endif -! -! general case: add a term to the MPC -! - nodempc(1,mpcfree)=node -! -! nodevector: additional node such that: -! - the coordinates of this node are the axis direction -! - the 1st DOF is reserved for the mean rotation value -! - if((labmpc(nmpc)(1:7).eq.'MEANROT').or. - & (labmpc(nmpc)(1:1).eq.'1')) then - nodevector=node - labmpc(nmpc)(1:7)='MEANROT' - endif -! - if(inode.eq.1) then - nodempc(2,mpcfree)=1 - else - nodempc(2,mpcfree)=0 - endif - mpcfree=nodempc(3,mpcfree) - else -! -! MPC definition finished: add a nonhomogeneous term -! - nk=nk+1 - if(nk.gt.nk_) then - write(*,*) '*ERROR in usermpc: increase nk_' - stop - endif -! - nodempc(1,mpcfree)=nk - nodempc(2,mpcfree)=1 -c - coefmpc(mpcfree)=1.d0 -c - mpcfreeold=mpcfree - mpcfree=nodempc(3,mpcfree) - nodempc(3,mpcfreeold)=0 - idof=8*(nk-1)+1 - call nident(ikboun,idof,nboun,id) - nboun=nboun+1 - if(nboun.gt.nboun_) then - write(*,*) '*ERROR in usermpc: increase nboun_' - stop - endif - nodeboun(nboun)=nk - ndirboun(nboun)=1 - typeboun(nboun)='U' - do l=nboun,id+2,-1 - ikboun(l)=ikboun(l-1) - ilboun(l)=ilboun(l-1) - enddo - ikboun(id+1)=idof - ilboun(id+1)=nboun -! -! calculating the MPC coefficients for linear applications -! - if((labmpc(nmpc)(1:7).eq.'MEANROT').or. - & (labmpc(nmpc)(1:1).eq.'1')) then - nkn=(inode-1)/3 - if(3*nkn.ne.inode-1) then - write(*,*) - & '*ERROR in usermpc: MPC has wrong number of terms' - stop - endif -! -! normal along the rotation axis -! - dd=0.d0 - do i=1,3 - aa(i)=co(i,nodevector) - dd=dd+aa(i)**2 - enddo - dd=dsqrt(dd) - if(dd.lt.1.d-10) then - write(*,*) - & '*ERROR in usermpc: rotation vector has zero length' - stop - endif - do i=1,3 - aa(i)=aa(i)/dd - enddo -! -! finding the center of gravity of the position and the -! displacements of the nodes involved in the MPC -! - do i=1,3 - cgx(i)=0.d0 - enddo -! - index=ipompc(nmpc) - do - node=nodempc(1,index) - if(node.eq.nodevector) exit - do j=1,3 - cgx(j)=cgx(j)+co(j,node) - enddo - index=nodempc(3,nodempc(3,nodempc(3,index))) - enddo -! - do i=1,3 - cgx(i)=cgx(i)/nkn - enddo -! -! calculating the derivatives -! - index=ipompc(nmpc) - do - node=nodempc(1,index) - if(node.eq.nodevector) exit -! -! relative positions -! - do j=1,3 - pi(j)=co(j,node)-cgx(j) - enddo - c1=pi(1)*pi(1)+pi(2)*pi(2)+pi(3)*pi(3) - if(c1.lt.1.d-20) then - write(*,*)'*WARNING in usermpc: node on rotation axis' - index=nodempc(3,nodempc(3,nodempc(3,index))) - cycle - endif -! - do j=1,3 - if(j.eq.1) then - c4=aa(2)*pi(3)-aa(3)*pi(2) - elseif(j.eq.2) then - c4=aa(3)*pi(1)-aa(1)*pi(3) - else - c4=aa(1)*pi(2)-aa(2)*pi(1) - endif - c9=c4/c1 -! - index1=ipompc(nmpc) - do - node1=nodempc(1,index1) - if(node1.eq.nodevector) exit - if(node1.eq.node) then - c10=c9*(1.d0-1.d0/real(nkn)) - else - c10=-c9/real(nkn) - endif - if(j.eq.1) then - coefmpc(index1)=coefmpc(index1)+c10 - elseif(j.eq.2) then - coefmpc(nodempc(3,index1))= - & coefmpc(nodempc(3,index1))+c10 - else - coefmpc(nodempc(3,nodempc(3,index1)))= - & coefmpc(nodempc(3,nodempc(3,index1)))+c10 - endif - index1=nodempc(3,nodempc(3,nodempc(3,index1))) - enddo - enddo - index=nodempc(3,nodempc(3,nodempc(3,index))) - enddo - coefmpc(index)=-nkn -! -! assigning the degrees of freedom -! - j=0 - index=ipompc(nmpc) - do - j=j+1 - if(j.gt.3) j=1 - nodempc(2,index)=j - index=nodempc(3,index) - if(nodempc(1,index).eq.nk) exit - enddo -! -! looking for the maximum tangent to decide which DOF should be -! taken to be the dependent one -! - index=ipompc(nmpc) - if(dabs(coefmpc(index)).lt.1.d-5) then -! -! changing the DOF of the dependent degree of freedom -! - amax=dabs(coefmpc(index)) - imax=1 - a(1)=coefmpc(index) - do i=2,3 - index=nodempc(3,index) - a(i)=coefmpc(index) - if(dabs(a(i)).gt.amax) then - amax=dabs(a(i)) - imax=i - endif - enddo -! - index=ipompc(nmpc) - nodempc(2,index)=imax - a1=a(1) - coefmpc(index)=a(imax) - do i=2,3 - index=nodempc(3,index) - if(i.eq.imax) then - nodempc(2,index)=1 - coefmpc(index)=a1 - else - nodempc(2,index)=i - endif - enddo -! -! updating ikmpc and ilmpc -! - index=ipompc(nmpc) - idofrem=8*(nodempc(1,index)-1)+1 - idofins=8*(nodempc(1,index)-1)+imax - call changedepterm(ikmpc,ilmpc,nmpc,nmpc,idofrem,idofins) - endif - elseif(labmpc(nmpc)(1:4).eq.'DIST') then - iperturb(2)=1 - if(iperturb(1).eq.0) iperturb(1)=2 - elseif(labmpc(nmpc)(1:3).eq.'GAP') then - iperturb(2)=1 - if(iperturb(1).eq.0) iperturb(1)=2 - elseif(labmpc(nmpc)(1:4).eq.'USER') then - iperturb(2)=1 - if(iperturb(1).eq.0) iperturb(1)=2 - else - write(*,*) '*ERROR in usermpc: mpc of type',labmpc(nmpc) - write(*,*) ' is unknown' - stop - endif - endif -! - return - end - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/utemp.f calculix-ccx-2.3/ccx_2.1/src/utemp.f --- calculix-ccx-2.1/ccx_2.1/src/utemp.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/utemp.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine utemp(temp,msecpt,kstep,kinc,time,node,coords,vold, - & mi) -! -! user subroutine utemp -! -! -! INPUT: -! -! msecpt number of temperature values (for volume elements:1) -! kstep step number -! kinc increment number -! time(1) current step time -! time(2) current total time -! node node number -! coords(1..3) global coordinates of the node -! vold(0..4,1..nk) solution field in all nodes -! 0: temperature -! 1: displacement in global x-direction -! 2: displacement in global y-direction -! 3: displacement in global z-direction -! 4: static pressure -! mi(1) max # of integration points per element (max -! over all elements) -! mi(2) max degree of freedomm per node (max over all -! nodes) in fields like v(0:mi(2))... -! -! OUTPUT: -! -! temp(1..msecpt) temperature in the node -! - implicit none -! - integer msecpt,kstep,kinc,node,mi(2) - real*8 temp(msecpt),time(2),coords(3),vold(0:mi(2),*) -! - temp(1)=293.d0 -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/valuesatinf.f calculix-ccx-2.3/ccx_2.1/src/valuesatinf.f --- calculix-ccx-2.1/ccx_2.1/src/valuesatinf.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/valuesatinf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine valuesatinf(inpc,textpart,physcon, - & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) -! -! reading the input deck: *VALUES AT INFINITY -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16) -! - integer i,istep,istat,n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*), - & ipoinpc(0:*) -! - real*8 physcon(*) -! - if(istep.gt.0) then - write(*,*) '*ERROR in physicalconstants: *VALUES AT INFINITY' - write(*,*) ' should only be used before the first STEP' - stop - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - do i=1,5 - read(textpart(i),'(f20.0)',iostat=istat) physcon(3+i) - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/variables.txt calculix-ccx-2.3/ccx_2.1/src/variables.txt --- calculix-ccx-2.1/ccx_2.1/src/variables.txt 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/variables.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,547 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - This file describes the variables used in CalculiX and their meaning - -REARRANGEMENT OF THE ORDER IN THE INPUT DECK - - ifreeinp: next blank line in field inp - - ipoinp(1,i): index of the first column in field inp - containing information on a block of lines in - the input deck corresponding to fundamental key i; - a fundamental key is a key for which the order - in the input file matters - (the fundamental keys are listed in file keystart.f) - ipoinp(2,i): index of the last column in field inp - containing information on a block of lines in - the input deck corresopnding to fundamental key i; - - inp: a column i in field inp (i.e. inp(1..3,i)) - corresponds to a uninterupted block of lines - assigned to one and the same fundamental key - in the input deck. inp(1,i) is its first line - in the input deck, inp(2,i) its last line and - inp(3,i) the next column in inp corresponding - to the same fundamental key; it takes the value - 0 if none other exists. - -MATERIAL DESCRIPTION - - nmat: # materials - - matname(i): name of material i - - nelcon(1,i): # (hyper)elastic constants for material i - (negative kode for nonlinear elastic constants) - nelcon(2,i): # temperature data points for the elastic constants - of material i - elcon(0,j,i): temperature at (hyper)elastic temperature point j of - material i - elcon(k,j,i): (hyper)elastic constant k at elastic temperature point j - of material i - - nrhcon(i): # temperature data points for the density of - material i - rhcon(0,j,i): temperature at density temperature point j of - material i - rhcon(1,j,i): density at the density temperature point j of - material i - - nshcon(i): # temperature data points for the specific heat of - material i - shcon(0,j,i): temperature at specific heat temperature point j of - material i - shcon(1,j,i): specific heat at the specific heat temperature point j of - material i - - nalcon(1,i): # of expansion constants for material i - nalcon(2,i): # of temperature data points for the expansion - coefficients of material i - alcon(0,j,i): temperature at expansion temperature point j - of material i - alcon(k,j,i): expansion coefficient k at expansion temperature - point j of material i - - ncocon(1,i): # of conductivity constants for material i - ncocon(2,i): # of temperature data points for the conductivity - coefficients of material i - cocon(0,j,i): temperature at conductivity temperature point j - of material i - cocon(k,j,i): conductivity coefficient k at conductivity temperature - point j of material i - - orname(i): name of orientation i - orab(1..6,i): coordinates of points a and b defining the new - orientation - norien: # orientations - - isotropic hardening: - - nplicon(0,i): # temperature data points for the isotropic hardening - curve of material i - nplicon(j,i): # of stress - plastic strain data points at temperature - j for material i - plicon(0,j,i): temperature data point j of material i - plicon(2*k-1,j,i): stress corresponding to stress-plastic strain data - point - k at temperature data point j of material i - plicon(2*k,j,i): plastic strain corresponding to stress-plastic strain - data point k at temperature data point j of material i - - kinematic hardening: - - nplkcon(0,i): # temperature data points for the kinematic hardening - curve of material i - nplkcon(j,i): # of stress - plastic strain data points at - temperature j for material i - plkcon(0,j,i): temperature data point j of material i - plkcon(2*k-1,j,i): stress corresponding to stress-plastic strain data - point k at temperature data point j of material i - plkcon(2*k,j,i): plastic strain corresponding to stress-plastic strain - data point - k at temperature data point j of material i - - kode=-1: Arrudy-Boyce - -2: Mooney-Rivlin - -3: Neo-Hooke - -4: Ogden (N=1) - -5: Ogden (N=2) - -6: Ogden (N=3) - -7: Polynomial (N=1) - -8: Polynomial (N=2) - -9: Polynomial (N=3) - -10: Reduced Polynomial (N=1) - -11: Reduced Polynomial (N=2) - -12: Reduced Polynomial (N=3) - -13: Van der Waals (not implemented yet) - -14: Yeoh - -15: Hyperfoam (N=1) - -16: Hyperfoam (N=2) - -17: Hyperfoam (N=3) - -50: deformation plasticity - -51: incremental plasticity (no viscosity) - -52: viscoplasticity - < -100: user material routine with -kode-100 user - defined constants with keyword *USER MATERIAL - - -PROCEDURE DESCRIPTION - - iperturb: 0: linear - 1: second order theory - 2: nonlinear geometric - 3: nonlinear elastic material (and nonlinear geometric) - - nmethod: 1: static (linear or nonlinear) - 2: frequency(linear) - 3: buckling (linear) - 4: dynamic (linear or nonlinear) - -GEOMETRY DESCRIPTION - - nk: highest node number - co(i,j): coordinate i of node j - intr(1,j): transformation number applicable in node j - intr(2,j): a SPC in a node j in which a transformation - applies corresponds to a MPC. intr(2,j) contains - the number of a new node generated for the - inhomogeneous part of the MPC - - -TOPOLOGY DESCRIPTION - - ne: highest element number - mint_: max # of integration points per element (max over all - elements) - kon(i): field containing the connectivity lists of the - elements in successive order - - For element i: - - ipkon(i): (location in kon of the first node in the element - connectivity list of element i)-1 - lakon(i): element label - ielorien(i): orientation number - ielmat(i): material number - -SHELL (2-D) AND BEAM (1-D) VARIABLES (INCLUDING PLANE STRAIN, PLANE - STRESS AND AXISYMMETRIC ELEMENTS) - - iponor(2,i): two pointers for entry i of kon. The first - pointer points to the location in xnor preceding - the normals of entry i, the second points to the - location in knor of the newly generated - dependent nodes of entry i. - xnor(i): field containing the normals in nodes on the - elements they belong to - knor(i): field containing the extra nodes needed to - expand the shell and beam elements to volume - elements - thickn(2,i): thicknesses (one for shells, two for beams) in - node i - thicke(2,i): thicknesses (one for shells, two for beams) in - element nodes. The entries correspond to the - nodal entries in field kon - offset(2,i): offsets (one for shells, two for beams) in - element i - iponoel(i): pointer for node i into field inoel, which - stores the 1-D and 2-D elements belonging to the - node. - inoel(3,i): field containing an element number, a local node - number within this element and a pointer to - another entry (or zero if there is no - other). - inoelfree: next free field in inoel - rig(i): character*1 field indicating whether node i is a - rigid node ('R') or not (' '). In a rigid node - or knot all expansion nodes except the ones not - in the midface of plane stress, plane strain and - axisymmetric elements are connected with a rigid - body MPC - -AMPLITUDES - - nam: # amplitude definitions - - amta(1,j): time of (time,amplitude) pair j - amta(2,j): amplitude of (time,amplitude) pair j - namtot: total # of (time,amplitude) pairs - - For amplitude i: - - amname(i): name of the amplitude - namta(1,i): location of first (time,amplitude) pair in - field amta - namta(2,i): location of last (time,amplitude) pair in - field amta - -TRANSFORMS - - ntrans # transform definitions - trab(1..6,i) coordinates of two points defining the transform - trab(7,i) =1 for rectangular transformations - =2 for cylindrical transformations - -SINGLE POINT CONSTRAINTS - - nboun # SPC's - - For SPC (single point constraint) i: - - nodeboun(i): SPC node - ndirboun(i): SPC direction - typeboun(i): SPC type (SPCs can contain the nonhomogeneous - part of MPCs): - B=prescribed boundary condition - M=midplane - P=planempc - R=rigidbody - S=straigthmpc - U=usermpc - xboun(i): magnitude of constraint at end of a step - xbounold(i): magnitude of constraint at beginning of a step - xbounact(i): magnitude of constraint at the end of the present - increment - xbounini(i): magnitude of constraint at the start of the - present increment - iamboun(i): amplitude number - ikboun(i): ordered array of the DOFs corresponding to the - SPC's (DOF=3*(nodeboun(i)-1)+ndirboun(i)) - ilboun(i): original SPC number for ikboun(i) - -MULTIPLE POINT CONSTRAINTS - - ipompc(i): starting location in nodempc and coefmpc of MPC i - - nodempc(1,ipompc(i)),nodempc(1,nodempc(3,ipompc(i))), - nodempc(1,nodempc(3,nodempc(3,nodempc(3,ipompc(i)))),... - until nodempc(3,nodempc(3,......))))))=0: - nodes belonging to MPC i - - nodempc(2,ipompc(i)),nodempc(2,nodempc(3,ipompc(i))), - nodempc(2,nodempc(3,nodempc(3,nodempc(3,ipompc(i)))),... - until nodempc(3,nodempc(3,......))))))=0: - directions belonging to MPC i - - xbounmpc(ipompc(i)),xbounmpc(nodempc(3,ipompc(i))), - xbounmpc(nodempc(3,nodempc(3,nodempc(3,ipompc(i)))),... - until nodempc(3,nodempc(3,......))))))=0: - coefficients belonging to MPC i - ikmpc (i): ordered array of the dependent DOFs - corresponding to the MPC's - DOF=3*(nodempc(1,ipompc(i))-1)+nodempc(2,ipompc(i)) - ilmpc (i): original SPC number for ikmpc(i) - - icascade: 0: MPC's did not change since the last iteration - 1: MPC's changed since last iteration: - dependency check in cascade.c necessary - 2: at least one nonlinear MPC had DOFs in common - with a linear MPC or another nonlinear MPC. - dependency check is necessary in each iteration - -POINT LOADS - - nforc: # of point loads - - For point load i: - - nodeforc(i): node in which force is applied - ndirforc(i): direction of force - xforc(i): magnitude of force at end of a step - xforcold(i): magnitude of force at start of a step - xforcact(i): actual magnitude - iamforc(i): amplitude number - ikforc(i): ordered array of the DOFs corresponding to the - point loads (DOF=3*(nodeboun(i)-1)+ndirboun(i)) - ilforc(i): original SPC number for ikforc(i) - -DISTRIBUTED LOADS - - nload: # of facial distributed loads - - For distributed load i: - - nelemload(1,i): element to which distributed load is applied - nelemload(2,i): node for the environment temperature (only for - heat transfer analyses) - sideload(i): load label; indicated element side to which load - is applied - xload(1,i): magnitude of load at end of a step or, for heat - transfer analyses, the convection (*FILM) or the - radiation coefficient (*RADIATE) - xload(2,i): the environment temperature (only for heat - transfer analyses - xloadold(1..2,i):magnitude of load at start of a step - xloadact(1..2,i):actual magnitude of load - iamload(1,i): amplitude number for xload(1,i) - iamload(2,i): amplitude number for xload(2,i) - -MASS FLOW RATE - - nflow: # of mass flow rates - - For mass flow rate i: - - nodeflow(1,i): node from which the mass flows - nodeflow(2,i): node to which the mass flows - xflow(i): magnitude of the mass flow rate - xflowold(i): magnitude of the mass flow rate at start of a step - xflowact(i): actual magnitude of the mass flow rate - iamflow(i): amplitude number for xflow(i) - -TEMPERATURE LOADS - - t0(i): initial temperature in node i at the start of the - calculation - t1(i): temperature at the end of a step in node i - t1old(i): temperature at the start of a step in node i - t1act(i): actual temperature in node i - iamt1(i): amplitude number - -CENTRIFUGAL LOADING - - om: square of the rotational speed at the end of a step - omold: square of the rotational speed at the start of a step - omact: actual value of the square of the rotational speed - iamom: amplitude number - p1(i): coordinate i of a first point on the rotation axis - p2(i): coordinate i of a second point on the rotation axis - -GRAVITY LOADING - - bodyf(i): coordinate i of the body force at the end of a step - bodyfold(i): coordinate i of the body force at the start of a step - bodyfact(i): coordinate i of the actual body force - iambodyf: amplitude number - -STRESS AND STRAIN FIELDS - - eei(i,j,k): in general: - Lagrange strain component i in integration point j - of element k (linear strain in linear elastic - calculations) - - for elements with *DEFORMATION PLASTICITY property: - Eulerian strain component i in integration point j - of element k (linear strain in linear elastic - calculations) - - eeiini(i,j,k): Lagrange strain component i in integration point - of element k at the start of an increment - - een(i,j): Lagrange strain component i in node j (mean over all - adjacent elements linear strain in linear elastic - calculations) - - stx(i,j,k): Cauchy or PK2 - stress component i in integration point j - of element k at the end of an iteration - (linear stress in linear elastic calculations) - - sti(i,j,k): PK2 stress component i in integration point j - of element k at the start of an iteration - (linear stress in linear elastic calculations) - - stiini(i,j,k): PK2 stress component i in integration point j - of element k at the start of an increment - - stn(i,j): Cauchy stress component i in node j (mean over all - adjacent elements; "linear" stress in linear elastic - calculations) - -THERMAL ANALYSIS - - ithermal: 0: no temperatures involved in the calculation - 1: stress analysis with given temperature field - 2: thermal analysis (no displacements) - 3: coupled thermal-mechanical analysis: - temperatures and displacements are solved for - simultaneously - - v(0,j): temperature of node j at the end of - an iteration (for ithermal > 1) - vold(0,j): temperature of node j at the start - of an iteration (for ithermal > 1) - vini(0,j): temperature of node j at the start - of an increment (for ithermal > 1) - - fn(0,j): actual temperature at node j (for ithermal > 1) - - qfx(i,j,k): heat flux component i in integration point j - of element k at the end of an iteration - - qfn(i,j): heat flux component i in node j (mean over all - adjacent elements) - - -DISPLACEMENTS AND SPATIAL/TIME DERIVATIVES - - v(i,j): displacement of node j in direction i at the end of - an iteration - vold(i,j): displacement of node j in direction i at the start - of an iteration - vini(i,j): displacement of node j in direction i at the start - of an increment - - ve(i,j): velocity of node j in direction i at the end of - an iteration - veold(i,j): velocity of node j in direction i at the start - of an iteration - veini(i,j): velocity of node j in direction i at the start - of an increment - - accold(i,j): acceleration of node j in direction i at the start - of an iteration - accini(i,j): acceleration of node j in direction i at the start - of an increment - - vkl(i,j): (i,j) component of the displacement gradient tensor - at the end of an iteration - - xkl(i,j): (i,j) component of the deformation gradient tensor - at the end of an iteration - - xikl(i,j): (i,j) component of the deformation gradient tensor - at the start of an increment - - ckl(i,j): (i,j) component of the inverse of the deformation - gradient tensor - -LINEAR EQUATION SYSTEM - - ad(i): element i on diagonal of stiffness matrix - au(i): element i in upper triangle of stiffness matrix - adb(i): element i on diagonal of mass matrix, or, for - buckling, of the incremental stiffness matrix - (only nonzero elements are stored) - aub(i): element i in upper triangle of mass matrix, or, for - buckling, of the incremental stiffness matrix - (only nonzero elements are stored) - neq[0]: # of mechanical equations - neq[1]: sum of mechanical and thermal equations - nzl: number of the column such that all columns with - a higher column number do not contain any - (projected) nonzero off-diagonal terms (<= neq[1]) - nzs: sum of projected nonzero off-diagonal terms - nactdof(i,j): actual degree of freedom (in the system of equations) - of DOF i of node j (0 if not active) - -INTERNAL AND EXTERNAL FORCES - - fext(i): external mechanical forces in DOF i (due to point - loads and distributed loads, including centrifugal and - gravity loads, but excluding temperature loading and - displacement loading) - - fextini(i): external mechanical forces in DOF i (due to point - loads and distributed loads, including centrifugal and - gravity loads, but excluding temperature loading and - displacement loading) at the end of the last increment - - finc(i): external mechanical forces in DOF i augmented by - contributions due to temperature loading and prescribed - displacements; used in linear calculations only - - f(i): actual internal forces in DOF i due to: - actual displacements in the independent nodes; - prescribed displacements at the end of the increment - in the dependent nodes; - temperatures at the end of the increment in all nodes - - fini(i): internal forces in DOF i at the end of the last - increment - - b(i): right hand side of the equation system: difference - between fext and f in nonlinear calcultions; for linear - calculations, b=finc. - - fn(i,j): actual force at node j in direction i - -INCREMENT PARAMETERS - - tinc: user given increment size (can be modified by the - program if the parameter DIRECT is not activated) - tper: user given step size - - dtheta: normalized (by tper) increment size - theta: normalized (by tper) size of all previous increments (not - including the present increment) - reltime: theta+dtheta - - dtime: real time increment size - time: real time size of all previous increments INCLUDING - the present increment - -DIRECT INTEGRATION DYNAMICS - - alpha,bet,gam: parameter in the alpha-method of Hilber, Hughes and - Taylor - iexpl: =0: implicit dynamics - =1: explicit dynamics - -FREQUENCY CALCULATIONS - - mei(0) number of requested eigenvalues - mei(1) number of Lanczos vectors - mei(2) maximum number of iterations - fei(0) tolerance (accuracy) - fei(1) lower value of requested frequency range - fei(2) upper value of requested frequency range - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/viewfactors.f calculix-ccx-2.3/ccx_2.1/src/viewfactors.f --- calculix-ccx-2.1/ccx_2.1/src/viewfactors.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/viewfactors.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,98 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine viewfactors(textpart,iviewfile,istep,inpc, - & istat,n,key,iline,ipol,inl,ipoinp,inp,jobnamec,ipoinpc) -! -! reading the input deck: *VIEWFACTOR -! - implicit none -! - character*1 inpc(*) - character*132 textpart(16),jobnamec(*) -! - integer i,iviewfile,istep,n,istat,iline,ipol,inl,ipoinp(2,*), - & inp(3,*),key,j,k,l,ipoinpc(0:*) -! - if(istep.lt.1) then - write(*,*) '*ERROR in viscos: *VISCO can only be used' - write(*,*) ' within a STEP' - stop - endif -! - do i=2,n - if(textpart(i)(1:4).eq.'READ') then -c if(istep.ne.1) then -c write(*,*) '*ERROR in viewfactors: *VIEWFACTOR,READ can' -c write(*,*) ' only be used in the first step' -c stop -c endif - if(iviewfile.eq.0) then - iviewfile=-1 - else - iviewfile=-abs(iviewfile) - endif - elseif(textpart(i)(1:5).eq.'WRITE') then - if(iviewfile.eq.0) then - iviewfile=2 - else - iviewfile=2*iviewfile/abs(iviewfile) - endif - elseif(textpart(i)(1:6).eq.'INPUT=') then - jobnamec(2)(1:126)=textpart(i)(7:132) - jobnamec(2)(127:132)=' ' - loop1: do j=1,126 - if(jobnamec(2)(j:j).eq.'"') then - do k=j+1,126 - if(jobnamec(2)(k:k).eq.'"') then - do l=k-1,126 - jobnamec(2)(l:l)=' ' - exit loop1 - enddo - endif - jobnamec(2)(k-1:k-1)=jobnamec(2)(k:k) - enddo - jobnamec(2)(126:126)=' ' - endif - enddo loop1 - elseif(textpart(i)(1:7).eq.'OUTPUT=') then - jobnamec(3)(1:125)=textpart(i)(8:132) - jobnamec(3)(126:132)=' ' - loop2: do j=1,125 - if(jobnamec(3)(j:j).eq.'"') then - do k=j+1,125 - if(jobnamec(3)(k:k).eq.'"') then - do l=k-1,125 - jobnamec(3)(l:l)=' ' - exit loop2 - enddo - endif - jobnamec(3)(k-1:k-1)=jobnamec(3)(k:k) - enddo - jobnamec(3)(125:125)=' ' - endif - enddo loop2 - endif - enddo -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/viscos.f calculix-ccx-2.3/ccx_2.1/src/viscos.f --- calculix-ccx-2.1/ccx_2.1/src/viscos.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/viscos.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,158 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine viscos(inpc,textpart,nmethod,iperturb,isolver,istep, - & istat,n,tinc,tper,tmin,tmax,idrct,iline,ipol,inl,ipoinp, - & inp,ipoinpc) -! -! reading the input deck: *VISCO (provided for compatibility -! reasons with ABAQUS) -! -! isolver=0: SPOOLES -! 2: iterative solver with diagonal scaling -! 3: iterative solver with Cholesky preconditioning -! 4: sgi solver -! 5: TAUCS -! 7: pardiso -! - implicit none -! - character*1 inpc(*) - character*20 solver - character*132 textpart(16) -! - integer nmethod,iperturb,isolver,istep,istat,n,key,i,idrct, - & iline,ipol,inl,ipoinp(2,*),inp(3,*),ipoinpc(0:*) -! - real*8 tinc,tper,tmin,tmax -! - idrct=0 - tmin=0.d0 - tmax=0.d0 -! - if((iperturb.eq.1).and.(istep.gt.1)) then - write(*,*) '*ERROR in viscos: perturbation analysis is' - write(*,*) ' not provided in a *VISCO step. Perform' - write(*,*) ' a genuine nonlinear geometric calculation' - write(*,*) ' instead (parameter NLGEOM)' - stop - endif -! - if(istep.lt.1) then - write(*,*) '*ERROR in viscos: *VISCO can only be used' - write(*,*) ' within a STEP' - stop - endif -! -! default solver -! - if(isolver.eq.0) then - solver(1:7)='SPOOLES' - elseif(isolver.eq.2) then - solver(1:16)='ITERATIVESCALING' - elseif(isolver.eq.3) then - solver(1:17)='ITERATIVECHOLESKY' - elseif(isolver.eq.4) then - solver(1:3)='SGI' - elseif(isolver.eq.5) then - solver(1:5)='TAUCS' - elseif(isolver.eq.7) then - solver(1:7)='PARDISO' - endif -! - do i=2,n - if(textpart(i)(1:7).eq.'SOLVER=') then - read(textpart(i)(8:27),'(a20)') solver - elseif((textpart(i)(1:6).eq.'DIRECT').and. - & (textpart(i)(1:9).ne.'DIRECT=NO')) then - idrct=1 - endif - enddo -! - if(solver(1:7).eq.'SPOOLES') then - isolver=0 - elseif(solver(1:16).eq.'ITERATIVESCALING') then - isolver=2 - elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then - isolver=3 - elseif(solver(1:3).eq.'SGI') then - isolver=4 - elseif(solver(1:5).eq.'TAUCS') then - isolver=5 - elseif(solver(1:7).eq.'PARDISO') then - isolver=7 - else - write(*,*) '*WARNING in viscos: unknown solver;' - write(*,*) ' the default solver is used' - endif -! - nmethod=1 -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) - if((istat.lt.0).or.(key.eq.1)) then - if(iperturb.ge.2) then - write(*,*) '*WARNING in viscos: a nonlinear geometric analys - &is is requested' - write(*,*) ' but no time increment nor step is speci - &fied' - write(*,*) ' the defaults (1,1) are used' - tinc=1.d0 - tper=1.d0 - tmin=1.d-5 - tmax=1.d+30 - endif - return - endif -! - read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(3)(1:20),'(f20.0)',iostat=istat) tmin - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) - read(textpart(4)(1:20),'(f20.0)',iostat=istat) tmax - if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) -! - if(tinc.le.0.d0) then - write(*,*) '*ERROR in viscos: initial increment size is negativ - &e' - endif - if(tper.le.0.d0) then - write(*,*) '*ERROR in viscos: step size is negative' - endif - if(tinc.gt.tper) then - write(*,*) '*ERROR in viscos: initial increment size exceeds st - &ep size' - endif -! - if(idrct.ne.1) then - if(dabs(tmin).lt.1.d-10) then - tmin=min(tinc,1.d-5*tper) - endif - if(dabs(tmax).lt.1.d-10) then - tmax=1.d+30 - endif - endif -! - call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, - & ipoinp,inp,ipoinpc) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/vortex.f calculix-ccx-2.3/ccx_2.1/src/vortex.f --- calculix-ccx-2.1/ccx_2.1/src/vortex.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/vortex.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,606 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine vortex(node1,node2,nodem,nelem,lakon,kon,ipkon, - & nactdog,identity,ielprop,prop,iflag,v,xflow,f, - & nodef,idirf,df,cp,R,numf,set,mi) -! -! orifice element -! - implicit none -! - logical identity - character*8 lakon(*) - character*81 set(*) -! - integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, - & ielprop(*),nodef(4),idirf(4),index,iflag, - & inv,ipkon(*),kon(*),t_chang,nelemswirl,mi(2) -! - real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,r,cp, - & p1,p2,T1,T2,km1,pi, - & r2d,r1d,eta,U1, - & c1u,c2u, cinput, r1, r2, omega, K1, rpm,ciu,expon, - & Ui,Kr,cte1,cte2,qred_crit,A,xflow_oil -! - if (iflag.eq.0) then - identity=.true. -! - if(nactdog(2,node1).ne.0)then - identity=.false. - elseif(nactdog(2,node2).ne.0)then - identity=.false. - elseif(nactdog(1,nodem).ne.0)then - identity=.false. - endif -! - elseif (iflag.eq.1)then -! - kappa=(cp/(cp-R)) - pi=4.d0*datan(1.d0) - index=ielprop(nelem) - qred_crit=dsqrt(kappa/R)* - & (1+0.5d0*(kappa-1))**(-0.5*(kappa+1)/(kappa-1)) -! -! Because there is no explicit expression relating massflow -! with to pressure loss for vortices -! For FREE as well as for FORCED VORTICES -! initial mass flow is set to Qred_crit/2 = 0.02021518917 -! with consideration to flow direction -! - node1=kon(ipkon(nelem)+1) - node2=kon(ipkon(nelem)+3) - p1=v(2,node1) - p2=v(2,node2) - T1=v(0,node1) - T2=v(0,node2) -! -! abstract cross section - A=10E-6 -! - if(p1.gt.p2) then - xflow=0.5/dsqrt(T1)*A*P1*qred_crit - else - xflow=-0.5/dsqrt(T1)*A*P1*qred_crit - endif -! - elseif (iflag.eq.2)then -! - numf=4 - index=ielprop(nelem) - kappa=(cp/(cp-R)) - km1=kappa-1 - pi=4.d0*datan(1.d0) -! -! radius downstream - r2d=prop(index+1) -! -! radius upstream - r1d=prop(index+2) -! -! pressure correction factor - eta=prop(index+3) -! - p1=v(2,node1) - p2=v(2,node2) -! - xflow=v(1,nodem) -! - if(xflow.gt.0.d0) then - inv=1.d0 - p1=v(2,node1) - p2=v(2,node2) - T1=v(0,node1) - T2=v(0,node2) - R1=r1d - R2=r2d -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! - elseif(xflow.lt.0.d0) then - inv=-1.d0 - R1=r2d - R2=r1d - p1=v(2,node2) - p2=v(2,node1) - T1=v(0,node2) - T2=v(0,node1) - xflow=-v(1,nodem) -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 -! - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 -! - kappa=(cp/(cp-R)) -! -! FREE VORTEX -! - if(lakon(nelem)(4:5).eq.'FR')then -! -! rotation induced loss (correction factor) - K1= prop(index+4) -! -! tangential velocity of the disk at vortex entry - U1=prop(index+5) -! -! number of the element generating the upstream swirl - nelemswirl=int(prop(index+6)) -! -! rotation speed (revolution per minutes) - rpm=prop(index+7) -! -! Temperature change - t_chang=prop(index+8) -! - if(rpm.gt.0) then -! -! rotation speed is given (rpm) if the swirl comes from a rotating part -! typically the blade of a coverplate -! - omega=pi/30d0*rpm - -! C_u is given by radius r1d (see definition of the flow direction) -! C_u related to radius r2d is a function of r1d -! - if(inv.gt.0) then - c1u=omega*r1 -! -! flow rotation at outlet - c2u=c1u*r1/r2 -! - elseif(inv.lt.0) then - c2u=omega*r2 -! - c1u=c2u*r2/r1 - endif -! - elseif(nelemswirl.gt.0) then - if(lakon(nelemswirl)(2:5).eq.'ORPN') then - cinput=prop(ielprop(nelemswirl)+5) - elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then - cinput=prop(ielprop(nelemswirl)+9) - elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then - cinput=prop(ielprop(nelemswirl)+7) - endif -! - cinput=U1+K1*(cinput-U1) -! - if(inv.gt.0) then - c1u=cinput - c2u=c1u*R1/R2 - elseif(inv.lt.0) then - c2u=cinput - c1u=c2u*R2/R1 - endif - endif -! -! storing the tengential velocity for later use (wirbel cascade) - if(inv.gt.0) then - prop(index+9)=c2u - elseif(inv.lt.0) then - prop(index+9)=c1u - endif -! -! inner rotation -! - if(R1.lt.R2) then - ciu=c1u - elseif(R1.ge.R2) then - ciu=c2u - endif -! - expon=kappa/km1 -! - if(R2.ge.R1) then -! - cte1=c1u**2/(2*Cp*T1) - cte2=1-(R1/R2)**2 - - f=P2/P1-1d0-eta*((1+cte1*cte2)**expon-1d0) -! - df(1)=-p2/p1**2 -! - df(2)=eta*expon*cte1/T1*cte2* - & (1+cte1*cte2)**(expon-1) -! - df(3)=0 -! - df(4)=1/p1 -! - elseif(R2.lt.R1) then -! - cte1=c2u**2/(2*Cp*T2) - cte2=1-(R2/R1)**2 -! - f=P1/P2-1d0-eta*((1+cte1*cte2)**expon-1d0) -! - df(1)=1/p2 -! - df(2)=eta*expon*cte1/T1*cte2* - & (1+cte1*cte2)**(expon-1) -! - df(3)=0 -! - df(4)=-p1/p2**2 -! - endif -! -! FORCED VORTEX -! - elseif(lakon(nelem)(4:5).eq.'FO') then -! -! core swirl ratio - Kr=prop(index+4) -! -! rotation speed (revolution per minutes) of the rotating part -! responsible for the swirl - rpm=prop(index+5) -! -! Temperature change - t_chang=prop(index+6) -! -! rotation speed - omega=pi/30*rpm -! - if(R2.ge.R1) then - Ui=omega*R1 - c1u=Ui*kr - c2u=c1u*R2/R1 - elseif(R2.lt.R1) then - Ui=omega*R2 - c2u=Ui*kr - c1u=c2u*R1/R2 - endif -! -! storing the tengential velocity for later use (wirbel cascade) - if(inv.gt.0) then - prop(index+7)=c2u - elseif(inv.lt.0) then - prop(index+7)=c1u - endif -! - expon=kappa/km1 -! - - if(((R2.ge.R1).and.(xflow.gt.0d0)) - & .or.((R2.lt.R1).and.(xflow.lt.0d0)))then -! - cte1=(c1u)**2/(2*Cp*T1) - cte2=(R2/R1)**2-1 -! - f=p2/p1-1-eta*((1+cte1*cte2)**expon-1) -! -! pressure node1 - df(1)=-p2/p1**2 -! -! temperature node1 - df(2)=eta*expon*cte1/T1*cte2*(1+cte1*cte2)**(expon-1) -! -! massflow nodem - df(3)=0 -! -! pressure node2 - df(4)=1/p1 -! - elseif(((R2.lt.R1).and.(xflow.gt.0d0)) - & .or.((R2.gt.R1).and.(xflow.lt.0d0)))then - cte1=(c2u)**2/(2*Cp*T2) - cte2=(R1/R2)**2-1 -! - f=p1/p2-1-eta*((1+cte1*cte2)**expon-1) -! -! pressure node1 - df(1)=1/p2 -! -! temperature node1 - df(2)=eta*expon*cte1/T2*cte2*(1+cte1*cte2)**(expon-1) -! -! massflow nodem - df(3)=0 -! -! pressure node2 - df(4)=-p1/p2**2 -! - endif - endif -! -! outpout -! - elseif(iflag.eq.3) then - - - index=ielprop(nelem) - kappa=(cp/(cp-R)) - km1=kappa-1 - pi=4.d0*datan(1.d0) -! -! radius downstream - r2d=prop(index+1) -! -! radius upstream - r1d=prop(index+2) -! -! pressure correction factor - eta=prop(index+3) -! - p1=v(2,node1) - p2=v(2,node2) -! - xflow=v(1,nodem) -! - if(xflow.gt.0.d0) then - inv=1.d0 - p1=v(2,node1) - p2=v(2,node2) - T1=v(0,node1) - T2=v(0,node2) - R1=r1d - R2=r2d -! - nodef(1)=node1 - nodef(2)=node1 - nodef(3)=nodem - nodef(4)=node2 -! - elseif(xflow.lt.0.d0) then - inv=-1.d0 - R1=r2d - R2=r1d - p1=v(2,node2) - p2=v(2,node1) - T1=v(0,node2) - T2=v(0,node1) - xflow=v(1,nodem) -! - nodef(1)=node2 - nodef(2)=node2 - nodef(3)=nodem - nodef(4)=node1 -! - endif -! - idirf(1)=2 - idirf(2)=0 - idirf(3)=1 - idirf(4)=2 -! - kappa=(cp/(cp-R)) -! -! FREE VORTEX -! - if(lakon(nelem)(4:5).eq.'FR')then -! -! rotation induced loss (correction factor) - K1= prop(index+4) -! -! tengential velocity of the disk at vortex entry - U1=prop(index+5) -! -! number of the element generating the upstream swirl - nelemswirl=int(prop(index+6)) -! -! rotation speed (revolution per minutes) - rpm=prop(index+7) -! -! Temperature change - t_chang=prop(index+8) -! - if(rpm.gt.0) then -! -! rotation speed is given (rpm) if the swirl comes from a rotating part -! typically the blade of a coverplate -! - omega=pi/30d0*rpm - -! C_u is given by radius r1d (see definition of the flow direction) -! C_u related to radius r2d is a function of r1d -! - if(inv.gt.0) then - c1u=omega*r1 -! -! flow rotation at outlet - c2u=c1u*r1/r2 -! - elseif(inv.lt.0) then - c2u=omega*r2 -! - c1u=c2u*r2/r1 - endif -! - elseif(nelemswirl.gt.0) then - if(lakon(nelemswirl)(2:5).eq.'ORPN') then - cinput=prop(ielprop(nelemswirl)+5) - elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then - cinput=prop(ielprop(nelemswirl)+9) - elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then - cinput=prop(ielprop(nelemswirl)+7) - endif -! - cinput=U1+K1*(cinput-U1) -! - if(inv.gt.0) then - c1u=cinput - c2u=c1u*R1/R2 - elseif(inv.lt.0) then - c2u=cinput - c1u=c2u*R2/R1 - endif - endif -! -! storing the tengential velocity for later use (wirbel cascade) - if(inv.gt.0) then - prop(index+9)=c2u - elseif(inv.lt.0) then - prop(index+9)=c1u - endif -! -! inner rotation -! - if(R1.lt.R2) then - ciu=c1u - elseif(R1.ge.R2) then - ciu=c2u - endif -! - expon=kappa/km1 -! - if(R2.ge.R1) then -! - cte1=c1u**2/(2*Cp*T1) - cte2=1-(R1/R2)**2 - - f=P2/P1-1d0-eta*((1+cte1*cte2)**expon-1d0) -! - df(1)=-p2/p1**2 -! - df(2)=eta*expon*cte1/T1*cte2* - & (1+cte1*cte2)**(expon-1) -! - df(3)=0 -! - df(4)=1/p1 -! - elseif(R2.lt.R1) then -! - cte1=c2u**2/(2*Cp*T2) - cte2=1-(R2/R1)**2 -! - f=P1/P2-1d0-eta*((1+cte1*cte2)**expon-1d0) -! - df(1)=1/p2 -! - df(2)=eta*expon*cte1/T1*cte2* - & (1+cte1*cte2)**(expon-1) -! - df(3)=0 -! - df(4)=-p1/p2**2 -! - endif -! -! FORCED VORTEX -! - elseif(lakon(nelem)(4:5).eq.'FO') then -! -! core swirl ratio - Kr=prop(index+4) -! -! rotation speed (revolution per minutes) of the rotating part -! responsible for the swirl - rpm=prop(index+5) -! -! Temperature change - t_chang=prop(index+6) -! -! rotation speed - omega=pi/30*rpm -! - if(R2.ge.R1) then - Ui=omega*R1 - c1u=Ui*kr - c2u=c1u*R2/R1 - elseif(R2.lt.R1) then - Ui=omega*R2 - c2u=Ui*kr - c1u=c2u*R1/R2 - endif -! -! storing the tengential velocity for later use (wirbel cascade) - if(inv.gt.0) then - prop(index+7)=c2u - elseif(inv.lt.0) then - prop(index+7)=c1u - endif -! - expon=kappa/km1 - endif -! - xflow_oil=0.d0 -! - write(1,*) '' - write(1,55) 'In line',int(nodem/1000),' from node',node1, - &' to node', node2,': air massflow rate=',xflow,'kg/s', - &', oil massflow rate=',xflow_oil,'kg/s' - 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.5,A,A,F9.5,A) - - if(inv.eq.1) then - write(1,56)' Inlet node ',node1,': Tt1= ',T1, - & 'K, Ts1= ',T1,'K, Pt1= ',P1/1E5, - & 'Bar' - write(1,*)' element V ',set(numf)(1:20) - write(1,57)' C1u= ',C1u,'m/s ,C2u= ',C2u,'m/s' - write(1,56)' Outlet node ',node2,': Tt2= ',T2, - & 'K, Ts2= ',T2,'K, Pt2= ',P2/1e5, - & 'Bar' -! - else if(inv.eq.-1) then - write(1,56)' Inlet node ',node2,': Tt1= ',T1, - & 'K, Ts1= ',T1,'K, Pt1= ',P1/1E5, - & 'Bar' - write(1,*)' element V ',set(numf)(1:20) - write(1,57)' C1u= ',C1u,'m/s ,C2u= ',C2u,'m/s' - write(1,56)' Outlet node ',node1,' Tt2= ', - & T2,'K, Ts2= ',T2,'K, Pt2= ',P2/1e5, - & 'Bar' - endif - 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A,f9.5) - 57 FORMAT(1X,A,f6.2,A,f6.2,A) - endif -! - return - end - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff -Nru calculix-ccx-2.1/ccx_2.1/src/wcoef.f calculix-ccx-2.3/ccx_2.1/src/wcoef.f --- calculix-ccx-2.1/ccx_2.1/src/wcoef.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/wcoef.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,146 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine wcoef(v,vo,al,um) -! -! computation of the coefficients of w in the derivation of the -! second order element stiffness matrix -! - implicit none -! - real*8 v(3,3,3,3),vo(3,3) -! - real*8 a2u,al,um,au,p1,p2,p3 -! - a2u=al+2.d0*um - au=al+um -! - p1=vo(1,1)+1.d0 - p2=vo(2,2)+1.d0 - p3=vo(3,3)+1.d0 -! - v(1,1,1,1)=a2u*p1*p1+um*(vo(1,2)**2+vo(1,3)**2) - v(2,1,1,1)=au*vo(1,2)*p1 - v(3,1,1,1)=au*vo(1,3)*p1 - v(1,2,1,1)=v(2,1,1,1) - v(2,2,1,1)=a2u*vo(1,2)**2+um*(p1*p1+vo(1,3)**2) - v(3,2,1,1)=au*vo(1,2)*vo(1,3) - v(1,3,1,1)=v(3,1,1,1) - v(2,3,1,1)=v(3,2,1,1) - v(3,3,1,1)=a2u*vo(1,3)**2+um*(p1*p1+vo(1,2)**2) -! - v(1,1,2,1)=al*vo(2,1)*p1+ - & um*(2.d0*vo(2,1)*p1+vo(1,2)*p2+vo(2,3)*vo(1,3)) - v(2,1,2,1)=al*p1*p2+um*vo(2,1)*vo(1,2) - v(3,1,2,1)=al*vo(2,3)*p1+um*vo(2,1)*vo(1,3) - v(1,2,2,1)=al*vo(2,1)*vo(1,2)+um*p1*p2 - v(2,2,2,1)=al*vo(1,2)*p2+ - & um*(vo(2,1)*p1+2.d0*vo(1,2)*p2+vo(2,3)*vo(1,3)) - v(3,2,2,1)=al*vo(2,3)*vo(1,2)+um*vo(1,3)*p2 - v(1,3,2,1)=al*vo(2,1)*vo(1,3)+um*vo(2,3)*p1 - v(2,3,2,1)=al*vo(1,3)*p2+um*vo(2,3)*vo(1,2) - v(3,3,2,1)=a2u*vo(2,3)*vo(1,3)+ - & um*(vo(2,1)*p1+vo(1,2)*p2) -! - v(1,1,3,1)=al*vo(3,1)*p1+ - & um*(vo(1,3)*p3+2.d0*vo(3,1)*p1+vo(3,2)*vo(1,2)) - v(2,1,3,1)=al*vo(3,2)*p1+um*vo(3,1)*vo(1,2) - v(3,1,3,1)=al*p1*p3+um*vo(3,1)*vo(1,3) - v(1,2,3,1)=al*vo(3,1)*vo(1,2)+um*vo(3,2)*p1 - v(2,2,3,1)=a2u*vo(3,2)*vo(1,2)+ - & um*(vo(1,3)*p3+vo(3,1)*p1) - v(3,2,3,1)=al*vo(1,2)*p3+um*vo(3,2)*vo(1,3) - v(1,3,3,1)=al*vo(3,1)*vo(1,3)+um*p1*p3 - v(2,3,3,1)=al*vo(3,2)*vo(1,3)+um*vo(1,2)*p3 - v(3,3,3,1)=al*vo(1,3)*p3+ - & um*(2.d0*vo(1,3)*p3+vo(3,1)*p1+vo(3,2)*vo(1,2)) -! - v(1,1,1,2)=al*vo(2,1)*p1+ - & um*(vo(1,2)*p2+2.d0*vo(2,1)*p1+vo(1,3)*vo(2,3)) - v(2,1,1,2)=al*vo(1,2)*vo(2,1)+um*p1*p2 - v(3,1,1,2)=al*vo(1,3)*vo(2,1)+um*vo(2,3)*p1 - v(1,2,1,2)=al*p1*p2+um*vo(1,2)*vo(2,1) - v(2,2,1,2)=al*vo(1,2)*p2+ - & um*(2.d0*vo(1,2)*p2+vo(2,1)*p1+vo(1,3)*vo(2,3)) - v(3,2,1,2)=al*vo(1,3)*p2+um*vo(1,2)*vo(2,3) - v(1,3,1,2)=al*vo(2,3)*p1+um*vo(1,3)*vo(2,1) - v(2,3,1,2)=al*vo(1,2)*vo(2,3)+um*vo(1,3)*p2 - v(3,3,1,2)=a2u*vo(1,3)*vo(2,3)+ - & um*(vo(1,2)*p2+vo(2,1)*p1) -! - v(1,1,2,2)=a2u*vo(2,1)**2+um*(p2*p2+vo(2,3)**2) - v(2,1,2,2)=au*vo(2,1)*p2 - v(3,1,2,2)=au*vo(2,3)*vo(2,1) - v(1,2,2,2)=v(2,1,2,2) - v(2,2,2,2)=a2u*p2*p2+um*(vo(2,1)**2+vo(2,3)**2) - v(3,2,2,2)=au*vo(2,3)*p2 - v(1,3,2,2)=v(3,1,2,2) - v(2,3,2,2)=v(3,2,2,2) - v(3,3,2,2)=a2u*vo(2,3)**2+um*(p2*p2+vo(2,1)**2) -! - v(1,1,3,2)=a2u*vo(3,1)*vo(2,1)+ - & um*(vo(3,2)*p2+vo(2,3)*p3) - v(2,1,3,2)=al*vo(3,2)*vo(2,1)+um*vo(3,1)*p2 - v(3,1,3,2)=al*vo(2,1)*p3+um*vo(3,1)*vo(2,3) - v(1,2,3,2)=al*vo(3,1)*p2+um*vo(3,2)*vo(2,1) - v(2,2,3,2)=al*vo(3,2)*p2+ - & um*(2.d0*vo(3,2)*p2+vo(2,3)*p3+vo(3,1)*vo(2,1)) - v(3,2,3,2)=al*p2*p3+um*vo(3,2)*vo(2,3) - v(1,3,3,2)=al*vo(3,1)*vo(2,3)+um*vo(2,1)*p3 - v(2,3,3,2)=al*vo(3,2)*vo(2,3)+um*p2*p3 - v(3,3,3,2)=al*vo(2,3)*p3+ - & um*(vo(3,2)*p2+2.d0*vo(2,3)*p3+vo(3,1)*vo(2,1)) -! - v(1,1,1,3)=al*vo(3,1)*p1+ - & um*(vo(1,3)*p3+2.d0*vo(3,1)*p1+vo(1,2)*vo(3,2)) - v(2,1,1,3)=al*vo(1,2)*vo(3,1)+um*vo(3,2)*p1 - v(3,1,1,3)=al*vo(1,3)*vo(3,1)+um*p1*p3 - v(1,2,1,3)=al*vo(3,2)*p1+um*vo(1,2)*vo(3,1) - v(2,2,1,3)=a2u*vo(1,2)*vo(3,2)+ - & um*(vo(1,3)*p3+vo(3,1)*p1) - v(3,2,1,3)=al*vo(1,3)*vo(3,2)+um*vo(1,2)*p3 - v(1,3,1,3)=al*p1*p3+um*vo(1,3)*vo(3,1) - v(2,3,1,3)=al*vo(1,2)*p3+um*vo(1,3)*vo(3,2) - v(3,3,1,3)=al*vo(1,3)*p3+ - & um*(2.d0*vo(1,3)*p3+vo(3,1)*p1+vo(1,2)*vo(3,2)) -! - v(1,1,2,3)=a2u*vo(2,1)*vo(3,1)+ - & um*(vo(2,3)*p3+vo(3,2)*p2) - v(2,1,2,3)=al*vo(3,1)*p2+um*vo(2,1)*vo(3,2) - v(3,1,2,3)=al*vo(2,3)*vo(3,1)+um*vo(2,1)*p3 - v(1,2,2,3)=al*vo(2,1)*vo(3,2)+um*vo(3,1)*p2 - v(2,2,2,3)=al*vo(3,2)*p2+ - & um*(vo(2,3)*p3+2.d0*vo(3,2)*p2+vo(2,1)*vo(3,1)) - v(3,2,2,3)=al*vo(2,3)*vo(3,2)+um*p2*p3 - v(1,3,2,3)=al*vo(2,1)*p3+um*vo(2,3)*vo(3,1) - v(2,3,2,3)=al*p2*p3+um*vo(2,3)*vo(3,2) - v(3,3,2,3)=al*vo(2,3)*p3+ - & um*(2.d0*vo(2,3)*p3+vo(3,2)*p2+vo(2,1)*vo(3,1)) -! - v(1,1,3,3)=a2u*vo(3,1)**2+um*(p3*p3+vo(3,2)**2) - v(2,1,3,3)=au*vo(3,2)*vo(3,1) - v(3,1,3,3)=au*vo(3,1)*p3 - v(1,2,3,3)=v(2,1,3,3) - v(2,2,3,3)=a2u*vo(3,2)**2+um*(p3*p3+vo(3,1)**2) - v(3,2,3,3)=au*vo(3,2)*p3 - v(1,3,3,3)=v(3,1,3,3) - v(2,3,3,3)=v(3,2,3,3) - v(3,3,3,3)=a2u*p3*p3+um*(vo(3,1)**2+vo(3,2)**2) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/writeboun.f calculix-ccx-2.3/ccx_2.1/src/writeboun.f --- calculix-ccx-2.1/ccx_2.1/src/writeboun.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writeboun.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,38 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writeboun(nodeboun,ndirboun,xboun,typeboun,nboun) -! -! writes an MPC to standard output (for debugging purposes) -! - implicit none -! - character*1 typeboun(*) - integer nodeboun(*),ndirboun(*),nboun,i - real*8 xboun(*) -! - write(*,*) - write(*,'(''SPC '')') - do i=1,nboun - write(*,'(i5,1x,i10,1x,i5,1x,e11.4,1x,a1)') i,nodeboun(i), - & ndirboun(i),xboun(i),typeboun(i) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writebv.f calculix-ccx-2.3/ccx_2.1/src/writebv.f --- calculix-ccx-2.1/ccx_2.1/src/writebv.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writebv.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writebv(x,nx) -! -! writes the buckling force factor to unit 3 -! - implicit none -! - integer j,nx - real*8 x(nx),pi -! - pi=4.d0*datan(1.d0) -! - write(5,*) - write(5,*) ' B U C K L I N G F A C T O R O U T P U T' - write(5,*) - write(5,*) 'MODE NO BUCKLING' - write(5,*) ' FACTOR' - write(5,*) - do j=1,nx - write(5,'(i7,2x,e14.7)') j,x(j) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writeevcs.f calculix-ccx-2.3/ccx_2.1/src/writeevcs.f --- calculix-ccx-2.1/ccx_2.1/src/writeevcs.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writeevcs.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,52 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writeevcs(x,nx,nm,xmin,xmax) -! -! writes the eigenvalues to unit 3 and replaces the -! eigenvalue by its square root = frequency (in rad/time) -! -! nm is the nodal diameter -! - implicit none -! - integer j,nx,nm - real*8 x(nx),pi,xmin,xmax -! - pi=4.d0*datan(1.d0) -! - write(5,*) - write(5,*) ' E I G E N V A L U E O U T P U T' - write(5,*) - write(5,*) ' NODAL MODE NO EIGENVALUE FREQUENCY' - write(5,*) 'DIAMETER (RAD/TIME) (CY - &CLES/TIME)' - write(5,*) - do j=1,nx - x(j)=dsqrt(x(j)) - if(xmin.gt.x(j)) cycle - if(xmax.gt.0.d0) then - if(xmax.lt.x(j)) exit - endif - write(5,'(i5,4x,i7,3(2x,e14.7))') nm,j,x(j)*x(j),x(j), - & x(j)/(2.d0*pi) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writeev.f calculix-ccx-2.3/ccx_2.1/src/writeev.f --- calculix-ccx-2.1/ccx_2.1/src/writeev.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writeev.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,51 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writeev(x,nx,xmin,xmax) -! -! writes the eigenvalues to unit 3 and replaces the -! eigenvalue by its square root = frequency (in rad/time) -! - implicit none -! - integer j,nx - real*8 x(nx),pi,xmin,xmax -! - pi=4.d0*datan(1.d0) -! - write(5,*) - write(5,*) ' E I G E N V A L U E O U T P U T' - write(5,*) - write(5,*) 'MODE NO EIGENVALUE FREQUENCY' - write(5,*) ' (RAD/TIME) (CYCLES/TIME - &)' - write(5,*) - do j=1,nx - if(x(j).lt.0.d0) x(j)=0.d0 - x(j)=dsqrt(x(j)) - if(xmin.gt.x(j)) cycle - if(xmax.gt.0.d0) then - if(xmax.lt.x(j)) exit - endif - write(5,'(i7,3(2x,e14.7))') j,x(j)*x(j),x(j), - & x(j)/(2.d0*pi) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writehe.f calculix-ccx-2.3/ccx_2.1/src/writehe.f --- calculix-ccx-2.1/ccx_2.1/src/writehe.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writehe.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,35 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writehe(j) -! -! writes a header for each eigenfrequency in the .dat file -! - implicit none -! - integer j -! - write(5,*) - write(5,100) j+1 - 100 format - & (' E I G E N V A L U E N U M B E R ',i5) - write(5,*) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writeim.f calculix-ccx-2.3/ccx_2.1/src/writeim.f --- calculix-ccx-2.1/ccx_2.1/src/writeim.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writeim.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writeim() -! -! writes a header for each eigenfrequency in the .dat file -! - implicit none -! - write(5,*) - write(5,100) - 100 format - & (' I M A G I N A R Y P A R T') - write(5,*) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writeinput.f calculix-ccx-2.3/ccx_2.1/src/writeinput.f --- calculix-ccx-2.1/ccx_2.1/src/writeinput.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writeinput.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,65 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writeinput(inpc,ipoinp,inp,nline,ninp,ipoinpc) -! - implicit none -! - integer nentries - parameter(nentries=14) -! - character*1 inpc(*) - character*20 nameref(nentries) -! - integer nline,i,j,ninp,ipoinp(2,nentries),inp(3,ninp),ipoinpc(0:*) -! - data nameref /'RESTART,READ','NODE','ELEMENT','NSET', - & 'ELSET','TRANSFORM','MATERIAL','ORIENTATION', - & 'SURFACE','TIE','SURFACEINTERACTION', - & 'INITIALCONDITIONS','AMPLITUDE','REST'/ -! - open(16,file='input.inpc',status='unknown',err=161) - do i=1,nline - write(16,'(1x,i6,1x,1320a1)') i, - & (inpc(j),j=ipoinpc(i-1)+1,ipoinpc(i)) - enddo - close(16) -! - open(16,file='input.ipoinp',status='unknown',err=162) - do i=1,nentries - write(16,'(1x,a20,1x,i6,1x,i6)') nameref(i),(ipoinp(j,i),j=1,2) - enddo - close(16) -! - open(16,file='input.inp',status='unknown',err=163) - do i=1,ninp - write(16,'(1x,i3,1x,i6,1x,i6,1x,i6)') i,(inp(j,i),j=1,3) - enddo - close(16) -! - return -! - 161 write(*,*) '*ERROR in writeinput: could not open file input.inpc' - stop -! - 162 write(*,*) - & '*ERROR in writeinput: could not open file input.ipoinp' - stop -! - 163 write(*,*) '*ERROR in writeinput: could not open file input.inp' - stop - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/writematrix.f calculix-ccx-2.3/ccx_2.1/src/writematrix.f --- calculix-ccx-2.1/ccx_2.1/src/writematrix.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writematrix.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,42 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writematrix(au,ad,irow,jq,neq,number) -! -! writes an MPC to standard output (for debugging purposes) -! - implicit none -! - integer irow(*),jq(*),neq,i,j,number - real*8 au(*),ad(*) -! - write(*,*) 'matrix number ',number -! - do i=1,neq - write(*,*) 'row ',i,' value ',ad(i) - enddo -! - do i=1,neq - do j=jq(i),jq(i+1)-1 - write(*,*) 'colomn ',i,' row ',irow(j),' value ',au(j) - enddo - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writempc.f calculix-ccx-2.3/ccx_2.1/src/writempc.f --- calculix-ccx-2.1/ccx_2.1/src/writempc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writempc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writempc(ipompc,nodempc,coefmpc,labmpc,mpc) -! -! writes an MPC to standard output (for debugging purposes) -! - implicit none -! - character*20 labmpc(*) - integer ipompc(*),nodempc(3,*),mpc,index,node,idir - real*8 coefmpc(*),coef -! - write(*,*) - write(*,'(''MPC '',i10,1x,a20)') mpc,labmpc(mpc) - index=ipompc(mpc) - do - node=nodempc(1,index) - idir=nodempc(2,index) - coef=coefmpc(index) - write(*,'(i10,1x,i5,1x,e11.4)') node,idir,coef -c write(*,'(i10,1x,i10,1x,i5,1x,e11.4)') index,node,idir,coef - index=nodempc(3,index) - if(index.eq.0) exit - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writepf.f calculix-ccx-2.3/ccx_2.1/src/writepf.f --- calculix-ccx-2.1/ccx_2.1/src/writepf.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writepf.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,44 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writepf(d,bjr,bji,freq,nev) -! -! writes the participation factors to unit 5 -! - implicit none -! - integer j,nev - real*8 d(*),bjr(*),bji(*),freq,pi -! - pi=4.d0*datan(1.d0) -! - write(5,*) - write(5,100) freq - 100 format('P A R T I C I P A T I O N F A C T O R S F O R', - &' F R E Q U E N C Y ',e11.4,' (CYCLES/TIME)') - write(5,*) - write(5,*) 'MODE NO FREQUENCY FACTOR' - write(5,*) ' (CYCLES/TIME) REAL IMAGINARY' - write(5,*) - do j=1,nev - write(5,'(i7,3(2x,e14.7))') j,d(j)/(2.d0*pi),bjr(j),bji(j) - enddo -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writere.f calculix-ccx-2.3/ccx_2.1/src/writere.f --- calculix-ccx-2.1/ccx_2.1/src/writere.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writere.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,33 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writere() -! -! writes a header for each eigenfrequency in the .dat file -! - implicit none -! - write(5,*) - write(5,100) - 100 format - & (' R E A L P A R T') - write(5,*) -! - return - end - diff -Nru calculix-ccx-2.1/ccx_2.1/src/writesummary.f calculix-ccx-2.3/ccx_2.1/src/writesummary.f --- calculix-ccx-2.1/ccx_2.1/src/writesummary.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/writesummary.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2007 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! - subroutine writesummary(istep,j,icutb,l,ttime,time,dtime) - implicit none -! -! writes increment statistics in the .sta file -! the close and open guarantees that the computer buffer is -! emptied each time a new line is written. That way the file -! is always up to data (also during the calculation) -! - integer istep,j,icutb,l -! integer iostat - real*8 ttime,time,dtime -! - write(8,100) istep,j,icutb+1,l,ttime,time,dtime -c call flush(8) - flush(8) -! -! for some unix systems flush has two arguments -! -! call flush(8,iostat) -! if(iostat.lt.0) then -! write(*,*) '*ERROR in writesummary: cannot flush buffer' -! stop -! endif -! - 100 format(1x,i5,1x,i10,2(1x,i5),3(1x,e13.6)) -! - return - end diff -Nru calculix-ccx-2.1/ccx_2.1/src/xlocal.f calculix-ccx-2.3/ccx_2.1/src/xlocal.f --- calculix-ccx-2.1/ccx_2.1/src/xlocal.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/xlocal.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,151 +0,0 @@ -! -! 3D local of the gauss points within the faces of -! the elements -! -! xlocal8r: C3D8R element -! xlocal8: C3D8 and C3D20R element -! xlocal20: C3D20 element -! xlocal4: C3D4 element -! xlocal10: C3D10 element -! xlocal6: C3D6 element -! xlocal15: C3D15 element -! - data xlocal8r / - & 0.000000000000000D+0, 0.000000000000000D+0,-0.100000000000000D+1 - &, 0.000000000000000D+0, 0.000000000000000D+0, 0.100000000000000D+1 - &, 0.000000000000000D+0,-0.100000000000000D+1, 0.000000000000000D+0 - &, 0.100000000000000D+1, 0.000000000000000D+0, 0.000000000000000D+0 - &, 0.000000000000000D+0, 0.100000000000000D+1, 0.000000000000000D+0 - &,-0.100000000000000D+1, 0.000000000000000D+0,0.000000000000000D+0/ -! - data xlocal8 / - &-0.577350269189626D+0, 0.577350269189626D+0,-0.100000000000000D+1 - &, 0.577350269189626D+0, 0.577350269189626D+0,-0.100000000000000D+1 - &,-0.577350269189626D+0,-0.577350269189626D+0,-0.100000000000000D+1 - &, 0.577350269189626D+0,-0.577350269189626D+0,-0.100000000000000D+1 - &,-0.577350269189626D+0,-0.577350269189626D+0, 0.100000000000000D+1 - &, 0.577350269189626D+0,-0.577350269189626D+0, 0.100000000000000D+1 - &,-0.577350269189626D+0, 0.577350269189626D+0, 0.100000000000000D+1 - &, 0.577350269189626D+0, 0.577350269189626D+0, 0.100000000000000D+1 - &,-0.577350269189626D+0,-0.100000000000000D+1,-0.577350269189626D+0 - &, 0.577350269189626D+0,-0.100000000000000D+1,-0.577350269189626D+0 - &,-0.577350269189626D+0,-0.100000000000000D+1, 0.577350269189626D+0 - &, 0.577350269189626D+0,-0.100000000000000D+1, 0.577350269189626D+0 - &, 0.100000000000000D+1,-0.577350269189626D+0,-0.577350269189626D+0 - &, 0.100000000000000D+1, 0.577350269189626D+0,-0.577350269189626D+0 - &, 0.100000000000000D+1,-0.577350269189626D+0, 0.577350269189626D+0 - &, 0.100000000000000D+1, 0.577350269189626D+0, 0.577350269189626D+0 - &, 0.577350269189626D+0, 0.100000000000000D+1,-0.577350269189626D+0 - &,-0.577350269189626D+0, 0.100000000000000D+1,-0.577350269189626D+0 - &, 0.577350269189626D+0, 0.100000000000000D+1, 0.577350269189626D+0 - &,-0.577350269189626D+0, 0.100000000000000D+1, 0.577350269189626D+0 - &,-0.100000000000000D+1, 0.577350269189626D+0,-0.577350269189626D+0 - &,-0.100000000000000D+1,-0.577350269189626D+0,-0.577350269189626D+0 - &,-0.100000000000000D+1, 0.577350269189626D+0, 0.577350269189626D+0 - &,-0.100000000000000D+1,-0.577350269189626D+0,0.577350269189626D+0/ -! - data xlocal20 / - &-0.774596669241483D+0, 0.774596669241483D+0,-0.100000000000000D+1 - &, 0.000000000000000D+0, 0.774596669241483D+0,-0.100000000000000D+1 - &, 0.774596669241483D+0, 0.774596669241483D+0,-0.100000000000000D+1 - &,-0.774596669241483D+0, 0.000000000000000D+0,-0.100000000000000D+1 - &, 0.000000000000000D+0, 0.000000000000000D+0,-0.100000000000000D+1 - &, 0.774596669241483D+0, 0.000000000000000D+0,-0.100000000000000D+1 - &,-0.774596669241483D+0,-0.774596669241483D+0,-0.100000000000000D+1 - &, 0.000000000000000D+0,-0.774596669241483D+0,-0.100000000000000D+1 - &, 0.774596669241483D+0,-0.774596669241483D+0,-0.100000000000000D+1 - &,-0.774596669241483D+0,-0.774596669241483D+0, 0.100000000000000D+1 - &, 0.000000000000000D+0,-0.774596669241483D+0, 0.100000000000000D+1 - &, 0.774596669241483D+0,-0.774596669241483D+0, 0.100000000000000D+1 - &,-0.774596669241483D+0, 0.000000000000000D+0, 0.100000000000000D+1 - &, 0.000000000000000D+0, 0.000000000000000D+0, 0.100000000000000D+1 - &, 0.774596669241483D+0, 0.000000000000000D+0, 0.100000000000000D+1 - &,-0.774596669241483D+0, 0.774596669241483D+0, 0.100000000000000D+1 - &, 0.000000000000000D+0, 0.774596669241483D+0, 0.100000000000000D+1 - &, 0.774596669241483D+0, 0.774596669241483D+0, 0.100000000000000D+1 - &,-0.774596669241483D+0,-0.100000000000000D+1,-0.774596669241483D+0 - &, 0.000000000000000D+0,-0.100000000000000D+1,-0.774596669241483D+0 - &, 0.774596669241483D+0,-0.100000000000000D+1,-0.774596669241483D+0 - &,-0.774596669241483D+0,-0.100000000000000D+1, 0.000000000000000D+0 - &, 0.000000000000000D+0,-0.100000000000000D+1, 0.000000000000000D+0 - &, 0.774596669241483D+0,-0.100000000000000D+1, 0.000000000000000D+0 - &,-0.774596669241483D+0,-0.100000000000000D+1, 0.774596669241483D+0 - &, 0.000000000000000D+0,-0.100000000000000D+1, 0.774596669241483D+0 - &, 0.774596669241483D+0,-0.100000000000000D+1, 0.774596669241483D+0 - &, 0.100000000000000D+1,-0.774596669241483D+0,-0.774596669241483D+0 - &, 0.100000000000000D+1, 0.000000000000000D+0,-0.774596669241483D+0 - &, 0.100000000000000D+1, 0.774596669241483D+0,-0.774596669241483D+0 - &, 0.100000000000000D+1,-0.774596669241483D+0, 0.000000000000000D+0 - &, 0.100000000000000D+1, 0.000000000000000D+0, 0.000000000000000D+0 - &, 0.100000000000000D+1, 0.774596669241483D+0, 0.000000000000000D+0 - &, 0.100000000000000D+1,-0.774596669241483D+0, 0.774596669241483D+0 - &, 0.100000000000000D+1, 0.000000000000000D+0, 0.774596669241483D+0 - &, 0.100000000000000D+1, 0.774596669241483D+0, 0.774596669241483D+0 - &, 0.774596669241483D+0, 0.100000000000000D+1,-0.774596669241483D+0 - &, 0.000000000000000D+0, 0.100000000000000D+1,-0.774596669241483D+0 - &,-0.774596669241483D+0, 0.100000000000000D+1,-0.774596669241483D+0 - &, 0.774596669241483D+0, 0.100000000000000D+1, 0.000000000000000D+0 - &, 0.000000000000000D+0, 0.100000000000000D+1, 0.000000000000000D+0 - &,-0.774596669241483D+0, 0.100000000000000D+1, 0.000000000000000D+0 - &, 0.774596669241483D+0, 0.100000000000000D+1, 0.774596669241483D+0 - &, 0.000000000000000D+0, 0.100000000000000D+1, 0.774596669241483D+0 - &,-0.774596669241483D+0, 0.100000000000000D+1, 0.774596669241483D+0 - &,-0.100000000000000D+1, 0.774596669241483D+0,-0.774596669241483D+0 - &,-0.100000000000000D+1, 0.000000000000000D+0,-0.774596669241483D+0 - &,-0.100000000000000D+1,-0.774596669241483D+0,-0.774596669241483D+0 - &,-0.100000000000000D+1, 0.774596669241483D+0, 0.000000000000000D+0 - &,-0.100000000000000D+1, 0.000000000000000D+0, 0.000000000000000D+0 - &,-0.100000000000000D+1,-0.774596669241483D+0, 0.000000000000000D+0 - &,-0.100000000000000D+1, 0.774596669241483D+0, 0.774596669241483D+0 - &,-0.100000000000000D+1, 0.000000000000000D+0, 0.774596669241483D+0 - &,-0.100000000000000D+1,-0.774596669241483D+0,0.774596669241483D+0/ -! - data xlocal4 / - & 0.333333333333333D+0, 0.333333333333333D+0, 0.000000000000000D+0 - &, 0.333333333333333D+0, 0.000000000000000D+0, 0.333333333333333D+0 - &, 0.333333333333334D+0, 0.333333333333333D+0, 0.333333333333333D+0 - &, 0.000000000000000D+0, 0.333333333333333D+0,0.333333333333333D+0/ -! - data xlocal10 / - & 0.166666666666667D+0, 0.166666666666667D+0, 0.000000000000000D+0 - &, 0.166666666666667D+0, 0.666666666666667D+0, 0.000000000000000D+0 - &, 0.666666666666667D+0, 0.166666666666667D+0, 0.000000000000000D+0 - &, 0.166666666666667D+0, 0.000000000000000D+0, 0.166666666666667D+0 - &, 0.666666666666667D+0, 0.000000000000000D+0, 0.166666666666667D+0 - &, 0.166666666666667D+0, 0.000000000000000D+0, 0.666666666666667D+0 - &, 0.666666666666666D+0, 0.166666666666667D+0, 0.166666666666667D+0 - &, 0.166666666666666D+0, 0.666666666666667D+0, 0.166666666666667D+0 - &, 0.166666666666666D+0, 0.166666666666667D+0, 0.666666666666667D+0 - &, 0.000000000000000D+0, 0.166666666666667D+0, 0.166666666666667D+0 - &, 0.000000000000000D+0, 0.166666666666667D+0, 0.666666666666667D+0 - &, 0.000000000000000D+0, 0.666666666666667D+0,0.166666666666667D+0/ -! - data xlocal6 / - & 0.333333333333333D+0, 0.333333333333333D+0,-0.100000000000000D+1 - &, 0.333333333333333D+0, 0.333333333333333D+0, 0.100000000000000D+1 - &, 0.500000000000000D+0, 0.000000000000000D+0, 0.000000000000000D+0 - &, 0.500000000000000D+0, 0.500000000000000D+0, 0.000000000000000D+0 - &, 0.000000000000000D+0, 0.500000000000000D+0,0.000000000000000D+0/ -! - data xlocal15 / - & 0.166666666666667D+0, 0.166666666666667D+0,-0.100000000000000D+1 - &, 0.166666666666667D+0, 0.666666666666667D+0,-0.100000000000000D+1 - &, 0.666666666666667D+0, 0.166666666666667D+0,-0.100000000000000D+1 - &, 0.,0.,0. - &, 0.166666666666667D+0, 0.166666666666667D+0, 0.100000000000000D+1 - &, 0.666666666666667D+0, 0.166666666666667D+0, 0.100000000000000D+1 - &, 0.166666666666667D+0, 0.666666666666667D+0, 0.100000000000000D+1 - &, 0.,0.,0. - &, 0.211324865405187D+0, 0.000000000000000D+0,-0.577350269189626D+0 - &, 0.788675134594813D+0, 0.000000000000000D+0,-0.577350269189626D+0 - &, 0.211324865405187D+0, 0.000000000000000D+0, 0.577350269189626D+0 - &, 0.788675134594813D+0, 0.000000000000000D+0, 0.577350269189626D+0 - &, 0.788675134594813D+0, 0.211324865405187D+0,-0.577350269189626D+0 - &, 0.211324865405187D+0, 0.788675134594813D+0,-0.577350269189626D+0 - &, 0.788675134594813D+0, 0.211324865405187D+0, 0.577350269189626D+0 - &, 0.211324865405187D+0, 0.788675134594813D+0, 0.577350269189626D+0 - &, 0.000000000000000D+0, 0.211324865405187D+0, 0.577350269189626D+0 - &, 0.000000000000000D+0, 0.788675134594813D+0, 0.577350269189626D+0 - &, 0.000000000000000D+0, 0.211324865405187D+0,-0.577350269189626D+0 - &, 0.000000000000000D+0,0.788675134594813D+0,-0.577350269189626D+0/ -! diff -Nru calculix-ccx-2.1/ccx_2.1/src/zeta_calc.f calculix-ccx-2.3/ccx_2.1/src/zeta_calc.f --- calculix-ccx-2.1/ccx_2.1/src/zeta_calc.f 2010-02-21 14:46:55.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.1/src/zeta_calc.f 1970-01-01 00:00:00.000000000 +0000 @@ -1,1379 +0,0 @@ -! -! CalculiX - A 3-dimensional finite element program -! Copyright (C) 1998-2005 Guido Dhondt -! -! This program is free software; you can redistribute it and/or -! modify it under the terms of the GNU General Public License as -! published by the Free Software Foundation(version 2); -! -! -! This program is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -! This subroutine enable to compuite the different zeta exponents for -! the different partial total head loss restrictors. The values of the -! 'zetas' have been found in the following published works -! -! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' -! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. -! ISBN 0-899116-284-4 -! -! D.S. MILLER 'INTERNAL FLOW SYSTEMS' -! 1978,vol.5 B.H.R.A FLUID ENGINEERING -! ISBN 0-900983-78-7 -! - subroutine zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, - & isothermal,kon,ipkon,R,kappa,v,mi) -! - implicit none -! - logical isothermal -! - character*8 lakon(*) -! - integer ielprop(*),nelem,iexp(2),i,j,ier,write1,iexp3(2), - & write2,nelem_ref,ipkon(*),kon(*),nelem0,nelem1,nelem2,node10, - & node20,nodem0,node11,node21,nodem1,node12,node22,nodem2, - & iexpbr1(2) /11,11/,icase,node0,node1,node2,mi(2) -! - real*8 zeta,prop(*),lzd,reynolds,ereo,fa2za1,zetap,zeta0, - & lambda,thau,a1,a2,dh,l,a2za1,ldumm,dhdumm,ks, - & form_fact,zeta01,zeta02,alpha,rad,delta,a0,b0,azb,rzdh, - & A,C,rei,lam,ai,b1,c1,b2,c2,zeta1,re_val,k,ldre, - & zetah,cd,cdu,km,Tt0,Ts0,Tt1,Ts1,Tt2,Ts2, - & rho0,rho1,rho2,V0,V1,v2,a0a1,a0a2,zetlin,lam10,lam20,pi, - & alpha1,alpha2,R,kappa,ang1s,ang2s,cang1s,cang2s, - & v(0:mi(2),*),V1V0,V2V0,z1_60,z1_90, - & z2_60,z2_90,afakt,V2V0L,kb,ks2,a2a0,Z90LIM11,Z90LIM51, - & lam11,lam12,lam21,lam22,W2W0,W1W0,dh0,dh2,hq,z2d390, - & z1p090,z90,z60,pt0,pt2,pt1,M0,M1,M2,W0W1,W0W2, - & xflow0,xflow1,xflow2,Qred_0, Qred_1, Qred_2,Qred_crit -! -! THICK EDGED ORIFICE IN STRAIGHT CONDUIT (L/DH > 0.015) -! I.E. IDEL' CHIK (SECTION III PAGE 140) -! -! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' -! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. -! ISBN 0-899116-284-4 -! -! ***** long orifice ***** -! -! DIAGRAMS 4-19 p 175 - Reynolds R:epsilon^-_oRe -! - real*8 XRE (14), YERE (14) - data XRE / 25.,40.,60.0,100.,200.,400.,1000.,2000.,4000., - & 10000.,20000.,100000.,200000.,1000000./ - data YERE/ 0.34,0.36,0.37,0.40,0.42,0.46,0.53,0.59, - & 0.64,0.74,0.81,0.94,0.95,0.98/ -! -! Diagram 4-19 p 175 - Reynolds | A1/A2 R: zeta_phi -! - real*8 zzeta (15,11) - data ((zzeta(i,j),i=1,15),j=1,11) - & /15.011 ,25.0,40.0,60.0,100.0,200.0,400.0,1000.0,2000.0, - & 4000.0,10000.0,20000.0,100000.0,200000.0,1000000.0, - & 0.00 ,1.94,1.38,1.14,0.89,0.69,0.64,0.39,0.30,0.22,0.15, - & 0.11,0.04,0.01,0.00, - & 0.20 ,1.78,1.36,1.05,0.85,0.67,0.57,0.36,0.26,0.20,0.13, - & 0.09,0.03,0.01,0.00, - & 0.30 ,1.57,1.16,0.88,0.75,0.57,0.43,0.30,0.22,0.17,0.10, - & 0.07,0.02,0.01,0.00, - & 0.40 ,1.35,0.99,0.79,0.57,0.40,0.28,0.19,0.14,0.10,0.06, - & 0.04,0.02,0.01,0.00, - & 0.50 ,1.10,0.75,0.55,0.34,0.19,0.12,0.07,0.05,0.03,0.02, - & 0.01,0.01,0.01,0.00, - & 0.60 ,0.85,0.56,0.30,0.19,0.10,0.06,0.03,0.02,0.01,0.01, - & 0.00,0.00,0.00,0.00, - & 0.70 ,0.58,0.37,0.23,0.11,0.06,0.03,0.02,0.01,0.00,0.00, - & 0.00,0.00,0.00,0.00, - & 0.80 ,0.40,0.24,0.13,0.06,0.03,0.02,0.01,0.00,0.00,0.00, - & 0.00,0.00,0.00,0.00, - & 0.90 ,0.20,0.13,0.08,0.03,0.01,0.00,0.00,0.00,0.00,0.00, - & 0.00,0.00,0.00,0.00, - & 0.95 ,0.03,0.03,0.02,0.00,0.00,0.00,0.00,0.00,0.00,0.00, - & 0.00,0.00,0.00,0.00/ -! -! Diagram 4-12 p 169 - l/Dh R: tau -! - real*8 XLZD (10), YTOR (10) - data XLZD / 0.0,0.2,0.4,0.6,0.8,1.0,1.2,1.6,2.0,2.4/ - data YTOR / 1.35,1.22,1.10,0.84,0.42,0.24,0.16,0.07,0.02,0.0/ - data IEXP / 10, 1/ -! -! ***** wall orifice ***** -! -! THICK-WALLED ORIFICE IN LARGE WALL (L/DH > 0.015) -! I.E. IDL'CHIK (page 174) -! -! DIAGRAM 4-18 A - l/Dh R: zeta_o -! - real*8 XLQD(12) - DATA XLQD / - & 0.,0.2,0.4,0.6,0.8,1.0,1.2,1.4,1.6,1.8,2.0,10.0/ - real*8 YZETA1(12) - DATA YZETA1 / - & 2.85,2.72,2.6,2.34,1.95,1.76,1.67,1.62,1.6,1.58,1.55,1.55/ -! -! DIAGRAM 4-19 p175 first line - Re (A1/A2=0) R: zeta_phi -! - real*8 XRE2(14) - DATA XRE2 / - & 25.,40.,60.,100.,200.,400.,1000.,2000.,4000.,10000., - & 20000.,50000.,100000.,1000000./ - real*8 YZETA2(14) - DATA YZETA2 / - & 1.94,1.38,1.14,.89,.69,.54,.39,.3,.22,.15,.11,.04,.01,0./ -! -! Diagram 4-18 p174 first case * (=multiplication) epsilon^-_oRe p 175 -! - real*8 YERE2(14) - DATA YERE2 / - & 1.,1.05,1.09,1.15,1.23,1.37,1.56,1.71,1.88,2.17,2.38,2.56, - & 2.72,2.85/ -! -! ***** expansion ***** -! -! SUDDEN EXPANSION OF A STREAM WITH UNIFORM VELOCITY DISTRIBUTION -! I.E. IDL'CHIK (page 160) -! -! DIAGRAM 4-1 - Re | A1/A2 R:zeta -! - real*8 ZZETA3(14,8) - DATA ZZETA3 / - & 14.008, 10.000,15.0,20.0,30.0,40.0,50.0,100.0,200.0,500.0, - & 1000.0,2000.0,3000.0,3500.0, - & .01 ,3.10,3.20,3.00,2.40,2.15,1.95,1.70,1.65,1.70,2.00, - & 1.60,1.00,1.00, - & 0.1 ,3.10,3.20,3.00,2.40,2.15,1.95,1.70,1.65,1.70,2.00, - & 1.60,1.00,0.81, - & 0.2 ,3.10,3.20,2.80,2.20,1.85,1.65,1.40,1.30,1.30,1.60, - & 1.25,0.70,0.64, - & 0.3 ,3.10,3.10,2.60,2.00,1.60,1.40,1.20,1.10,1.10,1.30, - & 0.95,0.60,0.50, - & 0.4 ,3.10,3.00,2.40,1.80,1.50,1.30,1.10,1.00,0.85,1.05, - & 0.80,0.40,0.36, - & 0.5 ,3.10,2.80,2.30,1.65,1.35,1.15,0.90,0.75,0.65,0.90, - & 0.65,0.30,0.25, - & 0.6 ,3.10,2.70,2.15,1.55,1.25,1.05,0.80,0.60,0.40,0.60, - & 0.50,0.20,0.16/ -! - DATA IEXP3 /0,0/ -! -! ***** contraction ***** -! -! SUDDEN CONTRACTION WITH & WITHOUT CONICAL BELLMOUTH ENTRY -! I.E. IDL'CHIK p 168 -! -! DIAGRAM 4-10 - Re | A1/A2 R: zeta -! - real*8 ZZETA41(14,7) - DATA ZZETA41 / - & 14.007 ,10.0,20.0,30.0,40.0,50.0,100.0,200.0,500.0,1000.0, - & 2000.0,4000.0,5000.0,10000.0, - &0.1 ,5.00,3.20,2.40,2.00,1.80,1.30,1.04,0.82,0.64,0.50, - & 0.80,0.75,0.50, - &0.2 ,5.00,3.10,2.30,1.84,1.62,1.20,0.95,0.70,0.50,0.40, - & 0.60,0.60,0.40, - &0.3 ,5.00,2.95,2.15,1.70,1.50,1.10,0.85,0.60,0.44,0.30, - & 0.55,0.55,0.35, - &0.4 ,5.00,2.80,2.00,1.60,1.40,1.00,0.78,0.50,0.35,0.25, - & 0.45,0.50,0.30, - &0.5 ,5.00,2.70,1.80,1.46,1.30,0.90,0.65,0.42,0.30,0.20, - & 0.40,0.42,0.25, - &0.6 ,5.00,2.60,1.70,1.35,1.20,0.80,0.56,0.35,0.24,0.15, - & 0.35,0.35,0.20/ -! -! Diagram 3-7 p128 - alpha | l/Dh R: zeta -! - real*8 ZZETA42(10,7) - DATA ZZETA42 / - & 10.007 ,0.,10.0,20.0,30.0,40.0,60.0,100.0,140.0,180.0, - & 0.025 ,0.50,0.47,0.45,0.43,0.41,0.40,0.42,0.45,0.50, - & 0.050 ,0.50,0.45,0.41,0.36,0.33,0.30,0.35,0.42,0.50, - & 0.075 ,0.50,0.42,0.35,0.30,0.26,0.23,0.30,0.40,0.50, - & 0.100 ,0.50,0.39,0.32,0.25,0.22,0.18,0.27,0.38,0.50, - & 0.150 ,0.50,0.37,0.27,0.20,0.16,0.15,0.25,0.37,0.50, - & 0.600 ,0.50,0.27,0.18,0.13,0.11,0.12,0.23,0.36,0.50/ -! -! ***** bends ***** -! -! SHARP ELBOW (R/DH = 0) AT 0 < DELTA < 180 -! I.E. IDL'CHIK page 294 -! DIAGRAM 6-5 - a0/b0 R: C1 -! - real*8 XAQB(12) - DATA XAQB / - & 0 .25,0.50,0.75,1.00,1.50,2.00,3.00,4.00,5.00,6.00,7.00,8.00/ -! - real*8 YC(12) - DATA YC / - & 1.10,1.07,1.04,1.00,0.95,0.90,0.83,0.78,0.75,0.72,0.71,0.70/ -! -! DIAGRAM 6-5 - delta R: A -! - real*8 XDELTA(10) - DATA XDELTA / - & 20.0,30.0,45.0,60.0,75.0,90.0,110.,130.,150.,180./ -! - real*8 YA(10) - DATA YA / - & 2.50,2.22,1.87,1.50,1.28,1.20,1.20,1.20,1.20,1.20/ -! -! SHARP BENDS 0.5 < R/DH < 1.5 AND 0 < DELTA < 180 -! I.E. IDL'CHIK page 289-290 -! DIAGRAM 6-1 (- delta from diagram 6-5) R: A1 -! - real*8 YA1(10) - DATA YA1 / - & 0.31,0.45,0.60,0.78,0.90,1.00,1.13,1.20,1.28,1.40/ -! -! DIAGRAM 6-1 - R0/D0 R: B1 -! - real*8 XRQDH(8) - DATA XRQDH / - & 0.50,0.60,0.70,0.80,0.90,1.00,1.25,1.50/ -! - real*8 YB1(8) - DATA YB1 / - & 1.18,0.77,0.51,0.37,0.28,0.21,0.19,0.17/ -! -! DIAGRAM 6-1 (- a0/b0 from diagram 6-5) R: C1 -! - real*8 YC1(12) - DATA YC1 / - & 1.30,1.17,1.09,1.00,0.90,0.85,0.85,0.90,095,0.98,1.00,1.00/ -! -! SMOOTH BENDS (R/DH > 1.5) AT 0 < DELTA < 180 -! I.E. IDL'CHIK -! -! DIAGRAM 6-1 - R0/D0 R: B1 (continuation of XRQDH) -! - real*8 XRZDH(14) - DATA XRZDH/ - & 1.00,2.00,4.00,6.00,8.00,10.0,15.0,20.0,25.0,30.0,35.0,40.0, - & 45.0,50.0/ -! - real*8 YB2(14) - DATA YB2 / - & 0.21,0.15,0.11,0.09,0.07,0.07,0.06,0.05,0.05,0.04,0.04,0.03, - & 0.03,0.03/ -! -! (- a0/b0 from Diagram 6-5) R: C2 -! - real*8 YC2(12) - DATA YC2 / - & 1.80,1.45,1.20,1.00,0.68,0.45,0.40,0.43,0.48,0.55,0.58,0.60/ -! -! D.S. MILLER 'INTERNAL FLOW SYSTEMS' -! 1978,vol.5 B.H.R.A FLUID ENGINEERING SERIES -! ISBN 0-900983-78-7 -! -! SMOOTH BENDS B.H.R.A HANDBOOK P.141 -! - REAL*8 ZZETAO(14,15) - DATA((ZZETAO(I,J),I=1,14),J=1,8) / - & 14.015,0.5,0.6,0.8,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10., - & 10.00, 0.030,0.025,0.021,0.016,0.022,0.030,0.034,0.036,0.040, - & 0.042,0.043,0.044,0.044, - & 15.00, 0.036,0.035,0.025,0.025,0.033,0.042,0.045,0.050,0.055, - & 0.055,0.058,0.060,0.063, - & 20.00, 0.056,0.046,0.034,0.034,0.045,0.054,0.056,0.062,0.066, - & 0.067,0.072,0.075,0.080, - & 30.00, 0.122,0.094,0.063,0.056,0.063,0.071,0.075,0.082,0.087, - & 0.089,0.097,0.101,0.110, - & 40.00, 0.220,0.160,0.100,0.085,0.080,0.086,0.092,0.100,0.106, - & 0.122,0.121,0.126,0.136, - & 50.00, 0.340,0.245,0.148,0.117,0.097,0.100,0.108,0.116,0.123, - & 0.133,0.144,0.150,0.159, - & 60.00, 0.480,0.350,0.196,0.150,0.115,0.116,0.122,0.131,0.140, - & 0.153,0.164,0.171,0.181/ - DATA((ZZETAO(I,J),I=1,14),J=9,15) / - & 70.00, 0.645,0.466,0.243,0.186,0.132,0.130,0.136,0.148,0.160, - & 0.172,0.185,0.191,0.200, - & 80.00, 0.827,0.600,0.288,0.220,0.147,0.142,0.150,0.166,0.180, - & 0.191,0.203,0.209,0.218, - & 90.00, 1.000,0.755,0.333,0.247,0.159,0.155,0.166,0.185,0.197, - & 0.209,0.220,0.227,0.236, - & 100.0, 1.125,0.863,0.375,0.264,0.167,0.166,0.183,0.202,0.214, - & 0.225,0.238,0.245,0.255, - & 120.0, 1.260,0.983,0.450,0.281,0.180,0.188,0.215,0.234,0.247, - & 0.260,0.273,0.282,0.291, - & 150.0, 1.335,1.060,0.536,0.289,0.189,0.214,0.251,0.272,0.297, - & 0.312,0.325,0.336,0.346, - & 180.0, 1.350,1.100,0.600,0.290,0.190,0.225,0.280,0.305,0.347, - & 0.364,0.378,0.390,0.400/ -! - REAL*8 KRE(22,4) - DATA KRE / - & 22.004,1.E+3,2.E+3,3.E+3,4.E+3,5.E+3,6.E+3,7.E+3,8.E+3,9.E+3, - & 1.E+4,2.E+4,3.E+4,4.E+4,6.E+4,8.E+4,1.E+5,2.E+5,3.E+5, - & 5.E+5,7.E+5,1.E+6, - & 1.0, 3.88,3.06,2.77,2.60,2.49,2.40,2.33,2.27,2.22,2.18, - & 1.86,1.69,1.57,1.41,1.30,1.22,5*1.00, - & 1.5, 3.88,3.06,2.77,2.60,2.49,2.40,2.33,2.27,2.22,2.18, - & 1.90,1.76,1.67,1.54,1.46,1.40,1.22,1.12,3*1.00, - & 2.0, 3.88,3.06,2.77,2.60,2.49,2.40,2.33,2.27,2.22,2.18, - & 1.93,1.80,1.71,1.60,1.53,1.47,1.32,1.23,1.13,1.06,1.00/ -! - integer iexp6(2) - DATA iexp6 /0,0/ -! -! Campbell, Slattery -! "Flow in the entrance of a tube" -! Journal of Basic Engineering, 1963 -! -! EXIT LOSS COEFFICIENT FOR LAMINAR FLOWS DEPENDING ON THE -! ACTUAL VELOCITY DISTRIBUTION AT THE EXIT -! - real*8 XDRE(12) - DATA XDRE / - & 0.000,0.001,0.0035,0.0065,0.010,0.0150,0.020, - & 0.025,0.035,0.045,0.056,0.065/ -! - real*8 ZETAEX(12) - DATA ZETAEX / - & 1.00,1.200,1.40,1.54,1.63,1.73,1.80,1.85,1.93, - & 1.97,2.00,2.00/ -! -! Branch Joint Genium -! Branching Flow Part IV - TEES -! Fluid Flow Division -! Section 404.2 page 4 December 1986 -! Genium Publishing (see www.genium.com) -! -! n.b: the values of this table have been scaled by a factor 64. -! - real*8 XANG(11),YANG(11) - data (XANG(i),YANG(i),i=1,11) - & /0.0d0,62.d0, - & 15.d0,62.d0, - & 30.d0,61.d0, - & 45.d0,61.d0, - & 60.d0,58.d0, - & 75.d0,52.d0, - & 90.d0,40.d0, - & 105.d0,36.d0, - & 120.d0,34.d0, - & 135.d0,33.d0, - & 150.d0,32.5d0/ -! -! Branch Joint Idelchik 1 -! Diagrams of resistance coefficients -! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' -! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. -! ISBN 0-899116-284-4 -! - real*8 TA2A0(12),TAFAKT(12) - data (TA2A0(i),TAFAKT(i),i=1,12) - & /0.d0 ,1.d0 , - & 0.16d0 ,1.d0 , - & 0.20d0 ,0.99d0, - & 0.25d0 ,0.95d0, - & 0.29d0 ,0.90d0, - & 0.31d0 ,0.85d0, - & 0.33d0 ,0.80d0, - & 0.35d0 ,0.78d0, - & 0.4d0 ,0.75d0, - & 0.6d0 ,0.70d0, - & 0.8d0 ,0.65d0, - & 1.d0 ,0.60d0/ -! -! Branch Joint Idelchik 2 -! Diagrams of resistance coefficients p348-351 section VII -! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' -! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. -! ISBN 0-899116-284-4 -! -! page 352 diagram 7-9 - alpha | Fs/Fc -! - real*8 KBTAB(6,7),KSTAB(6,6) - data ((KBTAB(i,j),j=1,7),i=1,6) - & /6.007d0 ,0.d0,15.d0,30.d0,45.d0,60.d0 ,90.d0 , - & 0.d0 ,0.d0, 0.d0, 0.d0, 0.d0, 0.d0 , 0.d0 , - & 0.1d0 ,0.d0, 0.d0, 0.d0, 0.d0, 0.d0 , 0.d0 , - & 0.2d0 ,0.d0, 0.d0, 0.d0, 0.d0, 0.d0 , 0.1d0 , - & 0.33d0,0.d0, 0.d0, 0.d0, 0.d0, 0.d0 , 0.2d0 , - & 0.5d0 ,0.d0, 0.d0, 0.d0, 0.d0, 0.1d0 , 0.25d0/ -! -! page 348-351 diagrams 7-5 to 7-8 - alpha | Fs/Fc -! - data ((KSTAB(i,j),j=1,6),i=1,6) - & /6.006d0 ,0.d0,15.d0 ,30.d0 ,45.d0 , 60.d0 , - & 0.d0 ,0.d0, 0.d0 , 0.d0 , 0.d0 , 0.d0 , - & 0.1d0 ,0.d0, 0.d0 , 0.d0 , 0.05d0, 0.d0 , - & 0.2d0 ,0.d0, 0.d0 , 0.d0 , 0.14d0, 0.d0 , - & 0.33d0,0.d0, 0.14d0, 0.17d0, 0.14d0, 0.1d0 , - & 0.5d0 ,0.d0, 0.4d0 , 0.4d0 , 0.3d0 , 0.25d0/ -! -! page 352 diagram 7-9 R: zeta_c,st -! - real*8 Z90TAB(6,13) - data ((Z90TAB(i,j),j=1,13),i=1,6)/ - &6.013,0. ,0.03,0.05,0.1 ,0.2 ,0.3 ,0.4 ,0.5 ,0.6 ,0.7 ,0.8 ,1.0 , - & .06, .02, .05, .08, .08, .07, .01,-.15,1.E9,1.E9,1.E9,1.E9,1.E9, - & .10, .04, .08, .10, .20, .26, .20, .05,-.13,1.E9,1.E9,1.E9,1.E9, - & .20, .08, .12, .18, .25, .34, .32, .26, .16, .02,-.14,1.E9,1.E9, - & .33, .45, .50, .52, .59, .66, .64, .62, .58, .44, .27, .08,-.34, - & .50,1.00,1.04,1.06,1.16,1.25,1.25,1.22,1.10, .88, .70, .45,0. / -! -! table to check the location of V2V0 in Z90TAB -! - real*8 Z90LIMX (5),Z90LIMY(5) - data Z90LIMX - & /0.06d0,0.1d0,0.2d0,0.33,0.5d0 / -! - data Z90LIMY - & / 0.1d0,0.1d0,0.3d0,0.5d0,0.7d0/ -! - pi=4.d0*datan(1.d0) -! - if ((lakon(nelem)(2:5).eq.'REUS').or. - & (lakon(nelem)(2:5).eq.'LPUS')) then -! -! user defined zeta -! - zeta=prop(ielprop(nelem)+4) -! - return -! - elseif((lakon(nelem)(2:5).eq.'REEN').or. - & (lakon(nelem)(2:5).eq.'LPEN')) then -! -! entrance -! - zeta=prop(ielprop(nelem)+4) -! - return -! - elseif((lakon(nelem)(2:7).eq.'RELOID').or. - & (lakon(nelem)(2:7).eq.'LPLOID')) then -! -! THICK EDGED ORIFICE IN STRAIGHT CONDUIT (L/DH > 0.015) -! I.E. IDEL'CHIK p175 -! -! Input parameters -! -! Inlet/outlet sections - a1=prop(ielprop(nelem)+1) - a2=prop(ielprop(nelem)+2) -! Hydraulic diameter - dh=prop(ielprop(nelem)+3) - if((dh.eq.0).and.(A1.le.A2)) then - dh=dsqrt(4d0*A1/Pi) - elseif((dh.eq.0).and.(A1.gt.A2)) then - dh=dsqrt(4d0*A2/Pi) - endif -! Length - l=prop(ielprop(nelem)+4) -! - lzd=l/dh - a2za1=min (a1/a2, 1.) -! - fa2za1=1.d0-a2za1 -! - write1= 0 - if ( lzd .gt. 2.4 ) write1= 1 -! - ldumm=1.D0 - dhdumm=-1.D0 - ks=0.d0 - form_fact=1.d0 -! - call friction_coefficient(ldumm,dhdumm,ks,reynolds, - & form_fact,lambda) -! - call onedint(XLZD,YTOR,10,lzd,thau,1,1,0,ier) - zeta0 = ((0.5+thau*dsqrt(fa2za1))+fa2za1) * fa2za1 -! - if(reynolds .gt. 1.E+05 ) then - zeta=zeta0 + lambda * dabs(lzd) - else - call onedint(XRE,YERE,14,reynolds,ereo,1,1,0,ier) -! - call twodint(zzeta,15,11,reynolds, - & a2za1,zetap,1,IEXP,IER) - zeta = zetap + ereo * zeta0 + lambda * dabs(lzd) - IF ( a2za1 .gt. 0.95 ) WRITE1=1 - endif -! - if(dabs(lzd) .le. 0.015 )then - write(*,*) '*WARNING in zeta_calc: L/DH outside valid' - write(*,*) ' range ie less than 0.015 !' - endif -! - if( write1 .eq. 1 ) then - write(*,*) - & 'WARNING in zeta_calc: geometry data outside valid range' - write(*,*) - & ' l/dh greater than 2.4- extrapolated value(s) !' - endif -! - elseif((lakon(nelem)(2:7).eq.'REWAOR').or. - & (lakon(nelem)(2:7).eq.'LPWAOR'))then -! -! THICK-WALLED ORIFICE IN LARGE WALL (L/DH > 0.015) -! I.E. IDL'CHIK page 174 -! -! Input parameters -! -! Inlet/outlet sections - a1=prop(ielprop(nelem)+1) - a2=prop(ielprop(nelem)+2) -! Hydraulic diameter - dh=prop(ielprop(nelem)+3) - if((dh.eq.0).and.(A1.le.A2)) then - dh=dsqrt(4d0*A1/Pi) - elseif((dh.eq.0).and.(A1.gt.A2)) then - dh=dsqrt(4d0*A2/Pi) - endif -! Length - l=prop(ielprop(nelem)+4) -! - lzd=l/dh - ldumm=1.D0 - dhdumm=-1.D0 - ks=0.d0 - form_fact=1.d0 -! - call friction_coefficient(ldumm,dhdumm,ks,reynolds, - & form_fact,lambda) - call onedint (XLQD,YZETA1,12,lzd,zeta01,1,1,0,IER) -! - write1=0 - if (lzd.gt.10.) write1=1 -! - if(reynolds.le.1.E+05) then -! - call onedint (XRE2,YZETA2,14,reynolds,zeta02,1,1,10,IER) - call onedint (XRE2,YERE2,14,reynolds,EREO,1,1,0,IER) -! - zeta=zeta02+0.342*ereo*zeta01+lambda*lzd -! - elseif(reynolds.gt.1.E+05) then - zeta=zeta01+lambda*lzd - endif - if(lzd.le.0.015) then - write(*,*) '*WARNING in zeta_calc' - write(*,*) - & ' l/dh outside valid range i.e. less than 0.015 !' - endif - if(write1.eq.1) then - write(*,*) '*WARNING in zeta_calc :extrapolated value(s)!' - endif -! - return -! - elseif((lakon(nelem)(2:7).eq.'REEL').or. - & (lakon(nelem)(2:7).eq.'LPEL')) then -! -! SUDDEN EXPANSION OF A STREAM WITH UNIFORM VELOCITY DISTRIBUTION -! I.E. IDL'CHIK page 160 -! -! Input parameters -! -! Inlet/outlet sections - a1=prop(ielprop(nelem)+1) - a2=prop(ielprop(nelem)+2) -c! Hydraulic diameter -c dh=prop(ielprop(nelem)+3) -c if((dh.eq.0).and.(A1.le.A2)) then -c dh=dsqrt(4d0*A1/Pi) -c elseif((dh.eq.0).and.(A1.gt.A2)) then -c dh=dsqrt(4d0*A2/Pi) -c endif -! - a2za1=a1/a2 - write1=0 -! - if (reynolds.LE.10.) then - zeta=26.0/reynolds - elseif (reynolds.gt.10.and.reynolds.le.3.5E+03) then - call twodint(zzeta3,14,11,reynolds,a2za1,zeta,1,IEXP3,IER) - if (a2za1.lt.0.01.or.a2za1.gt.0.6) write1=1 - else - zeta=(1.-a2za1)**2 - endif -! - if(write1 .eq. 1) then - write(*,*) '*WARNING in zeta_calc: extrapolated value(s)!' - endif - return -! - elseif((lakon(nelem)(2:7).eq.'RECO').or. - & (lakon(nelem)(2:7).eq.'LPCO'))then -! -! SUDDEN CONTRACTION WITH & WITHOUT CONICAL BELLMOUTH ENTRY -! I.E. IDL'CHIK p 168 -! -! Input parameters -! -! Inlet/outlet sections - a1=prop(ielprop(nelem)+1) - a2=prop(ielprop(nelem)+2) -! Hydraulic diameter - dh=prop(ielprop(nelem)+3) - if((dh.eq.0).and.(A1.le.A2)) then - dh=dsqrt(4d0*A1/Pi) - elseif((dh.eq.0).and.(A1.gt.A2)) then - dh=dsqrt(4d0*A2/Pi) - endif -! Length - l=prop(ielprop(nelem)+4) -! Angle - alpha=prop(ielprop(nelem)+5) -! - a2za1=a2/a1 - write1=0 - l=abs(l) - lzd=l/dh -! - if (l.eq.0.) then - if (reynolds.le.10.) then - zeta=27.0/reynolds - elseif(reynolds.gt.10.and.reynolds.le.1.E+04) then - call twodint(ZZETA41,14,11,reynolds,a2za1,zeta,1,IEXP,IER) - if (a2za1.le.0.1.or.a2za1.gt.0.6) write1=1 - elseif (reynolds.gt.1.E+04) then - zeta=0.5*(1.-a2za1) - endif - elseif(l.gt.0.) then - call twodint(ZZETA42,10,0,alpha,lzd,zeta0,1,IEXP,IER) - zeta=zeta0*(1.-a2za1) - if (lzd .lt. 0.025 .or. lzd .gt. 0.6) write1=1 - if (reynolds .le. 1.E+04) then - write(*,*) '*WARNING in zeta_calc: reynolds outside valid - & range i.e. < 10 000 !' - endif - endif -! - if ( write1 .eq. 1 ) then - WRITE(*,*) '*WARNING in zeta_calc: extrapolierte Werte!' - endif -! - return -! - elseif((lakon(nelem)(2:7).eq.'REBEID').or. - & (lakon(nelem)(2:7).eq.'LPBEID')) then -! -! -! SHARP ELBOW (R/DH = 0) AT 0 < DELTA < 180 -! I.E. IDL'CHIK page 294 -! -! SHARP BENDS 0.5 < R/DH < 1.5 AND 0 < DELTA < 180 -! I.E. IDL'CHIK page 289-290 -! -! SMOOTH BENDS (R/DH > 1.5) AT 0 < DELTA < 180 -! I.E. IDL'CHIK page 289-290 -! -! Input parameters -! -! Inlet/outlet sections - a1=prop(ielprop(nelem)+1) - a2=prop(ielprop(nelem)+2) -! Hydraulic diameter - dh=prop(ielprop(nelem)+3) - if((dh.eq.0).and.(A1.le.A2)) then - dh=dsqrt(4d0*A1/Pi) - elseif((dh.eq.0).and.(A1.gt.A2)) then - dh=dsqrt(4d0*A2/Pi) - endif -! radius - rad=prop(ielprop(nelem)+4) -! angle - delta=prop(ielprop(nelem)+5) -! heigth/width (square section) - a0=prop(ielprop(nelem)+6) - b0=prop(ielprop(nelem)+7) -! - write1=0 - write2=0 - rzdh=rad/dh - if(a0.eq.0.) azb=1.0 - if(a0.gt.0.) azb=a0/b0 -! - if (rzdh.le.0.5) then - call onedint(XAQB,YC,12,azb,C,1,1,0,IER) - zeta1=0.95*(SIN(delta*0.0087))**2+2.05*(SIN(delta*0.0087))**4 - call onedint(XDELTA,YA,10,delta,A,1,1,10,IER) - zeta=c*a*zeta1 - if (azb.le.0.25.or.azb.gt.8.0) write2=1 - if (reynolds.lt.4.E+04) then - if (reynolds.le.3.E+03) write1=1 - REI=MAX(2999.,reynolds) - ldumm=1.D0 - dhdumm=-1.D0 - ks=0.d0 - form_fact=1.d0 - call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact - & ,lambda) - re_val=4.E+04 - call friction_coefficient(ldumm,dhdumm,ks,re_val,form_fact - & , lam) - zeta=zeta*lambda/lam - endif -! - elseif (rzdh.gt.0.5.and.rzdh.lt.1.5) then - call onedint(XDELTA,YA1,10,delta,AI,1,1,10,IER) - call onedint(XRQDH,YB1,8,rzdh,B1,1,1,10,IER) - call onedint(XAQB,YC1,12,azb,C1,1,1,10,IER) - REI=MAX(2.E5,reynolds) - ldumm=1.D0 - dhdumm=-1.D0 - ks=0.d0 - form_fact=1.d0 - call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact - & , lambda) - zeta=AI*B1*C1+0.0175*delta*rzdh*lambda - if (azb.lt.0.25.or.azb.gt.8.0) write2=1 - if (reynolds.lt.2.E+05) then - IF (reynolds.lt.3.E+03) write1=1 - REI=MAX(2999.,reynolds) - call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact - & ,lambda) - re_val=2.E+05 - call friction_coefficient(ldumm,dhdumm,ks,re_val,form_fact - & , lam) - zeta=zeta*lambda/lam - endif -! - elseif (rzdh.ge.1.5.and.rzdh.lt.50.) then - call onedint(XDELTA,YA1,10,delta,AI,1,1,10,IER) - call onedint(XAQB,YC2,12,azb,C2,1,1,10,IER) - call onedint(XRZDH,YB2,8,rzdh,B2,1,1,0,IER) - REI=MAX(2.E5,reynolds) - ldumm=1.D0 - dhdumm=-1.D0 - ks=0.d0 - form_fact=1.d0 - call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact - & ,lambda) - zeta=AI*B2*C2+0.0175*delta*rzdh*lambda - if (azb.lt.0.25.or.azb.gt.8.0) write2=1 - if (reynolds.lt.2.E+05) then - if (reynolds.lt.3.E+03) write1=1 - REI=MAX(2999.,reynolds) - call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact - & ,lambda) - re_val=2.E+05 - call friction_coefficient(ldumm,dhdumm,ks,re_val,form_fact - & , lam) - zeta=zeta*lambda/lam - endif -! - elseif(rzdh.ge.50.) then - zeta=0.0175*rzdh*delta*lambda - if (reynolds .lt. 2.E+04) then - write (*,*)'Reynolds outside valid range i.e. < 20 000!' - endif - endif -! - if (write1 .eq. 1) then -! - write (*,*) 'Reynolds outside valid range i.e. < 3 000!' - endif -! - if(write2 .eq. 1) then - write(*,*) '*WARNING in zeta_calc: extrapolated value(s)!' - endif - return -! - elseif((lakon(nelem)(2:7).eq.'REBEMI').or. - & (lakon(nelem)(2:7).eq.'LPBEMI')) then -! -! SMOOTH BENDS B.H.R.A HANDBOOK -! -! Input parameters -! -! Inlet/outlet sections - a1=prop(ielprop(nelem)+1) - a2=prop(ielprop(nelem)+2) -! Hydraulic diameter - dh=prop(ielprop(nelem)+3) -! Radius: - rad=prop(ielprop(nelem)+4) -! angle delta: - delta=prop(ielprop(nelem)+5) -! - rzdh = Rad / DH -! - write1 = 0 - if ( delta .lt. 10. .or. delta .gt. 180. .or. - & rzdh .lt. 0.5 .or. rzdh. gt. 10. ) write1 = 1 -! - call twodint(ZZETAO,14,11,rzdh,delta,zeta0,1,IEXP6,IER) - call twodint(KRE, 22,11,reynolds,rzdh, k,1,IEXP6,IER) - zeta = zeta0 * k -! - if ( reynolds .lt. 1.E+3 .or. reynolds .gt. 1.E+6 ) then - write (*,*)'Reynolds outside valid range <1.E+3 or >1.0E+6' - endif -! - if ( write1 .eq. 1 ) then - write (*,*)': geometry data outside valid range ' - write (*,*)' - extrapolated value(s)!' - endif - RETURN -! - elseif((lakon(nelem)(2:7).eq.'REBEMA').or. - & (lakon(nelem)(2:7).eq.'LPBEMA')) then -! -! Own tables and formula to be included -! - Write(*,*) '*WARNING in zeta_calc: ZETA implicitly equal 1' - zeta=1.d0 - - RETURN -! - elseif((lakon(nelem)(2:7).eq.'REEX').or. - & (lakon(nelem)(2:7).eq.'LPEX')) then -! -! EXIT LOSS COEFFICIENT FOR LAMINAR FLOWS DEPENDING ON THE -! ACTUAL VELOCITY DISTRIBUTION AT THE EXIT -! -! Input parameters -! -! Inlet/outlet sections - a1=prop(ielprop(nelem)+1) - a2=prop(ielprop(nelem)+2) -! Hydraulic diameter - dh=prop(ielprop(nelem)+3) - if((dh.eq.0).and.(A1.le.A2)) then - dh=dsqrt(4d0*A1/Pi) - elseif((dh.eq.0).and.(A1.gt.A2)) then - dh=dsqrt(4d0*A2/Pi) - endif -! Reference element - nelem_ref=int(prop(ielprop(nelem)+4)) -! - if (lakon(nelem_ref)(2:5).ne.'GAPF') then - write(*,*) '*ERROR in zeta_calc :the reference element is no - &t of type GASPIPE' - stop - endif -! - if(lakon(nelem_ref)(2:6).eq.'GAPFI') then - isothermal=.true. - endif -! Length of the previous pipe element - l=abs(prop(ielprop(nelem_ref)+3)) -! - if (reynolds .le. 2300.) then -! (LAMINAR FLOW) - ldre=l/dh/reynolds - call onedint (XDRE,ZETAEX,12,ldre,zeta,1,1,0,IER) - elseif ((reynolds .gt. 2300) .and. (reynolds .lt. 3000)) then -! (TRANSITION LAMINAR-TURBULENT) - ldre=l/DH/2300. - call onedint (XDRE,ZETAEX,12,ldre,zetah,1,1,0,IER) - zeta=zetah-(zetah-1.)*((reynolds-2300.)/700.) - else -! (TURBULENT FLOW, RE .GT. 3000) - zeta=1. - endif -! - RETURN -! - elseif((lakon(nelem)(2:7).eq.'RELOLI').or. - & (lakon(nelem)(2:7).eq.'LPLOLI')) then -! -! 'METHOD OF LICHTAROWICZ' -! "Discharge coeffcients for incompressible non-cavitating -! flow through long orifices" -! A. Lichtarowicz, R.K duggins and E. Markland -! Journal Mechanical Engineering Science , vol 7, No. 2, 1965 -! -! TOTAL PRESSURE LOSS COEFFICIENT FOR LONG ORIFICES AND LOW REYNOLDS -! NUMBERS ( RE < 2.E04 ) -! -! Input parameters -! -! Inlet/outlet sections - a1=prop(ielprop(nelem)+1) - a2=prop(ielprop(nelem)+2) -! Hydraulic diameter - dh=prop(ielprop(nelem)+3) - if((dh.eq.0).and.(A1.le.A2)) then - dh=dsqrt(4d0*A1/Pi) - elseif((dh.eq.0).and.(A1.gt.A2)) then - dh=dsqrt(4d0*A2/Pi) - endif -! Length - l=prop(ielprop(nelem)+4) -! Isotermal -! - lzd=dabs(l)/dh -! - cdu=0.827-0.0085*lzd - km=a1/a2 - call cd_lichtarowicz(cd,cdu,reynolds,km,lzd) - if (reynolds .gt. 2.E04) then - write(*,*) - & '*WARNING in zeta_calc: range of application exceeded !' - endif -! - zeta=1./cd**2 -! - return -! -! Branch -! - elseif((lakon(nelem)(2:5).eq.'REBR').or. - & (lakon(nelem)(2:5).eq.'LPBR')) then - nelem0=prop(ielprop(nelem)+1) - nelem1=prop(ielprop(nelem)+2) - nelem2=prop(ielprop(nelem)+3) - A0=prop(ielprop(nelem)+4) - A1=prop(ielprop(nelem)+5) - A2=prop(ielprop(nelem)+6) - alpha1=prop(ielprop(nelem)+7) - alpha2=prop(ielprop(nelem)+8) -! -! node definition -! - node10=kon(ipkon(nelem0)+1) - node20=kon(ipkon(nelem0)+3) - nodem0=kon(ipkon(nelem0)+2) -! - node11=kon(ipkon(nelem1)+1) - node21=kon(ipkon(nelem1)+3) - nodem1=kon(ipkon(nelem1)+2) -! - node12=kon(ipkon(nelem2)+1) - node22=kon(ipkon(nelem2)+3) - nodem2=kon(ipkon(nelem2)+2) -! -! determining the nodes which are not in common -! - if(node10.eq.node11) then - node0=node10 - node1=node21 - if(node11.eq.node12) then - node2=node22 - elseif(node11.eq.node22) then - node2=node12 - endif - elseif(node10.eq.node21) then - node0=node10 - node1=node11 - if(node21.eq.node12) then - node0=node22 - elseif(node21.eq.node22) then - node2=node12 - endif - elseif(node20.eq.node11) then - node0=node20 - node1=node21 - if(node11.eq.node12) then - node2=node22 - elseif(node11.eq.node22) then - node2=node12 - endif - elseif(node20.eq.node21) then - node0=node20 - node1=node11 - if(node11.eq.node21) then - node2=node22 - elseif(node21.eq.node22) then - node2=node12 - endif - endif -! -! density -! - if(lakon(nelem)(2:3).eq.'RE') then -! -! for gases -! - qred_crit=dsqrt(kappa/R)* - & (1+0.5d0*(kappa-1))**(-0.5d0*(kappa+1)/(kappa-1)) -! - icase=0 -! - Tt0=v(0,node0) - xflow0=v(1,nodem0) - pt0=v(2,node0) -! - Qred_0=dabs(xflow0)*dsqrt(Tt0)/(A0*pt0) - if(Qred_0.gt.qred_crit) - & then - xflow0=qred_crit*(A0*pt0)/dsqrt(Tt0) - endif -! - call ts_calc(xflow0,Tt0,Pt0,kappa,r,a0,Ts0,icase) - M0=dsqrt(2/(kappa-1)*(Tt0/Ts0-1)) -! - rho0=pt0/(R*Tt0)*(Tt0/Ts0)**(-1/(kappa-1)) -! - Tt1=v(0,node1) - xflow1=v(1,nodem1) - pt1=v(2,node0) -! - Qred_1=dabs(xflow1)*dsqrt(Tt1)/(A1*pt1) - if(Qred_1.gt.qred_crit) - & then - xflow1=qred_crit*(A1*pt1)/dsqrt(Tt1) - endif -! - call ts_calc(xflow1,Tt1,Pt1,kappa,r,a1,Ts1,icase) - M1=dsqrt(2/(kappa-1)*(Tt1/Ts1-1)) -! - rho1=pt1/(R*Tt1)*(Tt1/Ts1)**(-1/(kappa-1)) -! - Tt2=v(0,node2) - xflow2=v(1,nodem2) - pt2=v(2,node0) -! - Qred_2=dabs(xflow2)*dsqrt(Tt2)/(A2*pt2) - if(Qred_2.gt.qred_crit) then - xflow2=qred_crit*(A2*pt2)/dsqrt(Tt2) - endif -! - call ts_calc(xflow2,Tt2,Pt2,kappa,r,a2,Ts2,icase) - M2=dsqrt(2/(kappa-1)*(Tt2/Ts2-1)) - rho2=pt2/(R*Tt2)*(Tt2/Ts2)**(-1/(kappa-1)) - else -! -! for liquids the density is supposed to be constant -! across the element -! - rho0=1.d0 - rho1=1.d0 - rho2=1.d0 - endif -! -! volumic flows (positive) -! - V0=dabs(v(1,nodem0)/rho0) - V1=dabs(v(1,nodem1)/rho1) - V2=dabs(v(1,nodem2)/rho2) -! - V1V0=V1/V0 - V2V0=V2/V0 -! - a0a1=a0/a1 - a0a2=a0/a2 - a2a0=1/a0a2 -! - W0W1=1/(V1V0*a0a1) - W0W2=1/(V2V0*a0a2) -! -! Branch Joint Genium -! Branching Flow Part IV - TEES -! Fluid Flow Division -! Section 404.2 page 4 December 1986 -! Genium Publishing (see www.genium.com) -! - if((lakon(nelem)(2:7).eq.'REBRJG').or. - & (lakon(nelem)(2:7).eq.'LPBRJG')) then -! - ang1s=(1.41d0-0.00594*alpha1)*alpha1*pi/180 - ang2s=(1.41d0-0.00594*alpha2)*alpha2*pi/180 -! - cang1s=dcos(ang1s) - cang2s=dcos(ang2s) -! -! linear part -! - zetlin=2.d0*(V1V0**2*a0a1*cang1s+V2V0**2*a0a2*cang2s) -! - if(nelem.eq.nelem1) then - call onedint(XANG,YANG,11,alpha1,lam10,1,2,22,ier) - zeta=lam10/64*(V1V0*a0a1)**2-zetlin+1d0 - zeta=zeta*(W0W1)**2 -! - elseif(nelem.eq.nelem2) then - call onedint(XANG,YANG,11,alpha2,lam20,1,2,22,ier) - zeta=lam20/64*(V2V0*a0a2)**2-zetlin+1d0 - zeta=zeta*(W0W2)**2 - endif - return -! - elseif((lakon(nelem)(2:8).eq.'REBRJI1').or. - & (lakon(nelem)(2:8).eq.'LPBRJI1')) then -! -! Branch Joint Idelchik 1 -! Diagrams of resistance coefficients p260-p266 section VII -! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' -! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. -! ISBN 0-899116-284-4 -! - a0a2=a0/a2 - if(alpha2.lt.60.) then - if(nelem.eq.nelem1) then - zeta=1.d0-V1V0**2 - & -2.d0*a0a2*V2V0**2*dcos(alpha2*pi/180) - zeta=zeta*(W0W1)**2 - elseif(nelem.eq.nelem2) then - zeta=1.d0-V1V0**2 - & -2.d0*a0a2*V2V0**2*dcos(alpha2*pi/180) - & +(a0a2*V2V0)**2-V1V0**2 - zeta=zeta*(W0W2)**2 - endif -! - elseif(alpha2.eq.60) then -! -! proceeding as for alpha2<60 with cos(alpha2)=0.5 -! - if(nelem.eq.nelem1) then - zeta=1.d0-V1V0**2-a0a2*V2V0**2 - zeta=zeta*(W0W1)**2 - elseif(nelem.eq.nelem2) then - zeta=1.d0-V1V0**2-a0a2*V2V0**2 - & +(a0a2*V2V0)**2-V1V0**2 - zeta=zeta*(W0W2)**2 - endif -! - elseif(alpha2.lt.90) then -! -! linear interpolation between alpha2=60 and alpha2=90 -! - z1_60=1.d0-V1V0**2-a0a2*V2V0**2 - z1_90=(1.55d0-V2V0)*V2V0 - if(nelem.eq.nelem1) then - zeta=z1_60+(z1_90-z1_60)*(alpha2-60.d0)/30 - zeta=zeta*(W0W1)**2 - elseif(nelem.eq.nelem2) then - z2_60=z1_60+(a0a2*V2V0)**2-V1V0**2 - call onedint(TA2A0,TAFAKT,12,a2a0,afakt, - & 1,1,11,ier) - z2_90=afakt*(1.d0+(a0a2*V2V0)**2-2.d0*V1V0**2) - zeta=z2_60+(z2_90-z2_60)*(alpha2-60.d0)/30d0 - zeta=zeta*(W0W2)**2 - endif -! - elseif (alpha2.eq.90) then - if(nelem.eq.nelem1) then - zeta=(1.55d0-V2V0)*V2V0 - zeta=zeta*(W0W1)**2 - elseif(nelem.eq.nelem2) then - call onedint(TA2A0,TAFAKT,12,a2a0,afakt, - & 1,1,11,ier) - zeta=afakt*(1.d0+(a0a2*V2V0)**2-2.d0*V1V0**2) - zeta=zeta*(W0W2)**2 - endif - endif - return -! - elseif((lakon(nelem)(2:8).eq.'REBRJI2').or. - & (lakon(nelem)(2:8).eq.'LPBRJI2')) then -! -! Branch Joint Idelchik 2 -! Diagrams of resistance coefficients page 348-352 -! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' -! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. -! ISBN 0-899116-284-4 page 348-352 -! - if(alpha2.lt.60) then - if(nelem.eq.nelem1) then - zeta=1+a0a1*V1V0**2*(a0a1-2.) - & -2d0*a0a2*V2V0**2*dcos(alpha2*pi/180) -! correction term - call twodint(KSTAB,6,11,a2a0,alpha2,ks2,1 - & ,iexpbr1,ier) - zeta=zeta+ks2 - zeta=zeta*(W0W1)**2 - elseif(nelem.eq.nelem2) then - zeta=1+a0a1*V1V0**2*(a0a1-2.) - & -2d0*a0a2*V2V0**2*dcos(alpha2*pi/180) - & -(a0a1*V1V0)**2+(a0a2*V2V0)**2 - call twodint(KBTAB,6,11,a2a0,alpha2,kb,1, - & iexpbr1,ier) - zeta=zeta+kb - zeta=zeta*(W0W2)**2 - endif -! - elseif(alpha2.eq.60) then -! as for alpha2 < 60 , with dcos(alpha2)=0.5 - if(nelem.eq.nelem1) then - zeta=1+a0a1*V1V0**2*(a0a1-2.)-a0a2*V2V0**2 - call twodint(KSTAB,6,11,a2a0,alpha2,ks2,1, - & iexpbr1,ier) - zeta=zeta+ks2 - zeta=zeta*(W0W1)**2 - elseif(nelem.eq.nelem2) then - zeta=1+a0a1*V1V0**2*(a0a1-2.)-a0a2*V2V0**2 - & -(a0a1*V1V0)**2+(a0a2*V2V0)**2 - call twodint(KBTAB,6,11,a2a0,alpha2,kb,1, - & iexpbr1,ier) - zeta=zeta+kb - zeta=zeta*(W0W2)**2 - endif -! - elseif(alpha2.lt.90) then -! linear interpolation between alpha2=60 and alpha2=90 - z1_60=1+a0a1*V1V0**2*(a0a1-2.)-a0a2*V2V0**2 -! correction term - call twodint(KSTAB,6,11,a2a0,alpha2,ks2,1, - & iexpbr1,ier) - z1_60=z1_60+ks2 - if(nelem.eq.nelem1) then - call twodint(Z90TAB,6,11,a2a0,V2V0,z1_90, - & 1,iexpbr1,ier) - zeta=z1_60+(z1_90-z1_60)*(alpha2-60)/30 - zeta=zeta*(W0W1)**2 - elseif(nelem.eq.nelem2) then - z2_60=z1_60-(a0a1*V1V0)**2+(a0a2*v2v0)**2 - call twodint(KBTAB,6,11,a2a0,alpha2,kb,1, - & iexpbr1,ier) - z2_60=z2_60+kb-ks2 - z2_90=1.+(a0a2*V2V0)**2-2*a0a1*V1V0**2+kb - zeta=z2_60+(z2_90-z2_60)*(alpha2-60)/30 - zeta=zeta*(W0W2)**2 - endif - elseif(alpha2.eq.90) then - if(nelem.eq.nelem2) then - call twodint(KBTAB,6,11,a2a0,alpha2,kb,1, - & iexpbr1,ier) - zeta=1.+(a0a2*V2V0)**2-2*a0a1*V1V0**2+kb - zeta=zeta*(W0W2)**2 - elseif(nelem.eq.nelem1) then -! table interpolation - call twodint(Z90TAB,6,11,a2a0,V2V0,zeta, - & 1,iexpbr1,ier) - zeta=zeta*(W0W1)**2 -! cheching whether the table eveluation in the eptrapolated domain -! (This procedure is guessed from the original table) -! - Z90LIM11=Z90LIMX(1) - Z90LIM51=Z90LIMX(5) - if((a2a0.ge.Z90LIM11) - & .and.(a2a0.le.Z90LIM51))then - call onedint(Z90LIMX,Z90LIMY,5,A2A0, - & V2V0L,1,1,11,ier) - if(V2V0.gt.V2V0L) then - write(*,*) 'WARNING in zeta_calc: in element', - & nelem - write(*,*) - & ' V2V0 in the extrapolated domain' - write(*,*) ' for zeta table (branch 1)' - endif - endif - endif - endif - return -! - elseif((lakon(nelem)(2:7).eq.'REBRSG').or. - & (lakon(nelem)(2:7).eq.'LPBRSG')) then -! -! Branch Split Genium -! Branching Flow Part IV - TEES -! Fluid Flow Division -! Section 404.2 page 3 December 1986 -! Genium Publishing (see www.genium.com) -! - if(nelem.eq.nelem1) then -! - ang1s=(1.41d0-0.00594*alpha1)*alpha1*pi/180 -! - cang1s=dcos(ang1s) -! - if(alpha1.le.22.5) then - lam11=0.0712*alpha1**0.7041+0.37 - lam12=0.0592*alpha1**0.7029+0.37 - else - lam11=1.d0 - lam12=0.9d0 - endif - zeta=lam11+(2.d0*lam12-lam11)*(V1V0*a0a1)**2 - & -2d0*lam12*V1V0*a0a1*cang1s - zeta=zeta*(W0W1)**2 -! - elseif(nelem.eq.nelem2) then -! - ang2s=(1.41d0-0.00594*alpha2)*alpha2*pi/180 -! - cang2s=dcos(ang2s) -! - if(alpha2.le.22.5) then - lam21=0.0712*alpha2**0.7041+0.37 - lam22=0.0592*alpha2**0.7029+0.37 - else - lam21=1.d0 - lam22=0.9d0 - endif -! - zeta=lam21+(2.d0*lam22-lam21)*(V2V0*a0a2)**2 - & -2d0*lam22*V2V0*a0a2*cang2s - zeta=zeta*(W0W2)**2 -! - endif - return -! - elseif((lakon(nelem)(2:8).eq.'REBRSI1').or. - & (lakon(nelem)(2:8).eq.'LPBRSI1')) then -! -! Branch Split Idelchik 1 -! Diagrams of resistance coefficients p280,p282 section VII -! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' -! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. -! ISBN 0-899116-284-4 -! - W1W0=V1V0*a0a1 - W2W0=V2V0*a0a2 -! - if(nelem.eq.nelem1) then - zeta=0.4d0*(1-W1W0)**2 - zeta=zeta*(W0W1)**2 -! - elseif(nelem.eq.nelem2) then -! - dh0=dsqrt(A0*4d0/Pi) - if(dh0.eq.0) then - dh0=dsqrt(4d0*A0/Pi) - endif - dh2=dsqrt(A2*4d0/Pi) - if(dh2.eq.0) then - dh2=dsqrt(4d0*A2/Pi) - endif -! - hq=dh2/dh0 - if(alpha2.le.60.or.hq.le.2.d0/3.d0) then - zeta=0.95d0*((W2W0-2d0*dcos(alpha2*pi/180)) - & *W2W0+1.d0) - zeta=zeta*(W0W2)**2 - else - z2d390=0.95d0*((W2W0-2d0*dcos(90.d0*pi/180)) - & *W2W0+1.d0) - z1p090=0.95*(0.34d0+W2W0**2) - z90=z2d390+(3*hq-2.d0)*(z1p090-z2d390) - Z60=0.95d0*((W2W0-2d0*dcos(60.d0*pi/180)) - & *W2W0+1.d0) - zeta=z60+(alpha2/30.d0-2.d0)*(z90-z60) - zeta=zeta*(W0W2)**2 - endif - endif - return -! - elseif((lakon(nelem)(2:8).eq.'REBRSI2').or. - & (lakon(nelem)(2:8).eq.'LPBRSI2')) then -! -! Branch Split Idelchik 2 -! Diagrams of resistance coefficients p289,section VII -! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' -! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. -! ISBN 0-899116-284-4 -! - if(nelem.eq.nelem1) then - W1W0=V1V0*a0a1 - W0W1=1/W1W0 - zeta=1.d0+0.3d0*W1W0**2 - zeta=zeta*(W0W1)**2 - elseif(nelem.eq.nelem2) then - W2W0=V2V0*a0a2 - W0W2=1/W2W0 - zeta=1.d0+0.3d0*W2W0**2 - zeta=zeta*(W0W2)**2 - endif - return - endif - endif -! - end - - diff -Nru calculix-ccx-2.1/ccx_2.3/src/absolute_relative.f calculix-ccx-2.3/ccx_2.3/src/absolute_relative.f --- calculix-ccx-2.1/ccx_2.3/src/absolute_relative.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/absolute_relative.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,434 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine absolute_relative(node1,node2,nodem,nelem,lakon, + & kon,ipkon, nactdog,identity,ielprop,prop,iflag,v, + & xflow,f,nodef,idirf,df,cp,R,physcon,numf,set,mi) +! +! orifice element +! + implicit none +! + logical identity + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(4),idirf(4),index,iflag, + & ipkon(*),kon(*),nelemswirl,mi(2) +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R, + & p1,p2,T1,T2,cp,physcon(*),km1,kp1,kdkm1, + & kdkp1,u,pi,Qred_crit,pt1,pt2,Tt1,Tt2,ct,fact, + & Cp_cor +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1)then +! + kappa=(cp/(cp-R)) + pi=4.d0*datan(1.d0) + index=ielprop(nelem) + qred_crit=dsqrt(kappa/R)* + & (1+0.5d0*(kappa-1))**(-0.5*(kappa+1)/(kappa-1)) +! +! Because the flow value is independant of the chosen +! coordinate system initial mass flow value is set to +! dsqrt(T1)*P1*Qred_crit with Qred_crit/2 = 0.02021518917 +! with consideration to flow direction +! + node1=kon(ipkon(nelem)+1) + node2=kon(ipkon(nelem)+3) + p1=v(2,node1) + p2=v(2,node2) + T1=v(0,node1) + T2=v(0,node2) +! + if(p1.gt.p2) then + xflow=0.75/dsqrt(T1)*P1*qred_crit + else + xflow=-0.75/dsqrt(T1)*P1*qred_crit + endif +! + elseif(iflag.eq.2) then +! + numf=4 + kappa=(cp/(cp-R)) + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + kdkp1=kappa/kp1 +! + index=ielprop(nelem) +! + u=prop(index+1) + ct=prop(index+2) +! + if(ct.eq.0) then + nelemswirl=prop(index+3) +! +! previous element is a preswirl nozzle +! + if(lakon(nelemswirl)(2:5).eq.'ORPN') then + ct=prop(ielprop(nelemswirl)+5) +! +! previous element is a forced vortex +! + elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then + ct=prop(ielprop(nelemswirl)+7) +! +! previous element is a free vortex +! + elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then + ct=prop(ielprop(nelemswirl)+9) + endif + endif +! + pt1=v(2,node1) + pt2=v(2,node2) +! + if(lakon(nelem)(2:4).eq.'ATR') then +! + if(u/CT.ge.2) then +! + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! +! in the case of a negative flow direction +! + if(xflow.le.0d0) then + write(*,*)'' + write(*,*)'*WARNING:' + write(*,*)'in element',nelem + write(*,*)'TYPE=ABSOLUTE TO RELATIVE' + write(*,*)'mass flow negative!' + write(*,*)'check results and element definition' + endif +! + else + pt1=v(2,node2) + pt2=v(2,node1) + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + if(xflow.le.0) then + write(*,*)'' + write(*,*)'*WARNING:' + write(*,*)'in element',nelem + write(*,*)'TYPE=ABSOLUTE TO RELATIVE' + write(*,*)'mass flow negative!' + write(*,*)'check results and element definition' + endif +! + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif +! + elseif(lakon(nelem)(2:4).eq.'RTA') then +! + if(u/CT.lt.2) then +! + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! + if(xflow.le.0d0) then + write(*,*)'' + write(*,*)'*WARNING:' + write(*,*)'in element',nelem + write(*,*)'TYPE=RELATIVE TO ABSOLUTE' + write(*,*)'mass flow negative!' + write(*,*)'check results and element definition' + endif +! + else +! + pt1=v(2,node2) + pt2=v(2,node1) + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + if(xflow.le.0) then + write(*,*)'' + write(*,*)'*WARNING:' + write(*,*)'in element',nelem + write(*,*)'TYPE=RELATIVE TO ABSOLUTE' + write(*,*)'mass flow negative!' + write(*,*)'check results and element definition' + endif +! + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 +! + endif + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 +! +! computing temperature corrected Cp=Cp(T) coefficient + call cp_corrected(cp,Tt1,Tt2,cp_cor) +! + if(Tt1.lt.273) then + Tt1= Tt2 + endif +! + if(cp_cor.eq.0) then + cp_cor=cp + endif +! +! transformation from absolute system to relative system +! + if(lakon(nelem)(2:4).eq.'ATR') then +! + fact=1+(u**2-2*u*ct)/(2*Cp_cor*Tt1) +! + f=Pt2-Pt1*(fact)**kdkm1 +! +! pressure node 1 +! + df(1)=-fact**kdkm1 +! +! temperature node1 +! + df(2)=-pt1*Kdkm1*(-(u**2-2*u*ct)/(2*Cp_cor*Tt1**2)) + & *fact**(kdkm1-1) +! +! mass flow node m +! + df(3)=0 +! +! pressure node 2 +! + df(4)=1 +! +! transformation from relative system to absolute system +! + elseif(lakon(nelem)(2:4).eq.'RTA') then +! + fact=1-(u**2-2*u*ct)/(2*Cp*Tt1) +! + f=Pt2-Pt1*(fact)**kdkm1 +! + df(1)=-fact**kdkm1 +! + df(2)=-Pt1*Kdkm1*((u**2-2*u*ct)/(2*Cp*Tt1**2)) + & *fact**(kdkm1-1) +! + df(3)=0 +! + df(4)=1 +! + endif + + elseif(iflag.eq.3) then + + kappa=(cp/(cp-R)) + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + kdkp1=kappa/kp1 +! + index=ielprop(nelem) +! + u=prop(index+1) + ct=prop(index+2) +! + if(ct.eq.0) then + nelemswirl=prop(index+3) +! +! previous element is a preswirl nozzle +! + if(lakon(nelemswirl)(2:5).eq.'ORPN') then + ct=prop(ielprop(nelemswirl)+5) +! +! previous element is a forced vortex +! + elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then + ct=prop(ielprop(nelemswirl)+7) +! +! previous element is a free vortex +! + elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then + ct=prop(ielprop(nelemswirl)+9) + endif + endif +! + pt1=v(2,node1) + pt2=v(2,node2) +! + if(lakon(nelem)(2:4).eq.'ATR') then +! + if(u/CT.ge.2) then +! + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! +! in the case of a negative flow direction +! + if(xflow.le.0d0) then + write(*,*)'' + write(*,*)'*WARNING:' + write(*,*)'in element',nelem + write(*,*)'TYPE=ABSOLUTE TO RELATIVE' + write(*,*)'mass flow negative!' + write(*,*)'check results and element definition' + endif +! + else + pt1=v(2,node2) + pt2=v(2,node1) + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + if(xflow.le.0) then + write(*,*)'' + write(*,*)'*WARNING:' + write(*,*)'in element',nelem + write(*,*)'TYPE=ABSOLUTE TO RELATIVE' + write(*,*)'mass flow negative!' + write(*,*)'check results and element definition' + endif +! + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif +! + elseif(lakon(nelem)(2:4).eq.'RTA') then +! + if(u/CT.lt.2) then +! + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! + if(xflow.le.0d0) then + write(*,*)'' + write(*,*)'*WARNING:' + write(*,*)'in element',nelem + write(*,*)'TYPE=RELATIVE TO ABSOLUTE' + write(*,*)'mass flow negative!' + write(*,*)'check results and element definition' + endif +! + else +! + pt1=v(2,node2) + pt2=v(2,node1) + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + if(xflow.le.0) then + write(*,*)'' + write(*,*)'*WARNING:' + write(*,*)'in element',nelem + write(*,*)'TYPE=RELATIVE TO ABSOLUTE' + write(*,*)'mass flow negative!' + write(*,*)'check results and element definition' + endif +! + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 +! + endif + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 +! +! computing temperature corrected Cp=Cp(T) coefficient + call cp_corrected(cp,Tt1,Tt2,cp_cor) +! + if(Tt1.lt.273) then + Tt1= Tt2 + endif +! + if(cp_cor.eq.0) then + cp_cor=cp + endif + + write(1,*) '' + write(1,55) 'In line',int(nodem/100),' from node',node1, + &' to node', node2,': air massflow rate=',xflow,'kg/s' +! &,', oil massflow rate=',xflow_oil,'kg/s' + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) + +! if(inv.eq.1) then + write(1,56)' Inlet node ',node1,': Tt1= ',Tt1, + & 'K, Ts1= ',Tt1,'K, Pt1= ',Pt1/1E5, + & 'Bar' + write(1,*)' element T ',set(numf)(1:20) + write(1,57)' u= ',u,'m/s ,Ct= ',Ct,'m/s' + write(1,56)' Outlet node ',node2,': Tt2= ',T2, + & 'K, Ts2= ',Tt2,'K, Ptt2= ',Pt2/1e5, + & 'Bar' +! + 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A,f9.5) + 57 FORMAT(1X,A,f6.2,A,f6.2,A) + + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/add_bo_st.f calculix-ccx-2.3/ccx_2.3/src/add_bo_st.f --- calculix-ccx-2.1/ccx_2.3/src/add_bo_st.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/add_bo_st.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,55 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine add_bo_st(au,jq,irow,i,j,value) +! +! stores the boundary stiffness coefficient (i,j) with value "value" +! in the stiffness matrix stored in spare matrix format +! + implicit none +! + integer jq(*),irow(*),i,j,ipointer,id + real*8 au(*),value +! + call nident(irow(jq(j)),i,jq(j+1)-jq(j),id) +! + ipointer=jq(j)+id-1 +! + if(irow(ipointer).ne.i) then +c write(*,*) i,j,ipointer,irow(ipointer) + write(*,*) '*ERROR in add_bo_st: coefficient should be 0' + stop + else + au(ipointer)=au(ipointer)+value + endif +! + return + end + + + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/addimd.f calculix-ccx-2.3/ccx_2.3/src/addimd.f --- calculix-ccx-2.1/ccx_2.3/src/addimd.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/addimd.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,43 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine addimd(imd,nmd,node) +! +! adds entity "node" to field imd. imd contains the +! entities selected by the user in which results are to be +! calculated in a modal dynamics calculation +! + implicit none +! + integer imd(*),nmd,node,id,l +! + call nident(imd,node,nmd,id) + do + if(id.gt.0) then + if(imd(id).eq.node)exit + endif + nmd=nmd+1 + do l=nmd,id+2,-1 + imd(l)=imd(l-1) + enddo + imd(id+1)=node + exit + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/addimdnodecload.f calculix-ccx-2.3/ccx_2.3/src/addimdnodecload.f --- calculix-ccx-2.1/ccx_2.3/src/addimdnodecload.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/addimdnodecload.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,65 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine addimdnodecload(nodeforc,iforc,imdnode,nmdnode,xforc, + & ikmpc,ilmpc,ipompc, + & nodempc,nmpc,imddof,nmddof, + & nactdof,mi,imdmpc,nmdmpc,imdboun,nmdboun, + & ikboun,nboun,ilboun,ithermal) +! +! adds the dof in which a user-defined point force was applied to imdnode +! (needed in dyna.c and steadystate.c) +! + implicit none +! + integer nodeforc(2,*),iforc,node,imdnode(*),nmdnode,ikmpc(*), + & ilmpc(*),ipompc(*),nodempc(3,*),nmpc,imddof(*),nmddof, + & mi(2),nactdof(0:mi(2),*),imdmpc(*),nmdmpc,imdboun(*),nmdboun, + & ikboun(*),nboun,ilboun(*),ithermal,k +! + real*8 xforc(*) +! + node=nodeforc(1,iforc) +! +! user-defined load +! + if((xforc(iforc).lt.1.2357111318d0).and. + & (xforc(iforc).gt.1.2357111316d0)) then + call addimd(imdnode,nmdnode,node) +! +! add the degrees of freedom corresponding to the node +! + if(ithermal.ne.2) then + do k=1,3 + call addimdnodedof(node,k,ikmpc,ilmpc,ipompc, + & nodempc,nmpc,imdnode,nmdnode,imddof,nmddof, + & nactdof,mi,imdmpc,nmdmpc,imdboun,nmdboun, + & ikboun,nboun,ilboun) + enddo + else + k=0 + call addimdnodedof(node,k,ikmpc,ilmpc,ipompc, + & nodempc,nmpc,imdnode,nmdnode,imddof,nmddof, + & nactdof,mi,imdmpc,nmdmpc,imdboun,nmdboun,ikboun, + & nboun,ilboun) + endif + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/addimdnodedload.f calculix-ccx-2.3/ccx_2.3/src/addimdnodedload.f --- calculix-ccx-2.1/ccx_2.3/src/addimdnodedload.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/addimdnodedload.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,169 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine addimdnodedload(nelemload,sideload,ipkon,kon,lakon, + & iload,imdnode,nmdnode,ikmpc,ilmpc,ipompc,nodempc,nmpc,imddof, + & nmddof,nactdof,mi,imdmpc,nmdmpc,imdboun,nmdboun,ikboun,nboun, + & ilboun,ithermal) +! +! adds the nodes belonging to a user-defined facial load to imdnode +! (needed in dyna.c and steadystate.c) +! + implicit none +! + character*8 lakon(*),lakonl + character*20 sideload(*) +! + integer nelemload(2,*),ipkon(*),kon(*),iload,ii,nopes,node,indexe, + & ifaceq(8,6),ifacew(8,5),ifacet(6,4),ig,ielem,nope,imdnode(*), + & nmdnode,ikmpc(*), + & ilmpc(*),ipompc(*),nodempc(3,*),nmpc,imddof(*),nmddof, + & mi(2),nactdof(0:mi(2),*),imdmpc(*),nmdmpc,imdboun(*),nmdboun, + & ikboun(*),nboun,ilboun(*),ithermal,k +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! + ielem=nelemload(1,iload) + lakonl=lakon(ielem) + indexe=ipkon(ielem) +! + if((sideload(iload)(1:1).eq.'P').and. + & (sideload(iload)(3:4).eq.'NU')) then + read(sideload(iload)(2:2),'(i1)') ig +! +! surface pressure: number of nodes belonging to the face +! + if(lakonl(4:4).eq.'2') then + nopes=8 + elseif(lakonl(4:4).eq.'8') then + nopes=4 + elseif(lakonl(4:5).eq.'10') then + nopes=6 + elseif(lakonl(4:4).eq.'4') then + nopes=3 + elseif(lakonl(4:5).eq.'15') then + if(ig.le.2) then + nopes=6 + else + nopes=8 + endif + elseif(lakonl(4:4).eq.'6') then + if(ig.le.2) then + nopes=3 + else + nopes=4 + endif + endif +! + do ii=1,nopes + if((lakonl(4:4).eq.'2').or.(lakonl(4:4).eq.'8')) then + node=kon(indexe+ifaceq(ii,ig)) + elseif((lakonl(4:5).eq.'10').or.(lakonl(4:4).eq.'4')) then + node=kon(indexe+ifacet(ii,ig)) + elseif((lakonl(4:5).eq.'15').or.(lakonl(4:4).eq.'6')) then + node=kon(indexe+ifacew(ii,ig)) + endif +! +! user-defined load +! + if(sideload(iload)(3:4).eq.'NU') then + call addimd(imdnode,nmdnode,node) +! +! add the degrees of freedom corresponding to the node +! + if(ithermal.ne.2) then + do k=1,3 + call addimdnodedof(node,k,ikmpc,ilmpc,ipompc, + & nodempc,nmpc,imdnode,nmdnode,imddof,nmddof, + & nactdof,mi,imdmpc,nmdmpc,imdboun,nmdboun, + & ikboun,nboun,ilboun) + enddo + else + k=0 + call addimdnodedof(node,k,ikmpc,ilmpc,ipompc, + & nodempc,nmpc,imdnode,nmdnode,imddof,nmddof, + & nactdof,mi,imdmpc,nmdmpc,imdboun,nmdboun,ikboun, + & nboun,ilboun) + endif + endif +! + enddo + elseif(sideload(iload)(1:1).eq.'B') then +! +! volumetric load; number of nodes in the element +! + if(lakonl(4:4).eq.'2') then + nope=20 + elseif(lakonl(4:4).eq.'8') then + nope=8 + elseif(lakonl(4:5).eq.'10') then + nope=10 + elseif(lakonl(4:4).eq.'4') then + nope=4 + elseif(lakonl(4:5).eq.'15') then + nope=15 + elseif(lakonl(4:4).eq.'6') then + nope=6 + endif +! + do ii=1,nope + node=kon(indexe+ii) +! +! user-defined load +! + if(sideload(iload)(3:4).eq.'NU') then + call addimd(imdnode,nmdnode,node) +! +! add the degrees of freedom corresponding to the node +! + if(ithermal.ne.2) then + do k=1,3 + call addimdnodedof(node,k,ikmpc,ilmpc,ipompc, + & nodempc,nmpc,imdnode,nmdnode,imddof,nmddof, + & nactdof,mi,imdmpc,nmdmpc,imdboun,nmdboun, + & ikboun,nboun,ilboun) + enddo + else + k=0 + call addimdnodedof(node,k,ikmpc,ilmpc,ipompc, + & nodempc,nmpc,imdnode,nmdnode,imddof,nmddof, + & nactdof,mi,imdmpc,nmdmpc,imdboun,nmdboun,ikboun, + & nboun,ilboun) + endif + endif + enddo +! + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/addimdnodedof.f calculix-ccx-2.3/ccx_2.3/src/addimdnodedof.f --- calculix-ccx-2.1/ccx_2.3/src/addimdnodedof.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/addimdnodedof.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,71 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine addimdnodedof(node,k,ikmpc,ilmpc,ipompc, + & nodempc,nmpc,imdnode,nmdnode,imddof,nmddof,nactdof,mi, + & imdmpc,nmdmpc,imdboun,nmdboun,ikboun,nboun,ilboun) +! +! node was kept by the user in a modal dynamics calculation; +! the present routine checks DOF k of node; if this DOF belongs +! to a MPC all independent nodes and DOF's of the MPC have to be kept +! + implicit none +! + integer node,k,idof,ikmpc(*),ilmpc(*),ipompc(*),nodempc(3,*), + & nmpc,imdnode(*),nmdnode,imddof(*),nmddof,id,ist,index,jdof, + & mi(2),nactdof(0:mi(2),*),imdmpc(*),nmdmpc,imdboun(*),nmdboun, + & ikboun(*),nboun,ilboun(*) +! + idof=nactdof(k,node) +c write(*,*) 'addimdnodedof ',node,k,idof + if(idof.eq.0) then + idof=(node-1)*8+k +! +! checking for mpc's +! + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + call addimd(imdmpc,nmdmpc,ilmpc(id)) + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + do + call addimd(imdnode,nmdnode,nodempc(1,index)) + jdof=nactdof(nodempc(2,index),nodempc(1,index)) + if(jdof.ne.0) call addimd(imddof,nmddof,jdof) + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif +! +! checking for spc's +! + call nident(ikboun,idof,nboun,id) + if(id.gt.0) then + if(ikboun(id).eq.idof) then + call addimd(imdboun,nmdboun,ilboun(id)) + endif + endif + else + call addimd(imddof,nmddof,idof) + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/addizdofcload.f calculix-ccx-2.3/ccx_2.3/src/addizdofcload.f --- calculix-ccx-2.1/ccx_2.3/src/addizdofcload.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/addizdofcload.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,58 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine addizdofcload(nodeforc,ndirforc,nactdof,mi,izdof, + & nzdof,iforc,iznode,nznode,nk,imdnode,nmdnode,xforc) +! +! adds the dof in which a point force was applied to iznode, izdof +! and to imdnode if user-defined load +! (needed in dyna.c and steadystate.c) +! + implicit none +! + integer nodeforc(2,*),ndirforc(*),iforc,node,j,jdof,mi(2),nk, + & nactdof(0:mi(2),*),izdof(*),nzdof,iznode(*),nznode,nodebasis, + & imdnode(*),nmdnode +! + real*8 xforc(*) +! + node=nodeforc(1,iforc) +! +! adding the nodes in the basis sector to iznode +! + nodebasis=mod(node,nk) + call addimd(iznode,nznode,nodebasis) +! +! user-defined load +! + if((xforc(iforc).lt.1.2357111318d0).and. + & (xforc(iforc).gt.1.2357111316d0)) then + call addimd(imdnode,nmdnode,node) + endif +! + j=ndirforc(iforc) +! +! C-convention! +! + jdof=nactdof(j,node)-1 +! + if(jdof.ne.0) call addimd(izdof,nzdof,jdof) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/addizdofdload.f calculix-ccx-2.3/ccx_2.3/src/addizdofdload.f --- calculix-ccx-2.1/ccx_2.3/src/addizdofdload.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/addizdofdload.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,155 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine addizdofdload(nelemload,sideload,ipkon,kon,lakon, + & nactdof,izdof,nzdof,mi,iload,iznode,nznode,nk,imdnode,nmdnode) +! +! adds the nodes belonging to a facial load to iznode, izdof +! and to imdnode if user-defined load +! (needed in dyna.c and steadystate.c) +! + implicit none +! + character*8 lakon(*),lakonl + character*20 sideload(*) +! + integer mi(2),nelemload(2,*),ipkon(*),kon(*),nactdof(0:mi(2),*), + & izdof(*),nzdof,iload,j,ii,nopes,node,indexe,jdof,ifaceq(8,6), + & ifacew(8,5),ifacet(6,4),ig,ielem,nope,iznode(*),nznode, + & nodebasis,nk,imdnode(*),nmdnode +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! + ielem=nelemload(1,iload) + lakonl=lakon(ielem) + indexe=ipkon(ielem) +! + if(sideload(iload)(1:1).eq.'P') then + read(sideload(iload)(2:2),'(i1)') ig +! +! surface pressure: number of nodes belonging to the face +! + if(lakonl(4:4).eq.'2') then + nopes=8 + elseif(lakonl(4:4).eq.'8') then + nopes=4 + elseif(lakonl(4:5).eq.'10') then + nopes=6 + elseif(lakonl(4:4).eq.'4') then + nopes=3 + elseif(lakonl(4:5).eq.'15') then + if(ig.le.2) then + nopes=6 + else + nopes=8 + endif + elseif(lakonl(4:4).eq.'6') then + if(ig.le.2) then + nopes=3 + else + nopes=4 + endif + endif +! + do ii=1,nopes + if((lakonl(4:4).eq.'2').or.(lakonl(4:4).eq.'8')) then + node=kon(indexe+ifaceq(ii,ig)) + elseif((lakonl(4:5).eq.'10').or.(lakonl(4:4).eq.'4')) then + node=kon(indexe+ifacet(ii,ig)) + elseif((lakonl(4:5).eq.'15').or.(lakonl(4:4).eq.'6')) then + node=kon(indexe+ifacew(ii,ig)) + endif +! +! adding the nodes in the basis sector to iznode +! + nodebasis=mod(node,nk) + call addimd(iznode,nznode,nodebasis) +! +! user-defined load +! + if(sideload(iload)(3:4).eq.'NU') then + call addimd(imdnode,nmdnode,node) + endif +! + do j=1,3 +! +! C-convention! +! + jdof=nactdof(j,node)-1 + if(jdof.ne.0) call addimd(izdof,nzdof,jdof) + enddo + enddo + elseif(sideload(iload)(1:1).eq.'B') then +! +! volumetric load; number of nodes in the element +! + if(lakonl(4:4).eq.'2') then + nope=20 + elseif(lakonl(4:4).eq.'8') then + nope=8 + elseif(lakonl(4:5).eq.'10') then + nope=10 + elseif(lakonl(4:4).eq.'4') then + nope=4 + elseif(lakonl(4:5).eq.'15') then + nope=15 + elseif(lakonl(4:4).eq.'6') then + nope=6 + endif +! + do ii=1,nope + node=kon(indexe+ii) +! +! adding the nodes in the basis sector to iznode +! + nodebasis=mod(node,nk) + call addimd(iznode,nznode,nodebasis) +! +! user-defined load +! + if(sideload(iload)(3:4).eq.'NU') then + call addimd(imdnode,nmdnode,node) + endif +! + do j=1,3 +! +! C-convention! +! + jdof=nactdof(j,node)-1 + if(jdof.ne.0) call addimd(izdof,nzdof,jdof) + enddo + enddo + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/add_pr.f calculix-ccx-2.3/ccx_2.3/src/add_pr.f --- calculix-ccx-2.1/ccx_2.3/src/add_pr.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/add_pr.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,66 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine add_pr(au,ad,icol,jq,i,j,value,i0,i1) +! +! stores coefficient (i,j) in the stiffness matrix stored in +! profile format +! + implicit none +! + integer icol(*),jq(*),i,j,ii,jj,ipointer,i0,i1 + real*8 ad(*),au(*),value +! + if(i.eq.j) then + if(i0.eq.i1) then + ad(i)=ad(i)+value + else + ad(i)=ad(i)+2.d0*value + endif + return + elseif(i.gt.j) then + ii=j + jj=i + else + ii=i + jj=j + endif +! + if(ii.lt.jq(jj)) then + write(*,*) '*ERROR in add_pr: coefficient should be 0' + stop + else + ipointer=icol(jj)-jj+ii+1 + au(ipointer)=au(ipointer)+value + endif +! + return + end + + + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/add_rect.c calculix-ccx-2.3/ccx_2.3/src/add_rect.c --- calculix-ccx-2.1/ccx_2.3/src/add_rect.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/add_rect.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,95 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include +#include "CalculiX.h" + +void add_rect(double *au_1,int * irow_1,int * jq_1,int n_1, int m_1, + double *au_2,int * irow_2,int * jq_2,int n_2, int m_2, + double **au_rp,int **irow_rp,int * jq_r){ + + /*Result fields*/ + int *irow=NULL,ifree=1,nzs,numb,icol,i,j,k,l,m,carre=0,kflag=2,istart,icounter, + pt1,pt2,row1,row2; + double *au=NULL,value; + clock_t debut; + clock_t fin; + + debut=clock(); + if((m_1!=m_2)||(n_1!=n_2)){ + printf("Error in mutli_rec : Matrix sizes are not compatible\n"); + return; + } + + nzs=jq_1[m_1]+jq_2[m_2]-2; + //printf("nzs add_rect = %d\n",nzs); +// irow=NNEW(int,nzs); +// au=NNEW(double,nzs); + irow=*irow_rp; + au=*au_rp; + + jq_r[0]=1; + + for(j=0;j +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif +#ifdef PARDISO + #include "pardiso.h" +#endif + +void arpackbu(double *co, int *nk, int *kon, int *ipkon, char *lakon, + int *ne, + int *nodeboun, int *ndirboun, double *xboun, int *nboun, + int *ipompc, int *nodempc, double *coefmpc, char *labmpc, + int *nmpc, + int *nodeforc, int *ndirforc,double *xforc, int *nforc, + int *nelemload, char *sideload, double *xload, + int *nload, + double *ad, double *au, double *b,int *nactdof, + int *icol, int *jq, int *irow, int *neq, int *nzl, + int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, + int *ilboun, + double *elcon, int *nelcon, double *rhcon, int *nrhcon, + double *alcon, int *nalcon, double *alzero, int *ielmat, + int *ielorien, int *norien, double *orab, int *ntmat_, + double *t0, double *t1, double *t1old, + int *ithermal,double *prestr, int *iprestr, + double *vold,int *iperturb, double *sti, int *nzs, + int *kode, double *adb, double *aub,int *mei, double *fei, + char *filab, double *eme, + int *iexpl, double *plicon, int *nplicon, double *plkcon, + int *nplkcon, + double *xstate, int *npmat_, char *matname, int *mi, + int *ncmat_, int *nstate_, double *ener, char *output, + char *set, int *nset, int *istartset, + int *iendset, int *ialset, int *nprint, char *prlab, + char *prset, int *nener, int *isolver, double *trab, + int *inotr, int *ntrans, double *ttime,double *fmpc, + char *cbody, int *ibody,double *xbody, int *nbody){ + + char bmat[2]="G", which[3]="LM", howmny[2]="A", + description[13]=" "; + + int *inum=NULL,k,ido,dz,iparam[11],ipntr[11],lworkl,im, + info,rvec=1,*select=NULL,lfin,j,lint,iout,iconverged=0,ielas,icmd=0, + iinc=1,istep=1,*ncocon=NULL,*nshcon=NULL,nev,ncv,mxiter,jrow, + *ipobody=NULL,inewton=0,coriolis=0,ifreebody,symmetryflag=0, + inputformat=0,ngraph=1,mt=mi[1]+1,mass[2]={0,0}, stiffness=1, buckling=0, + rhsi=1, intscheme=0, noddiam=-1,*ipneigh=NULL,*neigh=NULL; + + double *stn=NULL,*v=NULL,*resid=NULL,*z=NULL,*workd=NULL, + *workl=NULL,*aux=NULL,*d=NULL,sigma,*temp_array=NULL, + *een=NULL,cam[5],*f=NULL,*fn=NULL,qa[3],*fext=NULL,time=0.,*epn=NULL, + *xstateini=NULL,*xstiff=NULL,*stiini=NULL,*vini=NULL,*stx=NULL, + *enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL,*cocon=NULL, + *shcon=NULL,*physcon=NULL,*qfx=NULL,*qfn=NULL,tol, *cgr=NULL, + *xloadold=NULL,reltime,*vr=NULL,*vi=NULL,*stnr=NULL,*stni=NULL, + *vmax=NULL,*stnmax=NULL,*cs=NULL,*springarea=NULL,*eenmax=NULL; + + /* buckling routine; only for mechanical applications */ + + /* dummy arguments for the results call */ + + double *veold=NULL,*accold=NULL,bet,gam,dtime; + +#ifdef SGI + int token; +#endif + + /* copying the frequency parameters */ + + nev=mei[0]; + ncv=mei[1]; + mxiter=mei[2]; + tol=fei[0]; + + /* calculating the stresses due to the buckling load; this is a second + order calculation if iperturb != 0 */ + + *nmethod=1; + + /* assigning the body forces to the elements */ + + if(*nbody>0){ + ifreebody=*ne+1; + ipobody=NNEW(int,2*ifreebody**nbody); + for(k=1;k<=*nbody;k++){ + FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, + iendset,ialset,&inewton,nset,&ifreebody,&k)); + RENEW(ipobody,int,2*(*ne+ifreebody)); + } + RENEW(ipobody,int,2*(ifreebody-1)); + } + + /* determining the internal forces and the stiffness coefficients */ + + f=NNEW(double,neq[0]); + + /* allocating a field for the stiffness matrix */ + + xstiff=NNEW(double,27*mi[0]**ne); + +// iout=-1; + v=NNEW(double,mt**nk); + fn=NNEW(double,mt**nk); + stx=NNEW(double,6*mi[0]**ne); + + iout=-1; + inum=NNEW(int,*nk); + if(*iperturb==0){ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t0,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xboun,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[0],veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, + &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, + sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, + fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea, + &reltime)); + }else{ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1old,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xboun,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[0],veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, + &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, + sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, + fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea, + &reltime)); + } + + free(v);free(fn);free(stx);free(inum); + iout=1; + + /* determining the system matrix and the external forces */ + + ad=NNEW(double,neq[0]); + au=NNEW(double,nzs[0]); + fext=NNEW(double,neq[0]); + + if(*iperturb==0){ + FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, + ikmpc,ilmpc,ikboun,ilboun, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_, + t0,t0,ithermal,prestr,iprestr,vold,iperturb,sti, + &nzs[0],stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, + xstiff,npmat_,&dtime,matname,mi, + ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme,physcon, + shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc,&coriolis, + ibody,xloadold,&reltime,veold,springarea,nstate_, + xstateini,xstate)); + } + else{ + FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, + ikmpc,ilmpc,ikboun,ilboun, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_, + t0,t1old,ithermal,prestr,iprestr,vold,iperturb,sti, + &nzs[0],stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, + xstiff,npmat_,&dtime,matname,mi, + ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme,physcon, + shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc,&coriolis, + ibody,xloadold,&reltime,veold,springarea,nstate_, + xstateini,xstate)); + } + + /* determining the right hand side */ + + b=NNEW(double,neq[0]); + for(k=0;k0) free(ipobody); + + if(*nmethod==1){return;} + + /* loop checking the plausibility of the buckling factor + if (5*sigmad[0]/sigma)||(50000.0) FORTRAN(writehe,(&j)); + +// memset(&v[0],0.,sizeof(double)*mt**nk); + DMEMSET(v,0,mt**nk,0.); + if(*iperturb==0){ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum, + stx,elcon, + nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, + norien,orab,ntmat_,t0,t0,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,&z[lint], + nodeboun,ndirboun,xboun,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[0],veold,accold,&bet, + &gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, + xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea,&reltime));} + else{ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum, + stx,elcon, + nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, + norien,orab,ntmat_,t0,t1old,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,&z[lint], + nodeboun,ndirboun,xboun,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[0],veold,accold,&bet, + &gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, + xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea,&reltime)); + } + + ++*kode; + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); + } + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, + fn,&d[j],epn,ielmat,matname,enern,xstaten,nstate_,&istep,&iinc, + iperturb,ener,mi,output,ithermal,qfn,&j,&noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,stx,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, + set,nset,istartset,iendset,ialset,eenmax)); + if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} + } + + free(v);free(fn);free(stn);free(inum);free(stx);free(z);free(d);free(eei); + if(*nener==1){ + free(stiini);free(enerini);} + + if(strcmp1(&filab[261],"E ")==0) free(een); + if(strcmp1(&filab[522],"ENER")==0) free(enern); + + return; +} + +#endif diff -Nru calculix-ccx-2.1/ccx_2.3/src/arpack.c calculix-ccx-2.3/ccx_2.3/src/arpack.c --- calculix-ccx-2.1/ccx_2.3/src/arpack.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/arpack.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,625 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifdef ARPACK + +#include +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif +#ifdef MATRIXSTORAGE + #include "matrixstorage.h" +#endif +#ifdef PARDISO + #include "pardiso.h" +#endif + +void arpack(double *co, int *nk, int *kon, int *ipkon, char *lakon, + int *ne, + int *nodeboun, int *ndirboun, double *xboun, int *nboun, + int *ipompc, int *nodempc, double *coefmpc, char *labmpc, + int *nmpc, + int *nodeforc, int *ndirforc,double *xforc, int *nforc, + int *nelemload, char *sideload, double *xload, + int *nload, + double *ad, double *au, double *b, int *nactdof, + int *icol, int *jq, int *irow, int *neq, int *nzl, + int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, + int *ilboun, + double *elcon, int *nelcon, double *rhcon, int *nrhcon, + double *shcon, int *nshcon, double *cocon, int *ncocon, + double *alcon, int *nalcon, double *alzero, int *ielmat, + int *ielorien, int *norien, double *orab, int *ntmat_, + double *t0, double *t1, double *t1old, + int *ithermal,double *prestr, int *iprestr, + double *vold,int *iperturb, double *sti, int *nzs, + int *kode, double *adb, double *aub, + int *mei, double *fei, + char *filab, double *eme, + int *iexpl, double *plicon, int *nplicon, double *plkcon, + int *nplkcon, + double *xstate, int *npmat_, char *matname, int *mi, + int *ncmat_, int *nstate_, double *ener, char *jobnamec, + char *output, char *set, int *nset, int *istartset, + int *iendset, int *ialset, int *nprint, char *prlab, + char *prset, int *nener, int *isolver, double *trab, + int *inotr, int *ntrans, double *ttime, double *fmpc, + char *cbody, int *ibody,double *xbody, int *nbody){ + + /* calls the Arnoldi Package (ARPACK) */ + + char bmat[2]="G", which[3]="LM", howmny[2]="A", fneig[132]="", + description[13]=" "; + + int *inum=NULL,k,ido,dz,iparam[11],ipntr[11],lworkl,ngraph=1,im, + info,rvec=1,*select=NULL,lfin,j,lint,iout,ielas=1,icmd=0,mt=mi[1]+1, + iinc=1,istep=1,nev,ncv,mxiter,jrow,*ipobody=NULL,inewton=0,ifreebody, + mass[2]={1,1}, stiffness=1, buckling=0, rhsi=0, intscheme=0,noddiam=-1, + coriolis=0,symmetryflag=0,inputformat=0,*ipneigh=NULL,*neigh=NULL; + + double *stn=NULL,*v=NULL,*resid=NULL,*z=NULL,*workd=NULL, + *workl=NULL,*aux=NULL,*d=NULL,sigma=1,*temp_array=NULL, + *een=NULL,sum,cam[5],*f=NULL,*fn=NULL,qa[3],*fext=NULL,*epn=NULL, + *xstateini=NULL,*xstiff=NULL,*stiini=NULL,*vini=NULL,freq,*stx=NULL, + *enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL, + *physcon=NULL,*qfx=NULL,*qfn=NULL,tol,fmin,fmax,pi,*cgr=NULL, + *xloadold=NULL,reltime,*vr=NULL,*vi=NULL,*stnr=NULL,*stni=NULL, + *vmax=NULL,*stnmax=NULL,*cs=NULL,*springarea=NULL,*eenmax=NULL; + + FILE *f1; + + /* dummy arguments for the results call */ + + double *veold=NULL,*accold=NULL,bet,gam,dtime,time; + +#ifdef SGI + int token; +#endif + + if((strcmp1(&filab[870],"PU ")==0)|| + (strcmp1(&filab[1479],"PHS ")==0)|| + (strcmp1(&filab[1566],"MAXU")==0)|| + (strcmp1(&filab[1653],"MAXS")==0)){ + printf("*ERROR in arpack: PU, PHS, MAXU and MAX was selected in a frequency calculation without cyclic symmetry;\n this is not correct\n"); + FORTRAN(stop,()); + } + + /* copying the frequency parameters */ + + pi=4.*atan(1.); + + nev=mei[0]; + ncv=mei[1]; + mxiter=mei[2]; + tol=fei[0]; + fmin=2*pi*fei[1]; + fmax=2*pi*fei[2]; + + /* assigning the body forces to the elements */ + + if(*nbody>0){ + ifreebody=*ne+1; + ipobody=NNEW(int,2*ifreebody**nbody); + for(k=1;k<=*nbody;k++){ + FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, + iendset,ialset,&inewton,nset,&ifreebody,&k)); + RENEW(ipobody,int,2*(*ne+ifreebody)); + } + RENEW(ipobody,int,2*(ifreebody-1)); + if(inewton==1){ + printf("*ERROR in arpackcs: generalized gravity loading is not allowed in frequency calculations"); + FORTRAN(stop,()); + } + } + + /* field for initial values of state variables (needed if + previous static step was viscoplastic */ + + if(*nstate_!=0){ + xstateini=NNEW(double,*nstate_*mi[0]**ne); + for(k=0;k<*nstate_*mi[0]**ne;++k){ + xstateini[k]=xstate[k]; + } + } + + /* determining the internal forces and the stiffness coefficients */ + + f=NNEW(double,neq[1]); + + /* allocating a field for the stiffness matrix */ + + xstiff=NNEW(double,27*mi[0]**ne); + + iout=-1; + v=NNEW(double,mt**nk); + fn=NNEW(double,mt**nk); + stx=NNEW(double,6*mi[0]**ne); + if(*ithermal>1){ + qfx=NNEW(double,3*mi[0]**ne); + } + inum=NNEW(int,*nk); + if(*iperturb==0){ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t0,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xboun,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, + &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, + sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, + fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea, + &reltime)); + }else{ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1old,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xboun,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, + &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, + sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, + fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea, + &reltime)); + } + free(f);free(v);free(fn);free(stx);if(*ithermal>1)free(qfx);free(inum); + iout=1; + + /* filling in the matrix */ + + ad=NNEW(double,neq[1]); + au=NNEW(double,nzs[2]); + + adb=NNEW(double,neq[1]); + aub=NNEW(double,nzs[1]); + + fext=NNEW(double,neq[1]); + + if(*iperturb==0){ + FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, + ikmpc,ilmpc,ikboun,ilboun, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_, + t0,t0,ithermal,prestr,iprestr,vold,iperturb,sti, + nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, + xstiff,npmat_,&dtime,matname,mi, + ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme, + physcon,shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc, + &coriolis,ibody,xloadold,&reltime,veold,springarea,nstate_, + xstateini,xstate)); + } + else{ + FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, + ikmpc,ilmpc,ikboun,ilboun, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_, + t0,t1old,ithermal,prestr,iprestr,vold,iperturb,sti, + nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, + xstiff,npmat_,&dtime,matname,mi, + ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme, + physcon,shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc, + &coriolis,ibody,xloadold,&reltime,veold,springarea,nstate_, + xstateini,xstate)); + } + + free(fext); + + if(*nmethod==0){ + + /* error occurred in mafill: storing the geometry in frd format */ + + ++*kode;time=0.; + inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); + } + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, + fn,&time,epn,ielmat,matname,enern,xstaten,nstate_,&istep,&iinc, + iperturb,ener,mi,output,ithermal,qfn,&j,&noddiam,trab,inotr,ntrans, + orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, + set,nset,istartset,iendset,ialset,eenmax)); + + if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} + free(inum);FORTRAN(stop,()); + + } + + /* LU decomposition of the left hand matrix */ + + if(*isolver==0){ +#ifdef SPOOLES + spooles_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1], + &symmetryflag,&inputformat); +#else + printf("*ERROR in arpack: the SPOOLES library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==4){ +#ifdef SGI + token=1; + sgi_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1],token); +#else + printf("*ERROR in arpack: the SGI library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_factor(ad,&au,adb,aub,&sigma,icol,&irow,&neq[1],&nzs[1]); +#else + printf("*ERROR in arpack: the TAUCS library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==6){ +#ifdef MATRIXSTORAGE + matrixstorage(ad,&au,adb,aub,&sigma,icol,&irow,&neq[1],&nzs[1], + ntrans,inotr,trab,co,nk,nactdof,jobnamec,mi); +#else + printf("*ERROR in arpack: the MATRIXSTORAGE library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1]); +#else + printf("*ERROR in arpack: the PARDISO library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + +/* free(au);free(ad);*/ + +/* calculating the eigenvalues and eigenmodes */ + + printf(" Calculating the eigenvalues and the eigenmodes\n\n"); + + ido=0; + dz=neq[1]; + iparam[0]=1; + iparam[2]=mxiter; + iparam[3]=1; + iparam[6]=3; + + lworkl=ncv*(8+ncv); + info=0; + + resid=NNEW(double,neq[1]); + long long zsize=ncv*neq[1]; + z=NNEW(double,zsize); + workd=NNEW(double,3*neq[1]); + workl=NNEW(double,lworkl); + + FORTRAN(dsaupd,(&ido,bmat,&neq[1],which,&nev,&tol,resid,&ncv,z,&dz,iparam,ipntr,workd, + workl,&lworkl,&info)); + + temp_array=NNEW(double,neq[1]); + + while((ido==-1)||(ido==1)||(ido==2)){ + if(ido==-1){ + FORTRAN(op,(&neq[1],aux,&workd[ipntr[0]-1],temp_array,adb,aub,icol,irow,nzl)); + } + if((ido==-1)||(ido==1)){ + + /* solve the linear equation system */ + + if(ido==-1){ + if(*isolver==0){ +#ifdef SPOOLES + spooles_solve(temp_array,&neq[1]); +#endif + } + else if(*isolver==4){ +#ifdef SGI + sgi_solve(temp_array,token); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_solve(temp_array,&neq[1]); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_solve(temp_array,&neq[1]); +#endif + } + for(jrow=0;jrow1){ + qfn=NNEW(double,3**nk); + qfx=NNEW(double,3*mi[0]**ne); + } + + if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); + if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); + + temp_array=NNEW(double,neq[1]); + + lfin=0; + for(j=0;jd[j]) continue; + if(fmax>0.){ + if(fmax0) FORTRAN(writehe,(&j)); + + sum=0.; + for(k=0;k0.)&&(fmax>d[nev-1])){ + printf("\n*WARNING: not all frequencies in the requested interval might be found;\nincrease the number of requested frequencies\n"); + } + + if(mei[3]==1){ + fclose(f1); + } + + free(adb);free(aub);free(temp_array); + + free(v);free(fn);free(stn);free(inum);free(stx);free(resid); + free(z);free(workd);free(workl);free(select);free(d);free(xstiff); + free(ipobody); + + if(*ithermal>1){free(qfn);free(qfx);} + + if(*nstate_!=0){free(xstateini);} + + if(strcmp1(&filab[261],"E ")==0) free(een); + if(strcmp1(&filab[522],"ENER")==0) free(enern); + + for(k=0;k<6*mi[0]**ne;k++){eme[k]=0.;} + + return; +} + +#endif diff -Nru calculix-ccx-2.1/ccx_2.3/src/arpackcs.c calculix-ccx-2.3/ccx_2.3/src/arpackcs.c --- calculix-ccx-2.1/ccx_2.3/src/arpackcs.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/arpackcs.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1539 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifdef ARPACK + +#include +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif +#ifdef PARDISO + #include "pardiso.h" +#endif + +void arpackcs(double *co, int *nk, int *kon, int *ipkon, char *lakon, + int *ne, + int *nodeboun, int *ndirboun, double *xboun, int *nboun, + int *ipompc, int *nodempc, double *coefmpc, char *labmpc, + int *nmpc, + int *nodeforc, int *ndirforc,double *xforc, int *nforc, + int *nelemload, char *sideload, double *xload, + int *nload, + double *ad, double *au, double *b, int *nactdof, + int *icol, int *jq, int *irow, int *neq, int *nzl, + int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, + int *ilboun, + double *elcon, int *nelcon, double *rhcon, int *nrhcon, + double *alcon, int *nalcon, double *alzero, int *ielmat, + int *ielorien, int *norien, double *orab, int *ntmat_, + double *t0, double *t1, double *t1old, + int *ithermal,double *prestr, int *iprestr, + double *vold,int *iperturb, double *sti, int *nzs, + int *kode, double *adb, double *aub,int *mei, double *fei, + char *filab, double *eme, + int *iexpl, double *plicon, int *nplicon, double *plkcon, + int *nplkcon, + double *xstate, int *npmat_, char *matname, int *mi, + int *ics, double *cs, int *mpcend, int *ncmat_, + int *nstate_, int *mcs, int *nkon, double *ener, + char *jobnamec, char *output, char *set, int *nset, + int *istartset, + int *iendset, int *ialset, int *nprint, char *prlab, + char *prset, int *nener, int *isolver, double *trab, + int *inotr, int *ntrans, double *ttime, double *fmpc, + char *cbody, int *ibody, double *xbody, int *nbody, + int *nevtot){ + + /* calls the Arnoldi Package (ARPACK) for cyclic symmetry calculations */ + + char bmat[2]="G", which[3]="LM", howmny[2]="A",*lakont=NULL, + description[13]=" ",fneig[132]=""; + + int *inum=NULL,k,ido,dz,iparam[11],ipntr[11],lworkl,idir, + info,rvec=1,*select=NULL,lfin,j,lint,iout=1,nm,index,inode,id,i,idof, + ielas,icmd=0,kk,l,nkt,icntrl,*kont=NULL,*ipkont=NULL,*inumt=NULL, + *ielmatt=NULL,net,imag,icomplex,kkv,kk6,iinc=1,istep=1,nev,ncv, + mxiter,lprev,ilength,ij,i1,i2,iel,ielset,node,indexe,nope,ml1, + *inocs=NULL,*ielcs=NULL,jj,l1,l2,ngraph,is,jrow,*ipobody=NULL, + *inotrt=NULL,symmetryflag=0,inputformat=0,inewton=0,ifreebody, + mass=1, stiffness=1, buckling=0, rhsi=0, intscheme=0,*ncocon=NULL, + coriolis=0,iworsttime,l3,iray,mt,kkx,im; + + double *stn=NULL,*v=NULL,*resid=NULL,*z=NULL,*workd=NULL,*vr=NULL, + *workl=NULL,*aux=NULL,*d=NULL,sigma=1,*temp_array=NULL,*vini=NULL, + *een=NULL,cam[5],*f=NULL,*fn=NULL,qa[3],*fext=NULL,*epn=NULL,*stiini=NULL, + *xstateini=NULL,theta,pi,*coefmpcnew=NULL,*xstiff=NULL,*vi=NULL, + *vt=NULL,*fnt=NULL,*stnt=NULL,*eent=NULL,*cot=NULL,t[3],ctl,stl, + *t1t=NULL,freq,*stx=NULL,*enern=NULL,*enernt=NULL,*xstaten=NULL, + *eei=NULL,*enerini=NULL,*cocon=NULL,*qfx=NULL,*qfn=NULL,*qfnt=NULL, + tol,fmin,fmax,xreal,ximag,*cgr=NULL,*xloadold=NULL,reltime,constant, + vreal,vimag,*stnr=NULL,*stni=NULL,stnreal,stnimag,*vmax=NULL, + *stnmax=NULL,vl[4],stnl[6],dd,v1,v2,v3,bb,cc,al[3],cm,cn,tt, + worstpsmax,vray[3],worstumax,p1[3],p2[3],q[3],tan[3],*springarea=NULL, + *stxt=NULL,*eenmax=NULL,eenl[6]; + + FILE *f1; + + /* dummy arguments for the results call */ + + double *veold=NULL,*accold=NULL,bet,gam,dtime,time; + + int *ipneigh=NULL,*neigh=NULL; + +#ifdef SGI + int token; +#endif + + mt=mi[1]+1; + pi=4.*atan(1.); + constant=180./pi; + + /* copying the frequency parameters */ + + nev=mei[0]; + ncv=mei[1]; + mxiter=mei[2]; + tol=fei[0]; + fmin=2*pi*fei[1]; + fmax=2*pi*fei[2]; + + /* assigning the body forces to the elements */ + + if(*nbody>0){ + ifreebody=*ne+1; + ipobody=NNEW(int,2*ifreebody**nbody); + for(k=1;k<=*nbody;k++){ + FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, + iendset,ialset,&inewton,nset,&ifreebody,&k)); + RENEW(ipobody,int,2*(*ne+ifreebody)); + } + RENEW(ipobody,int,2*(ifreebody-1)); + if(inewton==1){ + printf("*ERROR in arpackcs: generalized gravity loading is not allowed in frequency calculations"); + FORTRAN(stop,()); + } + } + + /* determining the internal forces and the stiffness coefficients */ + + f=NNEW(double,*neq); + + /* allocating a field for the stiffness matrix */ + + xstiff=NNEW(double,27*mi[0]**ne); + + iout=-1; + v=NNEW(double,mt**nk); + fn=NNEW(double,mt**nk); + stx=NNEW(double,6*mi[0]**ne); + inum=NNEW(int,*nk); + if(*iperturb==0){ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t0,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xboun,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq,veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, + &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, + sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, + fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea, + &reltime)); + }else{ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1old,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xboun,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq,veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, + &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, + sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, + fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea, + &reltime)); + } + free(f);free(v);free(fn);free(stx);free(inum); + iout=1; + + /* determining the maximum number of sectors to be plotted */ + + ngraph=1; + for(j=0;j<*mcs;j++){ + if(cs[17*j+4]>ngraph) ngraph=cs[17*j+4]; + } + + /* assigning nodes and elements to sectors */ + + inocs=NNEW(int,*nk); + ielcs=NNEW(int,*ne); + ielset=cs[12]; + if((*mcs!=1)||(ielset!=0)){ + for(i=0;i<*nk;i++) inocs[i]=-1; + for(i=0;i<*ne;i++) ielcs[i]=-1; + } + + for(i=0;i<*mcs;i++){ + is=cs[17*i+4]; + if((is==1)&&(*mcs==1)) continue; + ielset=cs[17*i+12]; + if(ielset==0) continue; + for(i1=istartset[ielset-1]-1;i10){ + iel=ialset[i1]-1; + if(ipkon[iel]<0) continue; + ielcs[iel]=i; + indexe=ipkon[iel]; + if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; + else {nope=6;} + for(i2=0;i2=ialset[i1-1]-1) break; + if(ipkon[iel]<0) continue; + ielcs[iel]=i; + indexe=ipkon[iel]; + if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; + else {nope=6;} + for(i2=0;i20){inotrt=NNEW(int,2**nk*ngraph);} + if((strcmp1(&filab[0],"U ")==0)||(strcmp1(&filab[870],"PU ")==0)) + +// real and imaginary part of the displacements + + vt=NNEW(double,2*mt**nk*ngraph); + if(strcmp1(&filab[87],"NT ")==0) + t1t=NNEW(double,*nk*ngraph); + if((strcmp1(&filab[174],"S ")==0)||(strcmp1(&filab[1479],"PHS ")==0)|| + (strcmp1(&filab[1044],"ZZS ")==0)) + +// real and imaginary part of the stresses + + stnt=NNEW(double,2*6**nk*ngraph); + if(strcmp1(&filab[261],"E ")==0) + eent=NNEW(double,6**nk*ngraph); + if(strcmp1(&filab[348],"RF ")==0) + fnt=NNEW(double,mt**nk*ngraph); + if(strcmp1(&filab[522],"ENER")==0) + enernt=NNEW(double,*nk*ngraph); + if(strcmp1(&filab[1044],"ZZS ")==0) + stxt=NNEW(double,2*6*mi[0]**ne*ngraph); + + kont=NNEW(int,*nkon*ngraph); + ipkont=NNEW(int,*ne*ngraph); + for(l=0;l<*ne*ngraph;l++)ipkont[l]=-1; + lakont=NNEW(char,8**ne*ngraph); + inumt=NNEW(int,*nk*ngraph); + ielmatt=NNEW(int,*ne*ngraph); + + nkt=ngraph**nk; + net=ngraph**ne; + + /* copying the coordinates of the first sector */ + + for(l=0;l<3**nk;l++){cot[l]=co[l];} + if(*ntrans>0){for(l=0;l<*nk;l++){inotrt[2*l]=inotr[2*l];}} + for(l=0;l<*nkon;l++){kont[l]=kon[l];} + for(l=0;l<*ne;l++){ipkont[l]=ipkon[l];} + for(l=0;l<8**ne;l++){lakont[l]=lakon[l];} + for(l=0;l<*ne;l++){ielmatt[l]=ielmat[l];} + + /* generating the coordinates for the other sectors */ + + icntrl=1; + + FORTRAN(rectcyl,(cot,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filab,&imag,mi)); + + for(jj=0;jj<*mcs;jj++){ + is=cs[17*jj+4]; + for(i=1;i0){inotrt[2*l+i*2**nk]=inotrt[2*l];} + } + } + for(l=0;l<*nkon;l++){kont[l+i**nkon]=kon[l]+i**nk;} + for(l=0;l<*ne;l++){ + if(ielcs[l]==jj){ + if(ipkon[l]>=0){ + ipkont[l+i**ne]=ipkon[l]+i**nkon; + ielmatt[l+i**ne]=ielmat[l]; + for(l1=0;l1<8;l1++){ + l2=8*l+l1; + lakont[l2+i*8**ne]=lakon[l2]; + } + } + } + } + } + } + + icntrl=-1; + + FORTRAN(rectcyl,(cot,vt,fnt,stnt,qfnt,eent,cs,&nkt,&icntrl,t,filab,&imag,mi)); + + /* check that the tensor fields which are extrapolated from the + integration points are requested in global coordinates */ + + if(strcmp1(&filab[174],"S ")==0){ + if((strcmp1(&filab[179],"L")==0)&&(*norien>0)){ + printf("\n*WARNING in arpackcs: element fields in cyclic symmetry calculations\n cannot be requested in local orientations;\n the global orientation will be used \n\n"); + strcpy1(&filab[179],"G",1); + } + } + + if(strcmp1(&filab[261],"E ")==0){ + if((strcmp1(&filab[266],"L")==0)&&(*norien>0)){ + printf("\n*WARNING in arpackcs: element fields in cyclic symmetry calculation\n cannot be requested in local orientations;\n the global orientation will be used \n\n"); + strcpy1(&filab[266],"G",1); + } + } + + if(strcmp1(&filab[1479],"PHS ")==0){ + if((strcmp1(&filab[1484],"L")==0)&&(*norien>0)){ + printf("\n*WARNING in arpackcs: element fields in cyclic symmetry calculation\n cannot be requested in local orientations;\n the global orientation will be used \n\n"); + strcpy1(&filab[1484],"G",1); + } + } + + if(strcmp1(&filab[1653],"MAXS")==0){ + if((strcmp1(&filab[1658],"L")==0)&&(*norien>0)){ + printf("\n*WARNING in arpackcs: element fields in cyclic symmetry calculation\n cannot be requested in local orientations;\n the global orientation will be used \n\n"); + strcpy1(&filab[1658],"G",1); + } + } + + if(strcmp1(&filab[2523],"MAXE")==0){ + if((strcmp1(&filab[2528],"L")==0)&&(*norien>0)){ + printf("\n*WARNING in arpackcs: element fields in cyclic symmetry calculation\n cannot be requested in local orientations;\n the global orientation will be used \n\n"); + strcpy1(&filab[1658],"G",1); + } + } + + /* allocating fields for magnitude and phase information of + displacements and stresses */ + + if(strcmp1(&filab[870],"PU")==0){ + vr=NNEW(double,mt*nkt); + vi=NNEW(double,mt*nkt); + } + + if(strcmp1(&filab[1479],"PHS")==0){ + stnr=NNEW(double,6*nkt); + stni=NNEW(double,6*nkt); + } + + if(strcmp1(&filab[1566],"MAXU")==0){ + vmax=NNEW(double,4*nkt); + } + + if(strcmp1(&filab[1653],"MAXS")==0){ + stnmax=NNEW(double,7*nkt); + } + + if(strcmp1(&filab[2523],"MAXE")==0){ + eenmax=NNEW(double,7*nkt); + } + + /* start of output calculations */ + + lfin=0; + for(j=0;jd[j]) continue; + if(fmax>0.){ + if(fmax0)FORTRAN(writehe,(&j)); + + eei=NNEW(double,6*mi[0]**ne); + if(*nener==1){ + stiini=NNEW(double,6*mi[0]**ne); + enerini=NNEW(double,mi[0]**ne);} + +// memset(&v[0],0.,sizeof(double)*2*mt**nk); + DMEMSET(v,0,2*mt**nk,0.); + + for(k=0;k<*neq;k+=*neq/2){ + + for(i=0;i<6*mi[0]**ne;i++){eme[i]=0.;} + + if(k==0) {kk=0;kkv=0;kk6=0;kkx=0;if(*nprint>0)FORTRAN(writere,());} + else {kk=*nk;kkv=mt**nk;kk6=6**nk;kkx=6*mi[0]**ne; + if(*nprint>0)FORTRAN(writeim,());} + + /* generating the cyclic MPC's (needed for nodal diameters + different from 0 */ + + for(i=0;i<*nmpc;i++){ + index=ipompc[i]-1; + /* check whether thermal mpc */ + if(nodempc[3*index+1]==0) continue; + coefmpcnew[index]=coefmpc[index]; + while(1){ + index=nodempc[3*index+2]; + if(index==0) break; + index--; + + icomplex=0; + inode=nodempc[3*index]; + if(strcmp1(&labmpc[20*i],"CYCLIC")==0){ + icomplex=atoi(&labmpc[20*i+6]);} + else if(strcmp1(&labmpc[20*i],"SUBCYCLIC")==0){ + for(ij=0;ij<*mcs;ij++){ + lprev=cs[ij*17+13]; + ilength=cs[ij*17+3]; + FORTRAN(nident,(&ics[lprev],&inode,&ilength,&id)); + if(id!=0){ + if(ics[lprev+id-1]==inode){icomplex=ij+1;break;} + } + } + } + + if(icomplex!=0){ + idir=nodempc[3*index+1]; + idof=nactdof[mt*(inode-1)+idir]-1; + if(idof==-1){xreal=1.;ximag=1.;} + else{xreal=z[lint+idof];ximag=z[lint+idof+*neq/2];} + if(k==0) { + if(fabs(xreal)<1.e-30)xreal=1.e-30; + coefmpcnew[index]=coefmpc[index]* + (cs[17*(icomplex-1)+14]+ximag/xreal*cs[17*(icomplex-1)+15]);} + else { + if(fabs(ximag)<1.e-30)ximag=1.e-30; + coefmpcnew[index]=coefmpc[index]* + (cs[17*(icomplex-1)+14]-xreal/ximag*cs[17*(icomplex-1)+15]);} + } + else{coefmpcnew[index]=coefmpc[index];} + } + } + + if(*iperturb==0){ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,&v[kkv],&stn[kk6],inum, + &stx[kkx],elcon, + nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, + norien,orab,ntmat_,t0,t0,ithermal, + prestr,iprestr,filab,eme,&een[kk6],iperturb, + f,&fn[kkv],nactdof,&iout,qa,vold,&z[lint+k], + nodeboun,ndirboun,xboun,nboun,ipompc, + nodempc,coefmpcnew,labmpc,nmpc,nmethod,cam,neq,veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,&enern[kk],sti, + xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea,&reltime));} + else{ + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,&v[kkv],&stn[kk6],inum, + &stx[kkx],elcon, + nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, + norien,orab,ntmat_,t0,t1old,ithermal, + prestr,iprestr,filab,eme,&een[kk6],iperturb, + f,&fn[kkv],nactdof,&iout,qa,vold,&z[lint+k], + nodeboun,ndirboun,xboun,nboun,ipompc, + nodempc,coefmpcnew,labmpc,nmpc,nmethod,cam,neq,veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,&enern[kk],sti, + xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea,&reltime)); + } + + } + free(eei); + if(*nener==1){free(stiini);free(enerini);} + + if(strcmp1(&filab[1566],"MAXU")==0){ + + /* determining the ray vector; the components of the + ray vector are the coordinates of the node in node set + RAY */ + + iray=0; + for(i=0;i<*nset;i++){ + if(strcmp1(&set[81*i],"RAYN")==0){ + iray=ialset[istartset[i]-1]; + vray[0]=co[3*iray-3]; + vray[1]=co[3*iray-2]; + vray[2]=co[3*iray-1]; + break; + } + } + if(iray==0){ + printf("/n*ERROR in arpackcs: no light ray vector/n/n"); + FORTRAN(stop,()); + } + + /* initialization */ + + for(l1=0;l1<4**nk;l1++){vmax[l1]=0.;} + + /* vector p1 is a point on the rotation axis + vector p2 is a unit vector along the axis */ + + for(l2=0;l2<3;l2++){p1[l2]=cs[5+l2];} + for(l2=0;l2<3;l2++){p2[l2]=cs[8+l2]-p1[l2];} + dd=sqrt(p2[0]*p2[0]+p2[1]*p2[1]+p2[2]*p2[2]); + for(l2=0;l2<3;l2++){p2[l2]/=dd;} + + /* determine the time for the worst displacement + orthogonal to a give light ray vector ; */ + + for(l1=0;l1<*nk;l1++){ + + /* determining a vector through node (l1+1) and + orthogonal to the rotation axis */ + + for(l2=0;l2<3;l2++){q[l2]=co[3*l1+l2]-p1[l2];} + dd=q[0]*p2[0]+q[1]*p2[1]+q[2]*p2[2]; + for(l2=0;l2<3;l2++){q[l2]-=dd*p2[l2];} + + /* determining a vector tan orthogonal to vector q + and the ray vector */ + + tan[0]=q[1]*vray[2]-q[2]*vray[1]; + tan[1]=q[2]*vray[0]-q[0]*vray[2]; + tan[2]=q[0]*vray[1]-q[1]*vray[0]; + + printf("tangent= %d,%e,%e,%e\n",l1,tan[0],tan[1],tan[2]); + + worstumax=0.; + iworsttime=0; + for(l3=0;l3<360;l3++){ + ctl=cos(l3/constant); + stl=sin(l3/constant); + for(l2=1;l2<4;l2++){ + l=mt*l1+l2; + vl[l2]=ctl*v[l]-stl*v[l+mt**nk]; + } + + /* displacement component along the tangent vector + (no absolute value!) */ + + dd=vl[1]*tan[0]+vl[2]*tan[1]+vl[3]*tan[2]; + if(dd>worstumax){ + worstumax=dd; + iworsttime=l3; + } + } + ctl=cos(iworsttime/constant); + stl=sin(iworsttime/constant); + for(l2=1;l2<4;l2++){ + l=mt*l1+l2; + vl[l2]=ctl*v[l]-stl*v[l+mt**nk]; + } + vmax[4*l1]=1.*iworsttime; + vmax[4*l1+1]=vl[1]; + vmax[4*l1+2]=vl[2]; + vmax[4*l1+3]=vl[3]; + + } + } + + /* determine the worst principal stress anywhere + in the structure as a function of time; + the worst principal stress is the maximum + of the absolute value of the principal stresses */ + + if(strcmp1(&filab[1653],"MAXS")==0){ + + /* determining the set of nodes for the + worst principal stress calculation */ + + ielset=0; + for(i=0;i<*nset;i++){ + if(strcmp1(&set[81*i],"STRESSDOMAINN")==0){ + ielset=i+1; + break; + } + } + if(ielset==0){ + printf("\n*ERROR in arpackcs: no node set for MAXS\n"); + printf(" (must have the name STRESSDOMAIN)\n\n"); + FORTRAN(stop,()); + } + + for(i1=istartset[ielset-1]-1;i10){ + l1=ialset[i1]-1; + + worstpsmax=0.; + for(l3=0;l3<360;l3++){ + ctl=cos(l3/constant); + stl=sin(l3/constant); + for(l2=0;l2<6;l2++){ + l=6*l1+l2; + stnl[l2]=ctl*stn[l]-stl*stn[l+6**nk]; + } + + /* determining the eigenvalues */ + + v1=stnl[0]+stnl[1]+stnl[2]; + v2=stnl[1]*stnl[2]+stnl[0]*stnl[2]+stnl[0]*stnl[1]- + (stnl[5]*stnl[5]+stnl[4]*stnl[4]+stnl[3]*stnl[3]); + v3=stnl[0]*(stnl[1]*stnl[2]-stnl[5]*stnl[5]) + -stnl[3]*(stnl[3]*stnl[2]-stnl[4]*stnl[5]) + +stnl[4]*(stnl[3]*stnl[5]-stnl[4]*stnl[1]); + bb=v2-v1*v1/3.; + cc=-2.*v1*v1*v1/27.+v1*v2/3.-v3; + if(fabs(bb)<=1.e-10){ + if(fabs(cc)>1.e-10){ + al[0]=-pow(cc,(1./3.)); + }else{ + al[0]=0.; + } + al[1]=al[0]; + al[2]=al[0]; + }else{ + cm=2.*sqrt(-bb/3.); + cn=3.*cc/(cm*bb); + if(fabs(cn)>1.){ + if(cn>1.){ + cn=1.; + }else{ + cn=-1.; + } + } + tt=(atan2(sqrt(1.-cn*cn),cn))/3.; + al[0]=cm*cos(tt); + al[1]=cm*cos(tt+2.*pi/3.); + al[2]=cm*cos(tt+4.*pi/3.); + } + for(l2=0;l2<3;l2++){ + al[l2]+=v1/3.; + } + dd=fabs(al[0]); + if(fabs(al[1])>dd) dd=fabs(al[1]); + if(fabs(al[2])>dd) dd=fabs(al[2]); + if(dd>worstpsmax){ + worstpsmax=dd; + stnmax[7*l1]=dd; + for(l2=1;l2<7;l2++){ + stnmax[7*l1+l2]=stnl[l2-1]; + } + } + } + + }else{ + l1=ialset[i1-2]-1; + do{ + l1=l1-ialset[i1]; + if(l1>=ialset[i1-1]-1) break; + + worstpsmax=0.; + for(l3=0;l3<360;l3++){ + ctl=cos(l3/constant); + stl=sin(l3/constant); + for(l2=0;l2<6;l2++){ + l=6*l1+l2; + stnl[l2]=ctl*stn[l]-stl*stn[l+6**nk]; + } + + /* determining the eigenvalues */ + + v1=stnl[0]+stnl[1]+stnl[2]; + v2=stnl[1]*stnl[2]+stnl[0]*stnl[2]+stnl[0]*stnl[1]- + (stnl[5]*stnl[5]+stnl[4]*stnl[4]+stnl[3]*stnl[3]); + v3=stnl[0]*(stnl[1]*stnl[2]-stnl[5]*stnl[5]) + -stnl[3]*(stnl[3]*stnl[2]-stnl[4]*stnl[5]) + +stnl[4]*(stnl[3]*stnl[5]-stnl[4]*stnl[1]); + bb=v2-v1*v1/3.; + cc=-2.*v1*v1*v1/27.+v1*v2/3.-v3; + if(fabs(bb)<=1.e-10){ + if(fabs(cc)>1.e-10){ + al[0]=-pow(cc,(1./3.)); + }else{ + al[0]=0.; + } + al[1]=al[0]; + al[2]=al[0]; + }else{ + cm=2.*sqrt(-bb/3.); + cn=3.*cc/(cm*bb); + if(fabs(cn)>1.){ + if(cn>1.){ + cn=1.; + }else{ + cn=-1.; + } + } + tt=(atan2(sqrt(1.-cn*cn),cn))/3.; + al[0]=cm*cos(tt); + al[1]=cm*cos(tt+2.*pi/3.); + al[2]=cm*cos(tt+4.*pi/3.); + } + for(l2=0;l2<3;l2++){ + al[l2]+=v1/3.; + } + dd=fabs(al[0]); + if(fabs(al[1])>dd) dd=fabs(al[1]); + if(fabs(al[2])>dd) dd=fabs(al[2]); + if(dd>worstpsmax){ + worstpsmax=dd; + stnmax[7*l1]=dd; + for(l2=1;l2<7;l2++){ + stnmax[7*l1+l2]=stnl[l2-1]; + } + } + } + + }while(1); + } + } + } + + /* determine the worst principal strain anywhere + in the structure as a function of time; + the worst principal strain is the maximum + of the absolute value of the principal strains, + times its original sign */ + + if(strcmp1(&filab[2523],"MAXE")==0){ + + /* determining the set of nodes for the + worst principal strain calculation */ + + ielset=0; + for(i=0;i<*nset;i++){ + if(strcmp1(&set[81*i],"STRAINDOMAINN")==0){ + ielset=i+1; + break; + } + } + if(ielset==0){ + printf("\n*ERROR in arpackcs: no node set for MAXE\n"); + printf(" (must have the name STRAINDOMAIN)\n\n"); + FORTRAN(stop,()); + } + + for(i1=istartset[ielset-1]-1;i10){ + l1=ialset[i1]-1; + + worstpsmax=0.; + for(l3=0;l3<360;l3++){ + ctl=cos(l3/constant); + stl=sin(l3/constant); + for(l2=0;l2<6;l2++){ + l=6*l1+l2; + eenl[l2]=ctl*een[l]-stl*een[l+6**nk]; + } + + /* determining the eigenvalues */ + + v1=eenl[0]+eenl[1]+eenl[2]; + v2=eenl[1]*eenl[2]+eenl[0]*eenl[2]+eenl[0]*eenl[1]- + (eenl[5]*eenl[5]+eenl[4]*eenl[4]+eenl[3]*eenl[3]); + v3=eenl[0]*(eenl[1]*eenl[2]-eenl[5]*eenl[5]) + -eenl[3]*(eenl[3]*eenl[2]-eenl[4]*eenl[5]) + +eenl[4]*(eenl[3]*eenl[5]-eenl[4]*eenl[1]); + bb=v2-v1*v1/3.; + cc=-2.*v1*v1*v1/27.+v1*v2/3.-v3; + if(fabs(bb)<=1.e-10){ + if(fabs(cc)>1.e-10){ + al[0]=-pow(cc,(1./3.)); + }else{ + al[0]=0.; + } + al[1]=al[0]; + al[2]=al[0]; + }else{ + cm=2.*sqrt(-bb/3.); + cn=3.*cc/(cm*bb); + if(fabs(cn)>1.){ + if(cn>1.){ + cn=1.; + }else{ + cn=-1.; + } + } + tt=(atan2(sqrt(1.-cn*cn),cn))/3.; + al[0]=cm*cos(tt); + al[1]=cm*cos(tt+2.*pi/3.); + al[2]=cm*cos(tt+4.*pi/3.); + } + for(l2=0;l2<3;l2++){ + al[l2]+=v1/3.; + } + dd=fabs(al[0]); + if(fabs(al[1])>dd) dd=fabs(al[1]); + if(fabs(al[2])>dd) dd=fabs(al[2]); + if(dd>worstpsmax){ + worstpsmax=dd; + eenmax[7*l1]=dd; + for(l2=1;l2<7;l2++){ + eenmax[7*l1+l2]=eenl[l2-1]; + } + } + } + + }else{ + l1=ialset[i1-2]-1; + do{ + l1=l1-ialset[i1]; + if(l1>=ialset[i1-1]-1) break; + + worstpsmax=0.; + for(l3=0;l3<360;l3++){ + ctl=cos(l3/constant); + stl=sin(l3/constant); + for(l2=0;l2<6;l2++){ + l=6*l1+l2; + eenl[l2]=ctl*een[l]-stl*een[l+6**nk]; + } + + /* determining the eigenvalues */ + + v1=eenl[0]+eenl[1]+eenl[2]; + v2=eenl[1]*eenl[2]+eenl[0]*eenl[2]+eenl[0]*eenl[1]- + (eenl[5]*eenl[5]+eenl[4]*eenl[4]+eenl[3]*eenl[3]); + v3=eenl[0]*(eenl[1]*eenl[2]-eenl[5]*eenl[5]) + -eenl[3]*(eenl[3]*eenl[2]-eenl[4]*eenl[5]) + +eenl[4]*(eenl[3]*eenl[5]-eenl[4]*eenl[1]); + bb=v2-v1*v1/3.; + cc=-2.*v1*v1*v1/27.+v1*v2/3.-v3; + if(fabs(bb)<=1.e-10){ + if(fabs(cc)>1.e-10){ + al[0]=-pow(cc,(1./3.)); + }else{ + al[0]=0.; + } + al[1]=al[0]; + al[2]=al[0]; + }else{ + cm=2.*sqrt(-bb/3.); + cn=3.*cc/(cm*bb); + if(fabs(cn)>1.){ + if(cn>1.){ + cn=1.; + }else{ + cn=-1.; + } + } + tt=(atan2(sqrt(1.-cn*cn),cn))/3.; + al[0]=cm*cos(tt); + al[1]=cm*cos(tt+2.*pi/3.); + al[2]=cm*cos(tt+4.*pi/3.); + } + for(l2=0;l2<3;l2++){ + al[l2]+=v1/3.; + } + dd=fabs(al[0]); + if(fabs(al[1])>dd) dd=fabs(al[1]); + if(fabs(al[2])>dd) dd=fabs(al[2]); + if(dd>worstpsmax){ + worstpsmax=dd; + eenmax[7*l1]=dd; + for(l2=1;l2<7;l2++){ + eenmax[7*l1+l2]=eenl[l2-1]; + } + } + } + + }while(1); + } + } + } + + /* mapping the results to the other sectors */ + + for(l=0;l<*nk;l++){inumt[l]=inum[l];} + + icntrl=2;imag=1; + + FORTRAN(rectcyl,(co,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filab,&imag,mi)); + + if((strcmp1(&filab[0],"U ")==0)||(strcmp1(&filab[870],"PU ")==0)){ + for(l=0;l0){vi[l]=90.;} + else{vi[l]=-90.;} + } + else{ + vi[l]=atan(vimag/vreal)*constant; + if(vreal<0) vi[l]+=180.; + } + } + } + } + + /* determining magnitude and phase for the stress */ + + if(strcmp1(&filab[1479],"PHS")==0){ + for(l1=0;l10){stni[l]=90.;} + else{stni[l]=-90.;} + } + else{ + stni[l]=atan(stnimag/stnreal)*constant; + if(stnreal<0) stni[l]+=180.; + } + } + } + } + + ++*kode; + freq=d[j]/6.283185308; + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40*net);ipneigh=NNEW(int,nkt); + } + FORTRAN(out,(cot,&nkt,kont,ipkont,lakont,&net,vt,stnt,inumt,nmethod,kode, + filab,eent,t1t,fnt,&freq,epn,ielmatt,matname,enernt,xstaten,nstate_, + &istep,&iinc,iperturb,ener,mi,output,ithermal,qfn,&j,&nm, + trab,inotrt,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,stxt,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,&net,cs, + set,nset,istartset,iendset,ialset,eenmax)); + if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} + + } + + if((fmax>0.)&&(fmax>d[nev-1])){ + printf("\n*WARNING: not all frequencies in the requested interval might be found;\nincrease the number of requested frequencies\n"); + } + + free(adb);free(aub);free(temp_array);free(coefmpcnew); + + if((strcmp1(&filab[174],"S ")==0)||(strcmp1(&filab[1653],"MAXS")==0)|| + (strcmp1(&filab[1479],"PHS ")==0)||(strcmp1(&filab[1044],"ZZS ")==0)) + free(stn); + + free(v);free(fn);free(inum);free(stx);free(resid); + free(z);free(workd);free(workl);free(select);free(d); + + if((strcmp1(&filab[261],"E ")==0)||(strcmp1(&filab[2523],"MAXE")==0)) free(een); + if(strcmp1(&filab[522],"ENER")==0) free(enern); + + if((strcmp1(&filab[0],"U ")==0)||(strcmp1(&filab[870],"PU ")==0)) free(vt); + if(strcmp1(&filab[87],"NT ")==0) free(t1t); + if((strcmp1(&filab[174],"S ")==0)||(strcmp1(&filab[1479],"PHS ")==0)|| + (strcmp1(&filab[1044],"ZZS ")==0)) free(stnt); + if(strcmp1(&filab[261],"E ")==0) free(eent); + if(strcmp1(&filab[348],"RF ")==0) free(fnt); + if(strcmp1(&filab[522],"ENER")==0) free(enernt); + if(strcmp1(&filab[1044],"ZZS ")==0) free(stxt); + + free(cot);free(kont);free(ipkont);free(lakont);free(inumt);free(ielmatt); + if(*ntrans>0){free(inotrt);} + + if(mei[3]==1){ + (*nevtot)+=nev; + fclose(f1); + } + + } + + free(inocs);free(ielcs);free(xstiff); + free(ipobody); + + if(strcmp1(&filab[870],"PU")==0){free(vr);free(vi);} + if(strcmp1(&filab[1479],"PHS")==0){free(stnr);free(stni);} + if(strcmp1(&filab[1566],"MAXU")==0){free(vmax);} + if(strcmp1(&filab[1653],"MAXS")==0){free(stnmax);} + if(strcmp1(&filab[2523],"MAXE")==0){free(eenmax);} + + for(i=0;i<6*mi[0]**ne;i++){eme[i]=0.;} + + return; +} + +#endif diff -Nru calculix-ccx-2.1/ccx_2.3/src/attach.f calculix-ccx-2.3/ccx_2.3/src/attach.f --- calculix-ccx-2.1/ccx_2.3/src/attach.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/attach.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,351 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine attach(pneigh,pnode,nterms,ratio,dist,xil,etl) +! +! ataches node with coordinates in "pnode" to the face containing +! "nterms" nodes with coordinates in field "pneigh" (nterms < 9). +! cave: the coordinates are stored in pneigh(1..3,*) +! + implicit none +! + integer nterms,i,j,imin,jmin +! + real*8 ratio(8),pneigh(3,8),pnode(3),dummy, + & a(-1:1,-1:1),xi(-1:1,-1:1),et(-1:1,-1:1),p(3),aold(-1:1,-1:1), + & xiold(-1:1,-1:1),etold(-1:1,-1:1),distmin,xiopt,etopt, + & d1,d2,d3,d4,dist,xil,etl +! +c d1=0.25d0 +c d2=3.125d-2 +c d3=3.9063d-3 +c d4=1.d-3 + d1=1.d-2 + d2=1.d-4 + d3=1.d-6 + d4=1.d-8 +! +! initialisation +! + do i=-1,1 + do j=-1,1 + xi(i,j)=i*d1 + et(i,j)=j*d1 + call distattach(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, + & ratio,nterms) + enddo + enddo +! +! minimizing the distance from the face to the node +! + do + distmin=a(0,0) + imin=0 + jmin=0 + do i=-1,1 + do j=-1,1 + if(a(i,j).lt.distmin) then + distmin=a(i,j) + imin=i + jmin=j + endif + enddo + enddo +! +! exit if minimum found +! + if((imin.eq.0).and.(jmin.eq.0)) exit +! + do i=-1,1 + do j=-1,1 + aold(i,j)=a(i,j) + xiold(i,j)=xi(i,j) + etold(i,j)=et(i,j) + enddo + enddo +! + do i=-1,1 + do j=-1,1 + if((i+imin.ge.-1).and.(i+imin.le.1).and. + & (j+jmin.ge.-1).and.(j+jmin.le.1)) then + a(i,j)=aold(i+imin,j+jmin) + xi(i,j)=xiold(i+imin,j+jmin) + et(i,j)=etold(i+imin,j+jmin) + else + xi(i,j)=xi(i,j)+imin*d1 + et(i,j)=et(i,j)+jmin*d1 +! + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) +! + call distattach(xi(i,j),et(i,j),pneigh, + & pnode,a(i,j),p,ratio,nterms) +! write(*,*) a(i,j) + endif + enddo + enddo + enddo +! +! 2nd run +! initialisation +! + xiopt=xi(0,0) + etopt=et(0,0) + do i=-1,1 + do j=-1,1 + xi(i,j)=xiopt+i*d2 + et(i,j)=etopt+j*d2 + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) + call distattach(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, + & ratio,nterms) + enddo + enddo +! +! minimizing the distance from the face to the node +! + do + distmin=a(0,0) + imin=0 + jmin=0 + do i=-1,1 + do j=-1,1 + if(a(i,j).lt.distmin) then + distmin=a(i,j) + imin=i + jmin=j + endif + enddo + enddo +! +! exit if minimum found +! + if((imin.eq.0).and.(jmin.eq.0)) exit +! + do i=-1,1 + do j=-1,1 + aold(i,j)=a(i,j) + xiold(i,j)=xi(i,j) + etold(i,j)=et(i,j) + enddo + enddo +! + do i=-1,1 + do j=-1,1 + if((i+imin.ge.-1).and.(i+imin.le.1).and. + & (j+jmin.ge.-1).and.(j+jmin.le.1)) then + a(i,j)=aold(i+imin,j+jmin) + xi(i,j)=xiold(i+imin,j+jmin) + et(i,j)=etold(i+imin,j+jmin) + else + xi(i,j)=xi(i,j)+imin*d2 + et(i,j)=et(i,j)+jmin*d2 +! + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) +! + call distattach(xi(i,j),et(i,j),pneigh, + & pnode,a(i,j),p,ratio,nterms) +! write(*,*) a(i,j) + endif + enddo + enddo + enddo +! +! 3rd run +! initialisation +! + xiopt=xi(0,0) + etopt=et(0,0) + do i=-1,1 + do j=-1,1 + xi(i,j)=xiopt+i*d3 + et(i,j)=etopt+j*d3 + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) + call distattach(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, + & ratio,nterms) + enddo + enddo +! +! minimizing the distance from the face to the node +! + do + distmin=a(0,0) + imin=0 + jmin=0 + do i=-1,1 + do j=-1,1 + if(a(i,j).lt.distmin) then + distmin=a(i,j) + imin=i + jmin=j + endif + enddo + enddo +! +! exit if minimum found +! + if((imin.eq.0).and.(jmin.eq.0)) exit +! + do i=-1,1 + do j=-1,1 + aold(i,j)=a(i,j) + xiold(i,j)=xi(i,j) + etold(i,j)=et(i,j) + enddo + enddo +! + do i=-1,1 + do j=-1,1 + if((i+imin.ge.-1).and.(i+imin.le.1).and. + & (j+jmin.ge.-1).and.(j+jmin.le.1)) then + a(i,j)=aold(i+imin,j+jmin) + xi(i,j)=xiold(i+imin,j+jmin) + et(i,j)=etold(i+imin,j+jmin) + else + xi(i,j)=xi(i,j)+imin*d3 + et(i,j)=et(i,j)+jmin*d3 +! + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) +! + call distattach(xi(i,j),et(i,j),pneigh, + & pnode,a(i,j),p,ratio,nterms) +! write(*,*) a(i,j) + endif + enddo + enddo + enddo +! +! 4th run +! initialisation +! + xiopt=xi(0,0) + etopt=et(0,0) + do i=-1,1 + do j=-1,1 + xi(i,j)=xiopt+i*d4 + et(i,j)=etopt+j*d4 + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) + call distattach(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, + & ratio,nterms) + enddo + enddo +! +! minimizing the distance from the face to the node +! + do + distmin=a(0,0) + imin=0 + jmin=0 + do i=-1,1 + do j=-1,1 + if(a(i,j).lt.distmin) then + distmin=a(i,j) + imin=i + jmin=j + endif + enddo + enddo +! +! exit if minimum found +! + if((imin.eq.0).and.(jmin.eq.0)) exit +! + do i=-1,1 + do j=-1,1 + aold(i,j)=a(i,j) + xiold(i,j)=xi(i,j) + etold(i,j)=et(i,j) + enddo + enddo +! + do i=-1,1 + do j=-1,1 + if((i+imin.ge.-1).and.(i+imin.le.1).and. + & (j+jmin.ge.-1).and.(j+jmin.le.1)) then + a(i,j)=aold(i+imin,j+jmin) + xi(i,j)=xiold(i+imin,j+jmin) + et(i,j)=etold(i+imin,j+jmin) + else + xi(i,j)=xi(i,j)+imin*d4 + et(i,j)=et(i,j)+jmin*d4 +! + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) +! + call distattach(xi(i,j),et(i,j),pneigh, + & pnode,a(i,j),p,ratio,nterms) +! write(*,*) a(i,j) + endif + enddo + enddo + enddo +! + call distattach(xi(0,0),et(0,0),pneigh,pnode,a(0,0),p, + & ratio,nterms) +! + do i=1,3 + pnode(i)=p(i) + enddo +! + dist=a(0,0) +! + if(nterms.eq.3) then + xil=(xi(0,0)+1.d0)/2.d0 + etl=(et(0,0)+1.d0)/2.d0 + if(xil+etl.gt.1.d0) then + dummy=xil + xil=1.d0-etl + etl=1.d0-dummy + endif + elseif(nterms.eq.4) then + xil=xi(0,0) + etl=et(0,0) + elseif(nterms.eq.6) then + xil=(xi(0,0)+1.d0)/2.d0 + etl=(et(0,0)+1.d0)/2.d0 + if(xil+etl.gt.1.d0) then + dummy=xil + xil=1.d0-etl + etl=1.d0-dummy + endif + elseif(nterms.eq.8) then + xil=xi(0,0) + etl=et(0,0) + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/attachline.f calculix-ccx-2.3/ccx_2.3/src/attachline.f --- calculix-ccx-2.1/ccx_2.3/src/attachline.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/attachline.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,353 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine attachline(pneigh,pnode,nterms,ratio,dist,xil,etl,xn) +! +! finds the intersection of a straight line through the node +! with coordinates in pnode and direction vector xn with +! the face containing +! "nterms" nodes with coordinates in field "pneigh" (nterms < 9). +! cave: the coordinates are stored in pneigh(1..3,*) +! + implicit none +! + integer nterms,i,j,imin,jmin +! + real*8 ratio(8),pneigh(3,8),pnode(3),dummy, + & a(-1:1,-1:1),xi(-1:1,-1:1),et(-1:1,-1:1),p(3),aold(-1:1,-1:1), + & xiold(-1:1,-1:1),etold(-1:1,-1:1),distmin,xiopt,etopt, + & d1,d2,d3,d4,dist,xil,etl,xn(3) +! +c d1=0.25d0 +c d2=3.125d-2 +c d3=3.9063d-3 +c d4=1.d-3 + d1=1.d-1 + d2=1.d-2 + d3=1.d-4 + d4=1.d-6 +! +! initialisation +! + do i=-1,1 + do j=-1,1 + xi(i,j)=i*d1 + et(i,j)=j*d1 + call distattachline(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, + & ratio,nterms,xn) + enddo + enddo +! +! minimizing the distance from the face to the node +! + do + distmin=a(0,0) + imin=0 + jmin=0 + do i=-1,1 + do j=-1,1 + if(a(i,j).lt.distmin) then + distmin=a(i,j) + imin=i + jmin=j + endif + enddo + enddo +! +! exit if minimum found +! + if((imin.eq.0).and.(jmin.eq.0)) exit +! + do i=-1,1 + do j=-1,1 + aold(i,j)=a(i,j) + xiold(i,j)=xi(i,j) + etold(i,j)=et(i,j) + enddo + enddo +! + do i=-1,1 + do j=-1,1 + if((i+imin.ge.-1).and.(i+imin.le.1).and. + & (j+jmin.ge.-1).and.(j+jmin.le.1)) then + a(i,j)=aold(i+imin,j+jmin) + xi(i,j)=xiold(i+imin,j+jmin) + et(i,j)=etold(i+imin,j+jmin) + else + xi(i,j)=xi(i,j)+imin*d1 + et(i,j)=et(i,j)+jmin*d1 +! + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) +! + call distattachline(xi(i,j),et(i,j),pneigh, + & pnode,a(i,j),p,ratio,nterms,xn) +! write(*,*) a(i,j) + endif + enddo + enddo + enddo +! +! 2nd run +! initialisation +! + xiopt=xi(0,0) + etopt=et(0,0) + do i=-1,1 + do j=-1,1 + xi(i,j)=xiopt+i*d2 + et(i,j)=etopt+j*d2 + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) + call distattachline(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, + & ratio,nterms,xn) + enddo + enddo +! +! minimizing the distance from the face to the node +! + do + distmin=a(0,0) + imin=0 + jmin=0 + do i=-1,1 + do j=-1,1 + if(a(i,j).lt.distmin) then + distmin=a(i,j) + imin=i + jmin=j + endif + enddo + enddo +! +! exit if minimum found +! + if((imin.eq.0).and.(jmin.eq.0)) exit +! + do i=-1,1 + do j=-1,1 + aold(i,j)=a(i,j) + xiold(i,j)=xi(i,j) + etold(i,j)=et(i,j) + enddo + enddo +! + do i=-1,1 + do j=-1,1 + if((i+imin.ge.-1).and.(i+imin.le.1).and. + & (j+jmin.ge.-1).and.(j+jmin.le.1)) then + a(i,j)=aold(i+imin,j+jmin) + xi(i,j)=xiold(i+imin,j+jmin) + et(i,j)=etold(i+imin,j+jmin) + else + xi(i,j)=xi(i,j)+imin*d2 + et(i,j)=et(i,j)+jmin*d2 +! + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) +! + call distattachline(xi(i,j),et(i,j),pneigh, + & pnode,a(i,j),p,ratio,nterms,xn) +! write(*,*) a(i,j) + endif + enddo + enddo + enddo +! +! 3rd run +! initialisation +! + xiopt=xi(0,0) + etopt=et(0,0) + do i=-1,1 + do j=-1,1 + xi(i,j)=xiopt+i*d3 + et(i,j)=etopt+j*d3 + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) + call distattachline(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, + & ratio,nterms,xn) + enddo + enddo +! +! minimizing the distance from the face to the node +! + do + distmin=a(0,0) + imin=0 + jmin=0 + do i=-1,1 + do j=-1,1 + if(a(i,j).lt.distmin) then + distmin=a(i,j) + imin=i + jmin=j + endif + enddo + enddo +! +! exit if minimum found +! + if((imin.eq.0).and.(jmin.eq.0)) exit +! + do i=-1,1 + do j=-1,1 + aold(i,j)=a(i,j) + xiold(i,j)=xi(i,j) + etold(i,j)=et(i,j) + enddo + enddo +! + do i=-1,1 + do j=-1,1 + if((i+imin.ge.-1).and.(i+imin.le.1).and. + & (j+jmin.ge.-1).and.(j+jmin.le.1)) then + a(i,j)=aold(i+imin,j+jmin) + xi(i,j)=xiold(i+imin,j+jmin) + et(i,j)=etold(i+imin,j+jmin) + else + xi(i,j)=xi(i,j)+imin*d3 + et(i,j)=et(i,j)+jmin*d3 +! + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) +! + call distattachline(xi(i,j),et(i,j),pneigh, + & pnode,a(i,j),p,ratio,nterms,xn) +! write(*,*) a(i,j) + endif + enddo + enddo + enddo +! +! 4th run +! initialisation +! + xiopt=xi(0,0) + etopt=et(0,0) + do i=-1,1 + do j=-1,1 + xi(i,j)=xiopt+i*d4 + et(i,j)=etopt+j*d4 + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) + call distattachline(xi(i,j),et(i,j),pneigh,pnode,a(i,j),p, + & ratio,nterms,xn) + enddo + enddo +! +! minimizing the distance from the face to the node +! + do + distmin=a(0,0) + imin=0 + jmin=0 + do i=-1,1 + do j=-1,1 + if(a(i,j).lt.distmin) then + distmin=a(i,j) + imin=i + jmin=j + endif + enddo + enddo +! +! exit if minimum found +! + if((imin.eq.0).and.(jmin.eq.0)) exit +! + do i=-1,1 + do j=-1,1 + aold(i,j)=a(i,j) + xiold(i,j)=xi(i,j) + etold(i,j)=et(i,j) + enddo + enddo +! + do i=-1,1 + do j=-1,1 + if((i+imin.ge.-1).and.(i+imin.le.1).and. + & (j+jmin.ge.-1).and.(j+jmin.le.1)) then + a(i,j)=aold(i+imin,j+jmin) + xi(i,j)=xiold(i+imin,j+jmin) + et(i,j)=etold(i+imin,j+jmin) + else + xi(i,j)=xi(i,j)+imin*d4 + et(i,j)=et(i,j)+jmin*d4 +! + xi(i,j)=min(xi(i,j),1.d0) + xi(i,j)=max(xi(i,j),-1.d0) + et(i,j)=min(et(i,j),1.d0) + et(i,j)=max(et(i,j),-1.d0) +! + call distattachline(xi(i,j),et(i,j),pneigh, + & pnode,a(i,j),p,ratio,nterms,xn) +! write(*,*) a(i,j) + endif + enddo + enddo + enddo +! + call distattachline(xi(0,0),et(0,0),pneigh,pnode,a(0,0),p, + & ratio,nterms,xn) +! + do i=1,3 + pnode(i)=p(i) + enddo +! + dist=a(0,0) +! + if(nterms.eq.3) then + xil=(xi(0,0)+1.d0)/2.d0 + etl=(et(0,0)+1.d0)/2.d0 + if(xil+etl.gt.1.d0) then + dummy=xil + xil=1.d0-etl + etl=1.d0-dummy + endif + elseif(nterms.eq.4) then + xil=xi(0,0) + etl=et(0,0) + elseif(nterms.eq.6) then + xil=(xi(0,0)+1.d0)/2.d0 + etl=(et(0,0)+1.d0)/2.d0 + if(xil+etl.gt.1.d0) then + dummy=xil + xil=1.d0-etl + etl=1.d0-dummy + endif + elseif(nterms.eq.8) then + xil=xi(0,0) + etl=et(0,0) + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/bdfill.c calculix-ccx-2.3/ccx_2.3/src/bdfill.c --- calculix-ccx-2.1/ccx_2.3/src/bdfill.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/bdfill.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,204 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +/* + *Calculate the entries of Bd and Dd, and insert them into the data structure +*/ + +void bdfill(int **irowbdp, int *jqbd, + double **aubdp, double *bdd,int *nzsbd, int *ntie, int *ipkon, int *kon, + char *lakon, int *nslavnode, int *nmastnode, int *imastnode, + int *islavnode, int *islavsurf, int *imastsurf, double *pmastsurf, + int *itiefac, int *neq, int *nactdof, double *co, double *vold, + int *iponoels, int *inoels, int *mi, double *gapmints, double *gap, + double* pslavsurf,double* pslavdual){ + + int i, j, k,l,m, idof1,idofs,idofm, nodes, nodem, kflag,numb, + *mast1=NULL,number, *irowbd=NULL,ifree,mt=mi[1]+1,icounter,istart; + + double contribution=0.0, *aubd=NULL; + + irowbd = *irowbdp; aubd=*aubdp; + + ifree = 1; // position in the fieds FORTRAN condition + mast1=NNEW(int,*nzsbd); + + /* calculating the off-diagonal terms and storing them in aubd */ + + /* meaning of the fields in FORTRAN notation: + ipointer(i): points to an element in field aubd belonging to column i + aubd(ipointer(i)): value of that element + irowbd(ipointer(i)): row to which that element belongs + mast1(ipointer(i)): points to another element in field aubd belonging + to column i, unless zero. + */ + + for( i=0; i<*ntie; i++){ + for(j=nslavnode[i]; j0)&&(idofm>0)){ //insertion for active dofs + insertas(&irowbd, &mast1, &idofs, &idofm, &ifree, nzsbd, + &contribution, &aubd); + } + } + } + } + } + + *nzsbd=ifree-1; + /* Sort mast1, irowbd and aubd; + Outcome: the values in field aubd are sorted, column by + column; no sorting is done within the columns */ + + kflag = 2; + FORTRAN(isortiid, (mast1, irowbd, aubd, nzsbd, &kflag)); + /* fill in jqbd + jqbd(i): first element in field aubd belonging to column i */ + + j = 0; + for(i=0; i0){ + numb=jqbd[i+1]-jqbd[i]; + FORTRAN(isortid,(&irowbd[jqbd[i]-1],&aubd[jqbd[i]-1],&numb,&kflag)); + } + } + + number=5; + +// FORTRAN(writematrix,(aubd,bdd,irowbd,jqbd,&neq[1],&number)); + /*Calulation ot the real contribution*/ + + icounter=0; + + for (i=0;i0) + bdd[idof1-1]+=contribution; + } + } + } + + *irowbdp = irowbd; *aubdp=aubd; + + return; +} + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/beamsections.f calculix-ccx-2.3/ccx_2.3/src/beamsections.f --- calculix-ccx-2.1/ccx_2.3/src/beamsections.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/beamsections.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,294 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine beamsections(inpc,textpart,set,istartset,iendset, + & ialset,nset,ielmat,matname,nmat,ielorien,orname,norien, + & thicke,ipkon,iponor,xnor,ixfree, + & offset,lakon,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, + & ipoinpc) +! +! reading the input deck: *BEAM SECTION +! + implicit none +! + character*1 inpc(*) + character*4 section + character*8 lakon(*) + character*80 matname(*),orname(*),material,orientation + character*81 set(*),elset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),ielmat(*),ipoinpc(0:*), + & ielorien(*),ipkon(*),iline,ipol,inl,ipoinp(2,*),inp(3,*) +! + integer nset,nmat,norien,istep,istat,n,key,i,j,k,l,imaterial, + & iorientation,ipos,m,iponor(2,*),ixfree, + & indexx,indexe,irstrt +! + real*8 thicke(2,*),thickness1,thickness2,p(3),xnor(*),offset(2,*), + & offset1,offset2,dd +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) + & '*ERROR reading *BEAM SECTION: *SOLID SECTION should' + write(*,*) ' be placed before all step definitions' + stop + endif +! + offset1=0.d0 + offset2=0.d0 + orientation=' + & ' + section=' ' +! + do i=2,n + if(textpart(i)(1:9).eq.'MATERIAL=') then + material=textpart(i)(10:89) + elseif(textpart(i)(1:12).eq.'ORIENTATION=') then + orientation=textpart(i)(13:92) + elseif(textpart(i)(1:6).eq.'ELSET=') then + elset=textpart(i)(7:86) + elset(21:21)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + elseif(textpart(i)(1:8).eq.'SECTION=') then + if(textpart(i)(9:12).eq.'CIRC') then + section='CIRC' + elseif(textpart(i)(9:12).eq.'RECT') then + section='RECT' + else + write(*,*) + & '*ERROR reading *BEAM SECTION: unknown section' + stop + endif + elseif(textpart(i)(1:8).eq.'OFFSET1=') then + read(textpart(i)(9:28),'(f20.0)',iostat=istat) offset1 + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:8).eq.'OFFSET2=') then + read(textpart(i)(9:28),'(f20.0)',iostat=istat) offset2 + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + write(*,*) + & '*WARNING reading *BEAM SECTION: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! check whether a sections was defined +! + if(section.eq.' ') then + write(*,*) '*ERROR reading *BEAM SECTION: no section defined' + stop + endif +! +! check for the existence of the set,the material and orientation +! + do i=1,nmat + if(matname(i).eq.material) exit + enddo + if(i.gt.nmat) then + write(*,*) '*ERROR reading *BEAM SECTION: nonexistent material' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + imaterial=i +! + if(orientation.eq.' + & ') then + iorientation=0 + else + do i=1,norien + if(orname(i).eq.orientation) exit + enddo + if(i.gt.norien) then + write(*,*) + & '*ERROR reading *BEAM SECTION: nonexistent orientation' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iorientation=i + endif +! + do i=1,nset + if(set(i).eq.elset) exit + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR reading *BEAM SECTION: element set ',elset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! +! assigning the elements of the set the appropriate material, +! orientation number, section and offset(s) +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + if(lakon(ialset(j))(1:1).ne.'B') then + write(*,*) + & '*ERROR reading *BEAM SECTION: *BEAM SECTION can' + write(*,*) ' only be used for beam elements.' + write(*,*) ' Element ',ialset(j),' is not a beam el + &ement.' + stop + endif + ielmat(ialset(j))=imaterial + ielorien(ialset(j))=iorientation + offset(1,ialset(j))=offset1 + offset(2,ialset(j))=offset2 + if(section.eq.'RECT') then + lakon(ialset(j))(8:8)='R' + else + lakon(ialset(j))(8:8)='C' + endif + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + if(lakon(k)(1:1).ne.'B') then + write(*,*) + & '*ERROR reading *BEAM SECTION: *BEAM SECTION can' + write(*,*) ' only be used for beam elements.' + write(*,*) ' Element ',k,' is not a beam element + &.' + stop + endif + ielmat(k)=imaterial + ielorien(k)=iorientation + offset(1,k)=offset1 + offset(2,k)=offset2 + if(section.eq.'RECT') then + lakon(k)(8:8)='R' + else + lakon(k)(8:8)='C' + endif + enddo + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! +! assigning a thickness to the elements +! + read(textpart(1)(1:20),'(f20.0)',iostat=istat) thickness1 + if(istat.gt.0) then + write(*,*) + & '*ERROR reading *BEAM SECTION: first beam thickness is lacking' + call inputerror(inpc,ipoinpc,iline) + endif + if(n.gt.1) then + read(textpart(2)(1:20),'(f20.0)',iostat=istat) thickness2 + if(istat.gt.0) then + write(*,*) + & '*ERROR reading *BEAM SECTION: ', + & 'second beam thickness is lacking' + call inputerror(inpc,ipoinpc,iline) + endif + else + thickness2=thickness1 + endif + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + indexe=ipkon(ialset(j)) + do l=1,8 + thicke(1,indexe+l)=thickness1 + thicke(2,indexe+l)=thickness2 + enddo + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + indexe=ipkon(k) + do l=1,8 + thicke(1,indexe+l)=thickness1 + thicke(2,indexe+l)=thickness2 + enddo + enddo + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return +! +! assigning normal direction 1 for the beam +! + indexx=-1 + read(textpart(1)(1:20),'(f20.0)',iostat=istat) p(1) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) p(2) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) p(3) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + dd=dsqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3)) + if(dd.lt.1.d-10) then + write(*,*) + & '*ERROR reading *BEAM SECTION: normal in direction 1' + write(*,*) ' has zero size' + stop + endif + do j=1,3 + p(j)=p(j)/dd + enddo + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + indexe=ipkon(ialset(j)) + do l=1,8 + if(indexx.eq.-1) then + indexx=ixfree + do m=1,3 + xnor(indexx+m)=p(m) + enddo + ixfree=ixfree+6 + endif + iponor(1,indexe+l)=indexx + enddo + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + indexe=ipkon(k) + do l=1,8 + if(indexx.eq.-1) then + indexx=ixfree + do m=1,3 + xnor(indexx+m)=p(m) + enddo + ixfree=ixfree+6 + endif + iponor(1,indexe+l)=indexx + enddo + enddo + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/bodyadd.f calculix-ccx-2.3/ccx_2.3/src/bodyadd.f --- calculix-ccx-2.1/ccx_2.3/src/bodyadd.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/bodyadd.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,179 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine bodyadd(cbody,ibody,xbody,nbody,nbody_,set,label, + & iamplitude,xmagnitude,p1,p2,bodyf,xbodyold,lc) +! +! adds a volumetric dload condition to the data base +! + implicit none +! + character*20 label + character*81 set,cbody(*) +! + integer ibody(3,*),nbody,nbody_,id,iamplitude,ilabel,i,j,id1,lc +! + real*8 xbody(7,*),p1(3),p2(3),bodyf(3),xmagnitude,xbodyold(7,*), + & dd,p(3) +! +! assigning a number to the load type (stored in ibody(1,*)) +! + if(label(1:7).eq.'CENTRIF') then + ilabel=1 + elseif(label(1:4).eq.'GRAV') then + ilabel=2 + elseif(label(1:6).eq.'NEWTON') then + ilabel=3 + endif +! +! normalizing the direction for gravity forces +! + if(ilabel.eq.2) then + dd=dsqrt(bodyf(1)*bodyf(1)+bodyf(2)*bodyf(2)+bodyf(3)*bodyf(3)) + do i=1,3 + bodyf(i)=bodyf(i)/dd + enddo + endif +! +! checking whether a similar load type was already assigned to the +! same set +! + call cident(cbody,set,nbody,id) +! + if(id.ne.0) then + do + if(id.eq.0) exit + if(cbody(id).eq.set) then + if(ibody(1,id).eq.ilabel) then +! +! for gravity forces the gravity direction is +! checked; if the direction is different,it is +! a new loading +! + if(ilabel.eq.2) then + if(dabs(bodyf(1)*xbody(2,id)+bodyf(2)*xbody(3,id)+ + & bodyf(3)*xbody(4,id)-1.d0).gt.1.d-10) then + id=id-1 + cycle + endif + endif +! +! for centrifugal loads the centrifugal axis is +! checked +! + if(ilabel.eq.1) then + if(dabs(p2(1)*xbody(5,id)+p2(2)*xbody(6,id)+ + & p2(3)*xbody(7,id)-1.d0).gt.1.d-10) then + id=id-1 + cycle + endif + do i=1,3 + p(i)=xbody(1+i,id)-p1(i) + enddo + dd=dsqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3)) + if(dd.gt.1.d-10) then + do i=1,3 + p(i)=p(i)/dd + enddo + if(dabs(p(1)*xbody(5,id)+p(2)*xbody(6,id)+ + & p(3)*xbody(7,id)-1.d0).gt.1.d-10) then + id=id-1 + cycle + endif + endif + endif +! +! check for the same loadcase +! + if(ibody(3,id).ne.lc) then + id=id-1 + cycle + endif +! + ibody(2,id)=iamplitude + ibody(3,id)=lc + if(ilabel.eq.1) then + xbody(1,id)=xmagnitude + xbody(2,id)=p1(1) + xbody(3,id)=p1(2) + xbody(4,id)=p1(3) + xbody(5,id)=p2(1) + xbody(6,id)=p2(2) + xbody(7,id)=p2(3) + elseif(ilabel.eq.2) then + xbody(1,id)=xmagnitude + xbody(2,id)=bodyf(1) + xbody(3,id)=bodyf(2) + xbody(4,id)=bodyf(3) + endif + return + endif + id=id-1 + else + exit + endif + enddo + endif +! +! new set/loadtype combination +! + nbody=nbody+1 + if(nbody.gt.nbody_) then + write(*,*) '*ERROR in bodyadd: increase nbody_' + stop + endif +! +! reordering the arrays +! + do i=nbody,id+2,-1 + cbody(i)=cbody(i-1) + do j=1,3 + ibody(j,i)=ibody(j,i-1) + enddo + do j=1,7 + xbody(j,i)=xbody(j,i-1) + xbodyold(j,i)=xbodyold(j,i-1) + enddo + enddo +! +! inserting the new values +! + id1=id+1 +! + cbody(id1)=set + ibody(1,id1)=ilabel + ibody(2,id1)=iamplitude + ibody(3,id1)=lc + if(ilabel.eq.1) then + xbody(1,id1)=xmagnitude + xbody(2,id1)=p1(1) + xbody(3,id1)=p1(2) + xbody(4,id1)=p1(3) + xbody(5,id1)=p2(1) + xbody(6,id1)=p2(2) + xbody(7,id1)=p2(3) + elseif(ilabel.eq.2) then + xbody(1,id1)=xmagnitude + xbody(2,id1)=bodyf(1) + xbody(3,id1)=bodyf(2) + xbody(4,id1)=bodyf(3) + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/bodyforce.f calculix-ccx-2.3/ccx_2.3/src/bodyforce.f --- calculix-ccx-2.1/ccx_2.3/src/bodyforce.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/bodyforce.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,126 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine bodyforce(cbody,ibody,ipobody,nbody,set,istartset, + & iendset,ialset,inewton,nset,ifreebody,k) +! +! assigns the body forces to the elements by use of field ipobody +! + implicit none +! + character*81 cbody(*),elset,set(*) +! + integer ibody(3,*),ipobody(2,*),i,j,l,istartset(*),nbody, + & iendset(*),ialset(*),kindofbodyforce,inewton,nset,istat, + & ifreebody,k,index +! + elset=cbody(k) + kindofbodyforce=ibody(1,k) + if(kindofbodyforce.eq.3) inewton=1 +! +! check whether element number or set name +! + read(elset,'(i21)',iostat=istat) l + if(istat.eq.0) then + if(ipobody(1,l).eq.0) then + ipobody(1,l)=k + else +c + index=l + do + if(ipobody(1,index).eq.k) exit + if(ipobody(2,index).eq.0) then + ipobody(2,index)=ifreebody + ipobody(1,ifreebody)=k + ipobody(2,ifreebody)=0 + ifreebody=ifreebody+1 + exit + endif + index=ipobody(2,index) + enddo +c ipobody(2,ifreebody)=ipobody(2,l) +c ipobody(2,l)=ifreebody +c ipobody(1,ifreebody)=k +c ifreebody=ifreebody+1 + endif + return + endif +! +! set name +! + do i=1,nset + if(set(i).eq.elset) exit + enddo +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + l=ialset(j) + if(ipobody(1,l).eq.0) then + ipobody(1,l)=k + else +c + index=l + do + if(ipobody(1,index).eq.k) exit + if(ipobody(2,index).eq.0) then + ipobody(2,index)=ifreebody + ipobody(1,ifreebody)=k + ipobody(2,ifreebody)=0 + ifreebody=ifreebody+1 + exit + endif + index=ipobody(2,index) + enddo +c ipobody(2,ifreebody)=ipobody(2,l) +c ipobody(2,l)=ifreebody +c ipobody(1,ifreebody)=k +c ifreebody=ifreebody+1 + endif + else + l=ialset(j-2) + do + l=l-ialset(j) + if(l.ge.ialset(j-1)) exit + if(ipobody(1,l).eq.0) then + ipobody(1,l)=k + else +c + index=l + do + if(ipobody(1,index).eq.k) exit + if(ipobody(2,index).eq.0) then + ipobody(2,index)=ifreebody + ipobody(1,ifreebody)=k + ipobody(2,ifreebody)=0 + ifreebody=ifreebody+1 + exit + endif + index=ipobody(2,index) + enddo +c ipobody(2,ifreebody)=ipobody(2,l) +c ipobody(2,l)=ifreebody +c ipobody(1,ifreebody)=k +c ifreebody=ifreebody+1 + endif + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/bounadd.f calculix-ccx-2.3/ccx_2.3/src/bounadd.f --- calculix-ccx-2.1/ccx_2.3/src/bounadd.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/bounadd.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,264 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine bounadd(node,is,ie,val,nodeboun,ndirboun,xboun, + & nboun,nboun_,iamboun,iamplitude,nam,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, + & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc,type, + & typeboun,nmethod,iperturb,fixed,vold,nodetrue,mi) +! +! adds a boundary condition to the data base +! + implicit none +! + logical fixed +! + character*1 type,typeboun(*) + character*20 labmpc(*) +! + integer nodeboun(*),ndirboun(*),node,is,ie,nboun,nboun_,i,j, + & iamboun(*),iamplitude,nam,ipompc(*),nodempc(3,*),nmpc,nmpc_, + & mpcfree,inotr(2,*),ntrans,ikboun(*),ilboun(*),ikmpc(*), + & ilmpc(*),itr,idof,newnode,number,id,idofnew,idnew,nk,nk_, + & mpcfreenew,nmethod,iperturb,ii,nodetrue,mi(2) +! + real*8 xboun(*),val,coefmpc(*),trab(7,*),a(3,3),co(3,*), + & vold(0:mi(2),*) +! + if(ntrans.le.0) then + itr=0 + elseif(inotr(1,node).eq.0) then + itr=0 + else + itr=inotr(1,node) + endif +! + if((itr.eq.0).or.(is.eq.0).or.(is.eq.11).or.(is.eq.8)) then +! +! no transformation applies: simple SPC +! + loop: do ii=is,ie + if(ii.le.3) then + i=ii + elseif(ii.eq.4) then + i=5 + elseif(ii.eq.5) then + i=6 + elseif(ii.eq.6) then + i=7 + elseif(ii.eq.8) then + i=4 + elseif(ii.eq.11) then + i=0 + else + write(*,*) '*ERROR in bounadd: unknown DOF: ', + & ii + stop + endif + if((fixed).and.(i<5)) then + val=vold(i,nodetrue) + elseif(fixed) then + write(*,*) '*ERROR in bounadd: parameter FIXED cannot' + write(*,*) ' be used for rotations' + stop + endif + idof=8*(node-1)+i + call nident(ikboun,idof,nboun,id) + if(id.gt.0) then + if(ikboun(id).eq.idof) then + j=ilboun(id) + xboun(j)=val + typeboun(j)=type + if(nam.gt.0) iamboun(j)=iamplitude + cycle loop + endif + endif + nboun=nboun+1 + if(nboun.gt.nboun_) then + write(*,*) '*ERROR in bounadd: increase nboun_' + stop + endif + if((nmethod.eq.4).and.(iperturb.le.1)) then + write(*,*) '*ERROR in bounadd: in a modal dynamic step' + write(*,*) ' new SPCs are not allowed' + stop + endif + nodeboun(nboun)=node + ndirboun(nboun)=i + xboun(nboun)=val + typeboun(nboun)=type + if(nam.gt.0) iamboun(nboun)=iamplitude +! +! updating ikboun and ilboun +! + do j=nboun,id+2,-1 + ikboun(j)=ikboun(j-1) + ilboun(j)=ilboun(j-1) + enddo + ikboun(id+1)=idof + ilboun(id+1)=nboun + enddo loop + else +! +! transformation applies: SPC is MPC in global carthesian +! coordinates +! + call transformatrix(trab(1,itr),co(1,node),a) + do ii=is,ie + if(ii.le.3) then + i=ii + elseif(ii.eq.4) then + i=5 + elseif(ii.eq.5) then + i=6 + elseif(ii.eq.6) then + i=7 + elseif(ii.eq.8) then + i=4 + elseif(ii.eq.11) then + i=0 + else + write(*,*) '*ERROR in bounadd: unknown DOF: ', + & ii + stop + endif + if((fixed).and.(i<5)) then + val=vold(i,nodetrue) + elseif(fixed) then + write(*,*) '*ERROR in bounadd: parameter FIXED cannot' + write(*,*) ' be used for rotations' + stop + endif + if(inotr(2,node).ne.0) then + newnode=inotr(2,node) + idofnew=8*(newnode-1)+i + call nident(ikboun,idofnew,nboun,idnew) + if(idnew.gt.0) then + if(ikboun(idnew).eq.idofnew) then + j=ilboun(idnew) + xboun(j)=val + typeboun(j)=type + if(nam.gt.0) iamboun(j)=iamplitude + cycle + endif + endif + else +! +! new node is generated for the inhomogeneous MPC term +! + if((nmethod.eq.4).and.(iperturb.le.1)) then + write(*,*)'*ERROR in bounadd: in a modal dynamic step' + write(*,*) ' new SPCs are not allowed' + stop + endif + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in bounadd: increase nk_' + stop + endif + newnode=nk + inotr(2,node)=newnode + idofnew=8*(newnode-1)+i + idnew=nboun +! +! copying the initial conditions from node into newnode +! + do j=0,mi(2) + vold(j,newnode)=vold(j,node) + enddo +c write(*,*) ' bounadd ',nk,vold(0,nk),node,vold(0,node) + endif +! +! new mpc +! + do number=1,3 + idof=8*(node-1)+number + call nident(ikmpc,idof,nmpc,id) + if(id.ne.0) then + if(ikmpc(id).eq.idof) cycle + endif + if(dabs(a(number,i)).lt.1.d-5) cycle + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in bounadd: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + exit + enddo +! + number=number-1 + do j=1,3 + number=number+1 + if(number.gt.3) number=1 + if(dabs(a(number,i)).lt.1.d-5) cycle + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=number + coefmpc(mpcfree)=a(number,i) + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) '*ERROR in bounadd: increase nmpc_' + stop + endif + enddo + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=i + coefmpc(mpcfree)=-1.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) '*ERROR in bounadd: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew +! +! nonhomogeneous term +! + nboun=nboun+1 + if(nboun.gt.nboun_) then + write(*,*) '*ERROR in bounadd: increase nboun_' + stop + endif + nodeboun(nboun)=newnode + ndirboun(nboun)=i + xboun(nboun)=val + typeboun(nboun)=type + if(nam.gt.0) iamboun(nboun)=iamplitude +! +! updating ikboun and ilboun +! + do j=nboun,idnew+2,-1 + ikboun(j)=ikboun(j-1) + ilboun(j)=ilboun(j-1) + enddo + ikboun(idnew+1)=idofnew + ilboun(idnew+1)=nboun +! + enddo + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/boundaries.f calculix-ccx-2.3/ccx_2.3/src/boundaries.f --- calculix-ccx-2.1/ccx_2.3/src/boundaries.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/boundaries.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,346 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine boundaries(inpc,textpart,set,istartset,iendset, + & ialset,nset,nodeboun,ndirboun,xboun,nboun,nboun_,nk, + & iamboun,amname,nam,ipompc,nodempc,coefmpc,nmpc,nmpc_, + & mpcfree,inotr,trab,ntrans,ikboun,ilboun,ikmpc,ilmpc,nk_, + & co,labmpc,boun_flag,typeboun,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,nam_,namtot_,namta,amta,nmethod,iperturb, + & iaxial,ipoinpc,vold,mi) +! +! reading the input deck: *INITIAL CONDITIONS +! + implicit none +! + logical boun_flag,user,massflowrate,fixed +! + character*1 typeboun(*),type,inpc(*) + character*20 labmpc(*) + character*80 amname(*),amplitude + character*81 set(*),noset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),nodeboun(*),ndirboun(*), + & nset,nboun,nboun_,istep,istat,n,i,j,k,l,ibounstart,ibounend, + & key,nk,iamboun(*),nam,iamplitude,ipompc(*),nodempc(3,*), + & nmpc,nmpc_,mpcfree,inotr(2,*),ikboun(*),ilboun(*),ikmpc(*), + & ilmpc(*),nmpcold,id,idof,index1,ntrans,nk_,ipos,m,node,is,ie, + & iline,ipol,inl,ipoinp(2,*),inp(3,*),nam_,namtot,namtot_, + & namta(3,*),idelay,nmethod,iperturb,lc,iaxial,ipoinpc(0:*), + & ktrue,mi(2) +! + real*8 xboun(*),bounval,coefmpc(*),trab(7,*),co(3,*),amta(2,*), + & vold(0:mi(2),*) +! + type='B' + iamplitude=0 + idelay=0 + user=.false. + massflowrate=.false. + fixed=.false. + lc=1 +! + do i=2,n + if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.boun_flag)) then +! +! spc's in nonglobal coordinates result in mpc's +! removing these mpc's +! necessary and sufficient condition for a MPC to be removed: +! - on the dependent side a node "a" corresponding to SPC "b" +! (no matter which DOF); SPC "b" is applied in direction "c" of +! node "a" and corresponds to node "d" to account for the +! inhomogeneous term +! - on the independent side a term for node "d" in direction "c". +! + if(ntrans.gt.0) then + nmpcold=nmpc + do j=1,nk + if(inotr(2,j).gt.0) then + do k=1,3 + idof=8*(inotr(2,j)-1)+k + call nident(ikboun,idof,nboun,id) + if(id.gt.0) then + if(ikboun(id).eq.idof) then +! +! if a SPC is defined in direction k for a node j for which a +! local coordinate system applies, then the coordinate system +! number is stored in inotr(1,j) and the additional node +! for the inhomogeneous term is stored in inotr(2,j). The +! SPC DOF is (inotr(2,j)-1)*3+k, however, the independent +! MPC DOF is (j-1)*3+l, where l can be different from k, +! since (j-1)*3+k might already be taken by another MPC, or +! the coefficient for this direction might be zero. +! + loop: do l=1,3 + idof=8*(j-1)+l + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + index1=ipompc(ilmpc(id)) + if(index1.eq.0) cycle + do + if((nodempc(1,index1).eq. + & inotr(2,j)).and. + & (nodempc(2,index1).eq.k)) + & then + nodempc(3,index1)=mpcfree + mpcfree=ipompc(ilmpc(id)) + ipompc(ilmpc(id))=0 + do m=id,nmpc-1 + ikmpc(m)=ikmpc(m+1) + ilmpc(m)=ilmpc(m+1) + enddo + ikmpc(nmpc)=0 + ilmpc(nmpc)=0 + nmpc=nmpc-1 + exit + endif + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + enddo loop +! + endif + endif + enddo + endif + enddo +! +! getting rid of the superfluous lines in ipompc and labmpc +! + k=0 + do j=1,nmpcold + if(ipompc(j).ne.0) then + k=k+1 + ipompc(k)=ipompc(j) + labmpc(k)=labmpc(j) + index1=ipompc(j) + idof=8*(nodempc(1,index1)-1)+nodempc(2,index1) + call nident(ikmpc,idof,nmpc,id) + if(id.eq.0) then + write(*,*) '*ERROR in boundaries' + stop + elseif(ikmpc(id).ne.idof) then + write(*,*) '*ERROR in boundaries' + stop + endif + ilmpc(id)=k + endif + enddo + endif +! +! removing the boundary conditions defined by a *BOUNDARY +! statement +! + loop1: do + if(nboun.gt.0) then + do j=1,nboun + if(typeboun(j).eq.'B') then + node=nodeboun(j) + is=ndirboun(j) + ie=ndirboun(j) + call bounrem(node,is,ie,nodeboun,ndirboun,xboun, + & nboun,iamboun,nam,ikboun,ilboun,typeboun) + cycle loop1 + endif + enddo + exit + endif + exit + enddo loop1 +c nboun=0 + elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then + read(textpart(i)(11:90),'(a80)') amplitude + do j=nam,1,-1 + if(amname(j).eq.amplitude) then + iamplitude=j + exit + endif + enddo + if(j.eq.0) then + write(*,*)'*ERROR in boundaries: nonexistent amplitude' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iamplitude=j + elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN + if(idelay.ne.0) then + write(*,*) '*ERROR in boundaries: the parameter TIME' + write(*,*) ' DELAY is used twice in the same' + write(*,*) ' keyword; ' + call inputerror(inpc,ipoinpc,iline) + stop + else + idelay=1 + endif + nam=nam+1 + if(nam.gt.nam_) then + write(*,*) '*ERROR in boundaries: increase nam_' + stop + endif + amname(nam)=' + & ' + if(iamplitude.eq.0) then + write(*,*) '*ERROR in boundaries: time delay must be' + write(*,*) ' preceded by the amplitude parameter' + stop + endif + namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) + iamplitude=nam + if(nam.eq.1) then + namtot=0 + else + namtot=namta(2,nam-1) + endif + namtot=namtot+1 + if(namtot.gt.namtot_) then + write(*,*) '*ERROR boundaries: increase namtot_' + stop + endif + namta(1,nam)=namtot + namta(2,nam)=namtot + read(textpart(i)(11:30),'(f20.0)',iostat=istat) + & amta(1,namtot) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:9).eq.'LOADCASE=') then + read(textpart(i)(10:19),'(i10)',iostat=istat) lc + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(nmethod.ne.5) then + write(*,*) '*ERROR in boundaries: the parameter LOAD' + write(*,*) ' CASE is only allowed in STEADY STATE' + write(*,*) ' DYNAMICS calculations' + stop + endif + elseif(textpart(i)(1:4).eq.'USER') then + user=.true. + elseif(textpart(i)(1:8).eq.'MASSFLOW') then + massflowrate=.true. + elseif(textpart(i)(1:5).eq.'FIXED') then + fixed=.true. + else + write(*,*) + & '*WARNING in boundaries: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(user.and.(iamplitude.ne.0)) then + write(*,*) '*WARNING: no amplitude definition is allowed' + write(*,*) ' for temperatures defined by a' + write(*,*) ' user routine' + iamplitude=0 + endif +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return +! + read(textpart(2)(1:10),'(i10)',iostat=istat) ibounstart + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +c if(ibounstart.eq.11) ibounstart=0 +! + if(textpart(3)(1:1).eq.' ') then + ibounend=ibounstart + else + read(textpart(3)(1:10),'(i10)',iostat=istat) ibounend + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + endif +! + if(textpart(4)(1:1).eq.' ') then + bounval=0.d0 + else + read(textpart(4)(1:20),'(f20.0)',iostat=istat) bounval + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + endif + if((massflowrate).and.(iaxial.ne.0)) bounval=bounval/iaxial +! +! dummy temperature consisting of the first primes +! + if(user) bounval=1.2357111317d0 +! + read(textpart(1)(1:10),'(i10)',iostat=istat) l + if(istat.eq.0) then + if((l.gt.nk).or.(l.le.0)) then + write(*,*) '*ERROR in boundaries:' + write(*,*) ' node ',l,' is not defined' + stop + endif + ktrue=l + if(lc.ne.1) l=l+nk + call bounadd(l,ibounstart,ibounend,bounval, + & nodeboun,ndirboun,xboun,nboun,nboun_, + & iamboun,iamplitude,nam,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, + & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vold,ktrue,mi) + else + read(textpart(1)(1:80),'(a80)',iostat=istat) noset + noset(81:81)=' ' + ipos=index(noset,' ') + noset(ipos:ipos)='N' + do i=1,nset + if(set(i).eq.noset) exit + enddo + if(i.gt.nset) then + noset(ipos:ipos)=' ' + write(*,*) '*ERROR in boundaries: node set ',noset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + k=ialset(j) + ktrue=k + if(lc.ne.1) k=k+nk + call bounadd(k,ibounstart,ibounend,bounval, + & nodeboun,ndirboun,xboun,nboun,nboun_, + & iamboun,iamplitude,nam,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, + & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vold,ktrue,mi) + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + ktrue=k + if(lc.ne.1) k=k+nk + call bounadd(k,ibounstart,ibounend,bounval, + & nodeboun,ndirboun,xboun,nboun,nboun_, + & iamboun,iamplitude,nam,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, + & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_, + & labmpc,type,typeboun,nmethod,iperturb,fixed, + & vold,ktrue,mi) + enddo + endif + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/bounrem.f calculix-ccx-2.3/ccx_2.3/src/bounrem.f --- calculix-ccx-2.1/ccx_2.3/src/bounrem.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/bounrem.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,74 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine bounrem(node,is,ie,nodeboun,ndirboun,xboun, + & nboun,iamboun,nam,ikboun,ilboun,typeboun) +! +! removes boundary conditions in directions is up to and including +! ie in node "node" in the data base; no transformation is allowed +! in the node +! + implicit none +! + character*1 typeboun(*) +! + integer nodeboun(*),ndirboun(*),node,is,ie,nboun,i,j, + & iamboun(*),nam,ikboun(*),ilboun(*),idof,id,iboun +! + real*8 xboun(*) +! + do i=is,ie + idof=8*(node-1)+i + call nident(ikboun,idof,nboun,id) + if(id.gt.0) then + if(ikboun(id).eq.idof) then + iboun=ilboun(id) + do j=iboun,nboun-1 + nodeboun(j)=nodeboun(j+1) + ndirboun(j)=ndirboun(j+1) + xboun(j)=xboun(j+1) + typeboun(j)=typeboun(j+1) + if(nam.gt.0) iamboun(j)=iamboun(j+1) + enddo + do j=id,nboun-1 + ikboun(j)=ikboun(j+1) + ilboun(j)=ilboun(j+1) + enddo + do j=1,nboun-1 + if(ilboun(j).ge.iboun) then + ilboun(j)=ilboun(j)-1 + endif + enddo + nboun=nboun-1 + else + write(*,*) '*ERROR in bounrem: the boundary condition' + write(*,*) ' cannot be removed since it has' + write(*,*) ' not been defined' + stop + endif + else + write(*,*) '*ERROR in bounrem: the boundary condition' + write(*,*) ' cannot be removed since it has' + write(*,*) ' not been defined' + stop + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/buckles.f calculix-ccx-2.3/ccx_2.3/src/buckles.f --- calculix-ccx-2.1/ccx_2.3/src/buckles.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/buckles.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,165 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine buckles(inpc,textpart,nmethod,mei,fei, + & nforc,nload,ithermal,iprestr,nbody,t0,t1,nk,iperturb, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,isolver,ipoinpc) +! +! reading the input deck: *BUCKLE +! + implicit none +! + character*1 inpc(*) + character*20 solver + character*132 textpart(16) +! + integer nmethod,mei(4),istep,istat,n,key,ncv,mxiter, + & nforc,nload,ithermal,iprestr,i,nk,iperturb(2),iline,ipol,inl, + & ipoinp(2,*),inp(3,*),nev,isolver,nbody,ipoinpc(0:*) +! + real*8 fei(3),t0(*),t1(*),tol +! + if(istep.lt.1) then + write(*,*) '*ERROR in buckles: *BUCKLE can only be used' + write(*,*) ' within a STEP' + stop + endif +! +! no heat transfer analysis +! + if(ithermal.gt.1) then + ithermal=1 + endif +! +! default solver +! + solver=' ' + if(isolver.eq.0) then + solver(1:7)='SPOOLES' + elseif(isolver.eq.2) then + solver(1:16)='ITERATIVESCALING' + elseif(isolver.eq.3) then + solver(1:17)='ITERATIVECHOLESKY' + elseif(isolver.eq.4) then + solver(1:3)='SGI' + elseif(isolver.eq.5) then + solver(1:5)='TAUCS' + elseif(isolver.eq.7) then + solver(1:7)='PARDISO' + endif +! + do i=2,n + if(textpart(i)(1:7).eq.'SOLVER=') then + read(textpart(i)(8:27),'(a20)') solver + else + write(*,*) + & '*WARNING in buckles: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(solver(1:7).eq.'SPOOLES') then + isolver=0 + elseif(solver(1:16).eq.'ITERATIVESCALING') then + write(*,*) '*WARNING in frequencies: the iterative scaling' + write(*,*) ' procedure is not available for buckling' + write(*,*) ' calculations; the default solver is used' + elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then + write(*,*) '*WARNING in frequencies: the iterative scaling' + write(*,*) ' procedure is not available for buckling' + write(*,*) ' calculations; the default solver is used' + elseif(solver(1:3).eq.'SGI') then + isolver=4 + elseif(solver(1:5).eq.'TAUCS') then + isolver=5 + elseif(solver(1:7).eq.'PARDISO') then + isolver=7 + else + write(*,*) '*WARNING in buckles: unknown solver;' + write(*,*) ' the default solver is used' + endif +! + if((isolver.eq.2).or.(isolver.eq.3)) then + write(*,*) '*ERROR in buckles: the default solver ', + & solver + write(*,*) ' cannot be used for buckling calculations ' + stop + endif +! + nmethod=3 + if(iperturb(1).gt.1) iperturb(1)=0 + iperturb(2)=0 +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*) '*ERROR in buckles: definition not complete' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + read(textpart(1)(1:10),'(i10)',iostat=istat) nev + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(nev.le.0) then + write(*,*) '*ERROR in buckles: less than 1 eigenvalue re + &quested' + stop + endif + read(textpart(2)(1:20),'(f20.0)',iostat=istat) tol + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(tol.le.0.) then + tol=1.d-2 + endif + read(textpart(3)(1:10),'(i10)',iostat=istat) ncv + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(ncv.le.0) then + ncv=4*nev + endif + ncv=ncv+nev + read(textpart(4)(1:10),'(i10)',iostat=istat) mxiter + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(mxiter.le.0) then + mxiter=1000 + endif +! +! removing the natural boundary conditions +! + nforc=0 + nload=0 + nbody=0 + iprestr=0 + if(ithermal.eq.1) then + do i=1,nk + t1(i)=t0(i) + enddo + endif +! + mei(1)=nev + mei(2)=ncv + mei(3)=mxiter + fei(1)=tol +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/BUGS calculix-ccx-2.3/ccx_2.3/src/BUGS --- calculix-ccx-2.1/ccx_2.3/src/BUGS 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/BUGS 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,6 @@ +==== +BUGS Version 2.3 +==== + +- Ogden material with 2 or 3 equal eigenvalues does not work + properly diff -Nru calculix-ccx-2.1/ccx_2.3/src/calcmach.f calculix-ccx-2.3/ccx_2.3/src/calcmach.f --- calculix-ccx-2.1/ccx_2.3/src/calcmach.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/calcmach.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,64 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine calcmach(vold,voldcon,v,nk, + & ielmat,ntmat_,shcon,nshcon,rhcon,nrhcon,iout, + & nmethod,convergence,physcon,iponoel,inoel,ithermal, + & nactdoh,iit,compressible,ismooth,voldtu,vtu,turbulent, + & inomat,nodeboun,ndirboun,nboun,mi,co,factor) +! +! calculates +! vold (temperature,velocity and pressure) +! voldcon (volumetric energy density, volumetric momentum +! density and density) +! at the nodes +! +! prints if iout=1 +! + implicit none +! + integer convergence,compressible +! + integer nrhcon(*),ntmat_,nactdoh(0:4,*),iit,turbulent, + & nshcon(*),ielmat(*),nk,ithermal,i,j,k,index,iout, + & nmethod,imat,nelem,iponoel(*),inoel(3,*),ismooth, + & inomat(*),node,nodeboun(*),ndirboun(*),nboun,mi(2) +! + real*8 v(0:mi(2),*),vold(0:mi(2),*),voldcon(0:4,*), + & rhcon(0:1,ntmat_,*),rho,c1,vmax(0:4),dummy,press, + & voldmax(0:4),cp,r,temp,temp0,c2,c3,tempnew,vel2, + & shcon(0:3,ntmat_,*),drho,dtemp,physcon(*),dpress, + & voldtu(2,*),vtu(2,*),co(3,*),factor +! +! calculate the Mach number and store it in v(1,*) +! + do i=1,nk + imat=inomat(i) + temp=vold(0,i) + call materialdata_cp_sec(imat,ntmat_,temp,shcon, + & nshcon,cp,physcon) + r=shcon(3,1,imat) + vel2=vold(1,i)**2+vold(2,i)**2+vold(3,i)**2 + v(0,i)=cp/(cp-r) + v(1,i)=dsqrt((vold(1,i)**2+vold(2,i)**2+vold(3,i)**2) + & /(v(0,i)*r*(temp-physcon(1)))) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/calcresidual.c calculix-ccx-2.3/ccx_2.3/src/calcresidual.c --- calculix-ccx-2.1/ccx_2.3/src/calcresidual.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/calcresidual.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,121 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif + + +void calcresidual(int *nmethod, int *neq, double *b, double *fext, double *f, + int *iexpl, int *nactdof, double *aux1, double *aux2, double *vold, + double *vini, double *dtime, double *accold, int *nk, double *adb, + double *aub, int *icol, int *irow, int *nzl, double *alpha, + double *fextini, double *fini, int *islavnode, int *nslavnode, + int *imastnode, int *nmastnode, int *mortar, int *ntie,double *f_cm, + double* f_cs, int *mi){ + + int j,k,nodes,nodem,i,mt=mi[1]+1; + double scal1; + + /* residual for a static analysis */ + + if(*nmethod!=4){ + for(k=0;k +#include +#include +#include +#include "CalculiX.h" + +void calcshapef(int *nvar_, int *ipvar, double **varp, int *ne, + char *lakon, double *co, int *ipkon, int *kon, + int *nelemface, char *sideface, int *nface, + int *nvarf_, int *ipvarf, double **varfp){ + + /* determines the shape functions and their derivatives for + a fluid mesh and stores the results in ipvar and var */ + + int i,j,k,kk,nope,mint3d,iflag=3,nmethod=1,nvar,indexe,nelem, + mint2d,nopes,ig,nvarf,id; + + int ifaceq[48]= + {4,3,2,1,11,10,9,12, + 5,6,7,8,13,14,15,16, + 1,2,6,5,9,18,13,17, + 2,3,7,6,10,19,14,18, + 3,4,8,7,11,20,15,19, + 4,1,5,8,12,17,16,20}; + + int ifacet[24]= + {1,3,2,7,6,5, + 1,2,4,5,9,8, + 2,3,4,6,10,9, + 1,4,3,8,10,7}; + + int ifacew[40]= + {1,3,2,9,8,7,0,0, + 4,5,6,10,11,12,0,0, + 1,2,5,4,7,14,10,13, + 2,3,6,5,8,15,11,14, + 4,6,3,1,12,15,9,13}; + + double *var=NULL,xl[60],xi,et,ze,xsj,xl2[24],xs2[21],shp2[56],xsj2[3], + xi3d,et3d,ze3d,*varf=NULL; + + /* gauss points */ + + double gauss2d1[2]={0.,0.}; + + double gauss2d2[8]={ + -0.577350269189626,-0.577350269189626, + 0.577350269189626,-0.577350269189626, + -0.577350269189626,0.577350269189626, + 0.577350269189626,0.577350269189626}; + + double gauss2d3[18]={ + -0.774596669241483,-0.774596669241483, + -0.,-0.774596669241483, + 0.774596669241483,-0.774596669241483, + -0.774596669241483,0., + -0.,0., + 0.774596669241483,0., + -0.774596669241483,0.774596669241483, + -0.,0.774596669241483, + 0.774596669241483,0.774596669241483}; + + double gauss2d4[2]={0.333333333333333,0.333333333333333}; + + double gauss2d5[6]={ + 0.166666666666667,0.166666666666667, + 0.666666666666667,0.166666666666667, + 0.166666666666667,0.666666666666667}; + + double gauss3d1[3]={0.,0.,0.}; + + double gauss3d2[24]={ + -0.577350269189626,-0.577350269189626,-0.577350269189626, + 0.577350269189626,-0.577350269189626,-0.577350269189626, + -0.577350269189626,0.577350269189626,-0.577350269189626, + 0.577350269189626,0.577350269189626,-0.577350269189626, + -0.577350269189626,-0.577350269189626,0.577350269189626, + 0.577350269189626,-0.577350269189626,0.577350269189626, + -0.577350269189626,0.577350269189626,0.577350269189626, + 0.577350269189626,0.577350269189626,0.577350269189626}; + + double gauss3d3[81]={ + -0.774596669241483,-0.774596669241483,-0.774596669241483, + 0.,-0.774596669241483,-0.774596669241483, + 0.774596669241483,-0.774596669241483,-0.774596669241483, + -0.774596669241483,0.,-0.774596669241483, + 0.,0.,-0.774596669241483, + 0.774596669241483,0.,-0.774596669241483, + -0.774596669241483,0.774596669241483,-0.774596669241483, + 0.,0.774596669241483,-0.774596669241483, + 0.774596669241483,0.774596669241483,-0.774596669241483, + -0.774596669241483,-0.774596669241483,0., + 0.,-0.774596669241483,0., + 0.774596669241483,-0.774596669241483,0., + -0.774596669241483,0.,0., + 0.,0.,0., + 0.774596669241483,0.,0., + -0.774596669241483,0.774596669241483,0., + 0.,0.774596669241483,0., + 0.774596669241483,0.774596669241483,0., + -0.774596669241483,-0.774596669241483,0.774596669241483, + 0.,-0.774596669241483,0.774596669241483, + 0.774596669241483,-0.774596669241483,0.774596669241483, + -0.774596669241483,0.,0.774596669241483, + 0.,0.,0.774596669241483, + 0.774596669241483,0.,0.774596669241483, + -0.774596669241483,0.774596669241483,0.774596669241483, + 0.,0.774596669241483,0.774596669241483, + 0.774596669241483,0.774596669241483,0.774596669241483}; + + double gauss3d4[3]={0.25,0.25,0.25}; + + double gauss3d5[12]={ + 0.138196601125011,0.138196601125011,0.138196601125011, + 0.585410196624968,0.138196601125011,0.138196601125011, + 0.138196601125011,0.585410196624968,0.138196601125011, + 0.138196601125011,0.138196601125011,0.585410196624968}; + + double gauss3d7[6]={ + 0.333333333333333,0.333333333333333,-0.577350269189626, + 0.333333333333333,0.333333333333333,0.577350269189626}; + + double gauss3d8[27]={ + 0.166666666666667,0.166666666666667,-0.774596669241483, + 0.666666666666667,0.166666666666667,-0.774596669241483, + 0.166666666666667,0.666666666666667,-0.774596669241483, + 0.166666666666667,0.166666666666667,0., + 0.666666666666667,0.166666666666667,0., + 0.166666666666667,0.666666666666667,0., + 0.166666666666667,0.166666666666667,0.774596669241483, + 0.666666666666667,0.166666666666667,0.774596669241483, + 0.166666666666667,0.666666666666667,0.774596669241483}; + + double gauss3d11[3]={ + 0.333333333333333,0.333333333333333,0.}; + + double xlocal8r[18]={ + 0.000000000000000e+0, 0.000000000000000e+0,-0.100000000000000e+1 + , 0.000000000000000e+0, 0.000000000000000e+0, 0.100000000000000e+1 + , 0.000000000000000e+0,-0.100000000000000e+1, 0.000000000000000e+0 + , 0.100000000000000e+1, 0.000000000000000e+0, 0.000000000000000e+0 + , 0.000000000000000e+0, 0.100000000000000e+1, 0.000000000000000e+0 + ,-0.100000000000000e+1, 0.000000000000000e+0,0.000000000000000e+0}; + + double xlocal8[72]={ + -0.577350269189626e+0, 0.577350269189626e+0,-0.100000000000000e+1 + , 0.577350269189626e+0, 0.577350269189626e+0,-0.100000000000000e+1 + ,-0.577350269189626e+0,-0.577350269189626e+0,-0.100000000000000e+1 + , 0.577350269189626e+0,-0.577350269189626e+0,-0.100000000000000e+1 + ,-0.577350269189626e+0,-0.577350269189626e+0, 0.100000000000000e+1 + , 0.577350269189626e+0,-0.577350269189626e+0, 0.100000000000000e+1 + ,-0.577350269189626e+0, 0.577350269189626e+0, 0.100000000000000e+1 + , 0.577350269189626e+0, 0.577350269189626e+0, 0.100000000000000e+1 + ,-0.577350269189626e+0,-0.100000000000000e+1,-0.577350269189626e+0 + , 0.577350269189626e+0,-0.100000000000000e+1,-0.577350269189626e+0 + ,-0.577350269189626e+0,-0.100000000000000e+1, 0.577350269189626e+0 + , 0.577350269189626e+0,-0.100000000000000e+1, 0.577350269189626e+0 + , 0.100000000000000e+1,-0.577350269189626e+0,-0.577350269189626e+0 + , 0.100000000000000e+1, 0.577350269189626e+0,-0.577350269189626e+0 + , 0.100000000000000e+1,-0.577350269189626e+0, 0.577350269189626e+0 + , 0.100000000000000e+1, 0.577350269189626e+0, 0.577350269189626e+0 + , 0.577350269189626e+0, 0.100000000000000e+1,-0.577350269189626e+0 + ,-0.577350269189626e+0, 0.100000000000000e+1,-0.577350269189626e+0 + , 0.577350269189626e+0, 0.100000000000000e+1, 0.577350269189626e+0 + ,-0.577350269189626e+0, 0.100000000000000e+1, 0.577350269189626e+0 + ,-0.100000000000000e+1, 0.577350269189626e+0,-0.577350269189626e+0 + ,-0.100000000000000e+1,-0.577350269189626e+0,-0.577350269189626e+0 + ,-0.100000000000000e+1, 0.577350269189626e+0, 0.577350269189626e+0 + ,-0.100000000000000e+1,-0.577350269189626e+0,0.577350269189626e+0}; + + double xlocal20[162]={ + -0.774596669241483e+0, 0.774596669241483e+0,-0.100000000000000e+1 + , 0.000000000000000e+0, 0.774596669241483e+0,-0.100000000000000e+1 + , 0.774596669241483e+0, 0.774596669241483e+0,-0.100000000000000e+1 + ,-0.774596669241483e+0, 0.000000000000000e+0,-0.100000000000000e+1 + , 0.000000000000000e+0, 0.000000000000000e+0,-0.100000000000000e+1 + , 0.774596669241483e+0, 0.000000000000000e+0,-0.100000000000000e+1 + ,-0.774596669241483e+0,-0.774596669241483e+0,-0.100000000000000e+1 + , 0.000000000000000e+0,-0.774596669241483e+0,-0.100000000000000e+1 + , 0.774596669241483e+0,-0.774596669241483e+0,-0.100000000000000e+1 + ,-0.774596669241483e+0,-0.774596669241483e+0, 0.100000000000000e+1 + , 0.000000000000000e+0,-0.774596669241483e+0, 0.100000000000000e+1 + , 0.774596669241483e+0,-0.774596669241483e+0, 0.100000000000000e+1 + ,-0.774596669241483e+0, 0.000000000000000e+0, 0.100000000000000e+1 + , 0.000000000000000e+0, 0.000000000000000e+0, 0.100000000000000e+1 + , 0.774596669241483e+0, 0.000000000000000e+0, 0.100000000000000e+1 + ,-0.774596669241483e+0, 0.774596669241483e+0, 0.100000000000000e+1 + , 0.000000000000000e+0, 0.774596669241483e+0, 0.100000000000000e+1 + , 0.774596669241483e+0, 0.774596669241483e+0, 0.100000000000000e+1 + ,-0.774596669241483e+0,-0.100000000000000e+1,-0.774596669241483e+0 + , 0.000000000000000e+0,-0.100000000000000e+1,-0.774596669241483e+0 + , 0.774596669241483e+0,-0.100000000000000e+1,-0.774596669241483e+0 + ,-0.774596669241483e+0,-0.100000000000000e+1, 0.000000000000000e+0 + , 0.000000000000000e+0,-0.100000000000000e+1, 0.000000000000000e+0 + , 0.774596669241483e+0,-0.100000000000000e+1, 0.000000000000000e+0 + ,-0.774596669241483e+0,-0.100000000000000e+1, 0.774596669241483e+0 + , 0.000000000000000e+0,-0.100000000000000e+1, 0.774596669241483e+0 + , 0.774596669241483e+0,-0.100000000000000e+1, 0.774596669241483e+0 + , 0.100000000000000e+1,-0.774596669241483e+0,-0.774596669241483e+0 + , 0.100000000000000e+1, 0.000000000000000e+0,-0.774596669241483e+0 + , 0.100000000000000e+1, 0.774596669241483e+0,-0.774596669241483e+0 + , 0.100000000000000e+1,-0.774596669241483e+0, 0.000000000000000e+0 + , 0.100000000000000e+1, 0.000000000000000e+0, 0.000000000000000e+0 + , 0.100000000000000e+1, 0.774596669241483e+0, 0.000000000000000e+0 + , 0.100000000000000e+1,-0.774596669241483e+0, 0.774596669241483e+0 + , 0.100000000000000e+1, 0.000000000000000e+0, 0.774596669241483e+0 + , 0.100000000000000e+1, 0.774596669241483e+0, 0.774596669241483e+0 + , 0.774596669241483e+0, 0.100000000000000e+1,-0.774596669241483e+0 + , 0.000000000000000e+0, 0.100000000000000e+1,-0.774596669241483e+0 + ,-0.774596669241483e+0, 0.100000000000000e+1,-0.774596669241483e+0 + , 0.774596669241483e+0, 0.100000000000000e+1, 0.000000000000000e+0 + , 0.000000000000000e+0, 0.100000000000000e+1, 0.000000000000000e+0 + ,-0.774596669241483e+0, 0.100000000000000e+1, 0.000000000000000e+0 + , 0.774596669241483e+0, 0.100000000000000e+1, 0.774596669241483e+0 + , 0.000000000000000e+0, 0.100000000000000e+1, 0.774596669241483e+0 + ,-0.774596669241483e+0, 0.100000000000000e+1, 0.774596669241483e+0 + ,-0.100000000000000e+1, 0.774596669241483e+0,-0.774596669241483e+0 + ,-0.100000000000000e+1, 0.000000000000000e+0,-0.774596669241483e+0 + ,-0.100000000000000e+1,-0.774596669241483e+0,-0.774596669241483e+0 + ,-0.100000000000000e+1, 0.774596669241483e+0, 0.000000000000000e+0 + ,-0.100000000000000e+1, 0.000000000000000e+0, 0.000000000000000e+0 + ,-0.100000000000000e+1,-0.774596669241483e+0, 0.000000000000000e+0 + ,-0.100000000000000e+1, 0.774596669241483e+0, 0.774596669241483e+0 + ,-0.100000000000000e+1, 0.000000000000000e+0, 0.774596669241483e+0 + ,-0.100000000000000e+1,-0.774596669241483e+0,0.774596669241483e+0}; + + double xlocal4[12]={ + 0.333333333333333e+0, 0.333333333333333e+0, 0.000000000000000e+0 + , 0.333333333333333e+0, 0.000000000000000e+0, 0.333333333333333e+0 + , 0.333333333333334e+0, 0.333333333333333e+0, 0.333333333333333e+0 + , 0.000000000000000e+0, 0.333333333333333e+0,0.333333333333333e+0}; + + double xlocal10[36]={ + 0.166666666666667e+0, 0.166666666666667e+0, 0.000000000000000e+0 + , 0.166666666666667e+0, 0.666666666666667e+0, 0.000000000000000e+0 + , 0.666666666666667e+0, 0.166666666666667e+0, 0.000000000000000e+0 + , 0.166666666666667e+0, 0.000000000000000e+0, 0.166666666666667e+0 + , 0.666666666666667e+0, 0.000000000000000e+0, 0.166666666666667e+0 + , 0.166666666666667e+0, 0.000000000000000e+0, 0.666666666666667e+0 + , 0.666666666666666e+0, 0.166666666666667e+0, 0.166666666666667e+0 + , 0.166666666666666e+0, 0.666666666666667e+0, 0.166666666666667e+0 + , 0.166666666666666e+0, 0.166666666666667e+0, 0.666666666666667e+0 + , 0.000000000000000e+0, 0.166666666666667e+0, 0.166666666666667e+0 + , 0.000000000000000e+0, 0.166666666666667e+0, 0.666666666666667e+0 + , 0.000000000000000e+0, 0.666666666666667e+0,0.166666666666667e+0}; + + double xlocal6[15]={ + 0.333333333333333e+0, 0.333333333333333e+0,-0.100000000000000e+1 + , 0.333333333333333e+0, 0.333333333333333e+0, 0.100000000000000e+1 + , 0.500000000000000e+0, 0.000000000000000e+0, 0.000000000000000e+0 + , 0.500000000000000e+0, 0.500000000000000e+0, 0.000000000000000e+0 + , 0.000000000000000e+0, 0.500000000000000e+0,0.000000000000000e+0}; + + double xlocal15[60]={ + 0.166666666666667e+0, 0.166666666666667e+0,-0.100000000000000e+1 + , 0.166666666666667e+0, 0.666666666666667e+0,-0.100000000000000e+1 + , 0.666666666666667e+0, 0.166666666666667e+0,-0.100000000000000e+1 + , 0.,0.,0. + , 0.166666666666667e+0, 0.166666666666667e+0, 0.100000000000000e+1 + , 0.666666666666667e+0, 0.166666666666667e+0, 0.100000000000000e+1 + , 0.166666666666667e+0, 0.666666666666667e+0, 0.100000000000000e+1 + , 0.,0.,0. + , 0.211324865405187e+0, 0.000000000000000e+0,-0.577350269189626e+0 + , 0.788675134594813e+0, 0.000000000000000e+0,-0.577350269189626e+0 + , 0.211324865405187e+0, 0.000000000000000e+0, 0.577350269189626e+0 + , 0.788675134594813e+0, 0.000000000000000e+0, 0.577350269189626e+0 + , 0.788675134594813e+0, 0.211324865405187e+0,-0.577350269189626e+0 + , 0.211324865405187e+0, 0.788675134594813e+0,-0.577350269189626e+0 + , 0.788675134594813e+0, 0.211324865405187e+0, 0.577350269189626e+0 + , 0.211324865405187e+0, 0.788675134594813e+0, 0.577350269189626e+0 + , 0.000000000000000e+0, 0.211324865405187e+0, 0.577350269189626e+0 + , 0.000000000000000e+0, 0.788675134594813e+0, 0.577350269189626e+0 + , 0.000000000000000e+0, 0.211324865405187e+0,-0.577350269189626e+0 + , 0.000000000000000e+0,0.788675134594813e+0,-0.577350269189626e+0}; + + var=*varp; + varf=*varfp; + nvar=0; + nvarf=0; + + /* loop over all elements */ + + for(i=0;i<*ne;i++){ + + /* check for fluid elements */ + + if(strcmp1(&lakon[8*i],"F")!=0) continue; + + /* check whether element is actif */ + + if(ipkon[i]<0) continue; + + /* storing the beginning of the field for element i */ + + ipvar[i]=nvar; + ipvarf[i]=nvarf; + + /* determining the number of nodes belonging to the element + (nope) and the number of integration points (mint3d) */ + + if(strcmp1(&lakon[8*i+3],"20 ")==0){ + nope=20; + nopes=8; + mint2d=9; + mint3d=27; + }else if(strcmp1(&lakon[8*i+3],"20R")==0){ + nope=20; + nopes=8; + mint2d=4; + mint3d=8; + }else if(strcmp1(&lakon[8*i+3],"8 ")==0){ + nope=8; + nopes=4; + mint2d=4; + mint3d=8; + }else if(strcmp1(&lakon[8*i+3],"8R")==0){ + nope=8; + nopes=4; + mint2d=1; + mint3d=1; + }else if(strcmp1(&lakon[8*i+3],"10")==0){ + nope=10; + nopes=6; + mint2d=3; + mint3d=4; + }else if(strcmp1(&lakon[8*i+3],"4")==0){ + nope=4; + nopes=3; + mint2d=1; + mint3d=1; + }else if(strcmp1(&lakon[8*i+3],"15")==0){ + nope=15; + mint3d=9; + }else if(strcmp1(&lakon[8*i+3],"6 ")==0){ + nope=6; + mint3d=2; + }else if(strcmp1(&lakon[8*i+3],"6R")==0){ + nope=6; + mint3d=1; + }else{ + continue; + } + + /* copying the coordinates in a local field */ + + indexe=ipkon[i]; + for(j=0;j*nvar_){ + *nvar_=(int)(1.1**nvar_+5*nope+15); + RENEW(var,double,*nvar_); + } + + if(strcmp1(&lakon[8*i+3],"8R")==0){ + xi=gauss3d1[3*kk]; + et=gauss3d1[3*kk+1]; + ze=gauss3d1[3*kk+2]; + }else if((strcmp1(&lakon[8*i+3],"8")==0)|| + (strcmp1(&lakon[8*i+3],"20R")==0)){ + xi=gauss3d2[3*kk]; + et=gauss3d2[3*kk+1]; + ze=gauss3d2[3*kk+2]; + }else if(strcmp1(&lakon[8*i+3],"2")==0){ + xi=gauss3d3[3*kk]; + et=gauss3d3[3*kk+1]; + ze=gauss3d3[3*kk+2]; + }else if(strcmp1(&lakon[8*i+3],"10")==0){ + xi=gauss3d5[3*kk]; + et=gauss3d5[3*kk+1]; + ze=gauss3d5[3*kk+2]; + }else if(strcmp1(&lakon[8*i+3],"4")==0){ + xi=gauss3d4[3*kk]; + et=gauss3d4[3*kk+1]; + ze=gauss3d4[3*kk+2]; + }else if(strcmp1(&lakon[8*i+3],"15")==0){ + xi=gauss3d8[3*kk]; + et=gauss3d8[3*kk+1]; + ze=gauss3d8[3*kk+2]; + }else if(strcmp1(&lakon[8*i+3],"6R")==0){ + xi=gauss3d11[3*kk]; + et=gauss3d11[3*kk+1]; + ze=gauss3d11[3*kk+2]; + }else if(strcmp1(&lakon[8*i+3],"6")==0){ + xi=gauss3d7[3*kk]; + et=gauss3d7[3*kk+1]; + ze=gauss3d7[3*kk+2]; + } + + /* calculating the shape functions and their + derivatives */ + + if(nope==20){ + FORTRAN(shape20h,(&xi,&et,&ze,xl,&xsj,&var[nvar],&iflag)); + }else if(nope==8){ + FORTRAN(shape8h,(&xi,&et,&ze,xl,&xsj,&var[nvar],&iflag)); + }else if(nope==10){ + FORTRAN(shape10tet,(&xi,&et,&ze,xl,&xsj,&var[nvar],&iflag)); + }else if(nope==4){ + FORTRAN(shape4tet,(&xi,&et,&ze,xl,&xsj,&var[nvar],&iflag)); + }else if(nope==15){ + FORTRAN(shape15w,(&xi,&et,&ze,xl,&xsj,&var[nvar],&iflag)); + }else if(nope==6){ + FORTRAN(shape6w,(&xi,&et,&ze,xl,&xsj,&var[nvar],&iflag)); + } + + /* check the Jacobian determinant */ + + if(xsj<1.e-20){ + printf("*ERROR in calcshapef: nonpositive Jacobian\n"); + printf(" determinant in element %d\n\n",i); + xsj=fabs(xsj); + nmethod=0; + } + + /* storing the Jacobian determinant */ + + var[nvar+4*nope]=xsj; + + /* updating the pointer */ + + nvar+=5*nope+15; + + } + + /* free stream or solid surface boundaries */ + + if(*nface!=0){ + + nelem=i+1; + FORTRAN(nident,(nelemface,&nelem,nface,&id)); + + do{ + if(id==0) break; + if(nelemface[id-1]!=nelem) break; + ig=sideface[id-1]-'0'; + + /* treatment of wedge faces */ + + if(strcmp1(&lakon[8*i+3],"6")==0){ + mint2d=1; + if(ig<=2){ + nopes=3; + }else{ + nopes=4; + } + } + if(strcmp1(&lakon[8*i+3],"15")==0){ + mint2d=1; + if(ig<=2){ + mint2d=3; + nopes=6; + }else{ + mint2d=4; + nopes=8; + } + } + + /* storing the coordinates of the face nodes */ + + if((nope==20)||(nope==8)){ + for(j=0;j*nvarf_){ + *nvarf_=(int)(1.1**nvarf_+4*nope+nopes+7); + RENEW(varf,double,*nvarf_); + } + + if((strcmp1(&lakon[8*i+3],"8R")==0)|| + ((strcmp1(&lakon[8*i+3],"6")==0)&&(nopes==4))){ + xi=gauss2d1[2*kk]; + et=gauss2d1[2*kk+1]; + }else if((strcmp1(&lakon[8*i+3],"8")==0)|| + (strcmp1(&lakon[8*i+3],"20R")==0)|| + ((strcmp1(&lakon[8*i+3],"15")==0)&&(nopes==8))){ + xi=gauss2d2[2*kk]; + et=gauss2d2[2*kk+1]; + }else if(strcmp1(&lakon[8*i+3],"2")==0){ + xi=gauss2d3[2*kk]; + et=gauss2d3[2*kk+1]; + }else if((strcmp1(&lakon[8*i+3],"10")==0)|| + ((strcmp1(&lakon[8*i+3],"15")==0)&&(nopes==6))){ + xi=gauss2d5[2*kk]; + et=gauss2d5[2*kk+1]; + }else if((strcmp1(&lakon[8*i+3],"4")==0)|| + ((strcmp1(&lakon[8*i+3],"6")==0)&&(nopes==3))){ + xi=gauss2d4[2*kk]; + et=gauss2d4[2*kk+1]; + } + + /* local surface normal */ + + iflag=2; + if(nopes==8){ + FORTRAN(shape8q,(&xi,&et,xl2,xsj2,xs2,shp2,&iflag)); + }else if(nopes==4){ + FORTRAN(shape4q,(&xi,&et,xl2,xsj2,xs2,shp2,&iflag)); + }else if(nopes==6){ + FORTRAN(shape6tri,(&xi,&et,xl2,xsj2,xs2,shp2,&iflag)); + }else{ + FORTRAN(shape3tri,(&xi,&et,xl2,xsj2,xs2,shp2,&iflag)); + } + + /* copying the shape function values and the Jacobian + determinant into varf */ + + for(j=0;j0: input error) +! + logical boun_flag,cload_flag,dload_flag,temp_flag,elprint_flag, + & nodeprint_flag,elfile_flag,nodefile_flag,contactfile_flag, + & dflux_flag,cflux_flag,film_flag,radiate_flag,out3d, + & solid,network,faceprint_flag,contactprint_flag +! + character*1 typeboun(*),inpc(*) + character*3 output + character*87 filab(*) + character*6 prlab(*) + character*8 lakon(*) + character*20 labmpc(*),sideload(*) + character*80 matname(*),orname(*),amname(*) + character*81 set(*),prset(*),tieset(3,*),cbody(*) + character*132 jobnamec(*),textpart(16) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & nodeforc(2,*),ndirforc(*),nelemload(2,*),iaxial,j, + & istartset(*),iendset(*),ialset(*),ipkon(*),ics(*), + & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), + & namta(3,*),iamforc(*),iamload(2,*),iamt1(*),ipoinpc(0:*), + & iamboun(*),inotr(2,*),ikboun(*),ilboun(*),ikmpc(*),ilmpc(*), + & iponor(2,*),knor(*),ikforc(*),ilforc(*),iponoel(*),inoel(3,*), + & infree(4),ixfree,ikfree,inoelfree,iponoelmax,rig(*),nshcon(*), + & ncocon(2,*),nodebounold(*),ielprop(*),nprop,nprop_,maxsectors, + & ndirbounold(*),nnn(*),nline,ipoinp(2,*),inp(3,*), + & ianisoplas,cfd,ifile_output,ichangefriction +! + integer nalset,nalset_,nmat,nmat_,ntmat_,norien,norien_, + & nmethod,nk,ne,nboun,nmpc,nmpc_,mpcfree,i,istat,n, + & key,nk_,ne_,nboun_,ncs_,namtot_,nstate_,iviewfile, + & isolver,ithermal(2),iperturb(*),iprestr,istep,mei(4),nkon, + & nprint,nload,nload_,nforc,nforc_,nlabel,iumat,imat, + & nset,nset_,nprint_,nam,nam_,jout(2),ncmat_,itpamp, + & ierror,idrct,jmax(2),iexpl,iplas,npmat_,mi(2),ntrans,ntrans_, + & M_or_SPC,nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),nflow, + & memmpc_,ne1d,ne2d,nener,irstrt,ii,maxlenmpc,inl,ipol, + & iline,mcs,ntie,ntie_,lprev,newstep,nbody,nbody_,ibody(3,*) +! + real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),fmpc(*), + & xload(2,*),alzero(*),offset(2,*),prop(*), + & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*), + & alcon(0:6,ntmat_,*),thicke(2,*),thickn(2,*),xnor(*), + & t1(*),orab(7,*),prestr(6,mi(1),*),amta(2,*), + & veold(0:mi(2),*),t0(*),plicon(0:2*npmat_,ntmat_,*), + & plkcon(0:2*npmat_,ntmat_,*),trab(7,*),dcs(*), + & shcon(0:3,ntmat_,*),cocon(0:6,ntmat_,*), + & ctrl(*),vold(0:mi(2),*),xbounold(*),xforcold(*), + & xloadold(*),t1old(*),eme(*),sti(*),ener(*), + & xstate(nstate_,mi(1),*),ttime,qaold(2),cs(17,*),tietol(2,*), + & xbody(7,*),xbodyold(7,*) +! + real*8 fei(3),tinc,tper,xmodal(*),tmin,tmax, + & alpha,physcon(*) +! + save iaxial,solid,ianisoplas,network,out3d +! + integer nentries + parameter(nentries=14) +! + newstep=0 + iviewfile=0 + ichangefriction=0 +! + maxsectors=1 + if(mcs.ne.0) then + do i=1,mcs + maxsectors=max(maxsectors,int(cs(1,i))) + enddo + endif +! + do i=1,nentries + if(ipoinp(1,i).ne.0) then + ipol=i + inl=ipoinp(1,i) + iline=inp(1,inl)-1 + exit + endif + enddo +! + ixfree=infree(1) + ikfree=infree(2) + inoelfree=infree(3) + iponoelmax=infree(4) +! + iexpl=0 +! +! the following flag is used to check whether any SPC's or MPC's +! are used before transformation definitions +! + M_or_SPC=0 +! +! the flags indicate whether some specific keyword cards already +! occurred (needed to determine the effect of OP=NEW or to check +! whether the element or nodal output selection should be reset) +! + boun_flag=.false. + cload_flag=.false. + dload_flag=.false. + temp_flag=.false. + elprint_flag=.false. + nodeprint_flag=.false. + faceprint_flag=.false. + contactprint_flag=.false. + contactfile_flag=.false. + elfile_flag=.false. + nodefile_flag=.false. + film_flag=.false. + dflux_flag=.false. + radiate_flag=.false. + cflux_flag=.false. +! + nprint_=nprint +! + nprint=0 +! + if(istep.eq.0) then +! +! initializing the maxima +! + ne_=ne + nset_=nset + nalset_=nalset + nmat_=nmat + norien_=norien + ntrans_=ntrans + ntie_=ntie +! + nmethod=0 +! + ne=0 + nset=0 + nalset=0 + nmat=0 + norien=0 + ntrans=0 + ntie=0 +! + lprev=0 +! + do i=1,ne_ + ipkon(i)=-1 + enddo +! + if((ne1d.gt.0).or.(ne2d.gt.0)) then + do i=1,nlabel + filab(i)=' I ' + enddo + out3d=.false. + else + do i=1,nlabel + filab(i)=' ' + enddo + out3d=.true. + endif +! + iaxial=0 + solid=.false. + network=.false. + ianisoplas=0 +! + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + loop: do +! + if(istat.lt.0) then + write(*,*) + write(*,*) 'Job finished' + write(*,*) + return + endif +! + if(textpart(1)(1:10).eq.'*AMPLITUDE') then + call amplitudes(inpc,textpart,amname,amta,namta,nam, + & nam_,namtot_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, + & inp,ipoinpc) +! + elseif(textpart(1)(1:12).eq.'*BEAMSECTION') then + call beamsections(inpc,textpart,set,istartset,iendset, + & ialset,nset,ielmat,matname,nmat,ielorien,orname,norien, + & thicke,ipkon,iponor,xnor,ixfree, + & offset,lakon,irstrt,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:9).eq.'*BOUNDARY') then + M_or_SPC=1 + call boundaries(inpc,textpart,set,istartset,iendset, + & ialset,nset,nodeboun,ndirboun,xboun,nboun,nboun_,nk, + & iamboun,amname,nam,ipompc,nodempc,coefmpc,nmpc,nmpc_, + & mpcfree,inotr,trab,ntrans,ikboun,ilboun,ikmpc,ilmpc, + & nk_,co,labmpc,boun_flag,typeboun,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,nam_,namtot_,namta,amta,nmethod, + & iperturb,iaxial,ipoinpc,vold,mi) + boun_flag=.true. +! + elseif(textpart(1)(1:7).eq.'*BUCKLE') then + call buckles(inpc,textpart,nmethod,mei,fei, + & nforc,nload,ithermal,iprestr,nbody,t0,t1,nk,iperturb, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,isolver,ipoinpc) +! + elseif(textpart(1)(1:6).eq.'*CFLUX') then + call cfluxes(inpc,textpart,set,istartset,iendset, + & ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, + & amname,nam,ntrans,trab,inotr,co,ikforc,ilforc,nk, + & cflux_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_, + & namtot_,namta,amta,iaxial,ipoinpc) + cflux_flag=.true. +! + elseif(textpart(1)(1:15).eq.'*CHANGEFRICTION') then + ichangefriction=1 + call changefrictions(inpc,textpart,matname,nmat,nmat_, + & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,nrhcon, + & ipoinpc,imat) +! + elseif(textpart(1)(1:6).eq.'*CLOAD') then + call cloads(inpc,textpart,set,istartset,iendset, + & ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_, + & iamforc,amname,nam,ntrans,trab,inotr,co,ikforc,ilforc, + & nk,cload_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp, + & nam_,namtot_,namta,amta,nmethod,iaxial,iperturb,ipoinpc, + & maxsectors) + cload_flag=.true. +! + elseif(textpart(1)(1:13).eq.'*CONDUCTIVITY') then + call conductivities(inpc,textpart,cocon,ncocon, + & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:15).eq.'*CONTACTDAMPING') then + call contactdampings(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + elseif((textpart(1)(1:12).eq.'*CONTACTFILE').or. + & (textpart(1)(1:12).eq.'*CONTACTFILE')) then + ifile_output=3 + call noelfiles(inpc,textpart,jout,filab,nmethod, + & nodefile_flag,elfile_flag,ifile_output,nener,ithermal, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,out3d,nlabel, + & amname,nam,itpamp,idrct,ipoinpc,cfd,contactfile_flag, + & set,nset,xmodal) + contactfile_flag=.true. +! + elseif(textpart(1)(1:12).eq.'*CONTACTPAIR') then + call contactpairs(inpc,textpart,tieset,cs,istep, + & istat,n,iline,ipol,inl,ipoinp,inp,ntie,ntie_, + & iperturb,matname,nmat,ipoinpc,tietol,set,nset) +! + elseif(textpart(1)(1:13).eq.'*CONTACTPRINT') then + call contactprints(inpc,textpart,nprint,nprint_,jout, + & prlab,prset,contactprint_flag,ithermal,istep,istat,n, + & iline,ipol,inl,ipoinp,inp,amname,nam,itpamp,idrct, + & ipoinpc,nener) + contactprint_flag=.true. +! + elseif(textpart(1)(1:9).eq.'*CONTROLS') then + call controlss(inpc,textpart,ctrl,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:32).eq.'*COUPLEDTEMPERATURE-DISPLACEMENT') + & then + call couptempdisps(inpc,textpart,nmethod,iperturb,isolver, + & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline, + & ipol,inl,ipoinp,inp,ipoinpc,alpha,ctrl,iexpl) +! + elseif(textpart(1)(1:6).eq.'*CREEP') then + call creeps(inpc,textpart,nelcon,nmat,ntmat_,npmat_, + & plicon,nplicon,elcon,iplas,iperturb,nstate_,ncmat_, + & matname,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, + & ipoinpc,ianisoplas) +! + elseif(textpart(1)(1:16).eq.'*CYCLICHARDENING') then + call cychards(inpc,textpart,nelcon,nmat,ntmat_, + & npmat_,plicon,nplicon,ncmat_,elcon,matname, + & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! +c ics(15*ncx_+1) was removed: can be cleaned up. +c + elseif(textpart(1)(1:20).eq.'*CYCLICSYMMETRYMODEL') then + call cycsymmods(inpc,textpart,set,istartset,iendset, + & ialset,nset,tieset,tietol,co,nk,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,ikmpc,ilmpc,mpcfree,dcs(lprev+1), + & dcs(ncs_+lprev+1),ics(lprev+1),ics(ncs_+lprev+1), + & ics(2*ncs_+lprev+1),dcs(2*ncs_+lprev+1), + & dcs(3*ncs_+lprev+1),ncs_,cs,labmpc,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,ntie,mcs,lprev,ithermal, + & dcs(4*ncs_+1),dcs(6*ncs_+1),dcs(8*ncs_+1),dcs(10*ncs_+1), + & ics(3*ncs_+1),ics(5*ncs_+1),ics(7*ncs_+1),ics(8*ncs_+1), + & dcs(12*ncs_+1),ne,ipkon,kon,lakon,ics(14*ncs_+1), + & ics(16*ncs_+1),ics(18*ncs_+1),ipoinpc, + & maxsectors,trab,ntrans,ntrans_,jobnamec,vold,cfd,mi) +! + elseif(textpart(1)(1:8).eq.'*DASHPOT') then + call dashpots(inpc,textpart,nelcon,nmat,ntmat_,npmat_, + & plicon,nplicon, + & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,nmat_,set,istartset,iendset,ialset, + & nset,ielmat,ielorien,ipoinpc) +! + elseif(textpart(1)(1:22).eq.'*DEFORMATIONPLASTICITY') then + call defplasticities(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb, + & iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:8).eq.'*DENSITY') then + call densities(inpc,textpart,rhcon,nrhcon, + & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:7).eq.'*DEPVAR') then + call depvars(inpc,textpart,nelcon,nmat, + & nstate_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, + & ncocon,ipoinpc) +! + elseif(textpart(1)(1:6).eq.'*DFLUX') then + call dfluxes(inpc,textpart,set,istartset,iendset, + & ialset,nset,nelemload,sideload,xload,nload,nload_, + & ielmat,ntmat_,iamload,amname,nam,lakon,ne,dflux_flag, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_,namtot_, + & namta,amta,ipoinpc) + dflux_flag=.true. +! + elseif(textpart(1)(1:20).eq.'*DISTRIBUTEDCOUPLING') then + call distrubutedcouplings(inpc,textpart,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,nk,ikmpc,ilmpc, + & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc, + & lakon,kon,ipkon,set,nset,istartset,iendset,ialset,co) +! + elseif(textpart(1)(1:6).eq.'*DLOAD') then + call dloads(inpc,textpart,set,istartset,iendset, + & ialset,nset,nelemload,sideload,xload,nload,nload_, + & ielmat,iamload, + & amname,nam,lakon,ne,dload_flag,istep,istat,n, + & iline,ipol,inl,ipoinp,inp,cbody,ibody,xbody,nbody,nbody_, + & xbodyold,iperturb,physcon,nam_,namtot_,namta,amta,nmethod, + & ipoinpc,maxsectors) + dload_flag=.true. +! + elseif(textpart(1)(1:8).eq.'*DYNAMIC') then + call dynamics(inpc,textpart,nmethod,iperturb,tinc,tper, + & tmin,tmax,idrct,alpha,iexpl,isolver,istep, + & istat,n,iline,ipol,inl,ipoinp,inp,ithermal,ipoinpc,cfd) +! + elseif(textpart(1)(1:8).eq.'*ELASTIC') then + call elastics(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n, + & iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif((textpart(1)(1:8).eq.'*ELEMENT').and. + & (textpart(1)(1:14).ne.'*ELEMENTOUTPUT')) then + call elements(inpc,textpart,kon,ipkon,lakon,nkon, + & ne,ne_,set,istartset,iendset,ialset,nset,nset_,nalset, + & nalset_,mi(1),ixfree,iponor,xnor,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,iaxial,ipoinpc,solid,cfd, + & network) +! + elseif((textpart(1)(1:7).eq.'*ELFILE').or. + & (textpart(1)(1:14).eq.'*ELEMENTOUTPUT')) then + ifile_output=2 + call noelfiles(inpc,textpart,jout,filab,nmethod, + & nodefile_flag,elfile_flag,ifile_output,nener,ithermal, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,out3d,nlabel, + & amname,nam,itpamp,idrct,ipoinpc,cfd,contactfile_flag, + & set,nset,xmodal) + elfile_flag=.true. +! + elseif(textpart(1)(1:8).eq.'*ELPRINT') then + call elprints(inpc,textpart,set, + & nset,nprint,nprint_,jout, + & prlab,prset,nmethod,elprint_flag,nener,ithermal, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,amname,nam,itpamp, + & idrct,ipoinpc) + elprint_flag=.true. +! + elseif(textpart(1)(1:6).eq.'*ELSET') then + call noelsets(inpc,textpart,set,istartset,iendset,ialset, + & nset,nset_,nalset,nalset_,nk,ne,irstrt,istep,istat,n, + & iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:8).eq.'*ENDSTEP') then + exit +! + elseif(textpart(1)(1:9).eq.'*EQUATION') then + M_or_SPC=1 + call equations(inpc,textpart,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,nk,co,trab,inotr,ntrans,ikmpc,ilmpc, + & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:10).eq.'*EXPANSION') then + call expansions(inpc,textpart,alcon,nalcon, + & alzero,nmat,ntmat_,irstrt,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:10).eq.'*FACEPRINT') then + call faceprints(inpc,textpart,set,istartset,iendset,ialset, + & nset,nset_,nalset,nprint,nprint_,jout, + & prlab,prset,faceprint_flag,ithermal,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,amname,nam,itpamp,idrct,ipoinpc,cfd) + faceprint_flag=.true. +! + elseif(textpart(1)(1:5).eq.'*FILM') then + call films(inpc,textpart,set,istartset,iendset, + & ialset,nset,nelemload,sideload,xload,nload,nload_, + & ielmat,ntmat_,iamload,amname,nam,lakon,ne,film_flag, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_,namtot_, + & namta,amta,ipoinpc) + film_flag=.true. +! + elseif(textpart(1)(1:15).eq.'*FLUIDCONSTANTS') then + call fluidconstants(inpc,textpart,shcon,nshcon, + & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:13).eq.'*FLUIDSECTION') then + call fluidsections(inpc,textpart,set,istartset,iendset, + & ialset,nset,ielmat,matname,nmat, + & irstrt,istep,istat,n, + & iline,ipol,inl,ipoinp,inp,lakon,ielprop,nprop, + & nprop_,prop,iaxial,ipoinpc) +! + elseif(textpart(1)(1:10).eq.'*FREQUENCY') then + call frequencies(inpc,textpart,nmethod, + & mei,fei,iperturb,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,ithermal,isolver,xboun,nboun,ipoinpc) +! + elseif(textpart(1)(1:9).eq.'*FRICTION') then + call frictions(inpc,textpart,elcon,nelcon, + & imat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,ipoinpc,nstate_,ichangefriction) +! + elseif(textpart(1)(1:5).eq.'*GAP ') then + call gaps(inpc,textpart,set,istartset,iendset, + & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc, + & coefmpc,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon, + & ipkon,kon,nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,iperturb,ne_,co,xboun,ctrl,typeboun, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,iamboun,nam, + & inotr,trab,ntrans,nmethod,ipoinpc,mi) +! + elseif(textpart(1)(1:15).eq.'*GAPCONDUCTANCE') then + call gapconductances(inpc,textpart,nelcon,nmat,ntmat_, + & npmat_,plicon,nplicon,iperturb,irstrt,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:8).eq.'*HEADING') then + call headings(inpc,textpart,istat,n,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:13).eq.'*HEATTRANSFER') then + call heattransfers(inpc,textpart,nmethod,iperturb,isolver, + & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline, + & ipol,inl,ipoinp,inp,alpha,mei,fei,ipoinpc,ctrl,ttime) +! + elseif(textpart(1)(1:13).eq.'*HYPERELASTIC') then + call hyperelastics(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb, + & iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:10).eq.'*HYPERFOAM') then + call hyperfoams(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb,iline, + & ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:18).eq.'*INITIALCONDITIONS') then + call initialconditions(inpc,textpart,set,istartset,iendset, + & ialset,nset,t0,t1,prestr,iprestr,ithermal,veold,inoelfree, + & nk_,mi(1),istep,istat,n,iline,ipol,inl,ipoinp,inp,lakon, + & kon,co,ne,ipkon,vold,ipoinpc,xstate,nstate_) +! + elseif(textpart(1)(1:9).eq.'*MATERIAL') then + call materials(inpc,textpart,matname,nmat,nmat_, + & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:13).eq.'*MODALDAMPING') then + call modaldampings(inpc,textpart,nmethod,xmodal,istep, + & istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:13).eq.'*MODALDYNAMIC') then + call modaldynamics(inpc,textpart,nmethod,tinc,tper,iexpl, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,iperturb, + & isolver,cs,mcs,ipoinpc,idrct,ctrl,tmin,tmax, + & nforc,nload,nbody,iprestr,t0,t1,ithermal,nk,vold,veold, + & xmodal,set,nset,mi) +! + elseif(textpart(1)(1:12).eq.'*MODELCHANGE') then + call modelchanges(inpc,textpart,tieset,istat,n,iline, + & ipol,inl,ipoinp,inp,ntie,ipoinpc,istep) +! + elseif(textpart(1)(1:4).eq.'*MPC') then + call mpcs(inpc,textpart,set,istartset,iendset, + & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc, + & coefmpc,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon, + & ipkon,kon,nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,iperturb,ne_,co,xboun,ctrl,typeboun, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:11).eq.'*NOANALYSIS') then + call noanalysis(inpc,textpart,nmethod,iperturb,istep, + & istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc,tper) +! + elseif(textpart(1)(1:15).eq.'*NODALTHICKNESS') then + call nodalthicknesses(inpc,textpart,set,istartset,iendset, + & ialset,nset,thickn,nk,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,iaxial,ipoinpc) +! + elseif((textpart(1)(1:5).eq.'*NODE').and. + & (textpart(1)(1:10).ne.'*NODEPRINT').and. + & (textpart(1)(1:11).ne.'*NODEOUTPUT').and. + & (textpart(1)(1:9).ne.'*NODEFILE')) then + call nodes(inpc,textpart,co,nk,nk_,set,istartset,iendset, + & ialset,nset,nset_,nalset,nalset_,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,ipoinpc) +! + elseif((textpart(1)(1:9).eq.'*NODEFILE').or. + & (textpart(1)(1:11).eq.'*NODEOUTPUT')) then + ifile_output=1 + call noelfiles(inpc,textpart,jout,filab,nmethod, + & nodefile_flag,elfile_flag,ifile_output,nener,ithermal, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,out3d,nlabel, + & amname,nam,itpamp,idrct,ipoinpc,cfd,contactfile_flag, + & set,nset,xmodal) + nodefile_flag=.true. +! + elseif(textpart(1)(1:10).eq.'*NODEPRINT') then + call nodeprints(inpc,textpart,set,istartset,iendset,ialset, + & nset,nset_,nalset,nprint,nprint_,jout, + & prlab,prset,nodeprint_flag,ithermal,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,amname,nam,itpamp,idrct,ipoinpc,cfd) + nodeprint_flag=.true. +! + elseif(textpart(1)(1:7).eq.'*NORMAL') then + call normals(inpc,textpart,iponor,xnor,ixfree, + & ipkon,kon,nk,nk_,ne,lakon,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:5).eq.'*NSET') then + call noelsets(inpc,textpart,set,istartset,iendset,ialset, + & nset,nset_,nalset,nalset_,nk,ne,irstrt,istep,istat,n, + & iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:12).eq.'*ORIENTATION') then + call orientations(inpc,textpart,orname,orab,norien, + & norien_,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:18).eq.'*PHYSICALCONSTANTS') then + call physicalconstants(inpc,textpart,physcon, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:8).eq.'*PLASTIC') then + call plastics(inpc,textpart,nelcon,nmat,ntmat_,npmat_, + & plicon,nplicon,plkcon,nplkcon,iplas,iperturb,nstate_, + & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,ipoinpc,ianisoplas) +! + elseif(textpart(1)(1:19).eq.'*PRE-TENSIONSECTION') then + call pretensionsections(inpc,textpart,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,nk,ikmpc,ilmpc, + & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc, + & lakon,kon,ipkon,set,nset,istartset,iendset,ialset,co, + & ics,dcs) +! + elseif(textpart(1)(1:8).eq.'*RADIATE') then + call radiates(inpc,textpart,set,istartset,iendset, + & ialset,nset,nelemload,sideload,xload,nload,nload_, + & ielmat,ntmat_,iamload,amname,nam,lakon,ne,radiate_flag, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,physcon,nam_, + & namtot_,namta,amta,ipoinpc) + radiate_flag=.true. +! + elseif(textpart(1)(1:8).eq.'*RESTART') then + call restarts(istep,nset,nload,nforc, nboun,nk,ne, + & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint, + & mi(1),ntrans,ncs_,namtot_,ncmat_,mpcfree, + & maxlenmpc,ne1d, + & ne2d,nflow,nlabel,iplas,nkon,ithermal,nmethod, + & iperturb,nstate_,nener,set,istartset,iendset,ialset,co, + & kon,ipkon,lakon,nodeboun,ndirboun,iamboun,xboun,ikboun, + & ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, + & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc, + & nelemload,iamload,sideload,xload, + & elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,plicon, + & nplicon,plkcon,nplkcon,orname,orab,ielorien,trab,inotr, + & amname,amta,namta,t0,t1,iamt1,veold,ielmat, + & matname,prlab,prset,filab,vold,nodebounold, + & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, + & iponor,xnor,knor,thickn,thicke,offset,iponoel, + & inoel,rig,shcon,nshcon,cocon, + & ncocon,ics,sti,ener,xstate,jobnamec,infree,nnn, + & irstrt,inpc,textpart,istat,n,key,prestr,iprestr, + & cbody,ibody,xbody,nbody,xbodyold,ttime,qaold, + & cs,mcs,output,physcon,ctrl,typeboun,iline,ipol,inl, + & ipoinp,inp,fmpc,tieset,ntie,tietol,ipoinpc) +! + elseif(textpart(1)(1:10).eq.'*RIGIDBODY') then + call rigidbodies(inpc,textpart,set,istartset,iendset, + & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc, + & coefmpc,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon, + & ipkon,kon,nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,iperturb,ne_,ctrl,typeboun, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,co,ipoinpc) +! + elseif(textpart(1)(1:26).eq.'*SELECTCYCLICSYMMETRYMODES') then + call selcycsymmods(inpc,textpart,cs,ics,tieset,istartset, + & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc, + & ilmpc,mpcfree,mcs,set,nset,labmpc,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,nmethod,key,ipoinpc) +! + elseif(textpart(1)(1:13).eq.'*SHELLSECTION') then + call shellsections(inpc,textpart,set,istartset,iendset, + & ialset,nset,ielmat,matname,nmat,ielorien,orname, + & norien,thicke,kon,ipkon,offset,irstrt,istep,istat,n, + & iline,ipol,inl,ipoinp,inp,lakon,iaxial,ipoinpc) +! + elseif(textpart(1)(1:13).eq.'*SOLIDSECTION') then + call solidsections(inpc,textpart,set,istartset,iendset, + & ialset,nset,ielmat,matname,nmat,ielorien,orname, + & norien,lakon,thicke,kon,ipkon,irstrt,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,cs,mcs,iaxial,ipoinpc) +! + elseif(textpart(1)(1:20).eq.'*SPECIFICGASCONSTANT') then + call specificgasconstants(inpc,textpart,shcon,nshcon, + & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:13).eq.'*SPECIFICHEAT') then + call specificheats(inpc,textpart,shcon,nshcon, + & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:7).eq.'*SPRING') then + call springs(inpc,textpart,nelcon,nmat,ntmat_,npmat_, + & plicon,nplicon, + & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,nmat_,set,istartset,iendset,ialset, + & nset,ielmat,ielorien,ipoinpc) +! + elseif(textpart(1)(1:7).eq.'*STATIC') then + call statics(inpc,textpart,nmethod,iperturb,isolver,istep, + & istat,n,tinc,tper,tmin,tmax,idrct,iline,ipol,inl,ipoinp, + & inp,ithermal,cs,ics,tieset,istartset, + & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc, + & ilmpc,mpcfree,mcs,set,nset,labmpc,ipoinpc,iexpl,cfd,ttime, + & iaxial) +! + elseif(textpart(1)(1:20).eq.'*STEADYSTATEDYNAMICS') then + call steadystatedynamics(inpc,textpart,nmethod, + & iexpl,istep,istat,n,iline,ipol,inl,ipoinp,inp,iperturb, + & isolver,xmodal,cs,mcs,ipoinpc,nforc,nload,nbody,iprestr, + & t0,t1,ithermal,nk,set,nset) +! + elseif(textpart(1)(1:5).eq.'*STEP') then + call steps(inpc,textpart,iperturb,iprestr,nbody,nforc, + & nload,ithermal,t0,t1,nk,irstrt,istep,istat,n, + & jmax,ctrl,iline,ipol,inl,ipoinp,inp,newstep, + & ipoinpc,physcon) +! + elseif(textpart(1)(1:9).eq.'*SURFACE ') then + call surfaces(inpc,textpart,set,istartset,iendset,ialset, + & nset,nset_,nalset,nalset_,nk,ne,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,lakon,ipoinpc) +! + elseif(textpart(1)(1:16).eq.'*SURFACEBEHAVIOR') then + call surfacebehaviors(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:19).eq.'*SURFACEINTERACTION') then + call surfaceinteractions(inpc,textpart,matname,nmat,nmat_, + & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,nrhcon, + & ipoinpc,imat) +! + elseif(textpart(1)(1:12).eq.'*TEMPERATURE') then + call temperatures(inpc,textpart,set,istartset,iendset, + & ialset,nset,t0,t1,nk,ithermal,iamt1,amname,nam, + & inoelfree,nk_,nmethod,temp_flag,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,nam_,namtot_,namta,amta,ipoinpc) + temp_flag=.true. +! + elseif(textpart(1)(1:4).eq.'*TIE') then + call ties(inpc,textpart,tieset,tietol,istep, + & istat,n,iline,ipol,inl,ipoinp,inp,ntie,ntie_,ipoinpc) +! + elseif(textpart(1)(1:11).eq.'*TIMEPOINTS') then + call timepointss(inpc,textpart,amname,amta,namta,nam, + & nam_,namtot_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, + & inp,ipoinpc) +! + elseif(textpart(1)(1:10).eq.'*TRANSFORM') then + if(M_or_SPC.eq.1) then + write(*,*) '*WARNING in calinput: SPCs or MPCs have' + write(*,*) ' been defined before the definition' + write(*,*) ' of a transformation' + endif + call transforms(inpc,textpart,trab,ntrans,ntrans_, + & inotr,set,istartset,iendset,ialset,nset,istep,istat, + & n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:34).eq. + & '*UNCOUPLEDTEMPERATURE-DISPLACEMENT') then + call uncouptempdisps(inpc,textpart,nmethod,iperturb,isolver, + & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline, + & ipol,inl,ipoinp,inp,ipoinpc,alpha,ctrl) +! + elseif(textpart(1)(1:13).eq.'*USERMATERIAL') then + call usermaterials(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,iperturb,iumat,irstrt,istep,istat,n, + & iline,ipol,inl,ipoinp,inp,cocon,ncocon,ipoinpc) +! + elseif(textpart(1)(1:17).eq.'*VALUESATINFINITY') then + call valuesatinf(inpc,textpart,physcon, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! + elseif(textpart(1)(1:11).eq.'*VIEWFACTOR') then + call viewfactors(textpart,iviewfile,istep,inpc, + & istat,n,key,iline,ipol,inl,ipoinp,inp,jobnamec,ipoinpc) +! + elseif(textpart(1)(1:7).eq.'*VISCO') then + call viscos(inpc,textpart,nmethod,iperturb,isolver,istep, + & istat,n,tinc,tper,tmin,tmax,idrct,iline,ipol,inl,ipoinp, + & inp,ipoinpc) +! + elseif(inpc(iline-1).eq.inpc(iline)) then + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + else + write(*,*) '*WARNING in calinput. Card image cannot be inter + &preted:' + call inputwarning(inpc,ipoinpc,iline) + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + endif +! + enddo loop +! +! check whether the *END STEP card was preceded by a *STEP card +! + if(newstep.eq.0) then + write(*,*) '*ERROR in calinput: *END STEP card in step ', + & istep+1 + write(*,*) ' was not preceded by a *STEP card' + endif +! +! reorganizing the input in field inpc +! + j=1 + do + if(j.eq.1) then + inp(1,j)=iline+1 + else +c inp(1,j)=inp(1,inl)-iline + inp(1,j)=inp(1,inl) + endif +c inp(2,j)=inp(2,inl)-iline + inp(2,j)=inp(2,inl) + if(inp(3,inl).eq.0) then + inp(3,j)=0 + ipoinp(2,nentries)=j + exit + else + inl=inp(3,inl) + inp(3,j)=j+1 + j=j+1 + endif + enddo + do j=1,nentries-1 + ipoinp(1,j)=0 + enddo + ipoinp(1,nentries)=1 +c do j=iline+1,nline +c inpc(j-iline)=inpc(j) +c enddo +c nline=nline-iline +c call writeinput(inpc,ipoinp,inp,nline,ipoinp(2,12)) +! +! expanding the 1-D and 2-D elements to volume elements +! treating the incompressibility constraint +! + call gen3delem(kon,ipkon,lakon,ne,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,ikboun,ilboun,nboun, + & nboun_,nodeboun,ndirboun,xboun,iamboun,nam, + & inotr,trab,nk,nk_,iponoel,inoel,iponor,xnor,thicke,thickn, + & knor,istep,offset,t0,t1,ikforc,ilforc,rig,nforc, + & nforc_,nodeforc,ndirforc,xforc,iamforc,nelemload,sideload, + & nload,ithermal,ntrans,co,ixfree,ikfree,inoelfree,iponoelmax, + & iperturb,tinc,tper,tmin,tmax,ctrl,typeboun,nmethod,nset,set, + & istartset,iendset,ialset,prop,ielprop,vold,mi) +! +! New multistage Routine Call +! + call multistages(nkon,set,istartset,iendset, + & ialset,nset,tieset,tietol,co,nk,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,ikmpc,ilmpc,mpcfree,dcs(lprev+1), + & dcs(ncs_+lprev+1),ics(lprev+1),ics(ncs_+lprev+1), + & ics(2*ncs_+lprev+1),dcs(2*ncs_+lprev+1), + & dcs(3*ncs_+lprev+1),ncs_,cs,labmpc,ntie,mcs, + & dcs(4*ncs_+1),dcs(6*ncs_+1),dcs(8*ncs_+1),dcs(10*ncs_+1), + & ics(3*ncs_+1),ics(5*ncs_+1),ics(7*ncs_+1),ics(8*ncs_+1), + & dcs(12*ncs_+1),ne,ipkon,kon,lakon,ics(14*ncs_+1), + & ics(16*ncs_+1),ics(18*ncs_+1)) +! + infree(1)=ixfree + infree(2)=ikfree + infree(3)=inoelfree + infree(4)=iponoelmax +! +! check of the selected options +! + if(((iplas.eq.0).and.(ianisoplas.eq.0)).or.(nmethod.eq.2)) then + if(filab(6)(1:4).eq.'PEEQ') then + write(*,*) '*WARNING in calinput: PEEQ-output requested' + write(*,*) ' yet no (visco)plastic calculation' + filab(6)=' ' + endif + ii=0 + do i=1,nprint + if(prlab(i)(1:4).eq.'PEEQ') then + write(*,*) '*WARNING in calinput: PEEQ-output requested' + write(*,*) ' yet no (visco)plastic calculation' + cycle + endif + ii=ii+1 + prlab(ii)=prlab(i) + prset(ii)=prset(i) + enddo + nprint=ii + endif +! + if(ithermal(1).eq.0) then + if(filab(2)(1:2).eq.'NT') then + write(*,*) '*WARNING in calinput: temperature output' + write(*,*) ' requested, yet no thermal loading' + write(*,*) ' active' + filab(2)=' ' + endif + ii=0 + do i=1,nprint + if(prlab(i)(1:4).eq.'NT ') then + write(*,*) '*WARNING in calinput: temperature output' + write(*,*) ' requested, yet no thermal loading' + write(*,*) ' active' + cycle + endif + ii=ii+1 + prlab(ii)=prlab(i) + prset(ii)=prset(i) + enddo + nprint=ii + endif +! + if(ithermal(1).le.1) then + if(filab(9)(1:3).eq.'HFL') then + write(*,*) '*WARNING in calinput: heat flux output' + write(*,*) ' requested, yet no heat transfer' + write(*,*) ' calculation' + filab(9)=' ' + endif + if(filab(10)(1:3).eq.'RFL') then + write(*,*) '*WARNING in calinput: heat source output' + write(*,*) ' requested, yet no heat transfer' + write(*,*) ' calculation' + filab(10)=' ' + endif + if(filab(14)(1:2).eq.'MF') then + write(*,*) '*WARNING in calinput: mass flow output' + write(*,*) ' requested, yet no heat transfer' + write(*,*) ' calculation' + filab(14)=' ' + endif + if(filab(15)(1:2).eq.'PT') then + write(*,*) '*WARNING in calinput: total pressure output' + write(*,*) ' requested, yet no heat transfer' + write(*,*) ' calculation' + filab(15)=' ' + endif + if(filab(16)(1:2).eq.'TT') then + write(*,*) '*WARNING in calinput: total temperature output' + write(*,*) ' requested, yet no heat transfer' + write(*,*) ' calculation' + filab(16)=' ' + endif + endif +! +! check whether a material was assigned to each active element +! + ierror=0 + do i=1,ne + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).eq.'G') cycle + if(ielmat(i).eq.0) then + ierror=1 + write(*,*) '*ERROR in calinput: no material was assigned' + write(*,*) ' to element ',i + endif + enddo + if(ierror.eq.1) stop +! +! check whether the density was defined for dynamic calculations +! and transient thermal calculations +! + if(((nbody.gt.0).or. + & (nmethod.eq.2).or.(nmethod.eq.4)).and.(cfd.eq.0)) then + ierror=0 + do i=1,nmat + if((nrhcon(i).ne.0).or.(matname(i)(1:6).eq.'SPRING').or. + & (matname(i)(1:7).eq.'DASHPOT')) then + ierror=ierror+1 + else + write(*,*)'*WARNING in calinput: no density was assigned' + write(*,*) ' to material ', + & matname(i)(1:index(matname(i),' ')-1), + & ' in a dynamic' + write(*,*) ' calculation or a calculation with' + write(*,*) ' centrifugal or gravitational loads' + endif + enddo + if(ierror.eq.0) then + write(*,*) '*ERROR in calinput: no density was assigned' + write(*,*) ' to any material ', + & ' in a dynamic' + write(*,*) ' calculation or a calculation with' + write(*,*) ' centrifugal or gravitational loads' + stop + endif + endif +! +! check whether the specific heat was defined for +! transient thermal calculations +! + if((nmethod.eq.2).or.(nmethod.eq.4)) then + if(ithermal(1).ge.2) then + ierror=0 + do i=1,nmat + if(nshcon(i).ne.0) then + ierror=ierror+1 + else + write(*,*) '*WARNING in calinput: no specific heat ' + write(*,*) ' was assigned to material ', + & matname(i)(1:index(matname(i),' ')-1), + & ' in a transient' + write(*,*) ' heat transfer calculation' + write(*,*) + endif + enddo + if(ierror.eq.0) then + write(*,*) '*ERROR in calinput: no specific heat was' + write(*,*) ' assigned to any material ', + & ' in a transient' + write(*,*) ' heat transfer calculation' + stop + endif + endif + endif +! +! check whether a *FLUID CONSTANTS card was used for +! 3D compressible fluid calculations +! + if((cfd.eq.1).or.network) then + ierror=0 + do i=1,nmat + if(nshcon(i).ne.0) then + ierror=ierror+1 + else + write(*,*) '*WARNING in calinput: no specific heat ' + write(*,*) ' was assigned to material ', + & matname(i)(1:index(matname(i),' ')-1), + & ' in a transient' + write(*,*) ' heat transfer calculation' + write(*,*) + endif + enddo + if(ierror.eq.0) then + write(*,*) '*ERROR in calinput: no specific heat was' + write(*,*) ' assigned to any material ', + & ' in a transient' + write(*,*) ' heat transfer calculation' + stop + endif + endif +! +! check whether the elastic constants were defined for +! mechanical calculations +! + if((ithermal(1).ne.2).and.solid) then + ierror=0 + do i=1,nmat + if(nelcon(1,i).ne.0) then + ierror=ierror+1 + else + write(*,*)'*WARNING in calinput: no elastic constants ' + write(*,*)' were assigned to material ', + & matname(i)(1:index(matname(i),' ')-1) + write(*,*) ' in a (thermo)mechanical calculation' + write(*,*) + endif + enddo + if(ierror.eq.0) then + write(*,*) '*ERROR in calinput: no elastic constants' + write(*,*) ' were assigned to any material in a' + write(*,*) ' (thermo)mechanical calculation' + stop + endif + endif +! +! check whether the conductivity was defined for thermal calculations +! + if((ithermal(1).ge.2).and.(cfd.eq.0)) then + ierror=0 + do i=1,nmat + if(ncocon(1,i).ne.0) then + ierror=ierror+1 + else + write(*,*) '*WARNING in calinput: no conductivity ' + write(*,*) + & ' constants were assigned to material ', + & matname(i)(1:index(matname(i),' ')-1) + write(*,*) ' in a thermo(mechanical) calculation' + write(*,*) + endif + enddo + endif +! + if(cfd.eq.1) then + if(iperturb(1).eq.0) then + iperturb(1)=2 + elseif(iperturb(1).eq.1) then + write(*,*) '*ERROR in calinput: PERTURBATION and fluids' + write(*,*) ' are mutually exclusive; ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + endif +! + write(*,*) + write(*,*) 'STEP ',istep + write(*,*) + if(nmethod.eq.0) then + write(*,*) 'No analysis was selected' + elseif(nmethod.eq.1) then + write(*,*) 'Static analysis was selected' + elseif(nmethod.eq.2) then + write(*,*) 'Frequency analysis was selected' + elseif(nmethod.eq.3) then + write(*,*) 'Buckling analysis was selected' + elseif(nmethod.eq.4) then + write(*,*) 'Dynamic analysis was selected' + endif + write(*,*) + if(iperturb(1).eq.1) then + write(*,*) 'Perturbation parameter is active' + write(*,*) + elseif(iperturb(1).eq.2) then + write(*,*) 'Nonlinear geometric effects are taken into account' + write(*,*) + elseif(iperturb(1).eq.3) then + write(*,*) 'Nonlinear geometric effects and nonlinear ' + write(*,*) 'material laws are taken into account' + write(*,*) + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/carbon_seal.f calculix-ccx-2.3/ccx_2.3/src/carbon_seal.f --- calculix-ccx-2.1/ccx_2.3/src/carbon_seal.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/carbon_seal.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,192 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine carbon_seal(node1,node2,nodem,nelem,lakon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,R,physcon,dvi,numf,set,mi) +! +! carbon seal element calculated with Richter method +! Richter "Rohrhydraulik", Springer ,1971,p. 175 +! + implicit none +! + logical identity + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(4),idirf(4),index,iflag, + & inv,mi(2) +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),R,d,l, + & p1,p2,T1,physcon(*),dvi,pi,s,T2 +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1)then +! + index=ielprop(nelem) + d=prop(index+1) + s=prop(index+2) + l=prop(index+3) + pi=4.d0*datan(1.d0) +! + p1=v(2,node1) + p2=v(2,node2) + if(p1.ge.p2) then + inv=1 + T1=v(0,node1)+physcon(1) + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + T1=v(0,node2)+physcon(1) + endif +! + if(lakon(nelem)(2:6).eq.'CARBS') then +! +! gapflow +! Richter "Rohrhydraulik", Springer ,1971,p. 175 +! + xflow=inv*Pi*d*s**3*(P1**2-P2**2)/(24.d0*R*T1*dvi*l) + + elseif(lakon(nelem)(2:6).ne.'CARBS') then + write(*,*) '*WARNING in Carbon_seal.f' + write(*,*) 'unable to perform carbon seal calculation' + write(*,*) 'check input file' + endif +! + elseif (iflag.eq.2)then +! + numf=4 + p1=v(2,node1) + p2=v(2,node2) + if(p1.ge.p2) then + inv=1 + xflow=v(1,nodem) + T1=v(0,node1)+physcon(1) + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + xflow=-v(1,nodem) + T1=v(0,node2)+physcon(1) + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 +! + index=ielprop(nelem) + d=prop(index+1) + s=prop(index+2) + l=prop(index+3) + pi=4.d0*datan(1.d0) + +! + if (lakon(nelem)(2:8).eq.'CARBS') then +! + f=xflow*T1-pi*d*s**3*(P1**2-P2**2)/(24.d0*R*dvi*l) +! + df(1)=-(pi*d*s**3*P1)/(12.d0*R*dvi*l) + df(2)=xflow + df(3)=T1 + df(4)=(pi*d*s**3*P2)/(12.d0*R*dvi*l) +! + endif + + elseif(iflag.eq.3) then + p1=v(2,node1) + p2=v(2,node2) + if(p1.ge.p2) then + inv=1 + xflow=v(1,nodem) + T1=v(0,node1)+physcon(1) + T2=v(0,node2)+physcon(1) + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + xflow=-v(1,nodem) + T1=v(0,node2)+physcon(1) + T2=v(0,node1)+physcon(1) + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif + + write(1,*) '' + write(1,55) 'In line',int(nodem/100),' from node',node1, + &' to node', node2,': air massflow rate=',xflow,'kg/s' +! &,', oil massflow rate=',xflow_oil,'kg/s' + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) + + if(inv.eq.1) then + write(1,56)' Inlet node ',node1,': Tt1=',T1, + & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' + + write(1,*)' element G ',set(numf)(1:20) + + write(1,56)' Outlet node ',node2,': Tt2=',T2, + & 'K, Ts2=',T2,'K, Pt2=',P2/1e5,'Bar' +! + else if(inv.eq.-1) then + write(1,56)' Inlet node ',node2,': Tt1=',T1, + & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' + & + write(1,*)' element G ',set(numf)(1:20) + + write(1,56)' Outlet node ',node1,': Tt2=',T2, + & 'K, Ts2=',T2,'K, Pt2=',P2/1e5, 'Bar' + + endif + + 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A) + + + + + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cascade.c calculix-ccx-2.3/ccx_2.3/src/cascade.c --- calculix-ccx-2.1/ccx_2.3/src/cascade.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cascade.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,725 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include + +#ifdef SPOOLES +#include +#include +#include +#endif + +#include "CalculiX.h" + +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) + +void cascade(int *ipompc, double **coefmpcp, int **nodempcp, int *nmpc, + int *mpcfree, int *nodeboun, int *ndirboun, int*nboun, int*ikmpc, + int *ilmpc, int *ikboun, int *ilboun, int *mpcend, int *mpcmult, + char *labmpc, int *nk, int *memmpc_, int *icascade, int *maxlenmpc, + int *callfrommain, int *iperturb, int *ithermal){ + + /* detects cascaded mpc's and decascades them; checks multiple + occurrence of the same dependent DOF's in different mpc/spc's + + data structure of ipompc,coefmpc,nodempc: + for each mpc, e.g. i, + -the nodes are stored in nodempc(1,ipompc(i)), + nodempc(1,nodempc(3,ipompc(i))), + nodempc(1,nodempc(3,nodempc(3,ipompc(i))))... till + nodempc(3,nodempc(3,nodempc(3,.......))))))=0; + -the corresponding directions in nodempc(2,ipompc(i)), + nodempc(2,nodempc(3,ipompc(i))),..... + -the corresponding coefficient in coefmpc(ipompc(i)), + coefmpc(nodempc(3,ipompc(i))),..... + the mpc is written as a(1)u(i1,j1)+a(2)u(i2,j2)+... + +....a(k)u(ik,jk)=0, the first term is the dependent term, + the others are independent, at least after execution of the + present routine. The mpc's must be homogeneous, otherwise a + error message is generated and the program stops. */ + + int i,j,index,id,idof,nterm,idepend,*nodempc=NULL, + ispooles,iexpand,ichange,indexold, + mpc,indexnew,index1,index2,index1old,index2old,*jmpc=NULL,nl; + + double coef,*coefmpc=NULL; + +#ifdef SPOOLES + + int irow,icolumn,node,idir,irownl,icolnl,*ipointer=NULL,*icoef=NULL, + ifree,*indepdof=NULL,nindep; + + double *xcoef=NULL,b; + + DenseMtx *mtxB, *mtxX ; + Chv *rootchv ; + ChvManager *chvmanager ; + SubMtxManager *mtxmanager ; + FrontMtx *frontmtx ; + InpMtx *mtxA ; + double tau = 100.; + double cpus[10] ; + ETree *frontETree ; + FILE *msgFile ; + Graph *graph ; + int jrhs, msglvl=0, nedges,error, + nent, neqns, nrhs, pivotingflag=1, seed=389, + symmetryflag=2, type=1,maxdomainsize,maxzeros,maxsize; + int *oldToNew ; + int stats[20] ; + IV *newToOldIV, *oldToNewIV ; + IVL *adjIVL, *symbfacIVL ; +#endif + + nodempc=*nodempcp; + coefmpc=*coefmpcp; + + /* for(i=0;i<*nmpc;i++){ + j=i+1; + FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); + }*/ + + jmpc=NNEW(int,*nmpc); + idepend=0; + +/* check whether a node is used as a dependent node in a MPC + and in a SPC */ + + for(i=0;i<*nmpc;i++){ + if(*nboun>0){ + FORTRAN(nident,(ikboun,&ikmpc[i],nboun,&id));} + else{id=0;} + if(id>0){ + if(ikboun[id-1]==ikmpc[i]){ + printf("*ERROR in cascade: the DOF corresponding to \n node %d in direction %d is detected on the \n dependent side of a MPC and a SPC\n", + (ikmpc[i])/8+1,ikmpc[i]-8*((ikmpc[i])/8)); + FORTRAN(stop,()); + } + } + } + +/* check whether there are user mpc's: in user MPC's the + dependent DOF can change, however, the number of terms + cannot change */ + + for(i=0;i<*nmpc;i++){ + + /* linear mpc */ + + /* because of the next line the size of field labmpc + has to be defined as 20*nmpc+1: without "+1" an + undefined field is accessed */ + + if((strcmp1(&labmpc[20*i]," ")==0) || + (strcmp1(&labmpc[20*i],"CYCLIC")==0) || +/* ((strcmp1(&labmpc[20*i],"CYCLIC")==0)&&(*ithermal==2)) ||*/ + (strcmp1(&labmpc[20*i],"SUBCYCLIC")==0)|| + (strcmp1(&labmpc[20*i],"CONTACT")==0)|| + (*iperturb<2)) jmpc[i]=0; + + /* nonlinear mpc */ + + else if((strcmp1(&labmpc[20*i],"RIGID")==0) || + (strcmp1(&labmpc[20*i],"KNOT")==0) || +/* ((strcmp1(&labmpc[20*i],"CYCLIC")==0)&&(*ithermal!=2)) ||*/ + (strcmp1(&labmpc[20*i],"PLANE")==0) || + (strcmp1(&labmpc[20*i],"STRAIGHT")==0)|| + (strcmp1(&labmpc[20*i],"ISOCHORIC")==0)) jmpc[i]=1; + + /* user mpc */ + + else{ + jmpc[i]=1; + if(*icascade==0) *icascade=1; + } + } + +/* decascading */ + + ispooles=0; + + /* decascading using simple substitution */ + + do{ + ichange=0; + for(i=0;i<*nmpc;i++){ + if(jmpc[i]==1) nl=1; + else nl=0; + iexpand=0; + index=nodempc[3*ipompc[i]-1]; + if(index==0) continue; + do{ + idof=(nodempc[3*index-3]-1)*8+nodempc[3*index-2]; + FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); + if((id>0)&&(ikmpc[id-1]==idof)){ + + /* a term on the independent side of the MPC is + detected as dependent node in another MPC */ + + indexold=nodempc[3*index-1]; + coef=coefmpc[index-1]; + mpc=ilmpc[id-1]; + + /* no expansion of there is a dependence of a + nonlinear MPC on another linear or nonlinear MPC + and the call is from main */ + + if((jmpc[mpc-1]==1)||(nl==1)){ + *icascade=2; + if(idepend==0){ + printf("*INFO in cascade: linear MPCs and\n"); + printf(" nonlinear MPCs depend on each other\n"); + printf(" common node: %d in direction %d\n\n",nodempc[3*index-3],nodempc[3*index-2]); + idepend=1;} + if(*callfrommain==1){ + index=nodempc[3*index-1]; + if(index!=0) continue; + else break;} + } + +/* printf("*INFO in cascade: DOF %d of node %d is expanded\n", + nodempc[3*index-2],nodempc[3*index-3]);*/ + + /* collecting terms corresponding to the same DOF */ + + index1=ipompc[i]; + do{ + index2old=index1; + index2=nodempc[3*index1-1]; + if(index2==0) break; + do{ + if((nodempc[3*index1-3]==nodempc[3*index2-3])&& + (nodempc[3*index1-2]==nodempc[3*index2-2])){ + coefmpc[index1-1]+=coefmpc[index2-1]; + nodempc[3*index2old-1]=nodempc[3*index2-1]; + nodempc[3*index2-1]=*mpcfree; + *mpcfree=index2; + index2=nodempc[3*index2old-1]; + if(index2==0) break; + } + else{ + index2old=index2; + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + }while(1); + index1=nodempc[3*index1-1]; + if(index1==0) break; + }while(1); + + /* check for zero coefficients on the dependent side */ + + index1=ipompc[i]; + /* index1old=0; + do {*/ + if(fabs(coefmpc[index1-1])<1.e-10){ + /* if(index1old==0){*/ + printf("*ERROR in cascade: zero coefficient on the\n"); + printf(" dependent side of an equation\n"); + printf(" dependent node: %d",nodempc[3*index1-3]); + FORTRAN(stop,()); + } + /* else{ + nodempc[3*index1old-1]=nodempc[3*index1-1]; + nodempc[3*index1-1]=*mpcfree; + *mpcfree=index1; + index1=nodempc[3*index1old-1]; + } + } + else{ + index1old=index1; + index1=nodempc[3*index1-1]; + } + if(index1==0) break; + }while(1);*/ + + ichange=1;iexpand=1; + if((strcmp1(&labmpc[20*i]," ")==0)&& + (strcmp1(&labmpc[20*(mpc-1)],"CYCLIC")==0)) + strcpy1(&labmpc[20*i],"SUBCYCLIC",9); + indexnew=ipompc[mpc-1]; + coef=-coef/coefmpc[indexnew-1]; + indexnew=nodempc[3*indexnew-1]; + do{ + coefmpc[index-1]=coef*coefmpc[indexnew-1]; + nodempc[3*index-3]=nodempc[3*indexnew-3]; + nodempc[3*index-2]=nodempc[3*indexnew-2]; + indexnew=nodempc[3*indexnew-1]; + if(indexnew!=0){ + nodempc[3*index-1]=*mpcfree; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in cascade: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(j=*mpcfree;j<*memmpc_;j++){ + nodempc[3*j-1]=j+1; + } + nodempc[3**memmpc_-1]=0; + } + continue; + } + else{ + nodempc[3*index-1]=indexold; + break; + } + }while(1); + break; + } + else{ + index=nodempc[3*index-1]; + if(index!=0) continue; + else break; + } + }while(1); + if(iexpand==0) continue; + + /* one term of the mpc was expanded + collecting terms corresponding to the same DOF */ + + index1=ipompc[i]; + do{ + index2old=index1; + index2=nodempc[3*index1-1]; + if(index2==0) break; + do{ + if((nodempc[3*index1-3]==nodempc[3*index2-3])&& + (nodempc[3*index1-2]==nodempc[3*index2-2])){ + coefmpc[index1-1]+=coefmpc[index2-1]; + nodempc[3*index2old-1]=nodempc[3*index2-1]; + nodempc[3*index2-1]=*mpcfree; + *mpcfree=index2; + index2=nodempc[3*index2old-1]; + if(index2==0) break; + } + else{ + index2old=index2; + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + }while(1); + index1=nodempc[3*index1-1]; + if(index1==0) break; + }while(1); + + /* check for zero coefficients on the dependent and + independent side */ + + index1=ipompc[i]; + index1old=0; + do { + if(fabs(coefmpc[index1-1])<1.e-10){ + if(index1old==0){ + printf("*ERROR in cascade: zero coefficient on the\n"); + printf(" dependent side of an equation\n"); + printf(" dependent node: %d",nodempc[3*index1-3]); + FORTRAN(stop,()); + } + else{ + nodempc[3*index1old-1]=nodempc[3*index1-1]; + nodempc[3*index1-1]=*mpcfree; + *mpcfree=index1; + index1=nodempc[3*index1old-1]; + } + } + else{ + index1old=index1; + index1=nodempc[3*index1-1]; + } + if(index1==0) break; + }while(1); + } + if(ichange==0) break; + }while(1); + + /* decascading using spooles */ + +#ifdef SPOOLES + if((*icascade==1)&&(ispooles==1)){ + if ( (msgFile = fopen("spooles.out", "a")) == NULL ) { + fprintf(stderr, "\n fatal error in spooles.c" + "\n unable to open file spooles.out\n") ; + } + ipointer=NNEW(int,7**nk); + indepdof=NNEW(int,7**nk); + icoef=NNEW(int,2**memmpc_); + xcoef=NNEW(double,*memmpc_); + ifree=0; + nindep=0; + + for(i=*nmpc-1;i>-1;i--){ + index=ipompc[i]; + while(1){ + idof=8*(nodempc[3*index-3]-1)+nodempc[3*index-2]-1; + +/* check whether idof is a independent dof which has not yet been + stored in indepdof */ + + FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); + if((id==0)||(ikmpc[id-1]!=idof)){ + FORTRAN(nident,(indepdof,&idof,&nindep,&id)); + if((id==0)||(indepdof[id-1]!=idof)){ + for(j=nindep;j>id;j--){ + indepdof[j]=indepdof[j-1]; + } + indepdof[id]=idof; + nindep++; + } + } + + icoef[2*ifree]=i+1; + icoef[2*ifree+1]=ipointer[idof]; + xcoef[ifree]=coefmpc[index-1]; + ipointer[idof]=++ifree; + index=nodempc[3*index-1]; + if(index==0) break; + } + } + +/* filling the left hand side */ + + nent=*memmpc_; + neqns=*nmpc; + mtxA = InpMtx_new() ; + InpMtx_init(mtxA, INPMTX_BY_ROWS, type, nent, neqns) ; + + for(i=0;i<*nmpc;i++){ + idof=ikmpc[i]; + icolumn=ilmpc[i]-1; + if(strcmp1(&labmpc[20*icolumn],"RIGID")==0) icolnl=1; + else icolnl=0; + index=ipointer[idof-1]; + while(1){ + irow=icoef[2*index-2]-1; + if(irow!=icolumn){ + if(strcmp1(&labmpc[20*irow],"RIGID")==0)irownl=1; + else irownl=0; + if((irownl==1)||(icolnl==1)){ + *icascade=2; + InpMtx_free(mtxA); + printf("*ERROR in cascade: linear and nonlinear MPCs depend on each other"); + FORTRAN(stop,()); + } + } + if((strcmp1(&labmpc[20*irow]," ")==0)&& + (strcmp1(&labmpc[20*icolumn],"CYCLIC")==0)){ + strcpy1(&labmpc[20*irow],"SUBCYCLIC",9);} + coef=xcoef[index-1]; + InpMtx_inputRealEntry(mtxA,irow,icolumn,coef); + index=icoef[2*index-1]; + if(index==0) break; + } + ipointer[idof-1]=0; + } + + InpMtx_changeStorageMode(mtxA, INPMTX_BY_VECTORS) ; + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n input matrix") ; + InpMtx_writeForHumanEye(mtxA, msgFile) ; + fflush(msgFile) ; + } +/*--------------------------------------------------------------------*/ +/* + ------------------------------------------------- + STEP 2 : find a low-fill ordering + (1) create the Graph object + (2) order the graph using multiple minimum degree + ------------------------------------------------- +*/ + graph = Graph_new() ; + adjIVL = InpMtx_fullAdjacency(mtxA) ; + nedges = IVL_tsize(adjIVL) ; + Graph_init2(graph, 0, neqns, 0, nedges, neqns, nedges, adjIVL, + NULL, NULL) ; + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n graph of the input matrix") ; + Graph_writeForHumanEye(graph, msgFile) ; + fflush(msgFile) ; + } + maxdomainsize=800;maxzeros=1000;maxsize=64; + /*maxdomainsize=neqns/100;*/ + /*frontETree = orderViaMMD(graph, seed, msglvl, msgFile) ;*/ + /*frontETree = orderViaND(graph,maxdomainsize,seed,msglvl,msgFile); */ + /*frontETree = orderViaMS(graph,maxdomainsize,seed,msglvl,msgFile);*/ + frontETree=orderViaBestOfNDandMS(graph,maxdomainsize,maxzeros, + maxsize,seed,msglvl,msgFile); + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n front tree from ordering") ; + ETree_writeForHumanEye(frontETree, msgFile) ; + fflush(msgFile) ; + } +/*--------------------------------------------------------------------*/ +/* + ----------------------------------------------------- + STEP 3: get the permutation, permute the matrix and + front tree and get the symbolic factorization + ----------------------------------------------------- +*/ + oldToNewIV = ETree_oldToNewVtxPerm(frontETree) ; + oldToNew = IV_entries(oldToNewIV) ; + newToOldIV = ETree_newToOldVtxPerm(frontETree) ; + ETree_permuteVertices(frontETree, oldToNewIV) ; + InpMtx_permute(mtxA, oldToNew, oldToNew) ; +/* InpMtx_mapToUpperTriangle(mtxA) ;*/ + InpMtx_changeCoordType(mtxA,INPMTX_BY_CHEVRONS); + InpMtx_changeStorageMode(mtxA,INPMTX_BY_VECTORS); + symbfacIVL = SymbFac_initFromInpMtx(frontETree, mtxA) ; + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n old-to-new permutation vector") ; + IV_writeForHumanEye(oldToNewIV, msgFile) ; + fprintf(msgFile, "\n\n new-to-old permutation vector") ; + IV_writeForHumanEye(newToOldIV, msgFile) ; + fprintf(msgFile, "\n\n front tree after permutation") ; + ETree_writeForHumanEye(frontETree, msgFile) ; + fprintf(msgFile, "\n\n input matrix after permutation") ; + InpMtx_writeForHumanEye(mtxA, msgFile) ; + fprintf(msgFile, "\n\n symbolic factorization") ; + IVL_writeForHumanEye(symbfacIVL, msgFile) ; + fflush(msgFile) ; + } +/*--------------------------------------------------------------------*/ +/* + ------------------------------------------ + STEP 4: initialize the front matrix object + ------------------------------------------ +*/ + frontmtx = FrontMtx_new() ; + mtxmanager = SubMtxManager_new() ; + SubMtxManager_init(mtxmanager, NO_LOCK, 0) ; + FrontMtx_init(frontmtx, frontETree, symbfacIVL, type, symmetryflag, + FRONTMTX_DENSE_FRONTS, pivotingflag, NO_LOCK, 0, NULL, + mtxmanager, msglvl, msgFile) ; +/*--------------------------------------------------------------------*/ +/* + ----------------------------------------- + STEP 5: compute the numeric factorization + ----------------------------------------- +*/ + chvmanager = ChvManager_new() ; + ChvManager_init(chvmanager, NO_LOCK, 1) ; + DVfill(10, cpus, 0.0) ; + IVfill(20, stats, 0) ; + rootchv = FrontMtx_factorInpMtx(frontmtx, mtxA, tau, 0.0, chvmanager, + &error,cpus, stats, msglvl, msgFile) ; + ChvManager_free(chvmanager) ; + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n factor matrix") ; + FrontMtx_writeForHumanEye(frontmtx, msgFile) ; + fflush(msgFile) ; + } + if ( rootchv != NULL ) { + fprintf(msgFile, "\n\n matrix found to be singular\n") ; + exit(-1) ; + } + if(error>=0){ + fprintf(msgFile,"\n\nerror encountered at front %d",error); + exit(-1); + } +/*--------------------------------------------------------------------*/ +/* + -------------------------------------- + STEP 6: post-process the factorization + -------------------------------------- +*/ + FrontMtx_postProcess(frontmtx, msglvl, msgFile) ; + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n factor matrix after post-processing") ; + FrontMtx_writeForHumanEye(frontmtx, msgFile) ; + fflush(msgFile) ; + } + +/* reinitialize nodempc */ + + *mpcfree=1; + for(j=0;j<*nmpc;j++){ + ipompc[j]=0;} + +/* filling the RHS */ + + jrhs=0; + nrhs=1; + mtxB=DenseMtx_new(); + mtxX=DenseMtx_new(); + + for(i=nindep;i>0;i--){ + idof=indepdof[i-1]; + if(ipointer[idof]>0){ + +/* new RHS column */ + + DenseMtx_init(mtxB, type, 0, 0, neqns, nrhs, 1, neqns) ; + DenseMtx_zero(mtxB) ; + + index=ipointer[idof]; + while(1){ + irow=icoef[2*index-2]-1; + coef=xcoef[index-1]; + DenseMtx_setRealEntry(mtxB,irow,jrhs,coef); + index=icoef[2*index-1]; + if(index==0) break; + } + + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n rhs matrix in original ordering") ; + DenseMtx_writeForHumanEye(mtxB, msgFile) ; + fflush(msgFile) ; + } + +/*--------------------------------------------------------------------*/ +/* + --------------------------------------------------------- + STEP 8: permute the right hand side into the new ordering + --------------------------------------------------------- +*/ + DenseMtx_permuteRows(mtxB, oldToNewIV) ; + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n right hand side matrix in new ordering") ; + DenseMtx_writeForHumanEye(mtxB, msgFile) ; + fflush(msgFile) ; + } +/*--------------------------------------------------------------------*/ +/* + ------------------------------- + STEP 9: solve the linear system + ------------------------------- +*/ + DenseMtx_init(mtxX, type, 0, 0, neqns, nrhs, 1, neqns) ; + DenseMtx_zero(mtxX) ; + FrontMtx_solve(frontmtx, mtxX, mtxB, mtxmanager,cpus, msglvl, msgFile) ; + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n solution matrix in new ordering") ; + DenseMtx_writeForHumanEye(mtxX, msgFile) ; + fflush(msgFile) ; + } +/*--------------------------------------------------------------------*/ +/* + -------------------------------------------------------- + STEP 10: permute the solution into the original ordering + -------------------------------------------------------- +*/ + DenseMtx_permuteRows(mtxX, newToOldIV) ; + if ( msglvl > 1 ) { + fprintf(msgFile, "\n\n solution matrix in original ordering") ; + DenseMtx_writeForHumanEye(mtxX, msgFile) ; + fflush(msgFile) ; + } + + + for(j=0;j<*nmpc;j++){ + b=DenseMtx_entries(mtxX)[j]; + if(fabs(b)>1.e-10){ + nodempc[3**mpcfree-1]=ipompc[j]; + node=(int)((idof+8)/8); + idir=idof+1-8*(node-1); + nodempc[3**mpcfree-3]=node; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=b; + ipompc[j]=(*mpcfree)++; + if(*mpcfree>*memmpc_){ + *memmpc_=(int)(1.1**memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + } + } + } + } + } +/*--------------------------------------------------------------------*/ +/* + ----------- + free memory + ----------- +*/ + FrontMtx_free(frontmtx) ; + DenseMtx_free(mtxB) ; + DenseMtx_free(mtxX) ; + IV_free(newToOldIV) ; + IV_free(oldToNewIV) ; + InpMtx_free(mtxA) ; + ETree_free(frontETree) ; + IVL_free(symbfacIVL) ; + SubMtxManager_free(mtxmanager) ; + Graph_free(graph) ; + +/* diagonal terms */ + + for(i=0;i<*nmpc;i++){ + j=ilmpc[i]-1; + idof=ikmpc[i]; + node=(int)((idof+7)/8); + idir=idof-8*(node-1); + nodempc[3**mpcfree-1]=ipompc[j]; + nodempc[3**mpcfree-3]=node; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=1.; + ipompc[j]=(*mpcfree)++; + if(*mpcfree>*memmpc_){ + *memmpc_=(int)(1.1**memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + } + } + + free(ipointer);free(indepdof);free(icoef);free(xcoef); + + fclose(msgFile); + + } +#endif + +/* determining the effective size of nodempc and coefmpc for + the reallocation*/ + + *mpcend=0; + *mpcmult=0; + *maxlenmpc=0; + for(i=0;i<*nmpc;i++){ + index=ipompc[i]; + *mpcend=max(*mpcend,index); + nterm=1; + while(1){ + index=nodempc[3*index-1]; + if(index==0){ + *mpcmult+=nterm*(nterm-1); + *maxlenmpc=max(*maxlenmpc,nterm); + break; + } + *mpcend=max(*mpcend,index); + nterm++; + } + } + + free(jmpc); + + *nodempcp=nodempc; + *coefmpcp=coefmpc; + + /* for(i=0;i<*nmpc;i++){ + j=i+1; + FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); + }*/ + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/ccx_2.3.c calculix-ccx-2.3/ccx_2.3/src/ccx_2.3.c --- calculix-ccx-2.1/ccx_2.3/src/ccx_2.3.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ccx_2.3.c 2011-03-26 17:20:38.000000000 +0000 @@ -0,0 +1,1231 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifdef CALCULIX_MPI +#include +#endif + +#include +#include +#include +#include +#include "CalculiX.h" + +#ifdef CALCULIX_MPI +int myid = 0, nproc = 0; +#endif + +int main(int argc,char *argv[]) +{ + +int *kon=NULL, *nodeboun=NULL, *ndirboun=NULL, *ipompc=NULL, + *nodempc=NULL, *nodeforc=NULL, *ndirforc=NULL, + *nelemload=NULL,im, + *nnn=NULL, *nactdof=NULL, *icol=NULL,*ics=NULL, + *jq=NULL, *mast1=NULL, *irow=NULL, *rig=NULL, + *ikmpc=NULL, *ilmpc=NULL, *ikboun=NULL, *ilboun=NULL, + *npn=NULL, *adj=NULL, *xadj=NULL, *iw=NULL, *nreorder=NULL, + *mmm=NULL, *xnpn=NULL, *ipointer=NULL, + *istartset=NULL, *iendset=NULL, *ialset=NULL, *ielmat=NULL, + *ielorien=NULL, *nrhcon=NULL, *nodebounold=NULL, *ndirbounold=NULL, + *nelcon=NULL, *nalcon=NULL, *iamforc=NULL, *iamload=NULL, + *iamt1=NULL, *namta=NULL, *ipkon=NULL, *iamboun=NULL, + *nplicon=NULL, *nplkcon=NULL, *inotr=NULL, *iponor=NULL, *knor=NULL, + *ikforc=NULL, *ilforc=NULL, *iponoel=NULL, *inoel=NULL, *nshcon=NULL, + *ncocon=NULL,*ibody=NULL, *inum1=NULL,*ielprop=NULL, + *inum2=NULL,*ipoinpc=NULL,cfd=0,mt; + +double *co=NULL, *xboun=NULL, *coefmpc=NULL, *xforc=NULL, + *xload=NULL, *ad=NULL, *au=NULL, *xbounold=NULL, *xforcold=NULL, + *b=NULL, *vold=NULL, *sti=NULL, *xloadold=NULL, *xnor=NULL, + *reorder=NULL,*dcs=NULL, *thickn=NULL, *thicke=NULL, *offset=NULL, + *elcon=NULL, *rhcon=NULL, *alcon=NULL, *alzero=NULL, *t0=NULL, *t1=NULL, + *prestr=NULL, *orab=NULL, *amta=NULL, *veold=NULL, *accold=NULL, + *adb=NULL, *aub=NULL, *t1old=NULL, *eme=NULL, *plicon=NULL, *plkcon=NULL, + *xstate=NULL, *trab=NULL, *ener=NULL, *shcon=NULL, *cocon=NULL, + *cs=NULL,*tietol=NULL,*fmpc=NULL,*prop=NULL, + *xbody=NULL,*xbodyold=NULL; + +double ctrl[27]={4.5,8.5,9.5,16.5,10.5,4.5,0.,5.5,0.,0.,0.25,0.5,0.75,0.85,0.,0.,1.5,0.,0.005,0.01,0.,0.,0.02,1.e-5,1.e-3,1.e-8,1.e30}; + +char *sideload=NULL, *set=NULL, *matname=NULL, *orname=NULL, *amname=NULL, + *filab=NULL, *lakon=NULL, *labmpc=NULL, *prlab=NULL, *prset=NULL, + jobnamec[396]="",jobnamef[132]="",output[4]="frd", *typeboun=NULL, + *inpc=NULL,*tieset=NULL,*cbody=NULL; + +int nk,ne,nboun,nmpc,nforc,nload,nprint,nset,nalset,nentries=14, + nmethod,neq[3]={0,0,0},i,mpcfree=1,mei[4],j,nzl,nam,nbounold=0, + nforcold=0,nloadold=0,nbody,nbody_=0,nbodyold=0, + k,nzs[3],nmpc_=0,nload_=0,nforc_=0,istep,istat,nboun_=0, + iperturb[2]={0,0},nmat,ntmat_=0,norien,ithermal[2]={0,0}, + iprestr,kode,isolver=0,inlgeom=0, + jout[2]={1,1},nlabel,nkon=0,idrct,jmax[2],iexpl,nevtot=0, + iplas=0,npmat_=0,mi[2]={0,3},ntrans,mpcend=-1,namtot_=0,iumat=0,mpcmult, + icascade=0,maxlenmpc,mpcinfo[4],ne1d=0,ne2d=0,infree[4]={0,0,0,0}, + callfrommain,nflow=0,jin=0,irstrt=0,nener=0,jrstrt=0,nenerold, + nline,ipoinp[2*nentries],*inp=NULL,ntie,ntie_=0,mcs=0,nprop_=0, + nprop=0,itpamp=0,iviewfile,nkold,nevdamp_=0,npt_=0; + +int *meminset=NULL,*rmeminset=NULL; + +int nzs_,nk_=0,ne_=0,nset_=0,nalset_=0,nmat_=0,norien_=0,nam_=0, + ntrans_=0,ncs_=0,nstate_=0,ncmat_=0,memmpc_=0,nprint_=0; + +double fei[3],tinc,tper,tmin,tmax,*xmodal=NULL, + alpha,ttime=0.,qaold[2]={0.,0.},physcon[9]={0.,0.,0.,0.,0.,0.,0.,0.,0.}; + +#ifdef CALCULIX_MPI +MPI_Init(&argc, &argv) ; +MPI_Comm_rank(MPI_COMM_WORLD, &myid) ; +MPI_Comm_size(MPI_COMM_WORLD, &nproc) ; +#endif + +if(argc==1){printf("Usage: CalculiX.exe -i jobname\n");FORTRAN(stop,());} +else{ + for(i=1;i=0) { + + fflush(stdout); + + /* in order to reduce the number of variables to be transferred to + the subroutines, the max. field sizes are (for most fields) copied + into the real sizes */ + + nzs[1]=nzs_; + nprint=nprint_; + + if((istep == 0)||(irstrt<0)) { + ne=ne_; + nset=nset_; + nalset=nalset_; + nmat=nmat_; + norien=norien_; + ntrans=ntrans_; + ntie=ntie_; + + /* allocating space before the first step */ + + /* coordinates and topology */ + + co=NNEW(double,3*nk_); + kon=NNEW(int,28*ne_); + ipkon=NNEW(int,ne_); + lakon=NNEW(char,8*ne_); + + /* property cards */ + + ielprop=NNEW(int,ne_); + for(i=0;i0){xstate=NNEW(double,nstate_*mi[0]*ne);} + + /* material orientation */ + + orname=NNEW(char,80*norien); + orab=NNEW(double,7*norien); + ielorien=NNEW(int,ne_); + + /* transformations */ + + trab=NNEW(double,7*ntrans); + inotr=NNEW(int,2*nk_); + + /* amplitude definitions */ + + amname=NNEW(char,80*nam_); + amta=NNEW(double,2*namtot_); + namta=NNEW(int,3*nam_); + + /* temperatures */ + + if((ne1d==0)&&(ne2d==0)){ + t0=NNEW(double,nk_); + t1=NNEW(double,nk_);} + else{ + t0=NNEW(double,3*nk_); + t1=NNEW(double,3*nk_);} + iamt1=NNEW(int,nk_); + + prestr=NNEW(double,6*mi[0]*ne_); + vold=NNEW(double,mt*nk_); + veold=NNEW(double,mt*nk_); + + ielmat=NNEW(int,ne_); + + matname=NNEW(char,80*nmat); + + filab=NNEW(char,87*nlabel); + + /* tied constraints */ + + if(ntie_>0){ + tieset=NNEW(char,243*ntie_); + tietol=NNEW(double,2*ntie_); + cs=NNEW(double,17*ntie_); + } + + /* temporary fields for cyclic symmetry calculations */ + + if((ncs_>0)||(npt_>0)){ + if(2*npt_>24*ncs_){ + ics=NNEW(int,2*npt_); + }else{ + ics=NNEW(int,24*ncs_); + } + if(npt_>30*ncs_){ + dcs=NNEW(double,npt_); + }else{ + dcs=NNEW(double,30*ncs_); + } + } + + } + else { + + /* allocating and reallocating space for subsequent steps */ + + if((nmethod != 4) && ((nmethod != 1) || (iperturb[0] < 2))){ + veold=NNEW(double,mt*nk_); + } + else{ + RENEW(veold,double,mt*nk_); +// memset(&veold[mt*nk],0,sizeof(double)*mt*(nk_-nk)); + DMEMSET(veold,mt*nk,mt*nk_,0.); + } + RENEW(vold,double,mt*nk_); +// memset(&vold[mt*nk],0,sizeof(double)*mt*(nk_-nk)); + DMEMSET(vold,mt*nk,mt*nk_,0.); + + /* if(nmethod != 4){free(accold);}*/ + + RENEW(nodeboun,int,nboun_); + RENEW(ndirboun,int,nboun_); + RENEW(typeboun,char,nboun_); + RENEW(xboun,double,nboun_); + RENEW(ikboun,int,nboun_); + RENEW(ilboun,int,nboun_); + + RENEW(nodeforc,int,2*nforc_); + RENEW(ndirforc,int,nforc_); + RENEW(xforc,double,nforc_); + RENEW(ikforc,int,nforc_); + RENEW(ilforc,int,nforc_); + + RENEW(nelemload,int,2*nload_); + RENEW(sideload,char,20*nload_); + RENEW(xload,double,2*nload_); + + RENEW(cbody,char,81*nbody_); + RENEW(ibody,int,3*nbody_); + RENEW(xbody,double,7*nbody_); + RENEW(xbodyold,double,7*nbody_); + for(i=7*nbodyold;i<7*nbody_;i++) xbodyold[i]=0; + + if(nam > 0) { + RENEW(iamforc,int,nforc_); + RENEW(iamload,int,2*nload_); + RENEW(iamboun,int,nboun_); + RENEW(amname,char,80*nam_); + RENEW(amta,double,2*namtot_); + RENEW(namta,int,3*nam_); + } + + RENEW(ipompc,int,nmpc_); + + RENEW(labmpc,char,20*nmpc_+1); + RENEW(ikmpc,int,nmpc_); + RENEW(ilmpc,int,nmpc_); + RENEW(fmpc,double,nmpc_); + + if(ntrans > 0){ + RENEW(inotr,int,2*nk_); + } + + RENEW(co,double,3*nk_); + + if(ithermal[0] != 0){ + if((ne1d==0)&&(ne2d==0)){ + RENEW(t0,double,nk_); + RENEW(t1,double,nk_); + } + if(nam > 0) {RENEW(iamt1,int,nk_);} + } + + } + + /* allocation of fields in the restart file */ + + if(irstrt<0){ + nodebounold=NNEW(int,nboun_); + ndirbounold=NNEW(int,nboun_); + xbounold=NNEW(double,nboun_); + xforcold=NNEW(double,nforc_); + xloadold=NNEW(double,2*nload_); + if(ithermal[0]!=0) t1old=NNEW(double,nk_); + sti=NNEW(double,6*mi[0]*ne); + eme=NNEW(double,6*mi[0]*ne); + if(nener==1)ener=NNEW(double,mi[0]*ne*2); + nnn=NNEW(int,nk_); + } + + nenerold=nener; + nkold=nk; + + /* reading the input file */ + + FORTRAN(calinput,(co,&nk,kon,ipkon,lakon,&nkon,&ne, + nodeboun,ndirboun,xboun,&nboun, + ipompc,nodempc,coefmpc,&nmpc,&nmpc_,nodeforc,ndirforc,xforc,&nforc, + &nforc_,nelemload,sideload,xload,&nload,&nload_, + &nprint,prlab,prset,&mpcfree,&nboun_,mei,set,istartset,iendset, + ialset,&nset,&nalset,elcon,nelcon,rhcon,nrhcon,alcon,nalcon, + alzero,t0,t1,matname,ielmat,orname,orab,ielorien,amname, + amta,namta,&nam,&nmethod,iamforc,iamload,iamt1, + ithermal,iperturb,&istat,&istep,&nmat,&ntmat_,&norien,prestr, + &iprestr,&isolver,fei,veold,&tinc,&tper, + xmodal,filab,jout,&nlabel,&idrct, + jmax,&tmin,&tmax,&iexpl,&alpha,iamboun,plicon,nplicon, + plkcon,nplkcon,&iplas,&npmat_,mi,&nk_,trab,inotr,&ntrans, + ikboun,ilboun,ikmpc,ilmpc,ics,dcs,&ncs_,&namtot_,cs,&nstate_, + &ncmat_,&iumat,&mcs,labmpc,iponor,xnor,knor,thickn,thicke, + ikforc,ilforc,offset,iponoel,inoel,rig,infree,nshcon,shcon, + cocon,ncocon,physcon,&nflow, + ctrl,&memmpc_,&maxlenmpc,&ne1d,&ne2d,&nener,vold,nodebounold, + ndirbounold,xbounold,xforcold,xloadold,t1old,eme, + sti,ener,xstate,jobnamec,nnn,&irstrt,&ttime, + qaold,output,typeboun,inpc,&nline,ipoinp,inp,tieset,tietol, + &ntie,fmpc,cbody,ibody,xbody,&nbody,&nbody_,xbodyold,&nam_, + ielprop,&nprop,&nprop_,prop,&itpamp,&iviewfile,ipoinpc,&cfd)); + + if((nmethod!=1)||(iperturb[0]<2))icascade=0; + +/* FORTRAN(writeboun,(nodeboun,ndirboun,xboun,typeboun,&nboun));*/ + + if(istat<0) break; + + /*RENEW(inpc,char,(long long)132*nline);*/ + /* RENEW(inp,int,3*ipoinp[23]); */ + + if(istep == 1) { + + /* reallocating space in the first step */ + + /* allocating and initializing fields pointing to the previous step */ + + RENEW(vold,double,mt*nk); + sti=NNEW(double,6*mi[0]*ne); + + /* strains */ + + eme=NNEW(double,6*mi[0]*ne); + + /* residual stresses/strains */ + + if(iprestr==1) { + RENEW(prestr,double,6*mi[0]*ne); + for(i=0;i1){ + for(i=0;i0){ + RENEW(ielprop,int,ne); + RENEW(prop,double,nprop); + }else{ + free(ielprop);free(prop); + } + + /* fields for 1-D and 2-D elements */ + + if((ne1d!=0)||(ne2d!=0)){ + RENEW(iponor,int,2*nkon); + RENEW(xnor,double,infree[0]); + RENEW(knor,int,infree[1]); + free(thickn); + RENEW(thicke,double,2*nkon); + RENEW(offset,double,2*ne); + RENEW(inoel,int,3*(infree[2]-1)); + RENEW(iponoel,int,infree[3]); + RENEW(rig,int,infree[3]); + } + + /* set definitions */ + + RENEW(set,char,81*nset); + RENEW(istartset,int,nset); + RENEW(iendset,int,nset); + RENEW(ialset,int,nalset); + + /* material properties */ + + RENEW(elcon,double,(ncmat_+1)*ntmat_*nmat); + RENEW(nelcon,int,2*nmat); + + RENEW(rhcon,double,2*ntmat_*nmat); + RENEW(nrhcon,int,nmat); + + RENEW(shcon,double,4*ntmat_*nmat); + RENEW(nshcon,int,nmat); + + RENEW(cocon,double,7*ntmat_*nmat); + RENEW(ncocon,int,2*nmat); + + RENEW(alcon,double,7*ntmat_*nmat); + RENEW(nalcon,int,2*nmat); + RENEW(alzero,double,nmat); + + RENEW(matname,char,80*nmat); + RENEW(ielmat,int,ne); + + /* allocating space for the state variables */ + + if(nstate_>0){ + xstate=NNEW(double,nstate_*mi[0]*ne); + } + + /* next statements for plastic materials and nonlinear springs */ + + if(npmat_>0){ + RENEW(plicon,double,(2*npmat_+1)*ntmat_*nmat); + RENEW(nplicon,int,(ntmat_+1)*nmat); + }else{ + free(plicon);free(nplicon); + } + /* next statements only for plastic materials */ + + if(iplas!=0){ + RENEW(plkcon,double,(2*npmat_+1)*ntmat_*nmat); + RENEW(nplkcon,int,(ntmat_+1)*nmat); + } + else{ + free(plkcon);free(nplkcon); + } + + /* material orientation */ + + if(norien > 0) { + RENEW(orname,char,80*norien); + RENEW(ielorien,int,ne); + RENEW(orab,double,7*norien); + } + else { + free(orname); + free(ielorien); + free(orab); + } + + /* amplitude definitions */ + + if(nam > 0) { + RENEW(amname,char,80*nam); + RENEW(namta,int,3*nam); + RENEW(amta,double,2*namta[3*nam-2]); + } + else { + free(amname); + free(amta); + free(namta); + free(iamforc); + free(iamload); + free(iamboun); + } + + if(ntrans > 0){ + RENEW(trab,double,7*ntrans); + } + else{free(trab);free(inotr);} + + if(ithermal[0] == 0){free(t0);free(t1);} + if((ithermal[0] == 0)||(nam<=0)){free(iamt1);} + + if(ncs_>0){ + RENEW(ics,int,ncs_); + free(dcs); + }else if(npt_>0){free(ics);} + + if(mcs>0){ + RENEW(cs,double,17*mcs); + }else{ + free(cs); + } + + + /* tied contact constraints: generate appropriate MPC's */ + + tiedcontact(&ntie, tieset, &nset, set,istartset, iendset, ialset, + lakon, ipkon, kon,tietol,&nmpc, &mpcfree, &memmpc_, + &ipompc, &labmpc, &ikmpc, &ilmpc,&fmpc, &nodempc, &coefmpc, + ithermal, co, vold,&cfd,&nmpc_,mi,&nk); + + }else{ + + /* reallocating space in all but the first step (>1) */ + + RENEW(vold,double,mt*nk); + + /* if the SPC boundary conditions were changed in the present step, + they have to be rematched with those in the last step. Removed SPC + boundary conditions do not appear any more (this is different from + forces and loads, where removed forces or loads are reset to zero; + a removed SPC constraint does not have a numerical value any more) */ + + reorder=NNEW(double,nboun); + nreorder=NNEW(int,nboun); + if(nbounold 0) { + RENEW(amname,char,80*nam); + RENEW(namta,int,3*nam); + RENEW(amta,double,2*namta[3*nam-2]); + } + + } + + /* reallocating fields for all steps (>=1) */ + + RENEW(co,double,3*nk); + + RENEW(nodeboun,int,nboun); + RENEW(ndirboun,int,nboun); + RENEW(typeboun,char,nboun); + RENEW(xboun,double,nboun); + RENEW(ikboun,int,nboun); + RENEW(ilboun,int,nboun); + + RENEW(nodeforc,int,2*nforc); + RENEW(ndirforc,int,nforc); + RENEW(xforc,double,nforc); + RENEW(ikforc,int,nforc); + RENEW(ilforc,int,nforc); + + RENEW(nelemload,int,2*nload); + RENEW(sideload,char,20*nload); + RENEW(xload,double,2*nload); + + RENEW(cbody,char,81*nbody); + RENEW(ibody,int,3*nbody); + RENEW(xbody,double,7*nbody); + RENEW(xbodyold,double,7*nbody); + + RENEW(ipompc,int,nmpc); + RENEW(labmpc,char,20*nmpc+1); + RENEW(ikmpc,int,nmpc); + RENEW(ilmpc,int,nmpc); + RENEW(fmpc,double,nmpc); + + /* energy */ + + if((nener==1)&&(nenerold==0)){ + ener=NNEW(double,mi[0]*ne*2); + if((istep>1)&&(iperturb[0]>1)){ + printf("*ERROR in CalculiX: in nonlinear calculations"); + printf(" energy output must be selected in the first step"); + FORTRAN(stop,()); + } + } + + /* initial velocities and accelerations */ + + if((nmethod == 4) || ((nmethod == 1) && (iperturb[0] >= 2))) { + RENEW(veold,double,mt*nk); + } + else {free(veold);} + + if((nmethod == 4)&&(iperturb[0]>1)) { + accold=NNEW(double,mt*nk); + } + + if(nam > 0) { + RENEW(iamforc,int,nforc); + RENEW(iamload,int,2*nload); + RENEW(iamboun,int,nboun); + } + + /* temperature loading */ + + if(ithermal[0] != 0){ + if((ne1d==0)&&(ne2d==0)){ + RENEW(t0,double,nk); + RENEW(t1,double,nk); + } + if(nam > 0) {RENEW(iamt1,int,nk);} + } + + if(ntrans > 0){ + RENEW(inotr,int,2*nk); + } + + /* sorting the elements with distributed loads */ + +/* if(nload>0){ + if(nam>0){ + FORTRAN(isortiddc2,(nelemload,iamload,xload,xloadold,sideload,&nload,&kflag)); + }else{ + FORTRAN(isortiddc1,(nelemload,xload,xloadold,sideload,&nload,&kflag)); + } + }*/ + + /* calling the user routine ufaceload (can be empty) */ + + FORTRAN(ufaceload,(co,ipkon,kon,lakon,nelemload,sideload,&nload)); + + /* decascading MPC's and renumbering the equations: only necessary + if MPC's changed */ + + if(((istep == 1)||(ntrans>0)||(mpcend<0)||(nk!=nkold))&&(icascade==0)) { + + /* decascading the MPC's */ + + printf(" Decascading the MPC's\n\n"); + + callfrommain=1; + cascade(ipompc,&coefmpc,&nodempc,&nmpc, + &mpcfree,nodeboun,ndirboun,&nboun,ikmpc, + ilmpc,ikboun,ilboun,&mpcend,&mpcmult, + labmpc,&nk,&memmpc_,&icascade,&maxlenmpc, + &callfrommain,iperturb,ithermal); + + if(istep==1) nnn=NNEW(int,nk); + else RENEW(nnn,int,nk); + for(i=1;i<=nk;++i) + nnn[i-1]=i; + +// if((icascade==0)&&(isolver!=6)){ + if((icascade==10)&&(isolver!=6)){ + + /* renumbering the nodes */ + + printf(" Renumbering the nodes to decrease the profile:\n"); + fflush(stdout); + + npn=NNEW(int,20*ne+mpcend); + adj=NNEW(int,380*ne+mpcmult); + xadj=NNEW(int,nk+1); + iw=NNEW(int,3*nk+1); + mmm=NNEW(int,nk); + xnpn=NNEW(int,ne+nmpc+1); + inum1=NNEW(int,nk); + inum2=NNEW(int,nk); + + FORTRAN(renumber,(&nk,kon,ipkon,lakon,&ne,ipompc,nodempc,&nmpc,nnn, + npn,adj,xadj,iw,mmm,xnpn,inum1,inum2)); + + free(npn);free(adj);free(xadj);free(iw);free(mmm);free(xnpn); + free(inum1);free(inum2); + } + + } + + /* determining the matrix structure: changes if SPC's have changed */ + + if(icascade==0) printf(" Determining the structure of the matrix:\n"); + + nactdof=NNEW(int,mt*nk); + mast1=NNEW(int,nzs[1]); + irow=NNEW(int,nzs[1]); + + if((mcs==0)||(cs[1]<0)){ + + icol=NNEW(int,4*nk); + jq=NNEW(int,4*nk+1); + ipointer=NNEW(int,4*nk); + + if(icascade==0){ + mastruct(&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,&nboun,ipompc, + nodempc,&nmpc,nactdof,icol,jq,&mast1,&irow,&isolver,neq,nnn, + ikmpc,ilmpc,ipointer,nzs,&nmethod,ithermal, + ikboun,ilboun,iperturb,mi); + } + else{neq[0]=1;neq[1]=1;neq[2]=1;} + } + else{ + + icol=NNEW(int,8*nk); + jq=NNEW(int,8*nk+1); + ipointer=NNEW(int,8*nk); + + mastructcs(&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,&nboun, + ipompc,nodempc,&nmpc,nactdof,icol,jq,&mast1,&irow,&isolver, + neq,nnn,ikmpc,ilmpc,ipointer,nzs,&nmethod, + ics,cs,labmpc,&mcs,mi); + } + + free(ipointer);free(mast1); + if(icascade==0)RENEW(irow,int,nzs[2]); + + /* nmethod=1: static analysis */ + /* nmethod=2: frequency analysis */ + /* nmethod=3: buckling analysis */ + /* nmethod=4: linear dynamic analysis */ + /* nmethod=5: steady state dynamics analysis */ + + if((nmethod<=1)||(iperturb[0]>1)) + { + if(iperturb[0]<2){ + + prespooles(co,&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,xboun,&nboun, + ipompc,nodempc,coefmpc,labmpc,&nmpc,nodeforc,ndirforc,xforc, + &nforc, nelemload,sideload,xload,&nload, + ad,au,b,nactdof,&icol,jq,&irow,neq,&nzl,&nmethod,ikmpc, + ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,&norien,orab,&ntmat_, + t0,t1,t1old,ithermal,prestr,&iprestr, vold,iperturb,sti,nzs, + &kode,adb,aub,filab,eme,&iexpl,plicon, + nplicon,plkcon,nplkcon,xstate,&npmat_,matname, + &isolver,mi,&ncmat_,&nstate_,cs,&mcs,&nkon,ener, + xbounold,xforcold,xloadold,amname,amta,namta, + &nam,iamforc,iamload,iamt1,iamboun,&ttime, + output,set,&nset,istartset,iendset,ialset,&nprint,prlab, + prset,&nener,trab,inotr,&ntrans,fmpc,cbody,ibody,xbody,&nbody, + xbodyold,&tper); + + } + + else{ + + mpcinfo[0]=memmpc_;mpcinfo[1]=mpcfree;mpcinfo[2]=icascade; + mpcinfo[3]=maxlenmpc; + + nonlingeo(&co,&nk,&kon,&ipkon,&lakon,&ne,nodeboun,ndirboun,xboun,&nboun, + &ipompc,&nodempc,&coefmpc,&labmpc,&nmpc,nodeforc,ndirforc,xforc, + &nforc, nelemload,sideload,xload,&nload, + ad,au,b,nactdof,&icol,jq,&irow,neq,&nzl,&nmethod,&ikmpc, + &ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,&ielmat,&ielorien,&norien,orab,&ntmat_, + t0,t1,t1old,ithermal,prestr,&iprestr, + &vold,iperturb,sti,nzs,&kode,adb,aub,filab,&idrct,jmax, + jout,&tinc,&tper,&tmin,&tmax,eme,xbounold,xforcold,xloadold, + veold,accold,amname,amta,namta, + &nam,iamforc,iamload,iamt1,&alpha, + &iexpl,iamboun,plicon,nplicon,plkcon,nplkcon, + &xstate,&npmat_,&istep,&ttime,matname,qaold,mi, + &isolver,&ncmat_,&nstate_,&iumat,cs,&mcs,&nkon,&ener, + mpcinfo,nnn,output, + shcon,nshcon,cocon,ncocon,physcon,&nflow,ctrl, + set,&nset,istartset,iendset,ialset,&nprint,prlab, + prset,&nener,ikforc,ilforc,trab,inotr,&ntrans,&fmpc, + cbody,ibody,xbody,&nbody,xbodyold,ielprop,prop, + &ntie,tieset,&itpamp,&iviewfile,jobnamec,tietol,&inlgeom); + + memmpc_=mpcinfo[0];mpcfree=mpcinfo[1];icascade=mpcinfo[2]; + maxlenmpc=mpcinfo[3]; + + + } + } + else if(nmethod==2) + { + /* FREQUENCY ANALYSIS */ + + if((mcs==0)||(cs[1]<0)){ +#ifdef ARPACK + arpack(co,&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,xboun,&nboun, + ipompc,nodempc,coefmpc,labmpc,&nmpc,nodeforc,ndirforc,xforc, + &nforc, nelemload,sideload,xload,&nload, + ad,au,b,nactdof,icol,jq,irow,neq,&nzl,&nmethod,ikmpc, + ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, + shcon,nshcon,cocon,ncocon, + alcon,nalcon,alzero,ielmat,ielorien,&norien,orab,&ntmat_, + t0,t1,t1old,ithermal,prestr,&iprestr,vold,iperturb,sti,nzs, + &kode,adb,aub,mei,fei,filab, + eme,&iexpl,plicon,nplicon,plkcon,nplkcon, + xstate,&npmat_,matname,mi,&ncmat_,&nstate_,ener,jobnamec, + output,set,&nset,istartset,iendset,ialset,&nprint,prlab, + prset,&nener,&isolver,trab,inotr,&ntrans,&ttime,fmpc,cbody, + ibody,xbody,&nbody);} +#else + printf("*ERROR in CalculiX: the ARPACK library is not linked\n\n"); + FORTRAN(stop,());} +#endif + + else{ +#ifdef ARPACK + arpackcs(co,&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,xboun,&nboun, + ipompc,nodempc,coefmpc,labmpc,&nmpc,nodeforc,ndirforc,xforc, + &nforc, nelemload,sideload,xload,&nload, + ad,au,b,nactdof,icol,jq,irow,neq,&nzl,&nmethod,ikmpc, + ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,&norien,orab,&ntmat_, + t0,t1,t1old,ithermal,prestr,&iprestr, + vold,iperturb,sti,nzs,&kode,adb,aub,mei,fei,filab, + eme,&iexpl,plicon,nplicon,plkcon,nplkcon, + xstate,&npmat_,matname,mi,ics,cs,&mpcend,&ncmat_, + &nstate_,&mcs,&nkon,ener,jobnamec,output,set,&nset,istartset, + iendset,ialset,&nprint,prlab, + prset,&nener,&isolver,trab,inotr,&ntrans,&ttime,fmpc,cbody, + ibody,xbody,&nbody,&nevtot);} +#else + printf("*ERROR in CalculiX: the ARPACK library is not linked\n\n"); + FORTRAN(stop,());} +#endif + + } + else if(nmethod==3) + { +#ifdef ARPACK + arpackbu(co,&nk,kon,ipkon,lakon,&ne,nodeboun,ndirboun,xboun,&nboun, + ipompc,nodempc,coefmpc,labmpc,&nmpc,nodeforc,ndirforc,xforc, + &nforc, + nelemload,sideload,xload,&nload, + ad,au,b,nactdof,icol,jq,irow,neq,&nzl,&nmethod,ikmpc, + ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,&norien,orab,&ntmat_, + t0,t1,t1old,ithermal,prestr,&iprestr, + vold,iperturb,sti,nzs,&kode,adb,aub,mei,fei,filab, + eme,&iexpl,plicon,nplicon,plkcon,nplkcon, + xstate,&npmat_,matname,mi,&ncmat_,&nstate_,ener,output, + set,&nset,istartset,iendset,ialset,&nprint,prlab, + prset,&nener,&isolver,trab,inotr,&ntrans,&ttime,fmpc,cbody, + ibody,xbody,&nbody); +#else + printf("*ERROR in CalculiX: the ARPACK library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(nmethod==4) + { + if((ne1d!=0)||(ne2d!=0)){ + printf(" *WARNING: 1-D or 2-D elements may cause problems in modal dynamic calculations\n"); + printf(" ensure that point loads defined in a *MODAL DYNAMIC step\n"); + printf(" and applied to nodes belonging to 1-D or 2-D elements have been\n"); + printf(" applied to the same nodes in the preceding FREQUENCY step with\n"); + printf(" magnitude zero; look at example shellf.inp for a guideline.\n\n");} + + printf(" Composing the dynamic response from the eigenmodes\n\n"); + + dyna(&co,&nk,&kon,&ipkon,&lakon,&ne,&nodeboun,&ndirboun,&xboun,&nboun, + &ipompc,&nodempc,&coefmpc,&labmpc,&nmpc,nodeforc,ndirforc,xforc,&nforc, + nelemload,sideload,xload,&nload, + &nactdof,neq,&nzl,icol,irow,&nmethod,&ikmpc,&ilmpc,&ikboun,&ilboun, + elcon,nelcon,rhcon,nrhcon,cocon,ncocon, + alcon,nalcon,alzero,&ielmat,&ielorien,&norien,orab,&ntmat_,&t0, + &t1,ithermal,prestr,&iprestr,&vold,iperturb,&sti,nzs, + &tinc,&tper,xmodal,&veold,amname,amta, + namta,&nam,iamforc,iamload,&iamt1, + jout,&kode,filab,&eme,xforcold,xloadold, + &t1old,&iamboun,&xbounold,&iexpl,plicon, + nplicon,plkcon,nplkcon,xstate,&npmat_,matname, + mi,&ncmat_,&nstate_,&ener,jobnamec,&ttime,set,&nset, + istartset,iendset,&ialset,&nprint,prlab, + prset,&nener,trab,&inotr,&ntrans,&fmpc,cbody,ibody,xbody,&nbody, + xbodyold,&istep,&isolver,jq,output,&mcs,&nkon,&mpcend,ics,cs, + &ntie,tieset,&idrct,jmax,&tmin,&tmax,ctrl,&itpamp,tietol,&nalset,&nnn); + } + else if(nmethod==5) + { + if((ne1d!=0)||(ne2d!=0)){ + printf(" *WARNING: 1-D or 2-D elements may cause problems in steady state calculations\n"); + printf(" ensure that point loads defined in a *STEADY STATE DYNAMICS step\n"); + printf(" and applied to nodes belonging to 1-D or 2-D elements have been\n"); + printf(" applied to the same nodes in the preceding FREQUENCY step with\n"); + printf(" magnitude zero; look at example shellf.inp for a guideline.\n\n");} + + printf(" Composing the steady state response from the eigenmodes\n\n"); + + steadystate(&co,&nk,&kon,&ipkon,&lakon,&ne,&nodeboun,&ndirboun,&xboun,&nboun, + &ipompc,&nodempc,&coefmpc,&labmpc,&nmpc,nodeforc,ndirforc,xforc,&nforc, + nelemload,sideload,xload,&nload, + &nactdof,neq,&nzl,icol,irow,&nmethod,&ikmpc,&ilmpc,&ikboun,&ilboun, + elcon,nelcon,rhcon,nrhcon,cocon,ncocon, + alcon,nalcon,alzero,&ielmat,&ielorien,&norien,orab,&ntmat_,&t0, + &t1,ithermal,prestr,&iprestr,&vold,iperturb,sti,nzs, + &tinc,&tper,xmodal,veold,amname,amta, + namta,&nam,iamforc,iamload,&iamt1, + jout,&kode,filab,&eme,xforcold,xloadold, + &t1old,&iamboun,&xbounold,&iexpl,plicon, + nplicon,plkcon,nplkcon,xstate,&npmat_,matname, + mi,&ncmat_,&nstate_,&ener,jobnamec,&ttime,set,&nset, + istartset,iendset,ialset,&nprint,prlab, + prset,&nener,trab,&inotr,&ntrans,&fmpc,cbody,ibody,xbody,&nbody, + xbodyold,&istep,&isolver,jq,output,&mcs,&nkon,ics,cs,&mpcend,&nnn,ctrl); + } + + free(nactdof); + free(icol); + free(jq); + free(irow); + + /* deleting the perturbation loads and temperatures */ + + if((iperturb[0] == 1)&&(nmethod==3)) { + nforc=0; + nload=0; + nbody=0; + if(ithermal[0] == 1) { + for(k=0;k 0) { + for (i=0;i0){ + if(namta[3*iamboun[i]-1]>0){ + iamboun[i]=0; + xboun[i]=xbounold[i];} + } + } + for (i=0;i0){ + if(namta[3*iamforc[i]-1]>0){ + iamforc[i]=0; + xforc[i]=xforcold[i];} + } + } + for (i=0;i<2*nload;i++){ + if(iamload[i]>0){ + if(namta[3*iamload[i]-1]>0){ + iamload[i]=0; + xload[i]=xloadold[i];} + } + } + for (i=1;i<3*nbody;i=i+3){ + if(ibody[i]>0){ + if(namta[3*ibody[i]-1]>0){ + ibody[i]=0; + xbody[7*(i-1)/3]=xbodyold[7*(i-1)/3];} + } + } + if(ithermal[0]==1) { + if(iamt1[i]>0){ + if(namta[3*iamt1[i]-1]>0){ + iamt1[i]=0; + t1[i]=t1old[i];} + } + } + } + } + + + if((nmethod == 4)&&(iperturb[0]>1)) free(accold); + + if(irstrt>0){ + jrstrt++; + if(jrstrt==irstrt){ + jrstrt=0; + FORTRAN(restartwrite,(&istep, &nset, &nload, &nforc, &nboun, &nk, &ne, + &nmpc, &nalset, &nmat, &ntmat_, &npmat_, &norien, &nam, &nprint, + mi, &ntrans, &ncs_, &namtot_, &ncmat_, &mpcend,&maxlenmpc, &ne1d, + &ne2d, &nflow, &nlabel, &iplas, &nkon,ithermal,&nmethod,iperturb, + &nstate_,&nener, set, istartset, iendset, ialset, co, kon, ipkon, + lakon, nodeboun, ndirboun, iamboun, xboun, ikboun, ilboun, ipompc, + nodempc, coefmpc, labmpc, ikmpc, ilmpc, nodeforc, ndirforc, iamforc, + xforc, ikforc, ilforc, nelemload, iamload, sideload, xload, + elcon, nelcon, rhcon, nrhcon, alcon, nalcon, + alzero, plicon, nplicon, plkcon, nplkcon, orname, orab, ielorien, + trab, inotr, amname, amta, namta, t0, t1, iamt1, veold, + ielmat,matname, prlab,prset,filab, vold,nodebounold, + ndirbounold, xbounold, xforcold, xloadold, t1old, eme, + iponor, xnor, knor, thickn, thicke, offset, iponoel, inoel, rig, + shcon, nshcon, cocon, ncocon, ics, + sti, ener, xstate, jobnamec,infree,nnn,prestr,&iprestr,cbody, + ibody,xbody,&nbody,xbodyold,&ttime,qaold,cs,&mcs,output, + physcon,ctrl,typeboun,fmpc,tieset,&ntie,tietol)); + } + } + +} + + FORTRAN(closefile,()); + +#ifdef CALCULIX_MPI +MPI_Finalize(); +#endif + + return 0; + +} + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_bleedtapping.f calculix-ccx-2.3/ccx_2.3/src/cd_bleedtapping.f --- calculix-ccx-2.1/ccx_2.3/src/cd_bleedtapping.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_bleedtapping.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,138 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! this function enable to determine the discharge coefficient of bleed +! tappings +! + subroutine cd_bleedtapping(ps2,ps1,ps1pt1,nummer,curve,x_tab,y_tab + & ,cd) +! +! +! in : SImultation of the secondary air system of aero engines +! K.J.KUTZ T.M. SPEER +! Transactions of the ASME vol.116 April 1994 +! + implicit none +! + integer nummer,id,i,number,curve,index + real*8 x_tab(15),y_tab(15) +! +! Fig.7 tapping with lip +! + real*8 cdx1(9) + data cdx1 + & /0.24d0,0.52d0,0.8d0,1.14d0,1.42d0,1.9d0,2.5d0,3d0,3.4d0/ +! + + real*8 cdy1(9) + data cdy1 + & /0.167d0,0.310d0,0.467d0,0.611d0,0.711d0,0.789d0,0.833d0, + & 0.866d0,0.888d0/ +! +! Fig.7 tapping without lip +! + real*8 cdx2(7) + data cdx2 + & /1.0d0,1.14d0,1.42d0,1.9d0,2.5d0,3.0d0,3.4d0/ + + real*8 cdy2(7) + data cdy2 + & /0.d0,0.122d0,0.377d0,0.7d0,0.766d0,0.769d0,0.772d0/ + + real*8 ps2,ps1,dab,ps2pt1,ps1pt1,cdy(15),cd,cdx(20), + & dabmax +! + ps2pt1=ps2/ps1 + dabmax=100.d0 +! + if(nummer.eq.0) then + if (curve.eq.1) then + index=9 + write(*,*) + write(*,*) 'Cd calculations will be performed using' + write(*,*) 'Cd-Kurven HP3 Schlitz;Kurve Nr. 1' + do i=1,index + cdx(i)=cdx1(i) + cdy(i)=cdy1(i) + enddo +! + elseif(curve.eq.2) then + index=7 + write(*,*) + write(*,*) 'Cd calculations will be performed using' + write(*,*) 'Cd-Kurven HP3 Schlitz;Kurve Nr. 2' + do i=1,index + cdx(i)=cdx2(i) + cdy(i)=cdy2(i) + enddo +! + elseif(curve.gt.2) then + write(*,*) + write(*,*) 'no characteristic available under this index' + write(*,*) 'cd is implicitely assumed equal to 1' + cd=1.d0 + return + endif +! +! psvptv ratio between the static pressure in the main canal +! and the total pressure in the main canal +! +! check whether ps1/pt1 less than 1 , if not then a warning is sent and +! the calculation will peroceed with an "oversized" dab +! + if(abs(1.d0-ps2pt1).le.dabmax*(1.d0-ps1pt1)) then + dab=(1.d0-ps2pt1)/(1.d0-ps1pt1) + else + dab=dabmax + write(*,*) 'in cd_bleedtapping.f: ps1/pt1=',ps1pt1 + write(*,*) 'the calculation will proceed with DAB=100.' + endif +! +! determination of cd with the caracteristics +! + call ident(cdx,dab,index,id) + if(id.eq.1) then + cd=cdy(1) + elseif(id.ge.index) then + cd=cdy(index) + else + cd=cdy(id)+(cdy(id+1)-cdy(id)) + & *(dab-cdx(id))/(cdx(id+1)-cdx(id)) + endif +! + else + if(abs(1.d0-ps2pt1).le.dabmax*(1.d0-ps1pt1)) then + dab=(1.d0-ps2pt1)/(1.d0-ps1pt1) + else + dab=dabmax + write(*,*) 'in cd_bleedtapping.f: ps1/pt1=',ps1pt1 + write(*,*) 'the calculation will proceed with DAB=100.' + endif + + call ident(x_tab,dab,nummer,id) + if(id.le.1d0) then + cd=y_tab(1) + elseif(id.ge.nummer) then + cd=y_tab(nummer) + else + cd=y_tab(id)+(y_tab(id+1)-y_tab(id)) + & *(dab-x_tab(id))/(x_tab(id+1)-x_tab(id)) + endif + endif + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_bragg.f calculix-ccx-2.3/ccx_2.3/src/cd_bragg.f --- calculix-ccx-2.1/ccx_2.3/src/cd_bragg.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_bragg.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,138 @@ +! +! this subroutine enables to calculate a compressibility correction factor +! following the results that can be found in: +! +! S.L.Bragg +! "Effect of conpressibility on the discharge coefficient of orifices +! and convergent nozzles" +! Journal of Mechanical engineering vol 2 No 1 1960 +! + subroutine cd_bragg(cd,p2p1,cdbragg,itype) +! + implicit none +! +! itype is used in the proprietary version of cd_bragg +! + integer nx,ny,idx,idy,i,j,itype +! + real*8 cd,p2p1,cdbragg,z1,z2,z3,z4,et,xi +! + real*8 cd_tab (12) + data cd_tab + & /0.457d0,0.500d0,0.550d0,0.600d0,0.650d0,0.700d0, + & 0.750d0,0.800d0,0.850d0,0.900d0,0.950d0,1.000d0/ +! + real*8 p2p1_tab (19) + data p2p1_tab + & /0.00d0,0.10d0,0.15d0,0.20d0,0.25d0,0.30d0,0.35d0,0.40d0, + & 0.45d0,0.50d0,0.55d0,0.60d0,0.65d0,0.70d0,0.75d0,0.80d0, + & 0.85d0,0.90d0,1.00d0/ +! + real*8 cd_bragg_tab(19,12) + data ((cd_bragg_tab(i,j),i=1,19),j=1,12) + & /0.754d0,0.735d0,0.724d0,0.712d0,0.701d0,0.688d0,0.672d0, + & 0.655d0,0.633d0,0.610d0,0.590d0,0.570d0,0.549d0,0.530d0, + & 0.514d0,0.500d0,0.488d0,0.477d0,0.454d0, +! + & 0.789d0,0.770d0,0.760d0,0.749d0,0.747d0,0.733d0,0.709d0, + & 0.691d0,0.672d0,0.650d0,0.628d0,0.606d0,0.588d0,0.572d0, + & 0.558d0,0.543d0,0.531d0,0.520d0,0.500d0, +! + & 0.833d0,0.815d0,0.805d0,0.796d0,0.783d0,0.771d0,0.758d0, + & 0.740d0,0.720d0,0.700d0,0.675d0,0.655d0,0.638d0,0.621d0, + & 0.607d0,0.592d0,0.580d0,0.569d0,0.550d0, +! + & 0.870d0,0.855d0,0.846d0,0.828d0,0.827d0,0.815d0,0.801d0, + & 0.786d0,0.769d0,0.749d0,0.725d0,0.704d0,0.685d0,0.670d0, + & 0.654d0,0.641d0,0.630d0,0.619d0,0.600d0, +! + & 0.902d0,0.890d0,0.882d0,0.875d0,0.867d0,0.855d0,0.842d0, + & 0.830d0,0.811d0,0.792d0,0.773d0,0.751d0,0.732d0,0.718d0, + & 0.700d0,0.689d0,0.678d0,0.668d0,0.650d0, +! + & 0.929d0,0.920d0,0.912d0,0.908d0,0.900d0,0.890d0,0.880d0, + & 0.869d0,0.852d0,0.835d0,0.815d0,0.794d0,0.778d0,0.761d0, + & 0.749d0,0.736d0,0.725d0,0.716d0,0.700d0, +! + & 0.952d0,0.946d0,0.940d0,0.936d0,0.930d0,0.921d0,0.913d0, + & 0.903d0,0.889d0,0.873d0,0.854d0,0.836d0,0.820d0,0.808d0, + & 0.796d0,0.785d0,0.775d0,0.766d0,0.750d0, +! + & 0.970d0,0.966d0,0.962d0,0.958d0,0.953d0,0.948d0,0.941d0, + & 0.935d0,0.923d0,0.909d0,0.890d0,0.874d0,0.860d0,0.849d0, + & 0.838d0,0.829d0,0.820d0,0.812d0,0.800d0, +! + & 0.983d0,0.9805d0,0.98d0,0.978d0,0.975d0,0.970d0,0.965d0, + & 0.958d0,0.950d0,0.949d0,0.926d0,0.911d0,0.900d0,0.890d0, + & 0.881d0,0.874d0,0.867d0,0.860d0,0.850d0, +! + & 0.992d0,0.991d0,0.990d0,0.989d0,0.988d0,0.985d0,0.981d0, + & 0.980d0,0.973d0,0.967d0,0.956d0,0.943d0,0.935d0,0.928d0, + & 0.920d0,0.915d0,0.910d0,0.907d0,0.900d0, +! + & 0.999d0,0.999d0,0.998d0,0.998d0,0.998d0,0.997d0,0.995d0, + & 0.992d0,0.990d0,0.988d0,0.981d0,0.975d0,0.970d0,0.964d0, + & 0.960d0,0.958d0,0.954d0,0.952d0,0.950d0, +! + & 1.000d0,1.000d0,1.000d0,1.000d0,1.000d0,1.000d0,1.000d0, + & 1.000d0,1.000d0,1.000d0,1.000d0,1.000d0,1.000d0,1.000d0, + & 1.000d0,1.000d0,1.000d0,1.000d0,1.000d0/ +! + nx=19 + ny=12 +! + call ident(p2p1_tab,p2p1,nx,idx) + call ident(cd_tab,cd,ny,idy) +! + if (idx.eq.0) then + if(idy.eq.0) then + cdbragg=cd_bragg_tab(1,1) + else + if(idy.eq.ny) then + cdbragg=cd_bragg_tab(1,ny) + else + cdbragg=cd_bragg_tab(1,idy)+(cd_bragg_tab(1,idy+1) + & -cd_bragg_tab(1,idy)) + & *(cd-cd_tab(idy))/(cd_tab(idy+1)-cd_tab(idy)) + endif + endif +! + elseif(idx.ge.nx) then + if(idy.le.0) then + cdbragg=cd_bragg_tab(nx,1) + else + if(idy.ge.ny) then + cdbragg=cd_bragg_tab(nx,ny) + else + cdbragg=cd_bragg_tab(nx,idy)+ + & (cd_bragg_tab(nx,idy+1)-cd_bragg_tab(nx,idy)) + & *(cd-cd_tab(idy))/(cd_tab(idy+1)-cd_tab(idy)) + endif + endif + else + if(idy.le.0) then +! + cdbragg=cd_bragg_tab(idx,1)+(cd_bragg_tab(idx+1,1) + & -cd_bragg_tab(idx,1)) + & *(p2p1-p2p1_tab(idx))/(p2p1_tab(idx+1) + & -p2p1_tab(idx)) + elseif(idy.ge.ny) then + cdbragg=cd_bragg_tab(idx,ny)+(cd_bragg_tab(idx+1,ny) + & -cd_bragg_tab(idx,ny)) + & *(p2p1-p2p1_tab(idx))/(p2p1_tab(idx+1) + & -p2p1_tab(idx)) + else + xi=(p2p1-p2p1_tab(idx))/(p2p1_tab(idx+1) + & -p2p1_tab(idx)) + et=(cd-cd_tab(idy))/(cd_tab(idy+1)-cd_tab(idy)) + z1=cd_bragg_tab(idx,idy) + z2=cd_bragg_tab(idx+1,idy) + z3=cd_bragg_tab(idx,idy+1) + z4=cd_bragg_tab(idx+1,idy+1) + cdbragg=(1-xi)*(1-et)*z1+(1-xi)*et*z3 + & +xi*(1-et)*z2+xi*et*z4 + endif + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_chamfer.f calculix-ccx-2.3/ccx_2.3/src/cd_chamfer.f --- calculix-ccx-2.1/ccx_2.3/src/cd_chamfer.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_chamfer.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,127 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cd_chamfer(l,d,p_up,p_down,angle,cd) +! +! calculates the discharge coefficient of holes with chamfered inlets +! using N. Hay and A.Spencer +! "Disharge coefficient of Cooling holes with radiused and chamfered +! inlets" ASME 91-GT-269 +! +! Nota:the radius correction is not used here due to the unreliability +! of the results proposed check first line of table 1 +! + implicit none +! + integer i,j,idx,idy,nx,ny +! + real*8 l,d,p_up,p_down,angle,puzpd,lzd,xi,et,z1,z2,z3,z4, + & cd, tab_cd(3,4), tab30(3,4),tab45(3,4) +! + real*8 xpuzpd(3) + data xpuzpd /1.2d0,1.6d0,2.2d0/ +! + real*8 ylzd (4) + data ylzd /0.25d0,0.50d0,1.00d0,2.00d0/ +! + data ((tab30(i,j),i=1,3),j=1,4) + & /1.45d0,1.31d0,1.24d0, + & 1.35d0,1.28d0,1.21d0, + & 1.23d0,1.19d0,1.13d0, + & 1.20d0,1.18d0,1.10d0/ +! + data ((tab45(i,j),i=1,3),j=1,4) + & /1.19d0,1.19d0,1.16d0, + & 1.23d0,1.19d0,1.13d0, + & 1.14d0,1.11d0,1.07d0, + & 1.11d0,1.09d0,1.03d0/ +! + nx=3 + ny=4 +! + lzd=l/d + puzpd=p_up/p_down +! + call ident(xpuzpd,puzpd,nx,idx) + call ident(ylzd,lzd,ny,idy) +! + if (abs(angle-30.d0).le.0.1d0) then + do i=1,3 + do j=1,4 + tab_cd(i,j)=tab30(i,j) + enddo + enddo +! + elseif(abs(angle-45.d0).le.0.1d0) then + do i=1,3 + do j=1,4 + tab_cd(i,j)=tab45(i,j) + enddo + enddo + else + write(*,*) 'in cd_chamfer.f :unacceptable angle',angle,'grad' + stop + endif +! + if (idx.eq.0) then + if(idy.eq.0) then + cd=tab_cd(1,1) + else + if(idy.eq.ny) then + cd=tab_cd(1,ny) + else + cd=tab_cd(1,idy)+(tab_cd(1,idy+1)-tab_cd(1,idy)) + & *(lzd-ylzd(idy))/(ylzd(idy+1)-ylzd(idy)) + endif + endif +! + elseif(idx.ge.nx) then + if(idy.le.0) then + cd=tab_cd(nx,1) + else + if(idy.ge.ny) then + cd=tab_cd(nx,ny) + else + cd=tab_cd(1,idy)+(tab_cd(1,idy+1)-tab_cd(1,idy)) + & *(lzd-ylzd(idy))/(ylzd(idy+1)-ylzd(idy)) + endif + endif + else + if(idy.le.0) then + cd=tab_cd(idx,1)+(tab_cd(idx+1,1)-tab_cd(idx,1)) + & *(puzpd-xpuzpd(idx))/(xpuzpd(idx+1)-xpuzpd(idx)) + elseif(idy.ge.ny) then + cd=tab_cd(idx,ny)+(tab_cd(idx+1,ny)-tab_cd(idx,ny)) + & *(puzpd-xpuzpd(idx))/(xpuzpd(idx+1)-xpuzpd(idx)) + else + xi=(puzpd-xpuzpd(idx))/(xpuzpd(idx+1)-xpuzpd(idx)) + et=(lzd-ylzd(idy))/(ylzd(idy+1)-ylzd(idy)) + z1=tab_cd(idx,idy) + z2=tab_cd(idx+1,idy) + z3=tab_cd(idx,idy+1) + z4=tab_cd(idx+1,idy+1) + cd=(1-xi)*(1-et)*z1+(1-xi)*et*z3 + & +xi*(1-et)*z2+xi*et*z4 + endif + endif +! + write(*,*)'chamfer correction equals to',cd +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_lab_1spike.f calculix-ccx-2.3/ccx_2.3/src/cd_lab_1spike.f --- calculix-ccx-2.1/ccx_2.3/src/cd_lab_1spike.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_lab_1spike.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,117 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! +! this subroutine enables to calculate the discharge coefcieint of +! a labyrinth with one fin as a function of the ratio b/s and the +! pressure ratio Pdownstream/Pupstream +! the results are interpolated +! +! the relevant data can be found in: +! "Air System Correlations Part 1: Labyrinth Seals" +! H.Zimmermann and K.H. Wollf +! ASME 98-GT-206 +! fig 11 p 7 +! + subroutine cd_lab_1spike(pt0zps1,s,b,cd_1spike) +! + implicit none +! + integer nx,ny,idx,idy +! + real*8 pt0zps1,s,b,cd_1spike,z1,z2,z3,z4,xi,et,pdszpus,bzs +! + real*8 Pdszpus_tab(7) + data pdszpus_tab + & /0.400d0,0.500d0,0.555d0,0.625d0,0.714d0,0.833d0,1.000d0/ +! + real*8 bzs_tab(9) + data bzs_tab + & /0.250d0,0.285d0,0.330d0,0.400d0,0.5000d0,0.660d0,1d0,2d0,4d0/ +! + real*8 cd_1spike_tab(7,9) + data cd_1spike_tab + & /0.930d0,0.875d0,0.830d0,0.790d0,0.750d0,0.700d0,0.650d0, + & 0.930d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.660d0, + & 0.930d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.660d0, + & 0.918d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.670d0, + & 0.912d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.675d0, + & 0.900d0,0.875d0,0.830d0,0.800d0,0.750d0,0.710d0,0.687d0, + & 0.900d0,0.875d0,0.830d0,0.800d0,0.750d0,0.725d0,0.687d0, + & 0.912d0,0.875d0,0.862d0,0.837d0,0.800d0,0.785d0,0.743d0, + & 0.912d0,0.880d0,0.870d0,0.860d0,0.860d0,0.855d0,0.850d0/ + bzs=b/s + pdszpus=1/pt0zps1 + nx=7 + ny=9 +! + call ident(pdszpus_tab,pdszpus,nx,idx) + call ident(bzs_tab,bzs,ny,idy) +! + if (idx.eq.0) then + if(idy.eq.0) then + cd_1spike=cd_1spike_tab(1,1) + else + if(idy.eq.ny) then + cd_1spike=cd_1spike_tab(1,ny) + else + cd_1spike=cd_1spike_tab(1,idy)+(cd_1spike_tab(1,idy+1) + & -cd_1spike_tab(1,idy)) + & *(bzs-bzs_tab(idy))/(bzs_tab(idy+1)-bzs_tab(idy)) + endif + endif +! + elseif(idx.ge.nx) then + if(idy.le.0) then + cd_1spike=cd_1spike_tab(nx,1) + else + if(idy.ge.ny) then + cd_1spike=cd_1spike_tab(nx,ny) + else + cd_1spike=cd_1spike_tab(nx,idy)+ + & (cd_1spike_tab(nx,idy+1)-cd_1spike_tab(nx,idy)) + & *(bzs-bzs_tab(idy))/(bzs_tab(idy+1)-bzs_tab(idy)) + endif + endif + else + if(idy.le.0) then +! + cd_1spike=cd_1spike_tab(idx,1)+(cd_1spike_tab(idx+1,1) + & -cd_1spike_tab(idx,1)) + & *(pdszpus-pdszpus_tab(idx))/(pdszpus_tab(idx+1) + & -pdszpus_tab(idx)) + elseif(idy.ge.ny) then + cd_1spike=cd_1spike_tab(idx,ny)+(cd_1spike_tab(idx+1,ny) + & -cd_1spike_tab(idx,ny)) + & *(pdszpus-pdszpus_tab(idx))/(pdszpus_tab(idx+1) + & -pdszpus_tab(idx)) + else + xi=(pdszpus-pdszpus_tab(idx))/(pdszpus_tab(idx+1) + & -pdszpus_tab(idx)) + et=(bzs-bzs_tab(idy))/(bzs_tab(idy+1)-bzs_tab(idy)) + z1=cd_1spike_tab(idx,idy) + z2=cd_1spike_tab(idx+1,idy) + z3=cd_1spike_tab(idx,idy+1) + z4=cd_1spike_tab(idx+1,idy+1) + cd_1spike=(1-xi)*(1-et)*z1+(1-xi)*et*z3 + & +xi*(1-et)*z2+xi*et*z4 + endif + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_lab_cdrzcdlab.f calculix-ccx-2.3/ccx_2.3/src/cd_lab_cdrzcdlab.f --- calculix-ccx-2.1/ccx_2.3/src/cd_lab_cdrzcdlab.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_lab_cdrzcdlab.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,44 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! This subroutine is a dummy subroutine , to the knowledge of the authors +! no public source is available for such data +! + + subroutine cd_lab_cdrzcdlab (t,s,hst,x,p1,p2,cd_cdrzcdlab) +! + implicit none +! +! integer +! + real*8 t,s,hst,x,p1,p2,cd_cdrzcdlab +! + t=t + s=s + hst=hst + x=x + p1=p1 + p2=p2 + cd_cdrzcdlab=1.d0 +! + write(*,*) '*WARNING while using subroutine cd_lab_cdrzcdlab.f' + write(*,*) 'cd implicitely taken equal to 1' +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_lab_correction.f calculix-ccx-2.3/ccx_2.3/src/cd_lab_correction.f --- calculix-ccx-2.1/ccx_2.3/src/cd_lab_correction.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_lab_correction.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,130 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! +! this subroutine enables to calculate thecorrection factor of the discharge +! coefficient of a labyrinth with one fin as a function of the ratio b/s and the +! pressure ratio Pdownstream/Pupstream +! the results are interpolated +! +! the relevant data can be found in: +! "Air System Correlations Part 1: Labyrinth Seals" +! H.Zimmermann and K.H. Wollf +! ASME 98-GT-206 +! fig 12 p 7 +! + subroutine cd_lab_correction(p1p2,s,b,cd_correction) +! + implicit none +! + integer nx,ny,idx,idy +! + real*8 s,b,cd_correction,z1,z2,z3,z4,xi,et,szb,p1p2 +! + real*8 puszpds_tab(7) + data puszpds_tab + & /1.d0,1.2d0,1.4d0,1.6d0,1.8d0,2.d0,2.5d0/ +! + real*8 szb_tab(9) + data szb_tab + & /0.25d0,0.5d0,1.d0,1.5d0,2d0,2.5d0,3d0,3.5d0,4d0/ +! + real*8 cd_correction_tab(9,7) + data cd_correction_tab + & /1.05d0,1.07d0,1.03d0,0.98d0,0.95d0,0.94d0,0.95d0,0.95d0,0.95d0, + & 1.15d0,1.07d0,1.02d0,0.95d0,0.92d0,0.91d0,0.91d0,0.92d0,0.92d0, + & 1.15d0,1.05d0,0.98d0,0.91d0,0.88d0,0.86d0,0.86d0,0.87d0,0.87d0, + & 1.15d0,1.04d0,0.95d0,0.87d0,0.85d0,0.84d0,0.83d0,0.83d0,0.83d0, + & 1.15d0,1.03d0,0.91d0,0.85d0,0.81d0,0.80d0,0.80d0,0.80d0,0.80d0, + & 1.15d0,1.01d0,0.90d0,0.82d0,0.79d0,0.79d0,0.77d0,0.77d0,0.77d0, + & 1.10d0,1.00d0,0.88d0,0.79d0,0.75d0,0.74d0,0.73d0,0.72d0,0.70d0/ +! + szb=s/b +! + nx=9 + ny=7 +! +! p1p2=1/p2p1 +! if ((p1p2.ge.2.5d0).or.(szb.ge.4d0))then +! write(*,*) '*WARNING in cd_lab_correction' +! write(*,*) 'p1p2>2.5 or szb>4' +! write(*,*) 'check input file' +! write(*,*) 'calculation will proceed using cd_lab_correction=1' +! cd_correction=1.d0 +! return +! endif +! + call ident(puszpds_tab,p1p2,ny,idy) + call ident(szb_tab,szb,nx,idx) +! + if (idx.eq.0) then + if(idy.eq.0) then + cd_correction=cd_correction_tab(1,1) + else + if(idy.eq.ny) then + cd_correction=cd_correction_tab(1,ny) + else + cd_correction=cd_correction_tab(1,idy) + & +(cd_correction_tab(1,idy+1)-cd_correction_tab(1,idy)) + & *(szb-szb_tab(idx))/(szb_tab(idx+1)-szb_tab(idx)) + endif + endif +! + elseif(idx.ge.nx) then + if(idy.le.0) then + cd_correction=cd_correction_tab(nx,1) + else + if(idy.ge.ny) then + cd_correction=cd_correction_tab(nx,ny) + else + cd_correction=cd_correction_tab(nx,idy) + & +(cd_correction_tab(nx,idy+1)-cd_correction_tab(nx,idy)) + & *(szb-szb_tab(idx))/(szb_tab(idx+1)-szb_tab(idx)) + endif + endif + else + if(idy.le.0) then +! + cd_correction=cd_correction_tab(idx,1) + & +(cd_correction_tab(idx+1,1)-cd_correction_tab(idx,1)) + & *(p1p2-puszpds_tab(idy))/(puszpds_tab(idy+1) + & -puszpds_tab(idy)) + elseif(idy.ge.ny) then + cd_correction=cd_correction_tab(idx,ny) + & +(cd_correction_tab(idx+1,ny)-cd_correction_tab(idx,ny)) + & *(p1p2-puszpds_tab(idy))/(puszpds_tab(idy+1) + & -puszpds_tab(idy)) + else + et=(p1p2-puszpds_tab(idy))/(puszpds_tab(idy+1) + & -puszpds_tab(idy)) + xi=(szb-szb_tab(idx))/(szb_tab(idx+1)-szb_tab(idx)) + z1=cd_correction_tab(idx,idy) + z2=cd_correction_tab(idx+1,idy) + z3=cd_correction_tab(idx,idy+1) + z4=cd_correction_tab(idx+1,idy+1) + cd_correction=(1-xi)*(1-et)*z1+(1-xi)*et*z3 + & +xi*(1-et)*z2+xi*et*z4 + endif + endif +! +! if (cd_correction.ge.1.d0)then +! cd_correction=1.d0 +! endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_lab_honeycomb.f calculix-ccx-2.3/ccx_2.3/src/cd_lab_honeycomb.f --- calculix-ccx-2.1/ccx_2.3/src/cd_lab_honeycomb.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_lab_honeycomb.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,68 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! This subroutine enables to calculate the correction factor for a labyrinth seal +! wit a honeycomb stator +! s= gap, hl= width of a honeycomb cell +! the correction factors are interpolated from a table +! +! H.Zimmermann and K.h. Wolff +! "Air system correlations part 1 Labyrinth seals" +! asme 98-GT-206 +! + subroutine cd_lab_honeycomb(s,lc,cd_honeycomb) +! + implicit none +! + integer id +! + real*8 s,lc,cd_honeycomb,szlc +! +! lc=1/8 inch +! + real*8 szl(11) + data szl + & /0.05d0,0.06d0,0.075d0,0.081d0,0.1d0,0.13d0,0.15d0,0.16d0, + & 0.20d0,0.30d0,0.40d0/ +! + real*8 deltamp(11) + data deltamp + & /97.1d0,40d0,32d0,23d0,20d0,0d0,-3.3d0,-5.7d0,-8.5d0, + & -11.43d0,-12d0/ +! +! extrapolation + szlc=s/lc +! if (szlc.gt.0.40d0) then +! cd_honeycomb=deltamp(11) +! endif +! +! intrapolation +! + call ident(szl,szlc,11,id) +! call ident(yz,q,11,idy) + if(id.eq.1) then + cd_honeycomb=deltamp(1) + elseif(id.eq.11) then + cd_honeycomb=deltamp(11) + else + cd_honeycomb=deltamp(id)+(deltamp(id+1)-deltamp(id)) + & *(szlc-szl(id))/(szl(id+1)-szl(id)) + endif +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_lab_radius.f calculix-ccx-2.3/ccx_2.3/src/cd_lab_radius.f --- calculix-ccx-2.1/ccx_2.3/src/cd_lab_radius.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_lab_radius.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,90 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! This subroutines enables to caclulate a correction term linked to with the radius +! of the spike as a function of r/s (radius/gap) +! the parameter Hst ( height of the step ) enable to select either the table for a +! straight labyrinth (Hst=0) or for a stepped labyrinth +! +! H.Zimmermann and K.h. Wolff +! "Air system correlations part 1 Labyrinth seals" +! asme 98-GT-206 +! + subroutine cd_lab_radius(rad,s,hst,cd_radius) +! + implicit none +! + integer id,i,number +! + real*8 rad,s,cd_radius,rzs_tab(9),cd_sharp(9),rzs,hst +! + real*8 rzs_tab1(9) + data rzs_tab1 + & /0d0,0.05d0,0.100d0,0.150d0,0.200d0,0.250d0,0.300d0,0.350d0, + & 0.400d0/ +! + real*8 cd_sharp1(9) + data cd_sharp1 + & /1d0,1.025d0,1.10d0,1.11d0,1.12d0,1.125d0,1.126d0,1.127d0, + & 1.127d0/ +! + real*8 rzs_tab2(9) + data rzs_tab2 + & /0d0,0.05d0,075d0,0.100d0,0.15d0,0.20d0,0.25d0,0.30d0,0.40d0/ +! + real*8 cd_sharp2(9) + data cd_sharp2 + & /1d0,1.10d0,1.15d0,1.20d0,1.26d0,1.31d0,1.34d0,1.36d0,1.37d0/ +! + rzs=rad/s +! +! straight labyrinth +! + if(hst.eq.0d0) then + call ident(rzs_tab1,rzs,9,id) + number=9 + do i=1,9 + rzs_tab(i)=rzs_tab1(i) + cd_sharp(i)=cd_sharp1(i) + enddo +! +! stepped labyrinth +! + else + call ident(rzs_tab2,rzs,9,id) + number=9 + do i=1,9 + rzs_tab(i)=rzs_tab2(i) + cd_sharp(i)=cd_sharp2(i) + enddo + endif +! +! linear interpolation +! +! + if(id.eq.1) then + cd_radius=cd_sharp(1) + elseif(id.eq.number) then + cd_radius=cd_sharp(number) + else + cd_radius=cd_sharp(id)+(cd_sharp(id+1)-cd_sharp(id)) + & *(rzs-rzs_tab(id))/(rzs_tab(id+1)-rzs_tab(id)) + endif +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_lab_reynolds.f calculix-ccx-2.3/ccx_2.3/src/cd_lab_reynolds.f --- calculix-ccx-2.1/ccx_2.3/src/cd_lab_reynolds.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_lab_reynolds.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,59 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! this subroutine enables to calculate the discharge coefficient of a stepped labyrinth seal +! as a function of the reynolds number, the ratios s/l ,r/b and p1/p2 +! +! the related data can be found in +! "Some aerodynamic Aspects of Engine Secondary air systems" +! H. Zimmermann +! ASME 89-GT-209 +! Table p 7 +! + subroutine cd_lab_reynolds(reynolds,cd_reynolds) +! + implicit none +! + integer id +! + real*8 reynolds , cd_reynolds +! + real*8 tab_reynolds(6) + data tab_reynolds + & /220.d0,630.d0,1260d0,2300d0,3200d0,4300d0/ +! + real*8 tab_cd(6) + data tab_cd + & / 0.32d0,0.39d0,0.44d0,0.49d0,0.25d0,0.54d0/ + + call ident(tab_reynolds,reynolds,6,id) + + if(id.eq.1) then + cd_reynolds=tab_cd(1) + elseif(id.eq.18) then + cd_reynolds=tab_cd(6) + else + cd_reynolds=tab_cd(id)+(tab_cd(id+1)-tab_cd(id)) + & *(reynolds-tab_reynolds(id)) + & /(tab_reynolds(id+1)-tab_reynolds(id)) + endif +! + return +! + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_lab_straight.f calculix-ccx-2.3/ccx_2.3/src/cd_lab_straight.f --- calculix-ccx-2.1/ccx_2.3/src/cd_lab_straight.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_lab_straight.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,227 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! this subroutine enables to calculate the dicharge coefficient +! for a labyrinth with more than one spike +! as a function of the number of spikes(n), the pressure ratio (p2p1), +! the ratio between the gap and the breadth of the spike (s/b), +! the number of reynolds (reynolds) +! +! H.Zimmermann and K.h. Wolff +! "Air system correlations part 1 Labyrinth seals" +! asme 98-GT-206 +! + subroutine cd_lab_straight (n,p2p1,s,b,reynolds,cd_lab) +! + implicit none +! + integer i,j,n,idx,idy,nx,ny +! + real*8 szb,p2p1,p1p2,s,b,reynolds,cd_lab,z1,z2,z3,z4, + & et,xi +! + real*8 szb1(3) + data szb1 + & /0.230000d0,0.440000d0,0.830000d0/ +! + real*8 reynlds1(21) + data reynlds1 + & /100.0d0,200.0d0,300.d0,400.0d0,500.00d0,1000.0d0, + & 2000.d0,3000.d0,5000.d0,7000.d0,9000.d0,11000.d0,13000.d0, + & 15000.d0,18000.d0,21000.d0,25000.d0,30000.d0,35000.d0, + & 40000.d0,50000.d0/ +! + real*8 tcd1(3,21) + data ((tcd1(i,j),i=1,3),j=1,21) + & /0.470d0,0.330d0,0.230d0, + & 0.500d0,0.365d0,0.274d0, + & 0.517d0,0.385d0,0.300d0, + & 0.520d0,0.400d0,0.320d0, + & 0.530d0,0.415d0,0.333d0, + & 0.550d0,0.449d0,0.376d0, + & 0.575d0,0.483d0,0.420d0, + & 0.590d0,0.500d0,0.450d0, + & 0.607d0,0.530d0,0.480d0, + & 0.620d0,0.550d0,0.500d0, + & 0.625d0,0.565d0,0.515d0, + & 0.630d0,0.570d0,0.527d0, + & 0.630d0,0.580d0,0.540d0, + & 0.630d0,0.585d0,0.555d0, + & 0.630d0,0.589d0,0.565d0, + & 0.630d0,0.589d0,0.576d0, + & 0.630d0,0.590d0,0.580d0, + & 0.630d0,0.590d0,0.588d0, + & 0.630d0,0.590d0,0.590d0, + & 0.630d0,0.590d0,0.590d0, + & 0.630d0,0.590d0,0.590d0/ +! + real*8 szb2(3) + data szb2 + & /0.230000d0,0.440000d0,0.830000d0/ +! + real*8 reynlds2(21) + data reynlds2 + & /100.0d0,200.0d0,300.d0,400.0d0,500.00d0,1000.0d0, + & 2000.d0,3000.d0,5000.d0,7000.d0,9000.d0,11000.d0,13000.d0, + & 15000.d0,18000.d0,21000.d0,25000.d0,30000.d0,35000.d0, + & 40000.d0,50000.d0/ +! + real*8 tcd2(3,21) + data ((tcd2(i,j),i=1,3),j=1,21) + & /0.400d0,0.335d0,0.250d0, + & 0.445d0,0.390d0,0.308d0, + & 0.470d0,0.420d0,0.340d0, + & 0.490d0,0.440d0,0.360d0, + & 0.505d0,0.455d0,0.380d0, + & 0.550d0,0.500d0,0.442d0, + & 0.600d0,0.555d0,0.500d0, + & 0.625d0,0.580d0,0.525d0, + & 0.650d0,0.615d0,0.570d0, + & 0.660d0,0.640d0,0.600d0, + & 0.660d0,0.650d0,0.617d0, + & 0.660d0,0.655d0,0.635d0, + & 0.660d0,0.657d0,0.645d0, + & 0.660d0,0.660d0,0.650d0, + & 0.660d0,0.660d0,0.655d0, + & 0.660d0,0.660d0,0.660d0, + & 0.660d0,0.660d0,0.660d0, + & 0.660d0,0.660d0,0.660d0, + & 0.660d0,0.660d0,0.660d0, + & 0.660d0,0.660d0,0.660d0, + & 0.660d0,0.660d0,0.660d0/ +! + p1p2=1/p2p1 + szb=s/b +! +! which table is to be used? +! + if(n.le.2) then +! cd is interpolated in tcd1 +! + nx=3 + ny=22 +! interpolation in the 2d table. +! + call ident(szb1,szb,nx,idx) + call ident(reynlds1,reynolds,ny,idy) +! + if (idx.eq.0) then + if(idy.eq.0) then + cd_lab=tcd1(1,1) + else + if(idy.eq.ny) then + cd_lab=tcd1(1,ny) + else + cd_lab=tcd1(1,idy)+(tcd1(1,idy+1)-tcd1(1,idy)) + & *(reynolds-reynlds1(idy)) + & /(reynlds1(idy+1)-reynlds1(idy)) + endif + endif +! + elseif(idx.ge.nx) then + if(idy.le.0) then + cd_lab=tcd1(nx,1) + else + if(idy.ge.ny) then + cd_lab=tcd1(nx,ny) + else + cd_lab=tcd1(nx,idy)+(tcd1(nx,idy+1)-tcd1(nx,idy)) + & *(reynolds-reynlds1(idy)) + & /(reynlds1(idy+1)-reynlds1(idy)) + endif + endif + else + if(idy.le.0) then + + cd_lab=tcd1(idx,1)+(tcd1(idx+1,1)-tcd1(idx,1)) + & *(szb-szb1(idx))/(szb1(idx+1)-szb1(idx)) + elseif(idy.ge.ny) then + cd_lab=tcd1(idx,ny)+(tcd1(idx+1,ny)-tcd1(idx,ny)) + & *(szb-szb1(idx))/(szb1(idx+1)-szb1(idx)) + else + xi=(szb-szb1(idx))/(szb1(idx+1)-szb1(idx)) + et=(reynolds-reynlds1(idy))/ + & (reynlds1(idy+1)-reynlds1(idy)) + z1=tcd1(idx,idy) + z2=tcd1(idx+1,idy) + z3=tcd1(idx,idy+1) + z4=tcd1(idx+1,idy+1) + cd_lab=(1-xi)*(1-et)*z1+(1-xi)*et*z3 + & +xi*(1-et)*z2+xi*et*z4 + endif + endif +! + else +! cd is interpolated in tcd2 +! + nx=3 + ny=21 +! interpolation in the 2d table. +! + call ident(szb2,szb,nx,idx) + call ident(reynlds2,reynolds,ny,idy) +! + if (idx.eq.0) then + if(idy.eq.0) then + cd_lab=tcd2(1,1) + else + if(idy.eq.ny) then + cd_lab=tcd2(1,ny) + else + cd_lab=tcd2(1,idy)+(tcd2(1,idy+1)-tcd2(1,idy)) + & *(reynolds-reynlds2(idy)) + & /(reynlds2(idy+1)-reynlds2(idy)) + endif + endif +! + elseif(idx.ge.nx) then + if(idy.le.0) then + cd_lab=tcd2(nx,1) + else + if(idy.ge.ny) then + cd_lab=tcd2(nx,ny) + else + cd_lab=tcd2(nx,idy)+(tcd2(nx,idy+1)-tcd2(nx,idy)) + & *(reynolds-reynlds2(idy)) + & /(reynlds2(idy+1)-reynlds2(idy)) + endif + endif + else + if(idy.le.0) then + + cd_lab=tcd2(idx,1)+(tcd2(idx+1,1)-tcd2(idx,1)) + & *(szb-szb2(idx))/(szb2(idx+1)-szb2(idx)) + elseif(idy.ge.ny) then + cd_lab=tcd2(idx,ny)+(tcd2(idx+1,ny)-tcd2(idx,ny)) + & *(szb-szb2(idx))/(szb2(idx+1)-szb2(idx)) + else + xi=(szb-szb2(idx))/(szb2(idx+1)-szb2(idx)) + et=(reynolds-reynlds2(idy))/ + & (reynlds2(idy+1)-reynlds2(idy)) + z1=tcd2(idx,idy) + z2=tcd2(idx+1,idy) + z3=tcd2(idx,idy+1) + z4=tcd2(idx+1,idy+1) + cd_lab=(1-xi)*(1-et)*z1+(1-xi)*et*z3 + & +xi*(1-et)*z2+xi*et*z4 + endif + endif +! + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_lichtarowicz.f calculix-ccx-2.3/ccx_2.3/src/cd_lichtarowicz.f --- calculix-ccx-2.1/ccx_2.3/src/cd_lichtarowicz.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_lichtarowicz.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,52 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! This subroutines enables to calculate the reynolds number correction after: +! "Discharge coeffcients for incompressible non-cavitating flowthrough long orifices" +! A. Lichtarowicz, R.K duggins and E. Markland +! Journal Mechanical Engineering Science , vol 7, No. 2, 1965 +! + subroutine cd_lichtarowicz(cd,cdu,reynolds,amod,bdh) +! + implicit none +! +! integer +! + real*8 cdu,reynolds,amod,bdh,eps,A1,cd_diff,cd0,cd +! + cd0=cdu + cd_diff=1.d0 +! + do 10 while (cd_diff.ge.1E-3) +! + cd=cd0 + A1=20/(reynolds*dsqrt(1.d0-Amod**2))*(1.d0+2.25d0*bdh) + eps=(0.005d0*bdh)/(1.d0+7.5d0*(log10(0.00015d0*reynolds* + & dsqrt(1.d0-Amod**2)/cd))**2) + + cd=((-1/cdu+eps)+dsqrt((1/cdu-eps)**2.d0+4.d0*A1))/(2*A1) +! + cd_diff=dabs(cd-cd0) +! + cd0=cd +! + 10 continue +! write(*,*) 'lichtarowitz correction cd=',cd +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_Mcgreehan_Schotsch.f calculix-ccx-2.3/ccx_2.3/src/cd_Mcgreehan_Schotsch.f --- calculix-ccx-2.1/ccx_2.3/src/cd_Mcgreehan_Schotsch.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_Mcgreehan_Schotsch.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,46 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! +! this subroutine enables to calculate the basis incompressible +! discharge coefficient +! +! "Flow Characteristics of long orifices with rotation and corner radiusing" +! W.F. Mcgreehan and M.J. Schotsch +! ASME 87-GT-162 + + subroutine cd_Mcgreehan_Schotsch(rzdh,bdh,reynolds,cdu) +! + implicit none +! + real*8 cdu,bdh,reynolds,cd_re,rzdh,cd_r +! + cd_re=0.5885d0+372d0/reynolds +! +! the radius correction +! + cd_r=1-(0.008d0+0.992d0*exp(-5.5d0*rzdh-3.5d0*rzdh**2)) + & *(1-cd_re) +! + cdu=1.d0-(1.d0-cd_r)*(1d0+1.3d0*exp(-1.606d0*(bdh*bdh))) + & *(0.435d0+0.021d0*bdh) +! + return +! + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_ms_ms.f calculix-ccx-2.3/ccx_2.3/src/cd_ms_ms.f --- calculix-ccx-2.1/ccx_2.3/src/cd_ms_ms.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_ms_ms.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,75 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cd_ms_ms(p1,p2,T1,rad,d,xl,kappa,r,reynolds,u,vid,cd) +! +! This subroutine enables to calculate the discharge coefficient for an +! orifice (shap edged , rotating..) following the results obtained +! by Mcgreehan and Schotsch +! The decription of the method can be found in : +! "Flow characteristics of long orifices with rotation and +! corner radiusing" +! ASME 87-GT-162 +! + implicit none +! + real*8 p1,p2,T1,rad,d,xl,kappa,r,reynolds,u,cd,qlim,q, + & c1,c2,c3,fakt,aux,rzd,lkorr,qkorr,rv,vid +! + qlim=10.d0 +! +! taking in account the influence of the Reynolds number +! + cd=0.5885d0+372.d0/reynolds + cd=min(cd,1.d0) +! +! taking in account the edge radius +! + rzd=rad/d + aux=exp(-(3.5d0*rzd+5.5d0)*rzd) + fakt=aux+0.008d0*(1.d0-aux) + cd=1.d0-fakt*(1.d0-cd) + cd=min(max(cd,0.d0),1.d0) +! +! taking in account the lenght of the orifice +! + lkorr=xl-rad + q=lkorr/d + qkorr=min(q,qlim) + fakt=(1.d0+1.3d0*exp(-1.606d0*qkorr**2.d0))* + & (0.435d0+0.021d0*qkorr)/(2.3d0*0.435d0) + cd=1.d0-fakt*(1.d0-cd) + cd=min(max(cd,0.d0),1.d0) +! +! taking in account the tangential velocity +! + if(u.ne.0d0) then + vid=dsqrt(2.d0*kappa/(kappa-1.d0)*r*T1* + & (1.d0-(p2/p1)**((kappa-1.d0)/kappa))) + rv=u/vid*(0.6d0/cd)**3 + c1=exp(-rv**1.2d0) + c2=0.5d0*rv**0.6d0*dsqrt(0.6d0/cd) + c3=exp(-0.5d0*rv**0.9d0) + cd=cd*(c1+c2*c3) + cd=min(max(cd,0.d0),1.d0) +! + endif +! +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_own_albers.f calculix-ccx-2.3/ccx_2.3/src/cd_own_albers.f --- calculix-ccx-2.1/ccx_2.3/src/cd_own_albers.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_own_albers.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,42 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cd_own_albers(p1,p2,xl,d,cd,u,T1,R,kappa) +! + real*8 d,xl,p1,p2,cd,T1,R,kappa,u +! + p1=p1 + p2=p2 + xl=xl + d=d + u=u + T1=T1 + R=R + kappa=Kappa + cd=1.d0 + write(*,*) '*WARNING while using subroutine cd_own_albers.f' + write(*,*) 'cd implicitely taken equal to 1' + +! + return +! + end + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_pk_albers.f calculix-ccx-2.3/ccx_2.3/src/cd_pk_albers.f --- calculix-ccx-2.1/ccx_2.3/src/cd_pk_albers.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_pk_albers.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,47 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cd_pk_albers(rad,d,xl,reynolds,p2,p1,beta,kappa,cd,u, + & T1,R) +! + implicit none +! + real*8 rad,d,xl,reynolds,p2,p1,beta,kappa, + & cd,R,u,T1 +! + rad=rad + d=d + xl=xl + reynolds=reynolds + p2=p2 + p1=p1 + beta=beta + kappa=kappa + R=R + u=u + T1=T1 + + + cd=1.d0 + + write(*,*) '*WARNING while using subroutine cd_pk_albers.f' + write(*,*) 'cd implicitely taken equal to 1' +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_pk_ms.f calculix-ccx-2.3/ccx_2.3/src/cd_pk_ms.f --- calculix-ccx-2.1/ccx_2.3/src/cd_pk_ms.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_pk_ms.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,81 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cd_pk_ms(rad,d,xl,reynolds,p2,p1,beta,kappa,cd,u, + & T1,R) +! +! This subroutines enable to calculate the compressible discharge +! coefficient for thin and long orifices with corner radiusing; +! + implicit none +! + real*8 rad,d,xl,lqd,rqd,reynolds,p2,p1,p2p1,beta,beta_cor,kappa, + & cd,cdc_cl1,cdc_cl3,rldb,R,u,T1,c1,c2, + & c3,ms_cdr,rv,vid +! + p2p1=p2/p1 + rqd=rad/d + lqd=xl/d + rldb=max(lqd,0.d0) +! +! the method of cd calculation for a sharp edged aperture is only valid +! for beta comprised between 0 and 0.7 +! + if (beta.gt.0.7d0) then + beta_cor=0.7d0 + else + beta_cor=beta + endif +! +! differences between class1 or class2 or class3 +! + if (lqd.eq.rqd) then +! +! class1 +! + call pk_cdc_cl1(lqd,reynolds,p2p1,beta_cor,kappa,cdc_cl1) + cd=cdc_cl1 + else +! +! class2 or class3 (clas2 is a sub class of class3 ) +! + call pk_cdc_cl3(lqd,rqd,reynolds,p2p1,beta_cor,kappa,cdc_cl3) + cd=cdc_cl3 + endif +! +! if rotating orifice with Mac Greehan & Scotch +! The decription of the method can be found in : +! "Flow characteristics of long orifices with rotation and +! corner radiusing" ASME 87-GT-16 +! +! rotating case eq 17 + + if (u.ne.0) then + vid=dsqrt(2.d0*kappa/(kappa-1.d0)*R*T1* + & (1.d0-p2/p1**((kappa-1.d0)/kappa))) + rv=1000*u/vid*(cd/0.6)**(-3) + c1=exp(-rv**1.2d0) + c2=0.5*rv**(0.6d0)*(cd/0.6)**(-0.5d0) + c3=exp(-0.5d0*rv**0.9d0) + ms_cdr=cd*(c1+c2*c3) + cd=ms_cdr + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cd_preswirlnozzle.f calculix-ccx-2.3/ccx_2.3/src/cd_preswirlnozzle.f --- calculix-ccx-2.1/ccx_2.3/src/cd_preswirlnozzle.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cd_preswirlnozzle.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,73 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! this function enable to determine the discharge coefficient of +! preswirl nozzles +! + subroutine cd_preswirlnozzle(ps2,pt1,number,curve,x_tab,y_tab,cd) +! +! +! in : SImultation of the secondary air system of aero engines +! K.J.KUTZ T.M. SPEER +! Transactions of the ASME vol.116 April 1994 +! + implicit none +! + integer id,number,curve +! + real*8 x_tab(15),y_tab(15) +! + real*8 cdxp(11) + data cdxp + & /0.4d0,0.45d0,0.50d0,0.55d0,0.60d0,0.65d0,0.70d0,0.75d0, + & 0.80d0,0.85d0,0.90d0/ +! + real*8 cdyp(11) + data cdyp + & /0.942d0,0.939d0,0.932d0,0.929d0,0.925d0,0.921d0,0.917d0, + & 0.910d0,0.899d0,0.881d0,0.873d0/ +! +! determination of cd with the caracteristics by interpolation +! + real*8 ps2,pt1,ps2vpt1,cd +! + ps2vpt1=ps2/pt1 + if(number.eq.0) then + call ident(cdxp,ps2vpt1,11,id) + if(id.eq.0.6d0) then + cd=cdyp(1) + elseif(id.ge.1) then + cd=cdyp(11) + else + cd=cdyp(id)+(cdyp(id+1)-cdyp(id)) + & *(ps2vpt1-cdxp(id))/(cdxp(id+1)-cdxp(id)) + endif + else + call ident(x_tab,ps2vpt1,number,id) + if(id.le.1d0) then + cd=y_tab(1) + elseif(id.ge.15) then + cd=y_tab(15) + else + cd=y_tab(id)+(y_tab(id+1)-y_tab(id)) + & *(ps2vpt1-x_tab(id))/(x_tab(id+1)-x_tab(id)) + endif + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cfdconv.f calculix-ccx-2.3/ccx_2.3/src/cfdconv.f --- calculix-ccx-2.1/ccx_2.3/src/cfdconv.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cfdconv.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,119 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cfdconv(vold,voldcon,v,nk, + & ielmat,ntmat_,shcon,nshcon,rhcon,nrhcon,iout, + & nmethod,convergence,physcon,iponoel,inoel,ithermal, + & nactdoh,iit,compressible,ismooth,voldtu,vtu,turbulent, + & inomat,nodeboun,ndirboun,nboun,mi,co,factor,voldconini, + & dtimef) +! +! calculates the change in solution +! + implicit none +! + integer convergence,compressible +! + integer nrhcon(*),ntmat_,nactdoh(0:4,*),iit,turbulent, + & nshcon(*),ielmat(*),nk,ithermal,i,j,k,index,iout, + & nmethod,imat,nelem,iponoel(*),inoel(3,*),ismooth, + & inomat(*),node,nodeboun(*),ndirboun(*),nboun,mi(2) +! + real*8 v(0:mi(2),*),vold(0:mi(2),*),voldcon(0:4,*), + & rhcon(0:1,ntmat_,*),rho,c1,vmax(0:4),dummy,press, + & vconmax(0:4),cp,r,temp,temp0,c2,c3,tempnew,vel2, + & shcon(0:3,ntmat_,*),drho,dtemp,physcon(*),dpress, + & voldtu(2,*),vtu(2,*),co(3,*),factor,voldconini(0:4,*), + & dtimef +! + do j=0,4 + vmax(j)=0.d0 + vconmax(j)=0.d0 + enddo +! + if(compressible.eq.1) then + do i=1,nk + do j=0,4 + vmax(j)=vmax(j)+(voldcon(j,i)-voldconini(j,i))**2 + vconmax(j)=vconmax(j)+voldconini(j,i)**2 + voldconini(j,i)=voldcon(j,i) + enddo + enddo + else + do i=1,nk + do j=0,3 + vmax(j)=vmax(j)+(voldcon(j,i)-voldconini(j,i))**2 + vconmax(j)=vconmax(j)+voldconini(j,i)**2 + voldconini(j,i)=voldcon(j,i) + enddo +! +! for incompressible fluids the pressure is stored +! in vold(4,*), the initial pressure in +! voldconini(4,*) +! + do j=4,4 + vmax(j)=vmax(j)+(vold(j,i)-voldconini(j,i))**2 + vconmax(j)=vconmax(j)+voldconini(j,i)**2 + voldconini(j,i)=vold(j,i) + enddo + enddo + endif +! +! for steady state calculations: check convergence +! + convergence=0 + do i=0,4 + vmax(i)=dsqrt(vmax(i)) + vconmax(i)=dsqrt(vconmax(i)) + enddo + if(nmethod.eq.1) then + if(((dabs(vmax(0)).lt.1.d-8*dabs(vconmax(0))).or. + & (dabs(vconmax(0)).lt.1.d-10)).and. + & ((dabs(vmax(1)).lt.1.d-8*dabs(vconmax(1))).or. + & (dabs(vconmax(1)).lt.1.d-10)).and. + & ((dabs(vmax(2)).lt.1.d-8*dabs(vconmax(2))).or. + & (dabs(vconmax(2)).lt.1.d-10)).and. + & ((dabs(vmax(3)).lt.1.d-8*dabs(vconmax(3))).or. + & (dabs(vconmax(3)).lt.1.d-10)).and. + & ((dabs(vmax(4)).lt.1.d-8*dabs(vconmax(4))).or. + & (dabs(vconmax(4)).lt.1.d-10)).and. + & (iit.gt.1)) convergence=1 + endif + write(*,'(i10,11(1x,e11.4))') iit,vmax(0),vconmax(0), + & vmax(1),vconmax(1),vmax(2),vconmax(2), + & vmax(3),vconmax(3),vmax(4),vconmax(4),dtimef + factor=min(1.d0,1.01d0*factor) + if(dabs(vconmax(0)).gt.1.d-3) then + factor=min(factor,vconmax(0)/vmax(0)*0.001) + endif + if(dabs(vconmax(1)).gt.1.d-3) then + factor=min(factor,vconmax(1)/vmax(1)*0.001) + endif + if(dabs(vconmax(2)).gt.1.d-3) then + factor=min(factor,vconmax(2)/vmax(2)*0.001) + endif + if(dabs(vconmax(3)).gt.1.d-3) then + factor=min(factor,vconmax(3)/vmax(3)*0.001) + endif + if(dabs(vconmax(4)).gt.1.d-3) then + factor=min(factor,vconmax(4)/vmax(4)*0.001) + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cfluxes.f calculix-ccx-2.3/ccx_2.3/src/cfluxes.f --- calculix-ccx-2.1/ccx_2.3/src/cfluxes.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cfluxes.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,212 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cfluxes(inpc,textpart,set,istartset,iendset, + & ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, + & amname,nam,ntrans,trab,inotr,co,ikforc,ilforc,nk, + & cflux_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_, + & namtot_,namta,amta,iaxial,ipoinpc) +! +! reading the input deck: *CFLUX +! + implicit none +! + logical cflux_flag,user,add +! + character*1 inpc(*) + character*80 amplitude,amname(*) + character*81 set(*),noset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),nodeforc(2,*), + & nset,nforc,nforc_,istep,istat,n,i,j,k,l,iforcdir,key, + & iamforc(*),nam,iamplitude,ntrans,inotr(2,*),ipos,ikforc(*), + & ilforc(*),nk,iline,ipol,inl,ipoinp(2,*),inp(3,*),nam_,namtot, + & namtot_,namta(3,*),idelay,ndirforc(*),isector,iaxial, + & ipoinpc(0:*) +! + real*8 xforc(*),forcval,co(3,*),trab(7,*),amta(2,*) +! + iamplitude=0 + idelay=0 + user=.false. + add=.false. + isector=0 +! + if(istep.lt.1) then + write(*,*) '*ERROR in cfluxes: *CFLUX should only be used' + write(*,*) ' within a STEP' + stop + endif +! + do i=2,n + if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.cflux_flag)) then + do j=1,nforc + if(ndirforc(j).eq.0) xforc(j)=0.d0 + enddo + elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then + read(textpart(i)(11:90),'(a80)') amplitude + do j=nam,1,-1 + if(amname(j).eq.amplitude) then + iamplitude=j + exit + endif + enddo + if(j.eq.0) then + write(*,*)'*ERROR in cfluxes: nonexistent amplitude' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iamplitude=j + elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN + if(idelay.ne.0) then + write(*,*) '*ERROR in cfluxes: the parameter TIME DELAY' + write(*,*) ' is used twice in the same keyword' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + else + idelay=1 + endif + nam=nam+1 + if(nam.gt.nam_) then + write(*,*) '*ERROR in cfluxes: increase nam_' + stop + endif + amname(nam)=' + & ' + if(iamplitude.eq.0) then + write(*,*) '*ERROR in cfluxes: time delay must be' + write(*,*) ' preceded by the amplitude parameter' + stop + endif + namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) + iamplitude=nam + if(nam.eq.1) then + namtot=0 + else + namtot=namta(2,nam-1) + endif + namtot=namtot+1 + if(namtot.gt.namtot_) then + write(*,*) '*ERROR cfluxes: increase namtot_' + stop + endif + namta(1,nam)=namtot + namta(2,nam)=namtot + read(textpart(i)(11:30),'(f20.0)',iostat=istat) + & amta(1,namtot) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:4).eq.'USER') then + user=.true. + elseif(textpart(i)(1:3).eq.'ADD') then + add=.true. + else + write(*,*) + & '*WARNING in cfluxes: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(user.and.(iamplitude.ne.0)) then + write(*,*) '*WARNING: no amplitude definition is allowed' + write(*,*) ' for heat fluxes defined by a' + write(*,*) ' user routine' + iamplitude=0 + endif +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return +! + read(textpart(2)(1:10),'(i10)',iostat=istat) iforcdir + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if((iforcdir.ne.0).and.(iforcdir.ne.11)) then + write(*,*) '*ERROR in cfluxes: nonexistent degree of ' + write(*,*) ' freedom. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iforcdir=0 +! + if(textpart(3)(1:1).eq.' ') then + forcval=0.d0 + else + read(textpart(3)(1:20),'(f20.0)',iostat=istat) forcval + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(iaxial.ne.0) forcval=forcval/iaxial + endif +! +! dummy flux consisting of the first primes +! + if(user) forcval=1.2357111317d0 +! + read(textpart(1)(1:10),'(i10)',iostat=istat) l + if(istat.eq.0) then + if(l.gt.nk) then + write(*,*) '*ERROR in cfluxes: node ',l + write(*,*) ' is not defined' + stop + endif + call forcadd(l,iforcdir,forcval, + & nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, + & iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc, + & isector,add,user) + else + read(textpart(1)(1:80),'(a80)',iostat=istat) noset + noset(81:81)=' ' + ipos=index(noset,' ') + noset(ipos:ipos)='N' + do i=1,nset + if(set(i).eq.noset) exit + enddo + if(i.gt.nset) then + noset(ipos:ipos)=' ' + write(*,*) '*ERROR in cfluxes: node set ',noset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + call forcadd(ialset(j),iforcdir,forcval, + & nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, + & iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc, + & isector,add,user) + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + call forcadd(k,iforcdir,forcval, + & nodeforc,ndirforc,xforc,nforc,nforc_, + & iamforc,iamplitude,nam,ntrans,trab,inotr,co, + & ikforc,ilforc,isector,add,user) + enddo + endif + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cflux.f calculix-ccx-2.3/ccx_2.3/src/cflux.f --- calculix-ccx-2.1/ccx_2.3/src/cflux.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cflux.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,58 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cflux(flux,msecpt,kstep,kinc,time,node,coords,vold, + & mi) +! +! user subroutine cflux +! +! +! INPUT: +! +! msecpt number of flux values (for volume elements:1) +! kstep step number +! kinc increment number +! time(1) current step time +! time(2) current total time +! node node number +! coords(1..3) global coordinates of the node +! vold(0..4,1..nk) solution field in all nodes +! 0: temperature +! 1: displacement in global x-direction +! 2: displacement in global y-direction +! 3: displacement in global z-direction +! 4: static pressure +! mi(1) max # of integration points per element (max +! over all elements) +! mi(2) max degree of freedomm per node (max over all +! nodes) in fields like v(0:mi(2))... +! +! OUTPUT: +! +! flux(1..msecpt) concentrated flux in the node +! + implicit none +! + integer msecpt,kstep,kinc,node,mi(2) + real*8 flux(msecpt),time(2),coords(3),vold(0:mi(2),*) +! + flux(1)=10.d0 +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/changedepterm.f calculix-ccx-2.3/ccx_2.3/src/changedepterm.f --- calculix-ccx-2.1/ccx_2.3/src/changedepterm.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/changedepterm.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,77 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine changedepterm(ikmpc,ilmpc,nmpc,mpc,idofrem,idofins) +! +! changes the dependent term in ikmpc and ilmpc for MPC mpc. +! + implicit none +! + integer ikmpc(*),ilmpc(*),nmpc,idofrem,idofins,id,k,mpc +! +! remove MPC from ikmpc +! + call nident(ikmpc,idofrem,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idofrem) then + do k=id+1,nmpc + ikmpc(k-1)=ikmpc(k) + ilmpc(k-1)=ilmpc(k) + enddo + else + write(*,*) '*ERROR in changedepterm' + write(*,*) ' ikmpc database corrupted' + stop + endif + else + write(*,*) '*ERROR in changedepterm' + write(*,*) ' ikmpc database corrupted' + stop + endif +! +! insert new MPC +! + call nident(ikmpc,idofins,nmpc-1,id) + if((id.gt.0).and.(ikmpc(id).eq.idofins)) then + write(*,*) '*ERROR in changedepterm: dependent DOF' + write(*,*) ' of nonlinear MPC cannot be changed' + write(*,*) ' since new dependent DOF is already' + write(*,*) ' used in another MPC' + stop + else + do k=nmpc,id+2,-1 + ikmpc(k)=ikmpc(k-1) + ilmpc(k)=ilmpc(k-1) + enddo + ikmpc(id+1)=idofins + ilmpc(id+1)=mpc + endif +! + return + end + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/changefrictions.f calculix-ccx-2.3/ccx_2.3/src/changefrictions.f --- calculix-ccx-2.1/ccx_2.3/src/changefrictions.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/changefrictions.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,73 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine changefrictions(inpc,textpart,matname,nmat,nmat_, + & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,nrhcon,ipoinpc, + & imat) +! +! reading the input deck: *CHANGE FRICTION +! + implicit none +! + character*1 inpc(*) + character*80 matname(*),interactionname + character*132 textpart(16) +! + integer nmat,nmat_,istep,istat,n,key,i,irstrt,iline,ipol,inl, + & ipoinp(2,*),inp(3,*),nrhcon(*),ipoinpc(0:*),imat +! + if(istep.eq.0) then + write(*,*) '*ERROR reading *CHANGE FRICTION: *CHANGE FRICTION' + write(*,*) ' cannot be used before the first step' + stop + endif +! + do i=2,n + if(textpart(i)(1:12).eq.'INTERACTION=') then + interactionname=textpart(i)(13:92) + else + write(*,*) + & '*WARNING reading *CHANGE FRICTION: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! check whether the interaction exists +! + imat=0 + do i=1,nmat + if(matname(i).eq.interactionname) then + imat=i + exit + endif + enddo +! + if(imat.eq.0) then + write(*,*) '*ERROR reading *CHANGE FRICTION:',interactionname + write(*,*) ' is a nonexistent interaction' + stop + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/characteristic.f calculix-ccx-2.3/ccx_2.3/src/characteristic.f --- calculix-ccx-2.1/ccx_2.3/src/characteristic.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/characteristic.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,223 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine characteristic(node1,node2,nodem,nelem, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,physcon,numf,set,mi) +! +! This subroutine is used to enables the processing of empiric +! given under the form +! massflow*dsqrt(T1)/Pt1=f((Pt1-Pt2)/Pt1) and T1=T2 +! characteristics the subroutine proceeds using +! linear interpolation to estimate the values for the whole characteristic +! note that the characteristic is implicitely containing the point (0,0) +! + implicit none +! + logical identity + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem, + & ielprop(*),nodef(4),idirf(4),index,iflag, + & inv,id,numf,npu,i,mi(2) +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4), + & p1,p2,physcon(*), + & xpu(10),ypu(10),Qred,p1mp2zp1,T1,scal,T2 +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif ((iflag.eq.1).or.(iflag.eq.2)) then +! + index=ielprop(nelem) +! + npu=nint(prop(index+2)) + scal=prop(index+1) +! + do i=1,npu + xpu(i)=prop(index+2*i+1) + ypu(i)=prop(index+2*i+2) + enddo +! + p1=v(2,node1) + p2=v(2,node2) +! + if(p1.ge.p2) then + inv=1 + T1=v(0,node1)+physcon(1) + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + T1=v(0,node2)+physcon(1) + endif +! + p1mp2zp1=(P1-P2)/P1 +! + if(iflag.eq.1) then + + call ident(xpu,p1mp2zp1,npu,id) + if(id.le.2) then + Qred=scal*ypu(2)/xpu(2)*p1mp2zp1 + xflow=inv*Qred*P1/dsqrt(T1) + elseif(id.ge.npu) then + Qred=scal*ypu(npu-2) + xflow=inv*Qred*P1/dsqrt(T1) + else + Qred=scal*ypu(id)+(ypu(id+1)-ypu(id)) + & *(p1mp2zp1-xpu(id))/(xpu(id+1)-xpu(id)) + xflow=inv*Qred*P1/dsqrt(T1) + endif +! + elseif (iflag.eq.2) then + numf=4 +! + p1=v(2,node1) + p2=v(2,node2) + xflow=v(1,nodem) +! + if (p1.ge.p2) then +! + inv=1 + xflow=v(1,nodem) + T1=v(0,node1)+physcon(1) + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! + else +! + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + T1=v(0,node2)+physcon(1) + xflow=-v(1,nodem) + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 +! + df(2)=xflow/(2.d0*P1*dsqrt(T1)) + df(3)=inv*dsqrt(T1)/P1 +! + call ident(xpu,p1mp2zp1,npu,id) +! + if(id.lt.2) then + f=dabs(xflow)*dsqrt(T1)/p1-scal*ypu(2)/xpu(2)*p1mp2zp1 + df(4)=scal*ypu(2)/(xpu(2)*P1) + df(1)=-xflow*dsqrt(T1)/(P1**2.d0)-(P2/P1**2.d0) + & *scal*ypu(2)/xpu(2) +! + elseif(id.ge.npu) then + f=dabs(xflow)/P1*dsqrt(T1)-scal*ypu(npu) + df(4)=0.01d0 + df(1)=-xflow*dsqrt(T1)/P1**2 +! + else + f=dabs(xflow)/P1*dsqrt(T1)-(scal*ypu(id) + & +scal*(ypu(id+1)-ypu(id)) + & *(p1mp2zp1-xpu(id))/(xpu(id+1)-xpu(id))) +! + df(4)=scal*(ypu(id+1)-ypu(id))/(xpu(id+1)-xpu(id))*1/p1 +! + df(1)=-xflow*dsqrt(T1)/P1**2-(P2/P1**2) + & *(scal*(ypu(id+1)-ypu(id))/(xpu(id+1)-xpu(id))) + endif + endif + + elseif(iflag.eq.3) then + p1=v(2,node1) + p2=v(2,node2) + xflow=v(1,nodem) +! + if (p1.ge.p2) then +! + inv=1 + xflow=v(1,nodem) + T1=v(0,node1)+physcon(1) + T2=v(0,node2)+physcon(1) + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! + else +! + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + T1=v(0,node2)+physcon(1) + T2=v(0,node1)+physcon(1) + xflow=-v(1,nodem) + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif +! + write(1,*) '' + write(1,55) 'In line',int(nodem/100),' from node',node1, + & ' to node', node2,': air massflow rate=',xflow,'kg/s' +! + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) +! + if(inv.eq.1) then + write(1,56)' Inlet node ',node1,': Tt1=',T1, + & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' + + write(1,*)' element G ',set(numf)(1:20) +! + write(1,56)' Outlet node ',node2,': Tt2=',T2, + & 'K, Ts2=',T2,'K, Pt2=',P2/1e5,'Bar' +! + else if(inv.eq.-1) then + write(1,56)' Inlet node ',node2,': Tt1=',T1, + & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' + & + write(1,*)' element G ',set(numf)(1:20) +! + write(1,56)' Outlet node ',node1,': Tt2=',T2, + & 'K, Ts2=',T2,'K, Pt2=',P2/1e5, 'Bar' +! + endif +! + 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A) +! + endif +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/checkarpackcs.f calculix-ccx-2.3/ccx_2.3/src/checkarpackcs.f --- calculix-ccx-2.1/ccx_2.3/src/checkarpackcs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/checkarpackcs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,219 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine checkarpackcs(iponoel,inoel,ne,ipkon,lakon, + & kon,iactnode,iactelem,iecovered,incovered,itime) +! + implicit none +! + character*8 lakon(*) +! + integer iponoel(*),inoel(2,*),ne,ipkon(*),kon(*),inoelfree, + & nope,indexe,iactelem(*),iactnode(*),iecovered(*),nactive, + & itime(*),i,j,k,index,node,node1,id,iref,ielem,iact,il,ih, + & incovered(*),nei1,nei2,nei3,ineigh10(3,10),ineigh20(3,20) +! + data ineigh10 /5,7,8,5,6,9,6,7,10,8,9,10, + & 1,2,2,2,3,3,3,1,1, + & 1,4,4,2,4,4,3,4,4/ + data ineigh20 /9,12,17,9,10,18,10,11,19,11,12,20, + & 13,16,17,13,14,18,14,15,19,15,16,20, + & 1,2,2,2,3,3,3,4,4,4,1,1, + & 5,6,6,6,7,7,7,8,8,8,5,5, + & 1,5,5,2,6,6,3,7,7,4,8,8/ +! +! determining the elements belonging to the nodes of +! the elements +! + inoelfree=1 + do i=1,ne + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).eq.'F') cycle + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + nope=15 + endif + indexe=ipkon(i) + do j=1,nope + node=kon(indexe+j) + inoel(1,inoelfree)=i + inoel(2,inoelfree)=iponoel(node) + iponoel(node)=inoelfree + inoelfree=inoelfree+1 + enddo + enddo +! +! determining an active (element,node) set +! + do i=1,ne + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).eq.'F') cycle + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + nope=15 + endif + indexe=ipkon(i) + node=kon(indexe+1) + iactelem(1)=i + iactnode(1)=node + incovered(node)=1 + nactive=1 + exit + enddo +! +! covering all elements through neighboring relations +! + do + if(nactive.eq.0) exit + ielem=iactelem(1) + write(*,*) 'ielem ',ielem +c do i=1,nactive +c write(*,*) iactelem(i),iactnode(i) +c enddo + node=iactnode(1) + iref=itime(node) + indexe=ipkon(ielem) +! +! removing the element from the active sets +! + do i=1,nactive-1 + iactelem(i)=iactelem(i+1) + iactnode(i)=iactnode(i+1) + enddo + iecovered(ielem)=1 + nactive=nactive-1 +! +! loop over all nodes belonging to the element +! + loop:do + do k=1,nope + node1=kon(indexe+k) + if(incovered(node1).eq.1) cycle +! +! checking for neighbors +! + if(nope.eq.20) then + nei1=kon(indexe+ineigh20(1,k)) + nei2=kon(indexe+ineigh20(2,k)) + nei3=kon(indexe+ineigh20(3,k)) + elseif(nope.eq.10) then + nei1=kon(indexe+ineigh10(1,k)) + nei2=kon(indexe+ineigh10(2,k)) + nei3=kon(indexe+ineigh10(3,k)) + else + write(*,*) '*ERROR in checkarpackcs: case not covered' + stop + endif + if(incovered(nei1).eq.1) then + iref=itime(nei1) + elseif(incovered(nei2).eq.1) then + iref=itime(nei2) + elseif(incovered(nei3).eq.1) then + iref=itime(nei3) + else + cycle + endif + + incovered(node1)=1 +c if(node1.eq.node) cycle +! +! checking for continuity of field time (to be done) +! + iact=itime(node1) + il=iact + ih=iact + if(iact.le.iref) then + do + ih=ih+180 + if(ih.ge.iref) exit + il=ih + enddo + else + do + il=il-180 + if(il.le.iref) exit + ih=il + enddo + endif + if((ih-iref)>(iref-il)) then + itime(node1)=il + else + itime(node1)=ih + endif + write(*,*) 'check ',node1,iref,iact,il,ih,itime(node1) +! +! covering all elements belonging to node node1 +! + index=iponoel(node1) + do + ielem=inoel(1,index) + if(iecovered(ielem).eq.0) then + call nident(iactelem,ielem,nactive,id) + if(id.gt.0) then + if(iactelem(id).eq.ielem) then +! +! element already belongs to the active set +! + index=inoel(2,index) + if(index.eq.0) exit + cycle + endif + endif +! +! new element to be added to the active set +! + nactive=nactive+1 + do j=nactive,id+2,-1 + iactelem(j)=iactelem(j-1) + iactnode(j)=iactnode(j-1) + enddo + iactelem(id+1)=ielem + iactnode(id+1)=node1 + endif + index=inoel(2,index) + if(index.eq.0) exit + enddo + enddo + do k=1,nope + node1=kon(indexe+k) + if(incovered(node1).eq.0) cycle loop + enddo + exit + enddo loop + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/checkconvergence.c calculix-ccx-2.3/ccx_2.3/src/checkconvergence.c --- calculix-ccx-2.1/ccx_2.3/src/checkconvergence.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/checkconvergence.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,521 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif + + +void checkconvergence(double *co, int *nk, int *kon, int *ipkon, char *lakon, + int *ne, double *stn, int *nmethod, + int *kode, char *filab, double *een, double *t1act, + double *time, double *epn,int *ielmat,char *matname, + double *enern, double *xstaten, int *nstate_, int *istep, + int *iinc, int *iperturb, double *ener, int *mi, char *output, + int *ithermal, double *qfn, int *mode, int *noddiam, double *trab, + int *inotr, int *ntrans, double *orab, int *ielorien, int *norien, + char *description,double *sti, + int *icutb, int *iit, double *dtime, double *qa, double *vold, + double *qam, double *ram1, double *ram2, double *ram, + double *cam, double *uam, int *ntg, double *ttime, + int *icntrl, double *theta, double *dtheta, double *veold, + double *vini, int *idrct, double *tper,int *istab, double *tmax, + int *nactdof, double *b, double *tmin, double *ctrl, double *amta, + int *namta, int *itpamp, int *inext, double *dthetaref, int *itp, + int *jprint, int *jout, int *uncoupled, double *t1, int *iitterm, + int *nelemload, int *nload, int *nodeboun, int *nboun, int *itg, + int *ndirboun, double *deltmx, int *iflagact,char *set,int *nset, + int *istartset,int *iendset,int *ialset){ + + int i0,ir,ip,ic,il,ig,ia,iest,iest1=0,iest2=0,iconvergence,idivergence, + ngraph=1,k,*ipneigh=NULL,*neigh=NULL,*inum=NULL,id,istart,iend,inew, + i,j,mt=mi[1]+1; + + double df,dc,db,dd,ran,can,rap,ea,cae,ral,da,*vr=NULL,*vi=NULL,*stnr=NULL, + *stni=NULL,*vmax=NULL,*stnmax=NULL,*cs=NULL,c1[2],c2[2],reftime, + *fn=NULL,*eenmax=NULL; + + /* next lines are active if the number of contact elements was + changed in the present increment */ + + if (*iflagact==1){ + if(ctrl[0]<*iit+4)ctrl[0]=*iit+4; + if(ctrl[1]<*iit+8)ctrl[1]=*iit+8; + ctrl[3]+=1; + } + + i0=ctrl[0];ir=ctrl[1];ip=ctrl[2];ic=ctrl[3];il=ctrl[4];ig=ctrl[5];ia=ctrl[7]; + df=ctrl[10];dc=ctrl[11];db=ctrl[12];da=ctrl[13];dd=ctrl[16]; + ran=ctrl[18];can=ctrl[19];rap=ctrl[22]; + ea=ctrl[23];cae=ctrl[24];ral=ctrl[25]; + + /* check for forced divergence (due to divergence of a user material + routine */ + + if(qa[2]>0.){idivergence=1;}else{idivergence=0;} + + if(*ithermal!=2){ + if(qa[0]>ea*qam[0]){ + if(*iit<=ip){c1[0]=ran;} + else{c1[0]=rap;} + c2[0]=can; + } + else{ + c1[0]=ea; + c2[0]=cae; + } + if(ram1[0]1){ + if(qa[1]>ea*qam[1]){ + if(*iit<=ip){c1[1]=ran;} + else{c1[1]=rap;} + c2[1]=can; + } + else{ + c1[1]=ea; + c2[1]=cae; + } + if(ram1[1]1)&&(ram[0]<=c1[0]*qam[0])&&(*iflagact==0)&& + // if((*iit>1)&&(ram[0]<=c1[0]*qam[0])&& + ((cam[0]<=c2[0]*uam[0])|| + (((ram[0]*cam[0]il)&&(*idrct==0)){ + if(*idrct==0){ + *dtheta=*dthetaref*db; + *dthetaref=*dtheta; + printf(" convergence; the increment size is decreased to %e\n\n",*dtheta**tper); + if(*dtheta<*tmin){ + printf("\n *ERROR: increment size smaller than minimum\n"); + printf(" best solution and residuals are in the frd file\n\n"); + fn=NNEW(double,mt**nk); + inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; + FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, + nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, + ielorien,co,nelemload,nload,nodeboun,nboun,itg,ntg, + vold,ndirboun)); + ++*kode; + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn,inum, + nmethod,kode, + filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, + xstaten,nstate_,istep,iinc,iperturb,ener,mi,output, + ithermal,qfn,mode,noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, + veold,ne,cs,set,nset,istartset,iendset,ialset,eenmax)); + FORTRAN(uout,(vold,mi)); + FORTRAN(stop,()); + } + } + else{ + printf("convergence\n\n");} + } + + /* check whether next increment size can be increased */ + + else if(*iit<=ig){ + if((*istab==1)&&(*idrct==0)){ + *dtheta=*dthetaref*dd; + *dthetaref=*dtheta; + printf(" convergence; the increment size is increased to %e\n\n",*dtheta**tper); + } + else{ + *istab=1; + printf(" convergence\n\n"); + *dtheta=*dthetaref; + } + } + else{ + *istab=0; + printf(" convergence\n\n"); + *dtheta=*dthetaref; + } + + if((*dtheta>*tmax)&&(*idrct==0)){ + *dtheta=*tmax; + *dthetaref=*dtheta; + printf(" the increment size exceeds thetamax and is decreased to %e\n\n",*dtheta**tper); + } + + /* if itp=1 the increment just finished ends at a time point */ + + if((*itpamp>0)&&(*idrct==0)){ + if(*itp==1){ + *jprint=*jout; + }else{ + *jprint=*jout+1; + } + if(namta[3**itpamp-1]<0){ +// reftime=*ttime+*dtheta**tper+1.01e-6; + reftime=*ttime+*dtheta**tper; + }else{ +// reftime=*time+*dtheta**tper+1.01e-6; + reftime=*time+*dtheta**tper; + } + istart=namta[3**itpamp-3]; + iend=namta[3**itpamp-2]; + FORTRAN(identamta,(amta,&reftime,&istart,&iend,&id)); + if(id1.-*theta){ + *dtheta=1.-*theta; + *dthetaref=*dtheta; + printf(" the increment size exceeds the remainder of the step and is decreased to %e\n\n",*dtheta**tper); + if(*dtheta<=1.e-6){(*ttime)+=(*dtheta**tper);} + } + } + else{ + + /* check for the amount of iterations */ + + if(*iit>ic){ + printf("\n *ERROR: too many iterations needed\n"); + printf(" best solution and residuals are in the frd file\n\n"); + fn=NNEW(double,mt**nk); + inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; + FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal,nk,sti,stn, + ipkon,inum,kon,lakon,ne,mi,orab,ielorien,co, + nelemload,nload,nodeboun,nboun,itg,ntg,vold,ndirboun)); + ++*kode; + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn,inum,nmethod,kode, + filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, + xstaten,nstate_,istep,iinc,iperturb,ener,mi,output, + ithermal,qfn,mode,noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, + veold,ne,cs,set,nset,istartset,iendset,ialset,eenmax)); + FORTRAN(uout,(vold,mi)); + FORTRAN(stop,()); + } + + /* check for diverging residuals */ + + if((*iit>=i0)||(fabs(ram[0])>1.e20)||(fabs(cam[0])>1.e20)|| + (fabs(ram[1])>1.e20)||(fabs(cam[1])>1.e20)|| + (cam[2]>*deltmx)){ + if(*ithermal!=2){ + if((ram1[0]>ram2[0])&&(ram[0]>ram2[0])&&(ram[0]>c1[0]*qam[0])) + idivergence=1; + } + + /* for thermal calculations the maximum temperature change + is checked as well */ + + if(*ithermal>1){ + if((ram1[1]>ram2[1])&&(ram[1]>ram2[1])&&(ram[1]>c1[1]*qam[1])) + idivergence=1; + if(cam[2]>*deltmx) idivergence=2; + } + if(idivergence>0){ + if(*idrct==1) { + printf("\n *ERROR: solution seems to diverge; please try \n"); + printf(" automatic incrementation; program stops\n"); + printf(" best solution and residuals are in the frd file\n\n"); + fn=NNEW(double,mt**nk); + inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; + FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal,nk, + sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, + ielorien,co,nelemload,nload,nodeboun,nboun,itg,ntg, + vold,ndirboun)); + ++*kode; + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, + inum,nmethod,kode, + filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, + xstaten,nstate_,istep,iinc,iperturb,ener,mi,output, + ithermal,qfn,mode,noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, + veold,ne,cs,set,nset,istartset,iendset,ialset,eenmax)); + FORTRAN(uout,(vold,mi)); + FORTRAN(stop,()); + } + else { + if(qa[2]>0.){ + *dtheta=*dtheta*qa[2]; + }else{ + if(idivergence==1){ + *dtheta=*dtheta*df; + }else{ + *dtheta=*dtheta**deltmx/cam[2]*da; + } + } + *dthetaref=*dtheta; + printf(" divergence; the increment size is decreased to %e\n",*dtheta**tper); + printf(" the increment is reattempted\n\n"); + *istab=0; + if(*itp==1){ + *itp=0; + (*inext)--; + } + if(*dtheta<*tmin){ + printf("\n *ERROR: increment size smaller than minimum\n"); + printf(" best solution and residuals are in the frd file\n\n"); + fn=NNEW(double,mt**nk); + inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; + FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, + nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, + ielorien,co,nelemload,nload,nodeboun,nboun, + itg,ntg,vold,ndirboun)); + ++*kode; + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, + inum,nmethod,kode, + filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, + xstaten,nstate_,istep,iinc,iperturb,ener,mi, + output,ithermal,qfn,mode,noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, + veold,ne,cs,set,nset,istartset,iendset,ialset,eenmax)); + FORTRAN(uout,(vold,mi)); + FORTRAN(stop,()); + } + *icntrl=1; + (*icutb)++; + if(*icutb>ia){ + printf("\n *ERROR: too many cutbacks\n"); + printf(" best solution and residuals are in the frd file\n\n"); + fn=NNEW(double,mt**nk); + inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; + FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, + nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, + ielorien,co,nelemload,nload,nodeboun,nboun, + itg,ntg,vold,ndirboun)); + ++*kode; + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, + inum,nmethod,kode, + filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, + xstaten,nstate_,istep,iinc,iperturb,ener,mi, + output,ithermal,qfn,mode,noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, + veold,ne,cs,set,nset,istartset,iendset,ialset,eenmax)); + FORTRAN(uout,(vold,mi)); + FORTRAN(stop,()); + } + if(*uncoupled){ + if(*ithermal==1){ + (ctrl[0])/=4; + } + *ithermal=3; + } + return; + } + } + } + + /* check for too slow convergence */ + + if(*iit>=ir){ + if(*ithermal!=2){ + iest1=(int)ceil(*iit+log(ran*qam[0]/(ram[0]))/log(ram[0]/(ram1[0]))); + } + if(*ithermal>1){ + iest2=(int)ceil(*iit+log(ran*qam[1]/(ram[1]))/log(ram[1]/(ram1[1]))); + } + if(iest1>iest2){iest=iest1;}else{iest=iest2;} + if(iest>0){ + printf(" estimated number of iterations till convergence = %d\n", + iest); + } + if((iest>ic)||(*iit==ic)){ + + if(*idrct!=1){ + *dtheta=*dtheta*dc; + *dthetaref=*dtheta; + printf(" too slow convergence; the increment size is decreased to %e\n",*dtheta**tper); + printf(" the increment is reattempted\n\n"); + *istab=0; + if(*dtheta<*tmin){ + printf("\n *ERROR: increment size smaller than minimum\n"); + printf(" best solution and residuals are in the frd file\n\n"); + fn=NNEW(double,mt**nk); + inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; + FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, + nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, + ielorien,co,nelemload,nload,nodeboun,nboun, + itg,ntg,vold,ndirboun)); + ++*kode; + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, + inum,nmethod,kode, + filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, + xstaten,nstate_,istep,iinc,iperturb,ener, + mi,output,ithermal,qfn,mode,noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, + veold,ne,cs,set,nset,istartset,iendset,ialset,eenmax)); + FORTRAN(uout,(vold,mi)); + FORTRAN(stop,()); + } + *icntrl=1; + (*icutb)++; + if(*icutb>ia){ + printf("\n *ERROR: too many cutbacks\n"); + printf(" best solution and residuals are in the frd file\n\n"); + fn=NNEW(double,mt**nk); + inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; + FORTRAN(storeresidual,(nactdof,b,fn,filab,ithermal, + nk,sti,stn,ipkon,inum,kon,lakon,ne,mi,orab, + ielorien,co,nelemload,nload,nodeboun,nboun, + itg,ntg,vold,ndirboun)); + ++*kode; + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,vold,stn, + inum,nmethod,kode, + filab,een,t1act,fn,ttime,epn,ielmat,matname,enern, + xstaten,nstate_,istep,iinc,iperturb,ener,mi, + output,ithermal,qfn,mode,noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph, + veold,ne,cs,set,nset,istartset,iendset,ialset,eenmax)); + FORTRAN(uout,(vold,mi)); + FORTRAN(stop,()); + } + if(*uncoupled){ + if(*ithermal==1){ + (ctrl[0])/=4; + } + *ithermal=3; + } + return; + } + } + } + + printf(" no convergence\n\n"); + + (*iit)++; + + } + + /* default value for qa[2] */ + + qa[2]=-1; + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/checkconvnet.c calculix-ccx-2.3/ccx_2.3/src/checkconvnet.c --- calculix-ccx-2.1/ccx_2.3/src/checkconvnet.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/checkconvnet.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,153 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif + +void checkconvnet(int *icutb, int *iin, + double *uamt, double *uamf, double *uamp, + double *cam1t, double *cam1f, double *cam1p, + double *cam2t, double *cam2f, double *cam2p, + double *camt, double *camf, double *camp, + int *icntrl, double *dtheta, double *ctrl, + double *uama,double *cam1a,double *cam2a,double *cama, + double *vamt, double *vamf, double *vamp, double *vama){ + + int i0,ir,ip,ic,il,ig,ia,idivergence; + + double c1t,c1f,c1p,c1a; + double df,dc,db,dd,ran,can,rap,ea,cae,ral; + + i0=ctrl[0];ir=ctrl[1];ip=ctrl[2];ic=ctrl[3];il=ctrl[4];ig=ctrl[5];ia=ctrl[7]; + df=ctrl[10];dc=ctrl[11];db=ctrl[12];dd=ctrl[16]; + ran=ctrl[18];can=ctrl[19];rap=ctrl[22]; + ea=ctrl[23];cae=ctrl[24];ral=ctrl[25]; + + /* temperature */ + + if(*iin<=ip){c1t=0.0001*ran;} + else{c1t=0.0001*rap;} + + /* mass flow */ + + if(*iin<=ip){c1f=0.0001*ran;} + else{c1f=0.0001*rap;} + + /* pressure */ + + if(*iin<=ip){c1p=0.0001*ran;} + else{c1p=0.0001*rap;} + + /* geometry */ + + if(*iin<=ip){c1a=0.0001*ran;} + else{c1a=0.0001*rap;} + + if(*cam1t<*cam2t) {*cam2t=*cam1t;} + if(*cam1f<*cam2f) {*cam2f=*cam1f;} + if(*cam1p<*cam2p) {*cam2p=*cam1p;} + if(*cam1a<*cam2a) {*cam2a=*cam1a;} + + /* check for convergence or divergence + comparison of the latest change with + - the largest change in the present calculation + - the largest value in the present calculation */ + + if(((*camt<=c1t**uamt)||(*camt<1.e-8**vamt))&& + ((*camf<=c1f**uamf)||(*camf<1.e-8**vamf))&& + ((*camp<=c1p**uamp)||(*camp<1.e-8**vamp))&& + ((*cama<=c1p**uama)||(*cama<1.e-8**vama))&& + (*iin>3)){ + + /* increment convergence reached */ + + printf(" flow network: convergence in gas iteration %d \n\n",*iin); + *icntrl=1; + *icutb=0; + } + + else { + + idivergence=0; + + /* divergence based on temperatures */ + + if((*iin>=20*i0)||(fabs(*camt)>1.e20)){ + if((*cam1t>=*cam2t)&&(*camt>=*cam2t)&&(*camt>c1t**uamt)){ + idivergence=1; + } + } + + /* divergence based on the mass flux */ + + if((*iin>=20*i0)||(fabs(*camf)>1.e20)){ + if((*cam1f>=*cam2f)&&(*camf>=*cam2f)&&(*camf>c1f**uamf)){ + idivergence=1; + } + } + + /* divergence based on pressures */ + + if((*iin>=20*i0)||(fabs(*camp)>1.e20)){ + if((*cam1p>=*cam2p)&&(*camp>=*cam2p)&&(*camp>c1p**uamp)){ + idivergence=1; + } + } + + /* divergence based on geometry */ + + if((*iin>=20*i0)||(fabs(*cama)>1.e20)){ + if((*cam1a>=*cam2a)&&(*cama>=*cam2a)&&(*cama>c1p**uama)){ + idivergence=1; + } + } + + /* divergence based on the number of iterations */ + + if(*iin>20*ic) idivergence=1; + + /* divergence based on singular matrix or negative pressures */ + + if(*iin==0) idivergence=1; + + if(idivergence==1){ + *dtheta=*dtheta*df; + printf("\n divergence; the increment size is decreased to %e\n",*dtheta); + printf(" the increment is reattempted\n\n"); + *iin=0; + (*icutb)++; + if(*icutb>ia){ + printf("\n *ERROR: too many cutbacks\n"); + FORTRAN(stop,()); + } + }else{ + printf(" no convergence\n\n"); + } + } + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/checkinclength.c calculix-ccx-2.3/ccx_2.3/src/checkinclength.c --- calculix-ccx-2.1/ccx_2.3/src/checkinclength.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/checkinclength.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,113 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif + +void checkinclength(double *time,double *ttime,double *theta, double *dtheta, + int *idrct, double *tper,double *tmax, double *tmin, double *ctrl, + double *amta,int *namta, int *itpamp, int *inext, double *dthetaref, + int *itp,int *jprint, int *jout){ + + int id,istart,iend,inew,ireduceincrement; + double reftime; + + int i0,ir,ip,ic,il,ig,ia; + double df,dc,db,dd,ran,can,rap,ea,cae,ral,da; + i0=ctrl[0];ir=ctrl[1];ip=ctrl[2];ic=ctrl[3];il=ctrl[4];ig=ctrl[5];ia=ctrl[7]; + df=ctrl[10];dc=ctrl[11];db=ctrl[12];da=ctrl[13];dd=ctrl[16]; + ran=ctrl[18];can=ctrl[19];rap=ctrl[22]; + ea=ctrl[23];cae=ctrl[24];ral=ctrl[25]; + + /* check whether the new increment size is not too big */ + + if(*dtheta>*tmax){ + *dtheta=*tmax; +// printf(" the increment size exceeds thetamax and is decreased to %e\n\n",*dtheta**tper); + } + + /* if itp=1 the increment just finished ends at a time point */ + + if((*itpamp>0)&&(*idrct==0)){ + if(namta[3**itpamp-1]<0){ + reftime=*ttime+(*dtheta)**tper; + }else{ + reftime=*time+(*dtheta)**tper; + } + istart=namta[3**itpamp-3]; + iend=namta[3**itpamp-2]; + FORTRAN(identamta,(amta,&reftime,&istart,&iend,&id)); + if(id1.-*theta){ + *dtheta=1.-*theta; + *dthetaref=*dtheta; + printf(" the increment size exceeds the remainder of the step and is decreased to %e\n\n",*dtheta**tper); + if(*dtheta<=1.e-6){(*ttime)+=(*dtheta**tper);} + } + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/checkslavevertex.f calculix-ccx-2.3/ccx_2.3/src/checkslavevertex.f --- calculix-ccx-2.1/ccx_2.3/src/checkslavevertex.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/checkslavevertex.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,55 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine checkslavevertex(lvertex,nvertex,pvertex, + & itriacornerl,xl2) +! +! check whether triangular master vertex lies within the slave +! surface +! + implicit none +! + integer nvertex,lvertex(*),nodel,i, + & itriacornerl(*) +! + real*8 pvertex(3,*),xl2(3,*) +! + + if(nvertex.ne.0) then + nodel=lvertex(nvertex) + else + nodel=0 + endif + if(nodel.ne.0) then +! +! S-edge lvertex(nvertex) (local number, applies to +! the nodes as well as to the edges) was cut +! + if(itriacornerl(nodel).eq.1) then + nvertex=nvertex+1 + do i=1,3 + pvertex(i,nvertex)=xl2(i,nodel) + enddo + lvertex(nvertex)=0 +! + itriacornerl(nodel)=2 + endif + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/checktime.f calculix-ccx-2.3/ccx_2.3/src/checktime.f --- calculix-ccx-2.1/ccx_2.3/src/checktime.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/checktime.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,91 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine checktime(itpamp,namta,tinc,ttime,amta,tmin,inext,itp) +! +! checks whether tmin does not exceed the first time point, +! in case a time points amplitude is active +! + implicit none +! + integer namta(3,*),itpamp,id,inew,inext,istart,iend,itp +! + real*8 amta(2,*),tinc,ttime,tmin,reftime +! + if(itpamp.gt.0) then +! +! identifying the location in the time points amplitude +! of the starting time of the step +! + if(namta(3,itpamp).lt.0) then + reftime=ttime + else + reftime=0 + endif + istart=namta(1,itpamp) + iend=namta(2,itpamp) + call identamta(amta,reftime,istart,iend,id) + if(id.lt.istart) then + inext=istart + else + inext=id+1 + endif +! +! identifying the location in the time points amplitude +! of the starting point increased by tinc +! + if(namta(3,itpamp).lt.0) then + reftime=ttime+tinc + else + reftime=tinc + endif + istart=namta(1,itpamp) + iend=namta(2,itpamp) + call identamta(amta,reftime,istart,iend,id) + if(id.lt.istart) then + inew=istart + else + inew=id+1 + endif +! +! if the next time point precedes tinc or tmin +! appropriate action must be taken +! + if(inew.gt.inext) then + if(namta(3,itpamp).lt.0) then + tinc=amta(1,inext)-ttime + else + tinc=amta(1,inext) + endif + inext=inext+1 + itp=1 + if(tinc.lt.tmin) then + write(*,*) '*ERROR in checktime: a time point' + write(*,*) ' precedes the minimum time tmin' + stop + else + write(*,*) '*WARNING in checktime: a time point' + write(*,*) ' precedes the initial time' + write(*,*) ' increment tinc; tinc is' + write(*,*) ' decreased to ',tinc + endif + endif + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/checktriaedge.f calculix-ccx-2.3/ccx_2.3/src/checktriaedge.f --- calculix-ccx-2.1/ccx_2.3/src/checktriaedge.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/checktriaedge.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,322 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine checktriaedge(node1,node2,ipe,ime,iactiveline, + & nactiveline,intersec,xntersec,nvertex,pvertex,lvertex, + & ifreeintersec,xn,co,nopes,xl2,itri,idin,vold,mi) +! +! check whether triangular master edge cuts the slave surface +! edges +! + implicit none +! + logical invert,active +! + integer node1,node2,ipe(*),ime(4,*),indexl,iactiveline(3,*), + & nactiveline,id,indexi,intersec(2,*),nvertex,lvertex(13),i, + & ifreeintersec,nopes,nintersec,j,itri,index1,index2, + & k,node,ithree,idin,mi(2) +! + real*8 xntersec(3,*),pvertex(3,*),pr(3),xm(3),xn(3),co(3,*), + & dd,xl2(3,*),rc(3),dc(3),al,ratio(8),dist,xil, + & etl,al2,inter(3),err,vold(0:mi(2),*) +! + data ithree /3/ +! +! check whether the first node of the edge has a lower number +! than the second node. If not, the line is stored in reverse +! order in field ime and the invert flag is set to true +! + err=1d-6 + invert=.false. + if(node2.lt.node1) then + node=node1 + node1=node2 + node2=node + invert=.true. + endif +! +! retrieving the number of the line in field ime: indexl +! + indexl=ipe(node1) + do + if(ime(1,indexl).eq.node2) exit + indexl=ime(4,indexl) + if(indexl.eq.0) then + write(*,*) '*ERROR in checktriaedge: line was not' + write(*,*) itri,"node1",node1, "node2",node2 + write(*,*) ' properly catalogued' + stop + endif + enddo +! +! check whether line is active (i.e. lies on the progressing +! front) +! + active=.false. + call nidentk(iactiveline,indexl,nactiveline,id,ithree) + if(id.gt.0) then + if(iactiveline(1,id).eq.indexl) then + active=.true. + endif + endif +! + if(active) then +! +! retrieving the intersection points and storing them in +! pvertex... +! + indexi=iactiveline(3,id) +! +! check whether there is at least one intersection +! + if(indexi.gt.0) then + nvertex=nvertex+1 + lvertex(nvertex)=intersec(1,indexi) + do i=1,3 + pvertex(i,nvertex)=xntersec(i,indexi) + enddo + indexi=intersec(2,indexi) +! +! check whether there is a second intersection +! + if(indexi.ne.0) then + nvertex=nvertex+1 +! +! for two intersections the orientation of the line +! is important +! + if(invert) then + lvertex(nvertex)=lvertex(nvertex-1) + lvertex(nvertex-1)=intersec(1,indexi) + do i=1,3 + pvertex(i,nvertex)=pvertex(i,nvertex-1) + pvertex(i,nvertex-1)=xntersec(i,indexi) + enddo + else + lvertex(nvertex)=intersec(1,indexi) + do i=1,3 + pvertex(i,nvertex)=xntersec(i,indexi) + enddo + endif + endif + endif +! +! remove the line from the active stack +! +c! restore intersec/ifreeintersec +c! +c indexi=iactiveline(3,id) +c do +c! +c! Inversion +c! +c idummy=indexi +c indexi=intersec(2,indexi) +c intersec(2,idummy)=0 +c if(indexi.eq.0) exit +c enddo +! +! restore iactiveline/nactiveline +! + nactiveline=nactiveline-1 + do i=id,nactiveline + do k=1,3 + iactiveline(k,i)=iactiveline(k,i+1) + enddo + enddo + else +! +! line was not active: check for intersections +! + do i=1,3 + pr(i)=co(i,node2)+vold(i,node2)- + & co(i,node1)-vold(i,node1) + enddo +! +! normal on a plane through the line and vector xn +! + xm(1)=xn(2)*pr(3)-xn(3)*pr(2) + xm(2)=xn(3)*pr(1)-xn(1)*pr(3) + xm(3)=xn(1)*pr(2)-xn(2)*pr(1) + dd=dsqrt(xm(1)**2+xm(2)**2+xm(3)**2) + do i=1,3 + xm(i)=xm(i)/dd + enddo +! +! check for intersections with the slave edges +! + nintersec=0 + do j=1,nopes + if(j.ne.nopes) then + do i=1,3 + rc(i)=co(i,node1)+vold(i,node1)-xl2(i,j) + dc(i)=xl2(i,j+1)-xl2(i,j) + enddo + else + do i=1,3 + rc(i)=co(i,node1)+vold(i,node1)-xl2(i,j) + dc(i)=xl2(i,1)-xl2(i,j) + enddo + endif + al=(xm(1)*rc(1)+xm(2)*rc(2)+xm(3)*rc(3))/ + & (xm(1)*dc(1)+xm(2)*dc(2)+xm(3)*dc(3)) +! +! the intersection point must lie in between the +! triangular vertices +! + if((al.ge.1.d0).or.(al.le.0.d0)) cycle +! intersection found: catalogueing the line as active +! and storing the intersection +! + do i=1,3 + inter(i)=xl2(i,j)+al*dc(i) + enddo +! +! +! + al2=(((inter(1)-co(1,node1)-vold(1,node1))*pr(1)+ + & (inter(2)-co(2,node1)-vold(2,node1))*pr(2)+ + & (inter(3)-co(3,node1)-vold(3,node1))*pr(3))- + & (pr(1)*xn(1)+pr(2)*xn(2)+pr(3)*xn(3))* + & ((inter(1)-co(1,node1)-vold(1,node1))*xn(1)+ + & (inter(2)-co(2,node1)-vold(2,node1))*xn(2)+ + & (inter(3)-co(3,node1)-vold(3,node1))*xn(3)))/ + & ((pr(1)**2+pr(2)**2+pr(3)**2)- + & (pr(1)*xn(1)+pr(2)*xn(2)+pr(3)*xn(3))**2) +! + if((al2.ge.1.0d0).or.(al2.le.0.0d0)) cycle +! + if(nintersec.eq.0) then + nactiveline=nactiveline+1 + ifreeintersec=ifreeintersec+1 + do k=nactiveline,id+2,-1 + do i=1,3 + iactiveline(i,k)=iactiveline(i,k-1) + enddo + enddo + iactiveline(1,id+1)=indexl + iactiveline(2,id+1)=itri + iactiveline(3,id+1)=ifreeintersec + nintersec=nintersec+1 + elseif(nintersec.eq.1) then + ifreeintersec=ifreeintersec+1 + intersec(2,iactiveline(3,id+1))=ifreeintersec + nintersec=nintersec+1 + else + write(*,*) '*ERROR in checktriaedge: no more' + write(*,*) ' than two intersections allowed' + stop + endif +! +! update intersec and xntersec +! + intersec(1,ifreeintersec)=j + do i=1,3 + xntersec(i,ifreeintersec)=inter(i) + enddo + call attachline(xl2,xntersec(1,ifreeintersec),nopes, + & ratio,dist,xil,etl,xn) +c ifreeintersec=intersec(2,ifreeintersec) + intersec(2,ifreeintersec)=0 + enddo +! +! if there are two intersections, their order has to be +! checked +! + if(nintersec.eq.2) then +! +! check order of crossings +! + index1=iactiveline(3,id+1) + index2=intersec(2,index1) +! +! measuring the distance from node1 +! + if(((xntersec(1,index1)-co(1,node1)-vold(1,node1))**2+ + & (xntersec(2,index1)-co(2,node1)-vold(2,node1))**2+ + & (xntersec(3,index1)-co(3,node1)-vold(3,node1))**2).gt. + & ((xntersec(1,index2)-co(1,node1)-vold(1,node1))**2+ + & (xntersec(2,index2)-co(2,node1)-vold(2,node1))**2+ + & (xntersec(3,index2)-co(3,node1)-vold(3,node1))**2) ) + & then +! + iactiveline(3,id+1)=index2 + intersec(2,index2)=index1 + intersec(2,index1)=0 + endif + endif +! +c indexi=iactiveline(3,id+1) +c if((indexi.gt.0).and.(nintersec.gt.0)) then + if(nintersec.gt.0) then + indexi=iactiveline(3,id+1) + nvertex=nvertex+1 + lvertex(nvertex)=intersec(1,indexi) + do i=1,3 + pvertex(i,nvertex)=xntersec(i,indexi) + enddo + indexi=intersec(2,indexi) +! +! check whether there is a second intersection +! + if((indexi.ne.0)) then + nvertex=nvertex+1 +! +! for two intersections the orientation of the line +! is important +! + if(invert) then + lvertex(nvertex)=lvertex(nvertex-1) + lvertex(nvertex-1)=intersec(1,indexi) + do i=1,3 + pvertex(i,nvertex)=pvertex(i,nvertex-1) + pvertex(i,nvertex-1)=xntersec(i,indexi) + enddo + else + lvertex(nvertex)=intersec(1,indexi) + do i=1,3 + pvertex(i,nvertex)=xntersec(i,indexi) + enddo + endif + endif + endif +! +! if there are no intersections the line has to be set +! active if node1 lies inside +! + if((idin.gt.0).and.(nintersec.eq.0)) then + nactiveline=nactiveline+1 + do k=nactiveline,id+2,-1 + do i=1,3 + iactiveline(i,k)=iactiveline(i,k-1) + enddo + enddo + iactiveline(1,id+1)=indexl + iactiveline(2,id+1)=itri + iactiveline(3,id+1)=0 + endif + endif +! + if(invert) then + node=node1 + node1=node2 + node2=node + endif + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/checktriavertex.f calculix-ccx-2.3/ccx_2.3/src/checktriavertex.f --- calculix-ccx-2.1/ccx_2.3/src/checktriavertex.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/checktriavertex.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,125 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine checktriavertex(inodesin,nnodesin,node,nvertex,pvertex, + & lvertex,pnodesin,inodesout,nnodesout,nopes,slavstraight, + & xn,co,xl2,vold,mi) +! +! check whether triangular master vertex lies within the slave +! surface +! + implicit none +! + logical in +! + integer inodesin(*),nnodesin,node,idi,nvertex,lvertex(*),i, + & inodesout(*),nnodesout,ido,nopes,j,mi(2) +! + real*8 pvertex(3,*),pnodesin(3,*),slavstraight(20),xn(3),co(3,*), + & al,xl2(3,*),ratio(8),dist,xil,etl,vold(0:mi(2),*) +! + in=.false. +! + do +! +! check whether nodes was already calatogued as being +! inside the slave surface +! + call nident(inodesin,node,nnodesin,idi) + if(idi.gt.0) then + if(inodesin(idi).eq.node) then + in=.true. + nvertex=nvertex+1 + do i=1,3 + pvertex(i,nvertex)=pnodesin(i,idi) + enddo + lvertex(nvertex)=0 + exit + endif + endif +! +! check whether nodes was already calatogued as being +! outside the slave surface +! + call nident(inodesout,node,nnodesout,ido) + if(ido.gt.0) then + if(inodesout(ido).eq.node) exit + endif +! +! node is not catalogued: check whether node is inside +! or outside the slave surface +! + do i=1,nopes +c if((slavstraight(i*4-3)*co(1,node)+ +c & slavstraight(i*4-2)*co(2,node)+ +c & slavstraight(i*4-1)*co(3,node)+ + if((slavstraight(i*4-3)*(co(1,node)+vold(1,node))+ + & slavstraight(i*4-2)*(co(2,node)+vold(2,node))+ + & slavstraight(i*4-1)*(co(3,node)+vold(3,node))+ + & slavstraight(i*4)).gt.0.d0) exit + if(i.eq.nopes) in=.true. + enddo + if(in) then + nvertex=nvertex+1 + lvertex(nvertex)=0 +! +! projecting the node on the mean slave plane +! +c al=-xn(1)*co(1,node)-xn(2)*co(2,node)-xn(3)*co(3,node)- +c & slavstraight(nopes*4+4) + al=-xn(1)*(co(1,node)+vold(1,node))-xn(2)* + & (co(2,node)+vold(2,node))-xn(3)*(co(3,node)+vold(3,node))- + & slavstraight(nopes*4+4) + do i=1,3 + pvertex(i,nvertex)=co(i,node)+vold(i,node)+al*xn(i) + enddo +! +! projecting the node on the slave surface +! + call attachline(xl2,pvertex,nopes,ratio,dist,xil,etl,xn) +! +! cataloguein the node in inodesin +! + nnodesin=nnodesin+1 + do j=nnodesin,idi+2,-1 + inodesin(j)=inodesin(j-1) + do i=1,3 + pnodesin(i,j)=pnodesin(i,j-1) + enddo + enddo + inodesin(idi+1)=node + do i=1,3 +c pnodesin(i,idi+1)=co(i,node)+vold(i,node) + pnodesin(i,idi+1)=pvertex(i,nvertex) + enddo + exit + else +! +! cataloguein the node in inodesout +! + nnodesout=nnodesout+1 + do j=nnodesout,ido+2,-1 + inodesout(j)=inodesout(j-1) + enddo + inodesout(ido+1)=node + exit + endif + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/chksurf.f calculix-ccx-2.3/ccx_2.3/src/chksurf.f --- calculix-ccx-2.1/ccx_2.3/src/chksurf.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/chksurf.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,391 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine chksurf(lakon,kon,ipkon,neigh,ipneigh,co,itypflag,node, + & icont,iscount,angmax) +! +! icont=1: element surfaces adjacent to a surface node have normal +! vectors which have an angle of less than 10 degree +! -> free surface assumed +! icont=0: -> edge assumed +! +! also counts the free surfaces adjacent to a node +! + implicit none +! + integer kon(*),ipkon(*),ielem,i,j,k,indexe, + & neigh(2,*),ipneigh(*),index,m,nvertex,itypflag,isurf,node,index1, + & ielem1,ncount,ntos8h(3,8),ntos4tet(3,4),iston8h(4,6), + & isnode, isidx,ifreesur(3),iston20h(8,6),iston10tet(6,4), + & iscount,lnod,icont,iston4tet(3,4) +! + real*8 co(3,*),angle,shpder8q(2,4,8),shpder6tri(2,3,6), + & vectors(3,3),vlen(2),lastvec(3),angtmp,xl(3,8), + & shpder4q(2,4,4),shpder3tri(2,3,3),angmax +! +! ntosX(j,k) returns the three surface id's j for the corner node k +! for the element surfaces adjacent to the node +! + data ntos8h /1,3,6,1,3,4,1,4,5,1,5,6,2,3,6,2,3,4,2,4,5,2,5,6/ +! + data ntos4tet /1,2,4,1,2,3,1,3,4,2,3,4/ +! +! istonX(j,k) returns the nodes j of the element surface k +! + data iston8h /1,2,3,4,5,8,7,6,1,5,6,2,2,6,7,3,3,7,8,4,4,8,5,1/ +! + data iston20h /1,2,3,4,9,10,11,12,5,8,7,6,16,15,14,13, + & 1,5,6,2,17,13,18,9,2,6,7,3,18,14,19,10, + & 3,7,8,4,19,15,20,11,4,8,5,1,20,16,17,12/ +! + data iston4tet /1,2,3,1,4,2,2,4,3,3,4,1/ +! + data iston10tet /1,2,3,5,6 ,7,1,4,2,8 ,9,5, + & 2,4,3,9,10,6,3,4,1,10,8,7/ +! +! shpder8q contains the first derivative of the shape functions +! of a 8 node quadrilateral element with shpder8q(i,j,k) where i +! can be 1 for the xi-derivative or 2 for the eta-derivative j +! can be 1-4 for the location in the corner nodes to be evaluated +! for the element nodes k +! + data shpder8q / + & -1.5d0,-1.5d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0, + & -0.5d0, 0.0d0, 1.5d0,-1.5d0, 0.0d0, 0.5d0, 0.0d0, 0.0d0, + & 0.0d0, 0.0d0, 0.0d0,-0.5d0, 1.5d0, 1.5d0,-0.5d0, 0.0d0, + & 0.0d0,-0.5d0, 0.0d0, 0.0d0, 0.5d0, 0.0d0,-1.5d0, 1.5d0, + & 2.0d0, 0.0d0,-2.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, + & 0.0d0, 0.0d0, 0.0d0, 2.0d0, 0.0d0,-2.0d0, 0.0d0, 0.0d0, + & 0.0d0, 0.0d0, 0.0d0, 0.0d0,-2.0d0, 0.0d0, 2.0d0, 0.0d0, + & 0.0d0, 2.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,-2.0d0/ +! +! same as above for a 4 node linear quadrilateral element +! + data shpder4q / + & -0.5d0,-0.5d0,-0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,-0.5d0, + & 0.5d0, 0.0d0, 0.5d0,-0.5d0, 0.0d0,-0.5d0, 0.0d0, 0.0d0, + & 0.0d0, 0.0d0, 0.0d0, 0.5d0, 0.5d0, 0.5d0, 0.5d0, 0.0d0, + & 0.0d0, 0.5d0, 0.0d0, 0.0d0,-0.5d0, 0.0d0,-0.5d0, 0.5d0/ +! +! same as above for a 6 node quadratic triangular element +! + data shpder6tri / + & -3.0d0,-3.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0, + & -1.0d0, 0.0d0, 3.0d0, 0.0d0,-1.0d0, 0.0d0, + & 0.0d0,-1.0d0, 0.0d0,-1.0d0, 0.0d0, 3.0d0, + & 4.0d0, 0.0d0,-4.0d0,-4.0d0, 0.0d0, 0.0d0, + & 0.0d0, 0.0d0, 0.0d0, 4.0d0, 4.0d0, 0.0d0, + & 0.0d0, 4.0d0, 0.0d0, 0.0d0,-4.0d0,-4.0d0/ +! +! same as above for a 3 node linear triangular element +! + data shpder3tri / + & -1.0d0,-1.0d0,-1.0d0,-1.0d0,-1.0d0,-1.0d0, + & 1.0d0, 0.0d0, 1.0d0, 0.0d0, 1.0d0, 0.0d0, + & 0.0d0, 1.0d0, 0.0d0, 1.0d0, 0.0d0, 1.0d0/ +! + character*8 lakon(*) +! + index=ipneigh(node) + icont=1 + iscount=0 + angmax=0.d0 +! + do + if(index.eq.0) exit + ielem=neigh(1,index) +! + if(lakon(ielem)(1:5).eq.'C3D20'.and.itypflag.eq.1) then + nvertex=8 + elseif(lakon(ielem)(1:5).eq.'C3D10'.and.itypflag.eq.2) then + nvertex=4 + elseif(lakon(ielem)(1:4).eq.'C3D8'.and.itypflag.eq.3) then + nvertex=8 + elseif(lakon(ielem)(1:4).eq.'C3D4'.and.itypflag.eq.4) then + nvertex=4 + else + index=neigh(2,index) + cycle + endif +! +! find the index of the node in the element +! + indexe=ipkon(ielem) + do m=1,nvertex + if(kon(indexe+m).eq.node) exit + enddo +! +! the local node number is m +! +! now every surface has to be checked +! + do j=1,3 + ifreesur(j)=0 + enddo +! + do isurf=1,3 +! +! finding the global node numbers of the +! nodes of the surface +! + if(nvertex.eq.4) then +! +! isidx: index of the surface neighbouring the node +! + isidx=ntos4tet(isurf,m) + elseif(nvertex.eq.8) then + isidx=ntos8h(isurf,m) + endif +! +! find out, if there is any element neighbouring 'node', +! which has also those nodes (-> surface is within volume) +! + index1=ipneigh(node) + do + if(index1.eq.0) exit + ielem1=neigh(1,index1) + if( + & .not.( + & lakon(ielem1)(1:5).eq.'C3D20'.and.itypflag.eq.1 + & .or. + & lakon(ielem1)(1:5).eq.'C3D10'.and.itypflag.eq.2 + & .or. + & lakon(ielem1)(1:4).eq.'C3D8'.and.itypflag.eq.3 + & .or. + & lakon(ielem1)(1:4).eq.'C3D4'.and.itypflag.eq.4 + & ) + & .or.ielem.eq.ielem1 + & ) then + index1=neigh(2,index1) + cycle + endif +! +! check every corner node in the element +! + ncount=0 + do k=1,3 + if(nvertex.eq.4) then + isnode=kon(indexe+iston4tet(k,isidx)) + elseif(nvertex.eq.8) then + isnode=kon(indexe+iston8h(k,isidx)) + endif + do j=1,nvertex + if(kon(ipkon(ielem1)+j).eq.isnode) + & ncount=ncount+1 + enddo + enddo +! + if(ncount.eq.3) then +! +! surface isurf is not a free surface +! + ifreesur(isurf)=1 + endif +! + index1=neigh(2,index1) + enddo + enddo +! + do isurf=1,3 + if(ifreesur(isurf).eq.0) then + iscount=iscount+1 + do i=1,3 + do j=1,3 + vectors(j,i)=0.d0 + enddo + enddo +! +! free surface: find out local node number +! of the 'surface element' neighbouring the +! node to be evaluated +! + if(nvertex.eq.8) then + isidx=ntos8h(isurf,m) + do j=1,4 + if( (isidx.eq.1.and.m.eq.1) + & .or.(isidx.eq.2.and.m.eq.5) + & .or.(isidx.eq.3.and.m.eq.1) + & .or.(isidx.eq.4.and.m.eq.2) + & .or.(isidx.eq.5.and.m.eq.3) + & .or.(isidx.eq.6.and.m.eq.4)) then + lnod=1 + elseif( (isidx.eq.1.and.m.eq.2) + & .or.(isidx.eq.2.and.m.eq.8) + & .or.(isidx.eq.3.and.m.eq.5) + & .or.(isidx.eq.4.and.m.eq.6) + & .or.(isidx.eq.5.and.m.eq.7) + & .or.(isidx.eq.6.and.m.eq.8)) then + lnod=2 + elseif( (isidx.eq.1.and.m.eq.3) + & .or.(isidx.eq.2.and.m.eq.7) + & .or.(isidx.eq.3.and.m.eq.6) + & .or.(isidx.eq.4.and.m.eq.7) + & .or.(isidx.eq.5.and.m.eq.8) + & .or.(isidx.eq.6.and.m.eq.5)) then + lnod=3 + elseif( (isidx.eq.1.and.m.eq.4) + & .or.(isidx.eq.2.and.m.eq.6) + & .or.(isidx.eq.3.and.m.eq.2) + & .or.(isidx.eq.4.and.m.eq.3) + & .or.(isidx.eq.5.and.m.eq.4) + & .or.(isidx.eq.6.and.m.eq.1)) then + lnod=4 + endif + enddo +! +c do k=1,8 +c write(*,*) 'node',node,' nodes', +c & kon(indexe+iston20h(k,isidx)),'lnod',lnod +c enddo +! + if(itypflag.eq.1) then +! +! get coordinates of the 2d-element nodes +! + do k=1,8 + do j=1,3 + xl(j,k)=co(j,kon(indexe+iston20h(k,isidx))) + enddo + enddo +! +! vectors(j,i) (i=1,2) is the j-derivative for the +! coordinates i. +! + do k=1,8 + do i=1,3 + do j=1,2 + vectors(j,i)=vectors(j,i)+ + & xl(i,k)*shpder8q(j,lnod,k) + enddo + enddo + enddo +! + elseif(itypflag.eq.3) then + do k=1,4 + do j=1,3 + xl(j,k)=co(j,kon(indexe+iston8h(k,isidx))) + enddo + enddo + do k=1,4 + do i=1,3 + do j=1,2 + vectors(j,i)=vectors(j,i)+ + & xl(i,k)*shpder4q(j,lnod,k) + enddo + enddo + enddo + endif +! + elseif(nvertex.eq.4) then + isidx=ntos4tet(isurf,m) + do j=1,3 + if( (isidx.eq.1.and.m.eq.1) + & .or.(isidx.eq.2.and.m.eq.1) + & .or.(isidx.eq.3.and.m.eq.2) + & .or.(isidx.eq.4.and.m.eq.3)) then + lnod=1 + elseif( (isidx.eq.1.and.m.eq.2) + & .or.(isidx.eq.2.and.m.eq.4) + & .or.(isidx.eq.3.and.m.eq.4) + & .or.(isidx.eq.4.and.m.eq.4)) then + lnod=2 + elseif( (isidx.eq.1.and.m.eq.3) + & .or.(isidx.eq.2.and.m.eq.2) + & .or.(isidx.eq.3.and.m.eq.3) + & .or.(isidx.eq.4.and.m.eq.1)) then + lnod=3 + endif + enddo +! + if(itypflag.eq.2) then + do k=1,6 + do j=1,3 + xl(j,k)=co(j,kon(indexe+iston10tet(k,isidx))) + enddo + enddo + do k=1,6 + do i=1,3 + do j=1,2 + vectors(j,i)=vectors(j,i)+ + & xl(i,k)*shpder6tri(j,lnod,k) + enddo + enddo + enddo + elseif(itypflag.eq.4) then + do k=1,3 + do j=1,3 + xl(j,k)=co(j,kon(indexe+iston4tet(k,isidx))) + enddo + enddo + do k=1,3 + do i=1,3 + do j=1,2 + vectors(j,i)=vectors(j,i)+ + & xl(i,k)*shpder3tri(j,lnod,k) + enddo + enddo + enddo + endif +! + endif +! +! vectors(3,i) is the normal vector of the surface in the +! evaluated node 'node' +! + vectors(3,1)=vectors(1,2)*vectors(2,3) + & -vectors(1,3)*vectors(2,2) + vectors(3,2)=vectors(1,3)*vectors(2,1) + & -vectors(1,1)*vectors(2,3) + vectors(3,3)=vectors(1,1)*vectors(2,2) + & -vectors(1,2)*vectors(2,1) + vlen(2)=dsqrt(vectors(3,1)*vectors(3,1) + & +vectors(3,2)*vectors(3,2) + & +vectors(3,3)*vectors(3,3)) +! + if(iscount.gt.1) then + angtmp=dabs((vectors(3,1)*lastvec(1) + & +vectors(3,2)*lastvec(2) + & +vectors(3,3)*lastvec(3)) + & /(vlen(1)*vlen(2))) + if(angtmp.lt.1.d0) then + angle=57.29577951d0*dacos(angtmp) + if(angle.gt.angmax) angmax=angle + else + angle=0.d0 + endif +! +! if the angle between the normal vectors of two +! surfaces is greater than 10 degree, than it is +! assumed that an edge (dicontinuity) is present +! + if(angle.ge.10.d0) then + icont=0 + endif + endif +! + do j=1,3 + lastvec(j)=vectors(3,j) + enddo + vlen(1)=vlen(2) +! + endif + enddo + index=neigh(2,index) + enddo + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/cident20.f calculix-ccx-2.3/ccx_2.3/src/cident20.f --- calculix-ccx-2.1/ccx_2.3/src/cident20.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cident20.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,42 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! +! identifies the position id of px in an ordered array +! x of integers; +! +! id is such that x(id).le.px and x(id+1).gt.px +! + SUBROUTINE cIDENT20(X,PX,N,ID) + IMPLICIT none + character*20 x,px + integer n,id,n2,m + DIMENSION X(N) + id=0 + if(n.eq.0) return + N2=N+1 + do + M=(N2+ID)/2 + IF(PX.GE.X(M)) then + ID=M + else + N2=M + endif + IF((N2-ID).EQ.1) return + enddo + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/cident.f calculix-ccx-2.3/ccx_2.3/src/cident.f --- calculix-ccx-2.1/ccx_2.3/src/cident.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cident.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,42 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! +! identifies the position id of px in an ordered array +! x of integers; +! +! id is such that x(id).le.px and x(id+1).gt.px +! + SUBROUTINE cIDENT(X,PX,N,ID) + IMPLICIT none + character*81 x,px + integer n,id,n2,m + DIMENSION X(N) + id=0 + if(n.eq.0) return + N2=N+1 + do + M=(N2+ID)/2 + IF(PX.GE.X(M)) then + ID=M + else + N2=M + endif + IF((N2-ID).EQ.1) return + enddo + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/cload.f calculix-ccx-2.3/ccx_2.3/src/cload.f --- calculix-ccx-2.1/ccx_2.3/src/cload.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cload.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,141 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cload(xload,kstep,kinc,time,node,idof,coords,vold, + & mi,ntrans,trab,inotr,veold,nmethod,nactdof,bcont) +! +! user subroutine cload +! +! +! INPUT: +! +! kstep step number +! kinc increment number +! time(1) current step time +! time(2) current total time +! node node number +! idof degree of freedom +! coords(1..3) global coordinates of the node +! vold(0..4,1..nk) solution field in all nodes +! 0: temperature +! 1: displacement in global x-direction +! 2: displacement in global y-direction +! 3: displacement in global z-direction +! 4: static pressure +! mi(1) max # of integration points per element (max +! over all elements) +! mi(2) max degree of freedomm per node (max over all +! nodes) in fields like v(0:mi(2))... +! veold(0..3,1..nk) derivative of the solution field w.r.t. +! time in all nodes +! 0: temperature rate +! 1: velocity in global x-direction +! 2: velocity in global y-direction +! 3: velocity in global z-direction +! ntrans number of transform definitions +! trab(1..6,i) coordinates of two points defining transform i +! trab(7,i) -1: cylindrical transformation +! 1: rectangular transformation +! inotr(1,j) transformation number applied to node j +! inotr(2,j) a SPC in a node j in which a transformation +! applied corresponds to a MPC. inotr(2,j) +! contains the number of a new node generated +! for the inhomogeneous part of the MPC +! nmethod kind of procedure +! 0: no analysis +! 1: static +! 2: frequency +! 3: buckling +! 4: modal dynamic +! 5: modal steady state dynamics +! 6: matrix storage +! nactdof(i,j) number of the degree of freedom in the global +! system of equations of local degree of freedom +! i (0<=i<=mi(2)) in node j; this field is only +! accessible for nmethod=4, else a segmentation +! fault may result +! bcont(i) contact force in global degree of freedom i: +! this option is only available for modal dynamic +! calculations (nmethod=4). In all other cases use +! of this field may lead to a segmentation fault +! +! OUTPUT: +! +! xload concentrated load in direction idof of node +! "node" (global coordinates) +! + implicit none +! + integer kstep,kinc,node,idof,mi(2),ntrans,inotr(2,*),itr, + & nmethod,nactdof(0:mi(2),*) +! + real*8 xload,time(2),coords(3),vold(0:mi(2),*),trab(7,*), + & veold(0:mi(2),*),a(3,3),ve1,ve2,ve3,f1,f2,f3,bcont(*), + & fcontact +! +! displacements vold and velocities veold are given in +! the global system +! +! example how to transform the velocity into the local system +! defined in node "node" +! + if(ntrans.eq.0) then + itr=0 + else + itr=inotr(1,node) + endif +! + if(itr.ne.0) then + call transformatrix(trab(1,itr),coords,a) + ve1=veold(1,node)*a(1,1)+veold(2,node)*a(2,1) + & +veold(3,node)*a(3,1) + ve2=veold(1,node)*a(1,2)+veold(2,node)*a(2,2) + & +veold(3,node)*a(3,2) + ve3=veold(1,node)*a(1,3)+veold(2,node)*a(2,3) + & +veold(3,node)*a(3,3) +! +! suppose you know the size of the force in local coordinates: +! f1, f2 and f3. Calculating the size of the force in +! direction idof in global coordinates is done in the following +! way: +! + xload=f1*a(idof,1)+f2*a(idof,2)+f3*a(idof,3) + else +! +! no local system defined in node "node"; suppose the force in +! global coordinates has components f1, f2 and f3 +! + if(idof.eq.1) then + xload=f1 + elseif(idof.eq.2) then + xload=f2 + elseif(idof.eq.3) then + xload=f3 + endif + endif +! +! the contact force fcontact for local degree of freedom idof +! in node node can be obtained by (only available for nmethod=4): +! + if(nmethod.eq.4) then + fcontact=bcont(nactdof(idof,node)) + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cloads.f calculix-ccx-2.3/ccx_2.3/src/cloads.f --- calculix-ccx-2.1/ccx_2.3/src/cloads.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cloads.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,251 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cloads(inpc,textpart,set,istartset,iendset, + & ialset,nset,nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, + & amname,nam,ntrans,trab,inotr,co,ikforc,ilforc,nk, + & cload_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp,nam_, + & namtot_,namta,amta,nmethod,iaxial,iperturb,ipoinpc, + & maxsectors) +! +! reading the input deck: *CLOADS +! + implicit none +! + logical cload_flag,add,user +! + character*1 inpc(*) + character*80 amplitude,amname(*) + character*81 set(*),noset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),nodeforc(2,*), + & nset,nforc,nforc_,istep,istat,n,i,j,k,l,iforcdir,key, + & iamforc(*),nam,iamplitude,ntrans,inotr(2,*),ipos,ikforc(*), + & ilforc(*),nk,iline,ipol,inl,ipoinp(2,*),inp(3,*),nam_,namtot, + & namtot_,namta(3,*),idelay,lc,nmethod,ndirforc(*),isector, + & iperturb,iaxial,ipoinpc(0:*),maxsectors,jsector +! + real*8 xforc(*),forcval,co(3,*),trab(7,*),amta(2,*) +! + iamplitude=0 + idelay=0 + lc=1 + isector=0 + user=.false. + add=.false. +! + if(istep.lt.1) then + write(*,*) '*ERROR in cloads: *CLOAD should only be used' + write(*,*) ' within a STEP' + stop + endif +! + do i=2,n + if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.cload_flag)) then + do j=1,nforc + xforc(j)=0.d0 + enddo + elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then + read(textpart(i)(11:90),'(a80)') amplitude + do j=1,nam + if(amname(j).eq.amplitude) then + iamplitude=j + exit + endif + enddo + if(j.gt.nam) then + write(*,*)'*ERROR in cloads: nonexistent amplitude' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iamplitude=j + elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN + if(idelay.ne.0) then + write(*,*) '*ERROR in cloads: the parameter TIME DELAY' + write(*,*) ' is used twice in the same keyword' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + else + idelay=1 + endif + nam=nam+1 + if(nam.gt.nam_) then + write(*,*) '*ERROR in cloads: increase nam_' + stop + endif + amname(nam)=' + & ' + if(iamplitude.eq.0) then + write(*,*) '*ERROR in cloads: time delay must be' + write(*,*) ' preceded by the amplitude parameter' + stop + endif + namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) + iamplitude=nam + if(nam.eq.1) then + namtot=0 + else + namtot=namta(2,nam-1) + endif + namtot=namtot+1 + if(namtot.gt.namtot_) then + write(*,*) '*ERROR cloads: increase namtot_' + stop + endif + namta(1,nam)=namtot + namta(2,nam)=namtot + read(textpart(i)(11:30),'(f20.0)',iostat=istat) + & amta(1,namtot) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:9).eq.'LOADCASE=') then + read(textpart(i)(10:19),'(i10)',iostat=istat) lc + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(nmethod.ne.5) then + write(*,*) '*ERROR in cloads: the parameter LOAD CASE' + write(*,*) ' is only allowed in STEADY STATE' + write(*,*) ' DYNAMICS calculations' + stop + endif + elseif(textpart(i)(1:7).eq.'SECTOR=') then + read(textpart(i)(8:17),'(i10)',iostat=istat) isector + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if((nmethod.le.3).or.(iperturb.gt.1)) then + write(*,*) '*ERROR in cloads: the parameter SECTOR' + write(*,*) ' is only allowed in MODAL DYNAMICS or' + write(*,*) ' STEADY STATE DYNAMICS calculations' + stop + endif + if(isector.gt.maxsectors) then + write(*,*) '*ERROR in cloads: sector ',isector + write(*,*) ' exceeds number of sectors' + stop + endif + isector=isector-1 + elseif(textpart(i)(1:4).eq.'USER') then + user=.true. + else + write(*,*) + & '*WARNING in cloads: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(user.and.(iamplitude.ne.0)) then + write(*,*) '*WARNING: no amplitude definition is allowed' + write(*,*) ' for concentrated loads defined by a' + write(*,*) ' user routine' + iamplitude=0 + endif +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return +! + read(textpart(2)(1:10),'(i10)',iostat=istat) iforcdir + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if((iforcdir.lt.1).or.(iforcdir.gt.6)) then + write(*,*) '*ERROR in cloads: nonexistent degree of freedom' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + if(iforcdir.gt.3) iforcdir=iforcdir+1 +! + if(textpart(3)(1:1).eq.' ') then + forcval=0.d0 + else + read(textpart(3)(1:20),'(f20.0)',iostat=istat) forcval + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(iaxial.ne.0) forcval=forcval/iaxial + endif +! +! dummy flux consisting of the first primes +! + if(user) forcval=1.2357111317d0 +! + read(textpart(1)(1:10),'(i10)',iostat=istat) l + if(istat.eq.0) then + if(l.gt.nk) then + write(*,*) '*ERROR in cloads: node ',l + write(*,*) ' is not defined' + stop + endif + if(lc.ne.1) then + jsector=isector+maxsectors + else + jsector=isector + endif + call forcadd(l,iforcdir,forcval,nodeforc,ndirforc,xforc, + & nforc,nforc_,iamforc,iamplitude,nam,ntrans,trab,inotr,co, + & ikforc,ilforc,jsector,add,user) + else + read(textpart(1)(1:80),'(a80)',iostat=istat) noset + noset(81:81)=' ' + ipos=index(noset,' ') + noset(ipos:ipos)='N' + do i=1,nset + if(set(i).eq.noset) exit + enddo + if(i.gt.nset) then + noset(ipos:ipos)=' ' + write(*,*) '*ERROR in cloads: node set ',noset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + k=ialset(j) + if(lc.ne.1) then + jsector=isector+maxsectors + else + jsector=isector + endif + call forcadd(k,iforcdir,forcval, + & nodeforc,ndirforc,xforc,nforc,nforc_,iamforc, + & iamplitude,nam,ntrans,trab,inotr,co,ikforc,ilforc, + & jsector,add,user) + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + if(lc.ne.1) then + jsector=isector+maxsectors + else + jsector=isector + endif + call forcadd(k,iforcdir,forcval, + & nodeforc,ndirforc,xforc,nforc,nforc_, + & iamforc,iamplitude,nam,ntrans,trab,inotr,co, + & ikforc,ilforc,jsector,add,user) + enddo + endif + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/closefile.f calculix-ccx-2.3/ccx_2.3/src/closefile.f --- calculix-ccx-2.1/ccx_2.3/src/closefile.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/closefile.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,61 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine closefile() + implicit none +! +! closes files at the end of the calculation +! + logical frd,rout +! + character*5 p9999 +! +! closing the .inp file +! + close(1) +! +! closing the .dat file +! + close(5) +! + inquire(7,opened=frd) + if(frd) then +! +! closing the .frd file +! + p9999=' 9999' + write(7,'(a5)') p9999 + close(7) + else +! +! closing the .onf file +! + close(11) + endif +! +! closing the .sta file +! + close(11) +! +! closing the .rout file +! + inquire(15,opened=rout) + if(rout) close(15) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/compdt.f calculix-ccx-2.3/ccx_2.3/src/compdt.f --- calculix-ccx-2.1/ccx_2.3/src/compdt.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/compdt.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,188 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine compdt(nk,dt,nshcon,shcon,nrhcon,rhcon,vold,ntmat_, + & iponoel,inoel,dtimef,iexplicit,ielmat,physcon,dh,cocon, + & ncocon,ithermal,mi,ipkon,kon,lakon,dtl,ne,v,co) +! +! - determine the time step for each node (stored in field dt +! and the minimum value across all nodes (dtimef) +! + implicit none +! + character*8 lakon(*),lakonl +! + integer nk,i,j,k,iponoel(*),inoel(3,*),index,nelem,ithermal, + & nshcon(*),nrhcon(*),ntmat_,ielmat(*),imat,ncocon(2,*),mi(2), + & ipkon(*),kon(*),ne,nope,indexe,iflag,iexplicit +! + real*8 dtimef,dt(*),dvi,r,cp,rho,shcon(0:3,ntmat_,*), + & rhcon(0:1,ntmat_,*),vold(0:mi(2),*),temp,vel,dtu,dtnu, + & physcon(*),dh(*),cocon(0:6,ntmat_,*),dtal,cond,voldl(3,20), + & xl(3,20),vertex6(3,6),vertex8(3,8),xi,et,ze,xsj,shp(4,20), + & dtl(*),h,v(0:mi(2),*),co(3,*),dd +! + data vertex6 /0.d0,0.d0,0.d0,1.d0,0.d0,0.d0, + & 0.d0,1.d0,0.d0,0.d0,0.d0,1.d0, + & 1.d0,0.d0,1.d0,0.d0,1.d0,1.d0/ + data vertex8 /-1.d0,-1.d0,-1.d0,1.d0,-1.d0,-1.d0, + & 1.d0,1.d0,-1.d0,-1.d0,1.d0,-1.d0, + & -1.d0,-1.d0,1.d0,1.d0,-1.d0,1.d0, + & 1.d0,1.d0,1.d0,-1.d0,1.d0,1.d0/ + data iflag /3/ +c! +c! determining the element height in flow direction +c! +c if(iexplicit.eq.1) then +c do i=1,ne +c indexe=ipkon(i) +c if(indexe.lt.0) cycle +c lakonl(1:8)=lakon(i)(1:8) +c! +c! number of nodes in the element +c! +c if(lakonl(4:4).eq.'2') then +c nope=20 +c elseif(lakonl(4:4).eq.'8') then +c nope=8 +c elseif(lakonl(4:5).eq.'10') then +c nope=10 +c elseif(lakonl(4:4).eq.'4') then +c nope=4 +c elseif(lakonl(4:5).eq.'15') then +c nope=15 +c elseif(lakonl(4:4).eq.'6') then +c nope=6 +c else +c cycle +c endif +c! +c! velocity at the nodes +c! +c do j=1,nope +c do k=1,3 +c voldl(k,j)=vold(k,kon(indexe+j)) +c xl(k,j)=co(k,kon(indexe+j)) +c enddo +c enddo +c! +c! element height +c! +c h=0.d0 +c do j=1,nope +c if(nope.eq.20) then +c call shape20h(xi,et,ze,xl,xsj,shp,iflag) +c elseif(nope.eq.8) then +c xi=vertex8(1,j) +c et=vertex8(2,j) +c ze=vertex8(3,j) +c call shape8h(xi,et,ze,xl,xsj,shp,iflag) +c elseif(nope.eq.10) then +c call shape10tet(xi,et,ze,xl,xsj,shp,iflag) +c elseif(nope.eq.4) then +c call shape4tet(xi,et,ze,xl,xsj,shp,iflag) +c elseif(nope.eq.15) then +c call shape15w(xi,et,ze,xl,xsj,shp,iflag) +c elseif(nope.eq.6) then +c xi=vertex6(1,j) +c et=vertex6(2,j) +c ze=vertex6(3,j) +c call shape6w(xi,et,ze,xl,xsj,shp,iflag) +c endif +c! +c dd=dsqrt(voldl(1,j)*voldl(1,j)+ +c & voldl(2,j)*voldl(2,j)+voldl(3,j)*voldl(3,j)) +c if(dd.lt.1.d-10) then +c cycle +c else +c h=h+dabs(shp(1,j)*voldl(1,j)+shp(2,j)*voldl(2,j)+ +c & shp(3,j)*voldl(3,j))/dd +c endif +c enddo +c! +cc if(h.gt.0.d0) h=2.d0/h +c if(h.gt.0.d0) h=nope/h +c! +c! height at the nodes of the elements is replaced by the +c! element height of the latter is smaller +c! +c do j=1,nope +c if(dtl(kon(indexe+j)).gt.h) dtl(kon(indexe+j))=h +c enddo +c enddo +c endif +! +! determining the time increment dt for each node. +! +! edge nodes (fields iponoel and inoel are determined in precfd.f) +! + dtimef=1.d30 +! + do i=1,nk + index=iponoel(i) + if(index.le.0) cycle +! +! look at an element belonging to the edge node +! + nelem=inoel(1,index) +! +! determining the time increment +! + imat=ielmat(nelem) + temp=vold(0,i) +! +! density for gases +! + vel=dsqrt(vold(1,i)**2+vold(2,i)**2+vold(3,i)**2) + if(iexplicit.eq.1) then + call materialdata_cp(imat,ntmat_,temp,shcon,nshcon,cp) + r=shcon(3,1,imat) + dt(i)=dh(i)/(dsqrt(cp*r*temp/(cp-r))+vel) +c dtl(i)=dtl(i)/(dsqrt(cp*r*temp/(cp-r))+vel) +cstart shallow +cccc dt(i)=dh(i)/(dsqrt(10.d0*rho)+vel) +cend shallow +c if(dtl(i).lt.dtimef) dtimef=dtl(i) + if(dt(i).lt.dtimef) dtimef=dt(i) + else + call materialdata_dvi(imat,ntmat_,temp,shcon,nshcon,dvi) + call materialdata_rho(rhcon,nrhcon,imat,rho, + & temp,ntmat_,ithermal) + if(vel.lt.1.d-10) vel=1.d-10 + dtu=dh(i)/vel + if(dvi.lt.1.d-10) dvi=1.d-10 + dtnu=dh(i)*dh(i)*rho/(2.d0*dvi) + dt(i)=dtu*dtnu/(dtu+dtnu) + if(ithermal.gt.1) then + call materialdata_cond(imat,ntmat_,temp,cocon,ncocon, + & cond) + call materialdata_cp(imat,ntmat_,temp,shcon,nshcon,cp) + if(cond.lt.1.d-10) cond=1.d-10 + dtal=dh(i)*dh(i)*rho*cp/(2.d0*cond) + dt(i)=(dt(i)*dtal)/(dt(i)+dtal) + endif + if(dt(i).lt.dtimef) dtimef=dt(i) + endif +! + enddo +! +! middle nodes (interpolation between neighboring end nodes; +! still to be done) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/compfluid.c calculix-ccx-2.3/ccx_2.3/src/compfluid.c --- calculix-ccx-2.1/ccx_2.3/src/compfluid.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/compfluid.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1107 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES +#include "spooles.h" +#endif +#ifdef SGI +#include "sgi.h" +#endif +#ifdef TAUCS +#include "tau.h" +#endif +#ifdef PARDISO +#include "pardiso.h" +#endif + +char *lakon1,*sideload1, *matname1, *sideface1; + +int *nk1,*kon1,*ipkon1,*ne1,*nodeboun1,*ndirboun1,*nboun1,*ipompc1, + *nodempc1,*nmpc1,*nodeforc1,*ndirforc1,*nforc1,*nelemload1,*nload1, + *ipobody1,*nbody1,*nactdoh1,*icolv1,*jqv1,*irowv1,neqv1,nzlv1,*nmethod1, + *ikmpc1,*ilmpc1,*ikboun1,*ilboun1,*nrhcon1,*ielmat1,*ntmat_1,*ithermal1, + nzsv1,*mi1,*ncmat_1,*nshcon1,*istep1,*iinc1,*ibody1,*turbulent1, + *nelemface1,*nface1,compressible1,num_cpus,*icolp1,*jqp1,*irowp1, + neqp1,nzlp1,nzsp1,iexplicit1,*ncocon1,neqt1,nzst1,*ipvar1,*ipvarf1; + +double *co1,*xboun1,*coefmpc1,*xforc1,*xload1,*xbody1,*rhcon1,*t01, + *vold1,*voldcon1,dtimef1,*physcon1,*shcon1,*ttime1,timef1,*xloadold1, + *voldtu1,*yy1,*b=NULL,*xbounact1,theta11,*v1,theta21,*cocon1, + reltimef1,*dtl1,*var1,*varf1,*sti1; + +void compfluid(double *co, int *nk, int *ipkon, int *kon, char *lakon, + int *ne, int *ipoface, char *sideface, int *ifreestream, + int *nfreestream, int *isolidsurf, int *neighsolidsurf, + int *nsolidsurf, int *iponoel, int *inoel, int *nshcon, double *shcon, + int *nrhcon, double *rhcon, double *vold, int *ntmat_,int *nodeboun, + int *ndirboun, int *nboun, int *ipompc,int *nodempc, int *nmpc, + int *ikmpc, int *ilmpc, int *ithermal, int *ikboun, int *ilboun, + int *turbulent, int *isolver, int *iexpl, double *voldtu, double *ttime, + double *time, double *dtime, int *nodeforc,int *ndirforc,double *xforc, + int *nforc, int *nelemload, char *sideload, double *xload,int *nload, + double *xbody,int *ipobody,int *nbody, int *ielmat, char *matname, + int *mi, int *ncmat_, double *physcon, int *istep, int *iinc, + int *ibody, double *xloadold, double *xboun, + double *coefmpc, int *nmethod, double *xforcold, double *xforcact, + int *iamforc,int *iamload, double *xbodyold, double *xbodyact, + double *t1old, double *t1, double *t1act, int *iamt1, double *amta, + int *namta, int *nam, double *ampli, double *xbounold, double *xbounact, + int *iamboun, int *itg, int *ntg, char *amname, double *t0, int *nelemface, + int *nface, double *cocon, int *ncocon, double *xloadact, double *tper, + int *jmax, int *jout, char *set, int *nset, int *istartset, + int *iendset, int *ialset, char *prset, char *prlab, int *nprint, + double *trab, int *inotr, int *ntrans, char *filab, char *labmpc, + double *sti, int *norien, double *orab){ + + /* main computational fluid dynamics routine */ + + /* References: + + Zienkiewicz, O.C., Taylor, R.L. and Nithiarasu, P., "The Finite + Element Method for Fluid Dynamics", 6th Edition, Elsevier (2006) + + Menter, F.R., "Two-Equation Eddy-Viscosity Turbulence Models + for Engineering Applications", AIAA Journal(1994), 32(8), + 1598-1605 */ + + char cflag[1]; + + int *ipointer=NULL, *mast1=NULL, *irowt=NULL, *irowv=NULL, *irowp=NULL, + *irowk=NULL, *icolt=NULL, *icolv=NULL, *icolp=NULL, *icolk=NULL, + *jqt=NULL, *jqv=NULL, *jqp=NULL, *jqk=NULL, *nactdoh=NULL,i,j, + *nactdok=NULL, *nx=NULL, *ny=NULL, *nz=NULL,nzs,neqt,neqv,neqp, + neqk,nzst,nzsv,nzsp,nzsk,iexplicit,nzlt,nzlv,nzlp,nzlk,kode,nnstep, + convergence,iout,iit,symmetryflag=0,inputformat=0,compressible, + nmethodd,nstate_=0,*ielorien=NULL,*inum=NULL,ismooth=0, + *inomat=NULL,ikin=0,mt=mi[1]+1,*ipvar=NULL,*ipvarf=NULL,nvar_,nvarf_, + nfield,ndim,iorienglob,cfd=1,force=0,euler=1; + + double *yy=NULL, *xsolidsurf=NULL, *dt=NULL, *voldcon=NULL, *x=NULL, + *y=NULL, *z=NULL, *xo=NULL, *yo=NULL, *zo=NULL, *adbt=NULL, + *aubt=NULL, *adbv=NULL, *aubv=NULL, *adbp=NULL, *aubp=NULL, + *adbk=NULL, *aubk=NULL,*v=NULL, *vtu=NULL,timef,ttimef, + dtimef,*addiv=NULL,*sol=NULL, *aux=NULL,shockscale,*stn=NULL, + *bk=NULL,*bt=NULL,*solk=NULL,*solt=NULL,theta1,theta2,*adb=NULL, + *aub=NULL,sigma=0.,*dh=NULL,reltimef,*fn=NULL, + *eme=NULL,*qfx=NULL,*xstate=NULL,*ener=NULL, + csmooth=0.,shockcoef=1.,*sa=NULL,*sav=NULL,*dtl=NULL,*varf=NULL, + *adlt=NULL,*adlv=NULL,*adlp=NULL,*adlk=NULL,factor=1.,*var=NULL, + *voldconini=NULL; + + /* standard: shockcoef=1 */ + /* attention: set to 0.1 for test purposes! */ + +#ifdef SGI + int token; +#endif + + /* variables for multithreading procedure */ + + int sys_cpus; + char *env; + + num_cpus = 0; +#ifdef _SC_NPROCESSORS_CONF + sys_cpus = sysconf(_SC_NPROCESSORS_CONF); + if (sys_cpus <= 0) + sys_cpus = 1; +#else + sys_cpus = 1; +#endif + env = getenv("CCX_NPROC"); + if (env) + num_cpus = atoi(env); + if (num_cpus > 0) { +// if (num_cpus > sys_cpus) +// num_cpus = sys_cpus; + } else if (num_cpus == -1) { + num_cpus = sys_cpus; + } else { + num_cpus = 1; + } + printf("Using up to %d cpu(s) for spooles.\n", num_cpus); + + pthread_t tid[num_cpus]; + + kode=0; + + /* *iexpl==0: structure:implicit, fluid:semi-implicit + *iexpl==1: structure:implicit, fluid:explicit + *iexpl==2: structure:explicit, fluid:semi-implicit + *iexpl==3: structure:explicit, fluid:explicit */ + + if((*iexpl==1)||(*iexpl==3)){ + iexplicit=1;theta1=0.5;theta2=0.;compressible=1; + }else{ + iexplicit=0; + theta1=1.0;theta2=1.0;compressible=0; + } + + /* if initial conditions are specified for the temperature, + it is assumed that the temperature is an unknown */ + + if(*ithermal==1) *ithermal=2; + + /* determining the matrix structure */ + + nzs=1000000; + + ipointer=NNEW(int,3**nk); + mast1=NNEW(int,nzs); + irowv=NNEW(int,nzs); + irowp=NNEW(int,nzs); + icolv=NNEW(int,3**nk); + icolp=NNEW(int,*nk); + jqv=NNEW(int,3**nk+1); + jqp=NNEW(int,*nk+1); + nactdoh=NNEW(int,mt**nk); + inomat=NNEW(int,*nk); + + if(*ithermal>1){ + irowt=NNEW(int,nzs); + icolt=NNEW(int,*nk); + jqt=NNEW(int,*nk+1); + } + + if(*turbulent!=0){ + irowk=NNEW(int,nzs); + icolk=NNEW(int,*nk); + jqk=NNEW(int,*nk+1); + nactdok=NNEW(int,*nk); + } + + mastructf(nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,nboun,ipompc, + nodempc,nmpc,nactdoh,icolt,icolv,icolp,icolk,jqt,jqv,jqp, + jqk,&mast1,&irowt,&irowv,&irowp,&irowk,isolver,&neqt,&neqv, + &neqp,&neqk,ikmpc,ilmpc,ipointer,&nzst,&nzsv,&nzsp,&nzsk, + ithermal,ikboun,ilboun,turbulent,nactdok,ifreestream,nfreestream, + isolidsurf,nsolidsurf,&nzs,&iexplicit,ielmat,inomat,labmpc); + + free(ipointer);free(mast1); + + /* initialization */ + + yy=NNEW(double,*nk); + xsolidsurf=NNEW(double,*nsolidsurf); + dh=NNEW(double,*nk); + voldcon=NNEW(double,mt**nk); + voldconini=NNEW(double,mt**nk); + x=NNEW(double,*nsolidsurf); + y=NNEW(double,*nsolidsurf); + z=NNEW(double,*nsolidsurf); + xo=NNEW(double,*nsolidsurf); + yo=NNEW(double,*nsolidsurf); + zo=NNEW(double,*nsolidsurf); + nx=NNEW(int,*nsolidsurf); + ny=NNEW(int,*nsolidsurf); + nz=NNEW(int,*nsolidsurf); + + FORTRAN(initialcfd,(yy,nk,co,ne,ipkon,kon,lakon,x,y,z,xo,yo,zo, + nx,ny,nz,isolidsurf,neighsolidsurf,xsolidsurf,dh,nshcon,shcon, + nrhcon,rhcon,vold,voldcon,ntmat_,iponoel,inoel, + &iexplicit,ielmat,nsolidsurf,turbulent,physcon,&compressible, + matname,inomat,voldtu,mi,&euler,ithermal)); + + free(x);free(y);free(z);free(xo);free(yo);free(zo);free(nx);free(ny); + free(nz); + + /* calculating the shape functions, their derivatives and the + Jacobian determinant in the integration points of the elements */ + + nvar_=35**ne; + ipvar=NNEW(int,*ne); + var=NNEW(double,nvar_); + + nvarf_=8**ne; + ipvarf=NNEW(int,*ne); + varf=NNEW(double,nvarf_); + + calcshapef(&nvar_,ipvar,&var,ne,lakon,co,ipkon,kon, + nelemface,sideface,nface,&nvarf_,ipvarf, + &varf); + + /* composing those left hand sides which do not depend on the increment */ + + /* lhs for the energy */ + + if(*ithermal>1){ + adbt=NNEW(double,neqt); + aubt=NNEW(double,nzst); + + FORTRAN(mafilltlhs,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + xboun,nboun,ipompc,nodempc,coefmpc,nmpc, + nactdoh,icolt,jqt,irowt,&neqt,&nzlt, + ikmpc,ilmpc,ikboun,ilboun,&nzst,adbt,aubt,ipvar,var)); + + adlt=NNEW(double,neqt); + FORTRAN(lump,(adbt,aubt,adlt,irowt,jqt,&neqt)); + } + + /* lhs for the velocity */ + + adbv=NNEW(double,neqv); + aubv=NNEW(double,nzsv); + + FORTRAN(mafillvlhs,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + xboun,nboun,ipompc,nodempc,coefmpc,nmpc, + nactdoh,icolv,jqv,irowv,&neqv,&nzlv, + ikmpc,ilmpc,ikboun,ilboun,&nzsv,adbv,aubv,ipvar,var)); + + adlv=NNEW(double,neqv); + FORTRAN(lump,(adbv,aubv,adlv,irowv,jqv,&neqv)); + + /* lhs for the pressure */ + + adbp=NNEW(double,neqp); + aubp=NNEW(double,nzsp); + + FORTRAN(mafillplhs,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nactdoh,icolp,jqp, + irowp,&neqp,&nzlp,ikmpc,ilmpc,ikboun,ilboun,&nzsp,adbp,aubp, + nmethod,&iexplicit,ipvar,var)); + + if(iexplicit==1){ + adlp=NNEW(double,neqp); + FORTRAN(lump,(adbp,aubp,adlp,irowp,jqp,&neqp)); + } + + if((iexplicit!=1)&&(neqp>0)){ + + /* LU decomposition of the left hand matrix */ + + if(*isolver==0){ +#ifdef SPOOLES + spooles_factor(adbp,aubp,adb,aub,&sigma,icolp,irowp,&neqp,&nzsp, + &symmetryflag,&inputformat); +#else + printf("*ERROR in compfluid: the SPOOLES library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==4){ +#ifdef SGI + token=1; + sgi_factor(adbp,aubp,adb,aub,&sigma,icolp,irowp,&neqp,&nzsp,token); +#else + printf("*ERROR in compfluid: the SGI library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_factor(adbp,&aubp,adb,aub,&sigma,icolp,&irowp,&neqp,&nzsp); +#else + printf("*ERROR in compfluid: the TAUCS library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_factor(adbp,aubp,adb,aub,&sigma,icolp,irowp,&neqp,&nzsp); +#else + printf("*ERROR in compfluid: the PARDISO library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + + } + + /* lhs for the turbulent */ + + if(*turbulent!=0){ + adbk=NNEW(double,neqk); + aubk=NNEW(double,nzsk); + FORTRAN(mafillklhs,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + xboun,nboun,ipompc,nodempc,coefmpc,nmpc, + nactdok,icolk,jqk,irowk,&neqk,&nzlk, + ikmpc,ilmpc,ikboun,ilboun,&nzsk,adbk,aubk,ipvar,var)); + + adlk=NNEW(double,neqk); + FORTRAN(lump,(adbk,aubk,adlk,irowk,jqk,&neqk)); + } + + /* starting the main loop */ + + v=NNEW(double,mt**nk); + vtu=NNEW(double,2**nk); + + /* ttimef is the total time up to the start of the present increment + timef is the step time up to the end of the present increment + dtimef is the present increment size */ + + ttimef=*ttime; + timef=*time-*dtime; + dt=NNEW(double,*nk); +// if((iexplicit==1)&&(*nmethod==1))dtl=NNEW(double,*nk); + + if(compressible){ + sa=NNEW(double,neqt); + sav=NNEW(double,neqv); + } + + iit=0; + + do{ + + iit++; + + /* determining a new time increment */ + +// if((iexplicit==1)&&(*nmethod==1))for(i=0;i<*nk;i++)dtl[i]=1.e30; + FORTRAN(compdt,(nk,dt,nshcon,shcon,nrhcon,rhcon,vold,ntmat_,iponoel, + inoel,&dtimef,&iexplicit,ielmat,physcon,dh,cocon,ncocon,ithermal, + mi,ipkon,kon,lakon,dtl,ne,v,co)); + + /* fixed time */ + + timef+=dtimef; + if((*dtime1.) reltimef=1.; + + if(iit>10){ +// if(iit>=2){ +// if((iexplicit==1)&&(*nmethod==1)){dtimef*=factor;} + if(*nmethod==1){dtimef*=factor;} + } + + /* determining the instantaneous load */ + + if(*nmethod==1){ + nmethodd=4; + FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc, + xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, + xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,time,&reltimef,ttime,dtime,ithermal,&nmethodd, + xbounold,xboun,xbounact,iamboun,nboun, + nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, + co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload,mi, + ntrans,trab,inotr,vold)); +/* FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc, + xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, + xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,&timef,&reltimef,&ttimef,&dtimef,ithermal,nmethod, + xbounold,xboun,xbounact,iamboun,nboun, + nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, + co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload));*/ + }else if(*nmethod==4){ + FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc, + xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, + xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,&timef,&reltimef,&ttimef,&dtimef,ithermal,nmethod, + xbounold,xboun,xbounact,iamboun,nboun, + nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, + co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload,mi, + ntrans,trab,inotr,vold)); + } + + /* if((iit/jout[1])*jout[1]==iit){ + nnstep=6; + FORTRAN(frddummy,(co,nk,kon,ipkon,lakon,ne,v,vold, + &kode,&timef,ielmat,matname,&nnstep,vtu,voldtu,voldcon)); + }*/ + + /* STEP 1: velocity correction */ + + b=NNEW(double,num_cpus*neqv); + + co1=co;nk1=nk;kon1=kon;ipkon1=ipkon;lakon1=lakon;ne1=ne; + nodeboun1=nodeboun;ndirboun1=ndirboun;xboun1=xboun;nboun1=nboun; + ipompc1=ipompc;nodempc1=nodempc,coefmpc1=coefmpc;nmpc1=nmpc; + nodeforc1=nodeforc;ndirforc1=ndirforc;xforc1=xforc;nforc1=nforc; + nelemload1=nelemload;sideload1=sideload;xload1=xload;nload1=nload; + xbody1=xbody;ipobody1=ipobody;nbody1=nbody;nactdoh1=nactdoh; + icolv1=icolv;jqv1=jqv;irowv1=irowv;neqv1=neqv;nzlv1=nzlv; + nmethod1=nmethod;ikmpc1=ikmpc;ilmpc1=ilmpc;ikboun1=ikboun; + ilboun1=ilboun;rhcon1=rhcon;nrhcon1=nrhcon;ielmat1=ielmat; + ntmat_1=ntmat_;t01=t0;ithermal1=ithermal;vold1=vold;voldcon1=voldcon; + nzsv1=nzsv;dtimef1=dtimef;matname1=matname;mi1=mi;ncmat_1=ncmat_; + physcon1=physcon;shcon1=shcon;nshcon1=nshcon;ttime1=ttime; + timef1=timef;istep1=istep;iinc1=iinc;ibody1=ibody;xloadold1=xloadold; + turbulent1=turbulent;voldtu1=voldtu;yy1=yy;nelemface1=nelemface; + sideface1=sideface;nface1=nface;compressible1=compressible; + dtl1=dtl;ipvar1=ipvar;var1=var;ipvarf1=ipvarf;varf1=varf;sti1=sti; + + /* create threads and wait */ + + for(i=0; i0)){ + aux=NNEW(double,neqp); + FORTRAN(solveeq,(adbp,aubp,adlp,addiv,b,sol,aux,icolp,irowp,jqp, + &neqp,&nzsp,&nzlp)); + free(b);free(aux); + }else if(neqp>0){ + + /* solving the system of equations (only for liquids) */ + + if(*isolver==0){ +#ifdef SPOOLES + spooles_solve(b,&neqp); +#endif + } + else if(*isolver==4){ +#ifdef SGI + sgi_solve(b,token); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_solve(b,&neqp); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_solve(b,&neqp); +#endif + } + + /* copying the solution into field sol */ + + for(i=0;i1){ + + + b=NNEW(double,num_cpus*neqt); + + co1=co;nk1=nk;kon1=kon;ipkon1=ipkon;lakon1=lakon;ne1=ne; + nodeboun1=nodeboun;ndirboun1=ndirboun;xboun1=xboun;nboun1=nboun; + ipompc1=ipompc;nodempc1=nodempc,coefmpc1=coefmpc;nmpc1=nmpc; + nodeforc1=nodeforc;ndirforc1=ndirforc;xforc1=xforc;nforc1=nforc; + nelemload1=nelemload;sideload1=sideload;xload1=xload;nload1=nload; + xbody1=xbody;ipobody1=ipobody;nbody1=nbody;nactdoh1=nactdoh; + neqt1=neqt; + nmethod1=nmethod;ikmpc1=ikmpc;ilmpc1=ilmpc;ikboun1=ikboun; + ilboun1=ilboun;rhcon1=rhcon;nrhcon1=nrhcon;ielmat1=ielmat; + ntmat_1=ntmat_;t01=t0;ithermal1=ithermal;vold1=vold;voldcon1=voldcon; + nzst1=nzst;dtimef1=dtimef;matname1=matname;mi1=mi;ncmat_1=ncmat_; + physcon1=physcon;shcon1=shcon;nshcon1=nshcon;ttime1=ttime; + timef1=timef;istep1=istep;iinc1=iinc;ibody1=ibody;xloadold1=xloadold; + reltimef1=reltimef;cocon1=cocon;ncocon1=ncocon;nelemface1=nelemface; + sideface1=sideface;nface1=nface;compressible1=compressible;v1=v; + voldtu1=voldtu;yy1=yy;turbulent1=turbulent; + dtl1=dtl;ipvar1=ipvar;var1=var;ipvarf1=ipvarf;varf1=varf; + + for(i=0; i0)&&(strcmp1(&filab[179],"L")==0)){ + iorienglob=1; + }else{ + iorienglob=0; + } + strcpy1(&cflag[0],&filab[178],1); + stn=NNEW(double,6**nk); + inum=NNEW(int,*nk); + FORTRAN(extrapolate,(sti,stn,ipkon,inum,kon,lakon, + &nfield,nk,ne,mi,&ndim,orab,ielorien,co,&iorienglob, + cflag,nelemload,nload,nodeboun,nboun,ndirboun, + vold,ithermal,&force,&cfd));*/ + + /* smoothing the solution (only for compressible fluids) */ + + if(compressible){ + + ismooth=1; + + /* shocksmoothing rho * total energy density */ + + sol=NNEW(double,neqt); + aux=NNEW(double,neqt); + for(i=0;i0)&&(strcmp1(&filab[179],"L")==0)){ + iorienglob=1; + }else{ + iorienglob=0; + } + strcpy1(&cflag[0],&filab[178],1); + stn=NNEW(double,6**nk); + inum=NNEW(int,*nk); + FORTRAN(extrapolate,(sti,stn,ipkon,inum,kon,lakon, + &nfield,nk,ne,mi,&ndim,orab,ielorien,co,&iorienglob, + cflag,nelemload,nload,nodeboun,nboun,ndirboun, + vold,ithermal,&force,&cfd)); + } + + /* check whether the Mach number is requested */ + + if((strcmp1(&filab[1914],"MACH")==0)|| + (strcmp1(&filab[1131],"TT")==0)){ + FORTRAN(calcmach,(vold,voldcon,v,nk, + ielmat,ntmat_,shcon,nshcon,rhcon,nrhcon,&iout, + nmethod,&convergence,physcon,iponoel,inoel,ithermal, + nactdoh,&iit,&compressible,&ismooth,voldtu,vtu,turbulent, + inomat,nodeboun,ndirboun,nboun,mi,co,&factor)); + } + + nnstep=6; + FORTRAN(frdfluid,(co,nk,kon,ipkon,lakon,ne,v,vold, + &kode,&timef,ielmat,matname,&nnstep,vtu,voldtu,voldcon, + physcon,filab,inomat,ntrans,inotr,trab,mi,stn)); + + if(strcmp1(&filab[174],"S ")==0){free(stn);free(inum);} + + } + + if(((iit/jout[1])*jout[1]==iit)||(convergence==1)){ + FORTRAN(printout,(set,nset,istartset,iendset,ialset,nprint, + prlab,prset,vold,t1,fn,ipkon,lakon,sti,eme,xstate,ener, + mi,&nstate_,ithermal,co,kon,qfx,&timef,trab,inotr,ntrans, + orab,ielorien,norien,nk,ne,inum,filab,vold,&ikin)); + + /* lift and drag force */ + + FORTRAN(printoutface,(co,rhcon,nrhcon,ntmat_,vold,shcon,nshcon, + cocon,ncocon,&compressible,istartset,iendset,ipkon,lakon,kon, + ialset,prset,&timef,nset,set,nprint,prlab,ielmat,mi)); + } + + if(convergence==1){ +/* nnstep=6; + FORTRAN(frdfluid,(co,nk,kon,ipkon,lakon,ne,v,vold, + &kode,&timef,ielmat,matname,&nnstep,vtu,voldtu,voldcon, + physcon,filab,inomat,ntrans,inotr,trab,mi,stn));*/ + break; + } + if(iit==jmax[1]) FORTRAN(stop,()); + + ttimef+=dtimef; + }while(1); + + if((iexplicit!=1)&&(neqp>0)){ + if(*isolver==0){ +#ifdef SPOOLES + spooles_cleanup(); +#endif + } + else if(*isolver==4){ +#ifdef SGI + sgi_cleanup(token); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_cleanup(); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_cleanup(&neqp); +#endif + } + } + + if(compressible){free(sa);free(sav);} + + free(yy);free(xsolidsurf);free(dt);free(dh);free(voldcon);free(voldconini); +// if((iexplicit==1)&&(*nmethod==1))free(dtl); + + free(irowv);free(irowp); + free(icolv);free(icolp); + free(jqv);free(jqp); + free(nactdoh);free(inomat); + + free(adbv);free(adbp); + free(aubv);free(aubp); + free(adlv);if(iexplicit==1) free(adlp); + + if(*ithermal>1){ + free(irowt);free(icolt);free(jqt);free(adbt);free(aubt);free(adlt); + } + + if(*turbulent!=0){ + free(irowk);free(icolk);free(jqk);free(nactdok); + free(adbk);free(aubk);free(adlk); + } + + free(v);free(vtu);free(var);free(ipvar);free(varf);free(ipvarf); + + return; + +} + +/* subroutine for multithreading of mafillv1rhs */ + +void *mafillv1rhsmt(void *i){ + + int index,nea,neb,nedelta; + + index=((int)i)*neqv1; + + nedelta=(int)ceil(*ne1/(double)num_cpus); + nea=((int)i)*nedelta+1; + neb=(((int)i)+1)*nedelta; + if(neb>*ne1) neb=*ne1; + + FORTRAN(mafillv1rhs,(co1,nk1,kon1,ipkon1,lakon1,ne1,nodeboun1,ndirboun1, + xboun1,nboun1,ipompc1,nodempc1,coefmpc1,nmpc1,nodeforc1,ndirforc1,xforc1, + nforc1,nelemload1,sideload1,xload1,nload1,xbody1,ipobody1,nbody1, + &b[index],nactdoh1,icolv1,jqv1,irowv1,&neqv1,&nzlv1,nmethod1,ikmpc1,ilmpc1,ikboun1, + ilboun1,rhcon1,nrhcon1,ielmat1,ntmat_1,t01,ithermal1,vold1,voldcon1,&nzsv1, + dtl1,matname1,mi1,ncmat_1,physcon1,shcon1,nshcon1,ttime1,&timef1, + istep1,iinc1,ibody1,xloadold1,turbulent1,voldtu1,yy1, + nelemface1,sideface1,nface1,&compressible1,&nea,&neb,&dtimef1, + ipvar1,var1,ipvarf1,varf1,sti1)); + + return NULL; +} + +/* subroutine for multithreading of mafillprhs */ + +void *mafillprhsmt(void *i){ + + int index,nea,neb,nedelta; + + index=((int)i)*neqp1; + + nedelta=(int)ceil(*ne1/(double)num_cpus); + nea=((int)i)*nedelta+1; + neb=(((int)i)+1)*nedelta; + if(neb>*ne1) neb=*ne1; + + FORTRAN(mafillprhs,(co1,nk1,kon1,ipkon1,lakon1,ne1,nodeboun1,ndirboun1, + xbounact1,nboun1,ipompc1,nodempc1,coefmpc1,nmpc1,nelemface1,sideface1, + nface1,&b[index],nactdoh1,icolp1,jqp1,irowp1,&neqp1,&nzlp1,nmethod1,ikmpc1,ilmpc1, + ikboun1,ilboun1,rhcon1,nrhcon1,ielmat1,ntmat_1,vold1,voldcon1,&nzsp1, + dtl1,matname1,mi1,ncmat_1,shcon1,nshcon1,v1,&theta11, + &iexplicit1,physcon1,&nea,&neb,&dtimef1,ipvar1,var1,ipvarf1,varf1)); + + return NULL; +} + +/* subroutine for multithreading of mafillv2rhs */ + +void *mafillv2rhsmt(void *i){ + + int index,nea,neb,nedelta; + + index=((int)i)*neqv1; + + nedelta=(int)ceil(*ne1/(double)num_cpus); + nea=((int)i)*nedelta+1; + neb=(((int)i)+1)*nedelta; + if(neb>*ne1) neb=*ne1; + + FORTRAN(mafillv2rhs,(co1,nk1,kon1,ipkon1,lakon1,ne1,nodeboun1,ndirboun1, + xboun1,nboun1,ipompc1,nodempc1,coefmpc1,nmpc1, + &b[index],nactdoh1,icolv1,jqv1,irowv1,&neqv1,&nzlv1,nmethod1,ikmpc1,ilmpc1,ikboun1, + ilboun1,vold1,&nzsv1,dtl1,v1,&theta21,&iexplicit1,&nea,&neb,mi1,&dtimef1, + ipvar1,var1,ipvarf1,varf1)); + + return NULL; +} + +/* subroutine for multithreading of mafilltrhs */ + +void *mafilltrhsmt(void *i){ + + int index,nea,neb,nedelta; + + index=((int)i)*neqt1; + + nedelta=(int)ceil(*ne1/(double)num_cpus); + nea=((int)i)*nedelta+1; + neb=(((int)i)+1)*nedelta; + if(neb>*ne1) neb=*ne1; + + FORTRAN(mafilltrhs,(co1,nk1,kon1,ipkon1,lakon1,ne1,nodeboun1,ndirboun1, + xboun1,nboun1,ipompc1,nodempc1,coefmpc1,nmpc1,nodeforc1,ndirforc1,xforc1, + nforc1,nelemload1,sideload1,xload1,nload1,xbody1,ipobody1,nbody1, + &b[index],nactdoh1,&neqt1,nmethod1,ikmpc1,ilmpc1,ikboun1, + ilboun1,rhcon1,nrhcon1,ielmat1,ntmat_1,t01,ithermal1,vold1,voldcon1,&nzst1, + dtl1,matname1,mi1,ncmat_1,physcon1,shcon1,nshcon1,ttime1,&timef1, + istep1,iinc1,ibody1,xloadold1,&reltimef1,cocon1,ncocon1,nelemface1, + sideface1,nface1,&compressible1,v1,voldtu1,yy1,turbulent1,&nea, + &neb,&dtimef1,ipvar1,var1,ipvarf1,varf1)); + + return NULL; +} + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/conductivities.f calculix-ccx-2.3/ccx_2.3/src/conductivities.f --- calculix-ccx-2.1/ccx_2.3/src/conductivities.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/conductivities.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,135 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine conductivities(inpc,textpart,cocon,ncocon, + & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, + & ipoinpc) +! +! reading the input deck: *CONDUCTIVITY +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer ncocon(2,*),nmat,ntmat,ntmat_,istep,istat,n,ipoinpc(0:*), + & i,ityp,key,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) +! + real*8 cocon(0:6,ntmat_,*) +! + ntmat=0 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in conductivities: *CONDUCTIVITY should be' + write(*,*) ' placed before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*)'*ERROR in conductivities: *CONDUCTIVITY should be' + write(*,*) ' preceded by a *MATERIAL card' + stop + endif +! + ityp=1 +! + do i=2,n + if(textpart(i)(1:5).eq.'TYPE=') then + if(textpart(i)(6:8).eq.'ISO') then + ityp=1 + elseif(textpart(i)(6:10).eq.'ORTHO') then + ityp=3 + elseif(textpart(i)(6:10).eq.'ANISO') then + ityp=6 + endif + else + write(*,*) + & '*WARNING in conductivities: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + ncocon(1,nmat)=ityp +! + if(ityp.eq.1) then + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + ncocon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in conductivities: increase ntmat_' + stop + endif + do i=1,1 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & cocon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + read(textpart(2)(1:20),'(f20.0)',iostat=istat) + & cocon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + elseif(ityp.eq.3) then + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + ncocon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in conductivities: increase ntmat_' + stop + endif + do i=1,3 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & cocon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + read(textpart(4)(1:20),'(f20.0)',iostat=istat) + & cocon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + elseif(ityp.eq.6) then + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + ncocon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in conductivities: increase ntmat_' + stop + endif + do i=1,6 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & cocon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + read(textpart(7)(1:20),'(f20.0)',iostat=istat) + & cocon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/contact.c calculix-ccx-2.3/ccx_2.3/src/contact.c --- calculix-ccx-2.1/ccx_2.3/src/contact.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/contact.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,114 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" + +void contact(int *ncont, int *ntie, char *tieset,int *nset,char *set, + int *istartset, int *iendset, int *ialset,int *itietri, + char *lakon, int *ipkon, int *kon, int *koncont, int *ne, + double *cg, double *straight, int *ifree, double *co, + double *vold, int *ielmat, double *cs, double *elcon, + int *istep,int *iinc,int *iit,int *ncmat_,int *ntmat_, + int *ne0, double *vini, + int *nmethod, int *nmpc, int *mpcfree, int *memmpc_, + int **ipompcp, char **labmpcp, int **ikmpcp, int **ilmpcp, + double **fmpcp, int **nodempcp, double **coefmpcp, + int *iperturb, int *ikboun, int *nboun, int *mi, + int *imastop,int *nslavnode,int *islavnode,int *islavsurf, + int *itiefac,double *areaslav,int *iponoels,int *inoels, + double *springarea, double *tietol, double *reltime){ + + char *labmpc=NULL; + + int i,ntrimax,*nx=NULL,*ny=NULL,*nz=NULL,*ipompc=NULL,*ikmpc=NULL, + *ilmpc=NULL,*nodempc=NULL,nmpc_; + + double *xo=NULL,*yo=NULL,*zo=NULL,*x=NULL,*y=NULL,*z=NULL, + *fmpc=NULL, *coefmpc=NULL; + + ipompc=*ipompcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; + fmpc=*fmpcp;nodempc=*nodempcp;coefmpc=*coefmpcp; + nmpc_=*nmpc; + + FORTRAN(updatecont,(koncont,ncont,co,vold, + cg,straight,mi)); + +/* printf("before remcontmpc mpcnew=%d\n",*nmpc); + for(i=0;i<*nmpc;i++){ + j=i+1; + FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); + }*/ + + /* deleting contact MPC's (not for modal dynamics calculations) */ + +/* if(*iperturb>1){ + remcontmpc(nmpc,labmpc,mpcfree,nodempc,ikmpc,ilmpc,coefmpc,ipompc); + }*/ + + /* determining the size of the auxiliary fields */ + + ntrimax=0; + for(i=0;i<*ntie;i++){ + if(itietri[2*i+1]-itietri[2*i]+1>ntrimax) + ntrimax=itietri[2*i+1]-itietri[2*i]+1; + } + xo=NNEW(double,ntrimax); + yo=NNEW(double,ntrimax); + zo=NNEW(double,ntrimax); + x=NNEW(double,ntrimax); + y=NNEW(double,ntrimax); + z=NNEW(double,ntrimax); + nx=NNEW(int,ntrimax); + ny=NNEW(int,ntrimax); + nz=NNEW(int,ntrimax); + + FORTRAN(gencontelem,(tieset,ntie,itietri,ne,ipkon,kon,lakon, + cg,straight,ifree,koncont, + co,vold,xo,yo,zo,x,y,z,nx,ny,nz,ielmat,cs,elcon,istep, + iinc,iit,ncmat_,ntmat_,ne0,vini,nmethod,mi, + imastop,nslavnode,islavnode,islavsurf,itiefac,areaslav,iponoels, + inoels,springarea,ikmpc,ilmpc,nmpc,ipompc,nodempc,coefmpc, + set,nset,istartset,iendset,ialset,tietol,reltime)); + + free(xo);free(yo);free(zo);free(x);free(y);free(z);free(nx); + free(ny);free(nz); + + /* generate MPC's for the middle nodes of the dependent contact + surface; they are connected to their endnode neighbors + (not for modal dynamic calculations) */ + +// printf("mpcold=%d\n",*nmpc); +/* if(*iperturb>1){ + gencontmpc(ne,ne0,lakon,ipkon,kon,nmpc,&ikmpc,&ilmpc,&ipompc,mpcfree, + &fmpc,&labmpc,&nodempc,memmpc_,&coefmpc,&nmpc_,ikboun, + nboun); + }*/ +// printf("mpcnew=%d\n",*nmpc); + + /* for(i=0;i<*nmpc;i++){ + j=i+1; + FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); + }*/ + + *ipompcp=ipompc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; + *fmpcp=fmpc;*nodempcp=nodempc;*coefmpcp=coefmpc; + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/contactdampings.f calculix-ccx-2.3/ccx_2.3/src/contactdampings.f --- calculix-ccx-2.1/ccx_2.3/src/contactdampings.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/contactdampings.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,68 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine contactdampings(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, + & inp,ipoinpc) +! +! reading the input deck: *CONTACT DAMPING +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat_,istep,istat,ipoinpc(0:*), + & n,key,i,ncmat_,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) +! + real*8 elcon(0:ncmat_,ntmat_,*) +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in contactdampings:' + write(*,*) ' *CONTACT DAMPING should be placed' + write(*,*) ' before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in contactdampings:' + write(*,*) ' *CONTACT DAMPING should be preceded' + write(*,*) ' by a *SURFACE INTERACTION card' + stop + endif +! + nelcon(1,nmat)=5 + nelcon(2,nmat)=1 +! +! no temperature dependence allowed; last line is decisive +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + do i=1,3 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(2+i,1,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + elcon(0,1,nmat)=0.d0 + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/contactmortar.c calculix-ccx-2.3/ccx_2.3/src/contactmortar.c --- calculix-ccx-2.1/ccx_2.3/src/contactmortar.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/contactmortar.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,668 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +void contactmortar(int *ncont, int *ntie, char *tieset, int *nset, char *set, + int *istartset, int *iendset, int *ialset, int *itietri, + char *lakon, int *ipkon, int *kon, int *koncont, int *ne, + double *cg, double *straight, double *co, + double *vold, int *ielmat, double *cs, double *elcon, + int *istep,int *iinc,int *iit,int *ncmat_,int *ntmat_, + int *ne0, double *vini, + int *nmethod,int *neq, int *nzs, int *nactdof, int *itiefac, + int *islavsurf, int *islavnode, int *imastnode, + int *nslavnode, int *nmastnode, int *ncone, double *ad, + double **aup, double *b, int **irowp, int *icol, int *jq, int *imastop, + int *iponoels, int *inoels, int *nzsc, double **aucp, + double *adc, int **irowcp, int *jqc, int *islavact, + double *gap, double *bdd, double **auqdtp, int **irowqdtp, + int *jqqdt, int *nzsqdt, int *nzlc,double *slavnor,double *bhat, + int *icolc, double **aubdp, int **irowbdp, int *jqbd, int *mi, + int *ipe, int *ime,double *tietol){ + + int i,j,k,numb,ntrimax,*nx=NULL,*ny=NULL,*nz=NULL,nintpoint=0, + nzsbd,*irowbd=NULL,l,nstart,kflag,ntri,ii,number, + *irowc=NULL,*imastsurf=NULL,jrow,jcol,islavnodeentry, + *islavactdof=NULL,*irow=NULL,*irowqdt=NULL,* jqctemp=NULL, + * irowctemp=NULL,jslavnodeentry; + + double *xo=NULL,*yo=NULL,*zo=NULL,*x=NULL,*y=NULL,*z=NULL,*aubd=NULL, + *auc=NULL, *pmastsurf=NULL,*auqdt=NULL,*gapmints=NULL,*pslavdual=NULL, + *slavtan=NULL,t1,t2,t3,e1,e2,e3,*au=NULL,* auctemp=NULL,*pslavsurf=NULL, + *areaslav=NULL; + + clock_t debut; + clock_t fin; + irow = *irowp; au=*aup; auc=*aucp; irowc=*irowcp; auqdt=*auqdtp; + irowqdt=*irowqdtp; aubd=*aubdp; irowbd=*irowbdp; + + /* update the location of the center of gravity of + the master triangles and the coefficients of their + bounding planes */ + + FORTRAN(updatecont,(koncont,ncont,co,vold, + cg,straight,mi)); + + /* determining the size of the auxiliary fields + (needed for the master triangle search for any + given location on the slave faces */ + + ntrimax=0; + for(i=0;i<*ntie;i++){ + if(itietri[2*i+1]-itietri[2*i]+1>ntrimax) + ntrimax=itietri[2*i+1]-itietri[2*i]+1; + } + + if ((*iinc==1)&&(*iit==1)){ + xo=NNEW(double,ntrimax); + yo=NNEW(double,ntrimax); + zo=NNEW(double,ntrimax); + x=NNEW(double,ntrimax); + y=NNEW(double,ntrimax); + z=NNEW(double,ntrimax); + nx=NNEW(int,ntrimax); + ny=NNEW(int,ntrimax); + nz=NNEW(int,ntrimax); + areaslav=NNEW(double,itiefac[2*(*ntie-1)+1]); + int ifree=0; + FORTRAN(genfirstactif,(tieset,ntie,itietri,ne,ipkon,kon,lakon, + cg,straight,koncont, + co,vold,xo,yo,zo,x,y,z,nx,ny,nz,ielmat,cs,elcon,istep, + iinc,iit,ncmat_,ntmat_,ne0,vini,nmethod,mi, + imastop,nslavnode,islavnode,islavsurf,itiefac,areaslav,iponoels, + inoels,set,nset,istartset,iendset,ialset,islavact,&ifree, + tietol)); + printf("Frist Active Set : %d nodes\n",ifree); + free(xo);free(yo);free(zo);free(x);free(y);free(z);free(nx); + free(ny);free(nz); + free(areaslav); + } + + xo=NNEW(double,ntrimax); + yo=NNEW(double,ntrimax); + zo=NNEW(double,ntrimax); + x=NNEW(double,ntrimax); + y=NNEW(double,ntrimax); + z=NNEW(double,ntrimax); + nx=NNEW(int,ntrimax); + ny=NNEW(int,ntrimax); + nz=NNEW(int,ntrimax); + + slavtan=NNEW(double,6*nslavnode[*ntie]); + pslavdual=NNEW(double,16*itiefac[2**ntie-1]); + + /* calculating the normals in the nodes of the slave + surface, the coefficients of the dual shape functions + (only for quads) and the gap size at the regular + integration points */ + + debut=clock(); + FORTRAN(gencontrel,(tieset,ntie,itietri,ipkon,kon, + lakon,set,cg,straight, + koncont,co,vold,xo,yo,zo,x,y,z,nx,ny,nz,nset, + iinc,iit, + islavsurf,imastsurf,pmastsurf,itiefac, + islavnode,nslavnode,slavnor,slavtan,imastop, + mi,ncont,ipe,ime,pslavsurf,pslavdual)); + fin= clock(); + printf("gencontrel : %f s\n",((double)(fin-debut))/CLOCKS_PER_SEC); + /* Calculating the location of the matched slave/master + integration points */ + + + debut=clock(); + imastsurf=NNEW(int,66); + gapmints=NNEW(double,66); + pmastsurf=NNEW(double,132); + pslavsurf=NNEW(double,198); + islavsurf[1]=0; + for(i=0;i<*ntie;i++){ + ii=i+1; + if(tieset[i*(81*3)+80]=='C'){ + nstart=itietri[2*i]-1; + ntri=itietri[2*i+1]-nstart; + for(j=0;j0){ + numb=(jqc[j+1]-jqc[j]); + FORTRAN(isortid,(&irowc[jqc[j]-1],&auc[jqc[j]-1],&numb,&kflag)); + } + } + + /* copying auc,adc,irowc, jqc and bhat into + au,ad,irow,jq and b */ + + RENEW(au,double,*nzsc); + RENEW(irow,int,*nzsc); + for(i=0;i0){ //risk Actif-Actif + islavnodeentry = floor(islavactdof[j]/10.); + jrow= islavactdof[j]-10*islavnodeentry; + + k=irow[i]-1; + if(islavactdof[k]>0){ + switch(jrow){ + + case 1 : + if(k==j+1){ + + e1=adc[j]; + e2=auc[i]; + e3=auc[i+1]; + jslavnodeentry=floor(islavactdof[j]/10.); + + ad[j]=slavnor[3*(jslavnodeentry-1)+jrow-1]; + t1=slavtan[6*(islavnodeentry-1)]; + t2=slavtan[6*(islavnodeentry-1)+1]; + t3=slavtan[6*(islavnodeentry-1)+2]; + + au[i]=t1*e1+t2*e2+t3*e3; + + t1=slavtan[6*(islavnodeentry-1)+3]; + t2=slavtan[6*(islavnodeentry-1)+4]; + t3=slavtan[6*(islavnodeentry-1)+5]; + + au[++i]=t1*e1+t2*e2+t3*e3; + + } + else{ //normal scheme + islavnodeentry = floor(islavactdof[k]/10.); + jrow= islavactdof[k]-10*islavnodeentry; + + if (jrow==1){ + e1=auc[i]; + jslavnodeentry=floor(islavactdof[j]/10.); + if (islavnodeentry!=jslavnodeentry){ + au[i]=0; + }else{ + jcol=islavactdof[j]-10*jslavnodeentry; + au[i]=slavnor[3*(islavnodeentry-1)+jcol-1]; + } + } + else if (jrow==2){ + t1=slavtan[6*(islavnodeentry-1)]; + t2=slavtan[6*(islavnodeentry-1)+1]; + t3=slavtan[6*(islavnodeentry-1)+2]; + e2=auc[i]; + if((k+1)==j){e3=adc[j];}else{e3=auc[i+1];} + au[i]=t1*e1+t2*e2+t3*e3; + + } + else{ + t1=slavtan[6*(islavnodeentry-1)+3]; + t2=slavtan[6*(islavnodeentry-1)+4]; + t3=slavtan[6*(islavnodeentry-1)+5]; + + au[i]=t1*e1+t2*e2+t3*e3; + + } + } + break; + + case 2 : if(k==j-1){ + + e1=auc[i]; + e2=ad[j]; + e3=auc[i+1]; + + au[i]=slavnor[3*(jslavnodeentry-1)+jrow-1]; + + t1=slavtan[6*(islavnodeentry-1)]; + t2=slavtan[6*(islavnodeentry-1)+1]; + t3=slavtan[6*(islavnodeentry-1)+2]; + + ad[j]=t1*e1+t2*e2+t3*e3; + t1=slavtan[6*(islavnodeentry-1)+3]; + t2=slavtan[6*(islavnodeentry-1)+4]; + t3=slavtan[6*(islavnodeentry-1)+5]; + + au[++i]=t1*e1+t2*e2+t3*e3; + + }else{ //normal scheme + islavnodeentry = floor(islavactdof[k]/10.); + jrow= islavactdof[k]-10*islavnodeentry; + + if (jrow==1){ + e1=auc[i]; + jslavnodeentry=floor(islavactdof[j]/10.); + if (islavnodeentry!=jslavnodeentry){ + au[i]=0; + }else{ + jcol=islavactdof[j]-10*jslavnodeentry; + au[i]=slavnor[3*(islavnodeentry-1)+jcol-1]; + + } + } + else if (jrow==2){ + t1=slavtan[6*(islavnodeentry-1)]; + t2=slavtan[6*(islavnodeentry-1)+1]; + t3=slavtan[6*(islavnodeentry-1)+2]; + e2=auc[i]; + if((k+1)==j){e3=adc[j];}else{e3=auc[i+1];} + au[i]=t1*e1+t2*e2+t3*e3; + + } + else{ + t1=slavtan[6*(islavnodeentry-1)+3]; + t2=slavtan[6*(islavnodeentry-1)+4]; + t3=slavtan[6*(islavnodeentry-1)+5]; + + au[i]=t1*e1+t2*e2+t3*e3; + + } + } + break; + + case 3 : if (k==j-2){ + + e1=auc[i]; + e2=auc[i+1]; + e3=adc[j]; + + au[i]=slavnor[3*(jslavnodeentry-1)+jrow-1]; + + t1=slavtan[6*(islavnodeentry-1)]; + t2=slavtan[6*(islavnodeentry-1)+1]; + t3=slavtan[6*(islavnodeentry-1)+2]; + + au[++i]=t1*e1+t2*e2+t3*e3; + + t1=slavtan[6*(islavnodeentry-1)+3]; + t2=slavtan[6*(islavnodeentry-1)+4]; + t3=slavtan[6*(islavnodeentry-1)+5]; + + ad[j]=t1*e1+t2*e2+t3*e3; + } + else{ //normal scheme + islavnodeentry = floor(islavactdof[k]/10.); + jrow= islavactdof[k]-10*islavnodeentry; + + if (jrow==1){ + e1=auc[i]; + jslavnodeentry=floor(islavactdof[j]/10.); + if (islavnodeentry!=jslavnodeentry){ + au[i]=0; + }else{ + jcol=islavactdof[j]-10*jslavnodeentry; + au[i]=slavnor[3*(islavnodeentry-1)+jcol-1]; + + } + } + else if (jrow==2){ + t1=slavtan[6*(islavnodeentry-1)]; + t2=slavtan[6*(islavnodeentry-1)+1]; + t3=slavtan[6*(islavnodeentry-1)+2]; + e2=auc[i]; + if((k+1)==j){e3=adc[j];}else{e3=auc[i+1];} + au[i]=t1*e1+t2*e2+t3*e3; + + } + else{ + t1=slavtan[6*(islavnodeentry-1)+3]; + t2=slavtan[6*(islavnodeentry-1)+4]; + t3=slavtan[6*(islavnodeentry-1)+5]; + + au[i]=t1*e1+t2*e2+t3*e3; + + } + } + break; + + default : printf("Problem of active set"); + break; + + } + } + i++; + + }else{ //Actif-Else + + k=irow[i]-1; + + if(islavactdof[k]>0){ + islavnodeentry = floor(islavactdof[k]/10.); + jrow= islavactdof[k]-10*islavnodeentry; + + if (jrow==1){ + e1=auc[i]; + jslavnodeentry=floor(islavactdof[j]/10.); + if (islavnodeentry!=jslavnodeentry){ + au[i]=0; + }else{ + jcol=islavactdof[j]-10*jslavnodeentry; + au[i]=slavnor[3*(islavnodeentry-1)+jcol-1]; + + } + } + else if (jrow==2){ + t1=slavtan[6*(islavnodeentry-1)]; + t2=slavtan[6*(islavnodeentry-1)+1]; + t3=slavtan[6*(islavnodeentry-1)+2]; + e2=auc[i]; + if((k+1)==j){e3=adc[j];}else{e3=auc[i+1];} + au[i]=t1*e1+t2*e2+t3*e3; + + } + else{ + t1=slavtan[6*(islavnodeentry-1)+3]; + t2=slavtan[6*(islavnodeentry-1)+4]; + t3=slavtan[6*(islavnodeentry-1)+5]; + + au[i]=t1*e1+t2*e2+t3*e3; + + } + + } + + i++; + + } + + } + } + + + /* changing b due to N and T (normal and tangential + direction at the slave surface */ + + for(k=0;k0){ + islavnodeentry = floor(islavactdof[k]/10.); + jrow= islavactdof[k]-10*islavnodeentry; + if (jrow==1){ + e1=bhat[k]; + b[k]=gap[islavnodeentry-1]; + // printf("jrow=1 %d %e\n",k,b[k]); + //printf("b,%d,%d,%f\n",k+1,jrow,ad[j]); + } + else if (jrow==2){ + t1=slavtan[6*(islavnodeentry-1)]; + t2=slavtan[6*(islavnodeentry-1)+1]; + t3=slavtan[6*(islavnodeentry-1)+2]; + e2=bhat[k]; + e3=bhat[k+1]; + b[k]=t1*e1+t2*e2+t3*e3; + // printf("jrow=2 %d %e\n",k,b[k]); + //printf("b,%d,%d,%f,%f,%f,%f,%f,%f,%f\n",k+1,jrow,t1,t2,t3,e1,e2,e3,au[i]); + } + else{ + t1=slavtan[6*(islavnodeentry-1)+3]; + t2=slavtan[6*(islavnodeentry-1)+4]; + t3=slavtan[6*(islavnodeentry-1)+5]; + // e3=b[k]; + b[k]=t1*e1+t2*e2+t3*e3; + // printf("jrow=3 %d %e\n",k,b[k]); + //printf("b,%d,%d,%f,%f,%f,%f,%f,%f,%f\n",k+1,jrow,t1,t2,t3,e1,e2,e3,au[i]); + } + } + } + + number=10; + + // FORTRAN(writematrix,(auc,adc,irowc,jqc,&neq[1],&number)); + + number=7; + + // FORTRAN(writematrix,(au,ad,irow,jq,&neq[1],&number)); + + printf("\n"); + number=8; + + // FORTRAN(writematrix,(au,bhat,irow,jq,&neq[1],&number)); + + + number=9; + +// FORTRAN(writematrix,(au,b,irow,jq,&neq[1],&number)); + + free(islavactdof); + + free(slavtan); + + /* So far every nonzero in Auc was stored; however, + Auc is symmetric. To reduce the computational effort + in subroutine contactstress Auc is now stored in + a symmetrical form, i.e. only half of the matrix + is stored */ + + auctemp=NNEW(double, *nzsc); + jqctemp=NNEW(int,neq[1]+1); + irowctemp=NNEW(int,*nzsc); + + k=0; + jqctemp[0]=1; + for (i=0;ii+1){ + auctemp[k]=auc[j]; + irowctemp[k++]=irowc[j]; + + } + } + jqctemp[i+1]=k+1; + + } + jqctemp[neq[1]]=k+1; + + *nzsc=k; + for(i=0;i<*nzsc;i++){ + auc[i]=auctemp[i]; + irowc[i]=irowctemp[i]; + } + + for(i=0;i-1;i--){ + if(icolc[i]>0){ + *nzlc=i+1; + break; + } + } + + *irowp = irow; *aup=au; *aucp=auc; *irowcp=irowc; *auqdtp=auqdt; + *irowqdtp=irowqdt; *aubdp=aubd; *irowbdp=irowbd; + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/contactpairs.f calculix-ccx-2.3/ccx_2.3/src/contactpairs.f --- calculix-ccx-2.1/ccx_2.3/src/contactpairs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/contactpairs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,163 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine contactpairs(inpc,textpart,tieset,cs,istep, + & istat,n,iline,ipol,inl,ipoinp,inp,ntie,ntie_, + & iperturb,matname,nmat,ipoinpc,tietol,set,nset) +! +! reading the input deck: *CONTACT PAIR +! + implicit none +! + logical surftosurf +! + character*1 inpc(*) + character*80 matname(*),material + character*81 tieset(3,*),noset,set(*) + character*132 textpart(16) +! + integer istep,istat,n,i,key,ipos,iline,ipol,inl,ipoinp(2,*), + & inp(3,*),ntie,ntie_,iperturb(2),nmat,ipoinpc(0:*),nset,j +! + real*8 cs(17,*),tietol(2,*),adjust +! +! tietol contains information on: +! - small (tietol<0) or large (tietol>0) sliding +! - the adjust value (only if dabs(tietol)>=2, +! adjust=dabs(tietol)-2 +! + if(istep.gt.0) then + write(*,*) '*ERROR in contactpairs: *CONTACT PAIR should' + write(*,*) ' be placed before all step definitions' + stop + endif +! + surftosurf=.false. +! + ntie=ntie+1 + if(ntie.gt.ntie_) then + write(*,*) '*ERROR in contactpairs: increase ntie_' + stop + endif + tietol(1,ntie)=1.d0 + do j=1,80 + tieset(1,ntie)(j:j)=' ' + enddo +! + do i=2,n + if(textpart(i)(1:12).eq.'INTERACTION=') then + material=textpart(i)(13:92) + elseif(textpart(i)(1:12).eq.'SMALLSLIDING') then + tietol(1,ntie)=-tietol(1,ntie) + elseif(textpart(i)(1:7).eq.'ADJUST=') then + read(textpart(i)(8:25),'(f20.0)',iostat=istat) adjust + if(istat.gt.0) then + noset(1:80)=textpart(i)(8:87) + noset(81:81)=' ' + ipos=index(noset,' ') + noset(ipos:ipos)='N' + do j=1,nset + if(set(j).eq.noset) exit + enddo + if(j.gt.nset) then + noset(ipos:ipos)=' ' + write(*,*) '*ERROR in contactpairs: adjust node set', + & noset + write(*,*) ' has not been defined' + call inputerror(inpc,ipoinpc,iline) + stop + endif + do j=1,ipos-1 + tieset(1,ntie)(j:j)=noset(j:j) + enddo + do j=ipos,80 + tieset(1,ntie)(j:j)=' ' + enddo + else + tietol(1,ntie)=dsign(1.d0,tietol(1,ntie))*(2.d0+adjust) + endif + elseif(textpart(i)(1:21).eq.'TYPE=SURFACETOSURFACE') then + surftosurf=.true. + else + write(*,*) + & '*WARNING in contactpairs: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! check for the existence of the surface interaction +! + do i=1,nmat + if(matname(i).eq.material) exit + enddo + if(i.gt.nmat) then + write(*,*) '*ERROR in contactpairs: nonexistent surface' + write(*,*) ' interaction; ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + tietol(2,ntie)=i+0.5d0 +! + tieset(1,ntie)(81:81)='C' +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*)'*ERROR in contactpairs: definition of the ' + write(*,*) ' contact pair is not complete.' + stop + endif +! +! +! storing the slave surface +! + if(surftosurf) then + tieset(2,ntie)(1:80)=textpart(1)(1:80) + tieset(2,ntie)(81:81)=' ' + ipos=index(tieset(2,ntie),' ') + tieset(2,ntie)(ipos:ipos)='T' + else + tieset(2,ntie)(1:80)=textpart(1)(1:80) + tieset(2,ntie)(81:81)=' ' + ipos=index(tieset(2,ntie),' ') + tieset(2,ntie)(ipos:ipos)='S' + endif +! + tieset(3,ntie)(1:80)=textpart(2)(1:80) + tieset(3,ntie)(81:81)=' ' + ipos=index(tieset(3,ntie),' ') + tieset(3,ntie)(ipos:ipos)='T' +! +! the definition of a contact pair triggers a geometrically +! nonlinear calculation +! + if(iperturb(1).eq.0) then + iperturb(1)=2 + endif + iperturb(2)=1 +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/contactprints.f calculix-ccx-2.3/ccx_2.3/src/contactprints.f --- calculix-ccx-2.1/ccx_2.3/src/contactprints.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/contactprints.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,156 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine contactprints(inpc,textpart, + & nprint,nprint_,jout,prlab,prset, + & contactprint_flag,ithermal,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,amname,nam,itpamp,idrct,ipoinpc,nener) +! +! reading the *CONTACT PRINT cards in the input deck +! + implicit none +! + logical contactprint_flag +! + character*1 total,nodesys,inpc(*) + character*6 prlab(*) + character*80 amname(*),timepointsname + character*81 prset(*),noset + character*132 textpart(16) +! + integer ii,i,nam,itpamp, + & jout(2),joutl,ithermal,nprint,nprint_,istep, + & istat,n,key,ipos,iline,ipol,inl,ipoinp(2,*),inp(3,*),idrct, + & ipoinpc(0:*),nener +! + if(istep.lt.1) then + write(*,*) '*ERROR in contactprints: *CONTACT PRINT + & should only be' + write(*,*) ' used within a *STEP definition' + stop + endif +! + nodesys='L' +! +! reset the nodal print requests (element print requests, if any, +! are kept) +! + if(.not.contactprint_flag) then + ii=0 + do i=1,nprint + if((prlab(i)(1:4).eq.'CSTR').or. + & (prlab(i)(1:4).eq.'CDIS').or. + & (prlab(i)(1:4).eq.'CELS')) cycle + ii=ii+1 + prlab(ii)=prlab(i) + prset(ii)=prset(i) + enddo + nprint=ii + endif +! +c jout=max(jout,1) + do ii=1,81 + noset(ii:ii)=' ' + enddo + total=' ' +! + do ii=2,n + if(textpart(ii)(1:10).eq.'FREQUENCY=') then + read(textpart(ii)(11:20),'(i10)',iostat=istat) joutl + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(joutl.eq.0) then + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol, + & inl,ipoinp,inp,ipoinpc) + if((key.eq.1).or.(istat.lt.0)) return + enddo + endif + if(joutl.gt.0) then + jout(1)=joutl + itpamp=0 + endif + elseif(textpart(ii)(1:10).eq.'TOTALS=YES') then + total='T' + elseif(textpart(ii)(1:11).eq.'TOTALS=ONLY') then + total='O' + elseif(textpart(ii)(1:11).eq.'TIMEPOINTS=') then + timepointsname=textpart(ii)(12:91) + do i=1,nam + if(amname(i).eq.timepointsname) then + itpamp=i + exit + endif + enddo + if(i.gt.nam) then + ipos=index(timepointsname,' ') + write(*,*) '*ERROR in contactprints: time points + & definition ' + & ,timepointsname(1:ipos-1),' is unknown or empty' + stop + endif + if(idrct.eq.1) then + write(*,*) '*ERROR in contactprints: the DIRECT option' + write(*,*) ' collides with a TIME POINTS ' + write(*,*) ' specification' + stop + endif + jout(1)=1 + jout(2)=1 + else + write(*,*) + & '*WARNING in contactprints: parameter not recognized:' + write(*,*) ' ', + & textpart(ii)(1:index(textpart(ii),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo + + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if(key.eq.1) exit + do ii=1,n + if((textpart(ii)(1:4).ne.'CSTR').and. + & (textpart(ii)(1:4).ne.'CELS').and. + & (textpart(ii)(1:4).ne.'CDIS')) then + write(*,*) '*WARNING in contactprints: label not + & applicable' + write(*,*) ' or unknown; ' + call inputwarning(inpc,ipoinpc,iline) + cycle + endif +! +! +! + if(textpart(ii)(1:4).eq.'CELS') nener=1 +! + nprint=nprint+1 + if(nprint.gt.nprint_) then + write(*,*) '*ERROR in contatcprints: increase nprint_' + stop + endif + prset(nprint)=noset + prlab(nprint)(1:4)=textpart(ii)(1:4) + prlab(nprint)(5:5)=total + prlab(nprint)(6:6)=nodesys + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/contactstress.c calculix-ccx-2.3/ccx_2.3/src/contactstress.c --- calculix-ccx-2.1/ccx_2.3/src/contactstress.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/contactstress.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,237 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +void contactstress(double *bhat, double *adc, double *auc,int *jqc, + int *irowc, int *neq, double *gap, double *bdd, double *b, int *islavact, + double *auqdt, int *irowqdt, int *jqqdt, int *ntie, int *nslavnode, + int *islavnode, double *slavnor, int *icolc, int *nzlc, int *nactdof, + int* iflagact,double* cstress, int *mi, double *cdisp, double *alm_old, + int *iit){ + + int i,j,idof1,idof2,idof3,nodes,mt=mi[1]+1,nacti=0,ninacti=0,nnogap=0, + max_node; + + double aux,stressnormal,stressnormal2,dispnormal,*unitmatrix=NULL, + constant=10000000000.E1,lamb_1,lamb_2,lamb_3, + *alm_new=NULL,max=0.0,lm_res,*delta_lm=NULL; + + clock_t debut; + clock_t fin; + + + /* determining the contact stress vectors and updating the active + and inactive sets and the Langrange Multipliers (LM) */ + + int number=11; + *iflagact=0; + + + debut = clock(); + FORTRAN(op,(&neq[1],&aux,b,cstress,adc,auc,icolc,irowc,nzlc)); + + alm_new=NNEW(double,neq[1]); // Contains the new current value of LM + delta_lm=NNEW(double,neq[1]); + + for (i=0;i<*ntie;i++){ + for(j=nslavnode[i];j-1E-10){ + nacti++; + if (islavact[j]!=1) {*iflagact = 1; + } + islavact[j]=1; + cdisp[6*j]=dispnormal; + cdisp[6*j+3]=stressnormal; + if (lm_res>max){ + max=lm_res; + max_node=nodes; + } + }else{ + if (islavact[j]!=0){ *iflagact = 1; + } + ninacti++; + islavact[j]=-1; + cstress[idof1]=0.; + cstress[idof2]=0.; + cstress[idof3]=0.; + alm_old[idof1]=0.; + alm_old[idof2]=0.; + alm_old[idof3]=0.; + alm_new[idof1]=0.; + alm_new[idof2]=0.; + alm_new[idof3]=0.; + cdisp[6*j]=0.; + cdisp[6*j+3]=0.; + } + }else{ + nnogap++; + cstress[idof1]=0.; + cstress[idof2]=0.; + cstress[idof3]=0.; + alm_old[idof1]=0.; + alm_old[idof2]=0.; + alm_old[idof3]=0.; + alm_new[idof1]=0.; + alm_new[idof2]=0.; + alm_new[idof3]=0.; + cdisp[6*j]=0.; + cdisp[6*j+3]=0.; + } + + }else{ //ACTIF and INACTIF remain the same just update datas of activ set + switch(islavact[j]){ + + case 0 : //Inactive + ninacti++; + islavact[j]=-1; + cstress[idof1]=0.; + cstress[idof2]=0.; + cstress[idof3]=0.; + alm_old[idof1]=0.; + alm_old[idof2]=0.; + alm_old[idof3]=0.; + cdisp[6*j]=0.; + cdisp[6*j+3]=0.; + break; + case 1 : //Active + { + nacti++; +// islavact[j]=1; + alm_old[idof1]=alm_new[idof1]; + alm_old[idof2]=alm_new[idof2]; + alm_old[idof3]=alm_new[idof3]; + cdisp[6*j]=dispnormal; + cdisp[6*j+3]=stressnormal; + if (lm_res>max){ + max=lm_res; + max_node=nodes; + } + break; + } + default : //No gap + { + nnogap++; + cstress[idof1]=0.; + cstress[idof2]=0.; + cstress[idof3]=0.; + alm_old[idof1]=0.; + alm_old[idof2]=0.; + alm_old[idof3]=0.; + cdisp[6*j]=0.; + cdisp[6*j+3]=0.; + break; + } + + } + + } + } + + } + + if((*iflagact==0)&&(*iit<=8)){ +// if((*iit<=8)){ + for (i=0;i<*ntie;i++){ + for(j=nslavnode[i];j0 s1,s2 ',s1,s2 +! + solreal(1)=(s1+s2)-a2/3.d0 + solreal(2)=-(s1+s2)/2.d0-a2/3.d0 + solreal(3)=solreal(2) +! + solimag(1)=0.d0 + solimag(2)=(s1-s2)*dsqrt(3.d0)/2.d0 + solimag(3)=-solimag(2) + else +! +! three real solutions +! + n=3 +! +! amplitude and phase of s1 +! + a=(r*r-d)**(1.d0/6.d0) + phi=(datan2(dsqrt(-d),r))/3.d0 +c phi=(datan(dsqrt(-d)/r))/3.d0 + write(30,*) 'd <=0 a,phi ',a,phi +! +! real and imaginary part of s1 +! + s1r=a*dcos(phi) + s1i=a*dsin(phi) + write(30,*) 'd >=0 s1r,s1i ',s1r,s1i +! + solreal(1)=2.d0*s1r-a2/3.d0 + solreal(2)=-s1r-a2/3.d0-s1i*dsqrt(3.d0) + solreal(3)=-s1r-a2/3.d0+s1i*dsqrt(3.d0) +! + solimag(1)=0.d0 + solimag(2)=0.d0 + solimag(3)=0.d0 + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cubtri.f calculix-ccx-2.3/ccx_2.3/src/cubtri.f --- calculix-ccx-2.1/ccx_2.3/src/cubtri.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cubtri.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,343 @@ +C ALGORITHM 584, COLLECTED ALGORITHMS FROM ACM. +C ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.8, NO. 2, +C JUN., 1982, P. 210. +C PROGRAM KONYN(OUTPUT,TAPE6=OUTPUT) + SUBROUTINE CUBTRI(F, T, EPS, MCALLS, ANS, ERR, NCALLS, W, NW, + * IDATA, RDATA, IER) +C +C ADAPTIVE CUBATURE OVER A TRIANGLE +C +C PARAMETERS +C F - USER SUPPLIED EXTERNAL FUNCTION OF THE FORM +C F(X,Y,IDATA,RDATA) +C WHERE X AND Y ARE THE CARTESIAN COORDINATES OF A +C POINT IN THE PLANE, AND IDATA AND RDATA ARE INTEGER +C AND REAL*8 VECTORS IN WHICH DATA MAY BE PASSED. +C T - ARRAY OF DIMENSION (2,3) WHERE T(1,J) AND T(2,J) +C ARE THE X AND Y COORDINATES OF THE J-TH VERTEX OF +C THE GIVEN TRIANGLE (INPUT) +C EPS - REQUIRED TOLERANCE (INPUT). IF THE COMPUTED +C INTEGRAL IS BETWEEN-1 AND 1, AN ABSOLUTE ERROR +C TEST IS USED, ELSE A RELATIVE ERROR TEST IS USED. +C MCALLS- MAXIMUM PERMITTED NUMBER OF CALLS TO F (INPUT) +C ANS - ESTIMATE FOR THE VALUE OF THE INTEGRAL OF F OVER +C THE GIVEN TRIANGLE (OUTPUT) +C ERR - ESTIMATED ABSOLUTE ERROR IN ANS (OUTPUT) +C NCALLS- ACTUAL NUMBER OF CALLS TO F (OUTPUT). THIS +C PARAMETER MUST BE INITIALIZED TO 0 ON THE FIRST +C CALL TO CUBTRI FOR A GIVEN INTEGRAL (INPUT) +C W - WORK SPACE. MAY NOT BE DESTROYED BETWEEN CALLS TO +C CUBTRI IF RESTARTING IS INTENDED +C NW - LENGTH OF WORK SPACE (INPUT). +C IF NW .GE. 3*(19+3*MCALLS)/38, TERMINATION DUE TO +C FULL WORK SPACE WILL NOT OCCUR. +C IER - TERMINATION INDICATOR (OUTPUT) +C IER=0 NORMAL TERMINATION, TOLERANCE SATISFIED +C IER=1 MAXIMUM NUMBER OF CALLS REACHED +C IER=2 WORK SPACE FULL +C IER=3 FURTHER SUBDIVISION OF TRIANGLES IMPOSSIBLE +C IER=4 NO FURTHER IMPROVEMENT IN ACCURACY IS +C POSSIBLE DUE TO ROUNDING ERRORS IN FUNCTION +C VALUES +C IER=5 NO FURTHER IMPROVEMENT IN ACCURACY IS +C POSSIBLE BECAUSE SUBDIVISION DOES NOT +C CHANGE THE ESTIMATED INTEGRAL. MACHINE +C ACCURACY HAS PROBABLY BEEN REACHED BUT +C THE ERROR ESTIMATE IS NOT SHARP ENOUGH. +C +C CUBTRI IS DESIGNED TO BE CALLED REPEATEDLY WITHOUT WASTING +C EARLIER WORK. THE PARAMETER NCALLS IS USED TO INDICATE TO +C CUBTRI AT WHAT POINT TO RESTART, AND MUST BE RE-INITIALIZED +C TO 0 WHEN A NEW INTEGRAL IS TO BE COMPUTED. AT LEAST ONE OF +C THE PARAMETERS EPS, MCALLS AND NW MUST BE CHANGED BETWEEN +C CALLS TO CUBTRI, ACCORDING TO THE RETURNED VALUE OF IER. NONE +C OF THE OTHER PARAMETERS MAY BE CHANGED IF RESTARTING IS DONE. +C IF IER=3 IS ENCOUNTERED, THERE PROBABLY IS A SINGULARITY +C SOMEWHERE IN THE REGION. THE ERROR MESSAGE INDICATES THAT +C FURTHER SUBDIVISION IS IMPOSSIBLE BECAUSE THE VERTICES OF THE +C SMALLER TRIANGLES PRODUCED WILL BEGIN TO COALESCE TO THE +C PRECISION OF THE COMPUTER. THIS SITUATION CAN USUALLY BE +C RELIEVED BY SPECIFYING THE REGION IN SUCH A WAY THAT THE +C SINGULARITY IS LOCATED AT THE THIRD VERTEX OF THE TRIANGLE. +C IF IER=4 IS ENCOUNTERED, THE VALUE OF THE INTEGRAL CANNOT BE +C IMPROVED ANY FURTHER. THE ONLY EXCEPTION TO THIS OCCURS WHEN A +C FUNCTION WITH HIGHLY IRREGULAR BEHAVIOUR IS INTEGRATED (E.G. +C FUNCTIONS WITH JUMP DISCONTINUITIES OR VERY HIGHLY OSCILLATORY +C FUNCTIONS). IN SUCH A CASE THE USER CAN DISABLE THE ROUNDING +C ERROR TEST BY REMOVING THE IF STATEMENT SHORTLY AFTER STATEMENT +C NUMBER 70. +C + implicit none + EXTERNAL F,rnderr + INTEGER IDATA(1), IER, MCALLS, NCALLS, NW,jkp,i,j,k,l,maxc,maxk, + & mw,nfe + REAL*8 ALFA, ANS, ANSKP, AREA, EPS, ERR, ERRMAX, H, Q1, Q2, R1,R2, + * RDATA(1), D(2,4), S(4), T(2,3), VEC(2,3), W(6,NW), X(2),zero, + & point5,one,rnderr +C ACTUAL DIMENSION OF W IS (6,NW/6) +C + REAL*8 TANS, TERR, DZERO + COMMON /CUBSTA/ TANS, TERR +C THIS COMMON IS REQUIRED TO PRESERVE TANS AND TERR BETWEEN CALLS +C AND TO SAVE VARIABLES IN FUNCTION RNDERR + DATA NFE /19/, S(1), S(2), S(3), S(4) /3*1E0,-1E0/, D(1,1), + * D(2,1) /0.0,0.0/, D(1,2), D(2,2) /0.0,1.0/, D(1,3), D(2,3) + * /1.0,0.0/, D(1,4), D(2,4) /1.0,1.0/ +C NFE IS THE NUMBER OF FUNCTION EVALUATIONS PER CALL TO CUBRUL. + DATA ZERO /0.E0/, ONE /1.E0/, DZERO /0.D0/, POINT5 /.5E0/ +C +C CALCULATE DIRECTION VECTORS, AREA AND MAXIMUM NUMBER +C OF SUBDIVISIONS THAT MAY BE PERFORMED + DO 20 I=1,2 + VEC(I,3) = T(I,3) + DO 10 J=1,2 + VEC(I,J) = T(I,J) - T(I,3) + 10 CONTINUE + 20 CONTINUE + MAXC = (MCALLS/NFE+3)/4 + IER = 1 + MAXK = MIN0(MAXC,(NW/6+2)/3) + IF (MAXC.GT.MAXK) IER = 2 + AREA = ABS(VEC(1,1)*VEC(2,2)-VEC(1,2)*VEC(2,1))*POINT5 + K = (NCALLS/NFE+3)/4 + MW = 3*(K-1) + 1 + IF (NCALLS.GT.0) GO TO 30 +C +C TEST FOR TRIVIAL CASES + TANS = DZERO + TERR = DZERO + IF (AREA.EQ.ZERO) GO TO 90 + IF (MCALLS.LT.NFE) GO TO 100 + IF (NW.LT.6) GO TO 110 +C +C INITIALIZE DATA LIST + K = 1 + MW = 1 + W(1,1) = ZERO + W(2,1) = ZERO + W(3,1) = ONE + CALL CUBRUL(F, VEC, W(1,1), IDATA, RDATA) + TANS = W(5,1) + TERR = W(6,1) + NCALLS = NFE +C +C TEST TERMINATION CRITERIA + 30 ANS = TANS + ERR = TERR + IF (ERR.LT.DMAX1(ONE,ABS(ANS))*EPS) GO TO 90 + IF (K.EQ.MAXK) GO TO 120 +C +C FIND TRIANGLE WITH LARGEST ERROR + ERRMAX = ZERO + DO 40 I=1,MW + IF (W(6,I).LE.ERRMAX) GO TO 40 + ERRMAX = W(6,I) + J = I + 40 CONTINUE +C +C SUBDIVIDE TRIANGLE INTO FOUR SUBTRIANGLES AND UPDATE DATA LIST + DO 50 I=1,2 + X(I) = W(I,J) + 50 CONTINUE + H = W(3,J)*POINT5 + IF (RNDERR(X(1),H,X(1),H).NE.ZERO) GO TO 130 + IF (RNDERR(X(2),H,X(2),H).NE.ZERO) GO TO 130 + ANSKP = (TANS) + TANS = TANS - (W(5,J)) + TERR = TERR - (W(6,J)) + R1 = W(4,J) + R2 = W(5,J) + JKP = J + Q1 = ZERO + Q2 = ZERO + DO 70 I=1,4 + DO 60 L=1,2 + W(L,J) = X(L) + H*D(L,I) + 60 CONTINUE + W(3,J) = H*S(I) + CALL CUBRUL(F, VEC, W(1,J), IDATA, RDATA) + Q2 = Q2 + W(5,J) + Q1 = Q1 + W(4,J) + J = MW + I + 70 CONTINUE + ALFA = 1E15 + IF (Q2.NE.R2) ALFA = ABS((Q1-R1)/(Q2-R2)-ONE) + J = JKP + DO 80 I=1,4 + W(6,J) = W(6,J)/ALFA + TANS = TANS + W(5,J) + TERR = TERR + W(6,J) + J = MW + I + 80 CONTINUE + MW = MW + 3 + NCALLS = NCALLS + 4*NFE + K = K + 1 +C +C IF ANSWER IS UNCHANGED, IT CANNOT BE IMPROVED + IF (ANSKP.EQ.(TANS)) GO TO 150 +C +C REMOVE THIS IF STATEMENT TO DISABLE ROUNDING ERROR TEST + IF (K.GT.3 .AND. ABS(Q2-R2).GT.ABS(Q1-R1)) GO TO 140 + GO TO 30 +C +C EXITS FROM SUBROUTINE + 90 IER = 0 + GO TO 120 + 100 IER = 1 + GO TO 120 + 110 IER = 2 + 120 ANS = TANS + ERR = TERR + RETURN + 130 IER = 3 + GO TO 120 + 140 IER = 4 + GO TO 120 + 150 IER = 5 + GO TO 120 + END + real*8 FUNCTION RNDERR(X, A, Y, B) +C THIS FUNCTION COMPUTES THE ROUNDING ERROR COMMITTED WHEN THE +C SUM X+A IS FORMED. IN THE CALLING PROGRAM, Y MUST BE THE SAME +C AS X AND B MUST BE THE SAME AS A. THEY ARE DECLARED AS +C DISTINCT VARIABLES IN THIS FUNCTION, AND THE INTERMEDIATE +C VARIABLES S AND T ARE PUT INTO COMMON, IN ORDER TO DEFEND +C AGAINST THE WELL-MEANING ACTIONS OF SOME OFFICIOUS OPTIMIZING +C FORTRAN COMPILERS. + implicit none + real*8 x,a,y,b,s,t + COMMON /CUBATB/ S, T + S = X + A + T = S - Y + RNDERR = T - B + RETURN + END + SUBROUTINE CUBRUL(F, VEC, P, IDATA, RDATA) +C +C BASIC CUBATURE RULE PAIR OVER A TRIANGLE +C +C PARAMETERS +C F - EXTERNAL FUNCTION - SEE COMMENTS TO CUBTRI +C VEC- MATRIX OF BASE VECTORS AND ORIGIN (INPUT) +C P - TRIANGLE DESCRIPTION VECTOR OF DIMENSION 6 +C P(1) - TRANSFORMED X COORDINATE OF ORIGIN VERTEX(INPUT) +C P(2) - TRANSFORMED Y COORDINATE OF ORIGIN VERTEX(INPUT) +C P(3) - DISTANCE OF OTHER VERTICES IN THE DIRECTIONS +C OF THE BASE VECTORS (INPUT) +C P(4) - LESS ACCURATE ESTIMATED INTEGRAL (OUTPUT) +C P(5) - MORE ACCURATE ESTIMATED INTEGRAL (OUTPUT) +C P(6) - ABS(P(5)-P(4)) (OUTPUT) +C +C CUBRUL EVALUATES A LINEAR COMBINATION OF BASIC INTEGRATION +C RULES HAVING D3 SYMMETRY. THE AREAL*8 COORDINATES PERTAINING TO +C THE J-TH RULE ARE STORED IN W(I,J),I=1,2,3. THE CORRESPONDING +C WEIGHTS ARE W(4,J) AND W(5,J), WITH W(5,J) BELONGING TO THE +C MORE ACCURATE FORMULA. IF W(1,J).EQ.W(2,J), THE INTEGRATION +C POINT IS THE CENTROID, ELSE IF W(2,J).EQ.W(3,J), THE EVALUATION +C POINTS ARE ON THE MEDIANS. IN BOTH CASES ADVANTAGE IS TAKEN OF +C SYMMETRY TO AVOID REPEATING FUNCTION EVALUATIONS. +C +C THE FOLLOWING REAL*8 VARIABLES ARE USED TO AVOID +C UNNECESSARY ROUNDING ERRORS IN FLOATING POINT ADDITION. +C THEY MAY BE DECLARED SINGLE PRECISION IF REAL*8 IS +C NOT AVAILABLE AND FULL ACCURACY IS NOT NEEDED. + implicit none + REAL*8 A1, A2, S, SN, DZERO, DONE, DTHREE, DSIX,f, + & point5,x,y + REAL*8 AREA, ORIGIN(2), P(6), RDATA(1), TVEC(2,3), VEC(2,3),W(5,6) + INTEGER IDATA(1),nquad,i,j,k +C +C W CONTAINS POINTS AND WEIGHTS OF THE INTEGRATION FORMULAE +C NQUAD - NUMBER OF BASIC RULES USED +C +C THIS PARTICULAR RULE IS THE 19 POINT EXTENSION (DEGREE 8) OF +C THE FAMILIAR 7 POINT RULE (DEGREE 5). +C +C SIGMA=SQRT(7) +C PHI=SQRT(15) +C W(1,1),W(2,1),W(3,1) = 1/3 +C W(4,1) = 9/40 +C W(5,1) = 7137/62720 - 45*SIGMA/1568 +C W(1,2) = 3/7 + 2*PHI/21 +C W(2,2),W(3,2) = 2/7 - PHI/21 +C W(4,2) = 31/80 - PHI/400 +C W(5,2) = - 9301697/4695040 - 13517313*PHI/23475200 +C + 764885*SIGMA/939008 + 198763*PHI*SIGMA/939008 +C W(*,3) = W(*,2) WITH PHI REPLACED BY -PHI +C W(1,5) = 4/9 + PHI/9 + SIGMA/9 - SIGMA*PHI/45 +C W(2,5),W(3,5) = 5/18 - PHI/18 - SIGMA/18 + SIGMA*PHI/90 +C W(4,5) = 0 +C W(5,5) = 102791225/59157504 + 23876225*PHI/59157504 +C - 34500875*SIGMA/59157504 - 9914825*PHI*SIGMA/59157504 +C W(*,4) = W(*,5) WITH PHI REPLACED BY -PHI +C W(1,6) = 4/9 + SIGMA/9 +C W(2,6) = W(2,4) +C W(3,6) = W(2,5) +C W(4,6) = 0 +C W(5,6) = 11075/8064 - 125*SIGMA/288 +C + DATA NQUAD /6/, W(1,1), W(2,1), W(3,1) /3*.33333333333333333333333 + * 33E0/, W(4,1), W(5,1) /.225E0,.3786109120031468330830822E-1/, + * W(1,2), W(2,2), W(3,2) /.7974269853530873223980253E0,2* + * .1012865073234563388009874E0/, W(4,2), W(5,2) + * /.3778175416344814577870518E0,.1128612762395489164329420E0/, + * W(1,3), W(2,3), W(3,3) /.5971587178976982045911758E-1,2* + * .4701420641051150897704412E0/, W(4,3), W(5,3) + * /.3971824583655185422129482E0,.2350720567323520126663380E0/ + DATA W(1,4), W(2,4), W(3,4) /.5357953464498992646629509E0,2* + * .2321023267750503676685246E0/, W(4,4), W(5,4) + * /0.E0,.3488144389708976891842461E0/, W(1,5), W(2,5), W(3,5) + * /.9410382782311208665596304E0,2*.2948086088443956672018481E-1/, + * W(4,5), W(5,5) /0.E0,.4033280212549620569433320E-1/, W(1,6), + * W(2,6), W(3,6) /.7384168123405100656112906E0, + * .2321023267750503676685246E0,.2948086088443956672018481E-1/, + * W(4,6), W(5,6) /0.E0,.2250583347313904927138324E0/ +C + DATA DZERO /0.D0/, DONE /1.D0/, DTHREE /3.D0/, DSIX /6.D0/, + * POINT5 /.5E0/ +C +C SCALE BASE VECTORS AND OBTAIN AREA + DO 20 I=1,2 + ORIGIN(I) = VEC(I,3) + P(1)*VEC(I,1) + P(2)*VEC(I,2) + DO 10 J=1,2 + TVEC(I,J) = P(3)*VEC(I,J) + 10 CONTINUE + 20 CONTINUE + AREA = POINT5*ABS(TVEC(1,1)*TVEC(2,2)-TVEC(1,2)*TVEC(2,1)) + A1 = DZERO + A2 = DZERO +C +C COMPUTE ESTIMATES FOR INTEGRAL AND ERROR + DO 40 K=1,NQUAD + X = ORIGIN(1) + W(1,K)*TVEC(1,1) + W(2,K)*TVEC(1,2) + Y = ORIGIN(2) + W(1,K)*TVEC(2,1) + W(2,K)*TVEC(2,2) + S = (F(X,Y,IDATA,RDATA)) + SN = DONE + IF (W(1,K).EQ.W(2,K)) GO TO 30 + X = ORIGIN(1) + W(2,K)*TVEC(1,1) + W(1,K)*TVEC(1,2) + Y = ORIGIN(2) + W(2,K)*TVEC(2,1) + W(1,K)*TVEC(2,2) + S = S + (F(X,Y,IDATA,RDATA)) + X = ORIGIN(1) + W(2,K)*TVEC(1,1) + W(3,K)*TVEC(1,2) + Y = ORIGIN(2) + W(2,K)*TVEC(2,1) + W(3,K)*TVEC(2,2) + S = S + (F(X,Y,IDATA,RDATA)) + SN = DTHREE + IF (W(2,K).EQ.W(3,K)) GO TO 30 + X = ORIGIN(1) + W(1,K)*TVEC(1,1) + W(3,K)*TVEC(1,2) + Y = ORIGIN(2) + W(1,K)*TVEC(2,1) + W(3,K)*TVEC(2,2) + S = S + (F(X,Y,IDATA,RDATA)) + X = ORIGIN(1) + W(3,K)*TVEC(1,1) + W(1,K)*TVEC(1,2) + Y = ORIGIN(2) + W(3,K)*TVEC(2,1) + W(1,K)*TVEC(2,2) + S = S + (F(X,Y,IDATA,RDATA)) + X = ORIGIN(1) + W(3,K)*TVEC(1,1) + W(2,K)*TVEC(1,2) + Y = ORIGIN(2) + W(3,K)*TVEC(2,1) + W(2,K)*TVEC(2,2) + S = S + (F(X,Y,IDATA,RDATA)) + SN = DSIX + 30 S = S/SN + A1 = A1 + W(4,K)*S + A2 = A2 + W(5,K)*S + 40 CONTINUE + P(4) = (A1)*AREA + P(5) = (A2)*AREA + P(6) = ABS(P(5)-P(4)) + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/cychards.f calculix-ccx-2.3/ccx_2.3/src/cychards.f --- calculix-ccx-2.1/ccx_2.3/src/cychards.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cychards.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,185 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cychards(inpc,textpart,nelcon,nmat,ntmat_, + & npmat_,plicon,nplicon,ncmat_,elcon,matname, + & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *CYCLIC HARDENING +! + implicit none +! + character*1 inpc(*) + character*80 matname(*) + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat_,ntmat,npmat_,npmat,istep, + & n,key,i,nplicon(0:ntmat_,*),istat,ncmat_,itemp,id,ipoinpc(0:*), + & ndata,ndatamax,kin,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*) +! + real*8 plicon(0:2*npmat_,ntmat_,*),temperature, + & elcon(0:ncmat_,ntmat_,*),plconloc(82),t1l +! + ntmat=0 + npmat=0 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in cychards: *CYCLIC HARDENING' + write(*,*) ' should be placed before all step' + write(*,*) ' definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in cychards: *CYCLIC HARDENING' + write(*,*) ' should be preceded' + write(*,*) ' by a *MATERIAL card' + stop + endif +! + if(((nelcon(1,nmat).ne.-51).and.(nelcon(1,nmat).ne.-114)).or. + & (nplicon(0,nmat).ne.0)) then + write(*,*) '*ERROR in cychards: *CYCLIC HARDENING' + write(*,*) ' should be preceded' + write(*,*) ' by an *PLASTIC,HARDENING=COMBINED card' + stop + endif +! + do i=2,n + write(*,*) + & '*WARNING in cychards: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + enddo +! +! isotropic hardening coefficients +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + read(textpart(3)(1:20),'(f20.0)',iostat=istat) temperature + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! +! first temperature +! + if(ntmat.eq.0) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in cychards: increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature +! +! new temperature +! + elseif(plicon(0,ntmat,nmat).ne.temperature) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in cychards: increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature + endif + do i=1,2 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & plicon(2*npmat+i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + npmat=npmat+1 + if(npmat.gt.npmat_) then + write(*,*) '*ERROR in cychards: increase npmat_' + stop + endif + nplicon(ntmat,nmat)=npmat + enddo +! + if(ntmat.eq.0) then + write(*,*) '*ERROR in cychards: *CYCLIC HARDENING card' + write(*,*) ' without data encountered' + stop + endif +! +! elastically anisotropic materials: recasting the input data +! in a format conform to the user routine umat_aniso_plas.f +! + if(nelcon(1,nmat).eq.-114) then +! +! isotropic hardening +! +! interpolating the plastic data at the elastic temperature +! data points +! + ndatamax=0 + do i=1,nelcon(2,nmat) + t1l=elcon(0,i,nmat) +! + if(nplicon(0,nmat).eq.1) then + id=-1 + else + call ident2(plicon(0,1,nmat),t1l,nplicon(0,nmat), + & 2*npmat_+1,id) + endif +! + if(nplicon(0,nmat).eq.0) then + continue + elseif((nplicon(0,nmat).eq.1).or.(id.eq.0).or. + & (id.eq.nplicon(0,nmat))) then + if(id.le.0) then + itemp=1 + else + itemp=id + endif + kin=0 + call plcopy(plicon,nplicon,plconloc,npmat_,ntmat_, + & nmat,itemp,i,kin) + if((id.eq.0).or.(id.eq.nplicon(0,nmat))) then + endif + else + kin=0 + call plmix(plicon,nplicon,plconloc,npmat_,ntmat_, + & nmat,id+1,t1l,i,kin) + endif +! + ndata=int(plconloc(81)) + if(ndata.eq.1) then + elcon(10,i,nmat)=plconloc(2) + elcon(11,i,nmat)=0.d0 + else + elcon(10,i,nmat)=plconloc(2) + elcon(11,i,nmat)=(plconloc(4)-plconloc(2))/ + & (plconloc(3)-plconloc(1)) + endif + ndatamax=max(ndata,ndatamax) + enddo + if(ndatamax.gt.2) then + write(*,*) '*WARNING in plastics: isotropic hardening' + write(*,*) ' curve is possibly nonlinear for' + write(*,*) ' the elastically anisotropic' + write(*,*) ' material ',matname(nmat)(71:80) + endif + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/cycsymmods.f calculix-ccx-2.3/ccx_2.3/src/cycsymmods.f --- calculix-ccx-2.1/ccx_2.3/src/cycsymmods.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/cycsymmods.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,536 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine cycsymmods(inpc,textpart,set,istartset,iendset, + & ialset,nset,tieset,tietol,co,nk,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,ikmpc,ilmpc,mpcfree,rcs,zcs,ics,nr,nz, + & rcs0,zcs0,ncs_,cs,labmpc,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,ntie,mcs,lprev,ithermal,rcscg,rcs0cg,zcscg, + & zcs0cg,nrcg,nzcg,jcs,kontri,straight,ne,ipkon,kon, + & lakon,lcs,ifacetet,inodface,ipoinpc,maxsectors, + & trab,ntrans,ntrans_,jobnamec,vold,cfd,mi) +! +! reading the input deck: *CYCLIC SYMMETRY MODEL +! +! several cyclic symmetry parts can be defined for one and the +! same model; for each part there must be a *CYCLIC SYMMETRY MODEL +! card +! +! cs(1,mcs): # segments in 360 degrees +! cs(2,mcs): minimum node diameter +! cs(3,mcs): maximum node diameter +! cs(4,mcs): # nodes on the independent side +! cs(5,mcs): # sectors to be plotted +! cs(6,mcs) up to cs(12,mcs): cyclic symmetry axis +! cs(13,mcs): number of the element set +! cs(14,mcs): sum of previous independent nodes +! cs(15,mcs): cos(angle); angle = 2*pi/cs(1,mcs) +! cs(16,mcs): sin(angle) +! cs(17,mcs): number of tie constraint +! + implicit none +! + logical triangulation,calcangle,nodesonaxis +! + character*1 inpc(*) + character*8 lakon(*) + character*20 labmpc(*) + character*80 tie + character*81 set(*),depset,indepset,tieset(3,*),elset + character*132 textpart(16),jobnamec(*) +! + integer istartset(*),iendset(*),ialset(*),ipompc(*),nodempc(3,*), + & nset,istep,istat,n,key,i,j,k,nk,nmpc,nmpc_,mpcfree,ics(*), + & nr(*),nz(*),jdep,jindep,l,noded,ikmpc(*),ilmpc(*),lcs(*), + & kflag,node,ncsnodes,ncs_,iline,ipol,inl,ipoinp(2,*),nneigh, + & inp(3,*),itie,iset,ipos,mcs,lprev,ntie,ithermal,ncounter, + & nrcg(*),nzcg(*),jcs(*),kontri(3,*),ne,ipkon(*),kon(*),nodei, + & ifacetet(*),inodface(*),ipoinpc(0:*),maxsectors, + & noden(2),ntrans,ntrans_,cfd,mi(2) +! + real*8 tolloc,co(3,*),coefmpc(*),rcs(*),zcs(*),rcs0(*),zcs0(*), + & csab(7),xn,yn,zn,dd,xap,yap,zap,tietol(2,*),cs(17,*),xsectors, + & gsectors,x3,y3,z3,phi,rcscg(*),rcs0cg(*),zcscg(*),zcs0cg(*), + & straight(9,*),x1,y1,z1,x2,y2,z2,zp,rp,dist,trab(7,*), + & vold(0:mi(2),*) +! + if(istep.gt.0) then + write(*,*) '*ERROR in cycsymmods: *CYCLIC SYMMETRY MODEL' + write(*,*) ' should be placed before all step definitions' + stop + endif +! + gsectors=1 + elset=' + & ' + tie=' + & ' + do i=2,n + if(textpart(i)(1:2).eq.'N=') then + read(textpart(i)(3:22),'(f20.0)',iostat=istat) xsectors + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:7).eq.'NGRAPH=') then + read(textpart(i)(8:27),'(f20.0)',iostat=istat) gsectors + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:4).eq.'TIE=') then + read(textpart(i)(5:84),'(a80)',iostat=istat) tie + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:6).eq.'ELSET=') then + read(textpart(i)(7:86),'(a80)',iostat=istat) elset + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + else + write(*,*) + & '*WARNING in cycsymmods: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(xsectors.le.0) then + write(*,*) '*ERROR in cycsymmods: the required parameter N' + write(*,*) ' is lacking on the *CYCLIC SYMMETRY MODEL' + write(*,*) ' keyword card or has a value <=0' + stop + endif + if(gsectors.lt.1) then + write(*,*) '*WARNING in cycsymmods: cannot plot less than' + write(*,*) ' one sector: one sector will be plotted' + gsectors=1 + endif + if(gsectors.gt.xsectors) then + write(*,*) '*WARNING in cycsymmods: cannot plot more than' + write(*,*) ' ',xsectors,'sectors;', + & xsectors,' sectors will' + write(*,*) ' be plotted' + gsectors=xsectors + endif +! + maxsectors=max(maxsectors,int(xsectors+0.5d0)) +! + mcs=mcs+1 + cs(2,mcs)=-0.5 + cs(3,mcs)=-0.5 + cs(14,mcs)=lprev+0.5 +! +! determining the tie constraint +! + itie=0 + do i=1,ntie + if((tieset(1,i)(1:80).eq.tie).and. + & (tieset(1,i)(81:81).ne.'C').and. + & (tieset(1,i)(81:81).ne.'T')) then + itie=i + exit + endif + enddo + if(itie.eq.0) then + if(ntie.eq.1) then + itie=1 + else + write(*,*) + & '*ERROR in cycsymmods: tie constraint is nonexistent' + call inputerror(inpc,ipoinpc,iline) + endif + endif +! + cs(1,mcs)=xsectors + cs(5,mcs)=gsectors+0.5 + cs(17,mcs)=itie+0.5 + depset=tieset(2,itie) + indepset=tieset(3,itie) + tolloc=tietol(1,itie) +! +! determining the element set +! + iset=0 + if(elset.eq.' ') then + write(*,*) '*INFO in cycsymmods: no element set given' + call inputinfo(inpc,ipoinpc,iline) + else + do i=1,nset + if(set(i).eq.elset) then + iset=i + exit + endif + enddo + if(iset.eq.0) then + write(*,*) '*ERROR in cycsymmods: element set does not' + write(*,*) ' exist; ' + call inputerror(inpc,ipoinpc,iline) + endif + endif + cs(13,mcs)=iset+0.5 +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + if((istat.lt.0).or.(key.eq.1)) then + write(*,*)'*ERROR in cycsymmods: definition of the cyclic' + write(*,*) ' symmetry model is not complete' + stop + endif +! + ntrans=ntrans+1 + if(ntrans.gt.ntrans_) then + write(*,*) '*ERROR in cycsymmods: increase ntrans_' + stop + endif +! + do i=1,6 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) csab(i) + trab(i,ntrans)=csab(i) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! +! cyclic coordinate system +! + csab(7)=-1.d0 +! +! marker for cyclic symmetry axis +! + trab(7,ntrans)=2 +! +c call writeset(nset,set,istartset,iendset,ialset) +! +! check whether depset and indepset exist +! + do i=1,nset + if(set(i).eq.depset) exit + enddo + if(i.gt.nset) then + write(*,*) '*ERROR in cycsymmods: surface ',depset + write(*,*) ' has not yet been defined.' + stop + endif + jdep=i +! + do i=1,nset + if(set(i).eq.indepset) exit + enddo + if(i.gt.nset) then + write(*,*) '*ERROR in cycsymmods: surface ',indepset + write(*,*) ' has not yet been defined.' + stop + endif + jindep=i +! +! unit vector along the rotation axis (xn,yn,zn) +! + xn=csab(4)-csab(1) + yn=csab(5)-csab(2) + zn=csab(6)-csab(3) + dd=dsqrt(xn*xn+yn*yn+zn*zn) + xn=xn/dd + yn=yn/dd + zn=zn/dd +! +! defining the indepset as a 2-D data field (axes: r=radial +! coordinate, z=axial coordinate): needed to allocate a node +! of the depset to a node of the indepset for the cyclic +! symmetry equations +! + l=0 + do j=istartset(jindep),iendset(jindep) + if(ialset(j).gt.0) then + l=l+1 + if(lprev+l.gt.ncs_) then + write(*,*) '*ERROR in cycsymmods: increase ncs_' + stop + endif + node =ialset(j) +! + xap=co(1,node)-csab(1) + yap=co(2,node)-csab(2) + zap=co(3,node)-csab(3) +! + ics(l)=node + zcs(l)=xap*xn+yap*yn+zap*zn + rcs(l)=dsqrt((xap-zcs(l)*xn)**2+ + & (yap-zcs(l)*yn)**2+ + & (zap-zcs(l)*zn)**2) + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + l=l+1 + if(l.gt.ncs_) then + write(*,*) '*ERROR in cycsymmods: increase ncs_' + stop + endif + node=k +! + xap=co(1,node)-csab(1) + yap=co(2,node)-csab(2) + zap=co(3,node)-csab(3) +! + ics(l)=node + zcs(l)=xap*xn+yap*yn+zap*zn + rcs(l)=dsqrt((xap-zcs(l)*xn)**2+ + & (yap-zcs(l)*yn)**2+ + & (zap-zcs(l)*zn)**2) + enddo + endif + enddo +! + ncsnodes=l +! +! initialization of near2d +! + do i=1,ncsnodes + nr(i)=i + nz(i)=i + rcs0(i)=rcs(i) + zcs0(i)=zcs(i) + enddo + kflag=2 + call dsort(rcs,nr,ncsnodes,kflag) + call dsort(zcs,nz,ncsnodes,kflag) +c write(*,*) 'independent side' +c do i=1,ncsnodes +c write(*,'(i5,1x,i5,3(1x,e11.4),1x,i5,1x,e11.4,1x,i5)') +c & i,ics(i),rcs0(i),zcs0(i),rcs(i),nr(i),zcs(i),nz(i) +c enddo +c write(*,*) +! +! check whether a tolerance was defined. If not, a tolerance +! is calculated as 0.5 % of the mean of the distance of every +! independent node to its nearest neighbour +! + if(tolloc.lt.1.d-30) then + nneigh=2 + dist=0.d0 + do i=1,ncsnodes + nodei=ics(i) +! + xap=co(1,nodei)-csab(1) + yap=co(2,nodei)-csab(2) + zap=co(3,nodei)-csab(3) +! + zp=xap*xn+yap*yn+zap*zn + rp=dsqrt((xap-zp*xn)**2+(yap-zp*yn)**2+(zap-zp*zn)**2) +! + call near2d(rcs0,zcs0,rcs,zcs,nr,nz,rp,zp,ncsnodes,noden, + & nneigh) +! + dist=dist+dsqrt((co(1,nodei)-co(1,noden(2)))**2+ + & (co(2,nodei)-co(2,noden(2)))**2+ + & (co(3,nodei)-co(3,noden(2)))**2) + enddo + tolloc=0.005d0*dist/ncsnodes + write(*,*) '*INFO in cycsymmods: no tolerance was defined' + write(*,*) ' in the *TIE option; a tolerance of ', + & tolloc + write(*,*) ' will be used' + write(*,*) + endif +! +! calculating the angle and check for nodes on the axis +! + calcangle=.false. + nodesonaxis=.false. +! + nneigh=1 + do i=istartset(jdep),iendset(jdep) + if(ialset(i).gt.0) then + if(i.gt.istartset(jdep)) then + if(ialset(i).eq.ialset(i-1)) cycle + endif + noded=ialset(i) +! + xap=co(1,noded)-csab(1) + yap=co(2,noded)-csab(2) + zap=co(3,noded)-csab(3) +! + zp=xap*xn+yap*yn+zap*zn + rp=dsqrt((xap-zp*xn)**2+(yap-zp*yn)**2+(zap-zp*zn)**2) +! + if((.not.calcangle).and.(rp.gt.1.d-10)) then + x2=(xap-zp*xn)/rp + y2=(yap-zp*yn)/rp + z2=(zap-zp*zn)/rp + endif +! + call near2d(rcs0,zcs0,rcs,zcs,nr,nz,rp,zp,ncsnodes,node, + & nneigh) +! + nodei=ics(node) + if(nodei.lt.0) cycle + if(nodei.eq.noded) then + ics(node)=-nodei + nodesonaxis=.true. + cycle + endif +! + xap=co(1,nodei)-csab(1) + yap=co(2,nodei)-csab(2) + zap=co(3,nodei)-csab(3) +! + zp=xap*xn+yap*yn+zap*zn + rp=dsqrt((xap-zp*xn)**2+(yap-zp*yn)**2+(zap-zp*zn)**2) +! + if((.not.calcangle).and.(rp.gt.1.d-10)) then + x3=(xap-zp*xn)/rp + y3=(yap-zp*yn)/rp + z3=(zap-zp*zn)/rp +! + x1=y2*z3-y3*z2 + y1=x3*z2-x2*z3 + z1=x2*y3-x3*y2 +! + phi=(x1*xn+y1*yn+z1*zn)/dabs(x1*xn+y1*yn+z1*zn)* + & 6.28318531d0/cs(1,mcs) + calcangle=.true. +c write(*,*) 'phi ',phi + endif +! + else + k=ialset(i-2) + do + k=k-ialset(i) + if(k.ge.ialset(i-1)) exit + noded=k +! + xap=co(1,noded)-csab(1) + yap=co(2,noded)-csab(2) + zap=co(3,noded)-csab(3) +! + zp=xap*xn+yap*yn+zap*zn + rp=dsqrt((xap-zp*xn)**2+(yap-zp*yn)**2+(zap-zp*zn)**2) +! + if((.not.calcangle).and.(rp.gt.1.d-10)) then + x2=(xap-zp*xn)/rp + y2=(yap-zp*yn)/rp + z2=(zap-zp*zn)/rp + endif +! + call near2d(rcs0,zcs0,rcs,zcs,nr,nz,rp,zp,ncsnodes,node, + & nneigh) +! + nodei=ics(node) + if(nodei.lt.0) cycle + if(nodei.eq.noded) then + ics(node)=-nodei + nodesonaxis=.true. + cycle + endif +! + xap=co(1,nodei)-csab(1) + yap=co(2,nodei)-csab(2) + zap=co(3,nodei)-csab(3) +! + zp=xap*xn+yap*yn+zap*zn + rp=dsqrt((xap-zp*xn)**2+(yap-zp*yn)**2+(zap-zp*zn)**2) +! + if((.not.calcangle).and.(rp.gt.1.d-10)) then + x3=(xap-zp*xn)/rp + y3=(yap-zp*yn)/rp + z3=(zap-zp*zn)/rp +! + x1=y2*z3-y3*z2 + y1=x3*z2-x2*z3 + z1=x2*y3-x3*y2 +! + phi=(x1*xn+y1*yn+z1*zn)/dabs(x1*xn+y1*yn+z1*zn)* + & 6.28318531d0/cs(1,mcs) + calcangle=.true. +c write(*,*) 'phi ',phi + endif +! + enddo + endif +! + enddo +! +! allocating a node of the depset to each node of the indepset +! + ncounter=0 + triangulation=.false. +! + do i=istartset(jdep),iendset(jdep) + if(ialset(i).gt.0) then + if(i.gt.istartset(jdep)) then + if(ialset(i).eq.ialset(i-1)) cycle + endif + noded=ialset(i) +! + call generatecycmpcs(tolloc,co,nk,ipompc,nodempc, + & coefmpc,nmpc,ikmpc,ilmpc,mpcfree,rcs,zcs,ics, + & nr,nz,rcs0,zcs0,labmpc, + & mcs,triangulation,csab,xn,yn,zn,phi,noded, + & ncsnodes,rcscg,rcs0cg,zcscg,zcs0cg,nrcg, + & nzcg,jcs,lcs,kontri,straight,ne,ipkon,kon,lakon, + & ifacetet,inodface,ncounter,jobnamec,vold,cfd,mi) +! + else + k=ialset(i-2) + do + k=k-ialset(i) + if(k.ge.ialset(i-1)) exit + noded=k +! + call generatecycmpcs(tolloc,co,nk,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,ikmpc,ilmpc,mpcfree,rcs,zcs,ics, + & nr,nz,rcs0,zcs0,ncs_,cs,labmpc,istep,istat,n, + & mcs,ithermal,triangulation,csab,xn,yn,zn,phi,noded, + & ncsnodes,rcscg,rcs0cg,zcscg,zcs0cg,nrcg, + & nzcg,jcs,lcs,kontri,straight,ne,ipkon,kon,lakon, + & ifacetet,inodface,ncounter,jobnamec,vold,cfd,mi) + enddo + endif +! + enddo +! + if(ncounter.ne.0) then + write(*,*) '*ERROR in cycsymmods: for at least one dependent' + write(*,*) ' node in a cyclic symmetry definition no ' + write(*,*) ' independent counterpart was found' + stop + endif +! +! sorting ics +! ics contains the master (independent) nodes +! + kflag=1 + call isortii(ics,nr,ncsnodes,kflag) + cs(4,mcs)=ncsnodes+0.5 + lprev=lprev+ncsnodes +! +! check orientation of (xn,yn,zn) (important for copying of base +! sector in arpackcs) +! + if(phi.lt.0.d0) then + csab(4)=2.d0*csab(1)-csab(4) + csab(5)=2.d0*csab(2)-csab(5) + csab(6)=2.d0*csab(3)-csab(6) + endif +! + do i=1,7 + cs(5+i,mcs)=csab(i) + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dashdamp.f calculix-ccx-2.3/ccx_2.3/src/dashdamp.f --- calculix-ccx-2.1/ccx_2.3/src/dashdamp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dashdamp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,109 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dashdamp(xl,elas,konl,voldl,s,imat,elcon,nelcon, + & ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc,plicon, + & nplicon,npmat_,iperturb,time,nmethod) +! +! calculates the damping coefficient of a dashpot +! + implicit none +! + character*8 lakonl +! + integer konl(20),i,j,imat,ncmat_,ntmat_,nope,iperturb,niso, + & kode,npmat_,nelcon(2,*),nplicon(0:ntmat_,*),nmethod,id +! + real*8 xl(3,9),elas(21),s(60,60),voldl(3,9),xn(3),dd, + & elcon(0:ncmat_,ntmat_,*),t0l,t1l,elconloc(21),damp, + & plicon(0:2*npmat_,ntmat_,*),plconloc(82),pl(3,9),time, + & xiso(20),yiso(20) +! +! original positions of the nodes belonging to the dashpot +! + if(iperturb.eq.0) then + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i) + enddo + enddo + else + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i)+voldl(j,i) + enddo + enddo + endif +! + dd=dsqrt((pl(1,2)-pl(1,1))**2 + & +(pl(2,2)-pl(2,1))**2 + & +(pl(3,2)-pl(3,1))**2) + do i=1,3 + xn(i)=(pl(i,2)-pl(i,1))/dd + enddo +! +! interpolating the material data +! + call materialdata_sp(elcon,nelcon,imat,ntmat_,i,t1l, + & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) +! +! calculating the damping force and damping coefficient +! + if(kode.eq.2) then + damp=elconloc(1) + else + if(nmethod.ne.5) then + write(*,*) '*ERROR in dashdamp: the damping coefficient' + write(*,*) ' may depend on temperature and frequency' + write(*,*) ' only; the latter is only allowed for' + write(*,*) ' steady state dynamics calculations' + stop + endif + niso=int(plconloc(81)) + do i=1,niso + xiso(i)=plconloc(2*i-1) + yiso(i)=plconloc(2*i) + enddo + call ident(xiso,time,niso,id) + if(id.eq.0) then + damp=yiso(1) + elseif(id.eq.niso) then + damp=yiso(niso) + else + damp=yiso(id)+(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id))* + & (time-xiso(id)) + endif + endif +c write(*,*) 'dashdamp ',time,damp +! + do i=1,3 + do j=1,3 + s(i,j)=damp*xn(i)*xn(j) + enddo + enddo + do i=1,3 + do j=1,3 + s(i+3,j)=-s(i,j) + s(i,j+3)=-s(i,j) + s(i+3,j+3)=s(i,j) + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dashforc.f calculix-ccx-2.3/ccx_2.3/src/dashforc.f --- calculix-ccx-2.1/ccx_2.3/src/dashforc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dashforc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,102 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dashforc(xl,konl,vl,imat,elcon,nelcon, + & elas,fn,ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc, + & plicon,nplicon,npmat_,vel,time,nmethod,mi) +! +! calculates the force of the dashpot +! + implicit none +! + character*8 lakonl +! + integer konl(20),i,j,imat,ncmat_,ntmat_,nope,nmethod, + & kode,nelcon(2,*),nplicon(0:ntmat_,*),npmat_,id,niso,mi(2) +! + real*8 xl(3,20),elas(21),t0l,t1l,vl(0:mi(2),20),plconloc(82), + & pl(0:3,9),xn(3),al,dd,fn(0:mi(2),*),vel(1:3,20),time, + & elcon(0:ncmat_,ntmat_,*),elconloc(21),xk,fk, + & plicon(0:2*npmat_,ntmat_,*),xiso(20),yiso(20) +! +! actual positions of the nodes belonging to the dashpot +! +c write(*,*) 'dashforc ',time + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i)+vl(j,i) + enddo + enddo +! + dd=dsqrt((pl(1,2)-pl(1,1))**2 + & +(pl(2,2)-pl(2,1))**2 + & +(pl(3,2)-pl(3,1))**2) + do i=1,3 + xn(i)=(pl(i,2)-pl(i,1))/dd + enddo +! + al=(vel(1,2)-vel(1,1))*xn(1)+ + & (vel(2,2)-vel(2,1))*xn(2)+ + & (vel(3,2)-vel(3,1))*xn(3) +! +! interpolating the material data +! + call materialdata_sp(elcon,nelcon,imat,ntmat_,i,t1l, + & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) +! +! calculating the dashpot force and the dashpot constant +! +c write(*,*) 'dashforc ',time + if(kode.eq.2)then + xk=elconloc(1) + fk=xk*al + else + if(nmethod.ne.5) then + write(*,*) '*ERROR in dashdamp: the damping coefficient' + write(*,*) ' may depend on temperature and frequency' + write(*,*) ' only; the latter is only allowed for' + write(*,*) ' steady state dynamics calculations' + stop + endif + niso=int(plconloc(81)) + do i=1,niso + xiso(i)=plconloc(2*i-1) + yiso(i)=plconloc(2*i) + enddo + call ident(xiso,time,niso,id) + if(id.eq.0) then + xk=yiso(1) + elseif(id.eq.niso) then + xk=yiso(niso) + else + xk=yiso(id)+(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) + & *(time-xiso(id)) + endif + fk=xk*al + endif +c write(*,*) 'dashforc ',time,xk +! + do i=1,3 + fn(i,konl(1))=-fk*xn(i) + fn(i,konl(2))=fk*xn(i) + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dashpots.f calculix-ccx-2.3/ccx_2.3/src/dashpots.f --- calculix-ccx-2.1/ccx_2.3/src/dashpots.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dashpots.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,204 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dashpots(inpc,textpart,nelcon,nmat,ntmat_,npmat_, + & plicon,nplicon, + & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,nmat_,set,istartset,iendset,ialset, + & nset,ielmat,ielorien,ipoinpc) +! +! reading the input deck: *DASHPOT +! + implicit none +! + logical frequency +! + character*1 inpc(*) + character*80 matname(*) + character*81 set(*),elset + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat_,ntmat,npmat_,npmat,istep, + & n,key,i,nplicon(0:ntmat_,*),ncmat_,istat,istartset(*), + & iendset(*),irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),nmat_, + & ialset(*),ipos,nset,j,k,ielmat(*),ielorien(*),ipoinpc(0:*) +! + real*8 plicon(0:2*npmat_,ntmat_,*),xfreq,temperature, + & elcon(0:ncmat_,ntmat_,*) +! + frequency=.false. +! + ntmat=0 + npmat=0 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in dashpots: *DASHPOT should be placed' + write(*,*) ' before all step definitions' + stop + endif +! + nmat=nmat+1 + if(nmat.gt.nmat_) then + write(*,*) '*ERROR in materials: increase nmat_' + stop + endif + matname(nmat)(1:7)='DASHPOT' + do i=8,80 + matname(nmat)(i:i)=' ' + enddo +! + do i=2,n + if(textpart(i)(1:6).eq.'ELSET=') then + elset=textpart(i)(7:86) + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + else + write(*,*) + & '*WARNING in dashpots: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! check for frequency dependency (for steady state dynamics +! calculations) +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + read(textpart(2)(1:20),'(f20.0)',iostat=istat) + & xfreq + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(xfreq.gt.0.d0) frequency=.true. + iline=iline-1 +! + if(.not.frequency) then + nelcon(1,nmat)=2 +! +! linear dashpot +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + ntmat=ntmat+1 + nelcon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in dashpots: increase ntmat_' + stop + endif + do i=1,2 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + if(textpart(3)(1:1).ne.' ') then + read(textpart(3)(1:20),'(f20.0)',iostat=istat) + & elcon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + elcon(0,ntmat,nmat)=0.d0 + endif + enddo + else + nelcon(1,nmat)=-51 +! +! kinematic hardening coefficients +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + read(textpart(3)(1:20),'(f20.0)',iostat=istat) temperature + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! +! first temperature +! + if(ntmat.eq.0) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in dashpots: increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature +! +! new temperature +! + elseif(plicon(0,ntmat,nmat).ne.temperature) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in dashpots: increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature + endif + do i=1,2 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & plicon(2*npmat+i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + npmat=npmat+1 + if(npmat.gt.npmat_) then + write(*,*) '*ERROR in dashpots: increase npmat_' + stop + endif + nplicon(ntmat,nmat)=npmat + enddo + endif +! + if(ntmat.eq.0) then + write(*,*) '*ERROR in dashpots: *DASHPOT card without data' + stop + endif + do i=1,nset + if(set(i).eq.elset) exit + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR in dashpots: element set ',elset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! +! assigning the elements of the set the appropriate material +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + ielmat(ialset(j))=nmat + ielorien(ialset(j))=0 + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + ielmat(k)=nmat + ielorien(k)=0 + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/date.pl calculix-ccx-2.3/ccx_2.3/src/date.pl --- calculix-ccx-2.1/ccx_2.3/src/date.pl 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/date.pl 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,14 @@ +#!/usr/bin/perl + +chomp($date=`date`); + +# inserting the date into ccx_2.3.c + +@ARGV="ccx_2.3.c"; +$^I=""; +while(<>){ + s/You are using an executable made on.*/You are using an executable made on $date\\n");/g; + print; +} + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/datest.f calculix-ccx-2.3/ccx_2.3/src/datest.f --- calculix-ccx-2.1/ccx_2.3/src/datest.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/datest.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,28 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine datest(au,jh,daval) + implicit real*8 (a-h,o-z) + real*8 au(jh) +c....test for rank + daval = 0.0d0 + do 100 j = 1,jh + daval=daval+abs(au(j)) + 100 continue + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/ddeabm.f calculix-ccx-2.3/ccx_2.3/src/ddeabm.f --- calculix-ccx-2.1/ccx_2.3/src/ddeabm.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ddeabm.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,4635 @@ +*DECK DDEABM + SUBROUTINE DDEABM (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, + + RWORK, LRW, IWORK, LIW, RPAR, IPAR) +C***BEGIN PROLOGUE DDEABM +C***PURPOSE Solve an initial value problem in ordinary differential +C equations using an Adams-Bashforth method. +C***LIBRARY SLATEC (DEPAC) +C***CATEGORY I1A1B +C***TYPE DOUBLE PRECISION (DEABM-S, DDEABM-D) +C***KEYWORDS ADAMS-BASHFORTH METHOD, DEPAC, INITIAL VALUE PROBLEMS, +C ODE, ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR +C***AUTHOR Shampine, L. F., (SNLA) +C Watts, H. A., (SNLA) +C***DESCRIPTION +C +C This is the Adams code in the package of differential equation +C solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. +C Design of the package was by L. F. Shampine and H. A. Watts. +C It is documented in +C SAND79-2374 , DEPAC - Design of a User Oriented Package of ODE +C Solvers. +C DDEABM is a driver for a modification of the code ODE written by +C L. F. Shampine and M. K. Gordon +C Sandia Laboratories +C Albuquerque, New Mexico 87185 +C +C ********************************************************************** +C * ABSTRACT * +C ************ +C +C Subroutine DDEABM uses the Adams-Bashforth-Moulton +C Predictor-Corrector formulas of orders one through twelve to +C integrate a system of NEQ first order ordinary differential +C equations of the form +C DU/DX = DF(X,U) +C when the vector Y(*) of initial values for U(*) at X=T is given. +C The subroutine integrates from T to TOUT. It is easy to continue the +C integration to get results at additional TOUT. This is the interval +C mode of operation. It is also easy for the routine to return with +C the solution at each intermediate step on the way to TOUT. This is +C the intermediate-output mode of operation. +C +C DDEABM uses subprograms DDES, DSTEPS, DINTP, DHSTRT, DHVNRM, +C D1MACH, and the error handling routine XERMSG. The only machine +C dependent parameters to be assigned appear in D1MACH. +C +C ********************************************************************** +C * Description of The Arguments To DDEABM (An Overview) * +C ********************************************************************** +C +C The Parameters are +C +C DF -- This is the name of a subroutine which you provide to +C define the differential equations. +C +C NEQ -- This is the number of (first order) differential +C equations to be integrated. +C +C T -- This is a DOUBLE PRECISION value of the independent +C variable. +C +C Y(*) -- This DOUBLE PRECISION array contains the solution +C components at T. +C +C TOUT -- This is a DOUBLE PRECISION point at which a solution is +C desired. +C +C INFO(*) -- The basic task of the code is to integrate the +C differential equations from T to TOUT and return an +C answer at TOUT. INFO(*) is an INTEGER array which is used +C to communicate exactly how you want this task to be +C carried out. +C +C RTOL, ATOL -- These DOUBLE PRECISION quantities represent +C relative and absolute error tolerances which you +C provide to indicate how accurately you wish the +C solution to be computed. You may choose them to be +C both scalars or else both vectors. +C +C IDID -- This scalar quantity is an indicator reporting what +C the code did. You must monitor this INTEGER variable to +C decide what action to take next. +C +C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of +C length LRW which provides the code with needed storage +C space. +C +C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW +C which provides the code with needed storage space and an +C across call flag. +C +C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and the DF subroutine. +C +C Quantities which are used as input items are +C NEQ, T, Y(*), TOUT, INFO(*), +C RTOL, ATOL, RWORK(1), LRW and LIW. +C +C Quantities which may be altered by the code are +C T, Y(*), INFO(1), RTOL, ATOL, +C IDID, RWORK(*) and IWORK(*). +C +C ********************************************************************** +C * INPUT -- What To Do On The First Call To DDEABM * +C ********************************************************************** +C +C The first call of the code is defined to be the start of each new +C problem. Read through the descriptions of all the following items, +C provide sufficient storage space for designated arrays, set +C appropriate variables for the initialization of the problem, and +C give information about how you want the problem to be solved. +C +C +C DF -- Provide a subroutine of the form +C DF(X,U,UPRIME,RPAR,IPAR) +C to define the system of first order differential equations +C which is to be solved. For the given values of X and the +C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must +C evaluate the NEQ components of the system of differential +C equations DU/DX=DF(X,U) and store the derivatives in the +C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for +C equations I=1,...,NEQ. +C +C Subroutine DF must NOT alter X or U(*). You must declare +C the name df in an external statement in your program that +C calls DDEABM. You must dimension U and UPRIME in DF. +C +C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and subroutine DF. They are not used or +C altered by DDEABM. If you do not need RPAR or IPAR, +C ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension them in +C your calling program and in DF as arrays of appropriate +C length. +C +C NEQ -- Set it to the number of differential equations. +C (NEQ .GE. 1) +C +C T -- Set it to the initial point of the integration. +C You must use a program variable for T because the code +C changes its value. +C +C Y(*) -- Set this vector to the initial values of the NEQ solution +C components at the initial point. You must dimension Y at +C least NEQ in your calling program. +C +C TOUT -- Set it to the first point at which a solution +C is desired. You can take TOUT = T, in which case the code +C will evaluate the derivative of the solution at T and +C return. Integration either forward in T (TOUT .GT. T) or +C backward in T (TOUT .LT. T) is permitted. +C +C The code advances the solution from T to TOUT using +C step sizes which are automatically selected so as to +C achieve the desired accuracy. If you wish, the code will +C return with the solution and its derivative following +C each intermediate step (intermediate-output mode) so that +C you can monitor them, but you still must provide TOUT in +C accord with the basic aim of the code. +C +C The first step taken by the code is a critical one +C because it must reflect how fast the solution changes near +C the initial point. The code automatically selects an +C initial step size which is practically always suitable for +C the problem. By using the fact that the code will not step +C past TOUT in the first step, you could, if necessary, +C restrict the length of the initial step size. +C +C For some problems it may not be permissible to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP. When you have declared a TSTOP point (see INFO(4) +C and RWORK(1)), you have told the code not to integrate +C past TSTOP. In this case any TOUT beyond TSTOP is invalid +C input. +C +C INFO(*) -- Use the INFO array to give the code more details about +C how you want your problem solved. This array should be +C dimensioned of length 15 to accommodate other members of +C DEPAC or possible future extensions, though DDEABM uses +C only the first four entries. You must respond to all of +C the following items which are arranged as questions. The +C simplest use of the code corresponds to answering all +C questions as YES ,i.e. setting ALL entries of INFO to 0. +C +C INFO(1) -- This parameter enables the code to initialize +C itself. You must set it to indicate the start of every +C new problem. +C +C **** Is this the first call for this problem ... +C YES -- set INFO(1) = 0 +C NO -- not applicable here. +C See below for continuation calls. **** +C +C INFO(2) -- How much accuracy you want of your solution +C is specified by the error tolerances RTOL and ATOL. +C The simplest use is to take them both to be scalars. +C To obtain more flexibility, they can both be vectors. +C The code must be told your choice. +C +C **** Are both error tolerances RTOL, ATOL scalars ... +C YES -- set INFO(2) = 0 +C and input scalars for both RTOL and ATOL +C NO -- set INFO(2) = 1 +C and input arrays for both RTOL and ATOL **** +C +C INFO(3) -- The code integrates from T in the direction +C of TOUT by steps. If you wish, it will return the +C computed solution and derivative at the next +C intermediate step (the intermediate-output mode) or +C TOUT, whichever comes first. This is a good way to +C proceed if you want to see the behavior of the solution. +C If you must have solutions at a great many specific +C TOUT points, this code will compute them efficiently. +C +C **** Do you want the solution only at +C TOUT (and not at the next intermediate step) ... +C YES -- set INFO(3) = 0 +C NO -- set INFO(3) = 1 **** +C +C INFO(4) -- To handle solutions at a great many specific +C values TOUT efficiently, this code may integrate past +C TOUT and interpolate to obtain the result at TOUT. +C Sometimes it is not possible to integrate beyond some +C point TSTOP because the equation changes there or it is +C not defined past TSTOP. Then you must tell the code +C not to go past. +C +C **** Can the integration be carried out without any +C Restrictions on the independent variable T ... +C YES -- set INFO(4)=0 +C NO -- set INFO(4)=1 +C and define the stopping point TSTOP by +C setting RWORK(1)=TSTOP **** +C +C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) +C error tolerances to tell the code how accurately you want +C the solution to be computed. They must be defined as +C program variables because the code may change them. You +C have two choices -- +C Both RTOL and ATOL are scalars. (INFO(2)=0) +C Both RTOL and ATOL are vectors. (INFO(2)=1) +C In either case all components must be non-negative. +C +C The tolerances are used by the code in a local error test +C at each step which requires roughly that +C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL +C for each vector component. +C (More specifically, a Euclidean norm is used to measure +C the size of vectors, and the error test uses the magnitude +C of the solution at the beginning of the step.) +C +C The true (global) error is the difference between the true +C solution of the initial value problem and the computed +C approximation. Practically all present day codes, +C including this one, control the local error at each step +C and do not even attempt to control the global error +C directly. Roughly speaking, they produce a solution Y(T) +C which satisfies the differential equations with a +C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , +C and, almost always, R(T) is bounded by the error +C tolerances. Usually, but not always, the true accuracy of +C the computed Y is comparable to the error tolerances. This +C code will usually, but not always, deliver a more accurate +C solution if you reduce the tolerances and integrate again. +C By comparing two such solutions you can get a fairly +C reliable idea of the true error in the solution at the +C bigger tolerances. +C +C Setting ATOL=0.D0 results in a pure relative error test on +C that component. Setting RTOL=0. results in a pure absolute +C error test on that component. A mixed test with non-zero +C RTOL and ATOL corresponds roughly to a relative error +C test when the solution component is much bigger than ATOL +C and to an absolute error test when the solution component +C is smaller than the threshold ATOL. +C +C Proper selection of the absolute error control parameters +C ATOL requires you to have some idea of the scale of the +C solution components. To acquire this information may mean +C that you will have to solve the problem more than once. In +C the absence of scale information, you should ask for some +C relative accuracy in all the components (by setting RTOL +C values non-zero) and perhaps impose extremely small +C absolute error tolerances to protect against the danger of +C a solution component becoming zero. +C +C The code will not attempt to compute a solution at an +C accuracy unreasonable for the machine being used. It will +C advise you if you ask for too much accuracy and inform +C you as to the maximum accuracy it believes possible. +C +C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length +C LRW in your calling program. +C +C RWORK(1) -- If you have set INFO(4)=0, you can ignore this +C optional input parameter. Otherwise you must define a +C stopping point TSTOP by setting RWORK(1) = TSTOP. +C (for some problems it may not be permissible to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP.) +C +C LRW -- Set it to the declared length of the RWORK array. +C You must have LRW .GE. 130+21*NEQ +C +C IWORK(*) -- Dimension this INTEGER work array of length LIW in +C your calling program. +C +C LIW -- Set it to the declared length of the IWORK array. +C You must have LIW .GE. 51 +C +C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and +C INTEGER type, respectively. You can use them for +C communication between your program that calls DDEABM and +C the DF subroutine. They are not used or altered by +C DDEABM. If you do not need RPAR or IPAR, ignore these +C parameters by treating them as dummy arguments. If you do +C choose to use them, dimension them in your calling program +C and in DF as arrays of appropriate length. +C +C ********************************************************************** +C * OUTPUT -- After Any Return From DDEABM * +C ********************************************************************** +C +C The principal aim of the code is to return a computed solution at +C TOUT, although it is also possible to obtain intermediate results +C along the way. To find out whether the code achieved its goal +C or if the integration process was interrupted before the task was +C completed, you must check the IDID parameter. +C +C +C T -- The solution was successfully advanced to the +C output value of T. +C +C Y(*) -- Contains the computed solution approximation at T. +C You may also be interested in the approximate derivative +C of the solution at T. It is contained in +C RWORK(21),...,RWORK(20+NEQ). +C +C IDID -- Reports what the code did +C +C *** Task Completed *** +C Reported by positive values of IDID +C +C IDID = 1 -- A step was successfully taken in the +C intermediate-output mode. The code has not +C yet reached TOUT. +C +C IDID = 2 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping exactly to TOUT. +C +C IDID = 3 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping past TOUT. +C Y(*) is obtained by interpolation. +C +C *** Task Interrupted *** +C Reported by negative values of IDID +C +C IDID = -1 -- A large amount of work has been expended. +C (500 steps attempted) +C +C IDID = -2 -- The error tolerances are too stringent. +C +C IDID = -3 -- The local error test cannot be satisfied +C because you specified a zero component in ATOL +C and the corresponding computed solution +C component is zero. Thus, a pure relative error +C test is impossible for this component. +C +C IDID = -4 -- The problem appears to be stiff. +C +C IDID = -5,-6,-7,..,-32 -- Not applicable for this code +C but used by other members of DEPAC or possible +C future extensions. +C +C *** Task Terminated *** +C Reported by the value of IDID=-33 +C +C IDID = -33 -- The code has encountered trouble from which +C it cannot recover. A message is printed +C explaining the trouble and control is returned +C to the calling program. For example, this occurs +C when invalid input is detected. +C +C RTOL, ATOL -- These quantities remain unchanged except when +C IDID = -2. In this case, the error tolerances have been +C increased by the code to values which are estimated to be +C appropriate for continuing the integration. However, the +C reported solution at T was obtained using the input values +C of RTOL and ATOL. +C +C RWORK, IWORK -- Contain information which is usually of no +C interest to the user but necessary for subsequent calls. +C However, you may find use for +C +C RWORK(11)--which contains the step size H to be +C attempted on the next step. +C +C RWORK(12)--if the tolerances have been increased by the +C code (IDID = -2) , they were multiplied by the +C value in RWORK(12). +C +C RWORK(13)--Which contains the current value of the +C independent variable, i.e. the farthest point +C integration has reached. This will be different +C from T only when interpolation has been +C performed (IDID=3). +C +C RWORK(20+I)--Which contains the approximate derivative +C of the solution component Y(I). In DDEABM, it +C is obtained by calling subroutine DF to +C evaluate the differential equation using T and +C Y(*) when IDID=1 or 2, and by interpolation +C when IDID=3. +C +C ********************************************************************** +C * INPUT -- What To Do To Continue The Integration * +C * (calls after the first) * +C ********************************************************************** +C +C This code is organized so that subsequent calls to continue the +C integration involve little (if any) additional effort on your +C part. You must monitor the IDID parameter in order to determine +C what to do next. +C +C Recalling that the principal task of the code is to integrate +C from T to TOUT (the interval mode), usually all you will need +C to do is specify a new TOUT upon reaching the current TOUT. +C +C Do not alter any quantity not specifically permitted below, +C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or +C the differential equation in subroutine DF. Any such alteration +C constitutes a new problem and must be treated as such, i.e. +C you must start afresh. +C +C You cannot change from vector to scalar error control or vice +C versa (INFO(2)) but you can change the size of the entries of +C RTOL, ATOL. Increasing a tolerance makes the equation easier +C to integrate. Decreasing a tolerance will make the equation +C harder to integrate and should generally be avoided. +C +C You can switch from the intermediate-output mode to the +C interval mode (INFO(3)) or vice versa at any time. +C +C If it has been necessary to prevent the integration from going +C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the +C code will not integrate to any TOUT beyond the currently +C specified TSTOP. Once TSTOP has been reached you must change +C the value of TSTOP or set INFO(4)=0. You may change INFO(4) +C or TSTOP at any time but you must supply the value of TSTOP in +C RWORK(1) whenever you set INFO(4)=1. +C +C The parameter INFO(1) is used by the code to indicate the +C beginning of a new problem and to indicate whether integration +C is to be continued. You must input the value INFO(1) = 0 +C when starting a new problem. You must input the value +C INFO(1) = 1 if you wish to continue after an interrupted task. +C Do not set INFO(1) = 0 on a continuation call unless you +C want the code to restart at the current T. +C +C *** Following A Completed Task *** +C If +C IDID = 1, call the code again to continue the integration +C another step in the direction of TOUT. +C +C IDID = 2 or 3, define a new TOUT and call the code again. +C TOUT must be different from T. You cannot change +C the direction of integration without restarting. +C +C *** Following An Interrupted Task *** +C To show the code that you realize the task was +C interrupted and that you want to continue, you +C must take appropriate action and reset INFO(1) = 1 +C If +C IDID = -1, the code has attempted 500 steps. +C If you want to continue, set INFO(1) = 1 and +C call the code again. An additional 500 steps +C will be allowed. +C +C IDID = -2, the error tolerances RTOL, ATOL have been +C increased to values the code estimates appropriate +C for continuing. You may want to change them +C yourself. If you are sure you want to continue +C with relaxed error tolerances, set INFO(1)=1 and +C call the code again. +C +C IDID = -3, a solution component is zero and you set the +C corresponding component of ATOL to zero. If you +C are sure you want to continue, you must first +C alter the error criterion to use positive values +C for those components of ATOL corresponding to zero +C solution components, then set INFO(1)=1 and call +C the code again. +C +C IDID = -4, the problem appears to be stiff. It is very +C inefficient to solve such problems with DDEABM. +C The code DDEBDF in DEPAC handles this task +C efficiently. If you are absolutely sure you want +C to continue with DDEABM, set INFO(1)=1 and call +C the code again. +C +C IDID = -5,-6,-7,..,-32 --- cannot occur with this code +C but used by other members of DEPAC or possible +C future extensions. +C +C *** Following A Terminated Task *** +C If +C IDID = -33, you cannot continue the solution of this +C problem. An attempt to do so will result in your +C run being terminated. +C +C ********************************************************************** +C *Long Description: +C +C ********************************************************************** +C * DEPAC Package Overview * +C ********************************************************************** +C +C .... You have a choice of three differential equation solvers from +C .... DEPAC. The following brief descriptions are meant to aid you in +C .... choosing the most appropriate code for your problem. +C +C .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of +C .... the three choices, both algorithmically and in the use of the +C .... code. DDERKF is primarily designed to solve non-stiff and +C .... mildly stiff differential equations when derivative evaluations +C .... are not expensive. It should generally not be used to get high +C .... accuracy results nor answers at a great many specific points. +C .... Because DDERKF has very low overhead costs, it will usually +C .... result in the least expensive integration when solving +C .... problems requiring a modest amount of accuracy and having +C .... equations that are not costly to evaluate. DDERKF attempts to +C .... discover when it is not suitable for the task posed. +C +C .... DDEABM is a variable order (one through twelve) Adams code. +C .... Its complexity lies somewhere between that of DDERKF and +C .... DDEBDF. DDEABM is primarily designed to solve non-stiff and +C .... mildly stiff differential equations when derivative evaluations +C .... are expensive, high accuracy results are needed or answers at +C .... many specific points are required. DDEABM attempts to discover +C .... when it is not suitable for the task posed. +C +C .... DDEBDF is a variable order (one through five) backward +C .... differentiation formula code. it is the most complicated of +C .... the three choices. DDEBDF is primarily designed to solve stiff +C .... differential equations at crude to moderate tolerances. +C .... If the problem is very stiff at all, DDERKF and DDEABM will be +C .... quite inefficient compared to DDEBDF. However, DDEBDF will be +C .... inefficient compared to DDERKF and DDEABM on non-stiff problems +C .... because it uses much more storage, has a much larger overhead, +C .... and the low order formulas will not give high accuracies +C .... efficiently. +C +C .... The concept of stiffness cannot be described in a few words. +C .... If you do not know the problem to be stiff, try either DDERKF +C .... or DDEABM. Both of these codes will inform you of stiffness +C .... when the cost of solving such problems becomes important. +C +C ********************************************************************* +C +C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user +C oriented package of ODE solvers, Report SAND79-2374, +C Sandia Laboratories, 1979. +C***ROUTINES CALLED DDES, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891006 Cosmetic changes to prologue. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891024 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900510 Convert XERRWV calls to XERMSG calls. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DDEABM +C + INTEGER IALPHA, IBETA, IDELSN, IDID, IFOURU, IG, IHOLD, + 1 INFO, IP, IPAR, IPHI, IPSI, ISIG, ITOLD, ITSTAR, ITWOU, + 2 IV, IW, IWORK, IWT, IYP, IYPOUT, IYY, LIW, LRW, NEQ + DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y + LOGICAL START,PHASE1,NORND,STIFF,INTOUT +C + DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), + 1 RPAR(*),IPAR(*) +C + CHARACTER*8 XERN1 + CHARACTER*16 XERN3 +C + EXTERNAL DF +C +C CHECK FOR AN APPARENT INFINITE LOOP +C +C***FIRST EXECUTABLE STATEMENT DDEABM + IF ( INFO(1) .EQ. 0 ) IWORK(LIW) = 0 + IF (IWORK(LIW) .GE. 5) THEN + IF (T .EQ. RWORK(21 + NEQ)) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DDEABM', + * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // + * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // + * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // + * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // + * 'CODE, PARTICULARLY INFO(1).', 13, 2) + RETURN + ENDIF + ENDIF +C +C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION +C + IDID=0 + IF (LRW .LT. 130+21*NEQ) THEN + WRITE (XERN1, '(I8)') LRW + CALL XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE RWORK ' // + * 'ARRAY MUST BE AT LEAST 130 + 21*NEQ.$$' // + * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) + IDID=-33 + ENDIF +C + IF (LIW .LT. 51) THEN + WRITE (XERN1, '(I8)') LIW + CALL XERMSG ('SLATEC', 'DDEABM', 'THE LENGTH OF THE IWORK ' // + * 'ARRAY MUST BE AT LEAST 51.$$YOU HAVE CALLED THE CODE ' // + * 'WITH LIW = ' // XERN1, 2, 1) + IDID=-33 + ENDIF +C +C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK ARRAY +C + IYPOUT = 21 + ITSTAR = NEQ + 21 + IYP = 1 + ITSTAR + IYY = NEQ + IYP + IWT = NEQ + IYY + IP = NEQ + IWT + IPHI = NEQ + IP + IALPHA = (NEQ*16) + IPHI + IBETA = 12 + IALPHA + IPSI = 12 + IBETA + IV = 12 + IPSI + IW = 12 + IV + ISIG = 12 + IW + IG = 13 + ISIG + IGI = 13 + IG + IXOLD = 11 + IGI + IHOLD = 1 + IXOLD + ITOLD = 1 + IHOLD + IDELSN = 1 + ITOLD + ITWOU = 1 + IDELSN + IFOURU = 1 + ITWOU +C + RWORK(ITSTAR) = T + IF (INFO(1) .EQ. 0) GO TO 50 + START = IWORK(21) .NE. (-1) + PHASE1 = IWORK(22) .NE. (-1) + NORND = IWORK(23) .NE. (-1) + STIFF = IWORK(24) .NE. (-1) + INTOUT = IWORK(25) .NE. (-1) +C + 50 CALL DDES(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(IYPOUT), + 1 RWORK(IYP),RWORK(IYY),RWORK(IWT),RWORK(IP),RWORK(IPHI), + 2 RWORK(IALPHA),RWORK(IBETA),RWORK(IPSI),RWORK(IV), + 3 RWORK(IW),RWORK(ISIG),RWORK(IG),RWORK(IGI),RWORK(11), + 4 RWORK(12),RWORK(13),RWORK(IXOLD),RWORK(IHOLD), + 5 RWORK(ITOLD),RWORK(IDELSN),RWORK(1),RWORK(ITWOU), + 5 RWORK(IFOURU),START,PHASE1,NORND,STIFF,INTOUT,IWORK(26), + 6 IWORK(27),IWORK(28),IWORK(29),IWORK(30),IWORK(31), + 7 IWORK(32),IWORK(33),IWORK(34),IWORK(35),IWORK(45), + 8 RPAR,IPAR) +C + IWORK(21) = -1 + IF (START) IWORK(21) = 1 + IWORK(22) = -1 + IF (PHASE1) IWORK(22) = 1 + IWORK(23) = -1 + IF (NORND) IWORK(23) = 1 + IWORK(24) = -1 + IF (STIFF) IWORK(24) = 1 + IWORK(25) = -1 + IF (INTOUT) IWORK(25) = 1 +C + IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 + IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 +C + RETURN + END +*DECK DDES + SUBROUTINE DDES (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, + + YPOUT, YP, YY, WT, P, PHI, ALPHA, BETA, PSI, V, W, SIG, G, GI, + + H, EPS, X, XOLD, HOLD, TOLD, DELSGN, TSTOP, TWOU, FOURU, START, + + PHASE1, NORND, STIFF, INTOUT, NS, KORD, KOLD, INIT, KSTEPS, + + KLE4, IQUIT, KPREV, IVC, IV, KGI, RPAR, IPAR) +C***BEGIN PROLOGUE DDES +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEABM +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (DES-S, DDES-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DDEABM merely allocates storage for DDES to relieve the user of the +C inconvenience of a long call list. Consequently DDES is used as +C described in the comments for DDEABM . +C +C***SEE ALSO DDEABM +C***ROUTINES CALLED D1MACH, DINTP, DSTEPS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900510 Convert XERRWV calls to XERMSG calls, cvt GOTOs to +C IF-THEN-ELSE. (RWC) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DDES +C + INTEGER IDID, INFO, INIT, IPAR, IQUIT, IV, IVC, K, KGI, KLE4, + 1 KOLD, KORD, KPREV, KSTEPS, L, LTOL, MAXNUM, NATOLP, NEQ, + 2 NRTOLP, NS + DOUBLE PRECISION A, ABSDEL, ALPHA, ATOL, BETA, D1MACH, + 1 DEL, DELSGN, DT, EPS, FOURU, G, GI, H, + 2 HA, HOLD, P, PHI, PSI, RPAR, RTOL, SIG, T, TOLD, TOUT, + 3 TSTOP, TWOU, U, V, W, WT, X, XOLD, Y, YP, YPOUT, YY + LOGICAL STIFF,CRASH,START,PHASE1,NORND,INTOUT +C + DIMENSION Y(*),YY(*),WT(*),PHI(NEQ,16),P(*),YP(*), + 1 YPOUT(*),PSI(12),ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13), + 2 GI(11),IV(10),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) + CHARACTER*8 XERN1 + CHARACTER*16 XERN3, XERN4 +C + EXTERNAL DF +C +C....................................................................... +C +C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE +C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE COUNTER +C IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE EXCESSIVE +C WORK. +C + SAVE MAXNUM + DATA MAXNUM/500/ +C +C....................................................................... +C +C***FIRST EXECUTABLE STATEMENT DDES + IF (INFO(1) .EQ. 0) THEN +C +C ON THE FIRST CALL , PERFORM INITIALIZATION -- +C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE +C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE +C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. +C + U=D1MACH(4) +C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS + TWOU=2.D0*U + FOURU=4.D0*U +C -- SET TERMINATION FLAG + IQUIT=0 +C -- SET INITIALIZATION INDICATOR + INIT=0 +C -- SET COUNTER FOR ATTEMPTED STEPS + KSTEPS=0 +C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT + INTOUT= .FALSE. +C -- SET INDICATOR FOR STIFFNESS DETECTION + STIFF= .FALSE. +C -- SET STEP COUNTER FOR STIFFNESS DETECTION + KLE4=0 +C -- SET INDICATORS FOR STEPS CODE + START= .TRUE. + PHASE1= .TRUE. + NORND= .TRUE. +C -- RESET INFO(1) FOR SUBSEQUENT CALLS + INFO(1)=1 + ENDIF +C +C....................................................................... +C +C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY +C + IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(1) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(1) MUST BE ' // + * 'SET TO 0 FOR THE START OF A NEW PROBLEM, AND MUST BE ' // + * 'SET TO 1 FOLLOWING AN INTERRUPTED TASK. YOU ARE ' // + * 'ATTEMPTING TO CONTINUE THE INTEGRATION ILLEGALLY BY ' // + * 'CALLING THE CODE WITH INFO(1) = ' // XERN1, 3, 1) + IDID=-33 + ENDIF +C + IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(2) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(2) MUST BE ' // + * '0 OR 1 INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // + * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // + * XERN1, 4, 1) + IDID=-33 + ENDIF +C + IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(3) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(3) MUST BE ' // + * '0 OR 1 INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT ' // + * 'MODE OF INTEGRATION, RESPECTIVELY. YOU HAVE CALLED ' // + * 'THE CODE WITH INFO(3) = ' // XERN1, 5, 1) + IDID=-33 + ENDIF +C + IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(4) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INFO(4) MUST BE ' // + * '0 OR 1 INDICATING WHETHER OR NOT THE INTEGRATION ' // + * 'INTERVAL IS TO BE RESTRICTED BY A POINT TSTOP. YOU ' // + * 'HAVE CALLED THE CODE WITH INFO(4) = ' // XERN1, 14, 1) + IDID=-33 + ENDIF +C + IF (NEQ .LT. 1) THEN + WRITE (XERN1, '(I8)') NEQ + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE NUMBER OF ' // + * 'EQUATIONS NEQ MUST BE A POSITIVE INTEGER. YOU HAVE ' // + * 'CALLED THE CODE WITH NEQ = ' // XERN1, 6, 1) + IDID=-33 + ENDIF +C + NRTOLP = 0 + NATOLP = 0 + DO 90 K=1,NEQ + IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') RTOL(K) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE RELATIVE ' // + * 'ERROR TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU ' // + * 'HAVE CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // + * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // + * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) + IDID = -33 + NRTOLP = 1 + ENDIF +C + IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') ATOL(K) + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, THE ABSOLUTE ' // + * 'ERROR TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU ' // + * 'HAVE CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // + * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // + * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) + IDID = -33 + NATOLP = 1 + ENDIF +C + IF (INFO(2) .EQ. 0) GO TO 100 + IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 100 + 90 CONTINUE +C + 100 IF (INFO(4) .EQ. 1) THEN + IF (SIGN(1.D0,TOUT-T) .NE. SIGN(1.D0,TSTOP-T) + 1 .OR. ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN + WRITE (XERN3, '(1PE15.6)') TOUT + WRITE (XERN4, '(1PE15.6)') TSTOP + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // + * 'CALLED THE CODE WITH TOUT = ' // XERN3 // ' BUT ' // + * 'YOU HAVE ALSO TOLD THE CODE (INFO(4) = 1) NOT TO ' // + * 'INTEGRATE PAST THE POINT TSTOP = ' // XERN4 // + * ' THESE INSTRUCTIONS CONFLICT.', 14, 1) + IDID=-33 + ENDIF + ENDIF +C +C CHECK SOME CONTINUATION POSSIBILITIES +C + IF (INIT .NE. 0) THEN + IF (T .EQ. TOUT) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // + * 'CALLED THE CODE WITH T = TOUT = ' // XERN3 // + * '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 9, 1) + IDID=-33 + ENDIF +C + IF (T .NE. TOLD) THEN + WRITE (XERN3, '(1PE15.6)') TOLD + WRITE (XERN4, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, YOU HAVE ' // + * 'CHANGED THE VALUE OF T FROM ' // XERN3 // ' TO ' // + * XERN4 //' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', + * 10, 1) + IDID=-33 + ENDIF +C + IF (INIT .NE. 1) THEN + IF (DELSGN*(TOUT-T) .LT. 0.D0) THEN + WRITE (XERN3, '(1PE15.6)') TOUT + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, BY ' // + * 'CALLING THE CODE WITH TOUT = ' // XERN3 // + * ' YOU ARE ATTEMPTING TO CHANGE THE DIRECTION OF ' // + * 'INTEGRATION.$$THIS IS NOT ALLOWED WITHOUT ' // + * 'RESTARTING.', 11, 1) + IDID=-33 + ENDIF + ENDIF + ENDIF +C +C INVALID INPUT DETECTED +C + IF (IDID .EQ. (-33)) THEN + IF (IQUIT .NE. (-33)) THEN + IQUIT = -33 + INFO(1) = -1 + ELSE + CALL XERMSG ('SLATEC', 'DDES', 'IN DDEABM, INVALID ' // + * 'INPUT WAS DETECTED ON SUCCESSIVE ENTRIES. IT IS ' // + * 'IMPOSSIBLE TO PROCEED BECAUSE YOU HAVE NOT ' // + * 'CORRECTED THE PROBLEM, SO EXECUTION IS BEING ' // + * 'TERMINATED.', 12, 2) + ENDIF + RETURN + ENDIF +C +C....................................................................... +C +C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED AS +C ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS CASE, +C THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE SMALLEST VALUE +C FOURU WHICH IS LIKELY TO BE REASONABLE FOR THIS METHOD AND MACHINE +C + DO 180 K=1,NEQ + IF (RTOL(K)+ATOL(K) .GT. 0.D0) GO TO 170 + RTOL(K)=FOURU + IDID=-2 + 170 IF (INFO(2) .EQ. 0) GO TO 190 + 180 CONTINUE +C + 190 IF (IDID .NE. (-2)) GO TO 200 +C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A +C SMALL POSITIVE VALUE + INFO(1)=-1 + RETURN +C +C BRANCH ON STATUS OF INITIALIZATION INDICATOR +C INIT=0 MEANS INITIAL DERIVATIVES AND NOMINAL STEP SIZE +C AND DIRECTION NOT YET SET +C INIT=1 MEANS NOMINAL STEP SIZE AND DIRECTION NOT YET SET +C INIT=2 MEANS NO FURTHER INITIALIZATION REQUIRED +C + 200 IF (INIT .EQ. 0) GO TO 210 + IF (INIT .EQ. 1) GO TO 220 + GO TO 240 +C +C....................................................................... +C +C MORE INITIALIZATION -- +C -- EVALUATE INITIAL DERIVATIVES +C + 210 INIT=1 + A=T + CALL DF(A,Y,YP,RPAR,IPAR) + IF (T .NE. TOUT) GO TO 220 + IDID=2 + DO 215 L = 1,NEQ + 215 YPOUT(L) = YP(L) + TOLD=T + RETURN +C +C -- SET INDEPENDENT AND DEPENDENT VARIABLES +C X AND YY(*) FOR STEPS +C -- SET SIGN OF INTEGRATION DIRECTION +C -- INITIALIZE THE STEP SIZE +C + 220 INIT = 2 + X = T + DO 230 L = 1,NEQ + 230 YY(L) = Y(L) + DELSGN = SIGN(1.0D0,TOUT-T) + H = SIGN(MAX(FOURU*ABS(X),ABS(TOUT-X)),TOUT-X) +C +C....................................................................... +C +C ON EACH CALL SET INFORMATION WHICH DETERMINES THE ALLOWED INTERVAL +C OF INTEGRATION BEFORE RETURNING WITH AN ANSWER AT TOUT +C + 240 DEL = TOUT - T + ABSDEL = ABS(DEL) +C +C....................................................................... +C +C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND RETURN +C + 250 IF(ABS(X-T) .LT. ABSDEL) GO TO 260 + CALL DINTP(X,YY,TOUT,Y,YPOUT,NEQ,KOLD,PHI,IVC,IV,KGI,GI, + 1 ALPHA,G,W,XOLD,P) + IDID = 3 + IF (X .NE. TOUT) GO TO 255 + IDID = 2 + INTOUT = .FALSE. + 255 T = TOUT + TOLD = T + RETURN +C +C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY CLOSE, +C EXTRAPOLATE AND RETURN +C + 260 IF (INFO(4) .NE. 1) GO TO 280 + IF (ABS(TSTOP-X) .GE. FOURU*ABS(X)) GO TO 280 + DT = TOUT - X + DO 270 L = 1,NEQ + 270 Y(L) = YY(L) + DT*YP(L) + CALL DF(TOUT,Y,YPOUT,RPAR,IPAR) + IDID = 3 + T = TOUT + TOLD = T + RETURN +C + 280 IF (INFO(3) .EQ. 0 .OR. .NOT.INTOUT) GO TO 300 +C +C INTERMEDIATE-OUTPUT MODE +C + IDID = 1 + DO 290 L = 1,NEQ + Y(L)=YY(L) + 290 YPOUT(L) = YP(L) + T = X + TOLD = T + INTOUT = .FALSE. + RETURN +C +C....................................................................... +C +C MONITOR NUMBER OF STEPS ATTEMPTED +C + 300 IF (KSTEPS .LE. MAXNUM) GO TO 330 +C +C A SIGNIFICANT AMOUNT OF WORK HAS BEEN EXPENDED + IDID=-1 + KSTEPS=0 + IF (.NOT. STIFF) GO TO 310 +C +C PROBLEM APPEARS TO BE STIFF + IDID=-4 + STIFF= .FALSE. + KLE4=0 +C + 310 DO 320 L = 1,NEQ + Y(L) = YY(L) + 320 YPOUT(L) = YP(L) + T = X + TOLD = T + INFO(1) = -1 + INTOUT = .FALSE. + RETURN +C +C....................................................................... +C +C LIMIT STEP SIZE, SET WEIGHT VECTOR AND TAKE A STEP +C + 330 HA = ABS(H) + IF (INFO(4) .NE. 1) GO TO 340 + HA = MIN(HA,ABS(TSTOP-X)) + 340 H = SIGN(HA,H) + EPS = 1.0D0 + LTOL = 1 + DO 350 L = 1,NEQ + IF (INFO(2) .EQ. 1) LTOL = L + WT(L) = RTOL(LTOL)*ABS(YY(L)) + ATOL(LTOL) + IF (WT(L) .LE. 0.0D0) GO TO 360 + 350 CONTINUE + GO TO 380 +C +C RELATIVE ERROR CRITERION INAPPROPRIATE + 360 IDID = -3 + DO 370 L = 1,NEQ + Y(L) = YY(L) + 370 YPOUT(L) = YP(L) + T = X + TOLD = T + INFO(1) = -1 + INTOUT = .FALSE. + RETURN +C + 380 CALL DSTEPS(DF,NEQ,YY,X,H,EPS,WT,START,HOLD,KORD,KOLD,CRASH,PHI,P, + 1 YP,PSI,ALPHA,BETA,SIG,V,W,G,PHASE1,NS,NORND,KSTEPS, + 2 TWOU,FOURU,XOLD,KPREV,IVC,IV,KGI,GI,RPAR,IPAR) +C +C....................................................................... +C + IF(.NOT.CRASH) GO TO 420 +C +C TOLERANCES TOO SMALL + IDID = -2 + RTOL(1) = EPS*RTOL(1) + ATOL(1) = EPS*ATOL(1) + IF (INFO(2) .EQ. 0) GO TO 400 + DO 390 L = 2,NEQ + RTOL(L) = EPS*RTOL(L) + 390 ATOL(L) = EPS*ATOL(L) + 400 DO 410 L = 1,NEQ + Y(L) = YY(L) + 410 YPOUT(L) = YP(L) + T = X + TOLD = T + INFO(1) = -1 + INTOUT = .FALSE. + RETURN +C +C (STIFFNESS TEST) COUNT NUMBER OF CONSECUTIVE STEPS TAKEN WITH THE +C ORDER OF THE METHOD BEING LESS OR EQUAL TO FOUR +C + 420 KLE4 = KLE4 + 1 + IF(KOLD .GT. 4) KLE4 = 0 + IF(KLE4 .GE. 50) STIFF = .TRUE. + INTOUT = .TRUE. + GO TO 250 + END +*DECK DINTP + SUBROUTINE DINTP (X, Y, XOUT, YOUT, YPOUT, NEQN, KOLD, PHI, IVC, + + IV, KGI, GI, ALPHA, OG, OW, OX, OY) +C***BEGIN PROLOGUE DINTP +C***PURPOSE Approximate the solution at XOUT by evaluating the +C polynomial computed in DSTEPS at XOUT. Must be used in +C conjunction with DSTEPS. +C***LIBRARY SLATEC (DEPAC) +C***CATEGORY I1A1B +C***TYPE DOUBLE PRECISION (SINTRP-S, DINTP-D) +C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, +C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR, +C SMOOTH INTERPOLANT +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C The methods in subroutine DSTEPS approximate the solution near X +C by a polynomial. Subroutine DINTP approximates the solution at +C XOUT by evaluating the polynomial there. Information defining this +C polynomial is passed from DSTEPS so DINTP cannot be used alone. +C +C Subroutine DSTEPS is completely explained and documented in the text +C "Computer Solution of Ordinary Differential Equations, the Initial +C Value Problem" by L. F. Shampine and M. K. Gordon. +C +C Input to DINTP -- +C +C The user provides storage in the calling program for the arrays in +C the call list +C DIMENSION Y(NEQN),YOUT(NEQN),YPOUT(NEQN),PHI(NEQN,16),OY(NEQN) +C AND ALPHA(12),OG(13),OW(12),GI(11),IV(10) +C and defines +C XOUT -- point at which solution is desired. +C The remaining parameters are defined in DSTEPS and passed to +C DINTP from that subroutine +C +C Output from DINTP -- +C +C YOUT(*) -- solution at XOUT +C YPOUT(*) -- derivative of solution at XOUT +C The remaining parameters are returned unaltered from their input +C values. Integration with DSTEPS may be continued. +C +C***REFERENCES H. A. Watts, A smoother interpolant for DE/STEP, INTRP +C II, Report SAND84-0293, Sandia Laboratories, 1984. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 840201 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DINTP +C + INTEGER I, IQ, IV, IVC, IW, J, JQ, KGI, KOLD, KP1, KP2, + 1 L, M, NEQN + DOUBLE PRECISION ALP, ALPHA, C, G, GDI, GDIF, GI, GAMMA, H, HI, + 1 HMU, OG, OW, OX, OY, PHI, RMU, SIGMA, TEMP1, TEMP2, TEMP3, + 2 W, X, XI, XIM1, XIQ, XOUT, Y, YOUT, YPOUT +C + DIMENSION Y(*),YOUT(*),YPOUT(*),PHI(NEQN,16),OY(*) + DIMENSION G(13),C(13),W(13),OG(13),OW(12),ALPHA(12),GI(11),IV(10) +C +C***FIRST EXECUTABLE STATEMENT DINTP + KP1 = KOLD + 1 + KP2 = KOLD + 2 +C + HI = XOUT - OX + H = X - OX + XI = HI/H + XIM1 = XI - 1.D0 +C +C INITIALIZE W(*) FOR COMPUTING G(*) +C + XIQ = XI + DO 10 IQ = 1,KP1 + XIQ = XI*XIQ + TEMP1 = IQ*(IQ+1) + 10 W(IQ) = XIQ/TEMP1 +C +C COMPUTE THE DOUBLE INTEGRAL TERM GDI +C + IF (KOLD .LE. KGI) GO TO 50 + IF (IVC .GT. 0) GO TO 20 + GDI = 1.0D0/TEMP1 + M = 2 + GO TO 30 + 20 IW = IV(IVC) + GDI = OW(IW) + M = KOLD - IW + 3 + 30 IF (M .GT. KOLD) GO TO 60 + DO 40 I = M,KOLD + 40 GDI = OW(KP2-I) - ALPHA(I)*GDI + GO TO 60 + 50 GDI = GI(KOLD) +C +C COMPUTE G(*) AND C(*) +C + 60 G(1) = XI + G(2) = 0.5D0*XI*XI + C(1) = 1.0D0 + C(2) = XI + IF (KOLD .LT. 2) GO TO 90 + DO 80 I = 2,KOLD + ALP = ALPHA(I) + GAMMA = 1.0D0 + XIM1*ALP + L = KP2 - I + DO 70 JQ = 1,L + 70 W(JQ) = GAMMA*W(JQ) - ALP*W(JQ+1) + G(I+1) = W(1) + 80 C(I+1) = GAMMA*C(I) +C +C DEFINE INTERPOLATION PARAMETERS +C + 90 SIGMA = (W(2) - XIM1*W(1))/GDI + RMU = XIM1*C(KP1)/GDI + HMU = RMU/H +C +C INTERPOLATE FOR THE SOLUTION -- YOUT +C AND FOR THE DERIVATIVE OF THE SOLUTION -- YPOUT +C + DO 100 L = 1,NEQN + YOUT(L) = 0.0D0 + 100 YPOUT(L) = 0.0D0 + DO 120 J = 1,KOLD + I = KP2 - J + GDIF = OG(I) - OG(I-1) + TEMP2 = (G(I) - G(I-1)) - SIGMA*GDIF + TEMP3 = (C(I) - C(I-1)) + RMU*GDIF + DO 110 L = 1,NEQN + YOUT(L) = YOUT(L) + TEMP2*PHI(L,I) + 110 YPOUT(L) = YPOUT(L) + TEMP3*PHI(L,I) + 120 CONTINUE + DO 130 L = 1,NEQN + YOUT(L) = ((1.0D0 - SIGMA)*OY(L) + SIGMA*Y(L)) + + 1 H*(YOUT(L) + (G(1) - SIGMA*OG(1))*PHI(L,1)) + 130 YPOUT(L) = HMU*(OY(L) - Y(L)) + + 1 (YPOUT(L) + (C(1) + RMU*OG(1))*PHI(L,1)) +C + RETURN + END +*DECK XERMSG + SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) +C***BEGIN PROLOGUE XERMSG +C***PURPOSE Process error messages for SLATEC and other libraries. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERMSG-A) +C***KEYWORDS ERROR MESSAGE, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C XERMSG processes a diagnostic message in a manner determined by the +C value of LEVEL and the current value of the library error control +C flag, KONTRL. See subroutine XSETF for details. +C +C LIBRAR A character constant (or character variable) with the name +C of the library. This will be 'SLATEC' for the SLATEC +C Common Math Library. The error handling package is +C general enough to be used by many libraries +C simultaneously, so it is desirable for the routine that +C detects and reports an error to identify the library name +C as well as the routine name. +C +C SUBROU A character constant (or character variable) with the name +C of the routine that detected the error. Usually it is the +C name of the routine that is calling XERMSG. There are +C some instances where a user callable library routine calls +C lower level subsidiary routines where the error is +C detected. In such cases it may be more informative to +C supply the name of the routine the user called rather than +C the name of the subsidiary routine that detected the +C error. +C +C MESSG A character constant (or character variable) with the text +C of the error or warning message. In the example below, +C the message is a character constant that contains a +C generic message. +C +C CALL XERMSG ('SLATEC', 'MMPY', +C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', +C *3, 1) +C +C It is possible (and is sometimes desirable) to generate a +C specific message--e.g., one that contains actual numeric +C values. Specific numeric values can be converted into +C character strings using formatted WRITE statements into +C character variables. This is called standard Fortran +C internal file I/O and is exemplified in the first three +C lines of the following example. You can also catenate +C substrings of characters to construct the error message. +C Here is an example showing the use of both writing to +C an internal file and catenating character strings. +C +C CHARACTER*5 CHARN, CHARL +C WRITE (CHARN,10) N +C WRITE (CHARL,10) LDA +C 10 FORMAT(I5) +C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// +C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// +C * CHARL, 3, 1) +C +C There are two subtleties worth mentioning. One is that +C the // for character catenation is used to construct the +C error message so that no single character constant is +C continued to the next line. This avoids confusion as to +C whether there are trailing blanks at the end of the line. +C The second is that by catenating the parts of the message +C as an actual argument rather than encoding the entire +C message into one large character variable, we avoid +C having to know how long the message will be in order to +C declare an adequate length for that large character +C variable. XERMSG calls XERPRN to print the message using +C multiple lines if necessary. If the message is very long, +C XERPRN will break it into pieces of 72 characters (as +C requested by XERMSG) for printing on multiple lines. +C Also, XERMSG asks XERPRN to prefix each line with ' * ' +C so that the total line length could be 76 characters. +C Note also that XERPRN scans the error message backwards +C to ignore trailing blanks. Another feature is that +C the substring '$$' is treated as a new line sentinel +C by XERPRN. If you want to construct a multiline +C message without having to count out multiples of 72 +C characters, just use '$$' as a separator. '$$' +C obviously must occur within 72 characters of the +C start of each line to have its intended effect since +C XERPRN is asked to wrap around at 72 characters in +C addition to looking for '$$'. +C +C NERR An integer value that is chosen by the library routine's +C author. It must be in the range -99 to 999 (three +C printable digits). Each distinct error should have its +C own error number. These error numbers should be described +C in the machine readable documentation for the routine. +C The error numbers need be unique only within each routine, +C so it is reasonable for each routine to start enumerating +C errors from 1 and proceeding to the next integer. +C +C LEVEL An integer value in the range 0 to 2 that indicates the +C level (severity) of the error. Their meanings are +C +C -1 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. An attempt is made to only print this +C message once. +C +C 0 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. +C +C 1 A recoverable error. This is used even if the error is +C so serious that the routine cannot return any useful +C answer. If the user has told the error package to +C return after recoverable errors, then XERMSG will +C return to the Library routine which can then return to +C the user's routine. The user may also permit the error +C package to terminate the program upon encountering a +C recoverable error. +C +C 2 A fatal error. XERMSG will not return to its caller +C after it receives a fatal error. This level should +C hardly ever be used; it is much better to allow the +C user a chance to recover. An example of one of the few +C cases in which it is permissible to declare a level 2 +C error is a reverse communication Library routine that +C is likely to be called repeatedly until it integrates +C across some interval. If there is a serious error in +C the input such that another step cannot be taken and +C the Library routine is called again without the input +C error having been corrected by the caller, the Library +C routine will probably be called forever with improper +C input. In this case, it is reasonable to declare the +C error to be fatal. +C +C Each of the arguments to XERMSG is input; none will be modified by +C XERMSG. A routine may make multiple calls to XERMSG with warning +C level messages; however, after a call to XERMSG with a recoverable +C error, the routine should return to the user. Do not try to call +C XERMSG with a second recoverable error after the first recoverable +C error because the error package saves the error number. The user +C can retrieve this error number by calling another entry point in +C the error handling package and then clear the error number when +C recovering from the error. Calling XERMSG in succession causes the +C old error number to be overwritten by the latest error number. +C This is considered harmless for error numbers associated with +C warning messages but must not be done for error numbers of serious +C errors. After a call to XERMSG with a recoverable error, the user +C must be given a chance to call NUMXER or XERCLR to retrieve or +C clear the error number. +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE +C***REVISION HISTORY (YYMMDD) +C 880101 DATE WRITTEN +C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. +C THERE ARE TWO BASIC CHANGES. +C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO +C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES +C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS +C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE +C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER +C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY +C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE +C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. +C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE +C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE +C OF LOWER CASE. +C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. +C THE PRINCIPAL CHANGES ARE +C 1. CLARIFY COMMENTS IN THE PROLOGUES +C 2. RENAME XRPRNT TO XERPRN +C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES +C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / +C CHARACTER FOR NEW RECORDS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C CLEAN UP THE CODING. +C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN +C PREFIX. +C 891013 REVISED TO CORRECT COMMENTS. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but +C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added +C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and +C XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERMSG + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 XLIBR, XSUBR + CHARACTER*72 TEMP + CHARACTER*20 LFIRST +C***FIRST EXECUTABLE STATEMENT XERMSG + LKNTRL = J4SAVE (2, 0, .FALSE.) + MAXMES = J4SAVE (4, 0, .FALSE.) +C +C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. +C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE +C SHOULD BE PRINTED. +C +C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN +C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, +C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. +C + IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. + * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN + CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // + * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// + * 'JOB ABORT DUE TO FATAL ERROR.', 72) + CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) + CALL XERHLT (' ***XERMSG -- INVALID INPUT') + RETURN + ENDIF +C +C RECORD THE MESSAGE. +C + I = J4SAVE (1, NERR, .TRUE.) + CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) +C +C HANDLE PRINT-ONCE WARNING MESSAGES. +C + IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN +C +C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. +C + XLIBR = LIBRAR + XSUBR = SUBROU + LFIRST = MESSG + LERR = NERR + LLEVEL = LEVEL + CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) +C + LKNTRL = MAX(-2, MIN(2,LKNTRL)) + MKNTRL = ABS(LKNTRL) +C +C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS +C ZERO AND THE ERROR IS NOT FATAL. +C + IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 + IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 + IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 + IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 +C +C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A +C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) +C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG +C IS NOT ZERO. +C + IF (LKNTRL .NE. 0) THEN + TEMP(1:21) = 'MESSAGE FROM ROUTINE ' + I = MIN(LEN(SUBROU), 16) + TEMP(22:21+I) = SUBROU(1:I) + TEMP(22+I:33+I) = ' IN LIBRARY ' + LTEMP = 33 + I + I = MIN(LEN(LIBRAR), 16) + TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) + TEMP(LTEMP+I+1:LTEMP+I+1) = '.' + LTEMP = LTEMP + I + 1 + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE +C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE +C FROM EACH OF THE FOLLOWING THREE OPTIONS. +C 1. LEVEL OF THE MESSAGE +C 'INFORMATIVE MESSAGE' +C 'POTENTIALLY RECOVERABLE ERROR' +C 'FATAL ERROR' +C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE +C 'PROG CONTINUES' +C 'PROG ABORTED' +C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK +C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS +C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) +C 'TRACEBACK REQUESTED' +C 'TRACEBACK NOT REQUESTED' +C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT +C EXCEED 74 CHARACTERS. +C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. +C + IF (LKNTRL .GT. 0) THEN +C +C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. +C + IF (LEVEL .LE. 0) THEN + TEMP(1:20) = 'INFORMATIVE MESSAGE,' + LTEMP = 20 + ELSEIF (LEVEL .EQ. 1) THEN + TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' + LTEMP = 30 + ELSE + TEMP(1:12) = 'FATAL ERROR,' + LTEMP = 12 + ENDIF +C +C THEN WHETHER THE PROGRAM WILL CONTINUE. +C + IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. + * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN + TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' + LTEMP = LTEMP + 14 + ELSE + TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' + LTEMP = LTEMP + 16 + ENDIF +C +C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' + LTEMP = LTEMP + 20 + ELSE + TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' + LTEMP = LTEMP + 24 + ENDIF + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C NOW SEND OUT THE MESSAGE. +C + CALL XERPRN (' * ', -1, MESSG, 72) +C +C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A +C TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR + DO 10 I=16,22 + IF (TEMP(I:I) .NE. ' ') GO TO 20 + 10 CONTINUE +C + 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) + CALL FDUMP + ENDIF +C +C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. +C + IF (LKNTRL .NE. 0) THEN + CALL XERPRN (' * ', -1, ' ', 72) + CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) + CALL XERPRN (' ', 0, ' ', 72) + ENDIF +C +C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE +C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. +C + 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN +C +C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A +C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR +C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. +C + IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN + IF (LEVEL .EQ. 1) THEN + CALL XERPRN + * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) + ELSE + CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) + ENDIF + CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) + CALL XERHLT (' ') + ELSE + CALL XERHLT (MESSG) + ENDIF + RETURN + END +*DECK XERPRN + SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) +C***BEGIN PROLOGUE XERPRN +C***SUBSIDIARY +C***PURPOSE Print error messages processed by XERMSG. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERPRN-A) +C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C This routine sends one or more lines to each of the (up to five) +C logical units to which error messages are to be sent. This routine +C is called several times by XERMSG, sometimes with a single line to +C print and sometimes with a (potentially very long) message that may +C wrap around into multiple lines. +C +C PREFIX Input argument of type CHARACTER. This argument contains +C characters to be put at the beginning of each line before +C the body of the message. No more than 16 characters of +C PREFIX will be used. +C +C NPREF Input argument of type INTEGER. This argument is the number +C of characters to use from PREFIX. If it is negative, the +C intrinsic function LEN is used to determine its length. If +C it is zero, PREFIX is not used. If it exceeds 16 or if +C LEN(PREFIX) exceeds 16, only the first 16 characters will be +C used. If NPREF is positive and the length of PREFIX is less +C than NPREF, a copy of PREFIX extended with blanks to length +C NPREF will be used. +C +C MESSG Input argument of type CHARACTER. This is the text of a +C message to be printed. If it is a long message, it will be +C broken into pieces for printing on multiple lines. Each line +C will start with the appropriate prefix and be followed by a +C piece of the message. NWRAP is the number of characters per +C piece; that is, after each NWRAP characters, we break and +C start a new line. In addition the characters '$$' embedded +C in MESSG are a sentinel for a new line. The counting of +C characters up to NWRAP starts over for each new line. The +C value of NWRAP typically used by XERMSG is 72 since many +C older error messages in the SLATEC Library are laid out to +C rely on wrap-around every 72 characters. +C +C NWRAP Input argument of type INTEGER. This gives the maximum size +C piece into which to break MESSG for printing on multiple +C lines. An embedded '$$' ends a line, and the count restarts +C at the following character. If a line break does not occur +C on a blank (it would split a word) that word is moved to the +C next line. Values of NWRAP less than 16 will be treated as +C 16. Values of NWRAP greater than 132 will be treated as 132. +C The actual line length will be NPREF + NWRAP after NPREF has +C been adjusted to fall between 0 and 16 and NWRAP has been +C adjusted to fall between 16 and 132. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 880621 DATE WRITTEN +C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF +C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK +C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE +C SLASH CHARACTER IN FORMAT STATEMENTS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK +C LINES TO BE PRINTED. +C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF +C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. +C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Added code to break messages between words. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERPRN + CHARACTER*(*) PREFIX, MESSG + INTEGER NPREF, NWRAP + CHARACTER*148 CBUFF + INTEGER IU(5), NUNIT + CHARACTER*2 NEWLIN + PARAMETER (NEWLIN = '$$') +C***FIRST EXECUTABLE STATEMENT XERPRN + CALL XGETUA(IU,NUNIT) +C +C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD +C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD +C ERROR MESSAGE UNIT. +C + N = I1MACH(4) + DO 10 I=1,NUNIT + IF (IU(I) .EQ. 0) IU(I) = N + 10 CONTINUE +C +C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE +C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING +C THE REST OF THIS ROUTINE. +C + IF ( NPREF .LT. 0 ) THEN + LPREF = LEN(PREFIX) + ELSE + LPREF = NPREF + ENDIF + LPREF = MIN(16, LPREF) + IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX +C +C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE +C TIME FROM MESSG TO PRINT ON ONE LINE. +C + LWRAP = MAX(16, MIN(132, NWRAP)) +C +C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. +C + LENMSG = LEN(MESSG) + N = LENMSG + DO 20 I=1,N + IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 + LENMSG = LENMSG - 1 + 20 CONTINUE + 30 CONTINUE +C +C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. +C + IF (LENMSG .EQ. 0) THEN + CBUFF(LPREF+1:LPREF+1) = ' ' + DO 40 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) + 40 CONTINUE + RETURN + ENDIF +C +C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING +C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. +C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. +C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. +C +C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE +C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE +C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH +C OF THE SECOND ARGUMENT. +C +C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE +C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER +C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT +C POSITION NEXTC. +C +C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE +C REMAINDER OF THE CHARACTER STRING. LPIECE +C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, +C WHICHEVER IS LESS. +C +C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: +C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE +C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY +C BLANK LINES. THIS TAKES CARE OF THE SITUATION +C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF +C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE +C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC +C SHOULD BE INCREMENTED BY 2. +C +C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. +C +C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 +C RESET LPIECE = LPIECE-1. NOTE THAT THIS +C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. +C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY +C AT THE END OF A LINE. +C + NEXTC = 1 + 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) + IF (LPIECE .EQ. 0) THEN +C +C THERE WAS NO NEW LINE SENTINEL FOUND. +C + IDELTA = 0 + LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) + IF (LPIECE .LT. LENMSG+1-NEXTC) THEN + DO 52 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 54 + ENDIF + 52 CONTINUE + ENDIF + 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSEIF (LPIECE .EQ. 1) THEN +C +C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). +C DON'T PRINT A BLANK LINE. +C + NEXTC = NEXTC + 2 + GO TO 50 + ELSEIF (LPIECE .GT. LWRAP+1) THEN +C +C LPIECE SHOULD BE SET DOWN TO LWRAP. +C + IDELTA = 0 + LPIECE = LWRAP + DO 56 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 58 + ENDIF + 56 CONTINUE + 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSE +C +C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. +C WE SHOULD DECREMENT LPIECE BY ONE. +C + LPIECE = LPIECE - 1 + CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + 2 + ENDIF +C +C PRINT +C + DO 60 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) + 60 CONTINUE +C + IF (NEXTC .LE. LENMSG) GO TO 50 + RETURN + END +*DECK XERSVE + SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, + + ICOUNT) +C***BEGIN PROLOGUE XERSVE +C***SUBSIDIARY +C***PURPOSE Record that an error has occurred. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (XERSVE-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C *Usage: +C +C INTEGER KFLAG, NERR, LEVEL, ICOUNT +C CHARACTER * (len) LIBRAR, SUBROU, MESSG +C +C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) +C +C *Arguments: +C +C LIBRAR :IN is the library that the message is from. +C SUBROU :IN is the subroutine that the message is from. +C MESSG :IN is the message to be saved. +C KFLAG :IN indicates the action to be performed. +C when KFLAG > 0, the message in MESSG is saved. +C when KFLAG=0 the tables will be dumped and +C cleared. +C when KFLAG < 0, the tables will be dumped and +C not cleared. +C NERR :IN is the error number. +C LEVEL :IN is the error severity. +C ICOUNT :OUT the number of times this message has been seen, +C or zero if the table has overflowed and does not +C contain this message specifically. When KFLAG=0, +C ICOUNT will not be altered. +C +C *Description: +C +C Record that this error occurred and possibly dump and clear the +C tables. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 800319 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900413 Routine modified to remove reference to KFLAG. (WRB) +C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling +C sequence, use IF-THEN-ELSE, make number of saved entries +C easily changeable, changed routine name from XERSAV to +C XERSVE. (RWC) +C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERSVE + PARAMETER (LENTAB=10) + INTEGER LUN(5) + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB + CHARACTER*20 MESTAB(LENTAB), MES + DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) + SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG + DATA KOUNTX/0/, NMSG/0/ +C***FIRST EXECUTABLE STATEMENT XERSVE +C + IF (KFLAG.LE.0) THEN +C +C Dump the table. +C + IF (NMSG.EQ.0) RETURN +C +C Print to each unit. +C + CALL XGETUA (LUN, NUNIT) + DO 20 KUNIT = 1,NUNIT + IUNIT = LUN(KUNIT) + IF (IUNIT.EQ.0) IUNIT = I1MACH(4) +C +C Print the table header. +C + WRITE (IUNIT,9000) +C +C Print body of table. +C + DO 10 I = 1,NMSG + WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), + * NERTAB(I),LEVTAB(I),KOUNT(I) + 10 CONTINUE +C +C Print number of other errors. +C + IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX + WRITE (IUNIT,9030) + 20 CONTINUE +C +C Clear the error tables. +C + IF (KFLAG.EQ.0) THEN + NMSG = 0 + KOUNTX = 0 + ENDIF + ELSE +C +C PROCESS A MESSAGE... +C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, +C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. +C + LIB = LIBRAR + SUB = SUBROU + MES = MESSG + DO 30 I = 1,NMSG + IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. + * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. + * LEVEL.EQ.LEVTAB(I)) THEN + KOUNT(I) = KOUNT(I) + 1 + ICOUNT = KOUNT(I) + RETURN + ENDIF + 30 CONTINUE +C + IF (NMSG.LT.LENTAB) THEN +C +C Empty slot found for new message. +C + NMSG = NMSG + 1 + LIBTAB(I) = LIB + SUBTAB(I) = SUB + MESTAB(I) = MES + NERTAB(I) = NERR + LEVTAB(I) = LEVEL + KOUNT (I) = 1 + ICOUNT = 1 + ELSE +C +C Table is full. +C + KOUNTX = KOUNTX+1 + ICOUNT = 0 + ENDIF + ENDIF + RETURN +C +C Formats. +C + 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / + + ' LIBRARY SUBROUTINE MESSAGE START NERR', + + ' LEVEL COUNT') + 9010 FORMAT (1X,A,3X,A,3X,A,3I10) + 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) + 9030 FORMAT (1X) + END +*DECK D1MACH + DOUBLE PRECISION FUNCTION D1MACH (I) +C***BEGIN PROLOGUE D1MACH +C***PURPOSE Return floating point machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C D1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument, and can be referenced as follows: +C +C D = D1MACH(I) +C +C where I=1,...,5. The (output) value of D above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. +C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. +C D1MACH( 3) = B**(-T), the smallest relative spacing. +C D1MACH( 4) = B**(1-T), the largest relative spacing. +C D1MACH( 5) = LOG10(B) +C +C Assume double precision numbers are represented in the T-digit, +C base-B form +C +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and +C EMIN .LE. E .LE. EMAX. +C +C The values of B, T, EMIN and EMAX are provided in I1MACH as +C follows: +C I1MACH(10) = B, the base. +C I1MACH(14) = T, the number of base-B digits. +C I1MACH(15) = EMIN, the smallest exponent E. +C I1MACH(16) = EMAX, the largest exponent E. +C +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890213 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 900911 Added SUN 386i constants. (WRB) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added CONVEX -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE D1MACH +C + INTEGER SMALL(4) + INTEGER LARGE(4) + INTEGER RIGHT(4) + INTEGER DIVER(4) + INTEGER LOG10(4) +C +C Initial data here correspond to the IEEE standard. The values for +C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value +C for DMACH(2) is a slight lower bound. The value for DMACH(5) is +C a 20-digit approximation. If one of the sets of initial data below +C is preferred, do the necessary commenting and uncommenting. (DWL) + DOUBLE PRECISION DMACH(5) + DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, + 1 0.30102999566398119521D0 / + SAVE DMACH +C +cc EQUIVALENCE (DMACH(1),SMALL(1)) +cc EQUIVALENCE (DMACH(2),LARGE(1)) +cc EQUIVALENCE (DMACH(3),RIGHT(1)) +cc EQUIVALENCE (DMACH(4),DIVER(1)) +cc EQUIVALENCE (DMACH(5),LOG10(1)) +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / +C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / +C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / +C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA SMALL(1) / ZC00800000 / +C DATA SMALL(2) / Z000000000 / +C DATA LARGE(1) / ZDFFFFFFFF / +C DATA LARGE(2) / ZFFFFFFFFF / +C DATA RIGHT(1) / ZCC5800000 / +C DATA RIGHT(2) / Z000000000 / +C DATA DIVER(1) / ZCC6800000 / +C DATA DIVER(2) / Z000000000 / +C DATA LOG10(1) / ZD00E730E7 / +C DATA LOG10(2) / ZC77800DC0 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O0000000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O0007777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O7770000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O7777777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA SMALL(1) / Z"3001800000000000" / +C DATA SMALL(2) / Z"3001000000000000" / +C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / +C DATA LARGE(2) / Z"4FFE000000000000" / +C DATA RIGHT(1) / Z"3FD2800000000000" / +C DATA RIGHT(2) / Z"3FD2000000000000" / +C DATA DIVER(1) / Z"3FD3800000000000" / +C DATA DIVER(2) / Z"3FD3000000000000" / +C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / +C DATA LOG10(2) / Z"3FFFF7988F8959AC" / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA SMALL(1) / 00564000000000000000B / +C DATA SMALL(2) / 00000000000000000000B / +C DATA LARGE(1) / 37757777777777777777B / +C DATA LARGE(2) / 37157777777777777777B / +C DATA RIGHT(1) / 15624000000000000000B / +C DATA RIGHT(2) / 00000000000000000000B / +C DATA DIVER(1) / 15634000000000000000B / +C DATA DIVER(2) / 00000000000000000000B / +C DATA LOG10(1) / 17164642023241175717B / +C DATA LOG10(2) / 16367571421742254654B / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn OR -pd8 COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CC0000000000000' / +C DATA DMACH(4) / Z'3CD0000000000000' / +C DATA DMACH(5) / Z'3FF34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F900000000000000000000000000000' / +C DATA DMACH(4) / Z'3F910000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE CRAY +C +C DATA SMALL(1) / 201354000000000000000B / +C DATA SMALL(2) / 000000000000000000000B / +C DATA LARGE(1) / 577767777777777777777B / +C DATA LARGE(2) / 000007777777777777774B / +C DATA RIGHT(1) / 376434000000000000000B / +C DATA RIGHT(2) / 000000000000000000000B / +C DATA DIVER(1) / 376444000000000000000B / +C DATA DIVER(2) / 000000000000000000000B / +C DATA LOG10(1) / 377774642023241175717B / +C DATA LOG10(2) / 000007571421742254654B / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - +C STATIC DMACH(5) +C +C DATA SMALL / 20K, 3*0 / +C DATA LARGE / 77777K, 3*177777K / +C DATA RIGHT / 31420K, 3*0 / +C DATA DIVER / 32020K, 3*0 / +C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA DMACH(1) / '0000000000000010'X / +C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / +C DATA DMACH(3) / '0000000000003CC0'X / +C DATA DMACH(4) / '0000000000003CD0'X / +C DATA DMACH(5) / '79FF509F44133FF3'X / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FORMAT +C +C DATA DMACH(1) / '0010000000000000'X / +C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / +C DATA DMACH(3) / '3CA0000000000000'X / +C DATA DMACH(4) / '3CB0000000000000'X / +C DATA DMACH(5) / '3FD34413509F79FF'X / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ +C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ +C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ +C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ +C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / +C +C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 16, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 15552, 0 / +C DATA DIVER(1), DIVER(2) / 15568, 0 / +C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / +C +C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) +C +C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / +C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / +C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / +C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / +C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / +C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / +C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / +C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +C DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / +C DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / +C DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / +C DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / +C DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / +C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / +C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / +C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2) / 40000B, 0 / +C DATA SMALL(3), SMALL(4) / 0, 1 / +C DATA LARGE(1), LARGE(2) / 77777B, 177777B / +C DATA LARGE(3), LARGE(4) / 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 225B / +C DATA DIVER(1), DIVER(2) / 40000B, 0 / +C DATA DIVER(3), DIVER(4) / 0, 227B / +C DATA LOG10(1), LOG10(2) / 46420B, 46502B / +C DATA LOG10(3), LOG10(4) / 76747B, 176377B / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / +C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / +C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / +C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / +C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / +C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / +C +C MACHINE CONSTANTS FOR THE IBM PC +C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION +C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. +C +C DATA SMALL(1) / 2.23D-308 / +C DATA LARGE(1) / 1.79D+308 / +C DATA RIGHT(1) / 1.11D-16 / +C DATA DIVER(1) / 2.22D-16 / +C DATA LOG10(1) / 0.301029995663981195D0 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / +C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / +C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 8388608, 0 / +C DATA LARGE(1), LARGE(2) / 2147483647, -1 / +C DATA RIGHT(1), RIGHT(2) / 612368384, 0 / +C DATA DIVER(1), DIVER(2) / 620756992, 0 / +C DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / +C +C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / +C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / +C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / +C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / +C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA SMALL(3), SMALL(4) / 0, 0 / +C DATA LARGE(1), LARGE(2) / 32767, -1 / +C DATA LARGE(3), LARGE(4) / -1, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA DIVER(3), DIVER(4) / 0, 0 / +C DATA LOG10(1), LOG10(2) / 16282, 8346 / +C DATA LOG10(3), LOG10(4) / -31493, -12296 / +C +C DATA SMALL(1), SMALL(2) / O000200, O000000 / +C DATA SMALL(3), SMALL(4) / O000000, O000000 / +C DATA LARGE(1), LARGE(2) / O077777, O177777 / +C DATA LARGE(3), LARGE(4) / O177777, O177777 / +C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / +C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / +C DATA DIVER(1), DIVER(2) / O022400, O000000 / +C DATA DIVER(3), DIVER(4) / O000000, O000000 / +C DATA LOG10(1), LOG10(2) / O037632, O020232 / +C DATA LOG10(3), LOG10(4) / O102373, O147770 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / +C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE SUN 386i +C +C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / +C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / +C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' +C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / +C DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / +C DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / +C DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / +C DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / +C +C***FIRST EXECUTABLE STATEMENT D1MACH + IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', + + 'I OUT OF BOUNDS', 1, 2) +C + D1MACH = DMACH(I) + RETURN +C + END +*DECK XGETUA + SUBROUTINE XGETUA (IUNITA, N) +C***BEGIN PROLOGUE XGETUA +C***PURPOSE Return unit number(s) to which error messages are being +C sent. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XGETUA-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C XGETUA may be called to determine the unit number or numbers +C to which error messages are being sent. +C These unit numbers may have been set by a call to XSETUN, +C or a call to XSETUA, or may be a default value. +C +C Description of Parameters +C --Output-- +C IUNIT - an array of one to five unit numbers, depending +C on the value of N. A value of zero refers to the +C default unit, as defined by the I1MACH machine +C constant routine. Only IUNIT(1),...,IUNIT(N) are +C defined by XGETUA. The values of IUNIT(N+1),..., +C IUNIT(5) are not defined (for N .LT. 5) or altered +C in any way by XGETUA. +C N - the number of units to which copies of the +C error messages are being sent. N will be in the +C range from 1 to 5. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XGETUA + DIMENSION IUNITA(5) +C***FIRST EXECUTABLE STATEMENT XGETUA + N = J4SAVE(5,0,.FALSE.) + DO 30 I=1,N + INDEX = I+4 + IF (I.EQ.1) INDEX = 3 + IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) + 30 CONTINUE + RETURN + END +*DECK DSTEPS + SUBROUTINE DSTEPS (DF, NEQN, Y, X, H, EPS, WT, START, HOLD, K, + + KOLD, CRASH, PHI, P, YP, PSI, ALPHA, BETA, SIG, V, W, G, + + PHASE1, NS, NORND, KSTEPS, TWOU, FOURU, XOLD, KPREV, IVC, IV, + + KGI, GI, RPAR, IPAR) +C***BEGIN PROLOGUE DSTEPS +C***PURPOSE Integrate a system of first order ordinary differential +C equations one step. +C***LIBRARY SLATEC (DEPAC) +C***CATEGORY I1A1B +C***TYPE DOUBLE PRECISION (STEPS-S, DSTEPS-D) +C***KEYWORDS ADAMS METHOD, DEPAC, INITIAL VALUE PROBLEMS, ODE, +C ORDINARY DIFFERENTIAL EQUATIONS, PREDICTOR-CORRECTOR +C***AUTHOR Shampine, L. F., (SNLA) +C Gordon, M. K., (SNLA) +C MODIFIED BY H.A. WATTS +C***DESCRIPTION +C +C Written by L. F. Shampine and M. K. Gordon +C +C Abstract +C +C Subroutine DSTEPS is normally used indirectly through subroutine +C DDEABM . Because DDEABM suffices for most problems and is much +C easier to use, using it should be considered before using DSTEPS +C alone. +C +C Subroutine DSTEPS integrates a system of NEQN first order ordinary +C differential equations one step, normally from X to X+H, using a +C modified divided difference form of the Adams Pece formulas. Local +C extrapolation is used to improve absolute stability and accuracy. +C The code adjusts its order and step size to control the local error +C per unit step in a generalized sense. Special devices are included +C to control roundoff error and to detect when the user is requesting +C too much accuracy. +C +C This code is completely explained and documented in the text, +C Computer Solution of Ordinary Differential Equations, The Initial +C Value Problem by L. F. Shampine and M. K. Gordon. +C Further details on use of this code are available in "Solving +C Ordinary Differential Equations with ODE, STEP, and INTRP", +C by L. F. Shampine and M. K. Gordon, SLA-73-1060. +C +C +C The parameters represent -- +C DF -- subroutine to evaluate derivatives +C NEQN -- number of equations to be integrated +C Y(*) -- solution vector at X +C X -- independent variable +C H -- appropriate step size for next step. Normally determined by +C code +C EPS -- local error tolerance +C WT(*) -- vector of weights for error criterion +C START -- logical variable set .TRUE. for first step, .FALSE. +C otherwise +C HOLD -- step size used for last successful step +C K -- appropriate order for next step (determined by code) +C KOLD -- order used for last successful step +C CRASH -- logical variable set .TRUE. when no step can be taken, +C .FALSE. otherwise. +C YP(*) -- derivative of solution vector at X after successful +C step +C KSTEPS -- counter on attempted steps +C TWOU -- 2.*U where U is machine unit roundoff quantity +C FOURU -- 4.*U where U is machine unit roundoff quantity +C RPAR,IPAR -- parameter arrays which you may choose to use +C for communication between your program and subroutine F. +C They are not altered or used by DSTEPS. +C The variables X,XOLD,KOLD,KGI and IVC and the arrays Y,PHI,ALPHA,G, +C W,P,IV and GI are required for the interpolation subroutine SINTRP. +C The remaining variables and arrays are included in the call list +C only to eliminate local retention of variables between calls. +C +C Input to DSTEPS +C +C First call -- +C +C The user must provide storage in his calling program for all arrays +C in the call list, namely +C +C DIMENSION Y(NEQN),WT(NEQN),PHI(NEQN,16),P(NEQN),YP(NEQN),PSI(12), +C 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), +C 2 RPAR(*),IPAR(*) +C +C **Note** +C +C The user must also declare START , CRASH , PHASE1 and NORND +C logical variables and DF an EXTERNAL subroutine, supply the +C subroutine DF(X,Y,YP) to evaluate +C DY(I)/DX = YP(I) = DF(X,Y(1),Y(2),...,Y(NEQN)) +C and initialize only the following parameters. +C NEQN -- number of equations to be integrated +C Y(*) -- vector of initial values of dependent variables +C X -- initial value of the independent variable +C H -- nominal step size indicating direction of integration +C and maximum size of step. Must be variable +C EPS -- local error tolerance per step. Must be variable +C WT(*) -- vector of non-zero weights for error criterion +C START -- .TRUE. +C YP(*) -- vector of initial derivative values +C KSTEPS -- set KSTEPS to zero +C TWOU -- 2.*U where U is machine unit roundoff quantity +C FOURU -- 4.*U where U is machine unit roundoff quantity +C Define U to be the machine unit roundoff quantity by calling +C the function routine D1MACH, U = D1MACH(4), or by +C computing U so that U is the smallest positive number such +C that 1.0+U .GT. 1.0. +C +C DSTEPS requires that the L2 norm of the vector with components +C LOCAL ERROR(L)/WT(L) be less than EPS for a successful step. The +C array WT allows the user to specify an error test appropriate +C for his problem. For example, +C WT(L) = 1.0 specifies absolute error, +C = ABS(Y(L)) error relative to the most recent value of the +C L-th component of the solution, +C = ABS(YP(L)) error relative to the most recent value of +C the L-th component of the derivative, +C = MAX(WT(L),ABS(Y(L))) error relative to the largest +C magnitude of L-th component obtained so far, +C = ABS(Y(L))*RELERR/EPS + ABSERR/EPS specifies a mixed +C relative-absolute test where RELERR is relative +C error, ABSERR is absolute error and EPS = +C MAX(RELERR,ABSERR) . +C +C Subsequent calls -- +C +C Subroutine DSTEPS is designed so that all information needed to +C continue the integration, including the step size H and the order +C K , is returned with each step. With the exception of the step +C size, the error tolerance, and the weights, none of the parameters +C should be altered. The array WT must be updated after each step +C to maintain relative error tests like those above. Normally the +C integration is continued just beyond the desired endpoint and the +C solution interpolated there with subroutine SINTRP . If it is +C impossible to integrate beyond the endpoint, the step size may be +C reduced to hit the endpoint since the code will not take a step +C larger than the H input. Changing the direction of integration, +C i.e., the sign of H , requires the user set START = .TRUE. before +C calling DSTEPS again. This is the only situation in which START +C should be altered. +C +C Output from DSTEPS +C +C Successful Step -- +C +C The subroutine returns after each successful step with START and +C CRASH set .FALSE. . X represents the independent variable +C advanced one step of length HOLD from its value on input and Y +C the solution vector at the new value of X . All other parameters +C represent information corresponding to the new X needed to +C continue the integration. +C +C Unsuccessful Step -- +C +C When the error tolerance is too small for the machine precision, +C the subroutine returns without taking a step and CRASH = .TRUE. . +C An appropriate step size and error tolerance for continuing are +C estimated and all other information is restored as upon input +C before returning. To continue with the larger tolerance, the user +C just calls the code again. A restart is neither required nor +C desirable. +C +C***REFERENCES L. F. Shampine and M. K. Gordon, Solving ordinary +C differential equations with ODE, STEP, and INTRP, +C Report SLA-73-1060, Sandia Laboratories, 1973. +C***ROUTINES CALLED D1MACH, DHSTRT +C***REVISION HISTORY (YYMMDD) +C 740101 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DSTEPS +C + INTEGER I, IFAIL, IM1, IP1, IPAR, IQ, J, K, KM1, KM2, KNEW, + 1 KOLD, KP1, KP2, KSTEPS, L, LIMIT1, LIMIT2, NEQN, NS, NSM2, + 2 NSP1, NSP2 + DOUBLE PRECISION ABSH, ALPHA, BETA, BIG, D1MACH, + 1 EPS, ERK, ERKM1, ERKM2, ERKP1, ERR, + 2 FOURU, G, GI, GSTR, H, HNEW, HOLD, P, P5EPS, PHI, PSI, R, + 3 REALI, REALNS, RHO, ROUND, RPAR, SIG, TAU, TEMP1, + 4 TEMP2, TEMP3, TEMP4, TEMP5, TEMP6, TWO, TWOU, U, V, W, WT, + 5 X, XOLD, Y, YP + LOGICAL START,CRASH,PHASE1,NORND + DIMENSION Y(*),WT(*),PHI(NEQN,16),P(*),YP(*),PSI(12), + 1 ALPHA(12),BETA(12),SIG(13),V(12),W(12),G(13),GI(11),IV(10), + 2 RPAR(*),IPAR(*) + DIMENSION TWO(13),GSTR(13) + EXTERNAL DF + SAVE TWO, GSTR +C + DATA TWO(1),TWO(2),TWO(3),TWO(4),TWO(5),TWO(6),TWO(7),TWO(8), + 1 TWO(9),TWO(10),TWO(11),TWO(12),TWO(13) + 2 /2.0D0,4.0D0,8.0D0,16.0D0,32.0D0,64.0D0,128.0D0,256.0D0, + 3 512.0D0,1024.0D0,2048.0D0,4096.0D0,8192.0D0/ + DATA GSTR(1),GSTR(2),GSTR(3),GSTR(4),GSTR(5),GSTR(6),GSTR(7), + 1 GSTR(8),GSTR(9),GSTR(10),GSTR(11),GSTR(12),GSTR(13) + 2 /0.5D0,0.0833D0,0.0417D0,0.0264D0,0.0188D0,0.0143D0,0.0114D0, + 3 0.00936D0,0.00789D0,0.00679D0,0.00592D0,0.00524D0,0.00468D0/ +C +C *** BEGIN BLOCK 0 *** +C CHECK IF STEP SIZE OR ERROR TOLERANCE IS TOO SMALL FOR MACHINE +C PRECISION. IF FIRST STEP, INITIALIZE PHI ARRAY AND ESTIMATE A +C STARTING STEP SIZE. +C *** +C +C IF STEP SIZE IS TOO SMALL, DETERMINE AN ACCEPTABLE ONE +C +C***FIRST EXECUTABLE STATEMENT DSTEPS + CRASH = .TRUE. + IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 5 + H = SIGN(FOURU*ABS(X),H) + RETURN + 5 P5EPS = 0.5D0*EPS +C +C IF ERROR TOLERANCE IS TOO SMALL, INCREASE IT TO AN ACCEPTABLE VALUE +C + ROUND = 0.0D0 + DO 10 L = 1,NEQN + 10 ROUND = ROUND + (Y(L)/WT(L))**2 + ROUND = TWOU*SQRT(ROUND) + IF(P5EPS .GE. ROUND) GO TO 15 + EPS = 2.0D0*ROUND*(1.0D0 + FOURU) + RETURN + 15 CRASH = .FALSE. + G(1) = 1.0D0 + G(2) = 0.5D0 + SIG(1) = 1.0D0 + IF(.NOT.START) GO TO 99 +C +C INITIALIZE. COMPUTE APPROPRIATE STEP SIZE FOR FIRST STEP +C +C CALL DF(X,Y,YP,RPAR,IPAR) +C SUM = 0.0 + DO 20 L = 1,NEQN + PHI(L,1) = YP(L) + 20 PHI(L,2) = 0.0D0 +C20 SUM = SUM + (YP(L)/WT(L))**2 +C SUM = SQRT(SUM) +C ABSH = ABS(H) +C IF(EPS .LT. 16.0*SUM*H*H) ABSH = 0.25*SQRT(EPS/SUM) +C H = SIGN(MAX(ABSH,FOURU*ABS(X)),H) +C + U = D1MACH(4) + BIG = SQRT(D1MACH(2)) + CALL DHSTRT(DF,NEQN,X,X+H,Y,YP,WT,1,U,BIG, + 1 PHI(1,3),PHI(1,4),PHI(1,5),PHI(1,6),RPAR,IPAR,H) +C + HOLD = 0.0D0 + K = 1 + KOLD = 0 + KPREV = 0 + START = .FALSE. + PHASE1 = .TRUE. + NORND = .TRUE. + IF(P5EPS .GT. 100.0D0*ROUND) GO TO 99 + NORND = .FALSE. + DO 25 L = 1,NEQN + 25 PHI(L,15) = 0.0D0 + 99 IFAIL = 0 +C *** END BLOCK 0 *** +C +C *** BEGIN BLOCK 1 *** +C COMPUTE COEFFICIENTS OF FORMULAS FOR THIS STEP. AVOID COMPUTING +C THOSE QUANTITIES NOT CHANGED WHEN STEP SIZE IS NOT CHANGED. +C *** +C + 100 KP1 = K+1 + KP2 = K+2 + KM1 = K-1 + KM2 = K-2 +C +C NS IS THE NUMBER OF DSTEPS TAKEN WITH SIZE H, INCLUDING THE CURRENT +C ONE. WHEN K.LT.NS, NO COEFFICIENTS CHANGE +C + IF(H .NE. HOLD) NS = 0 + IF (NS.LE.KOLD) NS = NS+1 + NSP1 = NS+1 + IF (K .LT. NS) GO TO 199 +C +C COMPUTE THOSE COMPONENTS OF ALPHA(*),BETA(*),PSI(*),SIG(*) WHICH +C ARE CHANGED +C + BETA(NS) = 1.0D0 + REALNS = NS + ALPHA(NS) = 1.0D0/REALNS + TEMP1 = H*REALNS + SIG(NSP1) = 1.0D0 + IF(K .LT. NSP1) GO TO 110 + DO 105 I = NSP1,K + IM1 = I-1 + TEMP2 = PSI(IM1) + PSI(IM1) = TEMP1 + BETA(I) = BETA(IM1)*PSI(IM1)/TEMP2 + TEMP1 = TEMP2 + H + ALPHA(I) = H/TEMP1 + REALI = I + 105 SIG(I+1) = REALI*ALPHA(I)*SIG(I) + 110 PSI(K) = TEMP1 +C +C COMPUTE COEFFICIENTS G(*) +C +C INITIALIZE V(*) AND SET W(*). +C + IF(NS .GT. 1) GO TO 120 + DO 115 IQ = 1,K + TEMP3 = IQ*(IQ+1) + V(IQ) = 1.0D0/TEMP3 + 115 W(IQ) = V(IQ) + IVC = 0 + KGI = 0 + IF (K .EQ. 1) GO TO 140 + KGI = 1 + GI(1) = W(2) + GO TO 140 +C +C IF ORDER WAS RAISED, UPDATE DIAGONAL PART OF V(*) +C + 120 IF(K .LE. KPREV) GO TO 130 + IF (IVC .EQ. 0) GO TO 122 + JV = KP1 - IV(IVC) + IVC = IVC - 1 + GO TO 123 + 122 JV = 1 + TEMP4 = K*KP1 + V(K) = 1.0D0/TEMP4 + W(K) = V(K) + IF (K .NE. 2) GO TO 123 + KGI = 1 + GI(1) = W(2) + 123 NSM2 = NS-2 + IF(NSM2 .LT. JV) GO TO 130 + DO 125 J = JV,NSM2 + I = K-J + V(I) = V(I) - ALPHA(J+1)*V(I+1) + 125 W(I) = V(I) + IF (I .NE. 2) GO TO 130 + KGI = NS - 1 + GI(KGI) = W(2) +C +C UPDATE V(*) AND SET W(*) +C + 130 LIMIT1 = KP1 - NS + TEMP5 = ALPHA(NS) + DO 135 IQ = 1,LIMIT1 + V(IQ) = V(IQ) - TEMP5*V(IQ+1) + 135 W(IQ) = V(IQ) + G(NSP1) = W(1) + IF (LIMIT1 .EQ. 1) GO TO 137 + KGI = NS + GI(KGI) = W(2) + 137 W(LIMIT1+1) = V(LIMIT1+1) + IF (K .GE. KOLD) GO TO 140 + IVC = IVC + 1 + IV(IVC) = LIMIT1 + 2 +C +C COMPUTE THE G(*) IN THE WORK VECTOR W(*) +C + 140 NSP2 = NS + 2 + KPREV = K + IF(KP1 .LT. NSP2) GO TO 199 + DO 150 I = NSP2,KP1 + LIMIT2 = KP2 - I + TEMP6 = ALPHA(I-1) + DO 145 IQ = 1,LIMIT2 + 145 W(IQ) = W(IQ) - TEMP6*W(IQ+1) + 150 G(I) = W(1) + 199 CONTINUE +C *** END BLOCK 1 *** +C +C *** BEGIN BLOCK 2 *** +C PREDICT A SOLUTION P(*), EVALUATE DERIVATIVES USING PREDICTED +C SOLUTION, ESTIMATE LOCAL ERROR AT ORDER K AND ERRORS AT ORDERS K, +C K-1, K-2 AS IF CONSTANT STEP SIZE WERE USED. +C *** +C +C INCREMENT COUNTER ON ATTEMPTED DSTEPS +C + KSTEPS = KSTEPS + 1 +C +C CHANGE PHI TO PHI STAR +C + IF(K .LT. NSP1) GO TO 215 + DO 210 I = NSP1,K + TEMP1 = BETA(I) + DO 205 L = 1,NEQN + 205 PHI(L,I) = TEMP1*PHI(L,I) + 210 CONTINUE +C +C PREDICT SOLUTION AND DIFFERENCES +C + 215 DO 220 L = 1,NEQN + PHI(L,KP2) = PHI(L,KP1) + PHI(L,KP1) = 0.0D0 + 220 P(L) = 0.0D0 + DO 230 J = 1,K + I = KP1 - J + IP1 = I+1 + TEMP2 = G(I) + DO 225 L = 1,NEQN + P(L) = P(L) + TEMP2*PHI(L,I) + 225 PHI(L,I) = PHI(L,I) + PHI(L,IP1) + 230 CONTINUE + IF(NORND) GO TO 240 + DO 235 L = 1,NEQN + TAU = H*P(L) - PHI(L,15) + P(L) = Y(L) + TAU + 235 PHI(L,16) = (P(L) - Y(L)) - TAU + GO TO 250 + 240 DO 245 L = 1,NEQN + 245 P(L) = Y(L) + H*P(L) + 250 XOLD = X + X = X + H + ABSH = ABS(H) + CALL DF(X,P,YP,RPAR,IPAR) +C +C ESTIMATE ERRORS AT ORDERS K,K-1,K-2 +C + ERKM2 = 0.0D0 + ERKM1 = 0.0D0 + ERK = 0.0D0 + DO 265 L = 1,NEQN + TEMP3 = 1.0D0/WT(L) + TEMP4 = YP(L) - PHI(L,1) + IF(KM2)265,260,255 + 255 ERKM2 = ERKM2 + ((PHI(L,KM1)+TEMP4)*TEMP3)**2 + 260 ERKM1 = ERKM1 + ((PHI(L,K)+TEMP4)*TEMP3)**2 + 265 ERK = ERK + (TEMP4*TEMP3)**2 + IF(KM2)280,275,270 + 270 ERKM2 = ABSH*SIG(KM1)*GSTR(KM2)*SQRT(ERKM2) + 275 ERKM1 = ABSH*SIG(K)*GSTR(KM1)*SQRT(ERKM1) + 280 TEMP5 = ABSH*SQRT(ERK) + ERR = TEMP5*(G(K)-G(KP1)) + ERK = TEMP5*SIG(KP1)*GSTR(K) + KNEW = K +C +C TEST IF ORDER SHOULD BE LOWERED +C + IF(KM2)299,290,285 + 285 IF(MAX(ERKM1,ERKM2) .LE. ERK) KNEW = KM1 + GO TO 299 + 290 IF(ERKM1 .LE. 0.5D0*ERK) KNEW = KM1 +C +C TEST IF STEP SUCCESSFUL +C + 299 IF(ERR .LE. EPS) GO TO 400 +C *** END BLOCK 2 *** +C +C *** BEGIN BLOCK 3 *** +C THE STEP IS UNSUCCESSFUL. RESTORE X, PHI(*,*), PSI(*) . +C IF THIRD CONSECUTIVE FAILURE, SET ORDER TO ONE. IF STEP FAILS MORE +C THAN THREE TIMES, CONSIDER AN OPTIMAL STEP SIZE. DOUBLE ERROR +C TOLERANCE AND RETURN IF ESTIMATED STEP SIZE IS TOO SMALL FOR MACHINE +C PRECISION. +C *** +C +C RESTORE X, PHI(*,*) AND PSI(*) +C + PHASE1 = .FALSE. + X = XOLD + DO 310 I = 1,K + TEMP1 = 1.0D0/BETA(I) + IP1 = I+1 + DO 305 L = 1,NEQN + 305 PHI(L,I) = TEMP1*(PHI(L,I) - PHI(L,IP1)) + 310 CONTINUE + IF(K .LT. 2) GO TO 320 + DO 315 I = 2,K + 315 PSI(I-1) = PSI(I) - H +C +C ON THIRD FAILURE, SET ORDER TO ONE. THEREAFTER, USE OPTIMAL STEP +C SIZE +C + 320 IFAIL = IFAIL + 1 + TEMP2 = 0.5D0 + IF(IFAIL - 3) 335,330,325 + 325 IF(P5EPS .LT. 0.25D0*ERK) TEMP2 = SQRT(P5EPS/ERK) + 330 KNEW = 1 + 335 H = TEMP2*H + K = KNEW + NS = 0 + IF(ABS(H) .GE. FOURU*ABS(X)) GO TO 340 + CRASH = .TRUE. + H = SIGN(FOURU*ABS(X),H) + EPS = EPS + EPS + RETURN + 340 GO TO 100 +C *** END BLOCK 3 *** +C +C *** BEGIN BLOCK 4 *** +C THE STEP IS SUCCESSFUL. CORRECT THE PREDICTED SOLUTION, EVALUATE +C THE DERIVATIVES USING THE CORRECTED SOLUTION AND UPDATE THE +C DIFFERENCES. DETERMINE BEST ORDER AND STEP SIZE FOR NEXT STEP. +C *** + 400 KOLD = K + HOLD = H +C +C CORRECT AND EVALUATE +C + TEMP1 = H*G(KP1) + IF(NORND) GO TO 410 + DO 405 L = 1,NEQN + TEMP3 = Y(L) + RHO = TEMP1*(YP(L) - PHI(L,1)) - PHI(L,16) + Y(L) = P(L) + RHO + PHI(L,15) = (Y(L) - P(L)) - RHO + 405 P(L) = TEMP3 + GO TO 420 + 410 DO 415 L = 1,NEQN + TEMP3 = Y(L) + Y(L) = P(L) + TEMP1*(YP(L) - PHI(L,1)) + 415 P(L) = TEMP3 + 420 CALL DF(X,Y,YP,RPAR,IPAR) +C +C UPDATE DIFFERENCES FOR NEXT STEP +C + DO 425 L = 1,NEQN + PHI(L,KP1) = YP(L) - PHI(L,1) + 425 PHI(L,KP2) = PHI(L,KP1) - PHI(L,KP2) + DO 435 I = 1,K + DO 430 L = 1,NEQN + 430 PHI(L,I) = PHI(L,I) + PHI(L,KP1) + 435 CONTINUE +C +C ESTIMATE ERROR AT ORDER K+1 UNLESS: +C IN FIRST PHASE WHEN ALWAYS RAISE ORDER, +C ALREADY DECIDED TO LOWER ORDER, +C STEP SIZE NOT CONSTANT SO ESTIMATE UNRELIABLE +C + ERKP1 = 0.0D0 + IF(KNEW .EQ. KM1 .OR. K .EQ. 12) PHASE1 = .FALSE. + IF(PHASE1) GO TO 450 + IF(KNEW .EQ. KM1) GO TO 455 + IF(KP1 .GT. NS) GO TO 460 + DO 440 L = 1,NEQN + 440 ERKP1 = ERKP1 + (PHI(L,KP2)/WT(L))**2 + ERKP1 = ABSH*GSTR(KP1)*SQRT(ERKP1) +C +C USING ESTIMATED ERROR AT ORDER K+1, DETERMINE APPROPRIATE ORDER +C FOR NEXT STEP +C + IF(K .GT. 1) GO TO 445 + IF(ERKP1 .GE. 0.5D0*ERK) GO TO 460 + GO TO 450 + 445 IF(ERKM1 .LE. MIN(ERK,ERKP1)) GO TO 455 + IF(ERKP1 .GE. ERK .OR. K .EQ. 12) GO TO 460 +C +C HERE ERKP1 .LT. ERK .LT. MAX(ERKM1,ERKM2) ELSE ORDER WOULD HAVE +C BEEN LOWERED IN BLOCK 2. THUS ORDER IS TO BE RAISED +C +C RAISE ORDER +C + 450 K = KP1 + ERK = ERKP1 + GO TO 460 +C +C LOWER ORDER +C + 455 K = KM1 + ERK = ERKM1 +C +C WITH NEW ORDER DETERMINE APPROPRIATE STEP SIZE FOR NEXT STEP +C + 460 HNEW = H + H + IF(PHASE1) GO TO 465 + IF(P5EPS .GE. ERK*TWO(K+1)) GO TO 465 + HNEW = H + IF(P5EPS .GE. ERK) GO TO 465 + TEMP2 = K+1 + R = (P5EPS/ERK)**(1.0D0/TEMP2) + HNEW = ABSH*MAX(0.5D0,MIN(0.9D0,R)) + HNEW = SIGN(MAX(HNEW,FOURU*ABS(X)),H) + 465 H = HNEW + RETURN +C *** END BLOCK 4 *** + END +*DECK FDUMP + SUBROUTINE FDUMP +C***BEGIN PROLOGUE FDUMP +C***PURPOSE Symbolic dump (should be locally written). +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (FDUMP-A) +C***KEYWORDS ERROR, XERMSG +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C ***Note*** Machine Dependent Routine +C FDUMP is intended to be replaced by a locally written +C version which produces a symbolic dump. Failing this, +C it should be replaced by a version which prints the +C subprogram nesting list. Note that this dump must be +C printed on each of up to five files, as indicated by the +C XGETUA routine. See XSETUA and XGETUA for details. +C +C Written by Ron Jones, with SLATEC Common Math Library Subcommittee +C +C***REFERENCES (NONE) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE FDUMP +C***FIRST EXECUTABLE STATEMENT FDUMP + RETURN + END +*DECK I1MACH + INTEGER FUNCTION I1MACH (I) +C***BEGIN PROLOGUE I1MACH +C***PURPOSE Return integer machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE INTEGER (I1MACH-I) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C I1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument and can be referenced as follows: +C +C K = I1MACH(I) +C +C where I=1,...,16. The (output) value of K above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C I/O unit numbers: +C I1MACH( 1) = the standard input unit. +C I1MACH( 2) = the standard output unit. +C I1MACH( 3) = the standard punch unit. +C I1MACH( 4) = the standard error message unit. +C +C Words: +C I1MACH( 5) = the number of bits per integer storage unit. +C I1MACH( 6) = the number of characters per integer storage unit. +C +C Integers: +C assume integers are represented in the S-digit, base-A form +C +C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C where 0 .LE. X(I) .LT. A for I=0,...,S-1. +C I1MACH( 7) = A, the base. +C I1MACH( 8) = S, the number of base-A digits. +C I1MACH( 9) = A**S - 1, the largest magnitude. +C +C Floating-Point Numbers: +C Assume floating-point numbers are represented in the T-digit, +C base-B form +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, +C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, the base. +C +C Single-Precision: +C I1MACH(11) = T, the number of base-B digits. +C I1MACH(12) = EMIN, the smallest exponent E. +C I1MACH(13) = EMAX, the largest exponent E. +C +C Double-Precision: +C I1MACH(14) = T, the number of base-B digits. +C I1MACH(15) = EMIN, the smallest exponent E. +C I1MACH(16) = EMAX, the largest exponent E. +C +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 891012 Added VAX G-floating constants. (WRB) +C 891012 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. +C (RWC) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added Convex -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler +C options. (DWL, RWC and WRB). +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE I1MACH +C +C Initial data here correspond to the IEEE standard. If one of the +C sets of initial data below is preferred, do the necessary commenting +C and uncommenting. (DWL) + INTEGER IMACH(16),OUTPUT + DATA IMACH( 1) / 5 / + DATA IMACH( 2) / 6 / + DATA IMACH( 3) / 6 / + DATA IMACH( 4) / 6 / + DATA IMACH( 5) / 32 / + DATA IMACH( 6) / 4 / + DATA IMACH( 7) / 2 / + DATA IMACH( 8) / 31 / + DATA IMACH( 9) / 2147483647 / + DATA IMACH(10) / 2 / + DATA IMACH(11) / 24 / + DATA IMACH(12) / -126 / + DATA IMACH(13) / 127 / + DATA IMACH(14) / 53 / + DATA IMACH(15) / -1022 / + DATA IMACH(16) / 1023 / + SAVE IMACH +cc EQUIVALENCE (IMACH(4),OUTPUT) +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 129 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1025 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA IMACH( 1) / 7 / +C DATA IMACH( 2) / 2 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 33 / +C DATA IMACH( 9) / Z1FFFFFFFF / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -256 / +C DATA IMACH(13) / 255 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -256 / +C DATA IMACH(16) / 255 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -50 / +C DATA IMACH(16) / 76 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -32754 / +C DATA IMACH(16) / 32780 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -4095 / +C DATA IMACH(13) / 4094 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -4095 / +C DATA IMACH(16) / 4094 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6LOUTPUT/ +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / 00007777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z'7FFFFFFF' / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16383 / +C DATA IMACH(16) / 16383 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -pd8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 46 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 46 / +C DATA IMACH( 9) / 1777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 64 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 777777777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C +C DATA IMACH( 1) / 11 / +C DATA IMACH( 2) / 12 / +C DATA IMACH( 3) / 8 / +C DATA IMACH( 4) / 10 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / 3 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 23 / +C DATA IMACH( 9) / 8388607 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 38 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 43 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 39 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 55 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 7 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1015 / +C DATA IMACH(16) / 1017 / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z7FFFFFFF / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE IBM PC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 54 / +C DATA IMACH(15) / -101 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 62 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1021 / +C DATA IMACH(13) / 1024 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16381 / +C DATA IMACH(16) / 16384 / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 1 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -1024 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR +C +C DATA IMACH( 1) / 1 / +C DATA IMACH( 2) / 1 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C***FIRST EXECUTABLE STATEMENT I1MACH + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) + RETURN +C + 10 CONTINUE + WRITE (UNIT = OUTPUT, FMT = 9000) + 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') +C +C CALL FDUMP +C + STOP + END +*DECK DHSTRT + SUBROUTINE DHSTRT (DF, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, + + BIG, SPY, PV, YP, SF, RPAR, IPAR, H) +C***BEGIN PROLOGUE DHSTRT +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (HSTART-S, DHSTRT-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DHSTRT computes a starting step size to be used in solving initial +C value problems in ordinary differential equations. +C +C ********************************************************************** +C ABSTRACT +C +C Subroutine DHSTRT computes a starting step size to be used by an +C initial value method in solving ordinary differential equations. +C It is based on an estimate of the local Lipschitz constant for the +C differential equation (lower bound on a norm of the Jacobian) , +C a bound on the differential equation (first derivative) , and +C a bound on the partial derivative of the equation with respect to +C the independent variable. +C (all approximated near the initial point A) +C +C Subroutine DHSTRT uses a function subprogram DHVNRM for computing +C a vector norm. The maximum norm is presently utilized though it +C can easily be replaced by any other vector norm. It is presumed +C that any replacement norm routine would be carefully coded to +C prevent unnecessary underflows or overflows from occurring, and +C also, would not alter the vector or number of components. +C +C ********************************************************************** +C On input you must provide the following +C +C DF -- This is a subroutine of the form +C DF(X,U,UPRIME,RPAR,IPAR) +C which defines the system of first order differential +C equations to be solved. For the given values of X and the +C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must +C evaluate the NEQ components of the system of differential +C equations DU/DX=DF(X,U) and store the derivatives in the +C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for +C equations I=1,...,NEQ. +C +C Subroutine DF must not alter X or U(*). You must declare +C the name DF in an external statement in your program that +C calls DHSTRT. You must dimension U and UPRIME in DF. +C +C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C program and subroutine DF. They are not used or altered by +C DHSTRT. If you do not need RPAR or IPAR, ignore these +C parameters by treating them as dummy arguments. If you do +C choose to use them, dimension them in your program and in +C DF as arrays of appropriate length. +C +C NEQ -- This is the number of (first order) differential equations +C to be integrated. +C +C A -- This is the initial point of integration. +C +C B -- This is a value of the independent variable used to define +C the direction of integration. A reasonable choice is to +C set B to the first point at which a solution is desired. +C You can also use B, if necessary, to restrict the length +C of the first integration step because the algorithm will +C not compute a starting step length which is bigger than +C ABS(B-A), unless B has been chosen too close to A. +C (it is presumed that DHSTRT has been called with B +C different from A on the machine being used. Also see the +C discussion about the parameter SMALL.) +C +C Y(*) -- This is the vector of initial values of the NEQ solution +C components at the initial point A. +C +C YPRIME(*) -- This is the vector of derivatives of the NEQ +C solution components at the initial point A. +C (defined by the differential equations in subroutine DF) +C +C ETOL -- This is the vector of error tolerances corresponding to +C the NEQ solution components. It is assumed that all +C elements are positive. Following the first integration +C step, the tolerances are expected to be used by the +C integrator in an error test which roughly requires that +C ABS(LOCAL ERROR) .LE. ETOL +C for each vector component. +C +C MORDER -- This is the order of the formula which will be used by +C the initial value method for taking the first integration +C step. +C +C SMALL -- This is a small positive machine dependent constant +C which is used for protecting against computations with +C numbers which are too small relative to the precision of +C floating point arithmetic. SMALL should be set to +C (approximately) the smallest positive DOUBLE PRECISION +C number such that (1.+SMALL) .GT. 1. on the machine being +C used. The quantity SMALL**(3/8) is used in computing +C increments of variables for approximating derivatives by +C differences. Also the algorithm will not compute a +C starting step length which is smaller than +C 100*SMALL*ABS(A). +C +C BIG -- This is a large positive machine dependent constant which +C is used for preventing machine overflows. A reasonable +C choice is to set big to (approximately) the square root of +C the largest DOUBLE PRECISION number which can be held in +C the machine. +C +C SPY(*),PV(*),YP(*),SF(*) -- These are DOUBLE PRECISION work +C arrays of length NEQ which provide the routine with needed +C storage space. +C +C RPAR,IPAR -- These are parameter arrays, of DOUBLE PRECISION and +C INTEGER type, respectively, which can be used for +C communication between your program and the DF subroutine. +C They are not used or altered by DHSTRT. +C +C ********************************************************************** +C On Output (after the return from DHSTRT), +C +C H -- is an appropriate starting step size to be attempted by the +C differential equation method. +C +C All parameters in the call list remain unchanged except for +C the working arrays SPY(*),PV(*),YP(*), and SF(*). +C +C ********************************************************************** +C +C***SEE ALSO DDEABM, DDEBDF, DDERKF +C***ROUTINES CALLED DHVNRM +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DHSTRT +C + INTEGER IPAR, J, K, LK, MORDER, NEQ + DOUBLE PRECISION A, ABSDX, B, BIG, DA, DELF, DELY, + 1 DFDUB, DFDXB, DHVNRM, + 2 DX, DY, ETOL, FBND, H, PV, RELPER, RPAR, SF, SMALL, SPY, + 3 SRYDPB, TOLEXP, TOLMIN, TOLP, TOLSUM, Y, YDPB, YP, YPRIME + DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*), + 1 SF(*),RPAR(*),IPAR(*) + EXTERNAL DF +C +C .................................................................. +C +C BEGIN BLOCK PERMITTING ...EXITS TO 160 +C***FIRST EXECUTABLE STATEMENT DHSTRT + DX = B - A + ABSDX = ABS(DX) + RELPER = SMALL**0.375D0 +C +C ............................................................... +C +C COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL +C DERIVATIVE OF THE EQUATION WITH RESPECT TO THE +C INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. +C ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE +C LOCALLY. +C + DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX), + 1 100.0D0*SMALL*ABS(A)),DX) + IF (DA .EQ. 0.0D0) DA = RELPER*DX + CALL DF(A+DA,Y,SF,RPAR,IPAR) + DO 10 J = 1, NEQ + YP(J) = SF(J) - YPRIME(J) + 10 CONTINUE + DELF = DHVNRM(YP,NEQ) + DFDXB = BIG + IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA) + FBND = DHVNRM(SF,NEQ) +C +C ............................................................... +C +C COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ +C CONSTANT FOR THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS +C ALSO REPRESENTS AN ESTIMATE OF THE NORM OF THE JACOBIAN +C LOCALLY. THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO +C ESTIMATE THE LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. +C THE FIRST PERTURBATION VECTOR IS BASED ON THE INITIAL +C DERIVATIVES AND DIRECTION OF INTEGRATION. THE SECOND +C PERTURBATION VECTOR IS FORMED USING ANOTHER EVALUATION OF +C THE DIFFERENTIAL EQUATION. THE THIRD PERTURBATION VECTOR +C IS FORMED USING PERTURBATIONS BASED ONLY ON THE INITIAL +C VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS CHANGED TO +C NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN +C INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT +C COMPONENTS OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE +C CONSISTENT WITH THE SLOPES OF LOCAL SOLUTION CURVES. +C ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST +C DERIVATIVE. +C +C PERTURBATION VECTOR SIZE IS HELD +C CONSTANT FOR ALL ITERATIONS. COMPUTE +C THIS CHANGE FROM THE +C SIZE OF THE VECTOR OF INITIAL +C VALUES. + DELY = RELPER*DHVNRM(Y,NEQ) + IF (DELY .EQ. 0.0D0) DELY = RELPER + DELY = SIGN(DELY,DX) + DELF = DHVNRM(YPRIME,NEQ) + FBND = MAX(FBND,DELF) + IF (DELF .EQ. 0.0D0) GO TO 30 +C USE INITIAL DERIVATIVES FOR FIRST PERTURBATION + DO 20 J = 1, NEQ + SPY(J) = YPRIME(J) + YP(J) = YPRIME(J) + 20 CONTINUE + GO TO 50 + 30 CONTINUE +C CANNOT HAVE A NULL PERTURBATION VECTOR + DO 40 J = 1, NEQ + SPY(J) = 0.0D0 + YP(J) = 1.0D0 + 40 CONTINUE + DELF = DHVNRM(YP,NEQ) + 50 CONTINUE +C + DFDUB = 0.0D0 + LK = MIN(NEQ+1,3) + DO 140 K = 1, LK +C DEFINE PERTURBED VECTOR OF INITIAL VALUES + DO 60 J = 1, NEQ + PV(J) = Y(J) + DELY*(YP(J)/DELF) + 60 CONTINUE + IF (K .EQ. 2) GO TO 80 +C EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED +C VECTOR AND COMPUTE CORRESPONDING DIFFERENCES + CALL DF(A,PV,YP,RPAR,IPAR) + DO 70 J = 1, NEQ + PV(J) = YP(J) - YPRIME(J) + 70 CONTINUE + GO TO 100 + 80 CONTINUE +C USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE +C IN COMPUTING ONE ESTIMATE + CALL DF(A+DA,PV,YP,RPAR,IPAR) + DO 90 J = 1, NEQ + PV(J) = YP(J) - SF(J) + 90 CONTINUE + 100 CONTINUE +C CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE +C AND A LOCAL LIPSCHITZ CONSTANT + FBND = MAX(FBND,DHVNRM(YP,NEQ)) + DELF = DHVNRM(PV,NEQ) +C ...EXIT + IF (DELF .GE. BIG*ABS(DELY)) GO TO 150 + DFDUB = MAX(DFDUB,DELF/ABS(DELY)) +C ......EXIT + IF (K .EQ. LK) GO TO 160 +C CHOOSE NEXT PERTURBATION VECTOR + IF (DELF .EQ. 0.0D0) DELF = 1.0D0 + DO 130 J = 1, NEQ + IF (K .EQ. 2) GO TO 110 + DY = ABS(PV(J)) + IF (DY .EQ. 0.0D0) DY = DELF + GO TO 120 + 110 CONTINUE + DY = Y(J) + IF (DY .EQ. 0.0D0) DY = DELY/RELPER + 120 CONTINUE + IF (SPY(J) .EQ. 0.0D0) SPY(J) = YP(J) + IF (SPY(J) .NE. 0.0D0) DY = SIGN(DY,SPY(J)) + YP(J) = DY + 130 CONTINUE + DELF = DHVNRM(YP,NEQ) + 140 CONTINUE + 150 CONTINUE +C +C PROTECT AGAINST AN OVERFLOW + DFDUB = BIG + 160 CONTINUE +C +C .................................................................. +C +C COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE +C + YDPB = DFDXB + DFDUB*FBND +C +C .................................................................. +C +C DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP +C SIZE IS TO BE BASED. A VALUE IN THE MIDDLE OF THE ERROR +C TOLERANCE RANGE IS SELECTED. +C + TOLMIN = BIG + TOLSUM = 0.0D0 + DO 170 K = 1, NEQ + TOLEXP = LOG10(ETOL(K)) + TOLMIN = MIN(TOLMIN,TOLEXP) + TOLSUM = TOLSUM + TOLEXP + 170 CONTINUE + TOLP = 10.0D0**(0.5D0*(TOLSUM/NEQ + TOLMIN)/(MORDER+1)) +C +C .................................................................. +C +C COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND +C SECOND DERIVATIVE INFORMATION +C +C RESTRICT THE STEP LENGTH TO BE NOT BIGGER +C THAN ABS(B-A). (UNLESS B IS TOO CLOSE +C TO A) + H = ABSDX +C + IF (YDPB .NE. 0.0D0 .OR. FBND .NE. 0.0D0) GO TO 180 +C +C BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND +C DERIVATIVE TERM (YDPB) ARE ZERO + IF (TOLP .LT. 1.0D0) H = ABSDX*TOLP + GO TO 200 + 180 CONTINUE +C + IF (YDPB .NE. 0.0D0) GO TO 190 +C +C ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO + IF (TOLP .LT. FBND*ABSDX) H = TOLP/FBND + GO TO 200 + 190 CONTINUE +C +C SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO + SRYDPB = SQRT(0.5D0*YDPB) + IF (TOLP .LT. SRYDPB*ABSDX) H = TOLP/SRYDPB + 200 CONTINUE +C +C FURTHER RESTRICT THE STEP LENGTH TO BE NOT +C BIGGER THAN 1/DFDUB + IF (H*DFDUB .GT. 1.0D0) H = 1.0D0/DFDUB +C +C FINALLY, RESTRICT THE STEP LENGTH TO BE NOT +C SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF +C A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, +C THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE +C STEP LENGTH. + H = MAX(H,100.0D0*SMALL*ABS(A)) + IF (H .EQ. 0.0D0) H = SMALL*ABS(B) +C +C NOW SET DIRECTION OF INTEGRATION + H = SIGN(H,DX) +C + RETURN + END +*DECK DHVNRM + DOUBLE PRECISION FUNCTION DHVNRM (V, NCOMP) +C***BEGIN PROLOGUE DHVNRM +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (HVNRM-S, DHVNRM-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C Compute the maximum norm of the vector V(*) of length NCOMP and +C return the result as DHVNRM +C +C***SEE ALSO DDEABM, DDEBDF, DDERKF +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891024 Changed routine name from DVNORM to DHVNRM. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DHVNRM +C + INTEGER K, NCOMP + DOUBLE PRECISION V + DIMENSION V(*) +C***FIRST EXECUTABLE STATEMENT DHVNRM + DHVNRM = 0.0D0 + DO 10 K = 1, NCOMP + DHVNRM = MAX(DHVNRM,ABS(V(K))) + 10 CONTINUE + RETURN + END +*DECK J4SAVE + FUNCTION J4SAVE (IWHICH, IVALUE, ISET) +C***BEGIN PROLOGUE J4SAVE +C***SUBSIDIARY +C***PURPOSE Save or recall global variables needed by error +C handling routines. +C***LIBRARY SLATEC (XERROR) +C***TYPE INTEGER (J4SAVE-I) +C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C J4SAVE saves and recalls several global variables needed +C by the library error handling routines. +C +C Description of Parameters +C --Input-- +C IWHICH - Index of item desired. +C = 1 Refers to current error number. +C = 2 Refers to current error control flag. +C = 3 Refers to current unit number to which error +C messages are to be sent. (0 means use standard.) +C = 4 Refers to the maximum number of times any +C message is to be printed (as set by XERMAX). +C = 5 Refers to the total number of units to which +C each error message is to be written. +C = 6 Refers to the 2nd unit for error messages +C = 7 Refers to the 3rd unit for error messages +C = 8 Refers to the 4th unit for error messages +C = 9 Refers to the 5th unit for error messages +C IVALUE - The value to be set for the IWHICH-th parameter, +C if ISET is .TRUE. . +C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE +C given the value, IVALUE. If ISET=.FALSE., the +C IWHICH-th parameter will be unchanged, and IVALUE +C is a dummy parameter. +C --Output-- +C The (old) value of the IWHICH-th parameter will be returned +C in the function value, J4SAVE. +C +C***SEE ALSO XERMSG +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900205 Minor modifications to prologue. (WRB) +C 900402 Added TYPE section. (WRB) +C 910411 Added KEYWORDS section. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE J4SAVE + LOGICAL ISET + INTEGER IPARAM(9) + SAVE IPARAM + DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ + DATA IPARAM(5)/1/ + DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ +C***FIRST EXECUTABLE STATEMENT J4SAVE + J4SAVE = IPARAM(IWHICH) + IF (ISET) IPARAM(IWHICH) = IVALUE + RETURN + END +*DECK XERCNT + SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) +C***BEGIN PROLOGUE XERCNT +C***SUBSIDIARY +C***PURPOSE Allow user control over handling of errors. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERCNT-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C Allows user control over handling of individual errors. +C Just after each message is recorded, but before it is +C processed any further (i.e., before it is printed or +C a decision to abort is made), a call is made to XERCNT. +C If the user has provided his own version of XERCNT, he +C can then override the value of KONTROL used in processing +C this message by redefining its value. +C KONTRL may be set to any value from -2 to 2. +C The meanings for KONTRL are the same as in XSETF, except +C that the value of KONTRL changes only for this message. +C If KONTRL is set to a value outside the range from -2 to 2, +C it will be moved back into that range. +C +C Description of Parameters +C +C --Input-- +C LIBRAR - the library that the routine is in. +C SUBROU - the subroutine that XERMSG is being called from +C MESSG - the first 20 characters of the error message. +C NERR - same as in the call to XERMSG. +C LEVEL - same as in the call to XERMSG. +C KONTRL - the current value of the control flag as set +C by a call to XSETF. +C +C --Output-- +C KONTRL - the new value of KONTRL. If KONTRL is not +C defined, it will remain at its original value. +C This changed value of control affects only +C the current occurrence of the current message. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE +C names, changed routine name from XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERCNT + CHARACTER*(*) LIBRAR, SUBROU, MESSG +C***FIRST EXECUTABLE STATEMENT XERCNT + RETURN + END +*DECK XERHLT + SUBROUTINE XERHLT (MESSG) +C***BEGIN PROLOGUE XERHLT +C***SUBSIDIARY +C***PURPOSE Abort program execution and print error message. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERHLT-A) +C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C ***Note*** machine dependent routine +C XERHLT aborts the execution of the program. +C The error message causing the abort is given in the calling +C sequence, in case one needs it for printing on a dayfile, +C for example. +C +C Description of Parameters +C MESSG is as in XERMSG. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to delete length of character +C and changed routine name from XERABT to XERHLT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERHLT + CHARACTER*(*) MESSG +C***FIRST EXECUTABLE STATEMENT XERHLT + STOP + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/ddebdf.f calculix-ccx-2.3/ccx_2.3/src/ddebdf.f --- calculix-ccx-2.1/ccx_2.3/src/ddebdf.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ddebdf.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,3308 @@ +*DECK DDEBDF + SUBROUTINE DDEBDF (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, + + RWORK, LRW, IWORK, LIW, RPAR, IPAR, DJAC) +C***BEGIN PROLOGUE DDEBDF +C***PURPOSE Solve an initial value problem in ordinary differential +C equations using backward differentiation formulas. It is +C intended primarily for stiff problems. +C***LIBRARY SLATEC (DEPAC) +C***CATEGORY I1A2 +C***TYPE DOUBLE PRECISION (DEBDF-S, DDEBDF-D) +C***KEYWORDS BACKWARD DIFFERENTIATION FORMULAS, DEPAC, +C INITIAL VALUE PROBLEMS, ODE, +C ORDINARY DIFFERENTIAL EQUATIONS, STIFF +C***AUTHOR Shampine, L. F., (SNLA) +C Watts, H. A., (SNLA) +C***DESCRIPTION +C +C This is the backward differentiation code in the package of +C differential equation solvers DEPAC, consisting of the codes +C DDERKF, DDEABM, and DDEBDF. Design of the package was by +C L. F. Shampine and H. A. Watts. It is documented in +C SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE +C Solvers. +C DDEBDF is a driver for a modification of the code LSODE written by +C A. C. Hindmarsh +C Lawrence Livermore Laboratory +C Livermore, California 94550 +C +C ********************************************************************** +C ** DEPAC PACKAGE OVERVIEW ** +C ********************************************************************** +C +C You have a choice of three differential equation solvers from +C DEPAC. The following brief descriptions are meant to aid you +C in choosing the most appropriate code for your problem. +C +C DDERKF is a fifth order Runge-Kutta code. It is the simplest of +C the three choices, both algorithmically and in the use of the +C code. DDERKF is primarily designed to solve non-stiff and mild- +C ly stiff differential equations when derivative evaluations are +C not expensive. It should generally not be used to get high +C accuracy results nor answers at a great many specific points. +C Because DDERKF has very low overhead costs, it will usually +C result in the least expensive integration when solving +C problems requiring a modest amount of accuracy and having +C equations that are not costly to evaluate. DDERKF attempts to +C discover when it is not suitable for the task posed. +C +C DDEABM is a variable order (one through twelve) Adams code. Its +C complexity lies somewhere between that of DDERKF and DDEBDF. +C DDEABM is primarily designed to solve non-stiff and mildly +C stiff differential equations when derivative evaluations are +C expensive, high accuracy results are needed or answers at +C many specific points are required. DDEABM attempts to discover +C when it is not suitable for the task posed. +C +C DDEBDF is a variable order (one through five) backward +C differentiation formula code. It is the most complicated of +C the three choices. DDEBDF is primarily designed to solve stiff +C differential equations at crude to moderate tolerances. +C If the problem is very stiff at all, DDERKF and DDEABM will be +C quite inefficient compared to DDEBDF. However, DDEBDF will be +C inefficient compared to DDERKF and DDEABM on non-stiff problems +C because it uses much more storage, has a much larger overhead, +C and the low order formulas will not give high accuracies +C efficiently. +C +C The concept of stiffness cannot be described in a few words. +C If you do not know the problem to be stiff, try either DDERKF +C or DDEABM. Both of these codes will inform you of stiffness +C when the cost of solving such problems becomes important. +C +C ********************************************************************** +C ** ABSTRACT ** +C ********************************************************************** +C +C Subroutine DDEBDF uses the backward differentiation formulas of +C orders one through five to integrate a system of NEQ first order +C ordinary differential equations of the form +C DU/DX = DF(X,U) +C when the vector Y(*) of initial values for U(*) at X=T is given. +C The subroutine integrates from T to TOUT. It is easy to continue the +C integration to get results at additional TOUT. This is the interval +C mode of operation. It is also easy for the routine to return with +C the solution at each intermediate step on the way to TOUT. This is +C the intermediate-output mode of operation. +C +C ********************************************************************** +C * Description of The Arguments To DDEBDF (An Overview) * +C ********************************************************************** +C +C The Parameters are: +C +C DF -- This is the name of a subroutine which you provide to +C define the differential equations. +C +C NEQ -- This is the number of (first order) differential +C equations to be integrated. +C +C T -- This is a DOUBLE PRECISION value of the independent +C variable. +C +C Y(*) -- This DOUBLE PRECISION array contains the solution +C components at T. +C +C TOUT -- This is a DOUBLE PRECISION point at which a solution is +C desired. +C +C INFO(*) -- The basic task of the code is to integrate the +C differential equations from T to TOUT and return an +C answer at TOUT. INFO(*) is an INTEGER array which is used +C to communicate exactly how you want this task to be +C carried out. +C +C RTOL, ATOL -- These DOUBLE PRECISION quantities +C represent relative and absolute error tolerances which you +C provide to indicate how accurately you wish the solution +C to be computed. You may choose them to be both scalars +C or else both vectors. +C +C IDID -- This scalar quantity is an indicator reporting what +C the code did. You must monitor this INTEGER variable to +C decide what action to take next. +C +C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of +C length LRW which provides the code with needed storage +C space. +C +C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW +C which provides the code with needed storage space and an +C across call flag. +C +C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and the DF subroutine (and the DJAC +C subroutine). +C +C DJAC -- This is the name of a subroutine which you may choose to +C provide for defining the Jacobian matrix of partial +C derivatives DF/DU. +C +C Quantities which are used as input items are +C NEQ, T, Y(*), TOUT, INFO(*), +C RTOL, ATOL, RWORK(1), LRW, +C IWORK(1), IWORK(2), and LIW. +C +C Quantities which may be altered by the code are +C T, Y(*), INFO(1), RTOL, ATOL, +C IDID, RWORK(*) and IWORK(*). +C +C ********************************************************************** +C * INPUT -- What To Do On The First Call To DDEBDF * +C ********************************************************************** +C +C The first call of the code is defined to be the start of each new +C problem. Read through the descriptions of all the following items, +C provide sufficient storage space for designated arrays, set +C appropriate variables for the initialization of the problem, and +C give information about how you want the problem to be solved. +C +C +C DF -- Provide a subroutine of the form +C DF(X,U,UPRIME,RPAR,IPAR) +C to define the system of first order differential equations +C which is to be solved. For the given values of X and the +C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must +C evaluate the NEQ components of the system of differential +C equations DU/DX=DF(X,U) and store the derivatives in the +C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for +C equations I=1,...,NEQ. +C +C Subroutine DF must not alter X or U(*). You must declare +C the name DF in an external statement in your program that +C calls DDEBDF. You must dimension U and UPRIME in DF. +C +C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and subroutine DF. They are not used or +C altered by DDEBDF. If you do not need RPAR or IPAR, +C ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension them in +C your calling program and in DF as arrays of appropriate +C length. +C +C NEQ -- Set it to the number of differential equations. +C (NEQ .GE. 1) +C +C T -- Set it to the initial point of the integration. +C You must use a program variable for T because the code +C changes its value. +C +C Y(*) -- Set this vector to the initial values of the NEQ solution +C components at the initial point. You must dimension Y at +C least NEQ in your calling program. +C +C TOUT -- Set it to the first point at which a solution is desired. +C You can take TOUT = T, in which case the code +C will evaluate the derivative of the solution at T and +C return. Integration either forward in T (TOUT .GT. T) +C or backward in T (TOUT .LT. T) is permitted. +C +C The code advances the solution from T to TOUT using +C step sizes which are automatically selected so as to +C achieve the desired accuracy. If you wish, the code will +C return with the solution and its derivative following +C each intermediate step (intermediate-output mode) so that +C you can monitor them, but you still must provide TOUT in +C accord with the basic aim of the code. +C +C The first step taken by the code is a critical one +C because it must reflect how fast the solution changes near +C the initial point. The code automatically selects an +C initial step size which is practically always suitable for +C the problem. By using the fact that the code will not +C step past TOUT in the first step, you could, if necessary, +C restrict the length of the initial step size. +C +C For some problems it may not be permissible to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP. When you have declared a TSTOP point (see INFO(4) +C and RWORK(1)), you have told the code not to integrate +C past TSTOP. In this case any TOUT beyond TSTOP is invalid +C input. +C +C INFO(*) -- Use the INFO array to give the code more details about +C how you want your problem solved. This array should be +C dimensioned of length 15 to accommodate other members of +C DEPAC or possible future extensions, though DDEBDF uses +C only the first six entries. You must respond to all of +C the following items which are arranged as questions. The +C simplest use of the code corresponds to answering all +C questions as YES ,i.e. setting all entries of INFO to 0. +C +C INFO(1) -- This parameter enables the code to initialize +C itself. You must set it to indicate the start of every +C new problem. +C +C **** Is this the first call for this problem ... +C YES -- Set INFO(1) = 0 +C NO -- Not applicable here. +C See below for continuation calls. **** +C +C INFO(2) -- How much accuracy you want of your solution +C is specified by the error tolerances RTOL and ATOL. +C The simplest use is to take them both to be scalars. +C To obtain more flexibility, they can both be vectors. +C The code must be told your choice. +C +C **** Are both error tolerances RTOL, ATOL scalars ... +C YES -- Set INFO(2) = 0 +C and input scalars for both RTOL and ATOL +C NO -- Set INFO(2) = 1 +C and input arrays for both RTOL and ATOL **** +C +C INFO(3) -- The code integrates from T in the direction +C of TOUT by steps. If you wish, it will return the +C computed solution and derivative at the next +C intermediate step (the intermediate-output mode) or +C TOUT, whichever comes first. This is a good way to +C proceed if you want to see the behavior of the solution. +C If you must have solutions at a great many specific +C TOUT points, this code will compute them efficiently. +C +C **** Do you want the solution only at +C TOUT (and NOT at the next intermediate step) ... +C YES -- Set INFO(3) = 0 +C NO -- Set INFO(3) = 1 **** +C +C INFO(4) -- To handle solutions at a great many specific +C values TOUT efficiently, this code may integrate past +C TOUT and interpolate to obtain the result at TOUT. +C Sometimes it is not possible to integrate beyond some +C point TSTOP because the equation changes there or it is +C not defined past TSTOP. Then you must tell the code +C not to go past. +C +C **** Can the integration be carried out without any +C restrictions on the independent variable T ... +C YES -- Set INFO(4)=0 +C NO -- Set INFO(4)=1 +C and define the stopping point TSTOP by +C setting RWORK(1)=TSTOP **** +C +C INFO(5) -- To solve stiff problems it is necessary to use the +C Jacobian matrix of partial derivatives of the system +C of differential equations. If you do not provide a +C subroutine to evaluate it analytically (see the +C description of the item DJAC in the call list), it will +C be approximated by numerical differencing in this code. +C Although it is less trouble for you to have the code +C compute partial derivatives by numerical differencing, +C the solution will be more reliable if you provide the +C derivatives via DJAC. Sometimes numerical differencing +C is cheaper than evaluating derivatives in DJAC and +C sometimes it is not - this depends on your problem. +C +C If your problem is linear, i.e. has the form +C DU/DX = DF(X,U) = J(X)*U + G(X) for some matrix J(X) +C and vector G(X), the Jacobian matrix DF/DU = J(X). +C Since you must provide a subroutine to evaluate DF(X,U) +C analytically, it is little extra trouble to provide +C subroutine DJAC for evaluating J(X) analytically. +C Furthermore, in such cases, numerical differencing is +C much more expensive than analytic evaluation. +C +C **** Do you want the code to evaluate the partial +C derivatives automatically by numerical differences ... +C YES -- Set INFO(5)=0 +C NO -- Set INFO(5)=1 +C and provide subroutine DJAC for evaluating the +C Jacobian matrix **** +C +C INFO(6) -- DDEBDF will perform much better if the Jacobian +C matrix is banded and the code is told this. In this +C case, the storage needed will be greatly reduced, +C numerical differencing will be performed more cheaply, +C and a number of important algorithms will execute much +C faster. The differential equation is said to have +C half-bandwidths ML (lower) and MU (upper) if equation I +C involves only unknowns Y(J) with +C I-ML .LE. J .LE. I+MU +C for all I=1,2,...,NEQ. Thus, ML and MU are the widths +C of the lower and upper parts of the band, respectively, +C with the main diagonal being excluded. If you do not +C indicate that the equation has a banded Jacobian, +C the code works with a full matrix of NEQ**2 elements +C (stored in the conventional way). Computations with +C banded matrices cost less time and storage than with +C full matrices if 2*ML+MU .LT. NEQ. If you tell the +C code that the Jacobian matrix has a banded structure and +C you want to provide subroutine DJAC to compute the +C partial derivatives, then you must be careful to store +C the elements of the Jacobian matrix in the special form +C indicated in the description of DJAC. +C +C **** Do you want to solve the problem using a full +C (dense) Jacobian matrix (and not a special banded +C structure) ... +C YES -- Set INFO(6)=0 +C NO -- Set INFO(6)=1 +C and provide the lower (ML) and upper (MU) +C bandwidths by setting +C IWORK(1)=ML +C IWORK(2)=MU **** +C +C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) +C error tolerances to tell the code how accurately you want +C the solution to be computed. They must be defined as +C program variables because the code may change them. You +C have two choices -- +C Both RTOL and ATOL are scalars. (INFO(2)=0) +C Both RTOL and ATOL are vectors. (INFO(2)=1) +C In either case all components must be non-negative. +C +C The tolerances are used by the code in a local error test +C at each step which requires roughly that +C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL +C for each vector component. +C (More specifically, a root-mean-square norm is used to +C measure the size of vectors, and the error test uses the +C magnitude of the solution at the beginning of the step.) +C +C The true (global) error is the difference between the true +C solution of the initial value problem and the computed +C approximation. Practically all present day codes, +C including this one, control the local error at each step +C and do not even attempt to control the global error +C directly. Roughly speaking, they produce a solution Y(T) +C which satisfies the differential equations with a +C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , +C and, almost always, R(T) is bounded by the error +C tolerances. Usually, but not always, the true accuracy of +C the computed Y is comparable to the error tolerances. This +C code will usually, but not always, deliver a more accurate +C solution if you reduce the tolerances and integrate again. +C By comparing two such solutions you can get a fairly +C reliable idea of the true error in the solution at the +C bigger tolerances. +C +C Setting ATOL=0. results in a pure relative error test on +C that component. Setting RTOL=0. results in a pure abso- +C lute error test on that component. A mixed test with non- +C zero RTOL and ATOL corresponds roughly to a relative error +C test when the solution component is much bigger than ATOL +C and to an absolute error test when the solution component +C is smaller than the threshold ATOL. +C +C Proper selection of the absolute error control parameters +C ATOL requires you to have some idea of the scale of the +C solution components. To acquire this information may mean +C that you will have to solve the problem more than once. In +C the absence of scale information, you should ask for some +C relative accuracy in all the components (by setting RTOL +C values non-zero) and perhaps impose extremely small +C absolute error tolerances to protect against the danger of +C a solution component becoming zero. +C +C The code will not attempt to compute a solution at an +C accuracy unreasonable for the machine being used. It will +C advise you if you ask for too much accuracy and inform +C you as to the maximum accuracy it believes possible. +C +C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length +C LRW in your calling program. +C +C RWORK(1) -- If you have set INFO(4)=0, you can ignore this +C optional input parameter. Otherwise you must define a +C stopping point TSTOP by setting RWORK(1) = TSTOP. +C (For some problems it may not be permissible to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP.) +C +C LRW -- Set it to the declared length of the RWORK array. +C You must have +C LRW .GE. 250+10*NEQ+NEQ**2 +C for the full (dense) Jacobian case (when INFO(6)=0), or +C LRW .GE. 250+10*NEQ+(2*ML+MU+1)*NEQ +C for the banded Jacobian case (when INFO(6)=1). +C +C IWORK(*) -- Dimension this INTEGER work array of length LIW in +C your calling program. +C +C IWORK(1), IWORK(2) -- If you have set INFO(6)=0, you can ignore +C these optional input parameters. Otherwise you must define +C the half-bandwidths ML (lower) and MU (upper) of the +C Jacobian matrix by setting IWORK(1) = ML and +C IWORK(2) = MU. (The code will work with a full matrix +C of NEQ**2 elements unless it is told that the problem has +C a banded Jacobian, in which case the code will work with +C a matrix containing at most (2*ML+MU+1)*NEQ elements.) +C +C LIW -- Set it to the declared length of the IWORK array. +C You must have LIW .GE. 56+NEQ. +C +C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and +C INTEGER type, respectively. You can use them for +C communication between your program that calls DDEBDF and +C the DF subroutine (and the DJAC subroutine). They are not +C used or altered by DDEBDF. If you do not need RPAR or +C IPAR, ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension them in +C your calling program and in DF (and in DJAC) as arrays of +C appropriate length. +C +C DJAC -- If you have set INFO(5)=0, you can ignore this parameter +C by treating it as a dummy argument. (For some compilers +C you may have to write a dummy subroutine named DJAC in +C order to avoid problems associated with missing external +C routine names.) Otherwise, you must provide a subroutine +C of the form +C DJAC(X,U,PD,NROWPD,RPAR,IPAR) +C to define the Jacobian matrix of partial derivatives DF/DU +C of the system of differential equations DU/DX = DF(X,U). +C For the given values of X and the vector +C U(*)=(U(1),U(2),...,U(NEQ)), the subroutine must evaluate +C the non-zero partial derivatives DF(I)/DU(J) for each +C differential equation I=1,...,NEQ and each solution +C component J=1,...,NEQ , and store these values in the +C matrix PD. The elements of PD are set to zero before each +C call to DJAC so only non-zero elements need to be defined. +C +C Subroutine DJAC must not alter X, U(*), or NROWPD. You +C must declare the name DJAC in an external statement in +C your program that calls DDEBDF. NROWPD is the row +C dimension of the PD matrix and is assigned by the code. +C Therefore you must dimension PD in DJAC according to +C DIMENSION PD(NROWPD,1) +C You must also dimension U in DJAC. +C +C The way you must store the elements into the PD matrix +C depends on the structure of the Jacobian which you +C indicated by INFO(6). +C *** INFO(6)=0 -- Full (Dense) Jacobian *** +C When you evaluate the (non-zero) partial derivative +C of equation I with respect to variable J, you must +C store it in PD according to +C PD(I,J) = * DF(I)/DU(J) * +C *** INFO(6)=1 -- Banded Jacobian with ML Lower and MU +C Upper Diagonal Bands (refer to INFO(6) description of +C ML and MU) *** +C When you evaluate the (non-zero) partial derivative +C of equation I with respect to variable J, you must +C store it in PD according to +C IROW = I - J + ML + MU + 1 +C PD(IROW,J) = * DF(I)/DU(J) * +C +C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and your Jacobian subroutine DJAC. They +C are not altered by DDEBDF. If you do not need RPAR or +C IPAR, ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension them +C in your calling program and in DJAC as arrays of +C appropriate length. +C +C ********************************************************************** +C * OUTPUT -- After any return from DDEBDF * +C ********************************************************************** +C +C The principal aim of the code is to return a computed solution at +C TOUT, although it is also possible to obtain intermediate results +C along the way. To find out whether the code achieved its goal +C or if the integration process was interrupted before the task was +C completed, you must check the IDID parameter. +C +C +C T -- The solution was successfully advanced to the +C output value of T. +C +C Y(*) -- Contains the computed solution approximation at T. +C You may also be interested in the approximate derivative +C of the solution at T. It is contained in +C RWORK(21),...,RWORK(20+NEQ). +C +C IDID -- Reports what the code did +C +C *** Task Completed *** +C Reported by positive values of IDID +C +C IDID = 1 -- A step was successfully taken in the +C intermediate-output mode. The code has not +C yet reached TOUT. +C +C IDID = 2 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping exactly to TOUT. +C +C IDID = 3 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping past TOUT. +C Y(*) is obtained by interpolation. +C +C *** Task Interrupted *** +C Reported by negative values of IDID +C +C IDID = -1 -- A large amount of work has been expended. +C (500 steps attempted) +C +C IDID = -2 -- The error tolerances are too stringent. +C +C IDID = -3 -- The local error test cannot be satisfied +C because you specified a zero component in ATOL +C and the corresponding computed solution +C component is zero. Thus, a pure relative error +C test is impossible for this component. +C +C IDID = -4,-5 -- Not applicable for this code but used +C by other members of DEPAC. +C +C IDID = -6 -- DDEBDF had repeated convergence test failures +C on the last attempted step. +C +C IDID = -7 -- DDEBDF had repeated error test failures on +C the last attempted step. +C +C IDID = -8,..,-32 -- Not applicable for this code but +C used by other members of DEPAC or possible +C future extensions. +C +C *** Task Terminated *** +C Reported by the value of IDID=-33 +C +C IDID = -33 -- The code has encountered trouble from which +C it cannot recover. A message is printed +C explaining the trouble and control is returned +C to the calling program. For example, this +C occurs when invalid input is detected. +C +C RTOL, ATOL -- These quantities remain unchanged except when +C IDID = -2. In this case, the error tolerances have been +C increased by the code to values which are estimated to be +C appropriate for continuing the integration. However, the +C reported solution at T was obtained using the input values +C of RTOL and ATOL. +C +C RWORK, IWORK -- Contain information which is usually of no +C interest to the user but necessary for subsequent calls. +C However, you may find use for +C +C RWORK(11)--which contains the step size H to be +C attempted on the next step. +C +C RWORK(12)--If the tolerances have been increased by the +C code (IDID = -2) , they were multiplied by the +C value in RWORK(12). +C +C RWORK(13)--which contains the current value of the +C independent variable, i.e. the farthest point +C integration has reached. This will be +C different from T only when interpolation has +C been performed (IDID=3). +C +C RWORK(20+I)--which contains the approximate derivative +C of the solution component Y(I). In DDEBDF, it +C is never obtained by calling subroutine DF to +C evaluate the differential equation using T and +C Y(*), except at the initial point of +C integration. +C +C ********************************************************************** +C ** INPUT -- What To Do To Continue The Integration ** +C ** (calls after the first) ** +C ********************************************************************** +C +C This code is organized so that subsequent calls to continue the +C integration involve little (if any) additional effort on your +C part. You must monitor the IDID parameter in order to determine +C what to do next. +C +C Recalling that the principal task of the code is to integrate +C from T to TOUT (the interval mode), usually all you will need +C to do is specify a new TOUT upon reaching the current TOUT. +C +C Do not alter any quantity not specifically permitted below, +C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or +C the differential equation in subroutine DF. Any such alteration +C constitutes a new problem and must be treated as such, i.e. +C you must start afresh. +C +C You cannot change from vector to scalar error control or vice +C versa (INFO(2)) but you can change the size of the entries of +C RTOL, ATOL. Increasing a tolerance makes the equation easier +C to integrate. Decreasing a tolerance will make the equation +C harder to integrate and should generally be avoided. +C +C You can switch from the intermediate-output mode to the +C interval mode (INFO(3)) or vice versa at any time. +C +C If it has been necessary to prevent the integration from going +C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the +C code will not integrate to any TOUT beyond the currently +C specified TSTOP. Once TSTOP has been reached you must change +C the value of TSTOP or set INFO(4)=0. You may change INFO(4) +C or TSTOP at any time but you must supply the value of TSTOP in +C RWORK(1) whenever you set INFO(4)=1. +C +C Do not change INFO(5), INFO(6), IWORK(1), or IWORK(2) +C unless you are going to restart the code. +C +C The parameter INFO(1) is used by the code to indicate the +C beginning of a new problem and to indicate whether integration +C is to be continued. You must input the value INFO(1) = 0 +C when starting a new problem. You must input the value +C INFO(1) = 1 if you wish to continue after an interrupted task. +C Do not set INFO(1) = 0 on a continuation call unless you +C want the code to restart at the current T. +C +C *** Following a Completed Task *** +C If +C IDID = 1, call the code again to continue the integration +C another step in the direction of TOUT. +C +C IDID = 2 or 3, define a new TOUT and call the code again. +C TOUT must be different from T. You cannot change +C the direction of integration without restarting. +C +C *** Following an Interrupted Task *** +C To show the code that you realize the task was +C interrupted and that you want to continue, you +C must take appropriate action and reset INFO(1) = 1 +C If +C IDID = -1, the code has attempted 500 steps. +C If you want to continue, set INFO(1) = 1 and +C call the code again. An additional 500 steps +C will be allowed. +C +C IDID = -2, the error tolerances RTOL, ATOL have been +C increased to values the code estimates appropriate +C for continuing. You may want to change them +C yourself. If you are sure you want to continue +C with relaxed error tolerances, set INFO(1)=1 and +C call the code again. +C +C IDID = -3, a solution component is zero and you set the +C corresponding component of ATOL to zero. If you +C are sure you want to continue, you must first +C alter the error criterion to use positive values +C for those components of ATOL corresponding to zero +C solution components, then set INFO(1)=1 and call +C the code again. +C +C IDID = -4,-5 --- cannot occur with this code but used +C by other members of DEPAC. +C +C IDID = -6, repeated convergence test failures occurred +C on the last attempted step in DDEBDF. An inaccu- +C rate Jacobian may be the problem. If you are +C absolutely certain you want to continue, restart +C the integration at the current T by setting +C INFO(1)=0 and call the code again. +C +C IDID = -7, repeated error test failures occurred on the +C last attempted step in DDEBDF. A singularity in +C the solution may be present. You should re- +C examine the problem being solved. If you are +C absolutely certain you want to continue, restart +C the integration at the current T by setting +C INFO(1)=0 and call the code again. +C +C IDID = -8,..,-32 --- cannot occur with this code but +C used by other members of DDEPAC or possible future +C extensions. +C +C *** Following a Terminated Task *** +C If +C IDID = -33, you cannot continue the solution of this +C problem. An attempt to do so will result in your +C run being terminated. +C +C ********************************************************************** +C +C ***** Warning ***** +C +C If DDEBDF is to be used in an overlay situation, you must save and +C restore certain items used internally by DDEBDF (values in the +C common block DDEBD1). This can be accomplished as follows. +C +C To save the necessary values upon return from DDEBDF, simply call +C DSVCO(RWORK(22+NEQ),IWORK(21+NEQ)). +C +C To restore the necessary values before the next call to DDEBDF, +C simply call DRSCO(RWORK(22+NEQ),IWORK(21+NEQ)). +C +C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user +C oriented package of ODE solvers, Report SAND79-2374, +C Sandia Laboratories, 1979. +C***ROUTINES CALLED DLSOD, XERMSG +C***COMMON BLOCKS DDEBD1 +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891024 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 900510 Convert XERRWV calls to XERMSG calls, make Prologue comments +C consistent with DEBDF. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DDEBDF + INTEGER IACOR, IBAND, IBEGIN, ICOMI, ICOMR, IDELSN, IDID, IER, + 1 IEWT, IINOUT, IINTEG, IJAC, ILRW, INFO, INIT, + 2 IOWNS, IPAR, IQUIT, ISAVF, ITOL, ITSTAR, ITSTOP, IWM, + 3 IWORK, IYH, IYPOUT, JSTART, KFLAG, KSTEPS, L, LIW, LRW, + 4 MAXORD, METH, MITER, ML, MU, N, NEQ, NFE, NJE, NQ, NQU, + 5 NST + DOUBLE PRECISION ATOL, EL0, H, HMIN, HMXI, HU, ROWNS, RPAR, + 1 RTOL, RWORK, T, TN, TOLD, TOUT, UROUND, Y + LOGICAL INTOUT + CHARACTER*8 XERN1, XERN2 + CHARACTER*16 XERN3 +C + DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), + 1 RPAR(*),IPAR(*) +C + COMMON /DDEBD1/ TOLD,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, + 1 IQUIT,INIT,IYH,IEWT,IACOR,ISAVF,IWM,KSTEPS,IBEGIN, + 2 ITOL,IINTEG,ITSTOP,IJAC,IBAND,IOWNS(6),IER,JSTART, + 3 KFLAG,L,METH,MITER,MAXORD,N,NQ,NST,NFE,NJE,NQU +C + EXTERNAL DF, DJAC +C +C CHECK FOR AN APPARENT INFINITE LOOP +C +C***FIRST EXECUTABLE STATEMENT DDEBDF + IF (INFO(1) .EQ. 0) IWORK(LIW) = 0 +C + IF (IWORK(LIW).GE. 5) THEN + IF (T .EQ. RWORK(21+NEQ)) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DDEBDF', + * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // + * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // + * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // + * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // + * 'CODE, PARTICULARLY INFO(1).', 13, 2) + RETURN + ENDIF + ENDIF +C + IDID = 0 +C +C CHECK VALIDITY OF INFO PARAMETERS +C + IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(1) + CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(1) MUST BE SET TO 0 ' // + * 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // + * 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // + * 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE ' // + * 'CODE WITH INFO(1) = ' // XERN1, 3, 1) + IDID = -33 + ENDIF +C + IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(2) + CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(2) MUST BE 0 OR 1 ' // + * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // + * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // + * XERN1, 4, 1) + IDID = -33 + ENDIF +C + IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(3) + CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(3) MUST BE 0 OR 1 ' // + * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // + * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // + * 'WITH INFO(3) = ' // XERN1, 5, 1) + IDID = -33 + ENDIF +C + IF (INFO(4) .NE. 0 .AND. INFO(4) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(4) + CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(4) MUST BE 0 OR 1 ' // + * 'INDICATING WHETHER OR NOT THE INTEGRATION INTERVAL IS ' // + * 'TO BE RESTRICTED BY A POINT TSTOP. YOU HAVE CALLED ' // + * 'THE CODE WITH INFO(4) = ' // XERN1, 14, 1) + IDID = -33 + ENDIF +C + IF (INFO(5) .NE. 0 .AND. INFO(5) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(5) + CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(5) MUST BE 0 OR 1 ' // + * 'INDICATING WHETHER THE CODE IS TOLD TO FORM THE ' // + * 'JACOBIAN MATRIX BY NUMERICAL DIFFERENCING OR YOU ' // + * 'PROVIDE A SUBROUTINE TO EVALUATE IT ANALYTICALLY. ' // + * 'YOU HAVE CALLED THE CODE WITH INFO(5) = ' // XERN1, 15, 1) + IDID = -33 + ENDIF +C + IF (INFO(6) .NE. 0 .AND. INFO(6) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(6) + CALL XERMSG ('SLATEC', 'DDEBDF', 'INFO(6) MUST BE 0 OR 1 ' // + * 'INDICATING WHETHER THE CODE IS TOLD TO TREAT THE ' // + * 'JACOBIAN AS A FULL (DENSE) MATRIX OR AS HAVING A ' // + * 'SPECIAL BANDED STRUCTURE. YOU HAVE CALLED THE CODE ' // + * 'WITH INFO(6) = ' // XERN1, 16, 1) + IDID = -33 + ENDIF +C + ILRW = NEQ + IF (INFO(6) .NE. 0) THEN +C +C CHECK BANDWIDTH PARAMETERS +C + ML = IWORK(1) + MU = IWORK(2) + ILRW = 2*ML + MU + 1 +C + IF (ML.LT.0 .OR. ML.GE.NEQ .OR. MU.LT.0 .OR. MU.GE.NEQ) THEN + WRITE (XERN1, '(I8)') ML + WRITE (XERN2, '(I8)') MU + CALL XERMSG ('SLATEC', 'DDEBDF', 'YOU HAVE SET INFO(6) ' // + * '= 1, TELLING THE CODE THAT THE JACOBIAN MATRIX HAS ' // + * 'A SPECIAL BANDED STRUCTURE. HOWEVER, THE LOWER ' // + * '(UPPER) BANDWIDTHS ML (MU) VIOLATE THE CONSTRAINTS ' // + * 'ML,MU .GE. 0 AND ML,MU .LT. NEQ. YOU HAVE CALLED ' // + * 'THE CODE WITH ML = ' // XERN1 // ' AND MU = ' // XERN2, + * 17, 1) + IDID = -33 + ENDIF + ENDIF +C +C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION +C + IF (LRW .LT. 250 + (10 + ILRW)*NEQ) THEN + WRITE (XERN1, '(I8)') LRW + IF (INFO(6) .EQ. 0) THEN + CALL XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY RWORK ' // + * 'MUST BE AT LEAST 250 + 10*NEQ + NEQ*NEQ.$$' // + * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 1, 1) + ELSE + CALL XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY RWORK ' // + * 'MUST BE AT LEAST 250 + 10*NEQ + (2*ML+MU+1)*NEQ.$$' // + * 'YOU HAVE CALLED THE CODE WITH LRW = ' // XERN1, 18, 1) + ENDIF + IDID = -33 + ENDIF +C + IF (LIW .LT. 56 + NEQ) THEN + WRITE (XERN1, '(I8)') LIW + CALL XERMSG ('SLATEC', 'DDEBDF', 'LENGTH OF ARRAY IWORK ' // + * 'BE AT LEAST 56 + NEQ. YOU HAVE CALLED THE CODE WITH ' // + * 'LIW = ' // XERN1, 2, 1) + IDID = -33 + ENDIF +C +C COMPUTE THE INDICES FOR THE ARRAYS TO BE STORED IN THE WORK +C ARRAY AND RESTORE COMMON BLOCK DATA +C + ICOMI = 21 + NEQ + IINOUT = ICOMI + 33 +C + IYPOUT = 21 + ITSTAR = 21 + NEQ + ICOMR = 22 + NEQ +C + IF (INFO(1) .NE. 0) INTOUT = IWORK(IINOUT) .NE. (-1) +C CALL DRSCO(RWORK(ICOMR),IWORK(ICOMI)) +C + IYH = ICOMR + 218 + IEWT = IYH + 6*NEQ + ISAVF = IEWT + NEQ + IACOR = ISAVF + NEQ + IWM = IACOR + NEQ + IDELSN = IWM + 2 + ILRW*NEQ +C + IBEGIN = INFO(1) + ITOL = INFO(2) + IINTEG = INFO(3) + ITSTOP = INFO(4) + IJAC = INFO(5) + IBAND = INFO(6) + RWORK(ITSTAR) = T +C + CALL DLSOD(DF,NEQ,T,Y,TOUT,RTOL,ATOL,IDID,RWORK(IYPOUT), + 1 RWORK(IYH),RWORK(IYH),RWORK(IEWT),RWORK(ISAVF), + 2 RWORK(IACOR),RWORK(IWM),IWORK(1),DJAC,INTOUT, + 3 RWORK(1),RWORK(12),RWORK(IDELSN),RPAR,IPAR) +C + IWORK(IINOUT) = -1 + IF (INTOUT) IWORK(IINOUT) = 1 +C + IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 + IF (T .NE. RWORK(ITSTAR)) IWORK(LIW) = 0 +C CALL DSVCO(RWORK(ICOMR),IWORK(ICOMI)) + RWORK(11) = H + RWORK(13) = TN + INFO(1) = IBEGIN +C + RETURN + END +*DECK DLSOD + SUBROUTINE DLSOD (DF, NEQ, T, Y, TOUT, RTOL, ATOL, IDID, YPOUT, + + YH, YH1, EWT, SAVF, ACOR, WM, IWM, DJAC, INTOUT, TSTOP, TOLFAC, + + DELSGN, RPAR, IPAR) +C***BEGIN PROLOGUE DLSOD +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEBDF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (LSOD-S, DLSOD-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C DDEBDF merely allocates storage for DLSOD to relieve the user of +C the inconvenience of a long call list. Consequently DLSOD is used +C as described in the comments for DDEBDF . +C +C***SEE ALSO DDEBDF +C***ROUTINES CALLED D1MACH, DHSTRT, DINTYD, DSTOD, DVNRMS, XERMSG +C***COMMON BLOCKS DDEBD1 +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900510 Convert XERRWV calls to XERMSG calls. (RWC) +C***END PROLOGUE DLSOD +C + INTEGER IBAND, IBEGIN, IDID, IER, IINTEG, IJAC, INIT, INTFLG, + 1 IOWNS, IPAR, IQUIT, ITOL, ITSTOP, IWM, JSTART, K, KFLAG, + 2 KSTEPS, L, LACOR, LDUM, LEWT, LSAVF, LTOL, LWM, LYH, MAXNUM, + 3 MAXORD, METH, MITER, N, NATOLP, NEQ, NFE, NJE, NQ, NQU, + 4 NRTOLP, NST + DOUBLE PRECISION ABSDEL, ACOR, ATOL, BIG, D1MACH, DEL, + 1 DELSGN, DT, DVNRMS, EL0, EWT, + 2 H, HA, HMIN, HMXI, HU, ROWNS, RPAR, RTOL, SAVF, T, TOL, + 3 TOLD, TOLFAC, TOUT, TSTOP, U, WM, X, Y, YH, YH1, YPOUT + LOGICAL INTOUT + CHARACTER*8 XERN1 + CHARACTER*16 XERN3, XERN4 +C + DIMENSION Y(*),YPOUT(*),YH(NEQ,6),YH1(*),EWT(*),SAVF(*), + 1 ACOR(*),WM(*),IWM(*),RTOL(*),ATOL(*),RPAR(*),IPAR(*) +C +C + COMMON /DDEBD1/ TOLD,ROWNS(210),EL0,H,HMIN,HMXI,HU,X,U,IQUIT,INIT, + 1 LYH,LEWT,LACOR,LSAVF,LWM,KSTEPS,IBEGIN,ITOL, + 2 IINTEG,ITSTOP,IJAC,IBAND,IOWNS(6),IER,JSTART, + 3 KFLAG,LDUM,METH,MITER,MAXORD,N,NQ,NST,NFE,NJE,NQU +C + EXTERNAL DF, DJAC +C +C .................................................................. +C +C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE +C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MAXNUM, THE +C COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE +C EXCESSIVE WORK. + SAVE MAXNUM +C + DATA MAXNUM /500/ +C +C .................................................................. +C +C***FIRST EXECUTABLE STATEMENT DLSOD + IF (IBEGIN .EQ. 0) THEN +C +C ON THE FIRST CALL , PERFORM INITIALIZATION -- +C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE +C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE +C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. +C + U = D1MACH(4) +C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETER + WM(1) = SQRT(U) +C -- SET TERMINATION FLAG + IQUIT = 0 +C -- SET INITIALIZATION INDICATOR + INIT = 0 +C -- SET COUNTER FOR ATTEMPTED STEPS + KSTEPS = 0 +C -- SET INDICATOR FOR INTERMEDIATE-OUTPUT + INTOUT = .FALSE. +C -- SET START INDICATOR FOR DSTOD CODE + JSTART = 0 +C -- SET BDF METHOD INDICATOR + METH = 2 +C -- SET MAXIMUM ORDER FOR BDF METHOD + MAXORD = 5 +C -- SET ITERATION MATRIX INDICATOR +C + IF (IJAC .EQ. 0 .AND. IBAND .EQ. 0) MITER = 2 + IF (IJAC .EQ. 1 .AND. IBAND .EQ. 0) MITER = 1 + IF (IJAC .EQ. 0 .AND. IBAND .EQ. 1) MITER = 5 + IF (IJAC .EQ. 1 .AND. IBAND .EQ. 1) MITER = 4 +C +C -- SET OTHER NECESSARY ITEMS IN COMMON BLOCK + N = NEQ + NST = 0 + NJE = 0 + HMXI = 0.0D0 + NQ = 1 + H = 1.0D0 +C -- RESET IBEGIN FOR SUBSEQUENT CALLS + IBEGIN = 1 + ENDIF +C +C .................................................................. +C +C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY +C + IF (NEQ .LT. 1) THEN + WRITE (XERN1, '(I8)') NEQ + CALL XERMSG ('SLATEC', 'DLSOD', + * 'IN DDEBDF, THE NUMBER OF EQUATIONS MUST BE A ' // + * 'POSITIVE INTEGER.$$YOU HAVE CALLED THE CODE WITH NEQ = ' // + * XERN1, 6, 1) + IDID=-33 + ENDIF +C + NRTOLP = 0 + NATOLP = 0 + DO 60 K = 1, NEQ + IF (NRTOLP .LE. 0) THEN + IF (RTOL(K) .LT. 0.) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') RTOL(K) + CALL XERMSG ('SLATEC', 'DLSOD', + * 'IN DDEBDF, THE RELATIVE ERROR TOLERANCES MUST ' // + * 'BE NON-NEGATIVE.$$YOU HAVE CALLED THE CODE WITH ' // + * 'RTOL(' // XERN1 // ') = ' // XERN3 // '$$IN THE ' // + * 'CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' // + * 'CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) + IDID = -33 + IF (NATOLP .GT. 0) GO TO 70 + NRTOLP = 1 + ELSEIF (NATOLP .GT. 0) THEN + GO TO 50 + ENDIF + ENDIF +C + IF (ATOL(K) .LT. 0.) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') ATOL(K) + CALL XERMSG ('SLATEC', 'DLSOD', + * 'IN DDEBDF, THE ABSOLUTE ERROR ' // + * 'TOLERANCES MUST BE NON-NEGATIVE.$$YOU HAVE CALLED ' // + * 'THE CODE WITH ATOL(' // XERN1 // ') = ' // XERN3 // + * '$$IN THE CASE OF VECTOR ERROR TOLERANCES, NO FURTHER ' + * // 'CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) + IDID=-33 + IF (NRTOLP .GT. 0) GO TO 70 + NATOLP=1 + ENDIF + 50 IF (ITOL .EQ. 0) GO TO 70 + 60 CONTINUE +C + 70 IF (ITSTOP .EQ. 1) THEN + IF (SIGN(1.0D0,TOUT-T) .NE. SIGN(1.0D0,TSTOP-T) .OR. + 1 ABS(TOUT-T) .GT. ABS(TSTOP-T)) THEN + WRITE (XERN3, '(1PE15.6)') TOUT + WRITE (XERN4, '(1PE15.6)') TSTOP + CALL XERMSG ('SLATEC', 'DLSOD', + * 'IN DDEBDF, YOU HAVE CALLED THE ' // + * 'CODE WITH TOUT = ' // XERN3 // '$$BUT YOU HAVE ' // + * 'ALSO TOLD THE CODE NOT TO INTEGRATE PAST THE POINT ' // + * 'TSTOP = ' // XERN4 // ' BY SETTING INFO(4) = 1.$$' // + * 'THESE INSTRUCTIONS CONFLICT.', 14, 1) + IDID=-33 + ENDIF + ENDIF +C +C CHECK SOME CONTINUATION POSSIBILITIES +C + IF (INIT .NE. 0) THEN + IF (T .EQ. TOUT) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DLSOD', + * 'IN DDEBDF, YOU HAVE CALLED THE CODE WITH T = TOUT = ' // + * XERN3 // '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', + * 9, 1) + IDID=-33 + ENDIF +C + IF (T .NE. TOLD) THEN + WRITE (XERN3, '(1PE15.6)') TOLD + WRITE (XERN4, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DLSOD', + * 'IN DDEBDF, YOU HAVE CHANGED THE VALUE OF T FROM ' // + * XERN3 // ' TO ' // XERN4 // + * ' THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) + IDID=-33 + ENDIF +C + IF (INIT .NE. 1) THEN + IF (DELSGN*(TOUT-T) .LT. 0.0D0) THEN + WRITE (XERN3, '(1PE15.6)') TOUT + CALL XERMSG ('SLATEC', 'DLSOD', + * 'IN DDEBDF, BY CALLING THE CODE WITH TOUT = ' // + * XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // + * 'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' // + * 'WITHOUT RESTARTING.', 11, 1) + IDID=-33 + ENDIF + ENDIF + ENDIF +C + IF (IDID .EQ. (-33)) THEN + IF (IQUIT .NE. (-33)) THEN +C INVALID INPUT DETECTED + IQUIT=-33 + IBEGIN=-1 + ELSE + CALL XERMSG ('SLATEC', 'DLSOD', + * 'IN DDEBDF, INVALID INPUT WAS DETECTED ON ' // + * 'SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE TO PROCEED ' // + * 'BECAUSE YOU HAVE NOT CORRECTED THE PROBLEM, ' // + * 'SO EXECUTION IS BEING TERMINATED.', 12, 2) + ENDIF + RETURN + ENDIF +C +C ............................................................... +C +C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND INTERPRETED +C AS ASKING FOR THE MOST ACCURATE SOLUTION POSSIBLE. IN THIS +C CASE, THE RELATIVE ERROR TOLERANCE RTOL IS RESET TO THE +C SMALLEST VALUE 100*U WHICH IS LIKELY TO BE REASONABLE FOR +C THIS METHOD AND MACHINE +C + DO 180 K = 1, NEQ + IF (RTOL(K) + ATOL(K) .GT. 0.0D0) GO TO 170 + RTOL(K) = 100.0D0*U + IDID = -2 + 170 CONTINUE +C ...EXIT + IF (ITOL .EQ. 0) GO TO 190 + 180 CONTINUE + 190 CONTINUE +C + IF (IDID .NE. (-2)) GO TO 200 +C RTOL=ATOL=0 ON INPUT, SO RTOL IS CHANGED TO A +C SMALL POSITIVE VALUE + IBEGIN = -1 + GO TO 460 + 200 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 450 +C BEGIN BLOCK PERMITTING ...EXITS TO 430 +C BEGIN BLOCK PERMITTING ...EXITS TO 260 +C BEGIN BLOCK PERMITTING ...EXITS TO 230 +C +C BRANCH ON STATUS OF INITIALIZATION INDICATOR +C INIT=0 MEANS INITIAL DERIVATIVES AND +C NOMINAL STEP SIZE +C AND DIRECTION NOT YET SET +C INIT=1 MEANS NOMINAL STEP SIZE AND +C DIRECTION NOT YET SET INIT=2 MEANS NO +C FURTHER INITIALIZATION REQUIRED +C + IF (INIT .EQ. 0) GO TO 210 +C ......EXIT + IF (INIT .EQ. 1) GO TO 230 +C .........EXIT + GO TO 260 + 210 CONTINUE +C +C ................................................ +C +C MORE INITIALIZATION -- +C -- EVALUATE INITIAL +C DERIVATIVES +C + INIT = 1 + CALL DF(T,Y,YH(1,2),RPAR,IPAR) + NFE = 1 +C ...EXIT + IF (T .NE. TOUT) GO TO 230 + IDID = 2 + DO 220 L = 1, NEQ + YPOUT(L) = YH(L,2) + 220 CONTINUE + TOLD = T +C ............EXIT + GO TO 450 + 230 CONTINUE +C +C -- COMPUTE INITIAL STEP SIZE +C -- SAVE SIGN OF INTEGRATION DIRECTION +C -- SET INDEPENDENT AND DEPENDENT VARIABLES +C X AND YH(*) FOR DSTOD +C + LTOL = 1 + DO 240 L = 1, NEQ + IF (ITOL .EQ. 1) LTOL = L + TOL = RTOL(LTOL)*ABS(Y(L)) + ATOL(LTOL) + IF (TOL .EQ. 0.0D0) GO TO 390 + EWT(L) = TOL + 240 CONTINUE +C + BIG = SQRT(D1MACH(2)) + CALL DHSTRT(DF,NEQ,T,TOUT,Y,YH(1,2),EWT,1,U,BIG, + 1 YH(1,3),YH(1,4),YH(1,5),YH(1,6),RPAR, + 2 IPAR,H) +C + DELSGN = SIGN(1.0D0,TOUT-T) + X = T + DO 250 L = 1, NEQ + YH(L,1) = Y(L) + YH(L,2) = H*YH(L,2) + 250 CONTINUE + INIT = 2 + 260 CONTINUE +C +C ...................................................... +C +C ON EACH CALL SET INFORMATION WHICH DETERMINES THE +C ALLOWED INTERVAL OF INTEGRATION BEFORE RETURNING +C WITH AN ANSWER AT TOUT +C + DEL = TOUT - T + ABSDEL = ABS(DEL) +C +C ...................................................... +C +C IF ALREADY PAST OUTPUT POINT, INTERPOLATE AND +C RETURN +C + 270 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 400 +C BEGIN BLOCK PERMITTING ...EXITS TO 380 + IF (ABS(X-T) .LT. ABSDEL) GO TO 290 + CALL DINTYD(TOUT,0,YH,NEQ,Y,INTFLG) + CALL DINTYD(TOUT,1,YH,NEQ,YPOUT,INTFLG) + IDID = 3 + IF (X .NE. TOUT) GO TO 280 + IDID = 2 + INTOUT = .FALSE. + 280 CONTINUE + T = TOUT + TOLD = T +C ..................EXIT + GO TO 450 + 290 CONTINUE +C +C IF CANNOT GO PAST TSTOP AND SUFFICIENTLY +C CLOSE, EXTRAPOLATE AND RETURN +C + IF (ITSTOP .NE. 1) GO TO 310 + IF (ABS(TSTOP-X) .GE. 100.0D0*U*ABS(X)) + 1 GO TO 310 + DT = TOUT - X + DO 300 L = 1, NEQ + Y(L) = YH(L,1) + (DT/H)*YH(L,2) + 300 CONTINUE + CALL DF(TOUT,Y,YPOUT,RPAR,IPAR) + NFE = NFE + 1 + IDID = 3 + T = TOUT + TOLD = T +C ..................EXIT + GO TO 450 + 310 CONTINUE +C + IF (IINTEG .EQ. 0 .OR. .NOT.INTOUT) GO TO 320 +C +C INTERMEDIATE-OUTPUT MODE +C + IDID = 1 + GO TO 370 + 320 CONTINUE +C +C ............................................. +C +C MONITOR NUMBER OF STEPS ATTEMPTED +C + IF (KSTEPS .LE. MAXNUM) GO TO 330 +C +C A SIGNIFICANT AMOUNT OF WORK HAS BEEN +C EXPENDED + IDID = -1 + KSTEPS = 0 + IBEGIN = -1 + GO TO 370 + 330 CONTINUE +C +C .......................................... +C +C LIMIT STEP SIZE AND SET WEIGHT VECTOR +C + HMIN = 100.0D0*U*ABS(X) + HA = MAX(ABS(H),HMIN) + IF (ITSTOP .EQ. 1) + 1 HA = MIN(HA,ABS(TSTOP-X)) + H = SIGN(HA,H) + LTOL = 1 + DO 340 L = 1, NEQ + IF (ITOL .EQ. 1) LTOL = L + EWT(L) = RTOL(LTOL)*ABS(YH(L,1)) + 1 + ATOL(LTOL) +C .........EXIT + IF (EWT(L) .LE. 0.0D0) GO TO 380 + 340 CONTINUE + TOLFAC = U*DVNRMS(NEQ,YH,EWT) +C .........EXIT + IF (TOLFAC .LE. 1.0D0) GO TO 400 +C +C TOLERANCES TOO SMALL + IDID = -2 + TOLFAC = 2.0D0*TOLFAC + RTOL(1) = TOLFAC*RTOL(1) + ATOL(1) = TOLFAC*ATOL(1) + IF (ITOL .EQ. 0) GO TO 360 + DO 350 L = 2, NEQ + RTOL(L) = TOLFAC*RTOL(L) + ATOL(L) = TOLFAC*ATOL(L) + 350 CONTINUE + 360 CONTINUE + IBEGIN = -1 + 370 CONTINUE +C ............EXIT + GO TO 430 + 380 CONTINUE +C +C RELATIVE ERROR CRITERION INAPPROPRIATE + 390 CONTINUE + IDID = -3 + IBEGIN = -1 +C .........EXIT + GO TO 430 + 400 CONTINUE +C +C ................................................... +C +C TAKE A STEP +C + CALL DSTOD(NEQ,Y,YH,NEQ,YH1,EWT,SAVF,ACOR,WM,IWM, + 1 DF,DJAC,RPAR,IPAR) +C + JSTART = -2 + INTOUT = .TRUE. + IF (KFLAG .EQ. 0) GO TO 270 +C +C ...................................................... +C + IF (KFLAG .EQ. -1) GO TO 410 +C +C REPEATED CORRECTOR CONVERGENCE FAILURES + IDID = -6 + IBEGIN = -1 + GO TO 420 + 410 CONTINUE +C +C REPEATED ERROR TEST FAILURES + IDID = -7 + IBEGIN = -1 + 420 CONTINUE + 430 CONTINUE +C +C ......................................................... +C +C STORE VALUES BEFORE RETURNING TO +C DDEBDF + DO 440 L = 1, NEQ + Y(L) = YH(L,1) + YPOUT(L) = YH(L,2)/H + 440 CONTINUE + T = X + TOLD = T + INTOUT = .FALSE. + 450 CONTINUE + 460 CONTINUE + RETURN + END +*DECK DSTOD + SUBROUTINE DSTOD (NEQ, Y, YH, NYH, YH1, EWT, SAVF, ACOR, WM, IWM, + + DF, DJAC, RPAR, IPAR) +C***BEGIN PROLOGUE DSTOD +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEBDF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (STOD-S, DSTOD-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DSTOD integrates a system of first order odes over one step in the +C integrator package DDEBDF. +C ---------------------------------------------------------------------- +C DSTOD performs one step of the integration of an initial value +C problem for a system of ordinary differential equations. +C Note.. DSTOD is independent of the value of the iteration method +C indicator MITER, when this is .NE. 0, and hence is independent +C of the type of chord method used, or the Jacobian structure. +C Communication with DSTOD is done with the following variables.. +C +C Y = An array of length .GE. N used as the Y argument in +C all calls to DF and DJAC. +C NEQ = Integer array containing problem size in NEQ(1), and +C passed as the NEQ argument in all calls to DF and DJAC. +C YH = An NYH by LMAX array containing the dependent variables +C and their approximate scaled derivatives, where +C LMAX = MAXORD + 1. YH(I,J+1) contains the approximate +C J-th derivative of Y(I), scaled by H**J/FACTORIAL(J) +C (J = 0,1,...,NQ). On entry for the first step, the first +C two columns of YH must be set from the initial values. +C NYH = A constant integer .GE. N, the first dimension of YH. +C YH1 = A one-dimensional array occupying the same space as YH. +C EWT = An array of N elements with which the estimated local +C errors in YH are compared. +C SAVF = An array of working storage, of length N. +C ACOR = A work array of length N, used for the accumulated +C corrections. On a successful return, ACOR(I) contains +C the estimated one-step local error in Y(I). +C WM,IWM = DOUBLE PRECISION and INTEGER work arrays associated with +C matrix operations in chord iteration (MITER .NE. 0). +C DPJAC = Name of routine to evaluate and preprocess Jacobian matrix +C if a chord method is being used. +C DSLVS = Name of routine to solve linear system in chord iteration. +C H = The step size to be attempted on the next step. +C H is altered by the error control algorithm during the +C problem. H can be either positive or negative, but its +C sign must remain constant throughout the problem. +C HMIN = The minimum absolute value of the step size H to be used. +C HMXI = Inverse of the maximum absolute value of H to be used. +C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. +C HMIN and HMXI may be changed at any time, but will not +C take effect until the next change of H is considered. +C TN = The independent variable. TN is updated on each step taken. +C JSTART = An integer used for input only, with the following +C values and meanings.. +C 0 Perform the first step. +C .GT.0 Take a new step continuing from the last. +C -1 Take the next step with a new value of H, MAXORD, +C N, METH, MITER, and/or matrix parameters. +C -2 Take the next step with a new value of H, +C but with other inputs unchanged. +C On return, JSTART is set to 1 to facilitate continuation. +C KFLAG = a completion code with the following meanings.. +C 0 The step was successful. +C -1 The requested error could not be achieved. +C -2 Corrector convergence could not be achieved. +C A return with KFLAG = -1 or -2 means either +C ABS(H) = HMIN or 10 consecutive failures occurred. +C On a return with KFLAG negative, the values of TN and +C the YH array are as of the beginning of the last +C step, and H is the last step size attempted. +C MAXORD = The maximum order of integration method to be allowed. +C METH/MITER = The method flags. See description in driver. +C N = The number of first-order differential equations. +C ---------------------------------------------------------------------- +C +C***SEE ALSO DDEBDF +C***ROUTINES CALLED DCFOD, DPJAC, DSLVS, DVNRMS +C***COMMON BLOCKS DDEBD1 +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C 920422 Changed DIMENSION statement. (WRB) +C***END PROLOGUE DSTOD +C + INTEGER I, I1, IALTH, IER, IOD, IOWND, IPAR, IPUP, IREDO, IRET, + 1 IWM, J, JB, JSTART, KFLAG, KSTEPS, L, LMAX, M, MAXORD, + 2 MEO, METH, MITER, N, NCF, NEQ, NEWQ, NFE, NJE, NQ, NQNYH, + 3 NQU, NST, NSTEPJ, NYH + DOUBLE PRECISION ACOR, CONIT, CRATE, DCON, DDN, + 1 DEL, DELP, DSM, DUP, DVNRMS, EL, EL0, ELCO, + 2 EWT, EXDN, EXSM, EXUP, H, HMIN, HMXI, HOLD, HU, R, RC, + 3 RH, RHDN, RHSM, RHUP, RMAX, ROWND, RPAR, SAVF, TESCO, + 4 TN, TOLD, UROUND, WM, Y, YH, YH1 + EXTERNAL DF, DJAC +C + DIMENSION Y(*),YH(NYH,*),YH1(*),EWT(*),SAVF(*),ACOR(*),WM(*), + 1 IWM(*),RPAR(*),IPAR(*) + COMMON /DDEBD1/ ROWND,CONIT,CRATE,EL(13),ELCO(13,12),HOLD,RC,RMAX, + 1 TESCO(3,12),EL0,H,HMIN,HMXI,HU,TN,UROUND,IOWND(7), + 2 KSTEPS,IOD(6),IALTH,IPUP,LMAX,MEO,NQNYH,NSTEPJ, + 3 IER,JSTART,KFLAG,L,METH,MITER,MAXORD,N,NQ,NST,NFE, + 4 NJE,NQU +C +C +C BEGIN BLOCK PERMITTING ...EXITS TO 690 +C BEGIN BLOCK PERMITTING ...EXITS TO 60 +C***FIRST EXECUTABLE STATEMENT DSTOD + KFLAG = 0 + TOLD = TN + NCF = 0 + IF (JSTART .GT. 0) GO TO 160 + IF (JSTART .EQ. -1) GO TO 10 + IF (JSTART .EQ. -2) GO TO 90 +C --------------------------------------------------------- +C ON THE FIRST CALL, THE ORDER IS SET TO 1, AND OTHER +C VARIABLES ARE INITIALIZED. RMAX IS THE MAXIMUM RATIO BY +C WHICH H CAN BE INCREASED IN A SINGLE STEP. IT IS +C INITIALLY 1.E4 TO COMPENSATE FOR THE SMALL INITIAL H, +C BUT THEN IS NORMALLY EQUAL TO 10. IF A FAILURE OCCURS +C (IN CORRECTOR CONVERGENCE OR ERROR TEST), RMAX IS SET AT +C 2 FOR THE NEXT INCREASE. +C --------------------------------------------------------- + LMAX = MAXORD + 1 + NQ = 1 + L = 2 + IALTH = 2 + RMAX = 10000.0D0 + RC = 0.0D0 + EL0 = 1.0D0 + CRATE = 0.7D0 + DELP = 0.0D0 + HOLD = H + MEO = METH + NSTEPJ = 0 + IRET = 3 + GO TO 50 + 10 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 30 +C ------------------------------------------------------ +C THE FOLLOWING BLOCK HANDLES PRELIMINARIES NEEDED WHEN +C JSTART = -1. IPUP IS SET TO MITER TO FORCE A MATRIX +C UPDATE. IF AN ORDER INCREASE IS ABOUT TO BE +C CONSIDERED (IALTH = 1), IALTH IS RESET TO 2 TO +C POSTPONE CONSIDERATION ONE MORE STEP. IF THE CALLER +C HAS CHANGED METH, DCFOD IS CALLED TO RESET THE +C COEFFICIENTS OF THE METHOD. IF THE CALLER HAS +C CHANGED MAXORD TO A VALUE LESS THAN THE CURRENT +C ORDER NQ, NQ IS REDUCED TO MAXORD, AND A NEW H CHOSEN +C ACCORDINGLY. IF H IS TO BE CHANGED, YH MUST BE +C RESCALED. IF H OR METH IS BEING CHANGED, IALTH IS +C RESET TO L = NQ + 1 TO PREVENT FURTHER CHANGES IN H +C FOR THAT MANY STEPS. +C ------------------------------------------------------ + IPUP = MITER + LMAX = MAXORD + 1 + IF (IALTH .EQ. 1) IALTH = 2 + IF (METH .EQ. MEO) GO TO 20 + CALL DCFOD(METH,ELCO,TESCO) + MEO = METH +C ......EXIT + IF (NQ .GT. MAXORD) GO TO 30 + IALTH = L + IRET = 1 +C ............EXIT + GO TO 60 + 20 CONTINUE + IF (NQ .LE. MAXORD) GO TO 90 + 30 CONTINUE + NQ = MAXORD + L = LMAX + DO 40 I = 1, L + EL(I) = ELCO(I,NQ) + 40 CONTINUE + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/(NQ+2) + DDN = DVNRMS(N,SAVF,EWT)/TESCO(1,L) + EXDN = 1.0D0/L + RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) + RH = MIN(RHDN,1.0D0) + IREDO = 3 + IF (H .EQ. HOLD) GO TO 660 + RH = MIN(RH,ABS(H/HOLD)) + H = HOLD + GO TO 100 + 50 CONTINUE +C ------------------------------------------------------------ +C DCFOD IS CALLED TO GET ALL THE INTEGRATION COEFFICIENTS +C FOR THE CURRENT METH. THEN THE EL VECTOR AND RELATED +C CONSTANTS ARE RESET WHENEVER THE ORDER NQ IS CHANGED, OR AT +C THE START OF THE PROBLEM. +C ------------------------------------------------------------ + CALL DCFOD(METH,ELCO,TESCO) + 60 CONTINUE + 70 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 680 + DO 80 I = 1, L + EL(I) = ELCO(I,NQ) + 80 CONTINUE + NQNYH = NQ*NYH + RC = RC*EL(1)/EL0 + EL0 = EL(1) + CONIT = 0.5D0/(NQ+2) + GO TO (90,660,160), IRET +C --------------------------------------------------------- +C IF H IS BEING CHANGED, THE H RATIO RH IS CHECKED AGAINST +C RMAX, HMIN, AND HMXI, AND THE YH ARRAY RESCALED. IALTH +C IS SET TO L = NQ + 1 TO PREVENT A CHANGE OF H FOR THAT +C MANY STEPS, UNLESS FORCED BY A CONVERGENCE OR ERROR TEST +C FAILURE. +C --------------------------------------------------------- + 90 CONTINUE + IF (H .EQ. HOLD) GO TO 160 + RH = H/HOLD + H = HOLD + IREDO = 3 + 100 CONTINUE + 110 CONTINUE + RH = MIN(RH,RMAX) + RH = RH/MAX(1.0D0,ABS(H)*HMXI*RH) + R = 1.0D0 + DO 130 J = 2, L + R = R*RH + DO 120 I = 1, N + YH(I,J) = YH(I,J)*R + 120 CONTINUE + 130 CONTINUE + H = H*RH + RC = RC*RH + IALTH = L + IF (IREDO .NE. 0) GO TO 150 + RMAX = 10.0D0 + R = 1.0D0/TESCO(2,NQU) + DO 140 I = 1, N + ACOR(I) = ACOR(I)*R + 140 CONTINUE +C ...............EXIT + GO TO 690 + 150 CONTINUE +C ------------------------------------------------------ +C THIS SECTION COMPUTES THE PREDICTED VALUES BY +C EFFECTIVELY MULTIPLYING THE YH ARRAY BY THE PASCAL +C TRIANGLE MATRIX. RC IS THE RATIO OF NEW TO OLD +C VALUES OF THE COEFFICIENT H*EL(1). WHEN RC DIFFERS +C FROM 1 BY MORE THAN 30 PERCENT, IPUP IS SET TO MITER +C TO FORCE DPJAC TO BE CALLED, IF A JACOBIAN IS +C INVOLVED. IN ANY CASE, DPJAC IS CALLED AT LEAST +C EVERY 20-TH STEP. +C ------------------------------------------------------ + 160 CONTINUE + 170 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 610 +C BEGIN BLOCK PERMITTING ...EXITS TO 490 + IF (ABS(RC-1.0D0) .GT. 0.3D0) IPUP = MITER + IF (NST .GE. NSTEPJ + 20) IPUP = MITER + TN = TN + H + I1 = NQNYH + 1 + DO 190 JB = 1, NQ + I1 = I1 - NYH + DO 180 I = I1, NQNYH + YH1(I) = YH1(I) + YH1(I+NYH) + 180 CONTINUE + 190 CONTINUE + KSTEPS = KSTEPS + 1 +C --------------------------------------------- +C UP TO 3 CORRECTOR ITERATIONS ARE TAKEN. A +C CONVERGENCE TEST IS MADE ON THE R.M.S. NORM +C OF EACH CORRECTION, WEIGHTED BY THE ERROR +C WEIGHT VECTOR EWT. THE SUM OF THE +C CORRECTIONS IS ACCUMULATED IN THE VECTOR +C ACOR(I). THE YH ARRAY IS NOT ALTERED IN THE +C CORRECTOR LOOP. +C --------------------------------------------- + 200 CONTINUE + M = 0 + DO 210 I = 1, N + Y(I) = YH(I,1) + 210 CONTINUE + CALL DF(TN,Y,SAVF,RPAR,IPAR) + NFE = NFE + 1 + IF (IPUP .LE. 0) GO TO 220 +C --------------------------------------- +C IF INDICATED, THE MATRIX P = I - +C H*EL(1)*J IS REEVALUATED AND +C PREPROCESSED BEFORE STARTING THE +C CORRECTOR ITERATION. IPUP IS SET TO 0 +C AS AN INDICATOR THAT THIS HAS BEEN +C DONE. +C --------------------------------------- + IPUP = 0 + RC = 1.0D0 + NSTEPJ = NST + CRATE = 0.7D0 + CALL DPJAC(NEQ,Y,YH,NYH,EWT,ACOR,SAVF, + 1 WM,IWM,DF,DJAC,RPAR,IPAR) +C ......EXIT + IF (IER .NE. 0) GO TO 440 + 220 CONTINUE + DO 230 I = 1, N + ACOR(I) = 0.0D0 + 230 CONTINUE + 240 CONTINUE + IF (MITER .NE. 0) GO TO 270 +C ------------------------------------ +C IN THE CASE OF FUNCTIONAL +C ITERATION, UPDATE Y DIRECTLY FROM +C THE RESULT OF THE LAST FUNCTION +C EVALUATION. +C ------------------------------------ + DO 250 I = 1, N + SAVF(I) = H*SAVF(I) - YH(I,2) + Y(I) = SAVF(I) - ACOR(I) + 250 CONTINUE + DEL = DVNRMS(N,Y,EWT) + DO 260 I = 1, N + Y(I) = YH(I,1) + EL(1)*SAVF(I) + ACOR(I) = SAVF(I) + 260 CONTINUE + GO TO 300 + 270 CONTINUE +C ------------------------------------ +C IN THE CASE OF THE CHORD METHOD, +C COMPUTE THE CORRECTOR ERROR, AND +C SOLVE THE LINEAR SYSTEM WITH THAT +C AS RIGHT-HAND SIDE AND P AS +C COEFFICIENT MATRIX. +C ------------------------------------ + DO 280 I = 1, N + Y(I) = H*SAVF(I) + 1 - (YH(I,2) + ACOR(I)) + 280 CONTINUE + CALL DSLVS(WM,IWM,Y,SAVF) +C ......EXIT + IF (IER .NE. 0) GO TO 430 + DEL = DVNRMS(N,Y,EWT) + DO 290 I = 1, N + ACOR(I) = ACOR(I) + Y(I) + Y(I) = YH(I,1) + EL(1)*ACOR(I) + 290 CONTINUE + 300 CONTINUE +C --------------------------------------- +C TEST FOR CONVERGENCE. IF M.GT.0, AN +C ESTIMATE OF THE CONVERGENCE RATE +C CONSTANT IS STORED IN CRATE, AND THIS +C IS USED IN THE TEST. +C --------------------------------------- + IF (M .NE. 0) + 1 CRATE = MAX(0.2D0*CRATE,DEL/DELP) + DCON = DEL*MIN(1.0D0,1.5D0*CRATE) + 1 /(TESCO(2,NQ)*CONIT) + IF (DCON .GT. 1.0D0) GO TO 420 +C ------------------------------------ +C THE CORRECTOR HAS CONVERGED. IPUP +C IS SET TO -1 IF MITER .NE. 0, TO +C SIGNAL THAT THE JACOBIAN INVOLVED +C MAY NEED UPDATING LATER. THE LOCAL +C ERROR TEST IS MADE AND CONTROL +C PASSES TO STATEMENT 500 IF IT +C FAILS. +C ------------------------------------ + IF (MITER .NE. 0) IPUP = -1 + IF (M .EQ. 0) DSM = DEL/TESCO(2,NQ) + IF (M .GT. 0) + 1 DSM = DVNRMS(N,ACOR,EWT) + 2 /TESCO(2,NQ) + IF (DSM .GT. 1.0D0) GO TO 380 +C BEGIN BLOCK +C PERMITTING ...EXITS TO 360 +C ------------------------------ +C AFTER A SUCCESSFUL STEP, +C UPDATE THE YH ARRAY. +C CONSIDER CHANGING H IF IALTH +C = 1. OTHERWISE DECREASE +C IALTH BY 1. IF IALTH IS THEN +C 1 AND NQ .LT. MAXORD, THEN +C ACOR IS SAVED FOR USE IN A +C POSSIBLE ORDER INCREASE ON +C THE NEXT STEP. IF A CHANGE +C IN H IS CONSIDERED, AN +C INCREASE OR DECREASE IN ORDER +C BY ONE IS CONSIDERED ALSO. A +C CHANGE IN H IS MADE ONLY IF +C IT IS BY A FACTOR OF AT LEAST +C 1.1. IF NOT, IALTH IS SET TO +C 3 TO PREVENT TESTING FOR THAT +C MANY STEPS. +C ------------------------------ + KFLAG = 0 + IREDO = 0 + NST = NST + 1 + HU = H + NQU = NQ + DO 320 J = 1, L + DO 310 I = 1, N + YH(I,J) = YH(I,J) + 1 + EL(J) + 2 *ACOR(I) + 310 CONTINUE + 320 CONTINUE + IALTH = IALTH - 1 + IF (IALTH .NE. 0) GO TO 340 +C --------------------------- +C REGARDLESS OF THE SUCCESS +C OR FAILURE OF THE STEP, +C FACTORS RHDN, RHSM, AND +C RHUP ARE COMPUTED, BY +C WHICH H COULD BE +C MULTIPLIED AT ORDER NQ - +C 1, ORDER NQ, OR ORDER NQ + +C 1, RESPECTIVELY. IN THE +C CASE OF FAILURE, RHUP = +C 0.0 TO AVOID AN ORDER +C INCREASE. THE LARGEST OF +C THESE IS DETERMINED AND +C THE NEW ORDER CHOSEN +C ACCORDINGLY. IF THE ORDER +C IS TO BE INCREASED, WE +C COMPUTE ONE ADDITIONAL +C SCALED DERIVATIVE. +C --------------------------- + RHUP = 0.0D0 +C .....................EXIT + IF (L .EQ. LMAX) GO TO 490 + DO 330 I = 1, N + SAVF(I) = ACOR(I) + 1 - YH(I,LMAX) + 330 CONTINUE + DUP = DVNRMS(N,SAVF,EWT) + 1 /TESCO(3,NQ) + EXUP = 1.0D0/(L+1) + RHUP = 1.0D0 + 1 /(1.4D0*DUP**EXUP + 2 + 0.0000014D0) +C .....................EXIT + GO TO 490 + 340 CONTINUE +C ...EXIT + IF (IALTH .GT. 1) GO TO 360 +C ...EXIT + IF (L .EQ. LMAX) GO TO 360 + DO 350 I = 1, N + YH(I,LMAX) = ACOR(I) + 350 CONTINUE + 360 CONTINUE + R = 1.0D0/TESCO(2,NQU) + DO 370 I = 1, N + ACOR(I) = ACOR(I)*R + 370 CONTINUE +C .................................EXIT + GO TO 690 + 380 CONTINUE +C ------------------------------------ +C THE ERROR TEST FAILED. KFLAG KEEPS +C TRACK OF MULTIPLE FAILURES. +C RESTORE TN AND THE YH ARRAY TO +C THEIR PREVIOUS VALUES, AND PREPARE +C TO TRY THE STEP AGAIN. COMPUTE THE +C OPTIMUM STEP SIZE FOR THIS OR ONE +C LOWER ORDER. AFTER 2 OR MORE +C FAILURES, H IS FORCED TO DECREASE +C BY A FACTOR OF 0.2 OR LESS. +C ------------------------------------ + KFLAG = KFLAG - 1 + TN = TOLD + I1 = NQNYH + 1 + DO 400 JB = 1, NQ + I1 = I1 - NYH + DO 390 I = I1, NQNYH + YH1(I) = YH1(I) - YH1(I+NYH) + 390 CONTINUE + 400 CONTINUE + RMAX = 2.0D0 + IF (ABS(H) .GT. HMIN*1.00001D0) + 1 GO TO 410 +C --------------------------------- +C ALL RETURNS ARE MADE THROUGH +C THIS SECTION. H IS SAVED IN +C HOLD TO ALLOW THE CALLER TO +C CHANGE H ON THE NEXT STEP. +C --------------------------------- + KFLAG = -1 +C .................................EXIT + GO TO 690 + 410 CONTINUE +C ...............EXIT + IF (KFLAG .LE. -3) GO TO 610 + IREDO = 2 + RHUP = 0.0D0 +C ............EXIT + GO TO 490 + 420 CONTINUE + M = M + 1 +C ...EXIT + IF (M .EQ. 3) GO TO 430 +C ...EXIT + IF (M .GE. 2 .AND. DEL .GT. 2.0D0*DELP) + 1 GO TO 430 + DELP = DEL + CALL DF(TN,Y,SAVF,RPAR,IPAR) + NFE = NFE + 1 + GO TO 240 + 430 CONTINUE +C ------------------------------------------ +C THE CORRECTOR ITERATION FAILED TO +C CONVERGE IN 3 TRIES. IF MITER .NE. 0 AND +C THE JACOBIAN IS OUT OF DATE, DPJAC IS +C CALLED FOR THE NEXT TRY. OTHERWISE THE +C YH ARRAY IS RETRACTED TO ITS VALUES +C BEFORE PREDICTION, AND H IS REDUCED, IF +C POSSIBLE. IF H CANNOT BE REDUCED OR 10 +C FAILURES HAVE OCCURRED, EXIT WITH KFLAG = +C -2. +C ------------------------------------------ +C ...EXIT + IF (IPUP .EQ. 0) GO TO 440 + IPUP = MITER + GO TO 200 + 440 CONTINUE + TN = TOLD + NCF = NCF + 1 + RMAX = 2.0D0 + I1 = NQNYH + 1 + DO 460 JB = 1, NQ + I1 = I1 - NYH + DO 450 I = I1, NQNYH + YH1(I) = YH1(I) - YH1(I+NYH) + 450 CONTINUE + 460 CONTINUE + IF (ABS(H) .GT. HMIN*1.00001D0) GO TO 470 + KFLAG = -2 +C ........................EXIT + GO TO 690 + 470 CONTINUE + IF (NCF .NE. 10) GO TO 480 + KFLAG = -2 +C ........................EXIT + GO TO 690 + 480 CONTINUE + RH = 0.25D0 + IPUP = MITER + IREDO = 1 +C .........EXIT + GO TO 650 + 490 CONTINUE + EXSM = 1.0D0/L + RHSM = 1.0D0/(1.2D0*DSM**EXSM + 0.0000012D0) + RHDN = 0.0D0 + IF (NQ .EQ. 1) GO TO 500 + DDN = DVNRMS(N,YH(1,L),EWT)/TESCO(1,NQ) + EXDN = 1.0D0/NQ + RHDN = 1.0D0/(1.3D0*DDN**EXDN + 0.0000013D0) + 500 CONTINUE + IF (RHSM .GE. RHUP) GO TO 550 + IF (RHUP .LE. RHDN) GO TO 540 + NEWQ = L + RH = RHUP + IF (RH .GE. 1.1D0) GO TO 520 + IALTH = 3 + R = 1.0D0/TESCO(2,NQU) + DO 510 I = 1, N + ACOR(I) = ACOR(I)*R + 510 CONTINUE +C ...........................EXIT + GO TO 690 + 520 CONTINUE + R = EL(L)/L + DO 530 I = 1, N + YH(I,NEWQ+1) = ACOR(I)*R + 530 CONTINUE + NQ = NEWQ + L = NQ + 1 + IRET = 2 +C ..................EXIT + GO TO 680 + 540 CONTINUE + GO TO 580 + 550 CONTINUE + IF (RHSM .LT. RHDN) GO TO 580 + NEWQ = NQ + RH = RHSM + IF (KFLAG .EQ. 0 .AND. RH .LT. 1.1D0) + 1 GO TO 560 + IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) +C ------------------------------------------ +C IF THERE IS A CHANGE OF ORDER, RESET NQ, +C L, AND THE COEFFICIENTS. IN ANY CASE H +C IS RESET ACCORDING TO RH AND THE YH ARRAY +C IS RESCALED. THEN EXIT FROM 680 IF THE +C STEP WAS OK, OR REDO THE STEP OTHERWISE. +C ------------------------------------------ +C ............EXIT + IF (NEWQ .EQ. NQ) GO TO 650 + NQ = NEWQ + L = NQ + 1 + IRET = 2 +C ..................EXIT + GO TO 680 + 560 CONTINUE + IALTH = 3 + R = 1.0D0/TESCO(2,NQU) + DO 570 I = 1, N + ACOR(I) = ACOR(I)*R + 570 CONTINUE +C .....................EXIT + GO TO 690 + 580 CONTINUE + NEWQ = NQ - 1 + RH = RHDN + IF (KFLAG .LT. 0 .AND. RH .GT. 1.0D0) RH = 1.0D0 + IF (KFLAG .EQ. 0 .AND. RH .LT. 1.1D0) GO TO 590 + IF (KFLAG .LE. -2) RH = MIN(RH,0.2D0) +C --------------------------------------------- +C IF THERE IS A CHANGE OF ORDER, RESET NQ, L, +C AND THE COEFFICIENTS. IN ANY CASE H IS +C RESET ACCORDING TO RH AND THE YH ARRAY IS +C RESCALED. THEN EXIT FROM 680 IF THE STEP +C WAS OK, OR REDO THE STEP OTHERWISE. +C --------------------------------------------- +C .........EXIT + IF (NEWQ .EQ. NQ) GO TO 650 + NQ = NEWQ + L = NQ + 1 + IRET = 2 +C ...............EXIT + GO TO 680 + 590 CONTINUE + IALTH = 3 + R = 1.0D0/TESCO(2,NQU) + DO 600 I = 1, N + ACOR(I) = ACOR(I)*R + 600 CONTINUE +C ..................EXIT + GO TO 690 + 610 CONTINUE +C --------------------------------------------------- +C CONTROL REACHES THIS SECTION IF 3 OR MORE FAILURES +C HAVE OCCURRED. IF 10 FAILURES HAVE OCCURRED, EXIT +C WITH KFLAG = -1. IT IS ASSUMED THAT THE +C DERIVATIVES THAT HAVE ACCUMULATED IN THE YH ARRAY +C HAVE ERRORS OF THE WRONG ORDER. HENCE THE FIRST +C DERIVATIVE IS RECOMPUTED, AND THE ORDER IS SET TO +C 1. THEN H IS REDUCED BY A FACTOR OF 10, AND THE +C STEP IS RETRIED, UNTIL IT SUCCEEDS OR H REACHES +C HMIN. +C --------------------------------------------------- + IF (KFLAG .NE. -10) GO TO 620 +C ------------------------------------------------ +C ALL RETURNS ARE MADE THROUGH THIS SECTION. H +C IS SAVED IN HOLD TO ALLOW THE CALLER TO CHANGE +C H ON THE NEXT STEP. +C ------------------------------------------------ + KFLAG = -1 +C ..................EXIT + GO TO 690 + 620 CONTINUE + RH = 0.1D0 + RH = MAX(HMIN/ABS(H),RH) + H = H*RH + DO 630 I = 1, N + Y(I) = YH(I,1) + 630 CONTINUE + CALL DF(TN,Y,SAVF,RPAR,IPAR) + NFE = NFE + 1 + DO 640 I = 1, N + YH(I,2) = H*SAVF(I) + 640 CONTINUE + IPUP = MITER + IALTH = 5 +C ......EXIT + IF (NQ .NE. 1) GO TO 670 + GO TO 170 + 650 CONTINUE + 660 CONTINUE + RH = MAX(RH,HMIN/ABS(H)) + GO TO 110 + 670 CONTINUE + NQ = 1 + L = 2 + IRET = 3 + 680 CONTINUE + GO TO 70 + 690 CONTINUE + HOLD = H + JSTART = 1 + RETURN +C ----------------------- END OF SUBROUTINE DSTOD +C ----------------------- + END +*DECK DCFOD + SUBROUTINE DCFOD (METH, ELCO, TESCO) +C***BEGIN PROLOGUE DCFOD +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEBDF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (CFOD-S, DCFOD-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C DCFOD defines coefficients needed in the integrator package DDEBDF +C +C***SEE ALSO DDEBDF +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890911 Removed unnecessary intrinsics. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE DCFOD +C +C + INTEGER I, IB, METH, NQ, NQM1, NQP1 + DOUBLE PRECISION AGAMQ, ELCO, FNQ, FNQM1, PC, PINT, RAGQ, + 1 RQ1FAC, RQFAC, TESCO, TSIGN, XPIN + DIMENSION ELCO(13,12),TESCO(3,12) +C ------------------------------------------------------------------ +C DCFOD IS CALLED BY THE INTEGRATOR ROUTINE TO SET COEFFICIENTS +C NEEDED THERE. THE COEFFICIENTS FOR THE CURRENT METHOD, AS +C GIVEN BY THE VALUE OF METH, ARE SET FOR ALL ORDERS AND SAVED. +C THE MAXIMUM ORDER ASSUMED HERE IS 12 IF METH = 1 AND 5 IF METH = +C 2. (A SMALLER VALUE OF THE MAXIMUM ORDER IS ALSO ALLOWED.) +C DCFOD IS CALLED ONCE AT THE BEGINNING OF THE PROBLEM, +C AND IS NOT CALLED AGAIN UNLESS AND UNTIL METH IS CHANGED. +C +C THE ELCO ARRAY CONTAINS THE BASIC METHOD COEFFICIENTS. +C THE COEFFICIENTS EL(I), 1 .LE. I .LE. NQ+1, FOR THE METHOD OF +C ORDER NQ ARE STORED IN ELCO(I,NQ). THEY ARE GIVEN BY A +C GENERATING POLYNOMIAL, I.E., +C L(X) = EL(1) + EL(2)*X + ... + EL(NQ+1)*X**NQ. +C FOR THE IMPLICIT ADAMS METHODS, L(X) IS GIVEN BY +C DL/DX = (X+1)*(X+2)*...*(X+NQ-1)/FACTORIAL(NQ-1), L(-1) = +C 0. FOR THE BDF METHODS, L(X) IS GIVEN BY +C L(X) = (X+1)*(X+2)* ... *(X+NQ)/K, +C WHERE K = FACTORIAL(NQ)*(1 + 1/2 + ... + 1/NQ). +C +C THE TESCO ARRAY CONTAINS TEST CONSTANTS USED FOR THE +C LOCAL ERROR TEST AND THE SELECTION OF STEP SIZE AND/OR ORDER. +C AT ORDER NQ, TESCO(K,NQ) IS USED FOR THE SELECTION OF STEP +C SIZE AT ORDER NQ - 1 IF K = 1, AT ORDER NQ IF K = 2, AND AT ORDER +C NQ + 1 IF K = 3. +C ------------------------------------------------------------------ + DIMENSION PC(12) +C +C***FIRST EXECUTABLE STATEMENT DCFOD + GO TO (10,60), METH +C + 10 CONTINUE + ELCO(1,1) = 1.0D0 + ELCO(2,1) = 1.0D0 + TESCO(1,1) = 0.0D0 + TESCO(2,1) = 2.0D0 + TESCO(1,2) = 1.0D0 + TESCO(3,12) = 0.0D0 + PC(1) = 1.0D0 + RQFAC = 1.0D0 + DO 50 NQ = 2, 12 +C ------------------------------------------------------------ +C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE +C POLYNOMIAL P(X) = (X+1)*(X+2)*...*(X+NQ-1). +C INITIALLY, P(X) = 1. +C ------------------------------------------------------------ + RQ1FAC = RQFAC + RQFAC = RQFAC/NQ + NQM1 = NQ - 1 + FNQM1 = NQM1 + NQP1 = NQ + 1 +C FORM COEFFICIENTS OF P(X)*(X+NQ-1). +C ---------------------------------- + PC(NQ) = 0.0D0 + DO 20 IB = 1, NQM1 + I = NQP1 - IB + PC(I) = PC(I-1) + FNQM1*PC(I) + 20 CONTINUE + PC(1) = FNQM1*PC(1) +C COMPUTE INTEGRAL, -1 TO 0, OF P(X) AND X*P(X). +C ----------------------- + PINT = PC(1) + XPIN = PC(1)/2.0D0 + TSIGN = 1.0D0 + DO 30 I = 2, NQ + TSIGN = -TSIGN + PINT = PINT + TSIGN*PC(I)/I + XPIN = XPIN + TSIGN*PC(I)/(I+1) + 30 CONTINUE +C STORE COEFFICIENTS IN ELCO AND TESCO. +C -------------------------------- + ELCO(1,NQ) = PINT*RQ1FAC + ELCO(2,NQ) = 1.0D0 + DO 40 I = 2, NQ + ELCO(I+1,NQ) = RQ1FAC*PC(I)/I + 40 CONTINUE + AGAMQ = RQFAC*XPIN + RAGQ = 1.0D0/AGAMQ + TESCO(2,NQ) = RAGQ + IF (NQ .LT. 12) TESCO(1,NQP1) = RAGQ*RQFAC/NQP1 + TESCO(3,NQM1) = RAGQ + 50 CONTINUE + GO TO 100 +C + 60 CONTINUE + PC(1) = 1.0D0 + RQ1FAC = 1.0D0 + DO 90 NQ = 1, 5 +C ------------------------------------------------------------ +C THE PC ARRAY WILL CONTAIN THE COEFFICIENTS OF THE +C POLYNOMIAL P(X) = (X+1)*(X+2)*...*(X+NQ). +C INITIALLY, P(X) = 1. +C ------------------------------------------------------------ + FNQ = NQ + NQP1 = NQ + 1 +C FORM COEFFICIENTS OF P(X)*(X+NQ). +C ------------------------------------ + PC(NQP1) = 0.0D0 + DO 70 IB = 1, NQ + I = NQ + 2 - IB + PC(I) = PC(I-1) + FNQ*PC(I) + 70 CONTINUE + PC(1) = FNQ*PC(1) +C STORE COEFFICIENTS IN ELCO AND TESCO. +C -------------------------------- + DO 80 I = 1, NQP1 + ELCO(I,NQ) = PC(I)/PC(2) + 80 CONTINUE + ELCO(2,NQ) = 1.0D0 + TESCO(1,NQ) = RQ1FAC + TESCO(2,NQ) = NQP1/ELCO(1,NQ) + TESCO(3,NQ) = (NQ+2)/ELCO(1,NQ) + RQ1FAC = RQ1FAC/FNQ + 90 CONTINUE + 100 CONTINUE + RETURN +C ----------------------- END OF SUBROUTINE DCFOD +C ----------------------- + END +*DECK DVNRMS + DOUBLE PRECISION FUNCTION DVNRMS (N, V, W) +C***BEGIN PROLOGUE DVNRMS +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEBDF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (VNWRMS-S, DVNRMS-D) +C***AUTHOR (UNKNOWN) +C***DESCRIPTION +C +C DVNRMS computes a weighted root-mean-square vector norm for the +C integrator package DDEBDF. +C +C***SEE ALSO DDEBDF +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C***END PROLOGUE DVNRMS + INTEGER I, N + DOUBLE PRECISION SUM, V, W + DIMENSION V(*),W(*) +C***FIRST EXECUTABLE STATEMENT DVNRMS + SUM = 0.0D0 + DO 10 I = 1, N + SUM = SUM + (V(I)/W(I))**2 + 10 CONTINUE + DVNRMS = SQRT(SUM/N) + RETURN +C ----------------------- END OF FUNCTION DVNRMS +C ------------------------ + END +*DECK DINTYD + SUBROUTINE DINTYD (T, K, YH, NYH, DKY, IFLAG) +C***BEGIN PROLOGUE DINTYD +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEBDF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (INTYD-S, DINTYD-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DINTYD approximates the solution and derivatives at T by polynomial +C interpolation. Must be used in conjunction with the integrator +C package DDEBDF. +C ---------------------------------------------------------------------- +C DINTYD computes interpolated values of the K-th derivative of the +C dependent variable vector Y, and stores it in DKY. +C This routine is called by DDEBDF with K = 0,1 and T = TOUT, but may +C also be called by the user for any K up to the current order. +C (see detailed instructions in LSODE usage documentation.) +C ---------------------------------------------------------------------- +C The computed values in DKY are gotten by interpolation using the +C Nordsieck history array YH. This array corresponds uniquely to a +C vector-valued polynomial of degree NQCUR or less, and DKY is set +C to the K-th derivative of this polynomial at T. +C The formula for DKY is.. +C Q +C DKY(I) = Sum C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1) +C J=K +C where C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR. +C The quantities NQ = NQCUR, L = NQ+1, N = NEQ, TN, and H are +C communicated by common. The above sum is done in reverse order. +C IFLAG is returned negative if either K or T is out of bounds. +C ---------------------------------------------------------------------- +C +C***SEE ALSO DDEBDF +C***ROUTINES CALLED (NONE) +C***COMMON BLOCKS DDEBD1 +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890911 Removed unnecessary intrinsics. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DINTYD +C + INTEGER I, IC, IER, IFLAG, IOWND, IOWNS, J, JB, JB2, JJ, JJ1, + 1 JP1, JSTART, K, KFLAG, L, MAXORD, METH, MITER, N, NFE, + 2 NJE, NQ, NQU, NST, NYH + DOUBLE PRECISION C, DKY, EL0, H, HMIN, HMXI, HU, R, ROWND, + 1 ROWNS, S, T, TN, TP, UROUND, YH + DIMENSION YH(NYH,*),DKY(*) + COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, + 1 IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, + 2 MAXORD,N,NQ,NST,NFE,NJE,NQU +C +C BEGIN BLOCK PERMITTING ...EXITS TO 130 +C***FIRST EXECUTABLE STATEMENT DINTYD + IFLAG = 0 + IF (K .LT. 0 .OR. K .GT. NQ) GO TO 110 + TP = TN - HU*(1.0D0 + 100.0D0*UROUND) + IF ((T - TP)*(T - TN) .LE. 0.0D0) GO TO 10 + IFLAG = -2 +C .........EXIT + GO TO 130 + 10 CONTINUE +C + S = (T - TN)/H + IC = 1 + IF (K .EQ. 0) GO TO 30 + JJ1 = L - K + DO 20 JJ = JJ1, NQ + IC = IC*JJ + 20 CONTINUE + 30 CONTINUE + C = IC + DO 40 I = 1, N + DKY(I) = C*YH(I,L) + 40 CONTINUE + IF (K .EQ. NQ) GO TO 90 + JB2 = NQ - K + DO 80 JB = 1, JB2 + J = NQ - JB + JP1 = J + 1 + IC = 1 + IF (K .EQ. 0) GO TO 60 + JJ1 = JP1 - K + DO 50 JJ = JJ1, J + IC = IC*JJ + 50 CONTINUE + 60 CONTINUE + C = IC + DO 70 I = 1, N + DKY(I) = C*YH(I,JP1) + S*DKY(I) + 70 CONTINUE + 80 CONTINUE +C .........EXIT + IF (K .EQ. 0) GO TO 130 + 90 CONTINUE + R = H**(-K) + DO 100 I = 1, N + DKY(I) = R*DKY(I) + 100 CONTINUE + GO TO 120 + 110 CONTINUE +C + IFLAG = -1 + 120 CONTINUE + 130 CONTINUE + RETURN +C ----------------------- END OF SUBROUTINE DINTYD +C ----------------------- + END +*DECK DPJAC + SUBROUTINE DPJAC (NEQ, Y, YH, NYH, EWT, FTEM, SAVF, WM, IWM, DF, + + DJAC, RPAR, IPAR) +C***BEGIN PROLOGUE DPJAC +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEBDF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (PJAC-S, DPJAC-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DPJAC sets up the iteration matrix (involving the Jacobian) for the +C integration package DDEBDF. +C +C***SEE ALSO DDEBDF +C***ROUTINES CALLED DGBFA, DGEFA, DVNRMS +C***COMMON BLOCKS DDEBD1 +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C 920422 Changed DIMENSION statement. (WRB) +C***END PROLOGUE DPJAC +C + INTEGER I, I1, I2, IER, II, IOWND, IOWNS, IPAR, IWM, J, J1, + 1 JJ, JSTART, KFLAG, L, LENP, MAXORD, MBA, MBAND, + 2 MEB1, MEBAND, METH, MITER, ML, ML3, MU, N, NEQ, + 3 NFE, NJE, NQ, NQU, NST, NYH + DOUBLE PRECISION CON, DI, DVNRMS, EL0, EWT, + 1 FAC, FTEM, H, HL0, HMIN, HMXI, HU, R, R0, ROWND, ROWNS, + 2 RPAR, SAVF, SRUR, TN, UROUND, WM, Y, YH, YI, YJ, YJJ + EXTERNAL DF, DJAC + DIMENSION Y(*),YH(NYH,*),EWT(*),FTEM(*),SAVF(*),WM(*),IWM(*), + 1 RPAR(*),IPAR(*) + COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, + 1 IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, + 2 MAXORD,N,NQ,NST,NFE,NJE,NQU +C ------------------------------------------------------------------ +C DPJAC IS CALLED BY DSTOD TO COMPUTE AND PROCESS THE MATRIX +C P = I - H*EL(1)*J , WHERE J IS AN APPROXIMATION TO THE JACOBIAN. +C HERE J IS COMPUTED BY THE USER-SUPPLIED ROUTINE DJAC IF +C MITER = 1 OR 4, OR BY FINITE DIFFERENCING IF MITER = 2, 3, OR 5. +C IF MITER = 3, A DIAGONAL APPROXIMATION TO J IS USED. +C J IS STORED IN WM AND REPLACED BY P. IF MITER .NE. 3, P IS THEN +C SUBJECTED TO LU DECOMPOSITION IN PREPARATION FOR LATER SOLUTION +C OF LINEAR SYSTEMS WITH P AS COEFFICIENT MATRIX. THIS IS DONE +C BY DGEFA IF MITER = 1 OR 2, AND BY DGBFA IF MITER = 4 OR 5. +C +C IN ADDITION TO VARIABLES DESCRIBED PREVIOUSLY, COMMUNICATION +C WITH DPJAC USES THE FOLLOWING.. +C Y = ARRAY CONTAINING PREDICTED VALUES ON ENTRY. +C FTEM = WORK ARRAY OF LENGTH N (ACOR IN DSTOD ). +C SAVF = ARRAY CONTAINING DF EVALUATED AT PREDICTED Y. +C WM = DOUBLE PRECISION WORK SPACE FOR MATRICES. ON OUTPUT IT +C CONTAINS THE +C INVERSE DIAGONAL MATRIX IF MITER = 3 AND THE LU +C DECOMPOSITION OF P IF MITER IS 1, 2 , 4, OR 5. +C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). +C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. +C WM(1) = SQRT(UROUND), USED IN NUMERICAL JACOBIAN +C INCREMENTS. WM(2) = H*EL0, SAVED FOR LATER USE IF MITER = +C 3. +C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING +C AT IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS +C THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER +C IS 4 OR 5. +C EL0 = EL(1) (INPUT). +C IER = OUTPUT ERROR FLAG, = 0 IF NO TROUBLE, .NE. 0 IF +C P MATRIX FOUND TO BE SINGULAR. +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, TN, UROUND, +C MITER, N, NFE, AND NJE. +C----------------------------------------------------------------------- +C BEGIN BLOCK PERMITTING ...EXITS TO 240 +C BEGIN BLOCK PERMITTING ...EXITS TO 220 +C BEGIN BLOCK PERMITTING ...EXITS TO 130 +C BEGIN BLOCK PERMITTING ...EXITS TO 70 +C***FIRST EXECUTABLE STATEMENT DPJAC + NJE = NJE + 1 + HL0 = H*EL0 + GO TO (10,40,90,140,170), MITER +C IF MITER = 1, CALL DJAC AND MULTIPLY BY SCALAR. +C ----------------------- + 10 CONTINUE + LENP = N*N + DO 20 I = 1, LENP + WM(I+2) = 0.0D0 + 20 CONTINUE + CALL DJAC(TN,Y,WM(3),N,RPAR,IPAR) + CON = -HL0 + DO 30 I = 1, LENP + WM(I+2) = WM(I+2)*CON + 30 CONTINUE +C ...EXIT + GO TO 70 +C IF MITER = 2, MAKE N CALLS TO DF TO APPROXIMATE J. +C -------------------- + 40 CONTINUE + FAC = DVNRMS(N,SAVF,EWT) + R0 = 1000.0D0*ABS(H)*UROUND*N*FAC + IF (R0 .EQ. 0.0D0) R0 = 1.0D0 + SRUR = WM(1) + J1 = 2 + DO 60 J = 1, N + YJ = Y(J) + R = MAX(SRUR*ABS(YJ),R0*EWT(J)) + Y(J) = Y(J) + R + FAC = -HL0/R + CALL DF(TN,Y,FTEM,RPAR,IPAR) + DO 50 I = 1, N + WM(I+J1) = (FTEM(I) - SAVF(I))*FAC + 50 CONTINUE + Y(J) = YJ + J1 = J1 + N + 60 CONTINUE + NFE = NFE + N + 70 CONTINUE +C ADD IDENTITY MATRIX. +C ------------------------------------------------- + J = 3 + DO 80 I = 1, N + WM(J) = WM(J) + 1.0D0 + J = J + (N + 1) + 80 CONTINUE +C DO LU DECOMPOSITION ON P. +C -------------------------------------------- + CALL DGEFA(WM(3),N,N,IWM(21),IER) +C .........EXIT + GO TO 240 +C IF MITER = 3, CONSTRUCT A DIAGONAL APPROXIMATION TO J AND +C P. --------- + 90 CONTINUE + WM(2) = HL0 + IER = 0 + R = EL0*0.1D0 + DO 100 I = 1, N + Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) + 100 CONTINUE + CALL DF(TN,Y,WM(3),RPAR,IPAR) + NFE = NFE + 1 + DO 120 I = 1, N + R0 = H*SAVF(I) - YH(I,2) + DI = 0.1D0*R0 - H*(WM(I+2) - SAVF(I)) + WM(I+2) = 1.0D0 + IF (ABS(R0) .LT. UROUND*EWT(I)) GO TO 110 +C .........EXIT + IF (ABS(DI) .EQ. 0.0D0) GO TO 130 + WM(I+2) = 0.1D0*R0/DI + 110 CONTINUE + 120 CONTINUE +C .........EXIT + GO TO 240 + 130 CONTINUE + IER = -1 +C ......EXIT + GO TO 240 +C IF MITER = 4, CALL DJAC AND MULTIPLY BY SCALAR. +C ----------------------- + 140 CONTINUE + ML = IWM(1) + MU = IWM(2) + ML3 = 3 + MBAND = ML + MU + 1 + MEBAND = MBAND + ML + LENP = MEBAND*N + DO 150 I = 1, LENP + WM(I+2) = 0.0D0 + 150 CONTINUE + CALL DJAC(TN,Y,WM(ML3),MEBAND,RPAR,IPAR) + CON = -HL0 + DO 160 I = 1, LENP + WM(I+2) = WM(I+2)*CON + 160 CONTINUE +C ...EXIT + GO TO 220 +C IF MITER = 5, MAKE MBAND CALLS TO DF TO APPROXIMATE J. +C ---------------- + 170 CONTINUE + ML = IWM(1) + MU = IWM(2) + MBAND = ML + MU + 1 + MBA = MIN(MBAND,N) + MEBAND = MBAND + ML + MEB1 = MEBAND - 1 + SRUR = WM(1) + FAC = DVNRMS(N,SAVF,EWT) + R0 = 1000.0D0*ABS(H)*UROUND*N*FAC + IF (R0 .EQ. 0.0D0) R0 = 1.0D0 + DO 210 J = 1, MBA + DO 180 I = J, N, MBAND + YI = Y(I) + R = MAX(SRUR*ABS(YI),R0*EWT(I)) + Y(I) = Y(I) + R + 180 CONTINUE + CALL DF(TN,Y,FTEM,RPAR,IPAR) + DO 200 JJ = J, N, MBAND + Y(JJ) = YH(JJ,1) + YJJ = Y(JJ) + R = MAX(SRUR*ABS(YJJ),R0*EWT(JJ)) + FAC = -HL0/R + I1 = MAX(JJ-MU,1) + I2 = MIN(JJ+ML,N) + II = JJ*MEB1 - ML + 2 + DO 190 I = I1, I2 + WM(II+I) = (FTEM(I) - SAVF(I))*FAC + 190 CONTINUE + 200 CONTINUE + 210 CONTINUE + NFE = NFE + MBA + 220 CONTINUE +C ADD IDENTITY MATRIX. +C ------------------------------------------------- + II = MBAND + 2 + DO 230 I = 1, N + WM(II) = WM(II) + 1.0D0 + II = II + MEBAND + 230 CONTINUE +C DO LU DECOMPOSITION OF P. +C -------------------------------------------- + CALL DGBFA(WM(3),MEBAND,N,ML,MU,IWM(21),IER) + 240 CONTINUE + RETURN +C ----------------------- END OF SUBROUTINE DPJAC +C ----------------------- + END +*DECK DSLVS + SUBROUTINE DSLVS (WM, IWM, X, TEM) +C***BEGIN PROLOGUE DSLVS +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEBDF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (SLVS-S, DSLVS-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DSLVS solves the linear system in the iteration scheme for the +C integrator package DDEBDF. +C +C***SEE ALSO DDEBDF +C***ROUTINES CALLED DGBSL, DGESL +C***COMMON BLOCKS DDEBD1 +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C 920422 Changed DIMENSION statement. (WRB) +C***END PROLOGUE DSLVS +C + INTEGER I, IER, IOWND, IOWNS, IWM, JSTART, KFLAG, L, MAXORD, + 1 MEBAND, METH, MITER, ML, MU, N, NFE, NJE, NQ, NQU, NST + DOUBLE PRECISION DI, EL0, H, HL0, HMIN, HMXI, HU, PHL0, + 1 R, ROWND, ROWNS, TEM, TN, UROUND, WM, X + DIMENSION WM(*), IWM(*), X(*), TEM(*) + COMMON /DDEBD1/ ROWND,ROWNS(210),EL0,H,HMIN,HMXI,HU,TN,UROUND, + 1 IOWND(14),IOWNS(6),IER,JSTART,KFLAG,L,METH,MITER, + 2 MAXORD,N,NQ,NST,NFE,NJE,NQU +C ------------------------------------------------------------------ +C THIS ROUTINE MANAGES THE SOLUTION OF THE LINEAR SYSTEM ARISING +C FROM A CHORD ITERATION. IT IS CALLED BY DSTOD IF MITER .NE. 0. +C IF MITER IS 1 OR 2, IT CALLS DGESL TO ACCOMPLISH THIS. +C IF MITER = 3 IT UPDATES THE COEFFICIENT H*EL0 IN THE DIAGONAL +C MATRIX, AND THEN COMPUTES THE SOLUTION. +C IF MITER IS 4 OR 5, IT CALLS DGBSL. +C COMMUNICATION WITH DSLVS USES THE FOLLOWING VARIABLES.. +C WM = DOUBLE PRECISION WORK SPACE CONTAINING THE INVERSE DIAGONAL +C MATRIX IF MITER +C IS 3 AND THE LU DECOMPOSITION OF THE MATRIX OTHERWISE. +C STORAGE OF MATRIX ELEMENTS STARTS AT WM(3). +C WM ALSO CONTAINS THE FOLLOWING MATRIX-RELATED DATA.. +C WM(1) = SQRT(UROUND) (NOT USED HERE), +C WM(2) = HL0, THE PREVIOUS VALUE OF H*EL0, USED IF MITER = +C 3. +C IWM = INTEGER WORK SPACE CONTAINING PIVOT INFORMATION, STARTING +C AT IWM(21), IF MITER IS 1, 2, 4, OR 5. IWM ALSO CONTAINS +C THE BAND PARAMETERS ML = IWM(1) AND MU = IWM(2) IF MITER IS +C 4 OR 5. +C X = THE RIGHT-HAND SIDE VECTOR ON INPUT, AND THE SOLUTION +C VECTOR ON OUTPUT, OF LENGTH N. +C TEM = VECTOR OF WORK SPACE OF LENGTH N, NOT USED IN THIS VERSION. +C IER = OUTPUT FLAG (IN COMMON). IER = 0 IF NO TROUBLE OCCURRED. +C IER = -1 IF A SINGULAR MATRIX AROSE WITH MITER = 3. +C THIS ROUTINE ALSO USES THE COMMON VARIABLES EL0, H, MITER, AND N. +C----------------------------------------------------------------------- +C BEGIN BLOCK PERMITTING ...EXITS TO 80 +C BEGIN BLOCK PERMITTING ...EXITS TO 60 +C***FIRST EXECUTABLE STATEMENT DSLVS + IER = 0 + GO TO (10,10,20,70,70), MITER + 10 CONTINUE + CALL DGESL(WM(3),N,N,IWM(21),X,0) +C ......EXIT + GO TO 80 +C + 20 CONTINUE + PHL0 = WM(2) + HL0 = H*EL0 + WM(2) = HL0 + IF (HL0 .EQ. PHL0) GO TO 40 + R = HL0/PHL0 + DO 30 I = 1, N + DI = 1.0D0 - R*(1.0D0 - 1.0D0/WM(I+2)) +C .........EXIT + IF (ABS(DI) .EQ. 0.0D0) GO TO 60 + WM(I+2) = 1.0D0/DI + 30 CONTINUE + 40 CONTINUE + DO 50 I = 1, N + X(I) = WM(I+2)*X(I) + 50 CONTINUE +C ......EXIT + GO TO 80 + 60 CONTINUE + IER = -1 +C ...EXIT + GO TO 80 +C + 70 CONTINUE + ML = IWM(1) + MU = IWM(2) + MEBAND = 2*ML + MU + 1 + CALL DGBSL(WM(3),MEBAND,N,ML,MU,IWM(21),X,0) + 80 CONTINUE + RETURN +C ----------------------- END OF SUBROUTINE DSLVS +C ----------------------- + END +*DECK DGBFA + SUBROUTINE DGBFA (ABD, LDA, N, ML, MU, IPVT, INFO) +C***BEGIN PROLOGUE DGBFA +C***PURPOSE Factor a band matrix using Gaussian elimination. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2A2 +C***TYPE DOUBLE PRECISION (SGBFA-S, DGBFA-D, CGBFA-C) +C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION +C***AUTHOR Moler, C. B., (U. of New Mexico) +C***DESCRIPTION +C +C DGBFA factors a double precision band matrix by elimination. +C +C DGBFA is usually called by DGBCO, but it can be called +C directly with a saving in time if RCOND is not needed. +C +C On Entry +C +C ABD DOUBLE PRECISION(LDA, N) +C contains the matrix in band storage. The columns +C of the matrix are stored in the columns of ABD and +C the diagonals of the matrix are stored in rows +C ML+1 through 2*ML+MU+1 of ABD . +C See the comments below for details. +C +C LDA INTEGER +C the leading dimension of the array ABD . +C LDA must be .GE. 2*ML + MU + 1 . +C +C N INTEGER +C the order of the original matrix. +C +C ML INTEGER +C number of diagonals below the main diagonal. +C 0 .LE. ML .LT. N . +C +C MU INTEGER +C number of diagonals above the main diagonal. +C 0 .LE. MU .LT. N . +C More efficient if ML .LE. MU . +C On Return +C +C ABD an upper triangular matrix in band storage and +C the multipliers which were used to obtain it. +C The factorization can be written A = L*U where +C L is a product of permutation and unit lower +C triangular matrices and U is upper triangular. +C +C IPVT INTEGER(N) +C an integer vector of pivot indices. +C +C INFO INTEGER +C = 0 normal value. +C = K if U(K,K) .EQ. 0.0 . This is not an error +C condition for this subroutine, but it does +C indicate that DGBSL will divide by zero if +C called. Use RCOND in DGBCO for a reliable +C indication of singularity. +C +C Band Storage +C +C If A is a band matrix, the following program segment +C will set up the input. +C +C ML = (band width below the diagonal) +C MU = (band width above the diagonal) +C M = ML + MU + 1 +C DO 20 J = 1, N +C I1 = MAX(1, J-MU) +C I2 = MIN(N, J+ML) +C DO 10 I = I1, I2 +C K = I - J + M +C ABD(K,J) = A(I,J) +C 10 CONTINUE +C 20 CONTINUE +C +C This uses rows ML+1 through 2*ML+MU+1 of ABD . +C In addition, the first ML rows in ABD are used for +C elements generated during the triangularization. +C The total number of rows needed in ABD is 2*ML+MU+1 . +C The ML+MU by ML+MU upper left triangle and the +C ML by ML lower right triangle are not referenced. +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DGBFA + INTEGER LDA,N,ML,MU,IPVT(*),INFO + DOUBLE PRECISION ABD(LDA,*) +C + DOUBLE PRECISION T + INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1 +C +C***FIRST EXECUTABLE STATEMENT DGBFA + M = ML + MU + 1 + INFO = 0 +C +C ZERO INITIAL FILL-IN COLUMNS +C + J0 = MU + 2 + J1 = MIN(N,M) - 1 + IF (J1 .LT. J0) GO TO 30 + DO 20 JZ = J0, J1 + I0 = M + 1 - JZ + DO 10 I = I0, ML + ABD(I,JZ) = 0.0D0 + 10 CONTINUE + 20 CONTINUE + 30 CONTINUE + JZ = J1 + JU = 0 +C +C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +C + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 130 + DO 120 K = 1, NM1 + KP1 = K + 1 +C +C ZERO NEXT FILL-IN COLUMN +C + JZ = JZ + 1 + IF (JZ .GT. N) GO TO 50 + IF (ML .LT. 1) GO TO 50 + DO 40 I = 1, ML + ABD(I,JZ) = 0.0D0 + 40 CONTINUE + 50 CONTINUE +C +C FIND L = PIVOT INDEX +C + LM = MIN(ML,N-K) + L = IDAMAX(LM+1,ABD(M,K),1) + M - 1 + IPVT(K) = L + K - M +C +C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +C + IF (ABD(L,K) .EQ. 0.0D0) GO TO 100 +C +C INTERCHANGE IF NECESSARY +C + IF (L .EQ. M) GO TO 60 + T = ABD(L,K) + ABD(L,K) = ABD(M,K) + ABD(M,K) = T + 60 CONTINUE +C +C COMPUTE MULTIPLIERS +C + T = -1.0D0/ABD(M,K) + CALL DSCAL(LM,T,ABD(M+1,K),1) +C +C ROW ELIMINATION WITH COLUMN INDEXING +C + JU = MIN(MAX(JU,MU+IPVT(K)),N) + MM = M + IF (JU .LT. KP1) GO TO 90 + DO 80 J = KP1, JU + L = L - 1 + MM = MM - 1 + T = ABD(L,J) + IF (L .EQ. MM) GO TO 70 + ABD(L,J) = ABD(MM,J) + ABD(MM,J) = T + 70 CONTINUE + CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1) + 80 CONTINUE + 90 CONTINUE + GO TO 110 + 100 CONTINUE + INFO = K + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + IPVT(N) = N + IF (ABD(M,N) .EQ. 0.0D0) INFO = N + RETURN + END +*DECK DGBSL + SUBROUTINE DGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB) +C***BEGIN PROLOGUE DGBSL +C***PURPOSE Solve the real band system A*X=B or TRANS(A)*X=B using +C the factors computed by DGBCO or DGBFA. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2A2 +C***TYPE DOUBLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C) +C***KEYWORDS BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE +C***AUTHOR Moler, C. B., (U. of New Mexico) +C***DESCRIPTION +C +C DGBSL solves the double precision band system +C A * X = B or TRANS(A) * X = B +C using the factors computed by DGBCO or DGBFA. +C +C On Entry +C +C ABD DOUBLE PRECISION(LDA, N) +C the output from DGBCO or DGBFA. +C +C LDA INTEGER +C the leading dimension of the array ABD . +C +C N INTEGER +C the order of the original matrix. +C +C ML INTEGER +C number of diagonals below the main diagonal. +C +C MU INTEGER +C number of diagonals above the main diagonal. +C +C IPVT INTEGER(N) +C the pivot vector from DGBCO or DGBFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C JOB INTEGER +C = 0 to solve A*X = B , +C = nonzero to solve TRANS(A)*X = B , where +C TRANS(A) is the transpose. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero will occur if the input factor contains a +C zero on the diagonal. Technically this indicates singularity +C but it is often caused by improper arguments or improper +C setting of LDA . It will not occur if the subroutines are +C called correctly and if DGBCO has set RCOND .GT. 0.0 +C or DGBFA has set INFO .EQ. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z) +C IF (RCOND is too small) GO TO ... +C DO 10 J = 1, P +C CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0) +C 10 CONTINUE +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED DAXPY, DDOT +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DGBSL + INTEGER LDA,N,ML,MU,IPVT(*),JOB + DOUBLE PRECISION ABD(LDA,*),B(*) +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,LA,LB,LM,M,NM1 +C***FIRST EXECUTABLE STATEMENT DGBSL + M = MU + ML + 1 + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , SOLVE A * X = B +C FIRST SOLVE L*Y = B +C + IF (ML .EQ. 0) GO TO 30 + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + LM = MIN(ML,N-K) + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW SOLVE U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/ABD(M,K) + LM = MIN(K,M) - 1 + LA = M - LM + LB = K - LM + T = -B(K) + CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, SOLVE TRANS(A) * X = B +C FIRST SOLVE TRANS(U)*Y = B +C + DO 60 K = 1, N + LM = MIN(K,M) - 1 + LA = M - LM + LB = K - LM + T = DDOT(LM,ABD(LA,K),1,B(LB),1) + B(K) = (B(K) - T)/ABD(M,K) + 60 CONTINUE +C +C NOW SOLVE TRANS(L)*X = Y +C + IF (ML .EQ. 0) GO TO 90 + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + LM = MIN(ML,N-K) + B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END +*DECK DGEFA + SUBROUTINE DGEFA (A, LDA, N, IPVT, INFO) +C***BEGIN PROLOGUE DGEFA +C***PURPOSE Factor a matrix using Gaussian elimination. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2A1 +C***TYPE DOUBLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C) +C***KEYWORDS GENERAL MATRIX, LINEAR ALGEBRA, LINPACK, +C MATRIX FACTORIZATION +C***AUTHOR Moler, C. B., (U. of New Mexico) +C***DESCRIPTION +C +C DGEFA factors a double precision matrix by Gaussian elimination. +C +C DGEFA is usually called by DGECO, but it can be called +C directly with a saving in time if RCOND is not needed. +C (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) . +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the matrix to be factored. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C On Return +C +C A an upper triangular matrix and the multipliers +C which were used to obtain it. +C The factorization can be written A = L*U where +C L is a product of permutation and unit lower +C triangular matrices and U is upper triangular. +C +C IPVT INTEGER(N) +C an integer vector of pivot indices. +C +C INFO INTEGER +C = 0 normal value. +C = K if U(K,K) .EQ. 0.0 . This is not an error +C condition for this subroutine, but it does +C indicate that DGESL or DGEDI will divide by zero +C if called. Use RCOND in DGECO for a reliable +C indication of singularity. +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED DAXPY, DSCAL, IDAMAX +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DGEFA + INTEGER LDA,N,IPVT(*),INFO + DOUBLE PRECISION A(LDA,*) +C + DOUBLE PRECISION T + INTEGER IDAMAX,J,K,KP1,L,NM1 +C +C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING +C +C***FIRST EXECUTABLE STATEMENT DGEFA + INFO = 0 + NM1 = N - 1 + IF (NM1 .LT. 1) GO TO 70 + DO 60 K = 1, NM1 + KP1 = K + 1 +C +C FIND L = PIVOT INDEX +C + L = IDAMAX(N-K+1,A(K,K),1) + K - 1 + IPVT(K) = L +C +C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED +C + IF (A(L,K) .EQ. 0.0D0) GO TO 40 +C +C INTERCHANGE IF NECESSARY +C + IF (L .EQ. K) GO TO 10 + T = A(L,K) + A(L,K) = A(K,K) + A(K,K) = T + 10 CONTINUE +C +C COMPUTE MULTIPLIERS +C + T = -1.0D0/A(K,K) + CALL DSCAL(N-K,T,A(K+1,K),1) +C +C ROW ELIMINATION WITH COLUMN INDEXING +C + DO 30 J = KP1, N + T = A(L,J) + IF (L .EQ. K) GO TO 20 + A(L,J) = A(K,J) + A(K,J) = T + 20 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) + 30 CONTINUE + GO TO 50 + 40 CONTINUE + INFO = K + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + IPVT(N) = N + IF (A(N,N) .EQ. 0.0D0) INFO = N + RETURN + END +*DECK DGESL + SUBROUTINE DGESL (A, LDA, N, IPVT, B, JOB) +C***BEGIN PROLOGUE DGESL +C***PURPOSE Solve the real system A*X=B or TRANS(A)*X=B using the +C factors computed by DGECO or DGEFA. +C***LIBRARY SLATEC (LINPACK) +C***CATEGORY D2A1 +C***TYPE DOUBLE PRECISION (SGESL-S, DGESL-D, CGESL-C) +C***KEYWORDS LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE +C***AUTHOR Moler, C. B., (U. of New Mexico) +C***DESCRIPTION +C +C DGESL solves the double precision system +C A * X = B or TRANS(A) * X = B +C using the factors computed by DGECO or DGEFA. +C +C On Entry +C +C A DOUBLE PRECISION(LDA, N) +C the output from DGECO or DGEFA. +C +C LDA INTEGER +C the leading dimension of the array A . +C +C N INTEGER +C the order of the matrix A . +C +C IPVT INTEGER(N) +C the pivot vector from DGECO or DGEFA. +C +C B DOUBLE PRECISION(N) +C the right hand side vector. +C +C JOB INTEGER +C = 0 to solve A*X = B , +C = nonzero to solve TRANS(A)*X = B where +C TRANS(A) is the transpose. +C +C On Return +C +C B the solution vector X . +C +C Error Condition +C +C A division by zero will occur if the input factor contains a +C zero on the diagonal. Technically this indicates singularity +C but it is often caused by improper arguments or improper +C setting of LDA . It will not occur if the subroutines are +C called correctly and if DGECO has set RCOND .GT. 0.0 +C or DGEFA has set INFO .EQ. 0 . +C +C To compute INVERSE(A) * C where C is a matrix +C with P columns +C CALL DGECO(A,LDA,N,IPVT,RCOND,Z) +C IF (RCOND is too small) GO TO ... +C DO 10 J = 1, P +C CALL DGESL(A,LDA,N,IPVT,C(1,J),0) +C 10 CONTINUE +C +C***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. +C Stewart, LINPACK Users' Guide, SIAM, 1979. +C***ROUTINES CALLED DAXPY, DDOT +C***REVISION HISTORY (YYMMDD) +C 780814 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 890831 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900326 Removed duplicate information from DESCRIPTION section. +C (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DGESL + INTEGER LDA,N,IPVT(*),JOB + DOUBLE PRECISION A(LDA,*),B(*) +C + DOUBLE PRECISION DDOT,T + INTEGER K,KB,L,NM1 +C***FIRST EXECUTABLE STATEMENT DGESL + NM1 = N - 1 + IF (JOB .NE. 0) GO TO 50 +C +C JOB = 0 , SOLVE A * X = B +C FIRST SOLVE L*Y = B +C + IF (NM1 .LT. 1) GO TO 30 + DO 20 K = 1, NM1 + L = IPVT(K) + T = B(L) + IF (L .EQ. K) GO TO 10 + B(L) = B(K) + B(K) = T + 10 CONTINUE + CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1) + 20 CONTINUE + 30 CONTINUE +C +C NOW SOLVE U*X = Y +C + DO 40 KB = 1, N + K = N + 1 - KB + B(K) = B(K)/A(K,K) + T = -B(K) + CALL DAXPY(K-1,T,A(1,K),1,B(1),1) + 40 CONTINUE + GO TO 100 + 50 CONTINUE +C +C JOB = NONZERO, SOLVE TRANS(A) * X = B +C FIRST SOLVE TRANS(U)*Y = B +C + DO 60 K = 1, N + T = DDOT(K-1,A(1,K),1,B(1),1) + B(K) = (B(K) - T)/A(K,K) + 60 CONTINUE +C +C NOW SOLVE TRANS(L)*X = Y +C + IF (NM1 .LT. 1) GO TO 90 + DO 80 KB = 1, NM1 + K = N - KB + B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1) + L = IPVT(K) + IF (L .EQ. K) GO TO 70 + T = B(L) + B(L) = B(K) + B(K) = T + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE + 100 CONTINUE + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/dderkf.f calculix-ccx-2.3/ccx_2.3/src/dderkf.f --- calculix-ccx-2.1/ccx_2.3/src/dderkf.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dderkf.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,4332 @@ +*DECK DDERKF + SUBROUTINE DDERKF (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, + + RWORK, LRW, IWORK, LIW, RPAR, IPAR) +C***BEGIN PROLOGUE DDERKF +C***PURPOSE Solve an initial value problem in ordinary differential +C equations using a Runge-Kutta-Fehlberg scheme. +C***LIBRARY SLATEC (DEPAC) +C***CATEGORY I1A1A +C***TYPE DOUBLE PRECISION (DERKF-S, DDERKF-D) +C***KEYWORDS DEPAC, INITIAL VALUE PROBLEMS, ODE, +C ORDINARY DIFFERENTIAL EQUATIONS, RKF, +C RUNGE-KUTTA-FEHLBERG METHODS +C***AUTHOR Watts, H. A., (SNLA) +C Shampine, L. F., (SNLA) +C***DESCRIPTION +C +C This is the Runge-Kutta code in the package of differential equation +C solvers DEPAC, consisting of the codes DDERKF, DDEABM, and DDEBDF. +C Design of the package was by L. F. Shampine and H. A. Watts. +C It is documented in +C SAND-79-2374 , DEPAC - Design of a User Oriented Package of ODE +C Solvers. +C DDERKF is a driver for a modification of the code RKF45 written by +C H. A. Watts and L. F. Shampine +C Sandia Laboratories +C Albuquerque, New Mexico 87185 +C +C ********************************************************************** +C ** DDEPAC PACKAGE OVERVIEW ** +C ********************************************************************** +C +C You have a choice of three differential equation solvers from +C DDEPAC. The following brief descriptions are meant to aid you +C in choosing the most appropriate code for your problem. +C +C DDERKF is a fifth order Runge-Kutta code. It is the simplest of +C the three choices, both algorithmically and in the use of the +C code. DDERKF is primarily designed to solve non-stiff and mild- +C ly stiff differential equations when derivative evaluations are +C not expensive. It should generally not be used to get high +C accuracy results nor answers at a great many specific points. +C Because DDERKF has very low overhead costs, it will usually +C result in the least expensive integration when solving +C problems requiring a modest amount of accuracy and having +C equations that are not costly to evaluate. DDERKF attempts to +C discover when it is not suitable for the task posed. +C +C DDEABM is a variable order (one through twelve) Adams code. Its +C complexity lies somewhere between that of DDERKF and DDEBDF. +C DDEABM is primarily designed to solve non-stiff and mildly +C stiff differential equations when derivative evaluations are +C expensive, high accuracy results are needed or answers at +C many specific points are required. DDEABM attempts to discover +C when it is not suitable for the task posed. +C +C DDEBDF is a variable order (one through five) backward +C differentiation formula code. It is the most complicated of +C the three choices. DDEBDF is primarily designed to solve stiff +C differential equations at crude to moderate tolerances. +C If the problem is very stiff at all, DDERKF and DDEABM will be +C quite inefficient compared to DDEBDF. However, DDEBDF will be +C inefficient compared to DDERKF and DDEABM on non-stiff problems +C because it uses much more storage, has a much larger overhead, +C and the low order formulas will not give high accuracies +C efficiently. +C +C The concept of stiffness cannot be described in a few words. +C If you do not know the problem to be stiff, try either DDERKF +C or DDEABM. Both of these codes will inform you of stiffness +C when the cost of solving such problems becomes important. +C +C ********************************************************************** +C ** ABSTRACT ** +C ********************************************************************** +C +C Subroutine DDERKF uses a Runge-Kutta-Fehlberg (4,5) method to +C integrate a system of NEQ first order ordinary differential +C equations of the form +C DU/DX = DF(X,U) +C when the vector Y(*) of initial values for U(*) at X=T is given. +C The subroutine integrates from T to TOUT. It is easy to continue the +C integration to get results at additional TOUT. This is the interval +C mode of operation. It is also easy for the routine to return with +C the solution at each intermediate step on the way to TOUT. This is +C the intermediate-output mode of operation. +C +C DDERKF uses subprograms DRKFS, DFEHL, DHSTRT, DHVNRM, D1MACH, and +C the error handling routine XERMSG. The only machine dependent +C parameters to be assigned appear in D1MACH. +C +C ********************************************************************** +C ** DESCRIPTION OF THE ARGUMENTS TO DDERKF (AN OVERVIEW) ** +C ********************************************************************** +C +C The Parameters are: +C +C DF -- This is the name of a subroutine which you provide to +C define the differential equations. +C +C NEQ -- This is the number of (first order) differential +C equations to be integrated. +C +C T -- This is a DOUBLE PRECISION value of the independent +C variable. +C +C Y(*) -- This DOUBLE PRECISION array contains the solution +C components at T. +C +C TOUT -- This is a DOUBLE PRECISION point at which a solution is +C desired. +C +C INFO(*) -- The basic task of the code is to integrate the +C differential equations from T to TOUT and return an +C answer at TOUT. INFO(*) is an INTEGER array which is used +C to communicate exactly how you want this task to be +C carried out. +C +C RTOL, ATOL -- These DOUBLE PRECISION quantities represent +C relative and absolute error tolerances which you provide +C to indicate how accurately you wish the solution to be +C computed. You may choose them to be both scalars or else +C both vectors. +C +C IDID -- This scalar quantity is an indicator reporting what +C the code did. You must monitor this INTEGER variable to +C decide what action to take next. +C +C RWORK(*), LRW -- RWORK(*) is a DOUBLE PRECISION work array of +C length LRW which provides the code with needed storage +C space. +C +C IWORK(*), LIW -- IWORK(*) is an INTEGER work array of length LIW +C which provides the code with needed storage space and an +C across call flag. +C +C RPAR, IPAR -- These are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and the DF subroutine. +C +C Quantities which are used as input items are +C NEQ, T, Y(*), TOUT, INFO(*), +C RTOL, ATOL, LRW and LIW. +C +C Quantities which may be altered by the code are +C T, Y(*), INFO(1), RTOL, ATOL, +C IDID, RWORK(*) and IWORK(*). +C +C ********************************************************************** +C ** INPUT -- What to do On The First Call To DDERKF ** +C ********************************************************************** +C +C The first call of the code is defined to be the start of each new +C problem. Read through the descriptions of all the following items, +C provide sufficient storage space for designated arrays, set +C appropriate variables for the initialization of the problem, and +C give information about how you want the problem to be solved. +C +C +C DF -- Provide a subroutine of the form +C DF(X,U,UPRIME,RPAR,IPAR) +C to define the system of first order differential equations +C which is to be solved. For the given values of X and the +C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must +C evaluate the NEQ components of the system of differential +C equations DU/DX=DF(X,U) and store the derivatives in the +C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for +C equations I=1,...,NEQ. +C +C Subroutine DF must not alter X or U(*). You must declare +C the name DF in an external statement in your program that +C calls DDERKF. You must dimension U and UPRIME in DF. +C +C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C calling program and subroutine DF. They are not used or +C altered by DDERKF. If you do not need RPAR or IPAR, +C ignore these parameters by treating them as dummy +C arguments. If you do choose to use them, dimension them in +C your calling program and in DF as arrays of appropriate +C length. +C +C NEQ -- Set it to the number of differential equations. +C (NEQ .GE. 1) +C +C T -- Set it to the initial point of the integration. +C You must use a program variable for T because the code +C changes its value. +C +C Y(*) -- Set this vector to the initial values of the NEQ solution +C components at the initial point. You must dimension Y at +C least NEQ in your calling program. +C +C TOUT -- Set it to the first point at which a solution +C is desired. You can take TOUT = T, in which case the code +C will evaluate the derivative of the solution at T and +C return. Integration either forward in T (TOUT .GT. T) or +C backward in T (TOUT .LT. T) is permitted. +C +C The code advances the solution from T to TOUT using +C step sizes which are automatically selected so as to +C achieve the desired accuracy. If you wish, the code will +C return with the solution and its derivative following +C each intermediate step (intermediate-output mode) so that +C you can monitor them, but you still must provide TOUT in +C accord with the basic aim of the code. +C +C The first step taken by the code is a critical one +C because it must reflect how fast the solution changes near +C the initial point. The code automatically selects an +C initial step size which is practically always suitable for +C the problem. By using the fact that the code will not +C step past TOUT in the first step, you could, if necessary, +C restrict the length of the initial step size. +C +C For some problems it may not be permissible to integrate +C past a point TSTOP because a discontinuity occurs there +C or the solution or its derivative is not defined beyond +C TSTOP. Since DDERKF will never step past a TOUT point, +C you need only make sure that no TOUT lies beyond TSTOP. +C +C INFO(*) -- Use the INFO array to give the code more details about +C how you want your problem solved. This array should be +C dimensioned of length 15 to accommodate other members of +C DEPAC or possible future extensions, though DDERKF uses +C only the first three entries. You must respond to all of +C the following items which are arranged as questions. The +C simplest use of the code corresponds to answering all +C questions as YES ,i.e. setting all entries of INFO to 0. +C +C INFO(1) -- This parameter enables the code to initialize +C itself. You must set it to indicate the start of every +C new problem. +C +C **** Is this the first call for this problem ... +C YES -- Set INFO(1) = 0 +C NO -- Not applicable here. +C See below for continuation calls. **** +C +C INFO(2) -- How much accuracy you want of your solution +C is specified by the error tolerances RTOL and ATOL. +C The simplest use is to take them both to be scalars. +C To obtain more flexibility, they can both be vectors. +C The code must be told your choice. +C +C **** Are both error tolerances RTOL, ATOL scalars ... +C YES -- Set INFO(2) = 0 +C and input scalars for both RTOL and ATOL +C NO -- Set INFO(2) = 1 +C and input arrays for both RTOL and ATOL **** +C +C INFO(3) -- The code integrates from T in the direction +C of TOUT by steps. If you wish, it will return the +C computed solution and derivative at the next +C intermediate step (the intermediate-output mode). +C This is a good way to proceed if you want to see the +C behavior of the solution. If you must have solutions at +C a great many specific TOUT points, this code is +C INEFFICIENT. The code DDEABM in DEPAC handles this task +C more efficiently. +C +C **** Do you want the solution only at +C TOUT (and not at the next intermediate step) ... +C YES -- Set INFO(3) = 0 +C NO -- Set INFO(3) = 1 **** +C +C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) +C error tolerances to tell the code how accurately you want +C the solution to be computed. They must be defined as +C program variables because the code may change them. You +C have two choices -- +C Both RTOL and ATOL are scalars. (INFO(2)=0) +C Both RTOL and ATOL are vectors. (INFO(2)=1) +C In either case all components must be non-negative. +C +C The tolerances are used by the code in a local error test +C at each step which requires roughly that +C ABS(LOCAL ERROR) .LE. RTOL*ABS(Y)+ATOL +C for each vector component. +C (More specifically, a maximum norm is used to measure +C the size of vectors, and the error test uses the average +C of the magnitude of the solution at the beginning and end +C of the step.) +C +C The true (global) error is the difference between the true +C solution of the initial value problem and the computed +C approximation. Practically all present day codes, +C including this one, control the local error at each step +C and do not even attempt to control the global error +C directly. Roughly speaking, they produce a solution Y(T) +C which satisfies the differential equations with a +C residual R(T), DY(T)/DT = DF(T,Y(T)) + R(T) , +C and, almost always, R(T) is bounded by the error +C tolerances. Usually, but not always, the true accuracy of +C the computed Y is comparable to the error tolerances. This +C code will usually, but not always, deliver a more accurate +C solution if you reduce the tolerances and integrate again. +C By comparing two such solutions you can get a fairly +C reliable idea of the true error in the solution at the +C bigger tolerances. +C +C Setting ATOL=0. results in a pure relative error test on +C that component. Setting RTOL=0. yields a pure absolute +C error test on that component. A mixed test with non-zero +C RTOL and ATOL corresponds roughly to a relative error +C test when the solution component is much bigger than ATOL +C and to an absolute error test when the solution component +C is smaller than the threshold ATOL. +C +C Proper selection of the absolute error control parameters +C ATOL requires you to have some idea of the scale of the +C solution components. To acquire this information may mean +C that you will have to solve the problem more than once. In +C the absence of scale information, you should ask for some +C relative accuracy in all the components (by setting RTOL +C values non-zero) and perhaps impose extremely small +C absolute error tolerances to protect against the danger of +C a solution component becoming zero. +C +C The code will not attempt to compute a solution at an +C accuracy unreasonable for the machine being used. It will +C advise you if you ask for too much accuracy and inform +C you as to the maximum accuracy it believes possible. +C If you want relative accuracies smaller than about +C 10**(-8), you should not ordinarily use DDERKF. The code +C DDEABM in DEPAC obtains stringent accuracies more +C efficiently. +C +C RWORK(*) -- Dimension this DOUBLE PRECISION work array of length +C LRW in your calling program. +C +C LRW -- Set it to the declared length of the RWORK array. +C You must have LRW .GE. 33+7*NEQ +C +C IWORK(*) -- Dimension this INTEGER work array of length LIW in +C your calling program. +C +C LIW -- Set it to the declared length of the IWORK array. +C You must have LIW .GE. 34 +C +C RPAR, IPAR -- These are parameter arrays, of DOUBLE PRECISION and +C INTEGER type, respectively. You can use them for +C communication between your program that calls DDERKF and +C the DF subroutine. They are not used or altered by +C DDERKF. If you do not need RPAR or IPAR, ignore these +C parameters by treating them as dummy arguments. If you do +C choose to use them, dimension them in your calling program +C and in DF as arrays of appropriate length. +C +C ********************************************************************** +C ** OUTPUT -- After any return from DDERKF ** +C ********************************************************************** +C +C The principal aim of the code is to return a computed solution at +C TOUT, although it is also possible to obtain intermediate results +C along the way. To find out whether the code achieved its goal +C or if the integration process was interrupted before the task was +C completed, you must check the IDID parameter. +C +C +C T -- The solution was successfully advanced to the +C output value of T. +C +C Y(*) -- Contains the computed solution approximation at T. +C You may also be interested in the approximate derivative +C of the solution at T. It is contained in +C RWORK(21),...,RWORK(20+NEQ). +C +C IDID -- Reports what the code did +C +C *** Task Completed *** +C Reported by positive values of IDID +C +C IDID = 1 -- A step was successfully taken in the +C intermediate-output mode. The code has not +C yet reached TOUT. +C +C IDID = 2 -- The integration to TOUT was successfully +C completed (T=TOUT) by stepping exactly to TOUT. +C +C *** Task Interrupted *** +C Reported by negative values of IDID +C +C IDID = -1 -- A large amount of work has been expended. +C (500 steps attempted) +C +C IDID = -2 -- The error tolerances are too stringent. +C +C IDID = -3 -- The local error test cannot be satisfied +C because you specified a zero component in ATOL +C and the corresponding computed solution +C component is zero. Thus, a pure relative error +C test is impossible for this component. +C +C IDID = -4 -- The problem appears to be stiff. +C +C IDID = -5 -- DDERKF is being used very inefficiently +C because the natural step size is being +C restricted by too frequent output. +C +C IDID = -6,-7,..,-32 -- Not applicable for this code but +C used by other members of DEPAC or possible +C future extensions. +C +C *** Task Terminated *** +C Reported by the value of IDID=-33 +C +C IDID = -33 -- The code has encountered trouble from which +C it cannot recover. A message is printed +C explaining the trouble and control is returned +C to the calling program. For example, this +C occurs when invalid input is detected. +C +C RTOL, ATOL -- These quantities remain unchanged except when +C IDID = -2. In this case, the error tolerances have been +C increased by the code to values which are estimated to be +C appropriate for continuing the integration. However, the +C reported solution at T was obtained using the input values +C of RTOL and ATOL. +C +C RWORK, IWORK -- Contain information which is usually of no +C interest to the user but necessary for subsequent calls. +C However, you may find use for +C +C RWORK(11)--which contains the step size H to be +C attempted on the next step. +C +C RWORK(12)--If the tolerances have been increased by the +C code (IDID = -2) , they were multiplied by the +C value in RWORK(12). +C +C RWORK(20+I)--which contains the approximate derivative +C of the solution component Y(I). In DDERKF, it +C is always obtained by calling subroutine DF to +C evaluate the differential equation using T and +C Y(*). +C +C ********************************************************************** +C ** INPUT -- What To Do To Continue The Integration ** +C ** (calls after the first) ** +C ********************************************************************** +C +C This code is organized so that subsequent calls to continue the +C integration involve little (if any) additional effort on your +C part. You must monitor the IDID parameter to determine +C what to do next. +C +C Recalling that the principal task of the code is to integrate +C from T to TOUT (the interval mode), usually all you will need +C to do is specify a new TOUT upon reaching the current TOUT. +C +C Do not alter any quantity not specifically permitted below, +C in particular do not alter NEQ, T, Y(*), RWORK(*), IWORK(*) or +C the differential equation in subroutine DF. Any such alteration +C constitutes a new problem and must be treated as such, i.e. +C you must start afresh. +C +C You cannot change from vector to scalar error control or vice +C versa (INFO(2)) but you can change the size of the entries of +C RTOL, ATOL. Increasing a tolerance makes the equation easier +C to integrate. Decreasing a tolerance will make the equation +C harder to integrate and should generally be avoided. +C +C You can switch from the intermediate-output mode to the +C interval mode (INFO(3)) or vice versa at any time. +C +C The parameter INFO(1) is used by the code to indicate the +C beginning of a new problem and to indicate whether integration +C is to be continued. You must input the value INFO(1) = 0 +C when starting a new problem. You must input the value +C INFO(1) = 1 if you wish to continue after an interrupted task. +C Do not set INFO(1) = 0 on a continuation call unless you +C want the code to restart at the current T. +C +C *** Following a Completed Task *** +C If +C IDID = 1, call the code again to continue the integration +C another step in the direction of TOUT. +C +C IDID = 2, define a new TOUT and call the code again. +C TOUT must be different from T. You cannot change +C the direction of integration without restarting. +C +C *** Following an Interrupted Task *** +C To show the code that you realize the task was +C interrupted and that you want to continue, you +C must take appropriate action and reset INFO(1) = 1 +C If +C IDID = -1, the code has attempted 500 steps. +C If you want to continue, set INFO(1) = 1 and +C call the code again. An additional 500 steps +C will be allowed. +C +C IDID = -2, the error tolerances RTOL, ATOL have been +C increased to values the code estimates appropriate +C for continuing. You may want to change them +C yourself. If you are sure you want to continue +C with relaxed error tolerances, set INFO(1)=1 and +C call the code again. +C +C IDID = -3, a solution component is zero and you set the +C corresponding component of ATOL to zero. If you +C are sure you want to continue, you must first +C alter the error criterion to use positive values +C for those components of ATOL corresponding to zero +C solution components, then set INFO(1)=1 and call +C the code again. +C +C IDID = -4, the problem appears to be stiff. It is very +C inefficient to solve such problems with DDERKF. +C The code DDEBDF in DEPAC handles this task +C efficiently. If you are absolutely sure you want +C to continue with DDERKF, set INFO(1)=1 and call +C the code again. +C +C IDID = -5, you are using DDERKF very inefficiently by +C choosing output points TOUT so close together that +C the step size is repeatedly forced to be rather +C smaller than necessary. If you are willing to +C accept solutions at the steps chosen by the code, +C a good way to proceed is to use the intermediate +C output mode (setting INFO(3)=1). If you must have +C solutions at so many specific TOUT points, the +C code DDEABM in DEPAC handles this task +C efficiently. If you want to continue with DDERKF, +C set INFO(1)=1 and call the code again. +C +C IDID = -6,-7,..,-32 --- cannot occur with this code but +C used by other members of DEPAC or possible future +C extensions. +C +C *** Following a Terminated Task *** +C If +C IDID = -33, you cannot continue the solution of this +C problem. An attempt to do so will result in your +C run being terminated. +C +C ********************************************************************** +C *Long Description: +C +C ********************************************************************** +C ** DEPAC Package Overview ** +C ********************************************************************** +C +C .... You have a choice of three differential equation solvers from +C .... DEPAC. The following brief descriptions are meant to aid you in +C .... choosing the most appropriate code for your problem. +C +C .... DDERKF is a fifth order Runge-Kutta code. It is the simplest of +C .... the three choices, both algorithmically and in the use of the +C .... code. DDERKF is primarily designed to solve non-stiff and +C .... mildly stiff differential equations when derivative evaluations +C .... are not expensive. It should generally not be used to get high +C .... accuracy results nor answers at a great many specific points. +C .... Because DDERKF has very low overhead costs, it will usually +C .... result in the least expensive integration when solving +C .... problems requiring a modest amount of accuracy and having +C .... equations that are not costly to evaluate. DDERKF attempts to +C .... discover when it is not suitable for the task posed. +C +C .... DDEABM is a variable order (one through twelve) Adams code. +C .... Its complexity lies somewhere between that of DDERKF and +C .... DDEBDF. DDEABM is primarily designed to solve non-stiff and +C .... mildly stiff differential equations when derivative evaluations +C .... are expensive, high accuracy results are needed or answers at +C .... many specific points are required. DDEABM attempts to discover +C .... when it is not suitable for the task posed. +C +C .... DDEBDF is a variable order (one through five) backward +C .... differentiation formula code. it is the most complicated of +C .... the three choices. DDEBDF is primarily designed to solve stiff +C .... differential equations at crude to moderate tolerances. +C .... If the problem is very stiff at all, DDERKF and DDEABM will be +C .... quite inefficient compared to DDEBDF. However, DDEBDF will be +C .... inefficient compared to DDERKF and DDEABM on non-stiff problems +C .... because it uses much more storage, has a much larger overhead, +C .... and the low order formulas will not give high accuracies +C .... efficiently. +C +C .... The concept of stiffness cannot be described in a few words. +C .... If you do not know the problem to be stiff, try either DDERKF +C .... or DDEABM. Both of these codes will inform you of stiffness +C .... when the cost of solving such problems becomes important. +C +C ********************************************************************* +C +C***REFERENCES L. F. Shampine and H. A. Watts, DEPAC - design of a user +C oriented package of ODE solvers, Report SAND79-2374, +C Sandia Laboratories, 1979. +C L. F. Shampine and H. A. Watts, Practical solution of +C ordinary differential equations by Runge-Kutta +C methods, Report SAND76-0585, Sandia Laboratories, +C 1976. +C***ROUTINES CALLED DRKFS, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891024 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900510 Convert XERRWV calls to XERMSG calls, make Prologue comments +C consistent with DERKF. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE DDERKF +C + INTEGER IDID, INFO, IPAR, IWORK, KDI, KF1, KF2, KF3, KF4, KF5, + 1 KH, KRER, KTF, KTO, KTSTAR, KU, KYP, KYS, LIW, LRW, NEQ + DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y + LOGICAL STIFF,NONSTF +C + DIMENSION Y(*),INFO(15),RTOL(*),ATOL(*),RWORK(*),IWORK(*), + 1 RPAR(*),IPAR(*) + CHARACTER*8 XERN1 + CHARACTER*16 XERN3 +C + EXTERNAL DF +C +C CHECK FOR AN APPARENT INFINITE LOOP +C +C***FIRST EXECUTABLE STATEMENT DDERKF + IF (INFO(1) .EQ. 0) IWORK(LIW) = 0 + IF (IWORK(LIW) .GE. 5) THEN + IF (T .EQ. RWORK(21+NEQ)) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DDERKF', + * 'AN APPARENT INFINITE LOOP HAS BEEN DETECTED.$$' // + * 'YOU HAVE MADE REPEATED CALLS AT T = ' // XERN3 // + * ' AND THE INTEGRATION HAS NOT ADVANCED. CHECK THE ' // + * 'WAY YOU HAVE SET PARAMETERS FOR THE CALL TO THE ' // + * 'CODE, PARTICULARLY INFO(1).', 13, 2) + RETURN + ENDIF + ENDIF +C +C CHECK LRW AND LIW FOR SUFFICIENT STORAGE ALLOCATION +C + IDID = 0 + IF (LRW .LT. 30 + 7*NEQ) THEN + WRITE (XERN1, '(I8)') LRW + CALL XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF RWORK ARRAY ' // + * 'MUST BE AT LEAST 30 + 7*NEQ. YOU HAVE CALLED THE ' // + * 'CODE WITH LRW = ' // XERN1, 1, 1) + IDID = -33 + ENDIF +C + IF (LIW .LT. 34) THEN + WRITE (XERN1, '(I8)') LIW + CALL XERMSG ('SLATEC', 'DDERKF', 'LENGTH OF IWORK ARRAY ' // + * 'MUST BE AT LEAST 34. YOU HAVE CALLED THE CODE WITH ' // + * 'LIW = ' // XERN1, 2, 1) + IDID = -33 + ENDIF +C +C COMPUTE INDICES FOR THE SPLITTING OF THE RWORK ARRAY +C + KH = 11 + KTF = 12 + KYP = 21 + KTSTAR = KYP + NEQ + KF1 = KTSTAR + 1 + KF2 = KF1 + NEQ + KF3 = KF2 + NEQ + KF4 = KF3 + NEQ + KF5 = KF4 + NEQ + KYS = KF5 + NEQ + KTO = KYS + NEQ + KDI = KTO + 1 + KU = KDI + 1 + KRER = KU + 1 +C +C ********************************************************************** +C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG +C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE +C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, +C S/HE MUST USE DRKFS DIRECTLY. +C ********************************************************************** +C + RWORK(KTSTAR) = T + IF (INFO(1) .NE. 0) THEN + STIFF = (IWORK(25) .EQ. 0) + NONSTF = (IWORK(26) .EQ. 0) + ENDIF +C + CALL DRKFS(DF,NEQ,T,Y,TOUT,INFO,RTOL,ATOL,IDID,RWORK(KH), + 1 RWORK(KTF),RWORK(KYP),RWORK(KF1),RWORK(KF2),RWORK(KF3), + 2 RWORK(KF4),RWORK(KF5),RWORK(KYS),RWORK(KTO),RWORK(KDI), + 3 RWORK(KU),RWORK(KRER),IWORK(21),IWORK(22),IWORK(23), + 4 IWORK(24),STIFF,NONSTF,IWORK(27),IWORK(28),RPAR,IPAR) +C + IWORK(25) = 1 + IF (STIFF) IWORK(25) = 0 + IWORK(26) = 1 + IF (NONSTF) IWORK(26) = 0 +C + IF (IDID .NE. (-2)) IWORK(LIW) = IWORK(LIW) + 1 + IF (T .NE. RWORK(KTSTAR)) IWORK(LIW) = 0 +C + RETURN + END +*DECK DRKFS + SUBROUTINE DRKFS (DF, NEQ, T, Y, TOUT, INFO, RTOL, ATOL, IDID, H, + + TOLFAC, YP, F1, F2, F3, F4, F5, YS, TOLD, DTSIGN, U26, RER, + + INIT, KSTEPS, KOP, IQUIT, STIFF, NONSTF, NTSTEP, NSTIFS, RPAR, + + IPAR) +C***BEGIN PROLOGUE DRKFS +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (DERKFS-S, DRKFS-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C Fehlberg Fourth-Fifth Order Runge-Kutta Method +C ********************************************************************** +C +C DRKFS integrates a system of first order ordinary differential +C equations as described in the comments for DDERKF . +C +C The arrays YP,F1,F2,F3,F4,F5,and YS (of length at least NEQ) +C appear in the call list for variable dimensioning purposes. +C +C The variables H,TOLFAC,TOLD,DTSIGN,U26,RER,INIT,KSTEPS,KOP,IQUIT, +C STIFF,NONSTF,NTSTEP, and NSTIFS are used internally by the code +C and appear in the call list to eliminate local retention of +C variables between calls. Accordingly, these variables and the +C array YP should not be altered. +C Items of possible interest are +C H - An appropriate step size to be used for the next step +C TOLFAC - Factor of change in the tolerances +C YP - Derivative of solution vector at T +C KSTEPS - Counter on the number of steps attempted +C +C ********************************************************************** +C +C***SEE ALSO DDERKF +C***ROUTINES CALLED D1MACH, DFEHL, DHSTRT, DHVNRM, XERMSG +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 900510 Convert XERRWV calls to XERMSG calls, change GOTOs to +C IF-THEN-ELSEs. (RWC) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DRKFS +C + INTEGER IDID, INFO, INIT, IPAR, IQUIT, K, KOP, KSTEPS, KTOL, + 1 MXKOP, MXSTEP, NATOLP, NEQ, NRTOLP, NSTIFS, NTSTEP + DOUBLE PRECISION A, ATOL, BIG, D1MACH, + 1 DT, DTSIGN, DHVNRM, DY, EE, EEOET, ES, ESTIFF, + 2 ESTTOL, ET, F1, F2, F3, F4, F5, H, HMIN, REMIN, RER, RPAR, + 3 RTOL, S, T, TOL, TOLD, TOLFAC, TOUT, U, U26, UTE, Y, YAVG, + 4 YP, YS + LOGICAL HFAILD,OUTPUT,STIFF,NONSTF + CHARACTER*8 XERN1 + CHARACTER*16 XERN3, XERN4 +C + DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), + 1 YS(*),INFO(15),RTOL(*),ATOL(*),RPAR(*),IPAR(*) +C + EXTERNAL DF +C +C .................................................................. +C +C A FIFTH ORDER METHOD WILL GENERALLY NOT BE CAPABLE OF DELIVERING +C ACCURACIES NEAR LIMITING PRECISION ON COMPUTERS WITH LONG +C WORDLENGTHS. TO PROTECT AGAINST LIMITING PRECISION DIFFICULTIES +C ARISING FROM UNREASONABLE ACCURACY REQUESTS, AN APPROPRIATE +C TOLERANCE THRESHOLD REMIN IS ASSIGNED FOR THIS METHOD. THIS +C VALUE SHOULD NOT BE CHANGED ACROSS DIFFERENT MACHINES. +C + SAVE REMIN, MXSTEP, MXKOP + DATA REMIN /1.0D-12/ +C +C .................................................................. +C +C THE EXPENSE OF SOLVING THE PROBLEM IS MONITORED BY COUNTING THE +C NUMBER OF STEPS ATTEMPTED. WHEN THIS EXCEEDS MXSTEP, THE +C COUNTER IS RESET TO ZERO AND THE USER IS INFORMED ABOUT POSSIBLE +C EXCESSIVE WORK. +C + DATA MXSTEP /500/ +C +C .................................................................. +C +C INEFFICIENCY CAUSED BY TOO FREQUENT OUTPUT IS MONITORED BY +C COUNTING THE NUMBER OF STEP SIZES WHICH ARE SEVERELY SHORTENED +C DUE SOLELY TO THE CHOICE OF OUTPUT POINTS. WHEN THE NUMBER OF +C ABUSES EXCEED MXKOP, THE COUNTER IS RESET TO ZERO AND THE USER +C IS INFORMED ABOUT POSSIBLE MISUSE OF THE CODE. +C + DATA MXKOP /100/ +C +C .................................................................. +C +C***FIRST EXECUTABLE STATEMENT DRKFS + IF (INFO(1) .EQ. 0) THEN +C +C ON THE FIRST CALL , PERFORM INITIALIZATION -- +C DEFINE THE MACHINE UNIT ROUNDOFF QUANTITY U BY CALLING THE +C FUNCTION ROUTINE D1MACH. THE USER MUST MAKE SURE THAT THE +C VALUES SET IN D1MACH ARE RELEVANT TO THE COMPUTER BEING USED. +C + U = D1MACH(4) +C -- SET ASSOCIATED MACHINE DEPENDENT PARAMETERS + U26 = 26.0D0*U + RER = 2.0D0*U + REMIN +C -- SET TERMINATION FLAG + IQUIT = 0 +C -- SET INITIALIZATION INDICATOR + INIT = 0 +C -- SET COUNTER FOR IMPACT OF OUTPUT POINTS + KOP = 0 +C -- SET COUNTER FOR ATTEMPTED STEPS + KSTEPS = 0 +C -- SET INDICATORS FOR STIFFNESS DETECTION + STIFF = .FALSE. + NONSTF = .FALSE. +C -- SET STEP COUNTERS FOR STIFFNESS DETECTION + NTSTEP = 0 + NSTIFS = 0 +C -- RESET INFO(1) FOR SUBSEQUENT CALLS + INFO(1) = 1 + ENDIF +C +C....................................................................... +C +C CHECK VALIDITY OF INPUT PARAMETERS ON EACH ENTRY +C + IF (INFO(1) .NE. 0 .AND. INFO(1) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(1) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, INFO(1) MUST BE SET TO 0 ' // + * 'FOR THE START OF A NEW PROBLEM, AND MUST BE SET TO 1 ' // + * 'FOLLOWING AN INTERRUPTED TASK. YOU ARE ATTEMPTING TO ' // + * 'CONTINUE THE INTEGRATION ILLEGALLY BY CALLING THE CODE ' // + * 'WITH INFO(1) = ' // XERN1, 3, 1) + IDID = -33 + ENDIF +C + IF (INFO(2) .NE. 0 .AND. INFO(2) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(2) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, INFO(2) MUST BE 0 OR 1 ' // + * 'INDICATING SCALAR AND VECTOR ERROR TOLERANCES, ' // + * 'RESPECTIVELY. YOU HAVE CALLED THE CODE WITH INFO(2) = ' // + * XERN1, 4, 1) + IDID = -33 + ENDIF +C + IF (INFO(3) .NE. 0 .AND. INFO(3) .NE. 1) THEN + WRITE (XERN1, '(I8)') INFO(3) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, INFO(3) MUST BE 0 OR 1 ' // + * 'INDICATING THE INTERVAL OR INTERMEDIATE-OUTPUT MODE OF ' // + * 'INTEGRATION, RESPECTIVELY. YOU HAVE CALLED THE CODE ' // + * 'WITH INFO(3) = ' // XERN1, 5, 1) + IDID = -33 + ENDIF +C + IF (NEQ .LT. 1) THEN + WRITE (XERN1, '(I8)') NEQ + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, THE NUMBER OF EQUATIONS ' // + * 'NEQ MUST BE A POSITIVE INTEGER. YOU HAVE CALLED THE ' // + * 'CODE WITH NEQ = ' // XERN1, 6, 1) + IDID = -33 + ENDIF +C + NRTOLP = 0 + NATOLP = 0 + DO 10 K=1,NEQ + IF (NRTOLP .EQ. 0 .AND. RTOL(K) .LT. 0.D0) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') RTOL(K) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, THE RELATIVE ERROR ' // + * 'TOLERANCES RTOL MUST BE NON-NEGATIVE. YOU HAVE ' // + * 'CALLED THE CODE WITH RTOL(' // XERN1 // ') = ' // + * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // + * 'NO FURTHER CHECKING OF RTOL COMPONENTS IS DONE.', 7, 1) + IDID = -33 + NRTOLP = 1 + ENDIF +C + IF (NATOLP .EQ. 0 .AND. ATOL(K) .LT. 0.D0) THEN + WRITE (XERN1, '(I8)') K + WRITE (XERN3, '(1PE15.6)') ATOL(K) + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, THE ABSOLUTE ERROR ' // + * 'TOLERANCES ATOL MUST BE NON-NEGATIVE. YOU HAVE ' // + * 'CALLED THE CODE WITH ATOL(' // XERN1 // ') = ' // + * XERN3 // '. IN THE CASE OF VECTOR ERROR TOLERANCES, ' // + * 'NO FURTHER CHECKING OF ATOL COMPONENTS IS DONE.', 8, 1) + IDID = -33 + NATOLP = 1 + ENDIF +C + IF (INFO(2) .EQ. 0) GO TO 20 + IF (NATOLP.GT.0 .AND. NRTOLP.GT.0) GO TO 20 + 10 CONTINUE +C +C +C CHECK SOME CONTINUATION POSSIBILITIES +C + 20 IF (INIT .NE. 0) THEN + IF (T .EQ. TOUT) THEN + WRITE (XERN3, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, YOU HAVE CALLED THE ' // + * 'CODE WITH T = TOUT = ' // XERN3 // '$$THIS IS NOT ' // + * 'ALLOWED ON CONTINUATION CALLS.', 9, 1) + IDID=-33 + ENDIF +C + IF (T .NE. TOLD) THEN + WRITE (XERN3, '(1PE15.6)') TOLD + WRITE (XERN4, '(1PE15.6)') T + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, YOU HAVE CHANGED THE ' // + * 'VALUE OF T FROM ' // XERN3 // ' TO ' // XERN4 // + * '$$THIS IS NOT ALLOWED ON CONTINUATION CALLS.', 10, 1) + IDID=-33 + ENDIF +C + IF (INIT .NE. 1) THEN + IF (DTSIGN*(TOUT-T) .LT. 0.D0) THEN + WRITE (XERN3, '(1PE15.6)') TOUT + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, BY CALLING THE CODE WITH TOUT = ' // + * XERN3 // ' YOU ARE ATTEMPTING TO CHANGE THE ' // + * 'DIRECTION OF INTEGRATION.$$THIS IS NOT ALLOWED ' // + * 'WITHOUT RESTARTING.', 11, 1) + IDID=-33 + ENDIF + ENDIF + ENDIF +C +C INVALID INPUT DETECTED +C + IF (IDID .EQ. (-33)) THEN + IF (IQUIT .NE. (-33)) THEN + IQUIT = -33 + GOTO 540 + ELSE + CALL XERMSG ('SLATEC', 'DRKFS', + * 'IN DDERKF, INVALID INPUT WAS ' // + * 'DETECTED ON SUCCESSIVE ENTRIES. IT IS IMPOSSIBLE ' // + * 'TO PROCEED BECAUSE YOU HAVE NOT CORRECTED THE ' // + * 'PROBLEM, SO EXECUTION IS BEING TERMINATED.', 12, 2) + RETURN + ENDIF + ENDIF +C +C ............................................................ +C +C RTOL = ATOL = 0. IS ALLOWED AS VALID INPUT AND +C INTERPRETED AS ASKING FOR THE MOST ACCURATE SOLUTION +C POSSIBLE. IN THIS CASE, THE RELATIVE ERROR TOLERANCE +C RTOL IS RESET TO THE SMALLEST VALUE RER WHICH IS LIKELY +C TO BE REASONABLE FOR THIS METHOD AND MACHINE. +C + DO 190 K = 1, NEQ + IF (RTOL(K) + ATOL(K) .GT. 0.0D0) GO TO 180 + RTOL(K) = RER + IDID = -2 + 180 CONTINUE +C ...EXIT + IF (INFO(2) .EQ. 0) GO TO 200 + 190 CONTINUE + 200 CONTINUE +C + IF (IDID .NE. (-2)) GO TO 210 +C +C RTOL=ATOL=0 ON INPUT, SO RTOL WAS CHANGED TO A +C SMALL POSITIVE VALUE + TOLFAC = 1.0D0 + GO TO 530 + 210 CONTINUE +C +C BRANCH ON STATUS OF INITIALIZATION INDICATOR +C INIT=0 MEANS INITIAL DERIVATIVES AND +C STARTING STEP SIZE +C NOT YET COMPUTED +C INIT=1 MEANS STARTING STEP SIZE NOT YET +C COMPUTED INIT=2 MEANS NO FURTHER +C INITIALIZATION REQUIRED +C + IF (INIT .EQ. 0) GO TO 220 +C ......EXIT + IF (INIT .EQ. 1) GO TO 240 +C .........EXIT + GO TO 260 + 220 CONTINUE +C +C ................................................ +C +C MORE INITIALIZATION -- +C -- EVALUATE INITIAL +C DERIVATIVES +C + INIT = 1 + A = T + CALL DF(A,Y,YP,RPAR,IPAR) + IF (T .NE. TOUT) GO TO 230 +C +C INTERVAL MODE + IDID = 2 + T = TOUT + TOLD = T +C .....................EXIT + GO TO 560 + 230 CONTINUE + 240 CONTINUE +C +C -- SET SIGN OF INTEGRATION DIRECTION AND +C -- ESTIMATE STARTING STEP SIZE +C + INIT = 2 + DTSIGN = SIGN(1.0D0,TOUT-T) + U = D1MACH(4) + BIG = SQRT(D1MACH(2)) + UTE = U**0.375D0 + DY = UTE*DHVNRM(Y,NEQ) + IF (DY .EQ. 0.0D0) DY = UTE + KTOL = 1 + DO 250 K = 1, NEQ + IF (INFO(2) .EQ. 1) KTOL = K + TOL = RTOL(KTOL)*ABS(Y(K)) + ATOL(KTOL) + IF (TOL .EQ. 0.0D0) TOL = DY*RTOL(KTOL) + F1(K) = TOL + 250 CONTINUE +C + CALL DHSTRT(DF,NEQ,T,TOUT,Y,YP,F1,4,U,BIG,F2,F3,F4, + 1 F5,RPAR,IPAR,H) + 260 CONTINUE +C +C ...................................................... +C +C SET STEP SIZE FOR INTEGRATION IN THE DIRECTION +C FROM T TO TOUT AND SET OUTPUT POINT INDICATOR +C + DT = TOUT - T + H = SIGN(H,DT) + OUTPUT = .FALSE. +C +C TEST TO SEE IF DDERKF IS BEING SEVERELY IMPACTED BY +C TOO MANY OUTPUT POINTS +C + IF (ABS(H) .GE. 2.0D0*ABS(DT)) KOP = KOP + 1 + IF (KOP .LE. MXKOP) GO TO 270 +C +C UNNECESSARY FREQUENCY OF OUTPUT IS RESTRICTING +C THE STEP SIZE CHOICE + IDID = -5 + KOP = 0 + GO TO 510 + 270 CONTINUE +C + IF (ABS(DT) .GT. U26*ABS(T)) GO TO 290 +C +C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND +C RETURN +C + DO 280 K = 1, NEQ + Y(K) = Y(K) + DT*YP(K) + 280 CONTINUE + A = TOUT + CALL DF(A,Y,YP,RPAR,IPAR) + KSTEPS = KSTEPS + 1 + GO TO 500 + 290 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 490 +C +C ********************************************* +C ********************************************* +C STEP BY STEP INTEGRATION +C + 300 CONTINUE +C BEGIN BLOCK PERMITTING ...EXITS TO 480 + HFAILD = .FALSE. +C +C TO PROTECT AGAINST IMPOSSIBLE ACCURACY +C REQUESTS, COMPUTE A TOLERANCE FACTOR +C BASED ON THE REQUESTED ERROR TOLERANCE +C AND A LEVEL OF ACCURACY ACHIEVABLE AT +C LIMITING PRECISION +C + TOLFAC = 0.0D0 + KTOL = 1 + DO 330 K = 1, NEQ + IF (INFO(2) .EQ. 1) KTOL = K + ET = RTOL(KTOL)*ABS(Y(K)) + 1 + ATOL(KTOL) + IF (ET .GT. 0.0D0) GO TO 310 + TOLFAC = MAX(TOLFAC, + 1 RER/RTOL(KTOL)) + GO TO 320 + 310 CONTINUE + TOLFAC = MAX(TOLFAC, + 1 ABS(Y(K)) + 2 *(RER/ET)) + 320 CONTINUE + 330 CONTINUE + IF (TOLFAC .LE. 1.0D0) GO TO 340 +C +C REQUESTED ERROR UNATTAINABLE DUE TO LIMITED +C PRECISION AVAILABLE + TOLFAC = 2.0D0*TOLFAC + IDID = -2 +C .....................EXIT + GO TO 520 + 340 CONTINUE +C +C SET SMALLEST ALLOWABLE STEP SIZE +C + HMIN = U26*ABS(T) +C +C ADJUST STEP SIZE IF NECESSARY TO HIT +C THE OUTPUT POINT -- LOOK AHEAD TWO +C STEPS TO AVOID DRASTIC CHANGES IN THE +C STEP SIZE AND THUS LESSEN THE IMPACT OF +C OUTPUT POINTS ON THE CODE. STRETCH THE +C STEP SIZE BY, AT MOST, AN AMOUNT EQUAL +C TO THE SAFETY FACTOR OF 9/10. +C + DT = TOUT - T + IF (ABS(DT) .GE. 2.0D0*ABS(H)) + 1 GO TO 370 + IF (ABS(DT) .GT. ABS(H)/0.9D0) + 1 GO TO 350 +C +C THE NEXT STEP, IF SUCCESSFUL, +C WILL COMPLETE THE INTEGRATION TO +C THE OUTPUT POINT +C + OUTPUT = .TRUE. + H = DT + GO TO 360 + 350 CONTINUE +C + H = 0.5D0*DT + 360 CONTINUE + 370 CONTINUE +C +C +C *************************************** +C CORE INTEGRATOR FOR TAKING A +C SINGLE STEP +C *************************************** +C TO AVOID PROBLEMS WITH ZERO +C CROSSINGS, RELATIVE ERROR IS +C MEASURED USING THE AVERAGE OF THE +C MAGNITUDES OF THE SOLUTION AT THE +C BEGINNING AND END OF A STEP. +C THE ERROR ESTIMATE FORMULA HAS +C BEEN GROUPED TO CONTROL LOSS OF +C SIGNIFICANCE. +C LOCAL ERROR ESTIMATES FOR A FIRST +C ORDER METHOD USING THE SAME +C STEP SIZE AS THE FEHLBERG METHOD +C ARE CALCULATED AS PART OF THE +C TEST FOR STIFFNESS. +C TO DISTINGUISH THE VARIOUS +C ARGUMENTS, H IS NOT PERMITTED +C TO BECOME SMALLER THAN 26 UNITS OF +C ROUNDOFF IN T. PRACTICAL LIMITS +C ON THE CHANGE IN THE STEP SIZE ARE +C ENFORCED TO SMOOTH THE STEP SIZE +C SELECTION PROCESS AND TO AVOID +C EXCESSIVE CHATTERING ON PROBLEMS +C HAVING DISCONTINUITIES. TO +C PREVENT UNNECESSARY FAILURES, THE +C CODE USES 9/10 THE STEP SIZE +C IT ESTIMATES WILL SUCCEED. +C AFTER A STEP FAILURE, THE STEP +C SIZE IS NOT ALLOWED TO INCREASE +C FOR THE NEXT ATTEMPTED STEP. THIS +C MAKES THE CODE MORE EFFICIENT ON +C PROBLEMS HAVING DISCONTINUITIES +C AND MORE EFFECTIVE IN GENERAL +C SINCE LOCAL EXTRAPOLATION IS BEING +C USED AND EXTRA CAUTION SEEMS +C WARRANTED. +C ....................................... +C +C MONITOR NUMBER OF STEPS ATTEMPTED +C + 380 CONTINUE + IF (KSTEPS .LE. MXSTEP) GO TO 390 +C +C A SIGNIFICANT AMOUNT OF WORK HAS +C BEEN EXPENDED + IDID = -1 + KSTEPS = 0 +C ........................EXIT + IF (.NOT.STIFF) GO TO 520 +C +C PROBLEM APPEARS TO BE STIFF + IDID = -4 + STIFF = .FALSE. + NONSTF = .FALSE. + NTSTEP = 0 + NSTIFS = 0 +C ........................EXIT + GO TO 520 + 390 CONTINUE +C +C ADVANCE AN APPROXIMATE SOLUTION OVER +C ONE STEP OF LENGTH H +C + CALL DFEHL(DF,NEQ,T,Y,H,YP,F1,F2,F3, + 1 F4,F5,YS,RPAR,IPAR) + KSTEPS = KSTEPS + 1 +C +C .................................... +C +C COMPUTE AND TEST ALLOWABLE +C TOLERANCES VERSUS LOCAL ERROR +C ESTIMATES. NOTE THAT RELATIVE +C ERROR IS MEASURED WITH RESPECT +C TO THE AVERAGE OF THE +C MAGNITUDES OF THE SOLUTION AT +C THE BEGINNING AND END OF THE +C STEP. LOCAL ERROR ESTIMATES +C FOR A SPECIAL FIRST ORDER +C METHOD ARE CALCULATED ONLY WHEN +C THE STIFFNESS DETECTION IS +C TURNED ON. +C + EEOET = 0.0D0 + ESTIFF = 0.0D0 + KTOL = 1 + DO 420 K = 1, NEQ + YAVG = 0.5D0 + 1 *(ABS(Y(K)) + 2 + ABS(YS(K))) + IF (INFO(2) .EQ. 1) KTOL = K + ET = RTOL(KTOL)*YAVG + ATOL(KTOL) + IF (ET .GT. 0.0D0) GO TO 400 +C +C PURE RELATIVE ERROR INAPPROPRIATE WHEN SOLUTION +C VANISHES + IDID = -3 +C ...........................EXIT + GO TO 520 + 400 CONTINUE +C + EE = ABS((-2090.0D0*YP(K) + 1 +(21970.0D0*F3(K) + 2 -15048.0D0*F4(K))) + 3 +(22528.0D0*F2(K) + 4 -27360.0D0*F5(K))) + IF (STIFF .OR. NONSTF) GO TO 410 + ES = ABS(H + 1 *(0.055455D0*YP(K) + 2 -0.035493D0*F1(K) + 3 -0.036571D0*F2(K) + 4 +0.023107D0*F3(K) + 5 -0.009515D0*F4(K) + 6 +0.003017D0*F5(K)) + 7 ) + ESTIFF = MAX(ESTIFF,ES/ET) + 410 CONTINUE + EEOET = MAX(EEOET,EE/ET) + 420 CONTINUE +C + ESTTOL = ABS(H)*EEOET/752400.0D0 +C +C ...EXIT + IF (ESTTOL .LE. 1.0D0) GO TO 440 +C +C .................................... +C +C UNSUCCESSFUL STEP +C + IF (ABS(H) .GT. HMIN) GO TO 430 +C +C REQUESTED ERROR UNATTAINABLE AT SMALLEST +C ALLOWABLE STEP SIZE + TOLFAC = 1.69D0*ESTTOL + IDID = -2 +C ........................EXIT + GO TO 520 + 430 CONTINUE +C +C REDUCE THE STEP SIZE , TRY AGAIN +C THE DECREASE IS LIMITED TO A FACTOR +C OF 1/10 +C + HFAILD = .TRUE. + OUTPUT = .FALSE. + S = 0.1D0 + IF (ESTTOL .LT. 59049.0D0) + 1 S = 0.9D0/ESTTOL**0.2D0 + H = SIGN(MAX(S*ABS(H),HMIN),H) + GO TO 380 + 440 CONTINUE +C +C ....................................... +C +C SUCCESSFUL STEP +C STORE SOLUTION AT T+H +C AND EVALUATE +C DERIVATIVES THERE +C + T = T + H + DO 450 K = 1, NEQ + Y(K) = YS(K) + 450 CONTINUE + A = T + CALL DF(A,Y,YP,RPAR,IPAR) +C +C CHOOSE NEXT STEP SIZE +C THE INCREASE IS LIMITED TO A FACTOR OF +C 5 IF STEP FAILURE HAS JUST OCCURRED, +C NEXT +C STEP SIZE IS NOT ALLOWED TO INCREASE +C + S = 5.0D0 + IF (ESTTOL .GT. 1.889568D-4) + 1 S = 0.9D0/ESTTOL**0.2D0 + IF (HFAILD) S = MIN(S,1.0D0) + H = SIGN(MAX(S*ABS(H),HMIN),H) +C +C ....................................... +C +C CHECK FOR STIFFNESS (IF NOT +C ALREADY DETECTED) +C +C IN A SEQUENCE OF 50 SUCCESSFUL +C STEPS BY THE FEHLBERG METHOD, 25 +C SUCCESSFUL STEPS BY THE FIRST +C ORDER METHOD INDICATES STIFFNESS +C AND TURNS THE TEST OFF. IF 26 +C FAILURES BY THE FIRST ORDER METHOD +C OCCUR, THE TEST IS TURNED OFF +C UNTIL THIS SEQUENCE OF 50 STEPS BY +C THE FEHLBERG METHOD IS COMPLETED. +C +C ...EXIT + IF (STIFF) GO TO 480 + NTSTEP = MOD(NTSTEP+1,50) + IF (NTSTEP .EQ. 1) NONSTF = .FALSE. +C ...EXIT + IF (NONSTF) GO TO 480 + IF (ESTIFF .GT. 1.0D0) GO TO 460 +C +C SUCCESSFUL STEP WITH FIRST ORDER +C METHOD + NSTIFS = NSTIFS + 1 +C TURN TEST OFF AFTER 25 INDICATIONS +C OF STIFFNESS + IF (NSTIFS .EQ. 25) STIFF = .TRUE. + GO TO 470 + 460 CONTINUE +C +C UNSUCCESSFUL STEP WITH FIRST ORDER +C METHOD + IF (NTSTEP - NSTIFS .LE. 25) GO TO 470 +C TURN STIFFNESS DETECTION OFF FOR THIS BLOCK OF +C FIFTY STEPS + NONSTF = .TRUE. +C RESET STIFF STEP COUNTER + NSTIFS = 0 + 470 CONTINUE + 480 CONTINUE +C +C ****************************************** +C END OF CORE INTEGRATOR +C ****************************************** +C +C +C SHOULD WE TAKE ANOTHER STEP +C +C ......EXIT + IF (OUTPUT) GO TO 490 + IF (INFO(3) .EQ. 0) GO TO 300 +C +C ********************************************* +C ********************************************* +C +C INTEGRATION SUCCESSFULLY COMPLETED +C +C ONE-STEP MODE + IDID = 1 + TOLD = T +C .....................EXIT + GO TO 560 + 490 CONTINUE + 500 CONTINUE +C +C INTERVAL MODE + IDID = 2 + T = TOUT + TOLD = T +C ...............EXIT + GO TO 560 + 510 CONTINUE + 520 CONTINUE + 530 CONTINUE + 540 CONTINUE +C +C INTEGRATION TASK INTERRUPTED +C + INFO(1) = -1 + TOLD = T +C ...EXIT + IF (IDID .NE. (-2)) GO TO 560 +C +C THE ERROR TOLERANCES ARE INCREASED TO VALUES +C WHICH ARE APPROPRIATE FOR CONTINUING + RTOL(1) = TOLFAC*RTOL(1) + ATOL(1) = TOLFAC*ATOL(1) +C ...EXIT + IF (INFO(2) .EQ. 0) GO TO 560 + DO 550 K = 2, NEQ + RTOL(K) = TOLFAC*RTOL(K) + ATOL(K) = TOLFAC*ATOL(K) + 550 CONTINUE + 560 CONTINUE + RETURN + END +*DECK XERMSG + SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) +C***BEGIN PROLOGUE XERMSG +C***PURPOSE Process error messages for SLATEC and other libraries. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERMSG-A) +C***KEYWORDS ERROR MESSAGE, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C XERMSG processes a diagnostic message in a manner determined by the +C value of LEVEL and the current value of the library error control +C flag, KONTRL. See subroutine XSETF for details. +C +C LIBRAR A character constant (or character variable) with the name +C of the library. This will be 'SLATEC' for the SLATEC +C Common Math Library. The error handling package is +C general enough to be used by many libraries +C simultaneously, so it is desirable for the routine that +C detects and reports an error to identify the library name +C as well as the routine name. +C +C SUBROU A character constant (or character variable) with the name +C of the routine that detected the error. Usually it is the +C name of the routine that is calling XERMSG. There are +C some instances where a user callable library routine calls +C lower level subsidiary routines where the error is +C detected. In such cases it may be more informative to +C supply the name of the routine the user called rather than +C the name of the subsidiary routine that detected the +C error. +C +C MESSG A character constant (or character variable) with the text +C of the error or warning message. In the example below, +C the message is a character constant that contains a +C generic message. +C +C CALL XERMSG ('SLATEC', 'MMPY', +C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', +C *3, 1) +C +C It is possible (and is sometimes desirable) to generate a +C specific message--e.g., one that contains actual numeric +C values. Specific numeric values can be converted into +C character strings using formatted WRITE statements into +C character variables. This is called standard Fortran +C internal file I/O and is exemplified in the first three +C lines of the following example. You can also catenate +C substrings of characters to construct the error message. +C Here is an example showing the use of both writing to +C an internal file and catenating character strings. +C +C CHARACTER*5 CHARN, CHARL +C WRITE (CHARN,10) N +C WRITE (CHARL,10) LDA +C 10 FORMAT(I5) +C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// +C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// +C * CHARL, 3, 1) +C +C There are two subtleties worth mentioning. One is that +C the // for character catenation is used to construct the +C error message so that no single character constant is +C continued to the next line. This avoids confusion as to +C whether there are trailing blanks at the end of the line. +C The second is that by catenating the parts of the message +C as an actual argument rather than encoding the entire +C message into one large character variable, we avoid +C having to know how long the message will be in order to +C declare an adequate length for that large character +C variable. XERMSG calls XERPRN to print the message using +C multiple lines if necessary. If the message is very long, +C XERPRN will break it into pieces of 72 characters (as +C requested by XERMSG) for printing on multiple lines. +C Also, XERMSG asks XERPRN to prefix each line with ' * ' +C so that the total line length could be 76 characters. +C Note also that XERPRN scans the error message backwards +C to ignore trailing blanks. Another feature is that +C the substring '$$' is treated as a new line sentinel +C by XERPRN. If you want to construct a multiline +C message without having to count out multiples of 72 +C characters, just use '$$' as a separator. '$$' +C obviously must occur within 72 characters of the +C start of each line to have its intended effect since +C XERPRN is asked to wrap around at 72 characters in +C addition to looking for '$$'. +C +C NERR An integer value that is chosen by the library routine's +C author. It must be in the range -99 to 999 (three +C printable digits). Each distinct error should have its +C own error number. These error numbers should be described +C in the machine readable documentation for the routine. +C The error numbers need be unique only within each routine, +C so it is reasonable for each routine to start enumerating +C errors from 1 and proceeding to the next integer. +C +C LEVEL An integer value in the range 0 to 2 that indicates the +C level (severity) of the error. Their meanings are +C +C -1 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. An attempt is made to only print this +C message once. +C +C 0 A warning message. This is used if it is not clear +C that there really is an error, but the user's attention +C may be needed. +C +C 1 A recoverable error. This is used even if the error is +C so serious that the routine cannot return any useful +C answer. If the user has told the error package to +C return after recoverable errors, then XERMSG will +C return to the Library routine which can then return to +C the user's routine. The user may also permit the error +C package to terminate the program upon encountering a +C recoverable error. +C +C 2 A fatal error. XERMSG will not return to its caller +C after it receives a fatal error. This level should +C hardly ever be used; it is much better to allow the +C user a chance to recover. An example of one of the few +C cases in which it is permissible to declare a level 2 +C error is a reverse communication Library routine that +C is likely to be called repeatedly until it integrates +C across some interval. If there is a serious error in +C the input such that another step cannot be taken and +C the Library routine is called again without the input +C error having been corrected by the caller, the Library +C routine will probably be called forever with improper +C input. In this case, it is reasonable to declare the +C error to be fatal. +C +C Each of the arguments to XERMSG is input; none will be modified by +C XERMSG. A routine may make multiple calls to XERMSG with warning +C level messages; however, after a call to XERMSG with a recoverable +C error, the routine should return to the user. Do not try to call +C XERMSG with a second recoverable error after the first recoverable +C error because the error package saves the error number. The user +C can retrieve this error number by calling another entry point in +C the error handling package and then clear the error number when +C recovering from the error. Calling XERMSG in succession causes the +C old error number to be overwritten by the latest error number. +C This is considered harmless for error numbers associated with +C warning messages but must not be done for error numbers of serious +C errors. After a call to XERMSG with a recoverable error, the user +C must be given a chance to call NUMXER or XERCLR to retrieve or +C clear the error number. +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE +C***REVISION HISTORY (YYMMDD) +C 880101 DATE WRITTEN +C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. +C THERE ARE TWO BASIC CHANGES. +C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO +C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES +C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS +C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE +C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER +C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY +C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE +C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. +C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE +C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE +C OF LOWER CASE. +C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. +C THE PRINCIPAL CHANGES ARE +C 1. CLARIFY COMMENTS IN THE PROLOGUES +C 2. RENAME XRPRNT TO XERPRN +C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES +C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / +C CHARACTER FOR NEW RECORDS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C CLEAN UP THE CODING. +C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN +C PREFIX. +C 891013 REVISED TO CORRECT COMMENTS. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but +C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added +C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and +C XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERMSG + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 XLIBR, XSUBR + CHARACTER*72 TEMP + CHARACTER*20 LFIRST +C***FIRST EXECUTABLE STATEMENT XERMSG + LKNTRL = J4SAVE (2, 0, .FALSE.) + MAXMES = J4SAVE (4, 0, .FALSE.) +C +C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. +C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE +C SHOULD BE PRINTED. +C +C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN +C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, +C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. +C + IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. + * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN + CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // + * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// + * 'JOB ABORT DUE TO FATAL ERROR.', 72) + CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) + CALL XERHLT (' ***XERMSG -- INVALID INPUT') + RETURN + ENDIF +C +C RECORD THE MESSAGE. +C + I = J4SAVE (1, NERR, .TRUE.) + CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) +C +C HANDLE PRINT-ONCE WARNING MESSAGES. +C + IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN +C +C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. +C + XLIBR = LIBRAR + XSUBR = SUBROU + LFIRST = MESSG + LERR = NERR + LLEVEL = LEVEL + CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) +C + LKNTRL = MAX(-2, MIN(2,LKNTRL)) + MKNTRL = ABS(LKNTRL) +C +C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS +C ZERO AND THE ERROR IS NOT FATAL. +C + IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 + IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 + IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 + IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 +C +C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A +C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) +C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG +C IS NOT ZERO. +C + IF (LKNTRL .NE. 0) THEN + TEMP(1:21) = 'MESSAGE FROM ROUTINE ' + I = MIN(LEN(SUBROU), 16) + TEMP(22:21+I) = SUBROU(1:I) + TEMP(22+I:33+I) = ' IN LIBRARY ' + LTEMP = 33 + I + I = MIN(LEN(LIBRAR), 16) + TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) + TEMP(LTEMP+I+1:LTEMP+I+1) = '.' + LTEMP = LTEMP + I + 1 + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE +C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE +C FROM EACH OF THE FOLLOWING THREE OPTIONS. +C 1. LEVEL OF THE MESSAGE +C 'INFORMATIVE MESSAGE' +C 'POTENTIALLY RECOVERABLE ERROR' +C 'FATAL ERROR' +C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE +C 'PROG CONTINUES' +C 'PROG ABORTED' +C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK +C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS +C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) +C 'TRACEBACK REQUESTED' +C 'TRACEBACK NOT REQUESTED' +C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT +C EXCEED 74 CHARACTERS. +C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. +C + IF (LKNTRL .GT. 0) THEN +C +C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. +C + IF (LEVEL .LE. 0) THEN + TEMP(1:20) = 'INFORMATIVE MESSAGE,' + LTEMP = 20 + ELSEIF (LEVEL .EQ. 1) THEN + TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' + LTEMP = 30 + ELSE + TEMP(1:12) = 'FATAL ERROR,' + LTEMP = 12 + ENDIF +C +C THEN WHETHER THE PROGRAM WILL CONTINUE. +C + IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. + * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN + TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' + LTEMP = LTEMP + 14 + ELSE + TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' + LTEMP = LTEMP + 16 + ENDIF +C +C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' + LTEMP = LTEMP + 20 + ELSE + TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' + LTEMP = LTEMP + 24 + ENDIF + CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) + ENDIF +C +C NOW SEND OUT THE MESSAGE. +C + CALL XERPRN (' * ', -1, MESSG, 72) +C +C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A +C TRACEBACK. +C + IF (LKNTRL .GT. 0) THEN + WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR + DO 10 I=16,22 + IF (TEMP(I:I) .NE. ' ') GO TO 20 + 10 CONTINUE +C + 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) + CALL FDUMP + ENDIF +C +C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. +C + IF (LKNTRL .NE. 0) THEN + CALL XERPRN (' * ', -1, ' ', 72) + CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) + CALL XERPRN (' ', 0, ' ', 72) + ENDIF +C +C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE +C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. +C + 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN +C +C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A +C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR +C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. +C + IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN + IF (LEVEL .EQ. 1) THEN + CALL XERPRN + * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) + ELSE + CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) + ENDIF + CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) + CALL XERHLT (' ') + ELSE + CALL XERHLT (MESSG) + ENDIF + RETURN + END +*DECK XERPRN + SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) +C***BEGIN PROLOGUE XERPRN +C***SUBSIDIARY +C***PURPOSE Print error messages processed by XERMSG. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERPRN-A) +C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR +C***AUTHOR Fong, Kirby, (NMFECC at LLNL) +C***DESCRIPTION +C +C This routine sends one or more lines to each of the (up to five) +C logical units to which error messages are to be sent. This routine +C is called several times by XERMSG, sometimes with a single line to +C print and sometimes with a (potentially very long) message that may +C wrap around into multiple lines. +C +C PREFIX Input argument of type CHARACTER. This argument contains +C characters to be put at the beginning of each line before +C the body of the message. No more than 16 characters of +C PREFIX will be used. +C +C NPREF Input argument of type INTEGER. This argument is the number +C of characters to use from PREFIX. If it is negative, the +C intrinsic function LEN is used to determine its length. If +C it is zero, PREFIX is not used. If it exceeds 16 or if +C LEN(PREFIX) exceeds 16, only the first 16 characters will be +C used. If NPREF is positive and the length of PREFIX is less +C than NPREF, a copy of PREFIX extended with blanks to length +C NPREF will be used. +C +C MESSG Input argument of type CHARACTER. This is the text of a +C message to be printed. If it is a long message, it will be +C broken into pieces for printing on multiple lines. Each line +C will start with the appropriate prefix and be followed by a +C piece of the message. NWRAP is the number of characters per +C piece; that is, after each NWRAP characters, we break and +C start a new line. In addition the characters '$$' embedded +C in MESSG are a sentinel for a new line. The counting of +C characters up to NWRAP starts over for each new line. The +C value of NWRAP typically used by XERMSG is 72 since many +C older error messages in the SLATEC Library are laid out to +C rely on wrap-around every 72 characters. +C +C NWRAP Input argument of type INTEGER. This gives the maximum size +C piece into which to break MESSG for printing on multiple +C lines. An embedded '$$' ends a line, and the count restarts +C at the following character. If a line break does not occur +C on a blank (it would split a word) that word is moved to the +C next line. Values of NWRAP less than 16 will be treated as +C 16. Values of NWRAP greater than 132 will be treated as 132. +C The actual line length will be NPREF + NWRAP after NPREF has +C been adjusted to fall between 0 and 16 and NWRAP has been +C adjusted to fall between 16 and 132. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 880621 DATE WRITTEN +C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF +C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK +C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE +C SLASH CHARACTER IN FORMAT STATEMENTS. +C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO +C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK +C LINES TO BE PRINTED. +C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF +C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. +C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. +C 891214 Prologue converted to Version 4.0 format. (WRB) +C 900510 Added code to break messages between words. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERPRN + CHARACTER*(*) PREFIX, MESSG + INTEGER NPREF, NWRAP + CHARACTER*148 CBUFF + INTEGER IU(5), NUNIT + CHARACTER*2 NEWLIN + PARAMETER (NEWLIN = '$$') +C***FIRST EXECUTABLE STATEMENT XERPRN + CALL XGETUA(IU,NUNIT) +C +C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD +C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD +C ERROR MESSAGE UNIT. +C + N = I1MACH(4) + DO 10 I=1,NUNIT + IF (IU(I) .EQ. 0) IU(I) = N + 10 CONTINUE +C +C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE +C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING +C THE REST OF THIS ROUTINE. +C + IF ( NPREF .LT. 0 ) THEN + LPREF = LEN(PREFIX) + ELSE + LPREF = NPREF + ENDIF + LPREF = MIN(16, LPREF) + IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX +C +C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE +C TIME FROM MESSG TO PRINT ON ONE LINE. +C + LWRAP = MAX(16, MIN(132, NWRAP)) +C +C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. +C + LENMSG = LEN(MESSG) + N = LENMSG + DO 20 I=1,N + IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 + LENMSG = LENMSG - 1 + 20 CONTINUE + 30 CONTINUE +C +C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. +C + IF (LENMSG .EQ. 0) THEN + CBUFF(LPREF+1:LPREF+1) = ' ' + DO 40 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) + 40 CONTINUE + RETURN + ENDIF +C +C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING +C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. +C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. +C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. +C +C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE +C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE +C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH +C OF THE SECOND ARGUMENT. +C +C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE +C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER +C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT +C POSITION NEXTC. +C +C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE +C REMAINDER OF THE CHARACTER STRING. LPIECE +C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, +C WHICHEVER IS LESS. +C +C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: +C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE +C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY +C BLANK LINES. THIS TAKES CARE OF THE SITUATION +C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF +C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE +C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC +C SHOULD BE INCREMENTED BY 2. +C +C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. +C +C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 +C RESET LPIECE = LPIECE-1. NOTE THAT THIS +C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. +C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY +C AT THE END OF A LINE. +C + NEXTC = 1 + 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) + IF (LPIECE .EQ. 0) THEN +C +C THERE WAS NO NEW LINE SENTINEL FOUND. +C + IDELTA = 0 + LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) + IF (LPIECE .LT. LENMSG+1-NEXTC) THEN + DO 52 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 54 + ENDIF + 52 CONTINUE + ENDIF + 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSEIF (LPIECE .EQ. 1) THEN +C +C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). +C DON'T PRINT A BLANK LINE. +C + NEXTC = NEXTC + 2 + GO TO 50 + ELSEIF (LPIECE .GT. LWRAP+1) THEN +C +C LPIECE SHOULD BE SET DOWN TO LWRAP. +C + IDELTA = 0 + LPIECE = LWRAP + DO 56 I=LPIECE+1,2,-1 + IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN + LPIECE = I-1 + IDELTA = 1 + GOTO 58 + ENDIF + 56 CONTINUE + 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + IDELTA + ELSE +C +C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. +C WE SHOULD DECREMENT LPIECE BY ONE. +C + LPIECE = LPIECE - 1 + CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) + NEXTC = NEXTC + LPIECE + 2 + ENDIF +C +C PRINT +C + DO 60 I=1,NUNIT + WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) + 60 CONTINUE +C + IF (NEXTC .LE. LENMSG) GO TO 50 + RETURN + END +*DECK XERSVE + SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, + + ICOUNT) +C***BEGIN PROLOGUE XERSVE +C***SUBSIDIARY +C***PURPOSE Record that an error has occurred. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (XERSVE-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C *Usage: +C +C INTEGER KFLAG, NERR, LEVEL, ICOUNT +C CHARACTER * (len) LIBRAR, SUBROU, MESSG +C +C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) +C +C *Arguments: +C +C LIBRAR :IN is the library that the message is from. +C SUBROU :IN is the subroutine that the message is from. +C MESSG :IN is the message to be saved. +C KFLAG :IN indicates the action to be performed. +C when KFLAG > 0, the message in MESSG is saved. +C when KFLAG=0 the tables will be dumped and +C cleared. +C when KFLAG < 0, the tables will be dumped and +C not cleared. +C NERR :IN is the error number. +C LEVEL :IN is the error severity. +C ICOUNT :OUT the number of times this message has been seen, +C or zero if the table has overflowed and does not +C contain this message specifically. When KFLAG=0, +C ICOUNT will not be altered. +C +C *Description: +C +C Record that this error occurred and possibly dump and clear the +C tables. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED I1MACH, XGETUA +C***REVISION HISTORY (YYMMDD) +C 800319 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900413 Routine modified to remove reference to KFLAG. (WRB) +C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling +C sequence, use IF-THEN-ELSE, make number of saved entries +C easily changeable, changed routine name from XERSAV to +C XERSVE. (RWC) +C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERSVE + PARAMETER (LENTAB=10) + INTEGER LUN(5) + CHARACTER*(*) LIBRAR, SUBROU, MESSG + CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB + CHARACTER*20 MESTAB(LENTAB), MES + DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) + SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG + DATA KOUNTX/0/, NMSG/0/ +C***FIRST EXECUTABLE STATEMENT XERSVE +C + IF (KFLAG.LE.0) THEN +C +C Dump the table. +C + IF (NMSG.EQ.0) RETURN +C +C Print to each unit. +C + CALL XGETUA (LUN, NUNIT) + DO 20 KUNIT = 1,NUNIT + IUNIT = LUN(KUNIT) + IF (IUNIT.EQ.0) IUNIT = I1MACH(4) +C +C Print the table header. +C + WRITE (IUNIT,9000) +C +C Print body of table. +C + DO 10 I = 1,NMSG + WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), + * NERTAB(I),LEVTAB(I),KOUNT(I) + 10 CONTINUE +C +C Print number of other errors. +C + IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX + WRITE (IUNIT,9030) + 20 CONTINUE +C +C Clear the error tables. +C + IF (KFLAG.EQ.0) THEN + NMSG = 0 + KOUNTX = 0 + ENDIF + ELSE +C +C PROCESS A MESSAGE... +C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, +C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. +C + LIB = LIBRAR + SUB = SUBROU + MES = MESSG + DO 30 I = 1,NMSG + IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. + * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. + * LEVEL.EQ.LEVTAB(I)) THEN + KOUNT(I) = KOUNT(I) + 1 + ICOUNT = KOUNT(I) + RETURN + ENDIF + 30 CONTINUE +C + IF (NMSG.LT.LENTAB) THEN +C +C Empty slot found for new message. +C + NMSG = NMSG + 1 + LIBTAB(I) = LIB + SUBTAB(I) = SUB + MESTAB(I) = MES + NERTAB(I) = NERR + LEVTAB(I) = LEVEL + KOUNT (I) = 1 + ICOUNT = 1 + ELSE +C +C Table is full. +C + KOUNTX = KOUNTX+1 + ICOUNT = 0 + ENDIF + ENDIF + RETURN +C +C Formats. +C + 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / + + ' LIBRARY SUBROUTINE MESSAGE START NERR', + + ' LEVEL COUNT') + 9010 FORMAT (1X,A,3X,A,3X,A,3I10) + 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) + 9030 FORMAT (1X) + END +*DECK D1MACH + DOUBLE PRECISION FUNCTION D1MACH (I) +C***BEGIN PROLOGUE D1MACH +C***PURPOSE Return floating point machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C D1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument, and can be referenced as follows: +C +C D = D1MACH(I) +C +C where I=1,...,5. The (output) value of D above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. +C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. +C D1MACH( 3) = B**(-T), the smallest relative spacing. +C D1MACH( 4) = B**(1-T), the largest relative spacing. +C D1MACH( 5) = LOG10(B) +C +C Assume double precision numbers are represented in the T-digit, +C base-B form +C +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and +C EMIN .LE. E .LE. EMAX. +C +C The values of B, T, EMIN and EMAX are provided in I1MACH as +C follows: +C I1MACH(10) = B, the base. +C I1MACH(14) = T, the number of base-B digits. +C I1MACH(15) = EMIN, the smallest exponent E. +C I1MACH(16) = EMAX, the largest exponent E. +C +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of D1MACH(1) - D1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 890213 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 900911 Added SUN 386i constants. (WRB) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added CONVEX -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE D1MACH +C +cc INTEGER SMALL(4) +cc INTEGER LARGE(4) +cc INTEGER RIGHT(4) +cc INTEGER DIVER(4) +cc INTEGER LOG10(4) +C +C Initial data here correspond to the IEEE standard. The values for +C DMACH(1), DMACH(3) and DMACH(4) are slight upper bounds. The value +C for DMACH(2) is a slight lower bound. The value for DMACH(5) is +C a 20-digit approximation. If one of the sets of initial data below +C is preferred, do the necessary commenting and uncommenting. (DWL) + DOUBLE PRECISION DMACH(5) + DATA DMACH / 2.23D-308, 1.79D+308, 1.111D-16, 2.222D-16, + 1 0.30102999566398119521D0 / + SAVE DMACH +C +cc EQUIVALENCE (DMACH(1),SMALL(1)) +cc EQUIVALENCE (DMACH(2),LARGE(1)) +cc EQUIVALENCE (DMACH(3),RIGHT(1)) +cc EQUIVALENCE (DMACH(4),DIVER(1)) +cc EQUIVALENCE (DMACH(5),LOG10(1)) +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / +C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / +C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / +C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA SMALL(1) / ZC00800000 / +C DATA SMALL(2) / Z000000000 / +C DATA LARGE(1) / ZDFFFFFFFF / +C DATA LARGE(2) / ZFFFFFFFFF / +C DATA RIGHT(1) / ZCC5800000 / +C DATA RIGHT(2) / Z000000000 / +C DATA DIVER(1) / ZCC6800000 / +C DATA DIVER(2) / Z000000000 / +C DATA LOG10(1) / ZD00E730E7 / +C DATA LOG10(2) / ZC77800DC0 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O0000000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O0007777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA SMALL(1) / O1771000000000000 / +C DATA SMALL(2) / O7770000000000000 / +C DATA LARGE(1) / O0777777777777777 / +C DATA LARGE(2) / O7777777777777777 / +C DATA RIGHT(1) / O1461000000000000 / +C DATA RIGHT(2) / O0000000000000000 / +C DATA DIVER(1) / O1451000000000000 / +C DATA DIVER(2) / O0000000000000000 / +C DATA LOG10(1) / O1157163034761674 / +C DATA LOG10(2) / O0006677466732724 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA SMALL(1) / Z"3001800000000000" / +C DATA SMALL(2) / Z"3001000000000000" / +C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / +C DATA LARGE(2) / Z"4FFE000000000000" / +C DATA RIGHT(1) / Z"3FD2800000000000" / +C DATA RIGHT(2) / Z"3FD2000000000000" / +C DATA DIVER(1) / Z"3FD3800000000000" / +C DATA DIVER(2) / Z"3FD3000000000000" / +C DATA LOG10(1) / Z"3FFF9A209A84FBCF" / +C DATA LOG10(2) / Z"3FFFF7988F8959AC" / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA SMALL(1) / 00564000000000000000B / +C DATA SMALL(2) / 00000000000000000000B / +C DATA LARGE(1) / 37757777777777777777B / +C DATA LARGE(2) / 37157777777777777777B / +C DATA RIGHT(1) / 15624000000000000000B / +C DATA RIGHT(2) / 00000000000000000000B / +C DATA DIVER(1) / 15634000000000000000B / +C DATA DIVER(2) / 00000000000000000000B / +C DATA LOG10(1) / 17164642023241175717B / +C DATA LOG10(2) / 16367571421742254654B / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn OR -pd8 COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CC0000000000000' / +C DATA DMACH(4) / Z'3CD0000000000000' / +C DATA DMACH(5) / Z'3FF34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F900000000000000000000000000000' / +C DATA DMACH(4) / Z'3F910000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE CRAY +C +C DATA SMALL(1) / 201354000000000000000B / +C DATA SMALL(2) / 000000000000000000000B / +C DATA LARGE(1) / 577767777777777777777B / +C DATA LARGE(2) / 000007777777777777774B / +C DATA RIGHT(1) / 376434000000000000000B / +C DATA RIGHT(2) / 000000000000000000000B / +C DATA DIVER(1) / 376444000000000000000B / +C DATA DIVER(2) / 000000000000000000000B / +C DATA LOG10(1) / 377774642023241175717B / +C DATA LOG10(2) / 000007571421742254654B / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - +C STATIC DMACH(5) +C +C DATA SMALL / 20K, 3*0 / +C DATA LARGE / 77777K, 3*177777K / +C DATA RIGHT / 31420K, 3*0 / +C DATA DIVER / 32020K, 3*0 / +C DATA LOG10 / 40423K, 42023K, 50237K, 74776K / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA DMACH(1) / '0000000000000010'X / +C DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / +C DATA DMACH(3) / '0000000000003CC0'X / +C DATA DMACH(4) / '0000000000003CD0'X / +C DATA DMACH(5) / '79FF509F44133FF3'X / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FORMAT +C +C DATA DMACH(1) / '0010000000000000'X / +C DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / +C DATA DMACH(3) / '3CA0000000000000'X / +C DATA DMACH(4) / '3CB0000000000000'X / +C DATA DMACH(5) / '3FD34413509F79FF'X / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ +C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ +C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ +C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ +C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA LOG10(1), LOG10(2) / 546979738, -805796613 / +C +C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C (EXPRESSED IN INTEGER AND HEXADECIMAL) +C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS +C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS +C +C DATA SMALL(1), SMALL(2) / 16, 0 / +C DATA LARGE(1), LARGE(2) / -32769, -1 / +C DATA RIGHT(1), RIGHT(2) / 15552, 0 / +C DATA DIVER(1), DIVER(2) / 15568, 0 / +C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / +C +C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / +C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) +C +C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / +C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / +C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / +C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / +C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA SMALL(1), SMALL(2) / '20000000, '00000201 / +C DATA LARGE(1), LARGE(2) / '37777777, '37777577 / +C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / +C DATA DIVER(1), DIVER(2) / '20000000, '00000334 / +C DATA LOG10(1), LOG10(2) / '23210115, '10237777 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +C DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / +C DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / +C DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / +C DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / +C DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C THREE WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / +C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / +C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / +C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA SMALL(1), SMALL(2) / 40000B, 0 / +C DATA SMALL(3), SMALL(4) / 0, 1 / +C DATA LARGE(1), LARGE(2) / 77777B, 177777B / +C DATA LARGE(3), LARGE(4) / 177777B, 177776B / +C DATA RIGHT(1), RIGHT(2) / 40000B, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 225B / +C DATA DIVER(1), DIVER(2) / 40000B, 0 / +C DATA DIVER(3), DIVER(4) / 0, 227B / +C DATA LOG10(1), LOG10(2) / 46420B, 46502B / +C DATA LOG10(3), LOG10(4) / 76747B, 176377B / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / +C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / +C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / +C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / +C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / +C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / +C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / +C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / +C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / +C +C MACHINE CONSTANTS FOR THE IBM PC +C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION +C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. +C +C DATA SMALL(1) / 2.23D-308 / +C DATA LARGE(1) / 1.79D+308 / +C DATA RIGHT(1) / 1.11D-16 / +C DATA DIVER(1) / 2.22D-16 / +C DATA LOG10(1) / 0.301029995663981195D0 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / +C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / +C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / +C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / +C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / +C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 8388608, 0 / +C DATA LARGE(1), LARGE(2) / 2147483647, -1 / +C DATA RIGHT(1), RIGHT(2) / 612368384, 0 / +C DATA DIVER(1), DIVER(2) / 620756992, 0 / +C DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / +C +C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / +C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / +C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / +C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / +C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). +C +C DATA SMALL(1), SMALL(2) / 128, 0 / +C DATA SMALL(3), SMALL(4) / 0, 0 / +C DATA LARGE(1), LARGE(2) / 32767, -1 / +C DATA LARGE(3), LARGE(4) / -1, -1 / +C DATA RIGHT(1), RIGHT(2) / 9344, 0 / +C DATA RIGHT(3), RIGHT(4) / 0, 0 / +C DATA DIVER(1), DIVER(2) / 9472, 0 / +C DATA DIVER(3), DIVER(4) / 0, 0 / +C DATA LOG10(1), LOG10(2) / 16282, 8346 / +C DATA LOG10(3), LOG10(4) / -31493, -12296 / +C +C DATA SMALL(1), SMALL(2) / O000200, O000000 / +C DATA SMALL(3), SMALL(4) / O000000, O000000 / +C DATA LARGE(1), LARGE(2) / O077777, O177777 / +C DATA LARGE(3), LARGE(4) / O177777, O177777 / +C DATA RIGHT(1), RIGHT(2) / O022200, O000000 / +C DATA RIGHT(3), RIGHT(4) / O000000, O000000 / +C DATA DIVER(1), DIVER(2) / O022400, O000000 / +C DATA DIVER(3), DIVER(4) / O000000, O000000 / +C DATA LOG10(1), LOG10(2) / O037632, O020232 / +C DATA LOG10(3), LOG10(4) / O102373, O147770 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / +C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / +C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / +C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA DMACH(1) / Z'0010000000000000' / +C DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3CA0000000000000' / +C DATA DMACH(4) / Z'3CB0000000000000' / +C DATA DMACH(5) / Z'3FD34413509F79FF' / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA DMACH(1) / Z'00010000000000000000000000000000' / +C DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / +C DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / +C DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / +C DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / +C +C MACHINE CONSTANTS FOR THE SUN 386i +C +C DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / +C DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / +C DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / +C DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' +C DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / +C DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / +C DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / +C DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / +C DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / +C +C***FIRST EXECUTABLE STATEMENT D1MACH + IF (I .LT. 1 .OR. I .GT. 5) CALL XERMSG ('SLATEC', 'D1MACH', + + 'I OUT OF BOUNDS', 1, 2) +C + D1MACH = DMACH(I) + RETURN +C + END +*DECK XGETUA + SUBROUTINE XGETUA (IUNITA, N) +C***BEGIN PROLOGUE XGETUA +C***PURPOSE Return unit number(s) to which error messages are being +C sent. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XGETUA-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C XGETUA may be called to determine the unit number or numbers +C to which error messages are being sent. +C These unit numbers may have been set by a call to XSETUN, +C or a call to XSETUA, or may be a default value. +C +C Description of Parameters +C --Output-- +C IUNIT - an array of one to five unit numbers, depending +C on the value of N. A value of zero refers to the +C default unit, as defined by the I1MACH machine +C constant routine. Only IUNIT(1),...,IUNIT(N) are +C defined by XGETUA. The values of IUNIT(N+1),..., +C IUNIT(5) are not defined (for N .LT. 5) or altered +C in any way by XGETUA. +C N - the number of units to which copies of the +C error messages are being sent. N will be in the +C range from 1 to 5. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED J4SAVE +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XGETUA + DIMENSION IUNITA(5) +C***FIRST EXECUTABLE STATEMENT XGETUA + N = J4SAVE(5,0,.FALSE.) + DO 30 I=1,N + INDEX = I+4 + IF (I.EQ.1) INDEX = 3 + IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) + 30 CONTINUE + RETURN + END +*DECK FDUMP + SUBROUTINE FDUMP +C***BEGIN PROLOGUE FDUMP +C***PURPOSE Symbolic dump (should be locally written). +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3 +C***TYPE ALL (FDUMP-A) +C***KEYWORDS ERROR, XERMSG +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C ***Note*** Machine Dependent Routine +C FDUMP is intended to be replaced by a locally written +C version which produces a symbolic dump. Failing this, +C it should be replaced by a version which prints the +C subprogram nesting list. Note that this dump must be +C printed on each of up to five files, as indicated by the +C XGETUA routine. See XSETUA and XGETUA for details. +C +C Written by Ron Jones, with SLATEC Common Math Library Subcommittee +C +C***REFERENCES (NONE) +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C***END PROLOGUE FDUMP +C***FIRST EXECUTABLE STATEMENT FDUMP + RETURN + END +*DECK DFEHL + SUBROUTINE DFEHL (DF, NEQ, T, Y, H, YP, F1, F2, F3, F4, F5, YS, + + RPAR, IPAR) +C***BEGIN PROLOGUE DFEHL +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (DEFEHL-S, DFEHL-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C Fehlberg Fourth-Fifth Order Runge-Kutta Method +C ********************************************************************** +C +C DFEHL integrates a system of NEQ first order +C ordinary differential equations of the form +C DU/DX = DF(X,U) +C over one step when the vector Y(*) of initial values for U(*) and +C the vector YP(*) of initial derivatives, satisfying YP = DF(T,Y), +C are given at the starting point X=T. +C +C DFEHL advances the solution over the fixed step H and returns +C the fifth order (sixth order accurate locally) solution +C approximation at T+H in the array YS(*). +C F1,---,F5 are arrays of dimension NEQ which are needed +C for internal storage. +C The formulas have been grouped to control loss of significance. +C DFEHL should be called with an H not smaller than 13 units of +C roundoff in T so that the various independent arguments can be +C distinguished. +C +C This subroutine has been written with all variables and statement +C numbers entirely compatible with DRKFS. For greater efficiency, +C the call to DFEHL can be replaced by the module beginning with +C line 222 and extending to the last line just before the return +C statement. +C +C ********************************************************************** +C +C***SEE ALSO DDERKF +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890831 Modified array declarations. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DFEHL +C + INTEGER IPAR, K, NEQ + DOUBLE PRECISION CH, F1, F2, F3, F4, F5, H, RPAR, T, Y, YP, YS + DIMENSION Y(*),YP(*),F1(*),F2(*),F3(*),F4(*),F5(*), + 1 YS(*),RPAR(*),IPAR(*) +C +C***FIRST EXECUTABLE STATEMENT DFEHL + CH = H/4.0D0 + DO 10 K = 1, NEQ + YS(K) = Y(K) + CH*YP(K) + 10 CONTINUE + CALL DF(T+CH,YS,F1,RPAR,IPAR) +C + CH = 3.0D0*H/32.0D0 + DO 20 K = 1, NEQ + YS(K) = Y(K) + CH*(YP(K) + 3.0D0*F1(K)) + 20 CONTINUE + CALL DF(T+3.0D0*H/8.0D0,YS,F2,RPAR,IPAR) +C + CH = H/2197.0D0 + DO 30 K = 1, NEQ + YS(K) = Y(K) + 1 + CH + 2 *(1932.0D0*YP(K) + (7296.0D0*F2(K) - 7200.0D0*F1(K))) + 30 CONTINUE + CALL DF(T+12.0D0*H/13.0D0,YS,F3,RPAR,IPAR) +C + CH = H/4104.0D0 + DO 40 K = 1, NEQ + YS(K) = Y(K) + 1 + CH + 2 *((8341.0D0*YP(K) - 845.0D0*F3(K)) + 3 + (29440.0D0*F2(K) - 32832.0D0*F1(K))) + 40 CONTINUE + CALL DF(T+H,YS,F4,RPAR,IPAR) +C + CH = H/20520.0D0 + DO 50 K = 1, NEQ + YS(K) = Y(K) + 1 + CH + 2 *((-6080.0D0*YP(K) + 3 + (9295.0D0*F3(K) - 5643.0D0*F4(K))) + 4 + (41040.0D0*F1(K) - 28352.0D0*F2(K))) + 50 CONTINUE + CALL DF(T+H/2.0D0,YS,F5,RPAR,IPAR) +C +C COMPUTE APPROXIMATE SOLUTION AT T+H +C + CH = H/7618050.0D0 + DO 60 K = 1, NEQ + YS(K) = Y(K) + 1 + CH + 2 *((902880.0D0*YP(K) + 3 + (3855735.0D0*F3(K) - 1371249.0D0*F4(K))) + 4 + (3953664.0D0*F2(K) + 277020.0D0*F5(K))) + 60 CONTINUE +C + RETURN + END +*DECK I1MACH + INTEGER FUNCTION I1MACH (I) +C***BEGIN PROLOGUE I1MACH +C***PURPOSE Return integer machine dependent constants. +C***LIBRARY SLATEC +C***CATEGORY R1 +C***TYPE INTEGER (I1MACH-I) +C***KEYWORDS MACHINE CONSTANTS +C***AUTHOR Fox, P. A., (Bell Labs) +C Hall, A. D., (Bell Labs) +C Schryer, N. L., (Bell Labs) +C***DESCRIPTION +C +C I1MACH can be used to obtain machine-dependent parameters for the +C local machine environment. It is a function subprogram with one +C (input) argument and can be referenced as follows: +C +C K = I1MACH(I) +C +C where I=1,...,16. The (output) value of K above is determined by +C the (input) value of I. The results for various values of I are +C discussed below. +C +C I/O unit numbers: +C I1MACH( 1) = the standard input unit. +C I1MACH( 2) = the standard output unit. +C I1MACH( 3) = the standard punch unit. +C I1MACH( 4) = the standard error message unit. +C +C Words: +C I1MACH( 5) = the number of bits per integer storage unit. +C I1MACH( 6) = the number of characters per integer storage unit. +C +C Integers: +C assume integers are represented in the S-digit, base-A form +C +C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) +C +C where 0 .LE. X(I) .LT. A for I=0,...,S-1. +C I1MACH( 7) = A, the base. +C I1MACH( 8) = S, the number of base-A digits. +C I1MACH( 9) = A**S - 1, the largest magnitude. +C +C Floating-Point Numbers: +C Assume floating-point numbers are represented in the T-digit, +C base-B form +C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) +C +C where 0 .LE. X(I) .LT. B for I=1,...,T, +C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. +C I1MACH(10) = B, the base. +C +C Single-Precision: +C I1MACH(11) = T, the number of base-B digits. +C I1MACH(12) = EMIN, the smallest exponent E. +C I1MACH(13) = EMAX, the largest exponent E. +C +C Double-Precision: +C I1MACH(14) = T, the number of base-B digits. +C I1MACH(15) = EMIN, the smallest exponent E. +C I1MACH(16) = EMAX, the largest exponent E. +C +C To alter this function for a particular environment, the desired +C set of DATA statements should be activated by removing the C from +C column 1. Also, the values of I1MACH(1) - I1MACH(4) should be +C checked for consistency with the local operating system. +C +C***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for +C a portable library, ACM Transactions on Mathematical +C Software 4, 2 (June 1978), pp. 177-188. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 750101 DATE WRITTEN +C 891012 Added VAX G-floating constants. (WRB) +C 891012 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900618 Added DEC RISC constants. (WRB) +C 900723 Added IBM RS 6000 constants. (WRB) +C 901009 Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16. +C (RWC) +C 910710 Added HP 730 constants. (SMR) +C 911114 Added Convex IEEE constants. (WRB) +C 920121 Added SUN -r8 compiler option constants. (WRB) +C 920229 Added Touchstone Delta i860 constants. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C 920625 Added Convex -p8 and -pd8 compiler option constants. +C (BKS, WRB) +C 930201 Added DEC Alpha and SGI constants. (RWC and WRB) +C 930618 Corrected I1MACH(5) for Convex -p8 and -pd8 compiler +C options. (DWL, RWC and WRB). +C 010817 Elevated IEEE to highest importance; see next set of +C comments below. (DWL) +C***END PROLOGUE I1MACH +C +C Initial data here correspond to the IEEE standard. If one of the +C sets of initial data below is preferred, do the necessary commenting +C and uncommenting. (DWL) + INTEGER IMACH(16),OUTPUT + DATA IMACH( 1) / 5 / + DATA IMACH( 2) / 6 / + DATA IMACH( 3) / 6 / + DATA IMACH( 4) / 6 / + DATA IMACH( 5) / 32 / + DATA IMACH( 6) / 4 / + DATA IMACH( 7) / 2 / + DATA IMACH( 8) / 31 / + DATA IMACH( 9) / 2147483647 / + DATA IMACH(10) / 2 / + DATA IMACH(11) / 24 / + DATA IMACH(12) / -126 / + DATA IMACH(13) / 127 / + DATA IMACH(14) / 53 / + DATA IMACH(15) / -1022 / + DATA IMACH(16) / 1023 / + SAVE IMACH +cc EQUIVALENCE (IMACH(4),OUTPUT) + output=imach(4) +cc +C +C MACHINE CONSTANTS FOR THE AMIGA +C ABSOFT COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE APOLLO +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 129 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1025 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM +C +C DATA IMACH( 1) / 7 / +C DATA IMACH( 2) / 2 / +C DATA IMACH( 3) / 2 / +C DATA IMACH( 4) / 2 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 33 / +C DATA IMACH( 9) / Z1FFFFFFFF / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -256 / +C DATA IMACH(13) / 255 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -256 / +C DATA IMACH(16) / 255 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -50 / +C DATA IMACH(16) / 76 / +C +C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 48 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 39 / +C DATA IMACH( 9) / O0007777777777777 / +C DATA IMACH(10) / 8 / +C DATA IMACH(11) / 13 / +C DATA IMACH(12) / -50 / +C DATA IMACH(13) / 76 / +C DATA IMACH(14) / 26 / +C DATA IMACH(15) / -32754 / +C DATA IMACH(16) / 32780 / +C +C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -4095 / +C DATA IMACH(13) / 4094 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -4095 / +C DATA IMACH(16) / 4094 / +C +C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6LOUTPUT/ +C DATA IMACH( 5) / 60 / +C DATA IMACH( 6) / 10 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 48 / +C DATA IMACH( 9) / 00007777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -929 / +C DATA IMACH(13) / 1070 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -929 / +C DATA IMACH(16) / 1069 / +C +C MACHINE CONSTANTS FOR THE CELERITY C1260 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z'7FFFFFFF' / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fn COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -fi COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -p8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16383 / +C DATA IMACH(16) / 16383 / +C +C MACHINE CONSTANTS FOR THE CONVEX +C USING THE -pd8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 9223372036854775807 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1023 / +C DATA IMACH(13) / 1023 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 46 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 46 / +C DATA IMACH( 9) / 1777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE CRAY +C USING THE 64 BIT INTEGER COMPILER OPTION +C +C DATA IMACH( 1) / 100 / +C DATA IMACH( 2) / 101 / +C DATA IMACH( 3) / 102 / +C DATA IMACH( 4) / 101 / +C DATA IMACH( 5) / 64 / +C DATA IMACH( 6) / 8 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 63 / +C DATA IMACH( 9) / 777777777777777777777B / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 47 / +C DATA IMACH(12) / -8189 / +C DATA IMACH(13) / 8190 / +C DATA IMACH(14) / 94 / +C DATA IMACH(15) / -8099 / +C DATA IMACH(16) / 8190 / +C +C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 +C +C DATA IMACH( 1) / 11 / +C DATA IMACH( 2) / 12 / +C DATA IMACH( 3) / 8 / +C DATA IMACH( 4) / 10 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING G_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE DEC ALPHA +C USING IEEE_FLOAT +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC RISC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING D_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE DEC VAX +C USING G_FLOATING +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1023 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE ELXSI 6400 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1022 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE HARRIS 220 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 24 / +C DATA IMACH( 6) / 3 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 23 / +C DATA IMACH( 9) / 8388607 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 38 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 43 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 6 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 63 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 730 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 3 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 39 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 2100 +C 4 WORD DOUBLE PRECISION OPTION WITH FTN4 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 4 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 23 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 55 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE HP 9000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 7 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 32 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -126 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1015 / +C DATA IMACH(16) / 1017 / +C +C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, +C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND +C THE PERKIN ELMER (INTERDATA) 7/32. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 7 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / Z7FFFFFFF / +C DATA IMACH(10) / 16 / +C DATA IMACH(11) / 6 / +C DATA IMACH(12) / -64 / +C DATA IMACH(13) / 63 / +C DATA IMACH(14) / 14 / +C DATA IMACH(15) / -64 / +C DATA IMACH(16) / 63 / +C +C MACHINE CONSTANTS FOR THE IBM PC +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE IBM RS 6000 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 0 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE INTEL i860 +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 54 / +C DATA IMACH(15) / -101 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 5 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / "377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 62 / +C DATA IMACH(15) / -128 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 32-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING +C 16-BIT INTEGER ARITHMETIC. +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 5 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C MACHINE CONSTANTS FOR THE SILICON GRAPHICS +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -125 / +C DATA IMACH(13) / 128 / +C DATA IMACH(14) / 53 / +C DATA IMACH(15) / -1021 / +C DATA IMACH(16) / 1024 / +C +C MACHINE CONSTANTS FOR THE SUN +C USING THE -r8 COMPILER OPTION +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 6 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 32 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 31 / +C DATA IMACH( 9) / 2147483647 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 53 / +C DATA IMACH(12) / -1021 / +C DATA IMACH(13) / 1024 / +C DATA IMACH(14) / 113 / +C DATA IMACH(15) / -16381 / +C DATA IMACH(16) / 16384 / +C +C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER +C +C DATA IMACH( 1) / 5 / +C DATA IMACH( 2) / 6 / +C DATA IMACH( 3) / 1 / +C DATA IMACH( 4) / 6 / +C DATA IMACH( 5) / 36 / +C DATA IMACH( 6) / 4 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 35 / +C DATA IMACH( 9) / O377777777777 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 27 / +C DATA IMACH(12) / -128 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 60 / +C DATA IMACH(15) / -1024 / +C DATA IMACH(16) / 1023 / +C +C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR +C +C DATA IMACH( 1) / 1 / +C DATA IMACH( 2) / 1 / +C DATA IMACH( 3) / 0 / +C DATA IMACH( 4) / 1 / +C DATA IMACH( 5) / 16 / +C DATA IMACH( 6) / 2 / +C DATA IMACH( 7) / 2 / +C DATA IMACH( 8) / 15 / +C DATA IMACH( 9) / 32767 / +C DATA IMACH(10) / 2 / +C DATA IMACH(11) / 24 / +C DATA IMACH(12) / -127 / +C DATA IMACH(13) / 127 / +C DATA IMACH(14) / 56 / +C DATA IMACH(15) / -127 / +C DATA IMACH(16) / 127 / +C +C***FIRST EXECUTABLE STATEMENT I1MACH + IF (I .LT. 1 .OR. I .GT. 16) GO TO 10 +C + I1MACH = IMACH(I) + RETURN +C + 10 CONTINUE + WRITE (UNIT = OUTPUT, FMT = 9000) + 9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS') +C +C CALL FDUMP +C + STOP + END +*DECK DHSTRT + SUBROUTINE DHSTRT (DF, NEQ, A, B, Y, YPRIME, ETOL, MORDER, SMALL, + + BIG, SPY, PV, YP, SF, RPAR, IPAR, H) +C***BEGIN PROLOGUE DHSTRT +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (HSTART-S, DHSTRT-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C DHSTRT computes a starting step size to be used in solving initial +C value problems in ordinary differential equations. +C +C ********************************************************************** +C ABSTRACT +C +C Subroutine DHSTRT computes a starting step size to be used by an +C initial value method in solving ordinary differential equations. +C It is based on an estimate of the local Lipschitz constant for the +C differential equation (lower bound on a norm of the Jacobian) , +C a bound on the differential equation (first derivative) , and +C a bound on the partial derivative of the equation with respect to +C the independent variable. +C (all approximated near the initial point A) +C +C Subroutine DHSTRT uses a function subprogram DHVNRM for computing +C a vector norm. The maximum norm is presently utilized though it +C can easily be replaced by any other vector norm. It is presumed +C that any replacement norm routine would be carefully coded to +C prevent unnecessary underflows or overflows from occurring, and +C also, would not alter the vector or number of components. +C +C ********************************************************************** +C On input you must provide the following +C +C DF -- This is a subroutine of the form +C DF(X,U,UPRIME,RPAR,IPAR) +C which defines the system of first order differential +C equations to be solved. For the given values of X and the +C vector U(*)=(U(1),U(2),...,U(NEQ)) , the subroutine must +C evaluate the NEQ components of the system of differential +C equations DU/DX=DF(X,U) and store the derivatives in the +C array UPRIME(*), that is, UPRIME(I) = * DU(I)/DX * for +C equations I=1,...,NEQ. +C +C Subroutine DF must not alter X or U(*). You must declare +C the name DF in an external statement in your program that +C calls DHSTRT. You must dimension U and UPRIME in DF. +C +C RPAR and IPAR are DOUBLE PRECISION and INTEGER parameter +C arrays which you can use for communication between your +C program and subroutine DF. They are not used or altered by +C DHSTRT. If you do not need RPAR or IPAR, ignore these +C parameters by treating them as dummy arguments. If you do +C choose to use them, dimension them in your program and in +C DF as arrays of appropriate length. +C +C NEQ -- This is the number of (first order) differential equations +C to be integrated. +C +C A -- This is the initial point of integration. +C +C B -- This is a value of the independent variable used to define +C the direction of integration. A reasonable choice is to +C set B to the first point at which a solution is desired. +C You can also use B, if necessary, to restrict the length +C of the first integration step because the algorithm will +C not compute a starting step length which is bigger than +C ABS(B-A), unless B has been chosen too close to A. +C (it is presumed that DHSTRT has been called with B +C different from A on the machine being used. Also see the +C discussion about the parameter SMALL.) +C +C Y(*) -- This is the vector of initial values of the NEQ solution +C components at the initial point A. +C +C YPRIME(*) -- This is the vector of derivatives of the NEQ +C solution components at the initial point A. +C (defined by the differential equations in subroutine DF) +C +C ETOL -- This is the vector of error tolerances corresponding to +C the NEQ solution components. It is assumed that all +C elements are positive. Following the first integration +C step, the tolerances are expected to be used by the +C integrator in an error test which roughly requires that +C ABS(LOCAL ERROR) .LE. ETOL +C for each vector component. +C +C MORDER -- This is the order of the formula which will be used by +C the initial value method for taking the first integration +C step. +C +C SMALL -- This is a small positive machine dependent constant +C which is used for protecting against computations with +C numbers which are too small relative to the precision of +C floating point arithmetic. SMALL should be set to +C (approximately) the smallest positive DOUBLE PRECISION +C number such that (1.+SMALL) .GT. 1. on the machine being +C used. The quantity SMALL**(3/8) is used in computing +C increments of variables for approximating derivatives by +C differences. Also the algorithm will not compute a +C starting step length which is smaller than +C 100*SMALL*ABS(A). +C +C BIG -- This is a large positive machine dependent constant which +C is used for preventing machine overflows. A reasonable +C choice is to set big to (approximately) the square root of +C the largest DOUBLE PRECISION number which can be held in +C the machine. +C +C SPY(*),PV(*),YP(*),SF(*) -- These are DOUBLE PRECISION work +C arrays of length NEQ which provide the routine with needed +C storage space. +C +C RPAR,IPAR -- These are parameter arrays, of DOUBLE PRECISION and +C INTEGER type, respectively, which can be used for +C communication between your program and the DF subroutine. +C They are not used or altered by DHSTRT. +C +C ********************************************************************** +C On Output (after the return from DHSTRT), +C +C H -- is an appropriate starting step size to be attempted by the +C differential equation method. +C +C All parameters in the call list remain unchanged except for +C the working arrays SPY(*),PV(*),YP(*), and SF(*). +C +C ********************************************************************** +C +C***SEE ALSO DDEABM, DDEBDF, DDERKF +C***ROUTINES CALLED DHVNRM +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 890911 Removed unnecessary intrinsics. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DHSTRT +C + INTEGER IPAR, J, K, LK, MORDER, NEQ + DOUBLE PRECISION A, ABSDX, B, BIG, DA, DELF, DELY, + 1 DFDUB, DFDXB, DHVNRM, + 2 DX, DY, ETOL, FBND, H, PV, RELPER, RPAR, SF, SMALL, SPY, + 3 SRYDPB, TOLEXP, TOLMIN, TOLP, TOLSUM, Y, YDPB, YP, YPRIME + DIMENSION Y(*),YPRIME(*),ETOL(*),SPY(*),PV(*),YP(*), + 1 SF(*),RPAR(*),IPAR(*) + EXTERNAL DF +C +C .................................................................. +C +C BEGIN BLOCK PERMITTING ...EXITS TO 160 +C***FIRST EXECUTABLE STATEMENT DHSTRT + DX = B - A + ABSDX = ABS(DX) + RELPER = SMALL**0.375D0 +C +C ............................................................... +C +C COMPUTE AN APPROXIMATE BOUND (DFDXB) ON THE PARTIAL +C DERIVATIVE OF THE EQUATION WITH RESPECT TO THE +C INDEPENDENT VARIABLE. PROTECT AGAINST AN OVERFLOW. +C ALSO COMPUTE A BOUND (FBND) ON THE FIRST DERIVATIVE +C LOCALLY. +C + DA = SIGN(MAX(MIN(RELPER*ABS(A),ABSDX), + 1 100.0D0*SMALL*ABS(A)),DX) + IF (DA .EQ. 0.0D0) DA = RELPER*DX + CALL DF(A+DA,Y,SF,RPAR,IPAR) + DO 10 J = 1, NEQ + YP(J) = SF(J) - YPRIME(J) + 10 CONTINUE + DELF = DHVNRM(YP,NEQ) + DFDXB = BIG + IF (DELF .LT. BIG*ABS(DA)) DFDXB = DELF/ABS(DA) + FBND = DHVNRM(SF,NEQ) +C +C ............................................................... +C +C COMPUTE AN ESTIMATE (DFDUB) OF THE LOCAL LIPSCHITZ +C CONSTANT FOR THE SYSTEM OF DIFFERENTIAL EQUATIONS. THIS +C ALSO REPRESENTS AN ESTIMATE OF THE NORM OF THE JACOBIAN +C LOCALLY. THREE ITERATIONS (TWO WHEN NEQ=1) ARE USED TO +C ESTIMATE THE LIPSCHITZ CONSTANT BY NUMERICAL DIFFERENCES. +C THE FIRST PERTURBATION VECTOR IS BASED ON THE INITIAL +C DERIVATIVES AND DIRECTION OF INTEGRATION. THE SECOND +C PERTURBATION VECTOR IS FORMED USING ANOTHER EVALUATION OF +C THE DIFFERENTIAL EQUATION. THE THIRD PERTURBATION VECTOR +C IS FORMED USING PERTURBATIONS BASED ONLY ON THE INITIAL +C VALUES. COMPONENTS THAT ARE ZERO ARE ALWAYS CHANGED TO +C NON-ZERO VALUES (EXCEPT ON THE FIRST ITERATION). WHEN +C INFORMATION IS AVAILABLE, CARE IS TAKEN TO ENSURE THAT +C COMPONENTS OF THE PERTURBATION VECTOR HAVE SIGNS WHICH ARE +C CONSISTENT WITH THE SLOPES OF LOCAL SOLUTION CURVES. +C ALSO CHOOSE THE LARGEST BOUND (FBND) FOR THE FIRST +C DERIVATIVE. +C +C PERTURBATION VECTOR SIZE IS HELD +C CONSTANT FOR ALL ITERATIONS. COMPUTE +C THIS CHANGE FROM THE +C SIZE OF THE VECTOR OF INITIAL +C VALUES. + DELY = RELPER*DHVNRM(Y,NEQ) + IF (DELY .EQ. 0.0D0) DELY = RELPER + DELY = SIGN(DELY,DX) + DELF = DHVNRM(YPRIME,NEQ) + FBND = MAX(FBND,DELF) + IF (DELF .EQ. 0.0D0) GO TO 30 +C USE INITIAL DERIVATIVES FOR FIRST PERTURBATION + DO 20 J = 1, NEQ + SPY(J) = YPRIME(J) + YP(J) = YPRIME(J) + 20 CONTINUE + GO TO 50 + 30 CONTINUE +C CANNOT HAVE A NULL PERTURBATION VECTOR + DO 40 J = 1, NEQ + SPY(J) = 0.0D0 + YP(J) = 1.0D0 + 40 CONTINUE + DELF = DHVNRM(YP,NEQ) + 50 CONTINUE +C + DFDUB = 0.0D0 + LK = MIN(NEQ+1,3) + DO 140 K = 1, LK +C DEFINE PERTURBED VECTOR OF INITIAL VALUES + DO 60 J = 1, NEQ + PV(J) = Y(J) + DELY*(YP(J)/DELF) + 60 CONTINUE + IF (K .EQ. 2) GO TO 80 +C EVALUATE DERIVATIVES ASSOCIATED WITH PERTURBED +C VECTOR AND COMPUTE CORRESPONDING DIFFERENCES + CALL DF(A,PV,YP,RPAR,IPAR) + DO 70 J = 1, NEQ + PV(J) = YP(J) - YPRIME(J) + 70 CONTINUE + GO TO 100 + 80 CONTINUE +C USE A SHIFTED VALUE OF THE INDEPENDENT VARIABLE +C IN COMPUTING ONE ESTIMATE + CALL DF(A+DA,PV,YP,RPAR,IPAR) + DO 90 J = 1, NEQ + PV(J) = YP(J) - SF(J) + 90 CONTINUE + 100 CONTINUE +C CHOOSE LARGEST BOUNDS ON THE FIRST DERIVATIVE +C AND A LOCAL LIPSCHITZ CONSTANT + FBND = MAX(FBND,DHVNRM(YP,NEQ)) + DELF = DHVNRM(PV,NEQ) +C ...EXIT + IF (DELF .GE. BIG*ABS(DELY)) GO TO 150 + DFDUB = MAX(DFDUB,DELF/ABS(DELY)) +C ......EXIT + IF (K .EQ. LK) GO TO 160 +C CHOOSE NEXT PERTURBATION VECTOR + IF (DELF .EQ. 0.0D0) DELF = 1.0D0 + DO 130 J = 1, NEQ + IF (K .EQ. 2) GO TO 110 + DY = ABS(PV(J)) + IF (DY .EQ. 0.0D0) DY = DELF + GO TO 120 + 110 CONTINUE + DY = Y(J) + IF (DY .EQ. 0.0D0) DY = DELY/RELPER + 120 CONTINUE + IF (SPY(J) .EQ. 0.0D0) SPY(J) = YP(J) + IF (SPY(J) .NE. 0.0D0) DY = SIGN(DY,SPY(J)) + YP(J) = DY + 130 CONTINUE + DELF = DHVNRM(YP,NEQ) + 140 CONTINUE + 150 CONTINUE +C +C PROTECT AGAINST AN OVERFLOW + DFDUB = BIG + 160 CONTINUE +C +C .................................................................. +C +C COMPUTE A BOUND (YDPB) ON THE NORM OF THE SECOND DERIVATIVE +C + YDPB = DFDXB + DFDUB*FBND +C +C .................................................................. +C +C DEFINE THE TOLERANCE PARAMETER UPON WHICH THE STARTING STEP +C SIZE IS TO BE BASED. A VALUE IN THE MIDDLE OF THE ERROR +C TOLERANCE RANGE IS SELECTED. +C + TOLMIN = BIG + TOLSUM = 0.0D0 + DO 170 K = 1, NEQ + TOLEXP = LOG10(ETOL(K)) + TOLMIN = MIN(TOLMIN,TOLEXP) + TOLSUM = TOLSUM + TOLEXP + 170 CONTINUE + TOLP = 10.0D0**(0.5D0*(TOLSUM/NEQ + TOLMIN)/(MORDER+1)) +C +C .................................................................. +C +C COMPUTE A STARTING STEP SIZE BASED ON THE ABOVE FIRST AND +C SECOND DERIVATIVE INFORMATION +C +C RESTRICT THE STEP LENGTH TO BE NOT BIGGER +C THAN ABS(B-A). (UNLESS B IS TOO CLOSE +C TO A) + H = ABSDX +C + IF (YDPB .NE. 0.0D0 .OR. FBND .NE. 0.0D0) GO TO 180 +C +C BOTH FIRST DERIVATIVE TERM (FBND) AND SECOND +C DERIVATIVE TERM (YDPB) ARE ZERO + IF (TOLP .LT. 1.0D0) H = ABSDX*TOLP + GO TO 200 + 180 CONTINUE +C + IF (YDPB .NE. 0.0D0) GO TO 190 +C +C ONLY SECOND DERIVATIVE TERM (YDPB) IS ZERO + IF (TOLP .LT. FBND*ABSDX) H = TOLP/FBND + GO TO 200 + 190 CONTINUE +C +C SECOND DERIVATIVE TERM (YDPB) IS NON-ZERO + SRYDPB = SQRT(0.5D0*YDPB) + IF (TOLP .LT. SRYDPB*ABSDX) H = TOLP/SRYDPB + 200 CONTINUE +C +C FURTHER RESTRICT THE STEP LENGTH TO BE NOT +C BIGGER THAN 1/DFDUB + IF (H*DFDUB .GT. 1.0D0) H = 1.0D0/DFDUB +C +C FINALLY, RESTRICT THE STEP LENGTH TO BE NOT +C SMALLER THAN 100*SMALL*ABS(A). HOWEVER, IF +C A=0. AND THE COMPUTED H UNDERFLOWED TO ZERO, +C THE ALGORITHM RETURNS SMALL*ABS(B) FOR THE +C STEP LENGTH. + H = MAX(H,100.0D0*SMALL*ABS(A)) + IF (H .EQ. 0.0D0) H = SMALL*ABS(B) +C +C NOW SET DIRECTION OF INTEGRATION + H = SIGN(H,DX) +C + RETURN + END +*DECK DHVNRM + DOUBLE PRECISION FUNCTION DHVNRM (V, NCOMP) +C***BEGIN PROLOGUE DHVNRM +C***SUBSIDIARY +C***PURPOSE Subsidiary to DDEABM, DDEBDF and DDERKF +C***LIBRARY SLATEC +C***TYPE DOUBLE PRECISION (HVNRM-S, DHVNRM-D) +C***AUTHOR Watts, H. A., (SNLA) +C***DESCRIPTION +C +C Compute the maximum norm of the vector V(*) of length NCOMP and +C return the result as DHVNRM +C +C***SEE ALSO DDEABM, DDEBDF, DDERKF +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 820301 DATE WRITTEN +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891024 Changed references from DVNORM to DHVNRM. (WRB) +C 891024 Changed routine name from DVNORM to DHVNRM. (WRB) +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900328 Added TYPE section. (WRB) +C 910722 Updated AUTHOR section. (ALS) +C***END PROLOGUE DHVNRM +C + INTEGER K, NCOMP + DOUBLE PRECISION V + DIMENSION V(*) +C***FIRST EXECUTABLE STATEMENT DHVNRM + DHVNRM = 0.0D0 + DO 10 K = 1, NCOMP + DHVNRM = MAX(DHVNRM,ABS(V(K))) + 10 CONTINUE + RETURN + END +*DECK J4SAVE + FUNCTION J4SAVE (IWHICH, IVALUE, ISET) +C***BEGIN PROLOGUE J4SAVE +C***SUBSIDIARY +C***PURPOSE Save or recall global variables needed by error +C handling routines. +C***LIBRARY SLATEC (XERROR) +C***TYPE INTEGER (J4SAVE-I) +C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C J4SAVE saves and recalls several global variables needed +C by the library error handling routines. +C +C Description of Parameters +C --Input-- +C IWHICH - Index of item desired. +C = 1 Refers to current error number. +C = 2 Refers to current error control flag. +C = 3 Refers to current unit number to which error +C messages are to be sent. (0 means use standard.) +C = 4 Refers to the maximum number of times any +C message is to be printed (as set by XERMAX). +C = 5 Refers to the total number of units to which +C each error message is to be written. +C = 6 Refers to the 2nd unit for error messages +C = 7 Refers to the 3rd unit for error messages +C = 8 Refers to the 4th unit for error messages +C = 9 Refers to the 5th unit for error messages +C IVALUE - The value to be set for the IWHICH-th parameter, +C if ISET is .TRUE. . +C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE +C given the value, IVALUE. If ISET=.FALSE., the +C IWHICH-th parameter will be unchanged, and IVALUE +C is a dummy parameter. +C --Output-- +C The (old) value of the IWHICH-th parameter will be returned +C in the function value, J4SAVE. +C +C***SEE ALSO XERMSG +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900205 Minor modifications to prologue. (WRB) +C 900402 Added TYPE section. (WRB) +C 910411 Added KEYWORDS section. (WRB) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE J4SAVE + LOGICAL ISET + INTEGER IPARAM(9) + SAVE IPARAM + DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ + DATA IPARAM(5)/1/ + DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ +C***FIRST EXECUTABLE STATEMENT J4SAVE + J4SAVE = IPARAM(IWHICH) + IF (ISET) IPARAM(IWHICH) = IVALUE + RETURN + END +*DECK XERCNT + SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) +C***BEGIN PROLOGUE XERCNT +C***SUBSIDIARY +C***PURPOSE Allow user control over handling of errors. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERCNT-A) +C***KEYWORDS ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C Allows user control over handling of individual errors. +C Just after each message is recorded, but before it is +C processed any further (i.e., before it is printed or +C a decision to abort is made), a call is made to XERCNT. +C If the user has provided his own version of XERCNT, he +C can then override the value of KONTROL used in processing +C this message by redefining its value. +C KONTRL may be set to any value from -2 to 2. +C The meanings for KONTRL are the same as in XSETF, except +C that the value of KONTRL changes only for this message. +C If KONTRL is set to a value outside the range from -2 to 2, +C it will be moved back into that range. +C +C Description of Parameters +C +C --Input-- +C LIBRAR - the library that the routine is in. +C SUBROU - the subroutine that XERMSG is being called from +C MESSG - the first 20 characters of the error message. +C NERR - same as in the call to XERMSG. +C LEVEL - same as in the call to XERMSG. +C KONTRL - the current value of the control flag as set +C by a call to XSETF. +C +C --Output-- +C KONTRL - the new value of KONTRL. If KONTRL is not +C defined, it will remain at its original value. +C This changed value of control affects only +C the current occurrence of the current message. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE +C names, changed routine name from XERCTL to XERCNT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERCNT + CHARACTER*(*) LIBRAR, SUBROU, MESSG +C***FIRST EXECUTABLE STATEMENT XERCNT + RETURN + END +*DECK XERHLT + SUBROUTINE XERHLT (MESSG) +C***BEGIN PROLOGUE XERHLT +C***SUBSIDIARY +C***PURPOSE Abort program execution and print error message. +C***LIBRARY SLATEC (XERROR) +C***CATEGORY R3C +C***TYPE ALL (XERHLT-A) +C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR +C***AUTHOR Jones, R. E., (SNLA) +C***DESCRIPTION +C +C Abstract +C ***Note*** machine dependent routine +C XERHLT aborts the execution of the program. +C The error message causing the abort is given in the calling +C sequence, in case one needs it for printing on a dayfile, +C for example. +C +C Description of Parameters +C MESSG is as in XERMSG. +C +C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC +C Error-handling Package, SAND82-0800, Sandia +C Laboratories, 1982. +C***ROUTINES CALLED (NONE) +C***REVISION HISTORY (YYMMDD) +C 790801 DATE WRITTEN +C 861211 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900206 Routine changed from user-callable to subsidiary. (WRB) +C 900510 Changed calling sequence to delete length of character +C and changed routine name from XERABT to XERHLT. (RWC) +C 920501 Reformatted the REFERENCES section. (WRB) +C***END PROLOGUE XERHLT + CHARACTER*(*) MESSG +C***FIRST EXECUTABLE STATEMENT XERHLT + STOP + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/defplas.f calculix-ccx-2.3/ccx_2.3/src/defplas.f --- calculix-ccx-2.1/ccx_2.3/src/defplas.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/defplas.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,179 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine defplas(elconloc,elas,emec,emec0,ithermal,icmd, + & beta,stre,ckl,vj) +! +! calculates stiffness and stresses for the deformation plasticity +! material law +! +! icmd=3: calcutates stress at mechanical strain +! else: calcutates stress and stiffness matrix at mechanical strain +! + implicit none +! + logical cauchy +! + integer ithermal,icmd,i,j,k,l,m,n,ii,istart,iend,nt,kk(84) +! + real*8 elconloc(*),elas(*),emec(*),emec0(*),beta(*),s(6),al, + & ee,un,s0,xn,stre(*),eq,c0,c1,c2,c3,dkl(3,3),ekl(3,3), + & q,dq,pp,el(6),ckl(3,3),vj +! + data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, + & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, + & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, + & 2,3,2,3/ +! + cauchy=.true. +! + istart=1 + iend=1 +! +! determining linear elastic material constants +! + ee=elconloc(1) + un=elconloc(2) + s0=elconloc(3) + xn=elconloc(4) + al=elconloc(5) +! + do i=1,6 + el(i)=emec(i) + enddo +! +! major loop +! + do ii=istart,iend +! + c0=(el(1)+el(2)+el(3))/3.d0 +! + el(1)=el(1)-c0 + el(2)=el(2)-c0 + el(3)=el(3)-c0 +! +! equivalent deviatoric strain +! + eq=dsqrt(2.d0/3.d0*(el(1)*el(1)+el(2)*el(2)+ + & el(3)*el(3)+2.d0*(el(4)*el(4)+ + & el(5)*el(5)+el(6)*el(6)))) +! +! initial value of the Mises equivalent stress (q) +! + c1=3.d0*ee*eq/(2.d0*(1.d0+un)) +! + if(c1.le.s0) then + q=c1 + else + q=(s0**(xn-1)*ee*eq/al)**(1.d0/xn) + endif +! +! determining the Mises equivalent stress q +! + c1=2.d0*(1.d0+un)/3.d0 + do + c2=al*(q/s0)**(xn-1.d0) + dq=(ee*eq-(c1+c2)*q)/(c1+xn*c2) + if((dabs(dq).lt.q*1.d-4).or.(dabs(dq).lt.1.d-10)) exit + q=q+dq + enddo +! + if(icmd.ne.3) then +! +! calculating the tangent stiffness matrix +! +! initialization of the Delta Dirac function +! + do i=1,3 + do j=1,3 + dkl(i,j)=0.d0 + enddo + enddo + do i=1,3 + dkl(i,i)=1.d0 + enddo +! + ekl(1,1)=el(1) + ekl(2,2)=el(2) + ekl(3,3)=el(3) + ekl(1,2)=el(4) + ekl(1,3)=el(5) + ekl(2,3)=el(6) + ekl(2,1)=ekl(1,2) + ekl(3,1)=ekl(1,3) + ekl(3,2)=ekl(2,3) +! + if(eq.lt.1.d-10) then + c1=ee/(1.d0+un) + c2=0.d0 + else + c1=2.d0/(3.d0*eq) + c2=c1*(1.d0/eq-1.d0/(eq+(xn-1.d0)*c2*q/ee)) + c1=c1*q + endif + c3=(ee/(1.d0-2.d0*un)-c1)/3.d0 +! + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + elas(i)=c1*((dkl(k,m)*dkl(l,n)+dkl(k,n)*dkl(l,m))/2.d0 + & -c2*ekl(k,l)*ekl(m,n)) + & +c3*dkl(k,l)*dkl(m,n) + enddo +! +! conversion of the stiffness matrix from spatial coordinates +! coordinates into material coordinates +! + call stiff2mat(elas,ckl,vj,cauchy) +! + endif +! +! calculating the stress +! + pp=-ee*c0/(1.d0-2.d0*un) +! + if(eq.lt.1.d-10) then + c1=0.d0 + else + c1=2.d0*q/(3.d0*eq) + endif +! + do i=1,6 + s(i)=el(i)*c1 + enddo + do i=1,3 + s(i)=s(i)-pp + enddo +! + do i=1,6 + stre(i)=s(i) + enddo +! +! converting the stress into the material frame of +! reference +! + call str2mat(stre,ckl,vj,cauchy) +! + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/defplasticities.f calculix-ccx-2.3/ccx_2.3/src/defplasticities.f --- calculix-ccx-2.1/ccx_2.3/src/defplasticities.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/defplasticities.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,85 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine defplasticities(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb,iline,ipol, + & inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *DEFORMATION PLASTICITY +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat,ntmat_,istep,istat, + & n,key,i,iperturb(2),iend,ncmat_,irstrt,iline,ipol,inl, + & ipoinp(2,*),inp(3,*),ipoinpc(0:*) +! + real*8 elcon(0:ncmat_,ntmat_,*) +! + ntmat=0 + iperturb(1)=3 + iperturb(2)=1 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in defplasticities: *DEFORMATION PLASTICITY' + write(*,*) ' should be placed before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in defplasticities: *DEFORMATION PLASTICITY' + write(*,*) ' should bepreceded by a *MATERIAL card' + stop + endif +! + do i=2,n + write(*,*) + & '*WARNING in defplasticities: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + enddo +! + nelcon(1,nmat)=-50 +! + iend=5 + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + nelcon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in defplasticities: increase ntmat_' + stop + endif + do i=1,iend + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + read(textpart(6)(1:20),'(f20.0)',iostat=istat) + & elcon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/densities.f calculix-ccx-2.3/ccx_2.3/src/densities.f --- calculix-ccx-2.1/ccx_2.3/src/densities.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/densities.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,77 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine densities(inpc,textpart,rhcon,nrhcon, + & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, + & ipoinpc) +! +! reading the input deck: *DENSITY +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nrhcon(*),nmat,ntmat,ntmat_,istep,istat,n,ipoinpc(0:*), + & key,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),i +! + real*8 rhcon(0:1,ntmat_,*) +! + ntmat=0 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in densities: *DENSITY should be placed' + write(*,*) ' before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in densities: *DENSITY should be preceded' + write(*,*) ' by a *MATERIAL card' + stop + endif +! + do i=2,n + write(*,*) + & '*WARNING in densities: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + enddo +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + nrhcon(nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in densities: increase ntmat_' + stop + endif + read(textpart(1)(1:20),'(f20.0)',iostat=istat) + & rhcon(1,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) + & rhcon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/depvars.f calculix-ccx-2.3/ccx_2.3/src/depvars.f --- calculix-ccx-2.1/ccx_2.3/src/depvars.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/depvars.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,74 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine depvars(inpc,textpart,nelcon,nmat, + & nstate_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, + & ncocon,ipoinpc) +! +! reading the input deck: *DEPVAR +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nelcon(2,*),nmat,istep,nstate_,ncocon(2,*),ipoinpc(0:*), + & n,key,istat,nstate,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),i +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in depvars: *DEPVAR should be placed' + write(*,*) ' before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in depvars: *DEPVAR should be preceded' + write(*,*) ' by a *MATERIAL card' + stop + endif +! + if((nelcon(1,nmat).gt.-100).and.(ncocon(1,nmat).gt.-100)) then + write(*,*) '*ERROR in depvars: *DEPVAR should be preceded' + write(*,*) ' by an *USER MATERIAL card' + stop + endif +! + do i=2,n + write(*,*) + & '*WARNING in depvars: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*) '*ERROR in depvars: incomplete definition' + stop + endif + read(textpart(1)(1:10),'(i10)',iostat=istat) nstate + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + nstate_=max(nstate_,nstate) +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/deuldlag.f calculix-ccx-2.3/ccx_2.3/src/deuldlag.f --- calculix-ccx-2.1/ccx_2.3/src/deuldlag.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/deuldlag.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,162 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine deuldlag(xi,et,ze,xlag,xeul,xj,xs) +! +! calculation of the coefficients of the linearization +! of J:=det(dx/dX)=1 at (xi,et,ze) for a 20-node quadratic +! isoparametric brick element, -1<=xi,et,ze<=1 +! xlag are Lagrangian coordinates, xeul are Eulerian coordinates +! + implicit none +! + integer i,j,k +! + real*8 xs(3,3),xlag(3,20),shpe(4,20),dd1,dd2,dd3,xeul(3,20) +! + real*8 xi,et,ze,xj,omg,omh,omr,opg,oph,opr, + & tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr, + & omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr +! +! shape functions and their glocal derivatives +! + omg=1.d0-xi + omh=1.d0-et + omr=1.d0-ze + opg=1.d0+xi + oph=1.d0+et + opr=1.d0+ze + tpgphpr=opg+oph+ze + tmgphpr=omg+oph+ze + tmgmhpr=omg+omh+ze + tpgmhpr=opg+omh+ze + tpgphmr=opg+oph-ze + tmgphmr=omg+oph-ze + tmgmhmr=omg+omh-ze + tpgmhmr=opg+omh-ze + omgopg=omg*opg/4.d0 + omhoph=omh*oph/4.d0 + omropr=omr*opr/4.d0 + omgmopg=(omg-opg)/4.d0 + omhmoph=(omh-oph)/4.d0 + omrmopr=(omr-opr)/4.d0 +! +! local derivatives of the shape functions: xi-derivative +! + shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0 + shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0 + shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0 + shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0 + shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0 + shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0 + shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0 + shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0 + shpe(1, 9)=omgmopg*omh*omr + shpe(1,10)=omhoph*omr + shpe(1,11)=omgmopg*oph*omr + shpe(1,12)=-omhoph*omr + shpe(1,13)=omgmopg*omh*opr + shpe(1,14)=omhoph*opr + shpe(1,15)=omgmopg*oph*opr + shpe(1,16)=-omhoph*opr + shpe(1,17)=-omropr*omh + shpe(1,18)=omropr*omh + shpe(1,19)=omropr*oph + shpe(1,20)=-omropr*oph +! +! local derivatives of the shape functions: eta-derivative +! + shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0 + shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0 + shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0 + shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0 + shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0 + shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0 + shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0 + shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0 + shpe(2, 9)=-omgopg*omr + shpe(2,10)=omhmoph*opg*omr + shpe(2,11)=omgopg*omr + shpe(2,12)=omhmoph*omg*omr + shpe(2,13)=-omgopg*opr + shpe(2,14)=omhmoph*opg*opr + shpe(2,15)=omgopg*opr + shpe(2,16)=omhmoph*omg*opr + shpe(2,17)=-omropr*omg + shpe(2,18)=-omropr*opg + shpe(2,19)=omropr*opg + shpe(2,20)=omropr*omg +! +! local derivatives of the shape functions: zeta-derivative +! + shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0 + shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0 + shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0 + shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0 + shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0 + shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0 + shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0 + shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0 + shpe(3, 9)=-omgopg*omh + shpe(3,10)=-omhoph*opg + shpe(3,11)=-omgopg*oph + shpe(3,12)=-omhoph*omg + shpe(3,13)=omgopg*omh + shpe(3,14)=omhoph*opg + shpe(3,15)=omgopg*oph + shpe(3,16)=omhoph*omg + shpe(3,17)=omrmopr*omg*omh + shpe(3,18)=omrmopr*opg*omh + shpe(3,19)=omrmopr*opg*oph + shpe(3,20)=omrmopr*omg*oph +! +! computation of the derivative of the global +! material coordinates w.r.t. the local coordinates +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,20 + xs(i,j)=xs(i,j)+xlag(i,k)*shpe(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant of the local +! coordinates w.r.t. the global material coordinates +! + dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2) + dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3) + dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1) + xj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3 + xj=1.d0/xj +! +! computation of the derivative of the global +! spatial coordinates w.r.t. the local coordinates +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,20 + xs(i,j)=xs(i,j)+xeul(i,k)*shpe(j,k) + enddo + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/dfdbj.c calculix-ccx-2.3/ccx_2.3/src/dfdbj.c --- calculix-ccx-2.1/ccx_2.3/src/dfdbj.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dfdbj.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,457 @@ +/* + CalculiX - A 3-dimensional finite element program + Copyright (C) 1998-2007 Guido Dhondt + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation(version 2); + + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +*/ + +#include +#include +#include +#include +#include "CalculiX.h" + +void dfdbj(double *bcont,double **dbcontp,int *neq,int *nope,int *konl, + int* nactdof,double *s,double *z,int *ikmpc,int *ilmpc, + int *ipompc,int *nodempc,int *nmpc,double *coefmpc, + double *fnl,int *nev,int **ikactcontp,int **ilactcontp, + int *nactcont,int *nactcont_,int *mi, int *cyclicsymmetry, + int *izdof, int *nzdof){ + + int j,j1,jdof,kdof,k,k1,l,id,index,ist,id1,ist1,index1,id2,ist2,index2, + jdbcontcol,i1,i3,i4,mt=mi[1]+1,im,*ikactcont=*ikactcontp, + *ilactcont=*ilactcontp,kdofm1; + + double d1,sl,*dbcont=*dbcontp; + + for(j=0; j<*nope; j++){ + i1=mt*(konl[j]-1)+1; + for(j1=0; j1<3; j1++){ + jdof=nactdof[i1+j1]; + if(jdof!=0){ + jdof--; + FORTRAN(nident,(ikactcont,&jdof,nactcont,&id)); + do{ + if(id>0){ + if(ikactcont[id-1]==jdof){ + jdbcontcol=ilactcont[id-1]; + break; + } + } + (*nactcont)++; + if(*nactcont>*nactcont_){ + *nactcont_=(int)(1.1**nactcont_); + RENEW(ikactcont,int,*nactcont_); + RENEW(ilactcont,int,*nactcont_); + RENEW(dbcont,double,*nev**nactcont_); + } + k=*nactcont-1; + l=k-1; + while(k>id){ + ikactcont[k]=ikactcont[l]; + ilactcont[k--]=ilactcont[l--]; + } + jdbcontcol=*nactcont; + ikactcont[id]=jdof; + ilactcont[id]=*nactcont; +// memset(&dbcont[(*nactcont-1)**nev],0,sizeof(double)**nev); + DMEMSET(dbcont,(*nactcont-1)**nev,*nactcont**nev,0.); + break; + }while(1); + bcont[jdof]-=fnl[j*3+j1]; + i4=(jdbcontcol-1)**nev; + i3=(3*j+j1); + for(k=0; k<*nope; k++){ + for(k1=0; k1<3; k1++){ + sl=s[(3*k+k1)*60+i3]; + kdof=nactdof[mt*(konl[k]-1)+k1+1]; + if(kdof!=0){ + if(!(*cyclicsymmetry)){ + for(l=0; l<*nev; l++){ + dbcont[i4+l]-=sl*z[(long long)l**neq+kdof-1]; + } + }else{ + kdofm1=kdof-1; + FORTRAN(nident,(izdof,&kdofm1,nzdof,&id)); + if(id!=0){ + if(izdof[id-1]==kdofm1){ + for(l=0; l<*nev; l++){ + dbcont[i4+l]-=sl*z[l**nzdof+id-1]; + } + }else{printf("*ERROR in dfdbj\n");FORTRAN(stop,());} + }else{printf("*ERROR in dfdbj\n");FORTRAN(stop,());} + } + } + else{ + kdof=8*(konl[k]-1)+k1+1; + FORTRAN(nident,(ikmpc,&kdof,nmpc,&id)); + if(id>0){ + id--; + if(ikmpc[id]==kdof){ + id=ilmpc[id]; + ist=ipompc[id-1]; + ist--; + index=nodempc[ist*3+2]; + if(index==0) continue; + index--; + do{ + kdof=nactdof[mt*(nodempc[index*3]-1)+nodempc[index*3+1]]; + d1=sl*coefmpc[index]/coefmpc[ist]; + if(kdof!=0){ + if(!(*cyclicsymmetry)){ + for(l=0; l<*nev; l++){ + dbcont[i4+l]+=d1*z[(long long)l**neq+kdof-1]; + } + } + }else{ + kdofm1=kdof-1; + FORTRAN(nident,(izdof,&kdofm1,nzdof,&id)); + if(id!=0){ + if(izdof[id-1]==kdofm1){ + for(l=0; l<*nev; l++){ + dbcont[i4+l]+=d1*z[l**nzdof+id-1]; + } + }else{printf("*ERROR in dfdbj\n");FORTRAN(stop,());} + }else{printf("*ERROR in dfdbj\n");FORTRAN(stop,());} + } + index=nodempc[index*3+2]; + if(index==0) break; + index--; + }while(1); + } + } + } + } + } + } + else{ + jdof=8*(konl[j]-1)+j1+1; + FORTRAN(nident,(ikmpc,&jdof,nmpc,&id1)); + if(id1>0){ + id1--; + if(ikmpc[id1]==jdof){ + id1=ilmpc[id1]; + ist1=ipompc[id1-1]; + ist1--; + index1=nodempc[ist1*3+2]; + if(index1==0) continue; + index1--; + do{ + jdof=nactdof[mt*(nodempc[index1*3]-1)+nodempc[index1*3+1]]; + if(jdof!=0){ + jdof--; + FORTRAN(nident,(ikactcont,&jdof,nactcont,&id)); + do{ + if(id>0){ + if(ikactcont[id-1]==jdof){ + jdbcontcol=ilactcont[id-1]; + } + } + (*nactcont)++; + if(*nactcont>*nactcont_){ + *nactcont_=(int)(1.1**nactcont_); + RENEW(ikactcont,int,*nactcont_); + RENEW(ilactcont,int,*nactcont_); + RENEW(dbcont,double,*nev**nactcont_); + } + k=*nactcont-1; + l=k-1; + do{ + ikactcont[k]=ikactcont[l]; + ilactcont[k--]=ilactcont[l--]; + }while(k>id); + jdbcontcol=*nactcont; + ikactcont[id]=jdof; + ilactcont[id]=*nactcont; +// memset(&dbcont[(*nactcont-1)**nev],0,sizeof(double)**nev); + DMEMSET(dbcont,(*nactcont-1)**nev,*nactcont**nev,0.); + break; + }while(1); + bcont[jdof]+=coefmpc[index1]*fnl[j*3+j1]/coefmpc[ist1]; + i4=(jdbcontcol-1)**nev; + i3=(3*j+j1); + for(k=0; k<*nope; k++){ + for(k1=0; k1<3; k1++){ + sl=s[(3*k+k1)*60+i3]; + kdof=nactdof[mt*(konl[k]-1)+k1+1]; + if(kdof!=0){ + d1=sl*coefmpc[index1]/coefmpc[ist1]; + if(!(*cyclicsymmetry)){ + for(l=0; l<*nev; l++){ + dbcont[i4+l]+=d1*z[(long long)l**neq+kdof-1]; + } + }else{ + kdofm1=kdof-1; + FORTRAN(nident,(izdof,&kdofm1,nzdof,&id)); + if(id!=0){ + if(izdof[id-1]==kdofm1){ + for(l=0; l<*nev; l++){ + dbcont[i4+l]+=d1*z[l**nzdof+id-1]; + } + }else{printf("*ERROR in dfdbj\n");FORTRAN(stop,());} + }else{printf("*ERROR in dfdbj\n");FORTRAN(stop,());} + } + } + else{ + kdof=8*(konl[k]-1)+k1+1; + FORTRAN(nident,(ikmpc,&kdof,nmpc,&id2)); + if(id2>0){ + id2--; + if(ikmpc[id2]==kdof){ + id2=ilmpc[id2]; + ist2=ipompc[id2-1]; + ist2--; + index2=nodempc[ist2*3+2]; + if(index2==0) continue; + index2--; + do{ + kdof=nactdof[mt*(nodempc[index2*3]-1)+nodempc[index2*3+1]]; + if(kdof!=0){ + d1=sl*coefmpc[index1]*coefmpc[index2]/(coefmpc[ist1]*coefmpc[ist2]); + if(!(*cyclicsymmetry)){ + for(l=0; l<*nev; l++){ + dbcont[i4+l]-=d1*z[(long long)l**neq+kdof-1]; + } + }else{ + kdofm1=kdof-1; + FORTRAN(nident,(izdof,&kdofm1,nzdof,&id)); + if(id!=0){ + if(izdof[id-1]==kdofm1){ + for(l=0; l<*nev; l++){ + dbcont[i4+l]-=d1*z[l**nzdof+id-1]; + } + }else{printf("*ERROR in dfdbj\n");FORTRAN(stop,());} + }else{printf("*ERROR in dfdbj\n");FORTRAN(stop,());} + } + } + index2=nodempc[index2*3+2]; + if(index2==0) break; + index2--; + }while(1); + } + } + } + } + } + } + index1=nodempc[index1*3+2]; + if(index1==0) break; + index1--; + }while(1); + } + } + } + } + } + *dbcontp=dbcont; + *ikactcontp=ikactcont; + *ilactcontp=ilactcont; +} + +/*! + ! CalculiX - A 3-dimensional finite element program + ! Copyright (C) 1998-2007 Guido Dhondt + ! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dfdbj(bcont,dbcont,neq,nope,konl,nactdof,s,z, + & ikmpc,ilmpc,ipompc,nodempc,nmpc,coefmpc,fnl,nev,iactcont, + & nactcont) +! +! calculates the derivative of the contact forces with respect +! to the modal variables +! + implicit none +! + integer j,j1,neq,nope,konl(*),nactdof(0:3,*),jdof,kdof, + & k,k1,l,id,ikmpc(*),ilmpc(*),ipompc(*),nodempc(3,*),nmpc, + & index,ist,id1,ist1,index1,id2,ist2,index2,nev ,iactcont(*), + & nactcont,jdofcont +! + real*8 bcont(*),dbcont(nev,*),s(60,60),z(neq,*),coefmpc(*), + & fnl(3,9) +! + do j=1,nope + do j1=1,3 + jdof=nactdof(j1,konl(j)) + if(jdof.ne.0) then + call nident(iactcont,jdof,nactcont,id) + jdofcont=0 + if(id.gt.0)then + if(iactcont(id).eq.jdof) then + jdofcont=id + endif + endif + if(jdofcont.eq.0) then + nactcont=nactcont+1 + do k=nactcont,id+2,-1 + iactcont(k)=iactcont(k-1) + do l=1,nev + dbcont(l,k)=dbcont(l,k-1) + enddo + enddo + jdofcont=id+1 + iactcont(jdofcont)=jdof + do l=1,nev + dbcont(l,jdofcont)=0.d0 + enddo + endif + bcont(jdof)=bcont(jdof)-fnl(j1,j) + do k=1,nope + do k1=1,3 + kdof=nactdof(k1,konl(k)) + if(kdof.ne.0) then + do l=1,nev + dbcont(l,jdofcont)=dbcont(l,jdofcont)- + & s(3*(j-1)+j1,3*(k-1)+k1)*z(kdof,l) + enddo + else + kdof=8*(konl(k)-1)+k1 + call nident(ikmpc,kdof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.kdof) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + kdof=nactdof(nodempc(2,index), + & nodempc(1,index)) + if(kdof.ne.0) then + do l=1,nev + dbcont(l,jdofcont)= + & dbcont(l,jdofcont)+ + & s(3*(j-1)+j1,3*(k-1)+k1)* + & coefmpc(index)*z(kdof,l)/ + & coefmpc(ist) + enddo + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + endif + enddo + enddo + else + jdof=8*(konl(j)-1)+j1 + call nident(ikmpc,jdof,nmpc,id1) + if(id1.gt.0) then + if(ikmpc(id1).eq.jdof) then + id1=ilmpc(id1) + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + jdof=nactdof(nodempc(2,index1), + & nodempc(1,index1)) + if(jdof.ne.0) then + call nident(iactcont,jdof,nactcont,id) + jdofcont=0 + if(id.gt.0)then + if(iactcont(id).eq.jdof) then + jdofcont=id + endif + endif + if(jdofcont.eq.0) then + nactcont=nactcont+1 + do k=nactcont,id+2,-1 + iactcont(k)=iactcont(k-1) + do l=1,nev + dbcont(l,k)=dbcont(l,k-1) + enddo + enddo + jdofcont=id+1 + iactcont(jdofcont)=jdof + do l=1,nev + dbcont(l,jdofcont)=0.d0 + enddo + endif + bcont(jdofcont)=bcont(jdofcont)+ + & coefmpc(index1)* + & fnl(j1,j)/coefmpc(ist1) + do k=1,nope + do k1=1,3 + kdof=nactdof(k1,konl(k)) + if(kdof.ne.0) then + do l=1,nev + dbcont(l,jdofcont)= + & dbcont(l,jdofcont) + & +s(3*(j-1)+j1,3*(k-1)+k1) + & *coefmpc(index1)*z(kdof,l)/ + & coefmpc(ist1) + enddo + else + kdof=8*(konl(k)-1)+k1 + call nident(ikmpc,kdof,nmpc,id2) + if(id2.gt.0) then + if(ikmpc(id2).eq.kdof) then + id2=ilmpc(id2) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) cycle + do +! +! translated to the left to avoid exceedance +! of 72 columns +! + kdof=nactdof(nodempc(2,index2), + & nodempc(1,index2)) + if(kdof.ne.0) then + do l=1,nev + dbcont(l,jdofcont)=dbcont(l,jdofcont) + & -s(3*(j-1)+j1,3*(k-1)+k1) + & *coefmpc(index1) + & *coefmpc(index2)*z(kdof,l)/ + & (coefmpc(ist1)*coefmpc(ist2)) + enddo + endif + index2=nodempc(3,index2) + if(index2.eq.0) exit +! +! end of translation +! + enddo + endif + endif + endif + enddo + enddo + endif + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo + enddo +! + return + end + */ diff -Nru calculix-ccx-2.1/ccx_2.3/src/dfluxes.f calculix-ccx-2.3/ccx_2.3/src/dfluxes.f --- calculix-ccx-2.1/ccx_2.3/src/dfluxes.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dfluxes.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,247 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dfluxes(inpc,textpart,set,istartset,iendset, + & ialset,nset,nelemload,sideload,xload,nload,nload_, + & ielmat,ntmat_,iamload, + & amname,nam,lakon,ne,dflux_flag,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,nam_,namtot_,namta,amta,ipoinpc) +! +! reading the input deck: *DFLUX +! + implicit none +! + logical dflux_flag +! + character*1 inpc(*) + character*8 lakon(*) + character*20 sideload(*),label + character*80 amname(*),amplitude + character*81 set(*),elset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),nelemload(2,*), + & ielmat(*),nset,nload,nload_,ntmat_,istep,istat,n,i,j,l,key, + & iamload(2,*),nam,iamplitude,ipos,ne,iline,ipol,inl,ipoinp(2,*), + & inp(3,*),nam_,namtot,namtot_,namta(3,*),idelay,isector, + & ipoinpc(0:*) +! + real*8 xload(2,*),xmagnitude,amta(2,*) +! + iamplitude=0 + idelay=0 + isector=0 +! + if(istep.lt.1) then + write(*,*) '*ERROR in dfluxes: *DFLUX should only be used' + write(*,*) ' within a STEP' + stop + endif +! + do i=2,n + if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.dflux_flag)) then + do j=1,nload + if((sideload(j)(1:1).eq.'S').or. + & (sideload(j)(1:2).eq.'BF')) then + xload(1,j)=0.d0 + endif + enddo + elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then + read(textpart(i)(11:90),'(a80)') amplitude + do j=nam,1,-1 + if(amname(j).eq.amplitude) then + iamplitude=j + exit + endif + enddo + if(j.eq.0) then + write(*,*)'*ERROR in dfluxes: nonexistent amplitude' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iamplitude=j + elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN + if(idelay.ne.0) then + write(*,*) '*ERROR in dfluxes: the parameter TIME DELAY' + write(*,*) ' is used twice in the same keyword' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + else + idelay=1 + endif + nam=nam+1 + if(nam.gt.nam_) then + write(*,*) '*ERROR in dfluxes: increase nam_' + stop + endif + amname(nam)=' + & ' + if(iamplitude.eq.0) then + write(*,*) '*ERROR in dfluxes: time delay must be' + write(*,*) ' preceded by the amplitude parameter' + stop + endif + namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) + iamplitude=nam + if(nam.eq.1) then + namtot=0 + else + namtot=namta(2,nam-1) + endif + namtot=namtot+1 + if(namtot.gt.namtot_) then + write(*,*) '*ERROR dfluxes: increase namtot_' + stop + endif + namta(1,nam)=namtot + namta(2,nam)=namtot + read(textpart(i)(11:30),'(f20.0)',iostat=istat) + & amta(1,namtot) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + write(*,*) + & '*WARNING in dfluxes: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return +! + read(textpart(2)(1:20),'(a20)',iostat=istat) label +! +! compatibility with ABAQUS for shells +! + if(label(2:4).eq.'NEG') label(2:4)='1 ' + if(label(2:4).eq.'POS') label(2:4)='2 ' + if(label(2:2).eq.'N') label(2:2)='5' + if(label(2:2).eq.'P') label(2:2)='6' +! + read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagnitude +! + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(((label(1:2).ne.'S1').and.(label(1:2).ne.'S2').and. + & (label(1:2).ne.'S3').and.(label(1:2).ne.'S4').and. + & (label(1:2).ne.'S5').and.(label(1:2).ne.'S6').and. + & (label(1:2).ne.'BF').and.(label(1:2).ne.'S ')).or. + & ((label(3:4).ne.' ').and.(label(3:4).ne.'NU'))) then + call inputerror(inpc,ipoinpc,iline) + endif +! + read(textpart(1)(1:10),'(i10)',iostat=istat) l + if(istat.eq.0) then + if(l.gt.ne) then + write(*,*) '*ERROR in dfluxes: element ',l + write(*,*) ' is not defined' + stop + endif +! + if((lakon(l)(1:2).eq.'CP').or. + & (lakon(l)(2:2).eq.'A').or. + & (lakon(l)(7:7).eq.'E').or. + & (lakon(l)(7:7).eq.'S').or. + & (lakon(l)(7:7).eq.'A')) then + if(label(1:2).eq.'S1') then + label(1:2)='S3' + elseif(label(1:2).eq.'S2') then + label(1:2)='S4' + elseif(label(1:2).eq.'S3') then + label(1:2)='S5' + elseif(label(1:2).eq.'S4') then + label(1:2)='S6' + elseif(label(1:2).eq.'S5') then + label(1:2)='S1' + elseif(label(1:2).eq.'S6') then + label(1:2)='S2' + endif + elseif((lakon(l)(1:1).eq.'B').or. + & (lakon(l)(7:7).eq.'B')) then + elseif((lakon(l)(1:1).eq.'S').or. + & (lakon(l)(7:7).eq.'L')) then + endif + call loadadd(l,label,xmagnitude,nelemload,sideload, + & xload,nload,nload_,iamload,iamplitude, + & nam,isector) + else + read(textpart(1)(1:80),'(a80)',iostat=istat) elset + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + do i=1,nset + if(set(i).eq.elset) exit + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR in dfluxes: element set ',elset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! + l=ialset(istartset(i)) + if((lakon(l)(1:2).eq.'CP').or. + & (lakon(l)(2:2).eq.'A').or. + & (lakon(l)(7:7).eq.'E').or. + & (lakon(l)(7:7).eq.'S').or. + & (lakon(l)(7:7).eq.'A')) then + if(label(1:2).eq.'S1') then + label(1:2)='S3' + elseif(label(1:2).eq.'S2') then + label(1:2)='S4' + elseif(label(1:2).eq.'S3') then + label(1:2)='S5' + elseif(label(1:2).eq.'S4') then + label(1:2)='S6' + endif + elseif((lakon(l)(1:1).eq.'B').or. + & (lakon(l)(7:7).eq.'B')) then + if(label(1:2).eq.'S2') label(1:2)='S5' + elseif((lakon(l)(1:1).eq.'S').or. + & (lakon(l)(7:7).eq.'L')) then + label(1:2)='S1' + endif +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + l=ialset(j) + call loadadd(l,label,xmagnitude,nelemload,sideload, + & xload,nload,nload_,iamload,iamplitude, + & nam,isector) + else + l=ialset(j-2) + do + l=l-ialset(j) + if(l.ge.ialset(j-1)) exit + call loadadd(l,label,xmagnitude,nelemload, + & sideload,xload,nload,nload_, + & iamload,iamplitude,nam,isector) + enddo + endif + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dflux.f calculix-ccx-2.3/ccx_2.3/src/dflux.f --- calculix-ccx-2.1/ccx_2.3/src/dflux.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dflux.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,361 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dflux(flux,sol,kstep,kinc,time,noel,npt,coords, + & jltyp,temp,press,loadtype,area,vold,co,lakonl,konl, + & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,iscale,mi) +! +! user subroutine dflux +! +! +! INPUT: +! +! sol current temperature value +! kstep step number +! kinc increment number +! time(1) current step time +! time(2) current total time +! noel element number +! npt integration point number +! coords(1..3) global coordinates of the integration point +! jltyp loading face kode: +! 1 = body flux +! 11 = face 1 +! 12 = face 2 +! 13 = face 3 +! 14 = face 4 +! 15 = face 5 +! 16 = face 6 +! temp currently not used +! press currently not used +! loadtype load type label +! area for surface flux: area covered by the +! integration point +! for body flux: volume covered by the +! integration point +! vold(0..4,1..nk) solution field in all nodes +! 0: temperature +! 1: displacement in global x-direction +! 2: displacement in global y-direction +! 3: displacement in global z-direction +! 4: static pressure +! co(3,1..nk) coordinates of all nodes +! 1: coordinate in global x-direction +! 2: coordinate in global y-direction +! 3: coordinate in global z-direction +! lakonl element label +! konl(1..20) nodes belonging to the element +! ipompc(1..nmpc)) ipompc(i) points to the first term of +! MPC i in field nodempc +! nodempc(1,*) node number of a MPC term +! nodempc(2,*) coordinate direction of a MPC term +! nodempc(3,*) if not 0: points towards the next term +! of the MPC in field nodempc +! if 0: MPC definition is finished +! coefmpc(*) coefficient of a MPC term +! nmpc number of MPC's +! ikmpc(1..nmpc) ordered global degrees of freedom of the MPC's +! the global degree of freedom is +! 8*(node-1)+direction of the dependent term of +! the MPC (direction = 0: temperature; +! 1-3: displacements; 4: static pressure; +! 5-7: rotations) +! ilmpc(1..nmpc) ilmpc(i) is the MPC number corresponding +! to the reference number in ikmpc(i) +! mi(1) max # of integration points per element (max +! over all elements) +! mi(2) max degree of freedomm per node (max over all +! nodes) in fields like v(0:mi(2))... +! +! OUTPUT: +! +! flux(1) magnitude of the flux +! flux(2) not used; please do NOT assign any value +! iscale determines whether the flux has to be +! scaled for increments smaller than the +! step time in static calculations +! 0: no scaling +! 1: scaling (default) +! + implicit none +! + character*8 lakonl + character*20 loadtype +! + integer kstep,kinc,noel,npt,jltyp,konl(20),ipompc(*), + & nodempc(3,*),nmpc,ikmpc(*),ilmpc(*),node,idof,id,iscale,mi(2) +! + real*8 flux(2),time(2),coords(3),sol,temp,press,vold(0:mi(2),*), + & area,co(3,*),coefmpc(*) +! +! the code starting here up to the end of the file serves as +! an example for combined mechanical-lubrication problems. +! Please replace it by your own code for your concrete application. +! + include "gauss.f" +! + integer ifaceq(8,6),ifacet(6,4),ifacew(8,5),ig,nelem,nopes, + & iflag,i,j,k,nope +! + real*8 xl21(3,8),xi,et,al,rho,um,h,pnode1(3),pnode2(3), + & ratio(8),dist,xl22(3,8),dpnode1(3,3),dpnode2(3,3),v1(3), + & v2(3),dh(3),xsj2(3),xs2(3,7),shp2(7,8) +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ + data iflag /3/ +! + nelem=noel +! + if(lakonl(4:4).eq.'2') then + nope=20 + nopes=8 + elseif(lakonl(4:4).eq.'8') then + nope=8 + nopes=4 + elseif(lakonl(4:5).eq.'10') then + nope=10 + nopes=6 + elseif(lakonl(4:4).eq.'4') then + nope=4 + nopes=3 + elseif(lakonl(4:5).eq.'15') then + nope=15 + elseif(lakonl(4:4).eq.'6') then + nope=6 + endif +! +! treatment of wedge faces +! + if(lakonl(4:4).eq.'6') then + if(ig.le.2) then + nopes=3 + else + nopes=4 + endif + endif + if(lakonl(4:5).eq.'15') then + if(ig.le.2) then + nopes=6 + else + nopes=8 + endif + endif +! +! first side of the oil film +! + ig=1 +! + if((nope.eq.20).or.(nope.eq.8)) then + do i=1,nopes + node=konl(ifaceq(i,ig)) + idof=8*(node-1)+4 + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in dflux: node ',node + write(*,*) ' is not connected to the structure' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + do j=1,3 + xl21(j,i)=co(j,node)+ + & vold(j,node) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + write(*,*) '*ERROR in dload: tetrahedral elements' + write(*,*) ' are not allowed' + stop + else + do i=1,nopes + node=konl(ifacew(i,ig)) + idof=8*(node-1)+4 + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in dflux: node ',node + write(*,*) ' is not connected to the structure' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + do j=1,3 + xl21(j,i)=co(j,node)+ + & vold(j,node) + enddo + enddo + endif +! +! projecting the integration point on the first side of the +! oil film +! + do j=1,3 + pnode1(j)=coords(j) + enddo +! + call attach(xl21,pnode1,nopes,ratio,dist,xi,et) +! +! derivative of the shape functions in (xi,et) +! + if(nopes.eq.8) then + call shape8q(xi,et,xl21,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl21,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl21,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl21,xsj2,xs2,shp2,iflag) + endif +! +! the gradient of pnode1 +! dpnode1(j,k)=dpnode1(j)/dx(k) +! + do i=1,3 + do j=1,3 + dpnode1(i,j)=0.d0 + do k=1,nopes + dpnode1(i,j)=dpnode1(i,j)+shp2(j,k)*xl21(i,k) + enddo + enddo + enddo +! +! second side of the oil film +! + ig=2 +! + if((nope.eq.20).or.(nope.eq.8)) then + do i=1,nopes + node=konl(ifaceq(i,ig)) + idof=8*(node-1)+4 + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in dflux: node ',node + write(*,*) ' is not connected to the structure' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + do j=1,3 + xl22(j,i)=co(j,node)+ + & vold(j,node) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + write(*,*) '*ERROR in dload: tetrahedral elements' + write(*,*) ' are not allowed' + stop + else + do i=1,nopes + node=konl(ifacew(i,ig)) + idof=8*(node-1)+4 + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in dflux: node ',node + write(*,*) ' is not connected to the structure' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + do j=1,3 + xl22(j,i)=co(j,node)+ + & vold(j,node) + enddo + enddo + endif +! +! projecting the integration point on the second side of the +! oil film +! + do j=1,3 + pnode2(j)=coords(j) + enddo +! + call attach(xl22,pnode2,nopes,ratio,dist,xi,et) +! +! derivative of the shape functions in (xi,et) +! + if(nopes.eq.8) then + call shape8q(xi,et,xl22,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl22,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl22,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl22,xsj2,xs2,shp2,iflag) + endif +! +! the gradient of pnode1 +! dpnode2(j,k)=dpnode2(j)/dx(k) +! + do i=1,3 + do j=1,3 + dpnode2(i,j)=0.d0 + do k=1,nopes + dpnode2(i,j)=dpnode2(i,j)+shp2(j,k)*xl22(i,k) + enddo + enddo + enddo +! +! calculating the thickness of the oil film +! + h=dsqrt((pnode1(1)-pnode2(1))**2+ + & (pnode1(2)-pnode2(2))**2+ + & (pnode1(3)-pnode2(3))**2) +! +! calculating the gradient of the oil film thickness +! + do i=1,3 + dh(i)=((pnode1(1)-pnode2(1))*(dpnode1(1,i)-dpnode2(1,i)) + & +(pnode1(2)-pnode2(2))*(dpnode1(2,i)-dpnode2(2,i)) + & +(pnode1(3)-pnode2(3))*(dpnode1(3,i)-dpnode2(3,i)))/h + enddo +! +! velocity of the parts adjoining the film +! the axis or rotation is assumed to be the x-axis +! + do i=1,3 + v1(i)=0.d0 + enddo + v2(1)=0.d0 + v2(2)=-26000.d0*coords(3)/dsqrt(coords(2)**2+coords(3)**2) + v2(3)=26000.d0*coords(2)/dsqrt(coords(2)**2+coords(3)**2) +! +! density (oil, N-mm-s-K system) +! + rho=890.d-9 +! +! body flux +! + flux(1)=-rho*((v1(1)+v2(1))*dh(1)+ + & (v1(2)+v2(2))*dh(2)+ + & (v1(3)+v2(3))*dh(3))/2.d0 +! + iscale=0 +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dgesv.f calculix-ccx-2.3/ccx_2.3/src/dgesv.f --- calculix-ccx-2.1/ccx_2.3/src/dgesv.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dgesv.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,2429 @@ +! +! subroutines to solve a set of linear equations with +! a general real matrix +! +! + SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK driver routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* March 31, 1993 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DGESV computes the solution to a real system of linear equations +* A * X = B, +* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. +* +* The LU decomposition with partial pivoting and row interchanges is +* used to factor A as +* A = P * L * U, +* where P is a permutation matrix, L is unit lower triangular, and U is +* upper triangular. The factored form of A is then used to solve the +* system of equations A * X = B. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of linear equations, i.e., the order of the +* matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the N-by-N coefficient matrix A. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* IPIV (output) INTEGER array, dimension (N) +* The pivot indices that define the permutation matrix P; +* row i of the matrix was interchanged with row IPIV(i). +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the N-by-NRHS matrix of right hand side matrix B. +* On exit, if INFO = 0, the N-by-NRHS solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, U(i,i) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, so the solution could not be computed. +* +* ===================================================================== +* +* .. External Subroutines .. + EXTERNAL DGETRF, DGETRS, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESV ', -INFO ) + RETURN + END IF +* +* Compute the LU factorization of A. +* + CALL DGETRF( N, N, A, LDA, IPIV, INFO ) + IF( INFO.EQ.0 ) THEN +* +* Solve the system A*X = B, overwriting B with X. +* + CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) + END IF + RETURN +* +* End of DGESV +* + END + SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1992 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETF2 computes an LU factorization of a general m-by-n matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 2 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the m by n matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -k, the k-th argument had an illegal value +* > 0: if INFO = k, U(k,k) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER J, JP +* .. +* .. External Functions .. + INTEGER IDAMAX + EXTERNAL IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DGER, DSCAL, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* + DO 10 J = 1, MIN( M, N ) +* +* Find pivot and test for singularity. +* + JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* Apply the interchange to columns 1:N. +* + IF( JP.NE.J ) + $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* Compute elements J+1:M of J-th column. +* + IF( J.LT.M ) + $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* Update trailing submatrix. +* + CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, + $ A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* End of DGETF2 +* + END + SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* March 31, 1993 +* +* .. Scalar Arguments .. + INTEGER INFO, LDA, M, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DGETRF computes an LU factorization of a general M-by-N matrix A +* using partial pivoting with row interchanges. +* +* The factorization has the form +* A = P * L * U +* where P is a permutation matrix, L is lower triangular with unit +* diagonal elements (lower trapezoidal if m > n), and U is upper +* triangular (upper trapezoidal if m < n). +* +* This is the right-looking Level 3 BLAS version of the algorithm. +* +* Arguments +* ========= +* +* M (input) INTEGER +* The number of rows of the matrix A. M >= 0. +* +* N (input) INTEGER +* The number of columns of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the M-by-N matrix to be factored. +* On exit, the factors L and U from the factorization +* A = P*L*U; the unit diagonal elements of L are not stored. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,M). +* +* IPIV (output) INTEGER array, dimension (min(M,N)) +* The pivot indices; for 1 <= i <= min(M,N), row i of the +* matrix was interchanged with row IPIV(i). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, U(i,i) is exactly zero. The factorization +* has been completed, but the factor U is exactly +* singular, and division by zero will occur if it is used +* to solve a system of equations. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRF', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* Use unblocked code. +* + CALL DGETF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* Use blocked code. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* Factor diagonal and subdiagonal blocks and test for exact +* singularity. +* + CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* Adjust INFO and the pivot indices. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* Apply interchanges to columns 1:J-1. +* + CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* Apply interchanges to columns J+JB:N. +* + CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* Compute block row of U. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* Update trailing submatrix. +* + CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* End of DGETRF +* + END + SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* March 31, 1993 +* +* .. Scalar Arguments .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DGETRS solves a system of linear equations +* A * X = B or A' * X = B +* with a general N-by-N matrix A using the LU factorization computed +* by DGETRF. +* +* Arguments +* ========= +* +* TRANS (input) CHARACTER*1 +* Specifies the form of the system of equations: +* = 'N': A * X = B (No transpose) +* = 'T': A'* X = B (Transpose) +* = 'C': A'* X = B (Conjugate transpose = Transpose) +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The factors L and U from the factorization A = P*L*U +* as computed by DGETRF. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* IPIV (input) INTEGER array, dimension (N) +* The pivot indices from DGETRF; for 1<=i<=N, row i of the +* matrix was interchanged with row IPIV(i). +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL NOTRAN +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DLASWP, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRS', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* Solve A * X = B. +* +* Apply row interchanges to the right hand sides. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* Solve L*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A' * X = B. +* +* Solve U'*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve L'*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* Apply row interchanges to the solution vectors. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* End of DGETRS +* + END + SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1999 +* +* .. Scalar Arguments .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DLASWP performs a series of row interchanges on the matrix A. +* One row interchange is initiated for each of rows K1 through K2 of A. +* +* Arguments +* ========= +* +* N (input) INTEGER +* The number of columns of the matrix A. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the matrix of column dimension N to which the row +* interchanges will be applied. +* On exit, the permuted matrix. +* +* LDA (input) INTEGER +* The leading dimension of the array A. +* +* K1 (input) INTEGER +* The first element of IPIV for which a row interchange will +* be done. +* +* K2 (input) INTEGER +* The last element of IPIV for which a row interchange will +* be done. +* +* IPIV (input) INTEGER array, dimension (M*abs(INCX)) +* The vector of pivot indices. Only the elements in positions +* K1 through K2 of IPIV are accessed. +* IPIV(K) = L implies rows K and L are to be interchanged. +* +* INCX (input) INTEGER +* The increment between successive values of IPIV. If IPIV +* is negative, the pivots are applied in reverse order. +* +* Further Details +* =============== +* +* Modified by +* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA +* +* ===================================================================== +* +* .. Local Scalars .. + INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 + DOUBLE PRECISION TEMP +* .. +* .. Executable Statements .. +* +* Interchange row I with row IPIV(I) for each of rows K1 through K2. +* + IF( INCX.GT.0 ) THEN + IX0 = K1 + I1 = K1 + I2 = K2 + INC = 1 + ELSE IF( INCX.LT.0 ) THEN + IX0 = 1 + ( 1-K2 )*INCX + I1 = K2 + I2 = K1 + INC = -1 + ELSE + RETURN + END IF +* + N32 = ( N / 32 )*32 + IF( N32.NE.0 ) THEN + DO 30 J = 1, N32, 32 + IX = IX0 + DO 20 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 10 K = J, J + 31 + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 10 CONTINUE + END IF + IX = IX + INCX + 20 CONTINUE + 30 CONTINUE + END IF + IF( N32.NE.N ) THEN + N32 = N32 + 1 + IX = IX0 + DO 50 I = I1, I2, INC + IP = IPIV( IX ) + IF( IP.NE.I ) THEN + DO 40 K = N32, N + TEMP = A( I, K ) + A( I, K ) = A( IP, K ) + A( IP, K ) = TEMP + 40 CONTINUE + END IF + IX = IX + INCX + 50 CONTINUE + END IF +* + RETURN +* +* End of DLASWP +* + END + INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1998 +* +* .. Scalar Arguments .. + INTEGER ISPEC + REAL ONE, ZERO +* .. +* +* Purpose +* ======= +* +* IEEECK is called from the ILAENV to verify that Infinity and +* possibly NaN arithmetic is safe (i.e. will not trap). +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies whether to test just for inifinity arithmetic +* or whether to test for infinity and NaN arithmetic. +* = 0: Verify infinity arithmetic only. +* = 1: Verify infinity and NaN arithmetic. +* +* ZERO (input) REAL +* Must contain the value 0.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* ONE (input) REAL +* Must contain the value 1.0 +* This is passed to prevent the compiler from optimizing +* away this code. +* +* RETURN VALUE: INTEGER +* = 0: Arithmetic failed to produce the correct answers +* = 1: Arithmetic produced the correct answers +* +* .. Local Scalars .. + REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, + $ NEGZRO, NEWZRO, POSINF +* .. +* .. Executable Statements .. + IEEECK = 1 +* + POSINF = ONE / ZERO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = -ONE / ZERO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGZRO = ONE / ( NEGINF+ONE ) + IF( NEGZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = ONE / NEGZRO + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + NEWZRO = NEGZRO + ZERO + IF( NEWZRO.NE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = ONE / NEWZRO + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* + NEGINF = NEGINF*POSINF + IF( NEGINF.GE.ZERO ) THEN + IEEECK = 0 + RETURN + END IF +* + POSINF = POSINF*POSINF + IF( POSINF.LE.ONE ) THEN + IEEECK = 0 + RETURN + END IF +* +* +* +* +* Return if we were only asked to check infinity arithmetic +* + IF( ISPEC.EQ.0 ) + $ RETURN +* + NAN1 = POSINF + NEGINF +* + NAN2 = POSINF / NEGINF +* + NAN3 = POSINF / POSINF +* + NAN4 = POSINF*ZERO +* + NAN5 = NEGINF*NEGZRO +* + NAN6 = NAN5*0.0 +* + IF( NAN1.EQ.NAN1 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN2.EQ.NAN2 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN3.EQ.NAN3 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN4.EQ.NAN4 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN5.EQ.NAN5 ) THEN + IEEECK = 0 + RETURN + END IF +* + IF( NAN6.EQ.NAN6 ) THEN + IEEECK = 0 + RETURN + END IF +* + RETURN + END + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, + $ N4 ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* June 30, 1999 +* +* .. Scalar Arguments .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* Purpose +* ======= +* +* ILAENV is called from the LAPACK routines to choose problem-dependent +* parameters for the local environment. See ISPEC for a description of +* the parameters. +* +* This version provides a set of parameters which should give good, +* but not optimal, performance on many of the currently available +* computers. Users are encouraged to modify this subroutine to set +* the tuning parameters for their particular machine using the option +* and problem size information in the arguments. +* +* This routine will not function correctly if it is converted to all +* lower case. Converting it to all upper case is allowed. +* +* Arguments +* ========= +* +* ISPEC (input) INTEGER +* Specifies the parameter to be returned as the value of +* ILAENV. +* = 1: the optimal blocksize; if this value is 1, an unblocked +* algorithm will give the best performance. +* = 2: the minimum block size for which the block routine +* should be used; if the usable block size is less than +* this value, an unblocked routine should be used. +* = 3: the crossover point (in a block routine, for N less +* than this value, an unblocked routine should be used) +* = 4: the number of shifts, used in the nonsymmetric +* eigenvalue routines +* = 5: the minimum column dimension for blocking to be used; +* rectangular blocks must have dimension at least k by m, +* where k is given by ILAENV(2,...) and m by ILAENV(5,...) +* = 6: the crossover point for the SVD (when reducing an m by n +* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds +* this value, a QR factorization is used first to reduce +* the matrix to a triangular form.) +* = 7: the number of processors +* = 8: the crossover point for the multishift QR and QZ methods +* for nonsymmetric eigenvalue problems. +* = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* =10: ieee NaN arithmetic can be trusted not to trap +* =11: infinity arithmetic can be trusted not to trap +* +* NAME (input) CHARACTER*(*) +* The name of the calling subroutine, in either upper case or +* lower case. +* +* OPTS (input) CHARACTER*(*) +* The character options to the subroutine NAME, concatenated +* into a single character string. For example, UPLO = 'U', +* TRANS = 'T', and DIAG = 'N' for a triangular routine would +* be specified as OPTS = 'UTN'. +* +* N1 (input) INTEGER +* N2 (input) INTEGER +* N3 (input) INTEGER +* N4 (input) INTEGER +* Problem dimensions for the subroutine NAME; these may not all +* be required. +* +* (ILAENV) (output) INTEGER +* >= 0: the value of the parameter specified by ISPEC +* < 0: if ILAENV = -k, the k-th argument had an illegal value. +* +* Further Details +* =============== +* +* The following conventions have been used when calling ILAENV from the +* LAPACK routines: +* 1) OPTS is a concatenation of all of the character options to +* subroutine NAME, in the same order that they appear in the +* argument list for NAME, even if they are not used in determining +* the value of the parameter specified by ISPEC. +* 2) The problem dimensions N1, N2, N3, N4 are specified in the order +* that they appear in the argument list for NAME. N1 is used +* first, N2 second, and so on, and unused problem dimensions are +* passed a value of -1. +* 3) The parameter value returned by ILAENV is checked for validity in +* the calling subroutine. For example, ILAENV is used to retrieve +* the optimal blocksize for STRTRI as follows: +* +* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +* IF( NB.LE.1 ) NB = MAX( 1, N ) +* +* ===================================================================== +* +* .. Local Scalars .. + LOGICAL CNAME, SNAME + CHARACTER*1 C1 + CHARACTER*2 C2, C4 + CHARACTER*3 C3 + CHARACTER*6 SUBNAM + INTEGER I, IC, IZ, NB, NBMIN, NX +* .. +* .. Intrinsic Functions .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. External Functions .. + INTEGER IEEECK + EXTERNAL IEEECK +* .. +* .. Executable Statements .. +* +C GO TO ( 100, 100, 100, 400, 500, 600, 700, 800, 900, 1000, +C $ 1100 ) ISPEC +C CHANGED COMPUTED GOTO: OBSOLETE +C + IF((ISPEC.EQ.1).OR.(ISPEC.EQ.2).OR.(ISPEC.EQ.3)) THEN + GO TO 100 + ELSEIF(ISPEC.EQ.4) THEN + GO TO 400 + ELSEIF(ISPEC.EQ.5) THEN + GO TO 500 + ELSEIF(ISPEC.EQ.6) THEN + GO TO 600 + ELSEIF(ISPEC.EQ.7) THEN + GO TO 700 + ELSEIF(ISPEC.EQ.8) THEN + GO TO 800 + ELSEIF(ISPEC.EQ.9) THEN + GO TO 900 + ELSEIF(ISPEC.EQ.10) THEN + GO TO 1000 + ELSEIF(ISPEC.EQ.11) THEN + GO TO 1100 + ENDIF +* +* Invalid value for ISPEC +* + ILAENV = -1 + RETURN +* + 100 CONTINUE +* +* Convert NAME to upper case if the first character is lower case. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1:1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII character set +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 10 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 10 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC character set +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1:1 ) = CHAR( IC+64 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) + $ SUBNAM( I:I ) = CHAR( IC+64 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* Prime machines: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 30 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1:1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2:3 ) + C3 = SUBNAM( 4:6 ) + C4 = C3( 2:3 ) +* + GO TO ( 110, 200, 300 ) ISPEC +* + 110 CONTINUE +* +* ISPEC = 1: block size +* +* In these examples, separate code is provided for setting NB for +* real and complex. We assume that NB will take the same value in +* single or double precision. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 32 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + END IF + ILAENV = NB + RETURN +* + 200 CONTINUE +* +* ISPEC = 2: minimum block size +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 8 + ELSE + NBMIN = 8 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + END IF + END IF + ILAENV = NBMIN + RETURN +* + 300 CONTINUE +* +* ISPEC = 3: crossover point +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 32 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NX = 128 + END IF + END IF + END IF + ILAENV = NX + RETURN +* + 400 CONTINUE +* +* ISPEC = 4: number of shifts (used by xHSEQR) +* + ILAENV = 6 + RETURN +* + 500 CONTINUE +* +* ISPEC = 5: minimum column dimension (not used) +* + ILAENV = 2 + RETURN +* + 600 CONTINUE +* +* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 700 CONTINUE +* +* ISPEC = 7: number of processors (not used) +* + ILAENV = 1 + RETURN +* + 800 CONTINUE +* +* ISPEC = 8: crossover point for multishift (used by xHSEQR) +* + ILAENV = 50 + RETURN +* + 900 CONTINUE +* +* ISPEC = 9: maximum size of the subproblems at the bottom of the +* computation tree in the divide-and-conquer algorithm +* (used by xGELSD and xGESDD) +* + ILAENV = 25 + RETURN +* + 1000 CONTINUE +* +* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap +* +c ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 0, 0.0, 1.0 ) + END IF + RETURN +* + 1100 CONTINUE +* +* ISPEC = 11: infinity arithmetic can be trusted not to trap +* +c ILAENV = 0 + ILAENV = 1 + IF( ILAENV.EQ.1 ) THEN + ILAENV = IEEECK( 1, 0.0, 1.0 ) + END IF + RETURN +* +* End of ILAENV +* + END +cc + integer function idamax(n,dx,incx) +c +c finds the index of element having max. absolute value. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dmax + integer i,incx,ix,n +c + idamax = 0 + if( n.lt.1 .or. incx.le.0 ) return + idamax = 1 + if(n.eq.1)return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + ix = 1 + dmax = dabs(dx(1)) + ix = ix + incx + do 10 i = 2,n + if(dabs(dx(ix)).le.dmax) go to 5 + idamax = i + dmax = dabs(dx(ix)) + 5 ix = ix + incx + 10 continue + return +c +c code for increment equal to 1 +c + 20 dmax = dabs(dx(1)) + do 30 i = 2,n + if(dabs(dx(i)).le.dmax) go to 30 + idamax = i + dmax = dabs(dx(i)) + 30 continue + return + end +cc + SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, LDA, M, N +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DGER performs the rank 1 operation +* +* A := alpha*x*y' + A, +* +* where alpha is a scalar, x is an m element vector, y is an n element +* vector and A is an m by n matrix. +* +* Parameters +* ========== +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( m - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the m +* element vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCY ) ). +* Before entry, the incremented array Y must contain the n +* element vector y. +* Unchanged on exit. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. On exit, A is +* overwritten by the updated matrix. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JY, KX +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( M.LT.0 )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( INCY.EQ.0 )THEN + INFO = 7 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGER ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* + IF( INCY.GT.0 )THEN + JY = 1 + ELSE + JY = 1 - ( N - 1 )*INCY + END IF + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( Y( JY ).NE.ZERO )THEN + TEMP = ALPHA*Y( JY ) + DO 10, I = 1, M + A( I, J ) = A( I, J ) + X( I )*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( M - 1 )*INCX + END IF + DO 40, J = 1, N + IF( Y( JY ).NE.ZERO )THEN + TEMP = ALPHA*Y( JY ) + IX = KX + DO 30, I = 1, M + A( I, J ) = A( I, J ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* End of DGER . +* + END +c SUBROUTINE XERBLA( SRNAME, INFO ) +c* +c* -- LAPACK auxiliary routine (preliminary version) -- +c* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +c* Courant Institute, Argonne National Lab, and Rice University +c* February 29, 1992 +c* +c* .. Scalar Arguments .. +c CHARACTER*6 SRNAME +c INTEGER INFO +c* .. +c* +c* Purpose +c* ======= +c* +c* XERBLA is an error handler for the LAPACK routines. +c* It is called by an LAPACK routine if an input parameter has an +c* invalid value. A message is printed and execution stops. +c* +c* Installers may consider modifying the STOP statement in order to +c* call system-specific exception-handling facilities. +cc* +c* Arguments +c* ========= +c* +c* SRNAME (input) CHARACTER*6 +c* The name of the routine which called XERBLA. +c* +c* INFO (input) INTEGER +c* The position of the invalid parameter in the parameter list +c* of the calling routine. +c* +c* +c WRITE( *, FMT = 9999 )SRNAME, INFO +c* +c STOP +c* +c 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', +c $ 'an illegal value' ) +c* +c* End of XERBLA +c* +c END +cc + subroutine dswap (n,dx,incx,dy,incy) +c +c interchanges two vectors. +c uses unrolled loops for increments equal one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal +c to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dx(ix) + dx(ix) = dy(iy) + dy(iy) = dtemp + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,3) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + 30 continue + if( n .lt. 3 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,3 + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + dtemp = dx(i + 1) + dx(i + 1) = dy(i + 1) + dy(i + 1) = dtemp + dtemp = dx(i + 2) + dx(i + 2) = dy(i + 2) + dy(i + 2) = dtemp + 50 continue + return + end +cc + subroutine dscal(n,da,dx,incx) +c +c scales a vector by a constant. +c uses unrolled loops for increment equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision da,dx(*) + integer i,incx,m,mp1,n,nincx +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dx(i) = da*dx(i) + 10 continue + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dx(i) = da*dx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dx(i) = da*dx(i) + dx(i + 1) = da*dx(i + 1) + dx(i + 2) = da*dx(i + 2) + dx(i + 3) = da*dx(i + 3) + dx(i + 4) = da*dx(i + 4) + 50 continue + return + end +cc + SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, + $ B, LDB ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + DOUBLE PRECISION ALPHA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DTRSM solves one of the matrix equations +* +* op( A )*X = alpha*B, or X*op( A ) = alpha*B, +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = A'. +* +* The matrix X is overwritten on B. +* +* Parameters +* ========== +* +* SIDE - CHARACTER*1. +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* Unchanged on exit. +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the matrix A is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* Unchanged on exit. +* +* TRANSA - CHARACTER*1. +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n' op( A ) = A. +* +* TRANSA = 'T' or 't' op( A ) = A'. +* +* TRANSA = 'C' or 'c' op( A ) = A'. +* +* Unchanged on exit. +* +* DIAG - CHARACTER*1. +* On entry, DIAG specifies whether or not A is unit triangular +* as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m +* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +* Before entry with UPLO = 'U' or 'u', the leading k by k +* upper triangular part of the array A must contain the upper +* triangular matrix and the strictly lower triangular part of +* A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading k by k +* lower triangular part of the array A must contain the lower +* triangular matrix and the strictly upper triangular part of +* A is not referenced. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced either, but are assumed to be unity. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When SIDE = 'L' or 'l' then +* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +* then LDA must be at least max( 1, n ). +* Unchanged on exit. +* +* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB - INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL LSIDE, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LSIDE = LSAME( SIDE , 'L' ) + IF( LSIDE )THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME( DIAG , 'N' ) + UPPER = LSAME( UPLO , 'U' ) +* + INFO = 0 + IF( ( .NOT.LSIDE ).AND. + $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 2 + ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN + INFO = 3 + ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. + $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN + INFO = 4 + ELSE IF( M .LT.0 )THEN + INFO = 5 + ELSE IF( N .LT.0 )THEN + INFO = 6 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTRSM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF( LSIDE )THEN + IF( LSAME( TRANSA, 'N' ) )THEN +* +* Form B := alpha*inv( A )*B. +* + IF( UPPER )THEN + DO 60, J = 1, N + IF( ALPHA.NE.ONE )THEN + DO 30, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 30 CONTINUE + END IF + DO 50, K = M, 1, -1 + IF( B( K, J ).NE.ZERO )THEN + IF( NOUNIT ) + $ B( K, J ) = B( K, J )/A( K, K ) + DO 40, I = 1, K - 1 + B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100, J = 1, N + IF( ALPHA.NE.ONE )THEN + DO 70, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 70 CONTINUE + END IF + DO 90 K = 1, M + IF( B( K, J ).NE.ZERO )THEN + IF( NOUNIT ) + $ B( K, J ) = B( K, J )/A( K, K ) + DO 80, I = K + 1, M + B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A' )*B. +* + IF( UPPER )THEN + DO 130, J = 1, N + DO 120, I = 1, M + TEMP = ALPHA*B( I, J ) + DO 110, K = 1, I - 1 + TEMP = TEMP - A( K, I )*B( K, J ) + 110 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( I, I ) + B( I, J ) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160, J = 1, N + DO 150, I = M, 1, -1 + TEMP = ALPHA*B( I, J ) + DO 140, K = I + 1, M + TEMP = TEMP - A( K, I )*B( K, J ) + 140 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( I, I ) + B( I, J ) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF( LSAME( TRANSA, 'N' ) )THEN +* +* Form B := alpha*B*inv( A ). +* + IF( UPPER )THEN + DO 210, J = 1, N + IF( ALPHA.NE.ONE )THEN + DO 170, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 170 CONTINUE + END IF + DO 190, K = 1, J - 1 + IF( A( K, J ).NE.ZERO )THEN + DO 180, I = 1, M + B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) + 180 CONTINUE + END IF + 190 CONTINUE + IF( NOUNIT )THEN + TEMP = ONE/A( J, J ) + DO 200, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260, J = N, 1, -1 + IF( ALPHA.NE.ONE )THEN + DO 220, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 220 CONTINUE + END IF + DO 240, K = J + 1, N + IF( A( K, J ).NE.ZERO )THEN + DO 230, I = 1, M + B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) + 230 CONTINUE + END IF + 240 CONTINUE + IF( NOUNIT )THEN + TEMP = ONE/A( J, J ) + DO 250, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A' ). +* + IF( UPPER )THEN + DO 310, K = N, 1, -1 + IF( NOUNIT )THEN + TEMP = ONE/A( K, K ) + DO 270, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 270 CONTINUE + END IF + DO 290, J = 1, K - 1 + IF( A( J, K ).NE.ZERO )THEN + TEMP = A( J, K ) + DO 280, I = 1, M + B( I, J ) = B( I, J ) - TEMP*B( I, K ) + 280 CONTINUE + END IF + 290 CONTINUE + IF( ALPHA.NE.ONE )THEN + DO 300, I = 1, M + B( I, K ) = ALPHA*B( I, K ) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360, K = 1, N + IF( NOUNIT )THEN + TEMP = ONE/A( K, K ) + DO 320, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 320 CONTINUE + END IF + DO 340, J = K + 1, N + IF( A( J, K ).NE.ZERO )THEN + TEMP = A( J, K ) + DO 330, I = 1, M + B( I, J ) = B( I, J ) - TEMP*B( I, K ) + 330 CONTINUE + END IF + 340 CONTINUE + IF( ALPHA.NE.ONE )THEN + DO 350, I = 1, M + B( I, K ) = ALPHA*B( I, K ) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSM . +* + END +cc + SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 TRANSA, TRANSB + INTEGER M, N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* Purpose +* ======= +* +* DGEMM performs one of the matrix-matrix operations +* +* C := alpha*op( A )*op( B ) + beta*C, +* +* where op( X ) is one of +* +* op( X ) = X or op( X ) = X', +* +* alpha and beta are scalars, and A, B and C are matrices, with op( A ) +* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +* +* Parameters +* ========== +* +* TRANSA - CHARACTER*1. +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n', op( A ) = A. +* +* TRANSA = 'T' or 't', op( A ) = A'. +* +* TRANSA = 'C' or 'c', op( A ) = A'. +* +* Unchanged on exit. +* +* TRANSB - CHARACTER*1. +* On entry, TRANSB specifies the form of op( B ) to be used in +* the matrix multiplication as follows: +* +* TRANSB = 'N' or 'n', op( B ) = B. +* +* TRANSB = 'T' or 't', op( B ) = B'. +* +* TRANSB = 'C' or 'c', op( B ) = B'. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix +* op( A ) and of the matrix C. M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix +* op( B ) and the number of columns of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - INTEGER. +* On entry, K specifies the number of columns of the matrix +* op( A ) and the number of rows of the matrix op( B ). K must +* be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +* k when TRANSA = 'N' or 'n', and is m otherwise. +* Before entry with TRANSA = 'N' or 'n', the leading m by k +* part of the array A must contain the matrix A, otherwise +* the leading k by m part of the array A must contain the +* matrix A. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANSA = 'N' or 'n' then +* LDA must be at least max( 1, m ), otherwise LDA must be at +* least max( 1, k ). +* Unchanged on exit. +* +* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is +* n when TRANSB = 'N' or 'n', and is k otherwise. +* Before entry with TRANSB = 'N' or 'n', the leading k by n +* part of the array B must contain the matrix B, otherwise +* the leading n by k part of the array B must contain the +* matrix B. +* Unchanged on exit. +* +* LDB - INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. When TRANSB = 'N' or 'n' then +* LDB must be at least max( 1, k ), otherwise LDB must be at +* least max( 1, n ). +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then C need not be set on input. +* Unchanged on exit. +* +* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). +* Before entry, the leading m by n part of the array C must +* contain the matrix C, except when beta is zero, in which +* case C need not be set on entry. +* On exit, the array C is overwritten by the m by n matrix +* ( alpha*op( A )*op( B ) + beta*C ). +* +* LDC - INTEGER. +* On entry, LDC specifies the first dimension of C as declared +* in the calling (sub) program. LDC must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL NOTA, NOTB + INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA, NCOLA and NROWB as the number of rows +* and columns of A and the number of rows of B respectively. +* + NOTA = LSAME( TRANSA, 'N' ) + NOTB = LSAME( TRANSB, 'N' ) + IF( NOTA )THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF( NOTB )THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF( ( .NOT.NOTA ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.NOTB ).AND. + $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( K .LT.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 8 + ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN + INFO = 10 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 13 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And if alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF( NOTB )THEN + IF( NOTA )THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 50, I = 1, M + C( I, J ) = ZERO + 50 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 60, I = 1, M + C( I, J ) = BETA*C( I, J ) + 60 CONTINUE + END IF + DO 80, L = 1, K + IF( B( L, J ).NE.ZERO )THEN + TEMP = ALPHA*B( L, J ) + DO 70, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 70 CONTINUE + END IF + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A'*B + beta*C +* + DO 120, J = 1, N + DO 110, I = 1, M + TEMP = ZERO + DO 100, L = 1, K + TEMP = TEMP + A( L, I )*B( L, J ) + 100 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF( NOTA )THEN +* +* Form C := alpha*A*B' + beta*C +* + DO 170, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 130, I = 1, M + C( I, J ) = ZERO + 130 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 140, I = 1, M + C( I, J ) = BETA*C( I, J ) + 140 CONTINUE + END IF + DO 160, L = 1, K + IF( B( J, L ).NE.ZERO )THEN + TEMP = ALPHA*B( J, L ) + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 150 CONTINUE + END IF + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A'*B' + beta*C +* + DO 200, J = 1, N + DO 190, I = 1, M + TEMP = ZERO + DO 180, L = 1, K + TEMP = TEMP + A( L, I )*B( J, L ) + 180 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/diamtr.f calculix-ccx-2.3/ccx_2.3/src/diamtr.f --- calculix-ccx-2.1/ccx_2.3/src/diamtr.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/diamtr.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,99 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine diamtr(n,e2,adj,xadj,mask,ls,xls,hlevel,snode,nc) +! +! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) +! + integer nc,j,snode,degree,mindeg,istrt,istop,hsize,node,jstrt, + & jstop,ewidth,i,width,depth,enode,n,sdepth,e2,xadj(n+1),adj(e2), + & xls(n+1),ls(n),mask(n),hlevel(n) +! + mindeg=n + do 10 i=1,n + if(mask(i).eq.0) then + degree=xadj(i+1)-xadj(i) + if(degree.lt.mindeg) then + snode=i + mindeg=degree + endif + endif + 10 continue +! + call rootls(n,snode,n+1,e2,adj,xadj,mask,ls,xls,sdepth,width) +! + nc=xls(sdepth+1)-1 +! + 15 continue +! + hsize=0 + istrt=xls(sdepth) + istop=xls(sdepth+1)-1 + do 20 i=istrt,istop + node=ls(i) + hsize=hsize+1 + hlevel(hsize)=node + xls(node)=xadj(node+1)-xadj(node) + 20 continue +! + if(hsize.gt.1) call isorti(hsize,hlevel,n,xls) +! + istop=hsize + hsize=1 + degree=xls(hlevel(1)) + do 25 i=2,istop + node=hlevel(i) + if(xls(node).ne.degree) then + degree=xls(node) + hsize=hsize+1 + hlevel(hsize)=node + endif + 25 continue +! + ewidth=nc+1 + do 30 i=1,hsize + node=hlevel(i) +! + call rootls(n,node,ewidth,e2,adj,xadj,mask,ls,xls,depth,width) + if(width.lt.ewidth) then +! + if(depth.gt.sdepth) then +! + snode=node + sdepth=depth + go to 15 + endif +! + enode=node + ewidth=width + endif + 30 continue +! + if(node.ne.enode) then + call rootls(n,enode,nc+1,e2,adj,xadj,mask,ls,xls,depth,width) + endif +! + do 50 i=1,depth + jstrt=xls(i) + jstop=xls(i+1)-1 + do 40 j=jstrt,jstop + mask(ls(j))=i-1 + 40 continue + 50 continue + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/distattach.f calculix-ccx-2.3/ccx_2.3/src/distattach.f --- calculix-ccx-2.1/ccx_2.3/src/distattach.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/distattach.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,97 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine distattach(xig,etg,pneigh,pnode,a,p,ratio,nterms) +! +! calculates the distance between the node with coordinates +! in "pnode" and the node with local coordinates xig and etg +! in a face described by "nterms" nodes with coordinates +! in pneigh +! + implicit none +! + integer nterms,i,j +! + real*8 ratio(8),pneigh(3,*),pnode(3),a,xi,et,xig,etg,p(3), + & dummy +! + if(nterms.eq.3) then + xi=(xig+1.d0)/2.d0 + et=(etg+1.d0)/2.d0 + if(xi+et.gt.1.d0) then + dummy=xi + xi=1.d0-et + et=1.d0-dummy + endif + ratio(1)=1.d0-xi-et + ratio(2)=xi + ratio(3)=et + elseif(nterms.eq.4) then + xi=xig + et=etg + ratio(1)=(1.d0-xi)*(1.d0-et)/4.d0 + ratio(2)=(1.d0+xi)*(1.d0-et)/4.d0 + ratio(3)=(1.d0+xi)*(1.d0+et)/4.d0 + ratio(4)=(1.d0-xi)*(1.d0+et)/4.d0 + elseif(nterms.eq.6) then + xi=(xig+1.d0)/2.d0 + et=(etg+1.d0)/2.d0 + if(xi+et.gt.1.d0) then + dummy=xi + xi=1.d0-et + et=1.d0-dummy + endif + ratio(1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et) + ratio(2)=xi*(2.d0*xi-1.d0) + ratio(3)=et*(2.d0*et-1.d0) + ratio(4)=4.d0*xi*(1.d0-xi-et) + ratio(5)=4.d0*xi*et + ratio(6)=4.d0*et*(1.d0-xi-et) + elseif(nterms.eq.8) then + xi=xig + et=etg + ratio(1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0 + ratio(2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0 + ratio(3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0 + ratio(4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0 + ratio(5)=(1.d0-xi*xi)*(1.d0-et)/2.d0 + ratio(6)=(1.d0+xi)*(1.d0-et*et)/2.d0 + ratio(7)=(1.d0-xi*xi)*(1.d0+et)/2.d0 + ratio(8)=(1.d0-xi)*(1.d0-et*et)/2.d0 + else + write(*,*) '*ERROR in distattach: case with ',nterms + write(*,*) ' terms is not covered' + stop + endif +! +! calculating the position in the face +! + do i=1,3 + p(i)=0.d0 + do j=1,nterms + p(i)=p(i)+ratio(j)*pneigh(i,j) + enddo + enddo +! +! calculating the distance +! + a=(pnode(1)-p(1))**2+(pnode(2)-p(2))**2+(pnode(3)-p(3))**2 +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/distattachline.f calculix-ccx-2.3/ccx_2.3/src/distattachline.f --- calculix-ccx-2.1/ccx_2.3/src/distattachline.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/distattachline.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,105 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine distattachline(xig,etg,pneigh,pnode,a,p, + & ratio,nterms,xn) +! +! calculates the distance between a straight line through the node +! with coordinates in "pnode" and direction vector "xn" and +! the node with local coordinates xig and etg +! in a face described by "nterms" nodes with coordinates +! in "pneigh" +! + implicit none +! + integer nterms,i,j +! + real*8 ratio(8),pneigh(3,*),pnode(3),a,xi,et,xig,etg,p(3), + & dummy,xn(3),coeff +! + if(nterms.eq.3) then + xi=(xig+1.d0)/2.d0 + et=(etg+1.d0)/2.d0 + if(xi+et.gt.1.d0) then + dummy=xi + xi=1.d0-et + et=1.d0-dummy + endif + ratio(1)=1.d0-xi-et + ratio(2)=xi + ratio(3)=et + elseif(nterms.eq.4) then + xi=xig + et=etg + ratio(1)=(1.d0-xi)*(1.d0-et)/4.d0 + ratio(2)=(1.d0+xi)*(1.d0-et)/4.d0 + ratio(3)=(1.d0+xi)*(1.d0+et)/4.d0 + ratio(4)=(1.d0-xi)*(1.d0+et)/4.d0 + elseif(nterms.eq.6) then + xi=(xig+1.d0)/2.d0 + et=(etg+1.d0)/2.d0 + if(xi+et.gt.1.d0) then + dummy=xi + xi=1.d0-et + et=1.d0-dummy + endif + ratio(1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et) + ratio(2)=xi*(2.d0*xi-1.d0) + ratio(3)=et*(2.d0*et-1.d0) + ratio(4)=4.d0*xi*(1.d0-xi-et) + ratio(5)=4.d0*xi*et + ratio(6)=4.d0*et*(1.d0-xi-et) + elseif(nterms.eq.8) then + xi=xig + et=etg + ratio(1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0 + ratio(2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0 + ratio(3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0 + ratio(4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0 + ratio(5)=(1.d0-xi*xi)*(1.d0-et)/2.d0 + ratio(6)=(1.d0+xi)*(1.d0-et*et)/2.d0 + ratio(7)=(1.d0-xi*xi)*(1.d0+et)/2.d0 + ratio(8)=(1.d0-xi)*(1.d0-et*et)/2.d0 + else + write(*,*) '*ERROR in distattach: case with ',nterms + write(*,*) ' terms is not covered' + stop + endif +! +! calculating the position in the face +! + do i=1,3 + p(i)=0.d0 + do j=1,nterms + p(i)=p(i)+ratio(j)*pneigh(i,j) + enddo + enddo +! +! calculating the distance +! +c a=(pnode(1)-p(1))**2+(pnode(2)-p(2))**2+(pnode(3)-p(3))**2 + coeff=0.0 + do i=1,3 + coeff=coeff+xn(i)*(p(i)-pnode(i)) + enddo + a=(p(1)-pnode(1)+coeff*xn(1))**2+(p(2)-pnode(2)+ + & coeff*xn(2))**2+(p(3)-pnode(3)+coeff*xn(3))**2 +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/distributedcouplings.f calculix-ccx-2.3/ccx_2.3/src/distributedcouplings.f --- calculix-ccx-2.1/ccx_2.3/src/distributedcouplings.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/distributedcouplings.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,396 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine distrubutedcouplings(inpc,textpart,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,nk,ikmpc,ilmpc, + & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc,lakon, + & kon,ipkon,set,nset,istartset,iendset,ialset,co) +! +! reading the input deck: *DISTRIBUTED COUPLING +! + implicit none +! + logical twod +! + character*1 inpc(*) + character*8 lakon(*) + character*20 labmpc(*) + character*81 surface,set(*) + character*132 textpart(16) +! + integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,istep,istat, + & n,i,j,key,nk,node,ifacequad(3,4),ifacetria(3,3),nmpcorig, + & mpcfreeold,ikmpc(*),ilmpc(*),id,idof,iline,ipol,inl, + & ipoinp(2,*),inp(3,*),ipoinpc(0:*),irefnode,lathyp(3,6),inum, + & jn,jt,iside,nelem,jface,nnodelem,nface,nodef(8),nodel(8), + & ifaceq(8,6),ifacet(6,4),ifacew1(4,5),ifacew2(8,5),indexpret, + & k,ipos,nope,m,kon(*),ipkon(*),indexe,iset,nset,idir, + & istartset(*),iendset(*),ialset(*),indexm,number +! + real*8 coefmpc(*),xn(3),dd,co(3,*),coef +! +! latin hypercube positions in a 3 x 3 matrix +! + data lathyp /1,2,3,1,3,2,2,1,3,2,3,1,3,1,2,3,2,1/ +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! +! nodes per face for quad elements +! + data ifacequad /1,2,5, + & 2,3,6, + & 3,4,7, + & 4,1,8/ +! +! nodes per face for tria elements +! + data ifacetria /1,2,4, + & 2,3,5, + & 3,1,6/ +! + if(istep.gt.0) then + write(*,*) '*ERROR in distributedcouplings.f: *EQUATION should' + write(*,*) ' be placed before all step definitions' + stop + endif +! + do i=2,n + if(textpart(i)(1:8).eq.'SURFACE=') then + surface=textpart(i)(9:88) + ipos=index(surface,' ') + surface(ipos:ipos)='T' + elseif(textpart(i)(1:5).eq.'NODE=') then + read(textpart(i)(6:15),'(i10)',iostat=istat) irefnode + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if((irefnode.gt.nk).or.(irefnode.le.0)) then + write(*,*) '*ERROR in distributedcouplings.f:' + write(*,*) ' node ',irefnode,' is not defined' + stop + endif + else + write(*,*) + & '*WARNING in distributedcouplings: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! checking whether the surface exists and is an element face +! surface +! + iset=0 + do i=1,nset + if(set(i).eq.surface) then + iset=i + exit + endif + enddo + if(iset.eq.0) then + write(*,*) '*ERROR in distributedcouplings: nonexistent' + write(*,*) ' surface or surface consists of nodes' + call inputerror(inpc,ipoinpc,iline) + endif +! +! reading the normal vector and normalizing +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + do i=1,3 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) xn(i) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) + do i=1,3 + xn(i)=xn(i)/dd + enddo +! +! generating a Latin hypercube +! checking which DOF's of xn, xt and xd are nonzero +! + do inum=1,6 + if(dabs(xn(lathyp(1,inum))).gt.1.d-3) exit + enddo + jn=lathyp(1,inum) +! +! generating the MPCs +! + indexpret=0 + m=iendset(iset)-istartset(iset)+1 +! +! loop over all element faces belonging to the surface +! + number=1 + do k=1,m + twod=.false. + iside=ialset(istartset(iset)+k-1) + nelem=int(iside/10.d0) + indexe=ipkon(nelem) + jface=iside-10*nelem +! +! nnodelem: #nodes in the face +! the nodes are stored in nodef(*) +! + if(lakon(nelem)(4:4).eq.'2') then + nnodelem=8 + nface=6 + elseif(lakon(nelem)(3:4).eq.'D8') then + nnodelem=4 + nface=6 + elseif(lakon(nelem)(4:5).eq.'10') then + nnodelem=6 + nface=4 + nope=10 + elseif(lakon(nelem)(4:4).eq.'4') then + nnodelem=3 + nface=4 + nope=4 + elseif(lakon(nelem)(4:5).eq.'15') then + if(jface.le.2) then + nnodelem=6 + else + nnodelem=8 + endif + nface=5 + nope=15 + elseif(lakon(nelem)(3:4).eq.'D6') then + if(jface.le.2) then + nnodelem=3 + else + nnodelem=4 + endif + nface=5 + nope=6 + elseif((lakon(nelem)(2:2).eq.'8').or. + & (lakon(nelem)(4:4).eq.'8')) then + nnodelem=3 + nface=4 + nope=8 + if(lakon(nelem)(4:4).eq.'8') then + twod=.true. + jface=jface-2 + endif + elseif((lakon(nelem)(2:2).eq.'6').or. + & (lakon(nelem)(4:4).eq.'6')) then + nnodelem=3 + nface=3 + if(lakon(nelem)(4:4).eq.'6') then + twod=.true. + jface=jface-2 + endif + else + cycle + endif +! +! determining the nodes of the face +! + if(nface.eq.3) then + do i=1,nnodelem + nodef(i)=kon(indexe+ifacetria(i,jface)) + nodel(i)=ifacetria(i,jface) + enddo + elseif(nface.eq.4) then + if(nope.eq.8) then + do i=1,nnodelem + nodef(i)=kon(indexe+ifacequad(i,jface)) + nodel(i)=ifacequad(i,jface) + enddo + else + do i=1,nnodelem + nodef(i)=kon(indexe+ifacet(i,jface)) + nodel(i)=ifacet(i,jface) + enddo + endif + elseif(nface.eq.5) then + if(nope.eq.6) then + do i=1,nnodelem + nodef(i)=kon(indexe+ifacew1(i,jface)) + nodel(i)=ifacew1(i,jface) + enddo + elseif(nope.eq.15) then + do i=1,nnodelem + nodef(i)=kon(indexe+ifacew2(i,jface)) + nodel(i)=ifacew2(i,jface) + enddo + endif + elseif(nface.eq.6) then + do i=1,nnodelem + nodef(i)=kon(indexe+ifaceq(i,jface)) + nodel(i)=ifaceq(i,jface) + enddo + endif +! +! loop over the nodes belonging to the face +! + loop: do i=1,nnodelem + node=nodef(i) +! +! MPC in the specified direction +! +! check whether initialized +! + if(indexpret.eq.0) then +! + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in distributedcouplings:' + write(*,*) ' increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + else +! +! check whether node was already treated +! + indexm=ipompc(nmpc) + do + if(node.eq.nodempc(1,indexm)) cycle loop + indexm=nodempc(3,indexm) + if(indexm.eq.0) exit + enddo + nodempc(3,indexpret)=mpcfree + number=number+1 + endif +! + idir=jn + if(dabs(xn(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xn(idir) + indexpret=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xn(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xn(idir) + indexpret=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xn(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xn(idir) + indexpret=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + enddo loop + enddo +! + nodempc(3,indexpret)=mpcfree + nodempc(1,mpcfree)=irefnode + nodempc(2,mpcfree)=1 + coefmpc(mpcfree)=-1.d0*number + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 +! +! choose a dependent node +! + indexm=ipompc(nmpc) + do + node=nodempc(1,indexm) + idir=nodempc(2,indexm) + idof=8*(node-1)+idir + nmpcorig=nmpc-1 + call nident(ikmpc,idof,nmpcorig,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + indexm=nodempc(3,indexm) + if(indexm.eq.0) then + write(*,*) '*ERROR in distributedcouplings:' + write(*,*) ' all DOFS have already' + write(*,*) ' been used' + stop + endif + cycle + endif + endif + if(indexm.ne.ipompc(nmpc)) then + coef=coefmpc(indexm) + nodempc(1,indexm)=nodempc(1,ipompc(nmpc)) + nodempc(2,indexm)=nodempc(2,ipompc(nmpc)) + coefmpc(indexm)=coefmpc(ipompc(nmpc)) + nodempc(1,ipompc(nmpc))=node + nodempc(2,ipompc(nmpc))=idir + coefmpc(ipompc(nmpc))=coef + endif + exit + enddo +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! +c do i=1,nmpc +c call writempc(ipompc,nodempc,coefmpc,labmpc,i) +c enddo +c do i=1,nmpc +c write(*,*) i,ikmpc(i),ilmpc(i) +c enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dKdm.f calculix-ccx-2.3/ccx_2.3/src/dKdm.f --- calculix-ccx-2.1/ccx_2.3/src/dKdm.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dKdm.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,45 @@ +! +! d{K(X)}/dxflow +! + subroutine dKdm(x,u,uprime,rpar,ipar) +! + implicit none + integer ipar + real*8 x,u(1),uprime(1),rpar(*),zk0,phi,Tup, + & xflow,Pup,f1_x,K_x,lambda1,df1dk,Rurd,f_k,kup +! + external f_k +! +! defining the parameters + phi=rpar(1) + lambda1=rpar(2) + zk0=rpar(3) + Pup=rpar(4) + Tup=rpar(5) + rurd=rpar(6) + xflow=rpar(7) + kup=rpar(8) +! +! find K(X) for the given x + + k_x=f_k(x,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) +! + k_x=dsqrt(K_x/x) +! +! f1_x + f1_x= (zk0*K_x)**(7.d0/4.d0) + & -(1-K_x)/dabs(1-K_x)*dabs(1-K_x)**(7d0*4d0) +! +! df1dK + df1dK=7d0/4d0*zk0**(7d0/4d0)*K_x**(3.d0/4.d0) + & +7d0/4d0*dabs(1-K_x)**(3.d0/4.d0) +! +! + uprime(1)=-x**1.6d0*lambda1*Pup**(0.8d0) + & /(xflow**2*Tup**0.8d0)*f1_x+u(1) + & *(lambda1*x**1.6d0*Pup**0.8d0/(xflow*Tup**0.8d0) + & *df1dK-2/x) +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/dKdp.f calculix-ccx-2.3/ccx_2.3/src/dKdp.f --- calculix-ccx-2.1/ccx_2.3/src/dKdp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dKdp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,45 @@ +! +! d{K(X)}/dPeint +! + subroutine dKdp(x,u,uprime,rpar,ipar) +! + implicit none + integer ipar + real*8 x,u(1),uprime(1),rpar(*),zk0,phi,Tup, + & xflow,Pup,f1_x,k_x,lambda1,df1dk,Rurd,f_k,kup +! + external f_k +! +! defining the parameters + phi=rpar(1) + lambda1=rpar(2) + zk0=rpar(3) + Pup=rpar(4) + Tup=rpar(5) + rurd=rpar(6) + xflow=rpar(7) + kup=rpar(8) +! +! find K(X) for the given x + k_x=f_k(x,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) +! + k_x=dsqrt(K_x/x) +! +! f1_x + f1_x= (zk0*K_x)**(7.d0/4.d0) + & -(1-K_x)/dabs(1-K_x)*dabs(1-K_x)**(7d0*4d0) +! +! df1dK + df1dK=7d0/4d0*zk0**(7d0/4d0)*K_x**(3.d0/4.d0) + & +7d0/4d0*dabs(1-K_x)**(3.d0/4.d0) +! + uprime(1)=0.8d0*x**1.6d0*lambda1*Pup**(-0.2) + & /(xflow*Tup**0.8d0)*f1_x+u(1) + & *(lambda1*x**1.6d0*Pup**0.8d0/(xflow*Tup**0.8d0) + & *df1dK-2/x) +! write(*,*) 'uprime',x,uprime(1) +! + return +! + end +! diff -Nru calculix-ccx-2.1/ccx_2.3/src/dKdt.f calculix-ccx-2.3/ccx_2.3/src/dKdt.f --- calculix-ccx-2.1/ccx_2.3/src/dKdt.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dKdt.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,45 @@ +! +! d{K(X)}/dTeint +! + subroutine dKdt(x,u,uprime,rpar,ipar) +! + implicit none + integer ipar + real*8 x,u(1),uprime(1),rpar(*),zk0,phi,Tup, + & xflow,Pup,f1_x,K_x,lambda1,df1dk,Rurd,f_k,kup +! + external f_k +! +! defining the parameters + phi=rpar(1) + lambda1=rpar(2) + zk0=rpar(3) + Pup=rpar(4) + Tup=rpar(5) + rurd=rpar(6) + xflow=rpar(7) + kup=rpar(8) +! +! find K(X) for the given x + + k_x=f_k(x,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) +! + k_x=dsqrt(K_x/x) +! +! f1_x + f1_x= (zk0*K_x)**(7.d0/4.d0) + & -(1-K_x)/dabs(1-K_x)*dabs(1-K_x)**(7d0*4d0) +! +! df1dK + df1dK=7d0/4d0*zk0**(7d0/4d0)*K_x**(3.d0/4.d0) + & +7d0/4d0*dabs(1-K_x)**(3.d0/4.d0) +! +! + uprime(1)=-0.8d0*x**1.6d0*lambda1*Pup**(0.8d0) + & /(xflow*Tup**1.8d0)*f1_x+u(1) + & *(lambda1*x**1.6d0*Pup**0.8d0/(xflow*Tup**0.8d0) + & *df1dK-2/x) +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/dKdX.f calculix-ccx-2.3/ccx_2.3/src/dKdX.f --- calculix-ccx-2.1/ccx_2.3/src/dKdX.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dKdX.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,22 @@ +! +! d{K(X)}/dX +! + subroutine dKdX(x,u,uprime,rpar,ipar) +! + implicit none + integer ipar + real*8 x,u(1),uprime(1),rpar(*),zk0,phi +! +! defining the parameters + phi=rpar(1) + zk0=rpar(3) + + uprime(1)=datan(1.d0)*0.315/(phi)*x**1.6* + & ((zk0*u(1))**1.75d0- + & (dabs(1.d0-u(1)))**1.75d0*(1.d0-u(1))/dabs(1.d0-u(1))) + & -2.d0*u(1)/x +! + return +! + end +! diff -Nru calculix-ccx-2.1/ccx_2.3/src/dload.f calculix-ccx-2.3/ccx_2.3/src/dload.f --- calculix-ccx-2.1/ccx_2.3/src/dload.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dload.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,269 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dload(f,kstep,kinc,time,noel,npt,layer,kspt, + & coords,jltyp,loadtype,vold,co,lakonl,konl, + & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,iscale,veold, + & rho,amat,mi) +! +! user subroutine dload +! +! +! INPUT: +! +! kstep step number +! kinc increment number +! time(1) current step time +! time(2) current total time +! noel element number +! npt integration point number +! layer currently not used +! kspt currently not used +! coords(1..3) global coordinates of the integration point +! jltyp loading face kode: +! 21 = face 1 +! 22 = face 2 +! 23 = face 3 +! 24 = face 4 +! 25 = face 5 +! 26 = face 6 +! loadtype load type label +! vold(0..4,1..nk) solution field in all nodes +! 0: temperature +! 1: displacement in global x-direction +! 2: displacement in global y-direction +! 3: displacement in global z-direction +! 4: static pressure +! veold(0..3,1..nk) derivative of the solution field w.r.t. +! time in all nodes +! 0: temperature rate +! 1: velocity in global x-direction +! 2: velocity in global y-direction +! 3: velocity in global z-direction +! co(3,1..nk) coordinates of all nodes +! 1: coordinate in global x-direction +! 2: coordinate in global y-direction +! 3: coordinate in global z-direction +! lakonl element label +! konl(1..20) nodes belonging to the element +! ipompc(1..nmpc)) ipompc(i) points to the first term of +! MPC i in field nodempc +! nodempc(1,*) node number of a MPC term +! nodempc(2,*) coordinate direction of a MPC term +! nodempc(3,*) if not 0: points towards the next term +! of the MPC in field nodempc +! if 0: MPC definition is finished +! coefmpc(*) coefficient of a MPC term +! nmpc number of MPC's +! ikmpc(1..nmpc) ordered global degrees of freedom of the MPC's +! the global degree of freedom is +! 8*(node-1)+direction of the dependent term of +! the MPC (direction = 0: temperature; +! 1-3: displacements; 4: static pressure; +! 5-7: rotations) +! ilmpc(1..nmpc) ilmpc(i) is the MPC number corresponding +! to the reference number in ikmpc(i) +! rho local density +! amat material name +! mi(1) max # of integration points per element (max +! over all elements) +! mi(2) max degree of freedomm per node (max over all +! nodes) in fields like v(0:mi(2))... +! +! OUTPUT: +! +! f magnitude of the distributed load +! iscale determines whether the flux has to be +! scaled for increments smaller than the +! step time in static calculations +! 0: no scaling +! 1: scaling (default) +! + implicit none +! + character*8 lakonl + character*20 loadtype + character*80 amat +! + integer kstep,kinc,noel,npt,jltyp,layer,kspt,konl(20),iscale,mi(2) +! + real*8 f,time(2),coords(3),vold(0:mi(2),*),co(3,*),rho +! +! the code starting here up to the end of the file serves as +! an example for combined mechanical-lubrication problems. +! Please replace it by your own code for your concrete application. +! + include "gauss.f" +! + integer ifaceq(8,6),ifacet(6,4),ifacew(8,5),ig,nelem,nopes, + & iflag,i,j,nope,ipompc(*),nodempc(3,*),nmpc,ikmpc(*),ilmpc(*), + & node,idof,id +! + real*8 xl2(3,8),pres(8),xi,et,xsj2(3),xs2(3,7),shp2(7,8), + & coefmpc(*),veold(0:mi(2),*) +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ + data iflag /2/ +! + nelem=noel + ig=jltyp-20 +! + if(lakonl(4:4).eq.'2') then + nope=20 + nopes=8 + elseif(lakonl(4:4).eq.'8') then + nope=8 + nopes=4 + elseif(lakonl(4:5).eq.'10') then + nope=10 + nopes=6 + elseif(lakonl(4:4).eq.'4') then + nope=4 + nopes=3 + elseif(lakonl(4:5).eq.'15') then + nope=15 + elseif(lakonl(4:4).eq.'6') then + nope=6 + endif +! +! treatment of wedge faces +! + if(lakonl(4:4).eq.'6') then + if(ig.le.2) then + nopes=3 + else + nopes=4 + endif + endif + if(lakonl(4:5).eq.'15') then + if(ig.le.2) then + nopes=6 + else + nopes=8 + endif + endif +! + do i=1,nopes + do j=1,3 + xl2(j,i)=0.d0 + enddo + enddo +! + if((nope.eq.20).or.(nope.eq.8)) then + do i=1,nopes + node=konl(ifaceq(i,ig)) + idof=8*(node-1) + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in dload: node ',node + write(*,*) ' is not connected to the oil film' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + pres(i)=vold(0,node) + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + do i=1,nopes + node=konl(ifacet(i,ig)) + node=konl(ifaceq(i,ig)) + idof=8*(node-1) + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in dload: node ',node + write(*,*) ' is not connected to the oil film' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + pres(i)=vold(0,node) + enddo + else + do i=1,nopes + node=konl(ifacew(i,ig)) + node=konl(ifaceq(i,ig)) + idof=8*(node-1) + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in dload: node ',node + write(*,*) ' is not connected to the oil film' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + pres(i)=vold(0,node) + enddo + endif +! + i=npt +! + if((lakonl(4:5).eq.'8R').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then + xi=gauss2d1(1,i) + et=gauss2d1(2,i) + elseif((lakonl(4:4).eq.'8').or. + & (lakonl(4:6).eq.'20R').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then + xi=gauss2d2(1,i) + et=gauss2d2(2,i) + elseif(lakonl(4:4).eq.'2') then + xi=gauss2d3(1,i) + et=gauss2d3(2,i) + elseif((lakonl(4:5).eq.'10').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then + xi=gauss2d5(1,i) + et=gauss2d5(2,i) + elseif((lakonl(4:4).eq.'4').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then + xi=gauss2d4(1,i) + et=gauss2d4(2,i) + endif +! + if(nopes.eq.8) then + call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + endif +! +! determining the pressure +! + f=0.d0 + do j=1,nopes + f=f+pres(j)*shp2(4,j) + enddo +! + iscale=0 +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dloads.f calculix-ccx-2.3/ccx_2.3/src/dloads.f --- calculix-ccx-2.1/ccx_2.3/src/dloads.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dloads.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,379 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dloads(inpc,textpart,set,istartset,iendset, + & ialset,nset,nelemload,sideload,xload,nload,nload_, + & ielmat,iamload,amname,nam,lakon,ne,dload_flag,istep, + & istat,n,iline,ipol,inl,ipoinp,inp,cbody,ibody,xbody,nbody, + & nbody_,xbodyold,iperturb,physcon,nam_,namtot_,namta,amta, + & nmethod,ipoinpc,maxsectors) +! +! reading the input deck: *DLOAD +! + implicit none +! + logical dload_flag +! + character*1 inpc(*) + character*8 lakon(*) + character*20 sideload(*),label + character*80 amname(*),amplitude + character*81 set(*),elset,cbody(*) + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),nelemload(2,*), + & ielmat(*),nset,nload,nload_,istep,istat,n,i,j,l,key, + & iamload(2,*),nam,iamplitude,ipos,ne,iline,ipol,iperturb, + & inl,ipoinp(2,*),inp(3,*),ibody(3,*),nbody,nbody_,nam_,namtot, + & namtot_,namta(3,*),idelay,nmethod,lc,isector,node,ipoinpc(0:*), + & maxsectors,jsector +! + real*8 xload(2,*),xbody(7,*),xmagnitude,dd,p1(3),p2(3),bodyf(3), + & xbodyold(7,*),physcon(*),amta(2,*) +! + iamplitude=0 + idelay=0 + lc=1 + isector=0 +! + if(istep.lt.1) then + write(*,*) '*ERROR in dloads: *DLOAD should only be used' + write(*,*) ' within a STEP' + stop + endif +! + do i=2,n + if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.dload_flag)) then + do j=1,nload + if(sideload(j)(1:1).eq.'P') then + xload(1,j)=0.d0 + endif + enddo + do j=1,nbody + xbody(1,j)=0.d0 + enddo + elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then + read(textpart(i)(11:90),'(a80)') amplitude + do j=1,nam + if(amname(j).eq.amplitude) then + iamplitude=j + exit + endif + enddo + if(j.gt.nam) then + write(*,*)'*ERROR in dloads: nonexistent amplitude' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iamplitude=j + elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN + if(idelay.ne.0) then + write(*,*) '*ERROR in dloads: the parameter TIME DELAY' + write(*,*) ' is used twice in the same keyword' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + else + idelay=1 + endif + nam=nam+1 + if(nam.gt.nam_) then + write(*,*) '*ERROR in dloads: increase nam_' + stop + endif + amname(nam)=' + & ' + if(iamplitude.eq.0) then + write(*,*) '*ERROR in dloads: time delay must be' + write(*,*) ' preceded by the amplitude parameter' + stop + endif + namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) + iamplitude=nam + if(nam.eq.1) then + namtot=0 + else + namtot=namta(2,nam-1) + endif + namtot=namtot+1 + if(namtot.gt.namtot_) then + write(*,*) '*ERROR dloads: increase namtot_' + stop + endif + namta(1,nam)=namtot + namta(2,nam)=namtot + read(textpart(i)(11:30),'(f20.0)',iostat=istat) + & amta(1,namtot) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:9).eq.'LOADCASE=') then + read(textpart(i)(10:19),'(i10)',iostat=istat) lc + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(nmethod.ne.5) then + write(*,*) '*ERROR in dloads: the parameter LOAD CASE' + write(*,*) ' is only allowed in STEADY STATE' + write(*,*) ' DYNAMICS calculations' + stop + endif + elseif(textpart(i)(1:7).eq.'SECTOR=') then + read(textpart(i)(8:17),'(i10)',iostat=istat) isector + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if((nmethod.le.3).or.(iperturb.gt.1)) then + write(*,*) '*ERROR in dloads: the parameter SECTOR' + write(*,*) ' is only allowed in MODAL DYNAMICS or' + write(*,*) ' STEADY STATE DYNAMICS calculations' + stop + endif + if(isector.gt.maxsectors) then + write(*,*) '*ERROR in dloads: sector ',isector + write(*,*) ' exceeds number of sectors' + stop + endif + isector=isector-1 + else + write(*,*) + & '*WARNING in dloads: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return +! + read(textpart(2)(1:20),'(a20)',iostat=istat) label + if(label(3:4).ne.'NP') then + read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagnitude + else + read(textpart(3)(1:10),'(i10)',iostat=istat) node + endif + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(label(1:7).eq.'CENTRIF') then + do i=1,3 + read(textpart(i+3)(1:20),'(f20.0)',iostat=istat) p1(i) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + do i=1,3 + read(textpart(i+6)(1:20),'(f20.0)',iostat=istat) p2(i) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + dd=dsqrt(p2(1)**2+p2(2)**2+p2(3)**2) + do i=1,3 + p2(i)=p2(i)/dd + enddo + elseif(label(1:4).eq.'GRAV') then + do i=1,3 + read(textpart(i+3)(1:20),'(f20.0)',iostat=istat) bodyf(i) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + elseif(label(1:6).eq.'NEWTON') then + if(iperturb.le.1) then + write(*,*) '*ERROR in dloads: NEWTON gravity force' + write(*,*) ' can only be used in a nonlinear' + write(*,*) ' procedure' + stop + endif + if(physcon(3).le.0.d0) then + write(*,*) '*ERROR in dloads: NEWTON gravity force' + write(*,*) ' requires the definition of a' + write(*,*) ' positive gravity constant with' + write(*,*) ' a *PHYSICAL CONSTANTS card' + stop + endif + elseif(((label(1:2).ne.'P1').and.(label(1:2).ne.'P2').and. + & (label(1:2).ne.'P3').and.(label(1:2).ne.'P4').and. + & (label(1:2).ne.'P5').and.(label(1:2).ne.'P6').and. + & (label(1:2).ne.'P ').and.(label(1:2).ne.'BX').and. + & (label(1:2).ne.'BY').and.(label(1:2).ne.'BZ').and. +cBernhardiStart + & (label(1:2).ne.'ED')).or. + & ((label(3:6).ne.'NOR1').and.(label(3:6).ne.'NOR2').and. + & (label(3:6).ne.'NOR3').and.(label(3:6).ne.'NOR4')).and. +cBernhardiEnd + & ((label(3:4).ne.' ').and.(label(3:4).ne.'NU').and. + & (label(3:4).ne.'NP'))) then + call inputerror(inpc,ipoinpc,iline) + endif +! + read(textpart(1)(1:10),'(i10)',iostat=istat) l + if(istat.eq.0) then + if(l.gt.ne) then + write(*,*) '*ERROR in dloads: element ',l + write(*,*) ' is not defined' + stop + endif + if((label(1:7).eq.'CENTRIF').or.(label(1:4).eq.'GRAV').or. + & (label(1:6).eq.'NEWTON')) then + elset(1:80)=textpart(1)(1:80) + elset(81:81)=' ' + call bodyadd(cbody,ibody,xbody,nbody,nbody_,elset,label, + & iamplitude,xmagnitude,p1,p2,bodyf,xbodyold,lc) + else + if((lakon(l)(1:2).eq.'CP').or. + & (lakon(l)(2:2).eq.'A').or. + & (lakon(l)(7:7).eq.'E').or. + & (lakon(l)(7:7).eq.'S').or. + & (lakon(l)(7:7).eq.'A')) then + if(label(1:2).eq.'P1') then + label(1:2)='P3' + elseif(label(1:2).eq.'P2') then + label(1:2)='P4' + elseif(label(1:2).eq.'P3') then + label(1:2)='P5' + elseif(label(1:2).eq.'P4') then + label(1:2)='P6' + endif + elseif((lakon(l)(1:1).eq.'B').or. + & (lakon(l)(7:7).eq.'B')) then + if(label(1:2).eq.'P2') label(1:2)='P5' + elseif((lakon(l)(1:1).eq.'S').or. + & (lakon(l)(7:7).eq.'L')) then +cBernhardiStart + if(label(1:6).eq.'EDNOR1') then + label(1:2)='P3' + elseif(label(1:6).eq.'EDNOR2') then + label(1:2)='P4' + elseif(label(1:6).eq.'EDNOR3') then + label(1:2)='P5' + elseif(label(1:6).eq.'EDNOR4') then + label(1:2)='P6' + else + label(1:2)='P1' + endif +cBernhardiEnd + endif + if(lc.ne.1) then + jsector=isector+maxsectors + else + jsector=isector + endif + if(label(3:4).ne.'NP') then + call loadadd(l,label,xmagnitude,nelemload,sideload, + & xload,nload,nload_,iamload,iamplitude, + & nam,jsector) + else + call loadaddp(l,label,nelemload,sideload, + & xload,nload,nload_,iamload,iamplitude, + & nam,node) + endif + endif + else + read(textpart(1)(1:80),'(a80)',iostat=istat) elset + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + do i=1,nset + if(set(i).eq.elset) exit + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR in dloads: element set ',elset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! + if((label(1:7).eq.'CENTRIF').or.(label(1:4).eq.'GRAV').or. + & (label(1:6).eq.'NEWTON')) then + call bodyadd(cbody,ibody,xbody,nbody,nbody_,elset,label, + & iamplitude,xmagnitude,p1,p2,bodyf,xbodyold,lc) + else + l=ialset(istartset(i)) + if((lakon(l)(1:2).eq.'CP').or. + & (lakon(l)(2:2).eq.'A').or. + & (lakon(l)(7:7).eq.'E').or. + & (lakon(l)(7:7).eq.'S').or. + & (lakon(l)(7:7).eq.'A')) then + if(label(1:2).eq.'P1') then + label(1:2)='P3' + elseif(label(1:2).eq.'P2') then + label(1:2)='P4' + elseif(label(1:2).eq.'P3') then + label(1:2)='P5' + elseif(label(1:2).eq.'P4') then + label(1:2)='P6' + endif + elseif((lakon(l)(1:1).eq.'B').or. + & (lakon(l)(7:7).eq.'B')) then + if(label(1:2).eq.'P2') label(1:2)='P5' + elseif((lakon(l)(1:1).eq.'S').or. + & (lakon(l)(7:7).eq.'L')) then +cBernhardiStart + if(label(1:6).eq.'EDNOR1') then + label(1:2)='P3' + elseif(label(1:6).eq.'EDNOR2') then + label(1:2)='P4' + elseif(label(1:6).eq.'EDNOR3') then + label(1:2)='P5' + elseif(label(1:6).eq.'EDNOR4') then + label(1:2)='P6' + else + label(1:2)='P1' + endif +cBernhardiEnd + endif +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + l=ialset(j) + if(lc.ne.1) then + jsector=isector+maxsectors + else + jsector=isector + endif + if(label(3:4).ne.'NP') then + call loadadd(l,label,xmagnitude,nelemload, + & sideload,xload,nload,nload_,iamload, + & iamplitude,nam,jsector) + else + call loadaddp(l,label,nelemload, + & sideload,xload,nload,nload_,iamload, + & iamplitude,nam,node) + endif + else + l=ialset(j-2) + do + l=l-ialset(j) + if(l.ge.ialset(j-1)) exit + if(lc.ne.1) then + jsector=isector+maxsectors + else + jsector=isector + endif + if(label(3:4).ne.'NP') then + call loadadd(l,label,xmagnitude,nelemload, + & sideload,xload,nload,nload_, + & iamload,iamplitude,nam,jsector) + else + call loadaddp(l,label,nelemload, + & sideload,xload,nload,nload_, + & iamload,iamplitude,nam,node) + endif + enddo + endif + enddo + endif + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dot.f calculix-ccx-2.3/ccx_2.3/src/dot.f --- calculix-ccx-2.1/ccx_2.3/src/dot.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dot.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,29 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + double precision function dot(a,b,n) + implicit none + integer k,n + real*8 a(*),b(*) +c....dot product function + dot = 0.0d0 + do 10 k = 1,n + dot = dot + a(k)*b(k) + 10 continue + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/dqag.f calculix-ccx-2.3/ccx_2.3/src/dqag.f --- calculix-ccx-2.1/ccx_2.3/src/dqag.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dqag.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1933 @@ + subroutine dqag(f,a,b,epsabs,epsrel,key,result,abserr,neval,ier, + * limit,lenw,last,iwork,work,phi,lambda1,zk0,Pup,Tup,rurd,xflow, + * kup) +c***begin prologue dqag +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a1 +c***keywords automatic integrator, general-purpose, +c integrand examinator, globally adaptive, +c gauss-kronrod +c***author piessens,robert,appl. math. & progr. div - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c definite integral i = integral of f over (a,b), +c hopefully satisfying following claim for accuracy +c abs(i-result)le.max(epsabs,epsrel*abs(i)). +c***description +c +c computation of a definite integral +c standard fortran subroutine +c double precision version +c +c f - double precision +c function subprogam defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c epsabs - double precision +c absolute accoracy requested +c epsrel - double precision +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c key - integer +c key for choice of local integration rule +c a gauss-kronrod pair is used with +c 7 - 15 points if key.lt.2, +c 10 - 21 points if key = 2, +c 15 - 31 points if key = 3, +c 20 - 41 points if key = 4, +c 25 - 51 points if key = 5, +c 30 - 61 points if key.gt.5. +c +c on return +c result - double precision +c approximation to the integral +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c ier.gt.0 abnormal termination of the routine +c the estimates for result and error are +c less reliable. it is assumed that the +c requested accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value of +c limit (and taking the according dimension +c adjustments into account). however, if +c this yield no improvement it is advised +c to analyze the integrand in order to +c determine the integration difficulaties. +c if the position of a local difficulty can +c be determined (i.e.singularity, +c discontinuity within the interval) one +c will probably gain from splitting up the +c interval at this point and calling the +c integrator on the subranges. if possible, +c an appropriate special-purpose integrator +c should be used which is designed for +c handling the type of difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c = 3 extremely bad integrand behaviour occurs +c at some points of the integration +c interval. +c = 6 the input is invalid, because +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28)) +c or limit.lt.1 or lenw.lt.limit*4. +c result, abserr, neval, last are set +c to zero. +c except when lenw is invalid, iwork(1), +c work(limit*2+1) and work(limit*3+1) are +c set to zero, work(1) is set to a and +c work(limit+1) to b. +c +c dimensioning parameters +c limit - integer +c dimensioning parameter for iwork +c limit determines the maximum number of subintervals +c in the partition of the given integration interval +c (a,b), limit.ge.1. +c if limit.lt.1, the routine will end with ier = 6. +c +c lenw - integer +c dimensioning parameter for work +c lenw must be at least limit*4. +c if lenw.lt.limit*4, the routine will end with +c ier = 6. +c +c last - integer +c on return, last equals the number of subintervals +c produced in the subdiviosion process, which +c determines the number of significant elements +c actually in the work arrays. +c +c work arrays +c iwork - integer +c vector of dimension at least limit, the first k +c elements of which contain pointers to the error +c estimates over the subintervals, such that +c work(limit*3+iwork(1)),... , work(limit*3+iwork(k)) +c form a decreasing sequence with k = last if +c last.le.(limit/2+2), and k = limit+1-last otherwise +c +c work - double precision +c vector of dimension at least lenw +c on return +c work(1), ..., work(last) contain the left end +c points of the subintervals in the partition of +c (a,b), +c work(limit+1), ..., work(limit+last) contain the +c right end points, +c work(limit*2+1), ..., work(limit*2+last) contain +c the integral approximations over the subintervals, +c work(limit*3+1), ..., work(limit*3+last) contain +c the error estimates. +c +c***references (none) +c***routines called dqage,xerror +c***end prologue dqag + real*8 a,abserr,b,epsabs,epsrel,f,result,work,d1mach(4), + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup + integer ier,iwork,key,last,lenw,limit,lvl,l1,l2,l3,neval +c + dimension iwork(limit),work(lenw) +c + external f +c +c check validity of lenw. +c + d1mach(1)=1E21 + d1mach(2)=0d0 + d1mach(3)=0d0 + d1mach(4)=1E-21 +c +c***first executable statement dqag + ier = 6 + neval = 0 + last = 0 + result = 0.0d+00 + abserr = 0.0d+00 + if(limit.lt.1.or.lenw.lt.limit*4) go to 10 +c +c prepare call for dqage. +c + l1 = limit+1 + l2 = limit+l1 + l3 = limit+l2 +c + call dqage(f,a,b,epsabs,epsrel,key,limit,result,abserr,neval, + * ier,work(1),work(l1),work(l2),work(l3),iwork,last,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup) +c +c call error handler if necessary. +c + lvl = 0 +10 if(ier.eq.6) lvl = 1 +! if(ier.ne.0) call xerror(26habnormal return from dqag ,26,ier,lvl) + return + end + subroutine dqage(f,a,b,epsabs,epsrel,key,limit,result,abserr, + * neval,ier,alist,blist,rlist,elist,iord,last,phi,lambda1,zk0, + * Pup,Tup,rurd,xflow,kup) +c***begin prologue dqage +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a1 +c***keywords automatic integrator, general-purpose, +c integrand examinator, globally adaptive, +c gauss-kronrod +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose the routine calculates an approximation result to a given +c definite integral i = integral of f over (a,b), +c hopefully satisfying following claim for accuracy +c abs(i-reslt).le.max(epsabs,epsrel*abs(i)). +c***description +c +c computation of a definite integral +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c epsabs - double precision +c absolute accuracy requested +c epsrel - double precision +c relative accuracy requested +c if epsabs.le.0 +c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c the routine will end with ier = 6. +c +c key - integer +c key for choice of local integration rule +c a gauss-kronrod pair is used with +c 7 - 15 points if key.lt.2, +c 10 - 21 points if key = 2, +c 15 - 31 points if key = 3, +c 20 - 41 points if key = 4, +c 25 - 51 points if key = 5, +c 30 - 61 points if key.gt.5. +c +c limit - integer +c gives an upperbound on the number of subintervals +c in the partition of (a,b), limit.ge.1. +c +c on return +c result - double precision +c approximation to the integral +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed abs(i-result) +c +c neval - integer +c number of integrand evaluations +c +c ier - integer +c ier = 0 normal and reliable termination of the +c routine. it is assumed that the requested +c accuracy has been achieved. +c ier.gt.0 abnormal termination of the routine +c the estimates for result and error are +c less reliable. it is assumed that the +c requested accuracy has not been achieved. +c error messages +c ier = 1 maximum number of subdivisions allowed +c has been achieved. one can allow more +c subdivisions by increasing the value +c of limit. +c however, if this yields no improvement it +c is rather advised to analyze the integrand +c in order to determine the integration +c difficulties. if the position of a local +c difficulty can be determined(e.g. +c singularity, discontinuity within the +c interval) one will probably gain from +c splitting up the interval at this point +c and calling the integrator on the +c subranges. if possible, an appropriate +c special-purpose integrator should be used +c which is designed for handling the type of +c difficulty involved. +c = 2 the occurrence of roundoff error is +c detected, which prevents the requested +c tolerance from being achieved. +c = 3 extremely bad integrand behaviour occurs +c at some points of the integration +c interval. +c = 6 the input is invalid, because +c (epsabs.le.0 and +c epsrel.lt.max(50*rel.mach.acc.,0.5d-28), +c result, abserr, neval, last, rlist(1) , +c elist(1) and iord(1) are set to zero. +c alist(1) and blist(1) are set to a and b +c respectively. +c +c alist - double precision +c vector of dimension at least limit, the first +c last elements of which are the left +c end points of the subintervals in the partition +c of the given integration range (a,b) +c +c blist - double precision +c vector of dimension at least limit, the first +c last elements of which are the right +c end points of the subintervals in the partition +c of the given integration range (a,b) +c +c rlist - double precision +c vector of dimension at least limit, the first +c last elements of which are the +c integral approximations on the subintervals +c +c elist - double precision +c vector of dimension at least limit, the first +c last elements of which are the moduli of the +c absolute error estimates on the subintervals +c +c iord - integer +c vector of dimension at least limit, the first k +c elements of which are pointers to the +c error estimates over the subintervals, +c such that elist(iord(1)), ..., +c elist(iord(k)) form a decreasing sequence, +c with k = last if last.le.(limit/2+2), and +c k = limit+1-last otherwise +c +c last - integer +c number of subintervals actually produced in the +c subdivision process +c +c***references (none) +c***routines called d1mach,dqk15,dqk21,dqk31, +c dqk41,dqk51,dqk61,dqpsrt +c***end prologue dqage +c + double precision a,abserr,alist,area,area1,area12,area2,a1,a2,b, + * blist,b1,b2,dabs,defabs,defab1,defab2,d1mach(4),elist, + * epmach,epsabs,epsrel,errbnd,errmax,error1,error2,erro12,errsum,f, + * resabs,result,rlist,uflow,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup + integer ier,iord,iroff1,iroff2,k,key,keyf,last,limit,maxerr,neval, + * nrmax +c + dimension alist(limit),blist(limit),elist(limit),iord(limit), + * rlist(limit) +c + external f + + + d1mach(1)=1E21 + d1mach(2)=0d0 + d1mach(3)=0d0 + d1mach(4)=1E-21 +c +c list of major variables +c ----------------------- +c +c alist - list of left end points of all subintervals +c considered up to now +c blist - list of right end points of all subintervals +c considered up to now +c rlist(i) - approximation to the integral over +c (alist(i),blist(i)) +c elist(i) - error estimate applying to rlist(i) +c maxerr - pointer to the interval with largest +c error estimate +c errmax - elist(maxerr) +c area - sum of the integrals over the subintervals +c errsum - sum of the errors over the subintervals +c errbnd - requested accuracy max(epsabs,epsrel* +c abs(result)) +c *****1 - variable for the left subinterval +c *****2 - variable for the right subinterval +c last - index for subdivision +c +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement dqage + epmach = d1mach(4) + uflow = d1mach(1) +c +c test on validity of parameters +c ------------------------------ +c + ier = 0 + neval = 0 + last = 0 + result = 0.0d+00 + abserr = 0.0d+00 + alist(1) = a + blist(1) = b + rlist(1) = 0.0d+00 + elist(1) = 0.0d+00 + iord(1) = 0 + if(epsabs.le.0.0d+00.and. + * epsrel.lt.max(0.5d+02*epmach,0.5d-28)) ier = 6 + if(ier.eq.6) go to 999 +c +c first approximation to the integral +c ----------------------------------- +c + keyf = key + if(key.le.0) keyf = 1 + if(key.ge.7) keyf = 6 + neval = 0 + if(keyf.eq.1) call dqk15(f,a,b,result,abserr,defabs,resabs, + & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + if(keyf.eq.2) call dqk21(f,a,b,result,abserr,defabs,resabs, + & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + if(keyf.eq.3) call dqk31(f,a,b,result,abserr,defabs,resabs, + & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + if(keyf.eq.4) call dqk41(f,a,b,result,abserr,defabs,resabs, + & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + if(keyf.eq.5) call dqk51(f,a,b,result,abserr,defabs,resabs, + & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + if(keyf.eq.6) call dqk61(f,a,b,result,abserr,defabs,resabs, + & phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + last = 1 + rlist(1) = result + elist(1) = abserr + iord(1) = 1 +c +c test on accuracy. +c + errbnd = max(epsabs,epsrel*dabs(result)) + if(abserr.le.0.5d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2 + if(limit.eq.1) ier = 1 + if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs) + * .or.abserr.eq.0.0d+00) go to 60 +c +c initialization +c -------------- +c +c + errmax = abserr + maxerr = 1 + area = result + errsum = abserr + nrmax = 1 + iroff1 = 0 + iroff2 = 0 +c +c main do-loop +c ------------ +c + do 30 last = 2,limit +c +c bisect the subinterval with the largest error estimate. +c + a1 = alist(maxerr) + b1 = 0.5d+00*(alist(maxerr)+blist(maxerr)) + a2 = b1 + b2 = blist(maxerr) + if(keyf.eq.1) call dqk15(f,a1,b1,area1,error1,resabs,defab1, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.2) call dqk21(f,a1,b1,area1,error1,resabs,defab1, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.3) call dqk31(f,a1,b1,area1,error1,resabs,defab1, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.4) call dqk41(f,a1,b1,area1,error1,resabs,defab1, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.5) call dqk51(f,a1,b1,area1,error1,resabs,defab1, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.6) call dqk61(f,a1,b1,area1,error1,resabs,defab1, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.1) call dqk15(f,a2,b2,area2,error2,resabs,defab2, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.2) call dqk21(f,a2,b2,area2,error2,resabs,defab2, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.3) call dqk31(f,a2,b2,area2,error2,resabs,defab2, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.4) call dqk41(f,a2,b2,area2,error2,resabs,defab2, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.5) call dqk51(f,a2,b2,area2,error2,resabs,defab2, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) + if(keyf.eq.6) call dqk61(f,a2,b2,area2,error2,resabs,defab2, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup ) +c +c improve previous approximations to integral +c and error and test for accuracy. +c + neval = neval+1 + area12 = area1+area2 + erro12 = error1+error2 + errsum = errsum+erro12-errmax + area = area+area12-rlist(maxerr) + if(defab1.eq.error1.or.defab2.eq.error2) go to 5 + if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12) + * .and.erro12.ge.0.99d+00*errmax) iroff1 = iroff1+1 + if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1 + 5 rlist(maxerr) = area1 + rlist(last) = area2 + errbnd = max(epsabs,epsrel*dabs(area)) + if(errsum.le.errbnd) go to 8 +c +c test for roundoff error and eventually set error flag. +c + if(iroff1.ge.6.or.iroff2.ge.20) ier = 2 +c +c set error flag in the case that the number of subintervals +c equals limit. +c + if(last.eq.limit) ier = 1 +c +c set error flag in the case of bad integrand behaviour +c at a point of the integration range. +c + if(max(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03* + * epmach)*(dabs(a2)+0.1d+04*uflow)) ier = 3 +c +c append the newly-created intervals to the list. +c + 8 if(error2.gt.error1) go to 10 + alist(last) = a2 + blist(maxerr) = b1 + blist(last) = b2 + elist(maxerr) = error1 + elist(last) = error2 + go to 20 + 10 alist(maxerr) = a2 + alist(last) = a1 + blist(last) = b1 + rlist(maxerr) = area2 + rlist(last) = area1 + elist(maxerr) = error2 + elist(last) = error1 +c +c call subroutine dqpsrt to maintain the descending ordering +c in the list of error estimates and select the subinterval +c with the largest error estimate (to be bisected next). +c + 20 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax,phi, + * lambda1,zk0,Pup,Tup,rurd,xflow,kup) +c ***jump out of do-loop + if(ier.ne.0.or.errsum.le.errbnd) go to 40 + 30 continue +c +c compute final result. +c --------------------- +c + 40 result = 0.0d+00 + do 50 k=1,last + result = result+rlist(k) + 50 continue + abserr = errsum + 60 if(keyf.ne.1) neval = (10*keyf+1)*(2*neval+1) + if(keyf.eq.1) neval = 30*neval+15 + 999 return + end + subroutine dqk15(f,a,b,result,abserr,resabs,resasc,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup) +c***begin prologue dqk15 +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a2 +c***keywords 15-point gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div - k.u.leuven +c***purpose to compute i = integral of f over (a,b), with error +c estimate +c j = integral of abs(f) over (a,b) +c***description +c +c integration rules +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the calling program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c on return +c result - double precision +c approximation to the integral i +c result is computed by applying the 15-point +c kronrod rule (resk) obtained by optimal addition +c of abscissae to the7-point gauss rule(resg). +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should not exceed abs(i-result) +c +c resabs - double precision +c approximation to the integral j +c +c resasc - double precision +c approximation to the integral of abs(f-i/(b-a)) +c over (a,b) +c +c***references (none) +c***routines called d1mach +c***end prologue dqk15 +c + double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, + * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, + * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup + integer j,jtw,jtwm1 + external f +c + dimension fv1(7),fv2(7),wg(4),wgk(8),xgk(8) + + d1mach(1)=1E21 + d1mach(2)=0d0 + d1mach(3)=0d0 + d1mach(4)=1E-21 + + +c +c the abscissae and weights are given for the interval (-1,1). +c because of symmetry only the positive abscissae and their +c corresponding weights are given. +c +c xgk - abscissae of the 15-point kronrod rule +c xgk(2), xgk(4), ... abscissae of the 7-point +c gauss rule +c xgk(1), xgk(3), ... abscissae which are optimally +c added to the 7-point gauss rule +c +c wgk - weights of the 15-point kronrod rule +c +c wg - weights of the 7-point gauss rule +c +c +c gauss quadrature weights and kronron quadrature abscissae and weights +c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +c bell labs, nov. 1981. +c + data wg ( 1) / 0.1294849661 6886969327 0611432679 082 d0 / + data wg ( 2) / 0.2797053914 8927666790 1467771423 780 d0 / + data wg ( 3) / 0.3818300505 0511894495 0369775488 975 d0 / + data wg ( 4) / 0.4179591836 7346938775 5102040816 327 d0 / +c + data xgk ( 1) / 0.9914553711 2081263920 6854697526 329 d0 / + data xgk ( 2) / 0.9491079123 4275852452 6189684047 851 d0 / + data xgk ( 3) / 0.8648644233 5976907278 9712788640 926 d0 / + data xgk ( 4) / 0.7415311855 9939443986 3864773280 788 d0 / + data xgk ( 5) / 0.5860872354 6769113029 4144838258 730 d0 / + data xgk ( 6) / 0.4058451513 7739716690 6606412076 961 d0 / + data xgk ( 7) / 0.2077849550 0789846760 0689403773 245 d0 / + data xgk ( 8) / 0.0000000000 0000000000 0000000000 000 d0 / +c + data wgk ( 1) / 0.0229353220 1052922496 3732008058 970 d0 / + data wgk ( 2) / 0.0630920926 2997855329 0700663189 204 d0 / + data wgk ( 3) / 0.1047900103 2225018383 9876322541 518 d0 / + data wgk ( 4) / 0.1406532597 1552591874 5189590510 238 d0 / + data wgk ( 5) / 0.1690047266 3926790282 6583426598 550 d0 / + data wgk ( 6) / 0.1903505780 6478540991 3256402421 014 d0 / + data wgk ( 7) / 0.2044329400 7529889241 4161999234 649 d0 / + data wgk ( 8) / 0.2094821410 8472782801 2999174891 714 d0 / +c +c +c list of major variables +c ----------------------- +c +c centr - mid point of the interval +c hlgth - half-length of the interval +c absc - abscissa +c fval* - function value +c resg - result of the 7-point gauss formula +c resk - result of the 15-point kronrod formula +c reskh - approximation to the mean value of f over (a,b), +c i.e. to i/(b-a) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement dqk15 + epmach = d1mach(4) + uflow = d1mach(1) +c + centr = 0.5d+00*(a+b) + hlgth = 0.5d+00*(b-a) + dhlgth = dabs(hlgth) +c +c compute the 15-point kronrod approximation to +c the integral, and estimate the absolute error. +c + fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + resg = fc*wg(4) + resk = fc*wgk(8) + resabs = dabs(resk) + do 10 j=1,3 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + 10 continue + do 15 j = 1,4 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + 15 continue + reskh = resk*0.5d+00 + resasc = wgk(8)*dabs(fc-reskh) + do 20 j=1,7 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) + * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 + * ((epmach*0.5d+02)*resabs,abserr) + return + end + subroutine dqk21(f,a,b,result,abserr,resabs,resasc,phi,lambda1, + & zk0,Pup,Tup,rurd,xflow,kup) +c***begin prologue dqk21 +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a2 +c***keywords 21-point gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose to compute i = integral of f over (a,b), with error +c estimate +c j = integral of abs(f) over (a,b) +c***description +c +c integration rules +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the driver program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c on return +c result - double precision +c approximation to the integral i +c result is computed by applying the 21-point +c kronrod rule (resk) obtained by optimal addition +c of abscissae to the 10-point gauss rule (resg). +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should not exceed abs(i-result) +c +c resabs - double precision +c approximation to the integral j +c +c resasc - double precision +c approximation to the integral of abs(f-i/(b-a)) +c over (a,b) +c +c***references (none) +c***routines called d1mach +c***end prologue dqk21 +c + double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, + * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, + * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup + integer j,jtw,jtwm1 + external f +c + dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11) + + d1mach(1)=1E21 + d1mach(2)=0d0 + d1mach(3)=0d0 + d1mach(4)=1E-21 +c +c the abscissae and weights are given for the interval (-1,1). +c because of symmetry only the positive abscissae and their +c corresponding weights are given. +c +c xgk - abscissae of the 21-point kronrod rule +c xgk(2), xgk(4), ... abscissae of the 10-point +c gauss rule +c xgk(1), xgk(3), ... abscissae which are optimally +c added to the 10-point gauss rule +c +c wgk - weights of the 21-point kronrod rule +c +c wg - weights of the 10-point gauss rule +c +c +c gauss quadrature weights and kronron quadrature abscissae and weights +c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +c bell labs, nov. 1981. +c + data wg ( 1) / 0.0666713443 0868813759 3568809893 332 d0 / + data wg ( 2) / 0.1494513491 5058059314 5776339657 697 d0 / + data wg ( 3) / 0.2190863625 1598204399 5534934228 163 d0 / + data wg ( 4) / 0.2692667193 0999635509 1226921569 469 d0 / + data wg ( 5) / 0.2955242247 1475287017 3892994651 338 d0 / +c + data xgk ( 1) / 0.9956571630 2580808073 5527280689 003 d0 / + data xgk ( 2) / 0.9739065285 1717172007 7964012084 452 d0 / + data xgk ( 3) / 0.9301574913 5570822600 1207180059 508 d0 / + data xgk ( 4) / 0.8650633666 8898451073 2096688423 493 d0 / + data xgk ( 5) / 0.7808177265 8641689706 3717578345 042 d0 / + data xgk ( 6) / 0.6794095682 9902440623 4327365114 874 d0 / + data xgk ( 7) / 0.5627571346 6860468333 9000099272 694 d0 / + data xgk ( 8) / 0.4333953941 2924719079 9265943165 784 d0 / + data xgk ( 9) / 0.2943928627 0146019813 1126603103 866 d0 / + data xgk ( 10) / 0.1488743389 8163121088 4826001129 720 d0 / + data xgk ( 11) / 0.0000000000 0000000000 0000000000 000 d0 / +c + data wgk ( 1) / 0.0116946388 6737187427 8064396062 192 d0 / + data wgk ( 2) / 0.0325581623 0796472747 8818972459 390 d0 / + data wgk ( 3) / 0.0547558965 7435199603 1381300244 580 d0 / + data wgk ( 4) / 0.0750396748 1091995276 7043140916 190 d0 / + data wgk ( 5) / 0.0931254545 8369760553 5065465083 366 d0 / + data wgk ( 6) / 0.1093871588 0229764189 9210590325 805 d0 / + data wgk ( 7) / 0.1234919762 6206585107 7958109831 074 d0 / + data wgk ( 8) / 0.1347092173 1147332592 8054001771 707 d0 / + data wgk ( 9) / 0.1427759385 7706008079 7094273138 717 d0 / + data wgk ( 10) / 0.1477391049 0133849137 4841515972 068 d0 / + data wgk ( 11) / 0.1494455540 0291690566 4936468389 821 d0 / +c +c +c list of major variables +c ----------------------- +c +c centr - mid point of the interval +c hlgth - half-length of the interval +c absc - abscissa +c fval* - function value +c resg - result of the 10-point gauss formula +c resk - result of the 21-point kronrod formula +c reskh - approximation to the mean value of f over (a,b), +c i.e. to i/(b-a) +c +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement dqk21 + epmach = d1mach(4) + uflow = d1mach(1) +c + centr = 0.5d+00*(a+b) + hlgth = 0.5d+00*(b-a) + dhlgth = dabs(hlgth) +c +c compute the 21-point kronrod approximation to +c the integral, and estimate the absolute error. +c + resg = 0.0d+00 + fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + resk = wgk(11)*fc + resabs = dabs(resk) + do 10 j=1,5 + jtw = 2*j + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + 10 continue + do 15 j = 1,5 + jtwm1 = 2*j-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + 15 continue + reskh = resk*0.5d+00 + resasc = wgk(11)*dabs(fc-reskh) + do 20 j=1,10 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) + * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 + * ((epmach*0.5d+02)*resabs,abserr) + return + end + subroutine dqk31(f,a,b,result,abserr,resabs,resasc,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup) +c***begin prologue dqk31 +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a2 +c***keywords 31-point gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose to compute i = integral of f over (a,b) with error +c estimate +c j = integral of abs(f) over (a,b) +c***description +c +c integration rules +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the calling program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c on return +c result - double precision +c approximation to the integral i +c result is computed by applying the 31-point +c gauss-kronrod rule (resk), obtained by optimal +c addition of abscissae to the 15-point gauss +c rule (resg). +c +c abserr - double precison +c estimate of the modulus of the modulus, +c which should not exceed abs(i-result) +c +c resabs - double precision +c approximation to the integral j +c +c resasc - double precision +c approximation to the integral of abs(f-i/(b-a)) +c over (a,b) +c +c***references (none) +c***routines called d1mach +c***end prologue dqk31 + double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, + * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, + * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup + integer j,jtw,jtwm1 + external f +c + dimension fv1(15),fv2(15),xgk(16),wgk(16),wg(8) + + d1mach(1)=1E21 + d1mach(2)=0d0 + d1mach(3)=0d0 + d1mach(4)=1E-21 +c +c the abscissae and weights are given for the interval (-1,1). +c because of symmetry only the positive abscissae and their +c corresponding weights are given. +c +c xgk - abscissae of the 31-point kronrod rule +c xgk(2), xgk(4), ... abscissae of the 15-point +c gauss rule +c xgk(1), xgk(3), ... abscissae which are optimally +c added to the 15-point gauss rule +c +c wgk - weights of the 31-point kronrod rule +c +c wg - weights of the 15-point gauss rule +c +c +c gauss quadrature weights and kronron quadrature abscissae and weights +c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +c bell labs, nov. 1981. +c + data wg ( 1) / 0.0307532419 9611726835 4628393577 204 d0 / + data wg ( 2) / 0.0703660474 8810812470 9267416450 667 d0 / + data wg ( 3) / 0.1071592204 6717193501 1869546685 869 d0 / + data wg ( 4) / 0.1395706779 2615431444 7804794511 028 d0 / + data wg ( 5) / 0.1662692058 1699393355 3200860481 209 d0 / + data wg ( 6) / 0.1861610000 1556221102 6800561866 423 d0 / + data wg ( 7) / 0.1984314853 2711157645 6118326443 839 d0 / + data wg ( 8) / 0.2025782419 2556127288 0620199967 519 d0 / +c + data xgk ( 1) / 0.9980022986 9339706028 5172840152 271 d0 / + data xgk ( 2) / 0.9879925180 2048542848 9565718586 613 d0 / + data xgk ( 3) / 0.9677390756 7913913425 7347978784 337 d0 / + data xgk ( 4) / 0.9372733924 0070590430 7758947710 209 d0 / + data xgk ( 5) / 0.8972645323 4408190088 2509656454 496 d0 / + data xgk ( 6) / 0.8482065834 1042721620 0648320774 217 d0 / + data xgk ( 7) / 0.7904185014 4246593296 7649294817 947 d0 / + data xgk ( 8) / 0.7244177313 6017004741 6186054613 938 d0 / + data xgk ( 9) / 0.6509967412 9741697053 3735895313 275 d0 / + data xgk ( 10) / 0.5709721726 0853884753 7226737253 911 d0 / + data xgk ( 11) / 0.4850818636 4023968069 3655740232 351 d0 / + data xgk ( 12) / 0.3941513470 7756336989 7207370981 045 d0 / + data xgk ( 13) / 0.2991800071 5316881216 6780024266 389 d0 / + data xgk ( 14) / 0.2011940939 9743452230 0628303394 596 d0 / + data xgk ( 15) / 0.1011420669 1871749902 7074231447 392 d0 / + data xgk ( 16) / 0.0000000000 0000000000 0000000000 000 d0 / +c + data wgk ( 1) / 0.0053774798 7292334898 7792051430 128 d0 / + data wgk ( 2) / 0.0150079473 2931612253 8374763075 807 d0 / + data wgk ( 3) / 0.0254608473 2671532018 6874001019 653 d0 / + data wgk ( 4) / 0.0353463607 9137584622 2037948478 360 d0 / + data wgk ( 5) / 0.0445897513 2476487660 8227299373 280 d0 / + data wgk ( 6) / 0.0534815246 9092808726 5343147239 430 d0 / + data wgk ( 7) / 0.0620095678 0067064028 5139230960 803 d0 / + data wgk ( 8) / 0.0698541213 1872825870 9520077099 147 d0 / + data wgk ( 9) / 0.0768496807 5772037889 4432777482 659 d0 / + data wgk ( 10) / 0.0830805028 2313302103 8289247286 104 d0 / + data wgk ( 11) / 0.0885644430 5621177064 7275443693 774 d0 / + data wgk ( 12) / 0.0931265981 7082532122 5486872747 346 d0 / + data wgk ( 13) / 0.0966427269 8362367850 5179907627 589 d0 / + data wgk ( 14) / 0.0991735987 2179195933 2393173484 603 d0 / + data wgk ( 15) / 0.1007698455 2387559504 4946662617 570 d0 / + data wgk ( 16) / 0.1013300070 1479154901 7374792767 493 d0 / +c +c +c list of major variables +c ----------------------- +c centr - mid point of the interval +c hlgth - half-length of the interval +c absc - abscissa +c fval* - function value +c resg - result of the 15-point gauss formula +c resk - result of the 31-point kronrod formula +c reskh - approximation to the mean value of f over (a,b), +c i.e. to i/(b-a) +c +c machine dependent constants +c --------------------------- +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c***first executable statement dqk31 + epmach = d1mach(4) + uflow = d1mach(1) +c + centr = 0.5d+00*(a+b) + hlgth = 0.5d+00*(b-a) + dhlgth = dabs(hlgth) +c +c compute the 31-point kronrod approximation to +c the integral, and estimate the absolute error. +c + fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + resg = wg(8)*fc + resk = wgk(16)*fc + resabs = dabs(resk) + do 10 j=1,7 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + 10 continue + do 15 j = 1,8 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + 15 continue + reskh = resk*0.5d+00 + resasc = wgk(16)*dabs(fc-reskh) + do 20 j=1,15 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) + * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 + * ((epmach*0.5d+02)*resabs,abserr) + return + end + subroutine dqk41(f,a,b,result,abserr,resabs,resasc,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup) +c***begin prologue dqk41 +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a2 +c***keywords 41-point gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose to compute i = integral of f over (a,b), with error +c estimate +c j = integral of abs(f) over (a,b) +c***description +c +c integration rules +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the calling program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c on return +c result - double precision +c approximation to the integral i +c result is computed by applying the 41-point +c gauss-kronrod rule (resk) obtained by optimal +c addition of abscissae to the 20-point gauss +c rule (resg). +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should not exceed abs(i-result) +c +c resabs - double precision +c approximation to the integral j +c +c resasc - double precision +c approximation to the integal of abs(f-i/(b-a)) +c over (a,b) +c +c***references (none) +c***routines called d1mach +c***end prologue dqk41 +c + double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, + * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, + * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup + integer j,jtw,jtwm1 + external f +c + dimension fv1(20),fv2(20),xgk(21),wgk(21),wg(10) + d1mach(1)=1E21 + d1mach(2)=0d0 + d1mach(3)=0d0 + d1mach(4)=1E-21 +c +c the abscissae and weights are given for the interval (-1,1). +c because of symmetry only the positive abscissae and their +c corresponding weights are given. +c +c xgk - abscissae of the 41-point gauss-kronrod rule +c xgk(2), xgk(4), ... abscissae of the 20-point +c gauss rule +c xgk(1), xgk(3), ... abscissae which are optimally +c added to the 20-point gauss rule +c +c wgk - weights of the 41-point gauss-kronrod rule +c +c wg - weights of the 20-point gauss rule +c +c +c gauss quadrature weights and kronron quadrature abscissae and weights +c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +c bell labs, nov. 1981. +c + data wg ( 1) / 0.0176140071 3915211831 1861962351 853 d0 / + data wg ( 2) / 0.0406014298 0038694133 1039952274 932 d0 / + data wg ( 3) / 0.0626720483 3410906356 9506535187 042 d0 / + data wg ( 4) / 0.0832767415 7670474872 4758143222 046 d0 / + data wg ( 5) / 0.1019301198 1724043503 6750135480 350 d0 / + data wg ( 6) / 0.1181945319 6151841731 2377377711 382 d0 / + data wg ( 7) / 0.1316886384 4917662689 8494499748 163 d0 / + data wg ( 8) / 0.1420961093 1838205132 9298325067 165 d0 / + data wg ( 9) / 0.1491729864 7260374678 7828737001 969 d0 / + data wg ( 10) / 0.1527533871 3072585069 8084331955 098 d0 / +c + data xgk ( 1) / 0.9988590315 8827766383 8315576545 863 d0 / + data xgk ( 2) / 0.9931285991 8509492478 6122388471 320 d0 / + data xgk ( 3) / 0.9815078774 5025025919 3342994720 217 d0 / + data xgk ( 4) / 0.9639719272 7791379126 7666131197 277 d0 / + data xgk ( 5) / 0.9408226338 3175475351 9982722212 443 d0 / + data xgk ( 6) / 0.9122344282 5132590586 7752441203 298 d0 / + data xgk ( 7) / 0.8782768112 5228197607 7442995113 078 d0 / + data xgk ( 8) / 0.8391169718 2221882339 4529061701 521 d0 / + data xgk ( 9) / 0.7950414288 3755119835 0638833272 788 d0 / + data xgk ( 10) / 0.7463319064 6015079261 4305070355 642 d0 / + data xgk ( 11) / 0.6932376563 3475138480 5490711845 932 d0 / + data xgk ( 12) / 0.6360536807 2651502545 2836696226 286 d0 / + data xgk ( 13) / 0.5751404468 1971031534 2946036586 425 d0 / + data xgk ( 14) / 0.5108670019 5082709800 4364050955 251 d0 / + data xgk ( 15) / 0.4435931752 3872510319 9992213492 640 d0 / + data xgk ( 16) / 0.3737060887 1541956067 2548177024 927 d0 / + data xgk ( 17) / 0.3016278681 1491300432 0555356858 592 d0 / + data xgk ( 18) / 0.2277858511 4164507808 0496195368 575 d0 / + data xgk ( 19) / 0.1526054652 4092267550 5220241022 678 d0 / + data xgk ( 20) / 0.0765265211 3349733375 4640409398 838 d0 / + data xgk ( 21) / 0.0000000000 0000000000 0000000000 000 d0 / +c + data wgk ( 1) / 0.0030735837 1852053150 1218293246 031 d0 / + data wgk ( 2) / 0.0086002698 5564294219 8661787950 102 d0 / + data wgk ( 3) / 0.0146261692 5697125298 3787960308 868 d0 / + data wgk ( 4) / 0.0203883734 6126652359 8010231432 755 d0 / + data wgk ( 5) / 0.0258821336 0495115883 4505067096 153 d0 / + data wgk ( 6) / 0.0312873067 7703279895 8543119323 801 d0 / + data wgk ( 7) / 0.0366001697 5820079803 0557240707 211 d0 / + data wgk ( 8) / 0.0416688733 2797368626 3788305936 895 d0 / + data wgk ( 9) / 0.0464348218 6749767472 0231880926 108 d0 / + data wgk ( 10) / 0.0509445739 2372869193 2707670050 345 d0 / + data wgk ( 11) / 0.0551951053 4828599474 4832372419 777 d0 / + data wgk ( 12) / 0.0591114008 8063957237 4967220648 594 d0 / + data wgk ( 13) / 0.0626532375 5478116802 5870122174 255 d0 / + data wgk ( 14) / 0.0658345971 3361842211 1563556969 398 d0 / + data wgk ( 15) / 0.0686486729 2852161934 5623411885 368 d0 / + data wgk ( 16) / 0.0710544235 5344406830 5790361723 210 d0 / + data wgk ( 17) / 0.0730306903 3278666749 5189417658 913 d0 / + data wgk ( 18) / 0.0745828754 0049918898 6581418362 488 d0 / + data wgk ( 19) / 0.0757044976 8455667465 9542775376 617 d0 / + data wgk ( 20) / 0.0763778676 7208073670 5502835038 061 d0 / + data wgk ( 21) / 0.0766007119 1799965644 5049901530 102 d0 / +c +c +c list of major variables +c ----------------------- +c +c centr - mid point of the interval +c hlgth - half-length of the interval +c absc - abscissa +c fval* - function value +c resg - result of the 20-point gauss formula +c resk - result of the 41-point kronrod formula +c reskh - approximation to mean value of f over (a,b), i.e. +c to i/(b-a) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement dqk41 + epmach = d1mach(4) + uflow = d1mach(1) +c + centr = 0.5d+00*(a+b) + hlgth = 0.5d+00*(b-a) + dhlgth = dabs(hlgth) +c +c compute the 41-point gauss-kronrod approximation to +c the integral, and estimate the absolute error. +c + resg = 0.0d+00 + fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + resk = wgk(21)*fc + resabs = dabs(resk) + do 10 j=1,10 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + 10 continue + do 15 j = 1,10 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + 15 continue + reskh = resk*0.5d+00 + resasc = wgk(21)*dabs(fc-reskh) + do 20 j=1,20 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0d+00.and.abserr.ne.0.d+00) + * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 + * ((epmach*0.5d+02)*resabs,abserr) + return + end + subroutine dqk51(f,a,b,result,abserr,resabs,resasc,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup) +c***begin prologue dqk51 +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a2 +c***keywords 51-point gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math & progr. div. - k.u.leuven +c***purpose to compute i = integral of f over (a,b) with error +c estimate +c j = integral of abs(f) over (a,b) +c***description +c +c integration rules +c standard fortran subroutine +c double precision version +c +c parameters +c on entry +c f - double precision +c function subroutine defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the calling program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c on return +c result - double precision +c approximation to the integral i +c result is computed by applying the 51-point +c kronrod rule (resk) obtained by optimal addition +c of abscissae to the 25-point gauss rule (resg). +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should not exceed abs(i-result) +c +c resabs - double precision +c approximation to the integral j +c +c resasc - double precision +c approximation to the integral of abs(f-i/(b-a)) +c over (a,b) +c +c***references (none) +c***routines called d1mach +c***end prologue dqk51 +c + double precision a,absc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, + * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, + * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup + integer j,jtw,jtwm1 + external f +c + dimension fv1(25),fv2(25),xgk(26),wgk(26),wg(13) + d1mach(1)=1E21 + d1mach(2)=0d0 + d1mach(3)=0d0 + d1mach(4)=1E-21 +c +c the abscissae and weights are given for the interval (-1,1). +c because of symmetry only the positive abscissae and their +c corresponding weights are given. +c +c xgk - abscissae of the 51-point kronrod rule +c xgk(2), xgk(4), ... abscissae of the 25-point +c gauss rule +c xgk(1), xgk(3), ... abscissae which are optimally +c added to the 25-point gauss rule +c +c wgk - weights of the 51-point kronrod rule +c +c wg - weights of the 25-point gauss rule +c +c +c gauss quadrature weights and kronron quadrature abscissae and weights +c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +c bell labs, nov. 1981. +c + data wg ( 1) / 0.0113937985 0102628794 7902964113 235 d0 / + data wg ( 2) / 0.0263549866 1503213726 1901815295 299 d0 / + data wg ( 3) / 0.0409391567 0130631265 5623487711 646 d0 / + data wg ( 4) / 0.0549046959 7583519192 5936891540 473 d0 / + data wg ( 5) / 0.0680383338 1235691720 7187185656 708 d0 / + data wg ( 6) / 0.0801407003 3500101801 3234959669 111 d0 / + data wg ( 7) / 0.0910282619 8296364981 1497220702 892 d0 / + data wg ( 8) / 0.1005359490 6705064420 2206890392 686 d0 / + data wg ( 9) / 0.1085196244 7426365311 6093957050 117 d0 / + data wg ( 10) / 0.1148582591 4571164833 9325545869 556 d0 / + data wg ( 11) / 0.1194557635 3578477222 8178126512 901 d0 / + data wg ( 12) / 0.1222424429 9031004168 8959518945 852 d0 / + data wg ( 13) / 0.1231760537 2671545120 3902873079 050 d0 / +c + data xgk ( 1) / 0.9992621049 9260983419 3457486540 341 d0 / + data xgk ( 2) / 0.9955569697 9049809790 8784946893 902 d0 / + data xgk ( 3) / 0.9880357945 3407724763 7331014577 406 d0 / + data xgk ( 4) / 0.9766639214 5951751149 8315386479 594 d0 / + data xgk ( 5) / 0.9616149864 2584251241 8130033660 167 d0 / + data xgk ( 6) / 0.9429745712 2897433941 4011169658 471 d0 / + data xgk ( 7) / 0.9207471152 8170156174 6346084546 331 d0 / + data xgk ( 8) / 0.8949919978 7827536885 1042006782 805 d0 / + data xgk ( 9) / 0.8658470652 9327559544 8996969588 340 d0 / + data xgk ( 10) / 0.8334426287 6083400142 1021108693 570 d0 / + data xgk ( 11) / 0.7978737979 9850005941 0410904994 307 d0 / + data xgk ( 12) / 0.7592592630 3735763057 7282865204 361 d0 / + data xgk ( 13) / 0.7177664068 1308438818 6654079773 298 d0 / + data xgk ( 14) / 0.6735663684 7346836448 5120633247 622 d0 / + data xgk ( 15) / 0.6268100990 1031741278 8122681624 518 d0 / + data xgk ( 16) / 0.5776629302 4122296772 3689841612 654 d0 / + data xgk ( 17) / 0.5263252843 3471918259 9623778158 010 d0 / + data xgk ( 18) / 0.4730027314 4571496052 2182115009 192 d0 / + data xgk ( 19) / 0.4178853821 9303774885 1814394594 572 d0 / + data xgk ( 20) / 0.3611723058 0938783773 5821730127 641 d0 / + data xgk ( 21) / 0.3030895389 3110783016 7478909980 339 d0 / + data xgk ( 22) / 0.2438668837 2098843204 5190362797 452 d0 / + data xgk ( 23) / 0.1837189394 2104889201 5969888759 528 d0 / + data xgk ( 24) / 0.1228646926 1071039638 7359818808 037 d0 / + data xgk ( 25) / 0.0615444830 0568507888 6546392366 797 d0 / + data xgk ( 26) / 0.0000000000 0000000000 0000000000 000 d0 / +c + data wgk ( 1) / 0.0019873838 9233031592 6507851882 843 d0 / + data wgk ( 2) / 0.0055619321 3535671375 8040236901 066 d0 / + data wgk ( 3) / 0.0094739733 8617415160 7207710523 655 d0 / + data wgk ( 4) / 0.0132362291 9557167481 3656405846 976 d0 / + data wgk ( 5) / 0.0168478177 0912829823 1516667536 336 d0 / + data wgk ( 6) / 0.0204353711 4588283545 6568292235 939 d0 / + data wgk ( 7) / 0.0240099456 0695321622 0092489164 881 d0 / + data wgk ( 8) / 0.0274753175 8785173780 2948455517 811 d0 / + data wgk ( 9) / 0.0307923001 6738748889 1109020215 229 d0 / + data wgk ( 10) / 0.0340021302 7432933783 6748795229 551 d0 / + data wgk ( 11) / 0.0371162714 8341554356 0330625367 620 d0 / + data wgk ( 12) / 0.0400838255 0403238207 4839284467 076 d0 / + data wgk ( 13) / 0.0428728450 2017004947 6895792439 495 d0 / + data wgk ( 14) / 0.0455029130 4992178890 9870584752 660 d0 / + data wgk ( 15) / 0.0479825371 3883671390 6392255756 915 d0 / + data wgk ( 16) / 0.0502776790 8071567196 3325259433 440 d0 / + data wgk ( 17) / 0.0523628858 0640747586 4366712137 873 d0 / + data wgk ( 18) / 0.0542511298 8854549014 4543370459 876 d0 / + data wgk ( 19) / 0.0559508112 2041231730 8240686382 747 d0 / + data wgk ( 20) / 0.0574371163 6156783285 3582693939 506 d0 / + data wgk ( 21) / 0.0586896800 2239420796 1974175856 788 d0 / + data wgk ( 22) / 0.0597203403 2417405997 9099291932 562 d0 / + data wgk ( 23) / 0.0605394553 7604586294 5360267517 565 d0 / + data wgk ( 24) / 0.0611285097 1705304830 5859030416 293 d0 / + data wgk ( 25) / 0.0614711898 7142531666 1544131965 264 d0 / +c note: wgk (26) was calculated from the values of wgk(1..25) + data wgk ( 26) / 0.0615808180 6783293507 8759824240 066 d0 / +c +c +c list of major variables +c ----------------------- +c +c centr - mid point of the interval +c hlgth - half-length of the interval +c absc - abscissa +c fval* - function value +c resg - result of the 25-point gauss formula +c resk - result of the 51-point kronrod formula +c reskh - approximation to the mean value of f over (a,b), +c i.e. to i/(b-a) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c +c***first executable statement dqk51 + epmach = d1mach(4) + uflow = d1mach(1) +c + centr = 0.5d+00*(a+b) + hlgth = 0.5d+00*(b-a) + dhlgth = dabs(hlgth) +c +c compute the 51-point kronrod approximation to +c the integral, and estimate the absolute error. +c + fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + resg = wg(13)*fc + resk = wgk(26)*fc + resabs = dabs(resk) + do 10 j=1,12 + jtw = j*2 + absc = hlgth*xgk(jtw) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + 10 continue + do 15 j = 1,13 + jtwm1 = j*2-1 + absc = hlgth*xgk(jtwm1) + fval1 = f(centr-absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+absc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + 15 continue + reskh = resk*0.5d+00 + resasc = wgk(26)*dabs(fc-reskh) + do 20 j=1,25 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) + * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 + * ((epmach*0.5d+02)*resabs,abserr) + return + end + subroutine dqk61(f,a,b,result,abserr,resabs,resasc,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup) +c***begin prologue dqk61 +c***date written 800101 (yymmdd) +c***revision date 830518 (yymmdd) +c***category no. h2a1a2 +c***keywords 61-point gauss-kronrod rules +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose to compute i = integral of f over (a,b) with error +c estimate +c j = integral of dabs(f) over (a,b) +c***description +c +c integration rule +c standard fortran subroutine +c double precision version +c +c +c parameters +c on entry +c f - double precision +c function subprogram defining the integrand +c function f(x). the actual name for f needs to be +c declared e x t e r n a l in the calling program. +c +c a - double precision +c lower limit of integration +c +c b - double precision +c upper limit of integration +c +c on return +c result - double precision +c approximation to the integral i +c result is computed by applying the 61-point +c kronrod rule (resk) obtained by optimal addition of +c abscissae to the 30-point gauss rule (resg). +c +c abserr - double precision +c estimate of the modulus of the absolute error, +c which should equal or exceed dabs(i-result) +c +c resabs - double precision +c approximation to the integral j +c +c resasc - double precision +c approximation to the integral of dabs(f-i/(b-a)) +c +c +c***references (none) +c***routines called d1mach +c***end prologue dqk61 +c + double precision a,dabsc,abserr,b,centr,dabs,dhlgth,dmax1,dmin1, + * d1mach(4),epmach,f,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs, + * resasc,resg,resk,reskh,result,uflow,wg,wgk,xgk,phi,lambda1, + * zk0,Pup,Tup,rurd,xflow,kup + integer j,jtw,jtwm1 + external f +c + dimension fv1(30),fv2(30),xgk(31),wgk(31),wg(15) + d1mach(1)=1E21 + d1mach(2)=0 + d1mach(3)=0 + d1mach(4)=1E-21 +c +c the abscissae and weights are given for the +c interval (-1,1). because of symmetry only the positive +c abscissae and their corresponding weights are given. +c +c xgk - abscissae of the 61-point kronrod rule +c xgk(2), xgk(4) ... abscissae of the 30-point +c gauss rule +c xgk(1), xgk(3) ... optimally added abscissae +c to the 30-point gauss rule +c +c wgk - weights of the 61-point kronrod rule +c +c wg - weigths of the 30-point gauss rule +c +c +c gauss quadrature weights and kronron quadrature abscissae and weights +c as evaluated with 80 decimal digit arithmetic by l. w. fullerton, +c bell labs, nov. 1981. +c + data wg ( 1) / 0.0079681924 9616660561 5465883474 674 d0 / + data wg ( 2) / 0.0184664683 1109095914 2302131912 047 d0 / + data wg ( 3) / 0.0287847078 8332336934 9719179611 292 d0 / + data wg ( 4) / 0.0387991925 6962704959 6801936446 348 d0 / + data wg ( 5) / 0.0484026728 3059405290 2938140422 808 d0 / + data wg ( 6) / 0.0574931562 1761906648 1721689402 056 d0 / + data wg ( 7) / 0.0659742298 8218049512 8128515115 962 d0 / + data wg ( 8) / 0.0737559747 3770520626 8243850022 191 d0 / + data wg ( 9) / 0.0807558952 2942021535 4694938460 530 d0 / + data wg ( 10) / 0.0868997872 0108297980 2387530715 126 d0 / + data wg ( 11) / 0.0921225222 3778612871 7632707087 619 d0 / + data wg ( 12) / 0.0963687371 7464425963 9468626351 810 d0 / + data wg ( 13) / 0.0995934205 8679526706 2780282103 569 d0 / + data wg ( 14) / 0.1017623897 4840550459 6428952168 554 d0 / + data wg ( 15) / 0.1028526528 9355884034 1285636705 415 d0 / +c + data xgk ( 1) / 0.9994844100 5049063757 1325895705 811 d0 / + data xgk ( 2) / 0.9968934840 7464954027 1630050918 695 d0 / + data xgk ( 3) / 0.9916309968 7040459485 8628366109 486 d0 / + data xgk ( 4) / 0.9836681232 7974720997 0032581605 663 d0 / + data xgk ( 5) / 0.9731163225 0112626837 4693868423 707 d0 / + data xgk ( 6) / 0.9600218649 6830751221 6871025581 798 d0 / + data xgk ( 7) / 0.9443744447 4855997941 5831324037 439 d0 / + data xgk ( 8) / 0.9262000474 2927432587 9324277080 474 d0 / + data xgk ( 9) / 0.9055733076 9990779854 6522558925 958 d0 / + data xgk ( 10) / 0.8825605357 9205268154 3116462530 226 d0 / + data xgk ( 11) / 0.8572052335 4606109895 8658510658 944 d0 / + data xgk ( 12) / 0.8295657623 8276839744 2898119732 502 d0 / + data xgk ( 13) / 0.7997278358 2183908301 3668942322 683 d0 / + data xgk ( 14) / 0.7677774321 0482619491 7977340974 503 d0 / + data xgk ( 15) / 0.7337900624 5322680472 6171131369 528 d0 / + data xgk ( 16) / 0.6978504947 9331579693 2292388026 640 d0 / + data xgk ( 17) / 0.6600610641 2662696137 0053668149 271 d0 / + data xgk ( 18) / 0.6205261829 8924286114 0477556431 189 d0 / + data xgk ( 19) / 0.5793452358 2636169175 6024932172 540 d0 / + data xgk ( 20) / 0.5366241481 4201989926 4169793311 073 d0 / + data xgk ( 21) / 0.4924804678 6177857499 3693061207 709 d0 / + data xgk ( 22) / 0.4470337695 3808917678 0609900322 854 d0 / + data xgk ( 23) / 0.4004012548 3039439253 5476211542 661 d0 / + data xgk ( 24) / 0.3527047255 3087811347 1037207089 374 d0 / + data xgk ( 25) / 0.3040732022 7362507737 2677107199 257 d0 / + data xgk ( 26) / 0.2546369261 6788984643 9805129817 805 d0 / + data xgk ( 27) / 0.2045251166 8230989143 8957671002 025 d0 / + data xgk ( 28) / 0.1538699136 0858354696 3794672743 256 d0 / + data xgk ( 29) / 0.1028069379 6673703014 7096751318 001 d0 / + data xgk ( 30) / 0.0514718425 5531769583 3025213166 723 d0 / + data xgk ( 31) / 0.0000000000 0000000000 0000000000 000 d0 / +c + data wgk ( 1) / 0.0013890136 9867700762 4551591226 760 d0 / + data wgk ( 2) / 0.0038904611 2709988405 1267201844 516 d0 / + data wgk ( 3) / 0.0066307039 1593129217 3319826369 750 d0 / + data wgk ( 4) / 0.0092732796 5951776342 8441146892 024 d0 / + data wgk ( 5) / 0.0118230152 5349634174 2232898853 251 d0 / + data wgk ( 6) / 0.0143697295 0704580481 2451432443 580 d0 / + data wgk ( 7) / 0.0169208891 8905327262 7572289420 322 d0 / + data wgk ( 8) / 0.0194141411 9394238117 3408951050 128 d0 / + data wgk ( 9) / 0.0218280358 2160919229 7167485738 339 d0 / + data wgk ( 10) / 0.0241911620 7808060136 5686370725 232 d0 / + data wgk ( 11) / 0.0265099548 8233310161 0601709335 075 d0 / + data wgk ( 12) / 0.0287540487 6504129284 3978785354 334 d0 / + data wgk ( 13) / 0.0309072575 6238776247 2884252943 092 d0 / + data wgk ( 14) / 0.0329814470 5748372603 1814191016 854 d0 / + data wgk ( 15) / 0.0349793380 2806002413 7499670731 468 d0 / + data wgk ( 16) / 0.0368823646 5182122922 3911065617 136 d0 / + data wgk ( 17) / 0.0386789456 2472759295 0348651532 281 d0 / + data wgk ( 18) / 0.0403745389 5153595911 1995279752 468 d0 / + data wgk ( 19) / 0.0419698102 1516424614 7147541285 970 d0 / + data wgk ( 20) / 0.0434525397 0135606931 6831728117 073 d0 / + data wgk ( 21) / 0.0448148001 3316266319 2355551616 723 d0 / + data wgk ( 22) / 0.0460592382 7100698811 6271735559 374 d0 / + data wgk ( 23) / 0.0471855465 6929915394 5261478181 099 d0 / + data wgk ( 24) / 0.0481858617 5708712914 0779492298 305 d0 / + data wgk ( 25) / 0.0490554345 5502977888 7528165367 238 d0 / + data wgk ( 26) / 0.0497956834 2707420635 7811569379 942 d0 / + data wgk ( 27) / 0.0504059214 0278234684 0893085653 585 d0 / + data wgk ( 28) / 0.0508817958 9874960649 2297473049 805 d0 / + data wgk ( 29) / 0.0512215478 4925877217 0656282604 944 d0 / + data wgk ( 30) / 0.0514261285 3745902593 3862879215 781 d0 / + data wgk ( 31) / 0.0514947294 2945156755 8340433647 099 d0 / +c +c list of major variables +c ----------------------- +c +c centr - mid point of the interval +c hlgth - half-length of the interval +c dabsc - abscissa +c fval* - function value +c resg - result of the 30-point gauss rule +c resk - result of the 61-point kronrod rule +c reskh - approximation to the mean value of f +c over (a,b), i.e. to i/(b-a) +c +c machine dependent constants +c --------------------------- +c +c epmach is the largest relative spacing. +c uflow is the smallest positive magnitude. +c + epmach = d1mach(4) + uflow = d1mach(1) +c + centr = 0.5d+00*(b+a) + hlgth = 0.5d+00*(b-a) + dhlgth = dabs(hlgth) +c +c compute the 61-point kronrod approximation to the +c integral, and estimate the absolute error. +c +c***first executable statement dqk61 + resg = 0.0d+00 + fc = f(centr,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + resk = wgk(31)*fc + resabs = dabs(resk) + do 10 j=1,15 + jtw = j*2 + dabsc = hlgth*xgk(jtw) + fval1 = f(centr-dabsc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+dabsc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtw) = fval1 + fv2(jtw) = fval2 + fsum = fval1+fval2 + resg = resg+wg(j)*fsum + resk = resk+wgk(jtw)*fsum + resabs = resabs+wgk(jtw)*(dabs(fval1)+dabs(fval2)) + 10 continue + do 15 j=1,15 + jtwm1 = j*2-1 + dabsc = hlgth*xgk(jtwm1) + fval1 = f(centr-dabsc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fval2 = f(centr+dabsc,phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) + fv1(jtwm1) = fval1 + fv2(jtwm1) = fval2 + fsum = fval1+fval2 + resk = resk+wgk(jtwm1)*fsum + resabs = resabs+wgk(jtwm1)*(dabs(fval1)+dabs(fval2)) + 15 continue + reskh = resk*0.5d+00 + resasc = wgk(31)*dabs(fc-reskh) + do 20 j=1,30 + resasc = resasc+wgk(j)*(dabs(fv1(j)-reskh)+dabs(fv2(j)-reskh)) + 20 continue + result = resk*hlgth + resabs = resabs*dhlgth + resasc = resasc*dhlgth + abserr = dabs((resk-resg)*hlgth) + if(resasc.ne.0.0d+00.and.abserr.ne.0.0d+00) + * abserr = resasc*dmin1(0.1d+01,(0.2d+03*abserr/resasc)**1.5d+00) + if(resabs.gt.uflow/(0.5d+02*epmach)) abserr = dmax1 + * ((epmach*0.5d+02)*resabs,abserr) + return + end + subroutine dqpsrt(limit,last,maxerr,ermax,elist,iord,nrmax, + * phi,lambda1,zk0,Pup,Tup,rurd,xflow,kup) +c***begin prologue dqpsrt +c***refer to dqage,dqagie,dqagpe,dqawse +c***routines called (none) +c***revision date 810101 (yymmdd) +c***keywords sequential sorting +c***author piessens,robert,appl. math. & progr. div. - k.u.leuven +c de doncker,elise,appl. math. & progr. div. - k.u.leuven +c***purpose this routine maintains the descending ordering in the +c list of the local error estimated resulting from the +c interval subdivision process. at each call two error +c estimates are inserted using the sequential search +c method, top-down for the largest error estimate and +c bottom-up for the smallest error estimate. +c***description +c +c ordering routine +c standard fortran subroutine +c double precision version +c +c parameters (meaning at output) +c limit - integer +c maximum number of error estimates the list +c can contain +c +c last - integer +c number of error estimates currently in the list +c +c maxerr - integer +c maxerr points to the nrmax-th largest error +c estimate currently in the list +c +c ermax - double precision +c nrmax-th largest error estimate +c ermax = elist(maxerr) +c +c elist - double precision +c vector of dimension last containing +c the error estimates +c +c iord - integer +c vector of dimension last, the first k elements +c of which contain pointers to the error +c estimates, such that +c elist(iord(1)),..., elist(iord(k)) +c form a decreasing sequence, with +c k = last if last.le.(limit/2+2), and +c k = limit+1-last otherwise +c +c nrmax - integer +c maxerr = iord(nrmax) +c +c***end prologue dqpsrt +c + double precision elist,ermax,errmax,errmin,phi,lambda1,zk0, + * Pup,Tup,rurd,xflow,kup + integer i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last,limit,maxerr, + * nrmax + dimension elist(last),iord(last) +c +c check whether the list contains more than +c two error estimates. +c +c***first executable statement dqpsrt + if(last.gt.2) go to 10 + iord(1) = 1 + iord(2) = 2 + go to 90 +c +c this part of the routine is only executed if, due to a +c difficult integrand, subdivision increased the error +c estimate. in the normal case the insert procedure should +c start after the nrmax-th largest error estimate. +c + 10 errmax = elist(maxerr) + if(nrmax.eq.1) go to 30 + ido = nrmax-1 + do 20 i = 1,ido + isucc = iord(nrmax-1) +c ***jump out of do-loop + if(errmax.le.elist(isucc)) go to 30 + iord(nrmax) = isucc + nrmax = nrmax-1 + 20 continue +c +c compute the number of elements in the list to be maintained +c in descending order. this number depends on the number of +c subdivisions still allowed. +c + 30 jupbn = last + if(last.gt.(limit/2+2)) jupbn = limit+3-last + errmin = elist(last) +c +c insert errmax by traversing the list top-down, +c starting comparison from the element elist(iord(nrmax+1)). +c + jbnd = jupbn-1 + ibeg = nrmax+1 + if(ibeg.gt.jbnd) go to 50 + do 40 i=ibeg,jbnd + isucc = iord(i) +c ***jump out of do-loop + if(errmax.ge.elist(isucc)) go to 60 + iord(i-1) = isucc + 40 continue + 50 iord(jbnd) = maxerr + iord(jupbn) = last + go to 90 +c +c insert errmin by traversing the list bottom-up. +c + 60 iord(i-1) = maxerr + k = jbnd + do 70 j=i,jbnd + isucc = iord(k) +c ***jump out of do-loop + if(errmin.lt.elist(isucc)) go to 80 + iord(k+1) = isucc + k = k-1 + 70 continue + iord(i) = last + go to 90 + 80 iord(k+1) = last +c +c set maxerr and ermax. +c + 90 maxerr = iord(nrmax) + ermax = elist(maxerr) + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/dredu.f calculix-ccx-2.3/ccx_2.3/src/dredu.f --- calculix-ccx-2.1/ccx_2.3/src/dredu.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dredu.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,36 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dredu(al,au,ad,jh,flg ,dj) + implicit real*8 (a-h,o-z) +c....reduce diagonal element in triangular decomposition + logical flg + real*8 al(jh),au(jh),ad(jh) + do 100 j = 1,jh + ud = au(j)*ad(j) + dj = dj - al(j)*ud + au(j) = ud + 100 continue +c....finish computation of column of al for unsymmetric matrices + if(flg) then + do 200 j = 1,jh + al(j) = al(j)*ad(j) + 200 continue + endif + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/drfftf.f calculix-ccx-2.3/ccx_2.3/src/drfftf.f --- calculix-ccx-2.1/ccx_2.3/src/drfftf.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/drfftf.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,596 @@ +! +! +! FFTPACK +! +!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! version 4 april 1985 +! +! a package of fortran subprograms for the fast fourier +! transform of periodic and other symmetric sequences +! +! by +! +! paul n swarztrauber +! +! national center for atmospheric research boulder,colorado 80307 +! +! which is sponsored by the national science foundation +! +! CHANGED ON 11 May 2005 by Guido Dhondt: +! 1. introduced array isave (compatibility with ifac in drfftf1) +! 2. changed real to double +! +!* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +! +! +!this package consists of programs which perform fast fourier +!transforms for both complex and real periodic sequences and +!certain other symmetric sequences that are listed below. +! +!1. drffti initialize drfftf and rfftb +!2. drfftf forward transform of a real periodic sequence +! +! +!****************************************************************** +! +!subroutine drffti(n,wsave,isave) +! +! **************************************************************** +! +!subroutine drffti initializes the array wsave which is used in +!both drfftf and rfftb. the prime factorization of n together with +!a tabulation of the trigonometric functions are computed and +!stored in wsave. +! +!input parameter +! +!n the length of the sequence to be transformed. +! +!output parameter +! +!wsave a work array which must be dimensioned at least 2*n. +! the same work array can be used for both drfftf and rfftb +! as long as n remains unchanged. different wsave arrays +! are required for different values of n. the contents of +! wsave must not be changed between calls of drfftf or rfftb. +!isave a work array which must be dimensioned at least 15. +! +!****************************************************************** +! +!subroutine drfftf(n,r,wsave,isave) +! +!****************************************************************** +! +!subroutine drfftf computes the fourier coefficients of a real +!perodic sequence (fourier analysis). the transform is defined +!below at output parameter r. +! +!input parameters +! +!n the length of the array r to be transformed. the method +! is most efficient when n is a product of small primes. +! n may change so long as different work arrays are provided +! +!r a real array of length n which contains the sequence +! to be transformed +! +!wsave a work array which must be dimensioned at least 2*n. +! in the program that calls drfftf. the wsave array must be +! initialized by calling subroutine drffti(n,wsave) and a +! different wsave array must be used for each different +! value of n. this initialization does not have to be +! repeated so long as n remains unchanged thus subsequent +! transforms can be obtained faster than the first. +! the same wsave array can be used by drfftf and rfftb. +!isave a work array which must be dimensioned at least 15. +! +! +!output parameters +! +!r r(1) = the sum from i=1 to i=n of r(i) +! +! if n is even set l =n/2 , if n is odd set l = (n+1)/2 +! +! then for k = 2,...,l +! +! r(2*k-2) = the sum from i = 1 to i = n of +! +! r(i)*cos((k-1)*(i-1)*2*pi/n) +! +! r(2*k-1) = the sum from i = 1 to i = n of +! +! -r(i)*sin((k-1)*(i-1)*2*pi/n) +! +! if n is even +! +! r(n) = the sum from i = 1 to i = n of +! +! (-1)**(i-1)*r(i) +! +! ***** note +! this transform is unnormalized since a call of drfftf +! followed by a call of rfftb will multiply the input +! sequence by n. +! +!wsave contains results which must not be destroyed between +! calls of drfftf or rfftb. +! +! + SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1) + implicit real*8(a-h,o-z) + DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , + 1 WA1(1) + DO 101 K=1,L1 + CH(1,1,K) = CC(1,K,1)+CC(1,K,2) + CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2) + 101 CONTINUE + IF (IDO-2) 107,105,102 + 102 IDP2 = IDO+2 + DO 104 K=1,L1 + DO 103 I=3,IDO,2 + IC = IDP2-I + TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + CH(I,1,K) = CC(I,K,1)+TI2 + CH(IC,2,K) = TI2-CC(I,K,1) + CH(I-1,1,K) = CC(I-1,K,1)+TR2 + CH(IC-1,2,K) = CC(I-1,K,1)-TR2 + 103 CONTINUE + 104 CONTINUE + IF (MOD(IDO,2) .EQ. 1) RETURN + 105 DO 106 K=1,L1 + CH(1,2,K) = -CC(IDO,K,2) + CH(IDO,1,K) = CC(IDO,K,1) + 106 CONTINUE + 107 RETURN + END + SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2) + implicit real*8(a-h,o-z) + DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , + 1 WA1(1) ,WA2(1) + DATA TAUR,TAUI /-.5,.866025403784439/ + DO 101 K=1,L1 + CR2 = CC(1,K,2)+CC(1,K,3) + CH(1,1,K) = CC(1,K,1)+CR2 + CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2)) + CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2 + 101 CONTINUE + IF (IDO .EQ. 1) RETURN + IDP2 = IDO+2 + DO 103 K=1,L1 + DO 102 I=3,IDO,2 + IC = IDP2-I + DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) + DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) + CR2 = DR2+DR3 + CI2 = DI2+DI3 + CH(I-1,1,K) = CC(I-1,K,1)+CR2 + CH(I,1,K) = CC(I,K,1)+CI2 + TR2 = CC(I-1,K,1)+TAUR*CR2 + TI2 = CC(I,K,1)+TAUR*CI2 + TR3 = TAUI*(DI2-DI3) + TI3 = TAUI*(DR3-DR2) + CH(I-1,3,K) = TR2+TR3 + CH(IC-1,2,K) = TR2-TR3 + CH(I,3,K) = TI2+TI3 + CH(IC,2,K) = TI3-TI2 + 102 CONTINUE + 103 CONTINUE + RETURN + END + SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3) + implicit real*8(a-h,o-z) + DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , + 1 WA1(1) ,WA2(1) ,WA3(1) + DATA HSQT2 /.7071067811865475/ + DO 101 K=1,L1 + TR1 = CC(1,K,2)+CC(1,K,4) + TR2 = CC(1,K,1)+CC(1,K,3) + CH(1,1,K) = TR1+TR2 + CH(IDO,4,K) = TR2-TR1 + CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3) + CH(1,3,K) = CC(1,K,4)-CC(1,K,2) + 101 CONTINUE + IF (IDO-2) 107,105,102 + 102 IDP2 = IDO+2 + DO 104 K=1,L1 + DO 103 I=3,IDO,2 + IC = IDP2-I + CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) + CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) + CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) + CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) + TR1 = CR2+CR4 + TR4 = CR4-CR2 + TI1 = CI2+CI4 + TI4 = CI2-CI4 + TI2 = CC(I,K,1)+CI3 + TI3 = CC(I,K,1)-CI3 + TR2 = CC(I-1,K,1)+CR3 + TR3 = CC(I-1,K,1)-CR3 + CH(I-1,1,K) = TR1+TR2 + CH(IC-1,4,K) = TR2-TR1 + CH(I,1,K) = TI1+TI2 + CH(IC,4,K) = TI1-TI2 + CH(I-1,3,K) = TI4+TR3 + CH(IC-1,2,K) = TR3-TI4 + CH(I,3,K) = TR4+TI3 + CH(IC,2,K) = TR4-TI3 + 103 CONTINUE + 104 CONTINUE + IF (MOD(IDO,2) .EQ. 1) RETURN + 105 CONTINUE + DO 106 K=1,L1 + TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4)) + TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4)) + CH(IDO,1,K) = TR1+CC(IDO,K,1) + CH(IDO,3,K) = CC(IDO,K,1)-TR1 + CH(1,2,K) = TI1-CC(IDO,K,3) + CH(1,4,K) = TI1+CC(IDO,K,3) + 106 CONTINUE + 107 RETURN + END + SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4) + implicit real*8(a-h,o-z) + DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , + 1 WA1(1) ,WA2(1) ,WA3(1) ,WA4(1) + DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, + 1-.809016994374947,.587785252292473/ + DO 101 K=1,L1 + CR2 = CC(1,K,5)+CC(1,K,2) + CI5 = CC(1,K,5)-CC(1,K,2) + CR3 = CC(1,K,4)+CC(1,K,3) + CI4 = CC(1,K,4)-CC(1,K,3) + CH(1,1,K) = CC(1,K,1)+CR2+CR3 + CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3 + CH(1,3,K) = TI11*CI5+TI12*CI4 + CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3 + CH(1,5,K) = TI12*CI5-TI11*CI4 + 101 CONTINUE + IF (IDO .EQ. 1) RETURN + IDP2 = IDO+2 + DO 103 K=1,L1 + DO 102 I=3,IDO,2 + IC = IDP2-I + DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2) + DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2) + DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3) + DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3) + DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4) + DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4) + DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5) + DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5) + CR2 = DR2+DR5 + CI5 = DR5-DR2 + CR5 = DI2-DI5 + CI2 = DI2+DI5 + CR3 = DR3+DR4 + CI4 = DR4-DR3 + CR4 = DI3-DI4 + CI3 = DI3+DI4 + CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3 + CH(I,1,K) = CC(I,K,1)+CI2+CI3 + TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3 + TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3 + TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3 + TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3 + TR5 = TI11*CR5+TI12*CR4 + TI5 = TI11*CI5+TI12*CI4 + TR4 = TI12*CR5-TI11*CR4 + TI4 = TI12*CI5-TI11*CI4 + CH(I-1,3,K) = TR2+TR5 + CH(IC-1,2,K) = TR2-TR5 + CH(I,3,K) = TI2+TI5 + CH(IC,2,K) = TI5-TI2 + CH(I-1,5,K) = TR3+TR4 + CH(IC-1,4,K) = TR3-TR4 + CH(I,5,K) = TI3+TI4 + CH(IC,4,K) = TI4-TI3 + 102 CONTINUE + 103 CONTINUE + RETURN + END + SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA) + implicit real*8(a-h,o-z) + DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , + 1 C1(IDO,L1,IP) ,C2(IDL1,IP), + 2 CH2(IDL1,IP) ,WA(1) + DATA TPI/6.28318530717959/ + ARG = TPI/FLOAT(IP) + DCP = COS(ARG) + DSP = SIN(ARG) + IPPH = (IP+1)/2 + IPP2 = IP+2 + IDP2 = IDO+2 + NBD = (IDO-1)/2 + IF (IDO .EQ. 1) GO TO 119 + DO 101 IK=1,IDL1 + CH2(IK,1) = C2(IK,1) + 101 CONTINUE + DO 103 J=2,IP + DO 102 K=1,L1 + CH(1,K,J) = C1(1,K,J) + 102 CONTINUE + 103 CONTINUE + IF (NBD .GT. L1) GO TO 107 + IS = -IDO + DO 106 J=2,IP + IS = IS+IDO + IDIJ = IS + DO 105 I=3,IDO,2 + IDIJ = IDIJ+2 + DO 104 K=1,L1 + CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) + CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) + 104 CONTINUE + 105 CONTINUE + 106 CONTINUE + GO TO 111 + 107 IS = -IDO + DO 110 J=2,IP + IS = IS+IDO + DO 109 K=1,L1 + IDIJ = IS + DO 108 I=3,IDO,2 + IDIJ = IDIJ+2 + CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J) + CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J) + 108 CONTINUE + 109 CONTINUE + 110 CONTINUE + 111 IF (NBD .LT. L1) GO TO 115 + DO 114 J=2,IPPH + JC = IPP2-J + DO 113 K=1,L1 + DO 112 I=3,IDO,2 + C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) + C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) + C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) + C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) + 112 CONTINUE + 113 CONTINUE + 114 CONTINUE + GO TO 121 + 115 DO 118 J=2,IPPH + JC = IPP2-J + DO 117 I=3,IDO,2 + DO 116 K=1,L1 + C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC) + C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC) + C1(I,K,J) = CH(I,K,J)+CH(I,K,JC) + C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J) + 116 CONTINUE + 117 CONTINUE + 118 CONTINUE + GO TO 121 + 119 DO 120 IK=1,IDL1 + C2(IK,1) = CH2(IK,1) + 120 CONTINUE + 121 DO 123 J=2,IPPH + JC = IPP2-J + DO 122 K=1,L1 + C1(1,K,J) = CH(1,K,J)+CH(1,K,JC) + C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J) + 122 CONTINUE + 123 CONTINUE +C + AR1 = 1. + AI1 = 0. + DO 127 L=2,IPPH + LC = IPP2-L + AR1H = DCP*AR1-DSP*AI1 + AI1 = DCP*AI1+DSP*AR1 + AR1 = AR1H + DO 124 IK=1,IDL1 + CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2) + CH2(IK,LC) = AI1*C2(IK,IP) + 124 CONTINUE + DC2 = AR1 + DS2 = AI1 + AR2 = AR1 + AI2 = AI1 + DO 126 J=3,IPPH + JC = IPP2-J + AR2H = DC2*AR2-DS2*AI2 + AI2 = DC2*AI2+DS2*AR2 + AR2 = AR2H + DO 125 IK=1,IDL1 + CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J) + CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC) + 125 CONTINUE + 126 CONTINUE + 127 CONTINUE + DO 129 J=2,IPPH + DO 128 IK=1,IDL1 + CH2(IK,1) = CH2(IK,1)+C2(IK,J) + 128 CONTINUE + 129 CONTINUE +C + IF (IDO .LT. L1) GO TO 132 + DO 131 K=1,L1 + DO 130 I=1,IDO + CC(I,1,K) = CH(I,K,1) + 130 CONTINUE + 131 CONTINUE + GO TO 135 + 132 DO 134 I=1,IDO + DO 133 K=1,L1 + CC(I,1,K) = CH(I,K,1) + 133 CONTINUE + 134 CONTINUE + 135 DO 137 J=2,IPPH + JC = IPP2-J + J2 = J+J + DO 136 K=1,L1 + CC(IDO,J2-2,K) = CH(1,K,J) + CC(1,J2-1,K) = CH(1,K,JC) + 136 CONTINUE + 137 CONTINUE + IF (IDO .EQ. 1) RETURN + IF (NBD .LT. L1) GO TO 141 + DO 140 J=2,IPPH + JC = IPP2-J + J2 = J+J + DO 139 K=1,L1 + DO 138 I=3,IDO,2 + IC = IDP2-I + CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) + CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) + CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) + CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) + 138 CONTINUE + 139 CONTINUE + 140 CONTINUE + RETURN + 141 DO 144 J=2,IPPH + JC = IPP2-J + J2 = J+J + DO 143 I=3,IDO,2 + IC = IDP2-I + DO 142 K=1,L1 + CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC) + CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC) + CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC) + CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J) + 142 CONTINUE + 143 CONTINUE + 144 CONTINUE + RETURN + END + SUBROUTINE dRFFTF (N,R,WSAVE,isave) + implicit real*8(a-h,o-z) + DIMENSION R(1) ,WSAVE(*),isave(*) + IF (N .EQ. 1) RETURN + CALL DRFFTF1 (N,R,WSAVE,WSAVE(N+1),isave) + RETURN + END + SUBROUTINE DRFFTF1 (N,C,CH,WA,IFAC) + implicit real*8(a-h,o-z) + DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(*) + NF = IFAC(2) + NA = 1 + L2 = N + IW = N + DO 111 K1=1,NF + KH = NF-K1 + IP = IFAC(KH+3) + L1 = L2/IP + IDO = N/L2 + IDL1 = IDO*L1 + IW = IW-(IP-1)*IDO + NA = 1-NA + IF (IP .NE. 4) GO TO 102 + IX2 = IW+IDO + IX3 = IX2+IDO + IF (NA .NE. 0) GO TO 101 + CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3)) + GO TO 110 + 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3)) + GO TO 110 + 102 IF (IP .NE. 2) GO TO 104 + IF (NA .NE. 0) GO TO 103 + CALL RADF2 (IDO,L1,C,CH,WA(IW)) + GO TO 110 + 103 CALL RADF2 (IDO,L1,CH,C,WA(IW)) + GO TO 110 + 104 IF (IP .NE. 3) GO TO 106 + IX2 = IW+IDO + IF (NA .NE. 0) GO TO 105 + CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2)) + GO TO 110 + 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2)) + GO TO 110 + 106 IF (IP .NE. 5) GO TO 108 + IX2 = IW+IDO + IX3 = IX2+IDO + IX4 = IX3+IDO + IF (NA .NE. 0) GO TO 107 + CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4)) + GO TO 110 + 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4)) + GO TO 110 + 108 IF (IDO .EQ. 1) NA = 1-NA + IF (NA .NE. 0) GO TO 109 + CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW)) + NA = 1 + GO TO 110 + 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW)) + NA = 0 + 110 L2 = L1 + 111 CONTINUE + IF (NA .EQ. 1) RETURN + DO 112 I=1,N + C(I) = CH(I) + 112 CONTINUE + RETURN + END + SUBROUTINE dRFFTI (N,WSAVE,isave) + implicit real*8(a-h,o-z) + DIMENSION WSAVE(*),isave(*) + IF (N .EQ. 1) RETURN + CALL DRFFTI1 (N,WSAVE(N+1),isave) + RETURN + END + SUBROUTINE DRFFTI1 (N,WA,IFAC) + implicit real*8(a-h,o-z) + DIMENSION WA(1) ,IFAC(*) ,NTRYH(4) + DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ + NL = N + NF = 0 + J = 0 + 101 J = J+1 + IF (J-4) 102,102,103 + 102 NTRY = NTRYH(J) + GO TO 104 + 103 NTRY = NTRY+2 + 104 NQ = NL/NTRY + NR = NL-NTRY*NQ + IF (NR) 101,105,101 + 105 NF = NF+1 + IFAC(NF+2) = NTRY + NL = NQ + IF (NTRY .NE. 2) GO TO 107 + IF (NF .EQ. 1) GO TO 107 + DO 106 I=2,NF + IB = NF-I+2 + IFAC(IB+2) = IFAC(IB+1) + 106 CONTINUE + IFAC(3) = 2 + 107 IF (NL .NE. 1) GO TO 104 + IFAC(1) = N + IFAC(2) = NF + TPI = 6.28318530717959 + ARGH = TPI/FLOAT(N) + IS = 0 + NFM1 = NF-1 + L1 = 1 + IF (NFM1 .EQ. 0) RETURN + DO 110 K1=1,NFM1 + IP = IFAC(K1+2) + LD = 0 + L2 = L1*IP + IDO = N/L2 + IPM = IP-1 + DO 109 J=1,IPM + LD = LD+L1 + I = IS + ARGLD = FLOAT(LD)*ARGH + FI = 0. + DO 108 II=3,IDO,2 + I = I+2 + FI = FI+1. + ARG = FI*ARGLD + WA(I-1) = COS(ARG) + WA(I) = SIN(ARG) + 108 CONTINUE + IS = IS+IDO + 109 CONTINUE + L1 = L2 + 110 CONTINUE + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/dsort.f calculix-ccx-2.3/ccx_2.3/src/dsort.f --- calculix-ccx-2.1/ccx_2.3/src/dsort.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dsort.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,333 @@ +*DECK DSORT + SUBROUTINE DSORT (DX, IY, N, KFLAG) +c +c slight change: XERMSG was removed; error messages are +c led to the screen +c +C***BEGIN PROLOGUE DSORT +C***PURPOSE Sort an array and optionally make the same interchanges in +C an auxiliary array. The array may be sorted in increasing +C or decreasing order. A slightly modified QUICKSORT +C algorithm is used. +C***LIBRARY SLATEC +C***CATEGORY N6A2B +C***TYPE DOUBLE PRECISION (SSORT-S, DSORT-D, ISORT-I) +C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING +C***AUTHOR Jones, R. E., (SNLA) +C Wisniewski, J. A., (SNLA) +C***ROUTINES CALLED XERMSG +C***DESCRIPTION +C +C DSORT sorts array DX and optionally makes the same interchanges in +C array IY. The array DX may be sorted in increasing order or +C decreasing order. A slightly modified quicksort algorithm is used. +C +C Description of Parameters +C DX - array of values to be sorted (usually abscissas) +C IY - array to be (optionally) carried along +C N - number of values in array DX to be sorted +C KFLAG - control parameter +C = 2 means sort DX in increasing order and carry IY along. +C = 1 means sort DX in increasing order (ignoring IY) +C = -1 means sort DX in decreasing order (ignoring IY) +C = -2 means sort DX in decreasing order and carry IY along. +C +C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm +C for sorting with minimal storage, Communications of +C the ACM, 12, 3 (1969), pp. 185-187. +C***REVISION HISTORY (YYMMDD) +C 761101 DATE WRITTEN +C 761118 Modified to use the Singleton quicksort algorithm. (JAW) +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891009 Removed unreferenced statement labels. (WRB) +C 891024 Changed category. (WRB) +C 891024 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901012 Declared all variables; changed X,Y to DX,IY; changed +C code to parallel SSORT. (M. McClain) +C 920501 Reformatted the REFERENCES section. (DWL, WRB) +C 920519 Clarified error messages. (DWL) +C 920801 Declarations section rebuilt and code restructured to use +C IF-THEN-ELSE-ENDIF. (RWC, WRB) +! 100411 changed the dimension of IL and IU from 21 to 31. +! +! field IL and IU have the dimension 31. This is log2 of the largest +! array size to be sorted. If arrays larger than 2**31 in length have +! to be sorted, this dimension has to be modified accordingly +! +C***END PROLOGUE DSORT +C .. Scalar Arguments .. + INTEGER KFLAG, N,IY(*),TY,TTY +C .. Array Arguments .. + DOUBLE PRECISION DX(*) +C .. Local Scalars .. + DOUBLE PRECISION R, T, TT + INTEGER I, IJ, J, K, KK, L, M, NN +C .. Local Arrays .. + INTEGER IL(31), IU(31) +C .. External Subroutines .. +c EXTERNAL XERMSG +C .. Intrinsic Functions .. + INTRINSIC ABS, INT +C***FIRST EXECUTABLE STATEMENT DSORT + NN = N + IF (NN .LT. 1) THEN + write(*,*) '*ERROR in dsort: the number of values to be' + write(*,*) ' sorted is not positive' + stop + ENDIF +C + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN + write(*,*) '*ERROR in dsort: the sort control parameter is' + write(*,*) ' not 2, 1, -1 or -2' + stop + ENDIF +C +C Alter array DX to get decreasing order if needed +C + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + DX(I) = -DX(I) + 10 CONTINUE + ENDIF +C + IF (KK .EQ. 2) GO TO 100 +C +C Sort DX only +C + M = 1 + I = 1 + J = NN + R = 0.375D0 +C + 20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437D0) THEN + R = R+3.90625D-2 + ELSE + R = R-0.21875D0 + ENDIF +C + 30 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = DX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (DX(I) .GT. T) THEN + DX(IJ) = DX(I) + DX(I) = T + T = DX(IJ) + ENDIF + L = J +C +C If last element of array is less than than T, interchange with T +C + IF (DX(J) .LT. T) THEN + DX(IJ) = DX(J) + DX(J) = T + T = DX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (DX(I) .GT. T) THEN + DX(IJ) = DX(I) + DX(I) = T + T = DX(IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 40 L = L-1 + IF (DX(L) .GT. T) GO TO 40 +C +C Find an element in the first half of the array which is greater +C than T +C + 50 K = K+1 + IF (DX(K) .LT. T) GO TO 50 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = DX(L) + DX(L) = DX(K) + DX(K) = TT + GO TO 40 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 +C +C Begin again on another portion of the unsorted array +C + 60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 +C + 80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = DX(I+1) + IF (DX(I) .LE. T) GO TO 80 + K = I +C + 90 DX(K+1) = DX(K) + K = K-1 + IF (T .LT. DX(K)) GO TO 90 + DX(K+1) = T + GO TO 80 +C +C Sort DX and carry IY along +C + 100 M = 1 + I = 1 + J = NN + R = 0.375D0 +C + 110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437D0) THEN + R = R+3.90625D-2 + ELSE + R = R-0.21875D0 + ENDIF +C + 120 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = DX(IJ) + TY = IY(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (DX(I) .GT. T) THEN + DX(IJ) = DX(I) + DX(I) = T + T = DX(IJ) + IY(IJ) = IY(I) + IY(I) = TY + TY = IY(IJ) + ENDIF + L = J +C +C If last element of array is less than T, interchange with T +C + IF (DX(J) .LT. T) THEN + DX(IJ) = DX(J) + DX(J) = T + T = DX(IJ) + IY(IJ) = IY(J) + IY(J) = TY + TY = IY(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (DX(I) .GT. T) THEN + DX(IJ) = DX(I) + DX(I) = T + T = DX(IJ) + IY(IJ) = IY(I) + IY(I) = TY + TY = IY(IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 130 L = L-1 + IF (DX(L) .GT. T) GO TO 130 +C +C Find an element in the first half of the array which is greater +C than T +C + 140 K = K+1 + IF (DX(K) .LT. T) GO TO 140 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = DX(L) + DX(L) = DX(K) + DX(K) = TT + TTY = IY(L) + IY(L) = IY(K) + IY(K) = TTY + GO TO 130 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 +C +C Begin again on another portion of the unsorted array +C + 150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 +C + 170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = DX(I+1) + TY = IY(I+1) + IF (DX(I) .LE. T) GO TO 170 + K = I +C + 180 DX(K+1) = DX(K) + IY(K+1) = IY(K) + K = K-1 + IF (T .LT. DX(K)) GO TO 180 + DX(K+1) = T + IY(K+1) = TY + GO TO 170 +C +C Clean up +C + 190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + DX(I) = -DX(I) + 200 CONTINUE + ENDIF + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/dsptri.f calculix-ccx-2.3/ccx_2.3/src/dsptri.f --- calculix-ccx-2.1/ccx_2.3/src/dsptri.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dsptri.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1454 @@ + SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AP( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DSPTRI computes the inverse of a real symmetric indefinite matrix +* A in packed storage using the factorization A = U*D*U**T or +* A = L*D*L**T computed by DSPTRF. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the details of the factorization are stored +* as an upper or lower triangular matrix. +* = 'U': Upper triangular, form is A = U*D*U**T; +* = 'L': Lower triangular, form is A = L*D*L**T. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) +* On entry, the block diagonal matrix D and the multipliers +* used to obtain the factor U or L as computed by DSPTRF, +* stored as a packed triangular matrix. +* +* On exit, if INFO = 0, the (symmetric) inverse of the original +* matrix, stored as a packed triangular matrix. The j-th column +* of inv(A) is stored in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; +* if UPLO = 'L', +* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. +* +* IPIV (input) INTEGER array, dimension (N) +* Details of the interchanges and the block structure of D +* as determined by DSPTRF. +* +* WORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its +* inverse could not be computed. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP + DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DSPMV, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPTRI', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* +* Check that the diagonal matrix D is nonsingular. +* + IF( UPPER ) THEN +* +* Upper triangular storage: examine D from bottom to top +* + KP = N*( N+1 ) / 2 + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) + $ RETURN + KP = KP - INFO + 10 CONTINUE + ELSE +* +* Lower triangular storage: examine D from top to bottom. +* + KP = 1 + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO ) + $ RETURN + KP = KP + N - INFO + 1 + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* Compute inv(A) from the factorization A = U*D*U'. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + K = 1 + KC = 1 + 30 CONTINUE +* +* If K > N, exit from loop. +* + IF( K.GT.N ) + $ GO TO 50 +* + KCNEXT = KC + K + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + AP( KC+K-1 ) = ONE / AP( KC+K-1 ) +* +* Compute column K of the inverse. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 ) + CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), + $ 1 ) + AP( KC+K-1 ) = AP( KC+K-1 ) - + $ DDOT( K-1, WORK, 1, AP( KC ), 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( AP( KCNEXT+K-1 ) ) + AK = AP( KC+K-1 ) / T + AKP1 = AP( KCNEXT+K ) / T + AKKP1 = AP( KCNEXT+K-1 ) / T + D = T*( AK*AKP1-ONE ) + AP( KC+K-1 ) = AKP1 / D + AP( KCNEXT+K ) = AK / D + AP( KCNEXT+K-1 ) = -AKKP1 / D +* +* Compute columns K and K+1 of the inverse. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 ) + CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ), + $ 1 ) + AP( KC+K-1 ) = AP( KC+K-1 ) - + $ DDOT( K-1, WORK, 1, AP( KC ), 1 ) + AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) - + $ DDOT( K-1, AP( KC ), 1, AP( KCNEXT ), + $ 1 ) + CALL DCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 ) + CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, + $ AP( KCNEXT ), 1 ) + AP( KCNEXT+K ) = AP( KCNEXT+K ) - + $ DDOT( K-1, WORK, 1, AP( KCNEXT ), 1 ) + END IF + KSTEP = 2 + KCNEXT = KCNEXT + K + 1 + END IF +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN +* +* Interchange rows and columns K and KP in the leading +* submatrix A(1:k+1,1:k+1) +* + KPC = ( KP-1 )*KP / 2 + 1 + CALL DSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 ) + KX = KPC + KP - 1 + DO 40 J = KP + 1, K - 1 + KX = KX + J - 1 + TEMP = AP( KC+J-1 ) + AP( KC+J-1 ) = AP( KX ) + AP( KX ) = TEMP + 40 CONTINUE + TEMP = AP( KC+K-1 ) + AP( KC+K-1 ) = AP( KPC+KP-1 ) + AP( KPC+KP-1 ) = TEMP + IF( KSTEP.EQ.2 ) THEN + TEMP = AP( KC+K+K-1 ) + AP( KC+K+K-1 ) = AP( KC+K+KP-1 ) + AP( KC+K+KP-1 ) = TEMP + END IF + END IF +* + K = K + KSTEP + KC = KCNEXT + GO TO 30 + 50 CONTINUE +* + ELSE +* +* Compute inv(A) from the factorization A = L*D*L'. +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2, depending on the size of the diagonal blocks. +* + NPP = N*( N+1 ) / 2 + K = N + KC = NPP + 60 CONTINUE +* +* If K < 1, exit from loop. +* + IF( K.LT.1 ) + $ GO TO 80 +* + KCNEXT = KC - ( N-K+2 ) + IF( IPIV( K ).GT.0 ) THEN +* +* 1 x 1 diagonal block +* +* Invert the diagonal block. +* + AP( KC ) = ONE / AP( KC ) +* +* Compute column K of the inverse. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 ) + CALL DSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1, + $ ZERO, AP( KC+1 ), 1 ) + AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 x 2 diagonal block +* +* Invert the diagonal block. +* + T = ABS( AP( KCNEXT+1 ) ) + AK = AP( KCNEXT ) / T + AKP1 = AP( KC ) / T + AKKP1 = AP( KCNEXT+1 ) / T + D = T*( AK*AKP1-ONE ) + AP( KCNEXT ) = AKP1 / D + AP( KC ) = AK / D + AP( KCNEXT+1 ) = -AKKP1 / D +* +* Compute columns K-1 and K of the inverse. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 ) + CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, + $ ZERO, AP( KC+1 ), 1 ) + AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 ) + AP( KCNEXT+1 ) = AP( KCNEXT+1 ) - + $ DDOT( N-K, AP( KC+1 ), 1, + $ AP( KCNEXT+2 ), 1 ) + CALL DCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 ) + CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1, + $ ZERO, AP( KCNEXT+2 ), 1 ) + AP( KCNEXT ) = AP( KCNEXT ) - + $ DDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 ) + END IF + KSTEP = 2 + KCNEXT = KCNEXT - ( N-K+3 ) + END IF +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN +* +* Interchange rows and columns K and KP in the trailing +* submatrix A(k-1:n,k-1:n) +* + KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1 + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 ) + KX = KC + KP - K + DO 70 J = K + 1, KP - 1 + KX = KX + N - J + 1 + TEMP = AP( KC+J-K ) + AP( KC+J-K ) = AP( KX ) + AP( KX ) = TEMP + 70 CONTINUE + TEMP = AP( KC ) + AP( KC ) = AP( KPC ) + AP( KPC ) = TEMP + IF( KSTEP.EQ.2 ) THEN + TEMP = AP( KC-N+K-1 ) + AP( KC-N+K-1 ) = AP( KC-N+KP-1 ) + AP( KC-N+KP-1 ) = TEMP + END IF + END IF +* + K = K - KSTEP + KC = KCNEXT + GO TO 60 + 80 CONTINUE + END IF +* + RETURN +* +* End of DSPTRI +* + END + SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO ) +* +* -- LAPACK routine (version 3.2) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, N +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AP( * ) +* .. +* +* Purpose +* ======= +* +* DSPTRF computes the factorization of a real symmetric matrix A stored +* in packed format using the Bunch-Kaufman diagonal pivoting method: +* +* A = U*D*U**T or A = L*D*L**T +* +* where U (or L) is a product of permutation and unit upper (lower) +* triangular matrices, and D is symmetric and block diagonal with +* 1-by-1 and 2-by-2 diagonal blocks. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2) +* On entry, the upper or lower triangle of the symmetric matrix +* A, packed columnwise in a linear array. The j-th column of A +* is stored in the array AP as follows: +* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; +* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. +* +* On exit, the block diagonal matrix D and the multipliers used +* to obtain the factor U or L, stored as a packed triangular +* matrix overwriting A (see below for further details). +* +* IPIV (output) INTEGER array, dimension (N) +* Details of the interchanges and the block structure of D. +* If IPIV(k) > 0, then rows and columns k and IPIV(k) were +* interchanged and D(k,k) is a 1-by-1 diagonal block. +* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and +* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) +* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = +* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were +* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* > 0: if INFO = i, D(i,i) is exactly zero. The factorization +* has been completed, but the block diagonal matrix D is +* exactly singular, and division by zero will occur if it +* is used to solve a system of equations. +* +* Further Details +* =============== +* +* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services +* Company +* +* If UPLO = 'U', then A = U*D*U', where +* U = P(n)*U(n)* ... *P(k)U(k)* ..., +* i.e., U is a product of terms P(k)*U(k), where k decreases from n to +* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such +* that if the diagonal block D(k) is of order s (s = 1 or 2), then +* +* ( I v 0 ) k-s +* U(k) = ( 0 I 0 ) s +* ( 0 0 I ) n-k +* k-s s n-k +* +* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). +* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), +* and A(k,k), and v overwrites A(1:k-2,k-1:k). +* +* If UPLO = 'L', then A = L*D*L', where +* L = P(1)*L(1)* ... *P(k)*L(k)* ..., +* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to +* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 +* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as +* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such +* that if the diagonal block D(k) is of order s (s = 1 or 2), then +* +* ( I 0 0 ) k-1 +* L(k) = ( 0 I 0 ) s +* ( 0 v I ) n-k-s+1 +* k-1 s n-k-s+1 +* +* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). +* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), +* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC, + $ KSTEP, KX, NPP + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1, + $ ROWMAX, T, WK, WKM1, WKP1 +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSPR, DSWAP, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSPTRF', -INFO ) + RETURN + END IF +* +* Initialize ALPHA for use in choosing pivot block size. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* + IF( UPPER ) THEN +* +* Factorize A as U*D*U' using the upper triangle of A +* +* K is the main loop index, decreasing from N to 1 in steps of +* 1 or 2 +* + K = N + KC = ( N-1 )*N / 2 + 1 + 10 CONTINUE + KNC = KC +* +* If K < 1, exit from loop +* + IF( K.LT.1 ) + $ GO TO 110 + KSTEP = 1 +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( AP( KC+K-1 ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, AP( KC ), 1 ) + COLMAX = ABS( AP( KC+IMAX-1 ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value +* + ROWMAX = ZERO + JMAX = IMAX + KX = IMAX*( IMAX+1 ) / 2 + IMAX + DO 20 J = IMAX + 1, K + IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN + ROWMAX = ABS( AP( KX ) ) + JMAX = J + END IF + KX = KX + J + 20 CONTINUE + KPC = ( IMAX-1 )*IMAX / 2 + 1 + IF( IMAX.GT.1 ) THEN + JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN +* +* interchange rows and columns K and IMAX, use 1-by-1 +* pivot block +* + KP = IMAX + ELSE +* +* interchange rows and columns K-1 and IMAX, use 2-by-2 +* pivot block +* + KP = IMAX + KSTEP = 2 + END IF + END IF +* + KK = K - KSTEP + 1 + IF( KSTEP.EQ.2 ) + $ KNC = KNC - K + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the leading +* submatrix A(1:k,1:k) +* + CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 ) + KX = KPC + KP - 1 + DO 30 J = KP + 1, KK - 1 + KX = KX + J - 1 + T = AP( KNC+J-1 ) + AP( KNC+J-1 ) = AP( KX ) + AP( KX ) = T + 30 CONTINUE + T = AP( KNC+KK-1 ) + AP( KNC+KK-1 ) = AP( KPC+KP-1 ) + AP( KPC+KP-1 ) = T + IF( KSTEP.EQ.2 ) THEN + T = AP( KC+K-2 ) + AP( KC+K-2 ) = AP( KC+KP-1 ) + AP( KC+KP-1 ) = T + END IF + END IF +* +* Update the leading submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = U(k)*D(k) +* +* where U(k) is the k-th column of U +* +* Perform a rank-1 update of A(1:k-1,1:k-1) as +* +* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)' +* + R1 = ONE / AP( KC+K-1 ) + CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP ) +* +* Store U(k) in column k +* + CALL DSCAL( K-1, R1, AP( KC ), 1 ) + ELSE +* +* 2-by-2 pivot block D(k): columns k and k-1 now hold +* +* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) +* +* where U(k) and U(k-1) are the k-th and (k-1)-th columns +* of U +* +* Perform a rank-2 update of A(1:k-2,1:k-2) as +* +* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )' +* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )' +* + IF( K.GT.2 ) THEN +* + D12 = AP( K-1+( K-1 )*K / 2 ) + D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12 + D11 = AP( K+( K-1 )*K / 2 ) / D12 + T = ONE / ( D11*D22-ONE ) + D12 = T / D12 +* + DO 50 J = K - 2, 1, -1 + WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )- + $ AP( J+( K-1 )*K / 2 ) ) + WK = D12*( D22*AP( J+( K-1 )*K / 2 )- + $ AP( J+( K-2 )*( K-1 ) / 2 ) ) + DO 40 I = J, 1, -1 + AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) - + $ AP( I+( K-1 )*K / 2 )*WK - + $ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1 + 40 CONTINUE + AP( J+( K-1 )*K / 2 ) = WK + AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1 + 50 CONTINUE +* + END IF +* + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K-1 ) = -KP + END IF +* +* Decrease K and return to the start of the main loop +* + K = K - KSTEP + KC = KNC - K + GO TO 10 +* + ELSE +* +* Factorize A as L*D*L' using the lower triangle of A +* +* K is the main loop index, increasing from 1 to N in steps of +* 1 or 2 +* + K = 1 + KC = 1 + NPP = N*( N+1 ) / 2 + 60 CONTINUE + KNC = KC +* +* If K > N, exit from loop +* + IF( K.GT.N ) + $ GO TO 110 + KSTEP = 1 +* +* Determine rows and columns to be interchanged and whether +* a 1-by-1 or 2-by-2 pivot block will be used +* + ABSAKK = ABS( AP( KC ) ) +* +* IMAX is the row-index of the largest off-diagonal element in +* column K, and COLMAX is its absolute value +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 ) + COLMAX = ABS( AP( KC+IMAX-K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* Column K is zero: set INFO and continue +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE +* +* JMAX is the column-index of the largest off-diagonal +* element in row IMAX, and ROWMAX is its absolute value +* + ROWMAX = ZERO + KX = KC + IMAX - K + DO 70 J = K, IMAX - 1 + IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN + ROWMAX = ABS( AP( KX ) ) + JMAX = J + END IF + KX = KX + N - J + 70 CONTINUE + KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1 + IF( IMAX.LT.N ) THEN + JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* no interchange, use 1-by-1 pivot block +* + KP = K + ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN +* +* interchange rows and columns K and IMAX, use 1-by-1 +* pivot block +* + KP = IMAX + ELSE +* +* interchange rows and columns K+1 and IMAX, use 2-by-2 +* pivot block +* + KP = IMAX + KSTEP = 2 + END IF + END IF +* + KK = K + KSTEP - 1 + IF( KSTEP.EQ.2 ) + $ KNC = KNC + N - K + 1 + IF( KP.NE.KK ) THEN +* +* Interchange rows and columns KK and KP in the trailing +* submatrix A(k:n,k:n) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ), + $ 1 ) + KX = KNC + KP - KK + DO 80 J = KK + 1, KP - 1 + KX = KX + N - J + 1 + T = AP( KNC+J-KK ) + AP( KNC+J-KK ) = AP( KX ) + AP( KX ) = T + 80 CONTINUE + T = AP( KNC ) + AP( KNC ) = AP( KPC ) + AP( KPC ) = T + IF( KSTEP.EQ.2 ) THEN + T = AP( KC+1 ) + AP( KC+1 ) = AP( KC+KP-K ) + AP( KC+KP-K ) = T + END IF + END IF +* +* Update the trailing submatrix +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-by-1 pivot block D(k): column k now holds +* +* W(k) = L(k)*D(k) +* +* where L(k) is the k-th column of L +* + IF( K.LT.N ) THEN +* +* Perform a rank-1 update of A(k+1:n,k+1:n) as +* +* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)' +* + R1 = ONE / AP( KC ) + CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1, + $ AP( KC+N-K+1 ) ) +* +* Store L(k) in column K +* + CALL DSCAL( N-K, R1, AP( KC+1 ), 1 ) + END IF + ELSE +* +* 2-by-2 pivot block D(k): columns K and K+1 now hold +* +* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) +* +* where L(k) and L(k+1) are the k-th and (k+1)-th columns +* of L +* + IF( K.LT.N-1 ) THEN +* +* Perform a rank-2 update of A(k+2:n,k+2:n) as +* +* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )' +* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )' +* + D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 ) + D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21 + D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21 + T = ONE / ( D11*D22-ONE ) + D21 = T / D21 +* + DO 100 J = K + 2, N + WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )- + $ AP( J+K*( 2*N-K-1 ) / 2 ) ) + WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )- + $ AP( J+( K-1 )*( 2*N-K ) / 2 ) ) +* + DO 90 I = J, N + AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )* + $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) / + $ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1 + 90 CONTINUE +* + AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK + AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1 +* + 100 CONTINUE + END IF + END IF + END IF +* +* Store details of the interchanges in IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K+1 ) = -KP + END IF +* +* Increase K and return to the start of the main loop +* + K = K + KSTEP + KC = KNC + N - K + 2 + GO TO 60 +* + END IF +* + 110 CONTINUE + RETURN +* +* End of DSPTRF +* + END + +* BLAS REQUIRED BY LAPACK ROUTINE: dsptri +* ----------------------------------------------------------- +* Note: Link to BLAS optimized for your system, if available. +* ----------------------------------------------------------- + + subroutine dcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end + double precision function ddot(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddot = dtemp + return + end + SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DSPMV performs the matrix-vector operation +* +* y := alpha*A*x + beta*y, +* +* where alpha and beta are scalars, x and y are n element vectors and +* A is an n by n symmetric matrix, supplied in packed form. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the upper or lower +* triangular part of the matrix A is supplied in the packed +* array AP as follows: +* +* UPLO = 'U' or 'u' The upper triangular part of A is +* supplied in AP. +* +* UPLO = 'L' or 'l' The lower triangular part of A is +* supplied in AP. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* AP - DOUBLE PRECISION array of DIMENSION at least +* ( ( n*( n + 1 ) )/2 ). +* Before entry with UPLO = 'U' or 'u', the array AP must +* contain the upper triangular part of the symmetric matrix +* packed sequentially, column by column, so that AP( 1 ) +* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +* and a( 2, 2 ) respectively, and so on. +* Before entry with UPLO = 'L' or 'l', the array AP must +* contain the lower triangular part of the symmetric matrix +* packed sequentially, column by column, so that AP( 1 ) +* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +* and a( 3, 1 ) respectively, and so on. +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the n +* element vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCY ) ). +* Before entry, the incremented array Y must contain the n +* element vector y. On exit, Y is overwritten by the updated +* vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 6 + ELSE IF( INCY.EQ.0 )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSPMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set up the start points in X and Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* +* First form y := beta*y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, N + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, N + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, N + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, N + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form y when AP contains the upper triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + K = KK + DO 50, I = 1, J - 1 + Y( I ) = Y( I ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( I ) + K = K + 1 + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 + KK = KK + J + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70, K = KK, KK + J - 2 + Y( IY ) = Y( IY ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 80 CONTINUE + END IF + ELSE +* +* Form y when AP contains the lower triangle. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 100, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + Y( J ) = Y( J ) + TEMP1*AP( KK ) + K = KK + 1 + DO 90, I = J + 1, N + Y( I ) = Y( I ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( I ) + K = K + 1 + 90 CONTINUE + Y( J ) = Y( J ) + ALPHA*TEMP2 + KK = KK + ( N - J + 1 ) + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + Y( JY ) = Y( JY ) + TEMP1*AP( KK ) + IX = JX + IY = JY + DO 110, K = KK + 1, KK + N - J + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( IX ) + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + ( N - J + 1 ) + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPMV . +* + END + +* BLAS REQUIRED BY LAPACK ROUTINE: dsptrf +* ----------------------------------------------------------- +* Note: Link to BLAS optimized for your system, if available. +* ----------------------------------------------------------- + + SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX, N + CHARACTER*1 UPLO +* .. Array Arguments .. + DOUBLE PRECISION AP( * ), X( * ) +* .. +* +* Purpose +* ======= +* +* DSPR performs the symmetric rank 1 operation +* +* A := alpha*x*x' + A, +* +* where alpha is a real scalar, x is an n element vector and A is an +* n by n symmetric matrix, supplied in packed form. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the upper or lower +* triangular part of the matrix A is supplied in the packed +* array AP as follows: +* +* UPLO = 'U' or 'u' The upper triangular part of A is +* supplied in AP. +* +* UPLO = 'L' or 'l' The lower triangular part of A is +* supplied in AP. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of dimension at least +* ( 1 + ( n - 1 )*abs( INCX ) ). +* Before entry, the incremented array X must contain the n +* element vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* AP - DOUBLE PRECISION array of DIMENSION at least +* ( ( n*( n + 1 ) )/2 ). +* Before entry with UPLO = 'U' or 'u', the array AP must +* contain the upper triangular part of the symmetric matrix +* packed sequentially, column by column, so that AP( 1 ) +* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) +* and a( 2, 2 ) respectively, and so on. On exit, the array +* AP is overwritten by the upper triangular part of the +* updated matrix. +* Before entry with UPLO = 'L' or 'l', the array AP must +* contain the lower triangular part of the symmetric matrix +* packed sequentially, column by column, so that AP( 1 ) +* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) +* and a( 3, 1 ) respectively, and so on. On exit, the array +* AP is overwritten by the lower triangular part of the +* updated matrix. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSPR ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* Set the start point in X if the increment is not unity. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* Start the operations. In this version the elements of the array AP +* are accessed sequentially with one pass through AP. +* + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* Form A when upper triangle is stored in AP. +* + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + K = KK + DO 10, I = 1, J + AP( K ) = AP( K ) + X( I )*TEMP + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = KX + DO 30, K = KK, KK + J - 1 + AP( K ) = AP( K ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* Form A when lower triangle is stored in AP. +* + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + K = KK + DO 50, I = J, N + AP( K ) = AP( K ) + X( I )*TEMP + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = JX + DO 70, K = KK, KK + N - J + AP( K ) = AP( K ) + X( IX )*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSPR . +* + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/dualshape3tri.f calculix-ccx-2.3/ccx_2.3/src/dualshape3tri.f --- calculix-ccx-2.1/ccx_2.3/src/dualshape3tri.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dualshape3tri.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,113 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dualshape3tri(xi,et,xl,xsj,xs,shp,iflag) +! +! shape functions and derivatives for a 3-node linear +! isoparametric triangular element. 0<=xi,et<=1,xi+et<=1 +! +! iflag=2: calculate the value of the shape functions, +! their derivatives w.r.t. the local coordinates +! and the Jacobian vector (local normal to the +! surface) +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian vector (local normal +! to the surface) +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,3),xs(3,2),xsi(2,3),xl(0:3,3),sh(3),xsj(3) +! + real*8 xi,et +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=-1.d0 + shp(1,2)=1.d0 + shp(1,3)=0.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=-1.d0 + shp(2,2)=0.d0 + shp(2,3)=1.d0 +! +! standard shape functions +! + shp(3,1)=1.d0-xi-et + shp(3,2)=xi + shp(3,3)=et +! +! Dual shape functions +! + shp(4,1)=3.d0*shp(3,1)-shp(3,2)-shp(3,3) + shp(4,2)=3.d0*shp(3,2)-shp(3,1)-shp(3,3) + shp(4,3)=3.d0*shp(3,3)-shp(3,1)-shp(3,2) +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,3 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian vector +! + xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=xs(2,2)/xsj(3) + xsi(2,1)=-xs(2,1)/xsj(3) + xsi(1,2)=-xs(1,2)/xsj(3) + xsi(2,2)=xs(1,1)/xsj(3) + xsi(1,3)=-xs(2,2)/xsj(1) + xsi(2,3)=xs(2,1)/xsj(1) +! +! computation of the global derivatives of the shape functions +! + do k=1,3 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dualshape4q.f calculix-ccx-2.3/ccx_2.3/src/dualshape4q.f --- calculix-ccx-2.1/ccx_2.3/src/dualshape4q.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dualshape4q.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,122 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dualshape4q(xi,et,xl,xsj,xs,shp,ns,pslavdual,iflag) +! +! iflag=2: calculate the value of the shape functions, +! their derivatives w.r.t. the local coordinates +! and the Jacobian vector (local normal to the +! surface) +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian vector (local normal +! to the surface) +! + implicit none +! + integer i,j,k,iflag,ns +! + real*8 shp(4,8),xs(3,2),xsi(2,3),xl(3,8),sh(3),xsj(3) +! + real*8 xi,et,pslavdual(16,*) +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=-(1.d0-et)/4.d0 + shp(1,2)=(1.d0-et)/4.d0 + shp(1,3)=(1.d0+et)/4.d0 + shp(1,4)=-(1.d0+et)/4.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=-(1.d0-xi)/4.d0 + shp(2,2)=-(1.d0+xi)/4.d0 + shp(2,3)=(1.d0+xi)/4.d0 + shp(2,4)=(1.d0-xi)/4.d0 +! +! standard shape functions +! + shp(3,1)=(1.d0-xi)*(1.d0-et)/4.d0 + shp(3,2)=(1.d0+xi)*(1.d0-et)/4.d0 + shp(3,3)=(1.d0+xi)*(1.d0+et)/4.d0 + shp(3,4)=(1.d0-xi)*(1.d0+et)/4.d0 +! +! Dual shape functions +! +c shp(4,1)=4.d0*shp(3,1)-2.d0*shp(3,2)+shp(3,3)-2.d0*shp(3,4) +c shp(4,2)=4.d0*shp(3,2)-2.d0*shp(3,1)+shp(3,4)-2.d0*shp(3,3) +c shp(4,3)=4.d0*shp(3,3)-2.d0*shp(3,2)+shp(3,1)-2.d0*shp(3,4) +c shp(4,4)=4.d0*shp(3,4)-2.d0*shp(3,1)+shp(3,2)-2.d0*shp(3,3) +! +! with Mass Matrix pslavdual +! + shp(4,1)=pslavdual(1,ns)*shp(3,1)+pslavdual(2,ns)*shp(3,2)+ + & pslavdual(3,ns)*shp(3,3)+pslavdual(4,ns)*shp(3,4) + shp(4,2)=pslavdual(5,ns)*shp(3,1)+pslavdual(6,ns)*shp(3,2)+ + & pslavdual(7,ns)*shp(3,3)+pslavdual(8,ns)*shp(3,4) + shp(4,3)=pslavdual(9,ns)*shp(3,1)+pslavdual(10,ns)*shp(3,2)+ + & pslavdual(11,ns)*shp(3,3)+pslavdual(12,ns)*shp(3,4) + shp(4,4)=pslavdual(13,ns)*shp(3,1)+pslavdual(14,ns)*shp(3,2)+ + & pslavdual(15,ns)*shp(3,3)+pslavdual(16,ns)*shp(3,4) +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,4 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian vector +! + xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=xs(2,2)/xsj(3) + xsi(2,1)=-xs(2,1)/xsj(3) + xsi(1,2)=-xs(1,2)/xsj(3) + xsi(2,2)=xs(1,1)/xsj(3) + xsi(1,3)=-xs(2,2)/xsj(1) + xsi(2,3)=xs(2,1)/xsj(1) +! +! computation of the global derivatives of the shape functions +! + do k=1,4 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/dualshape6tri.f calculix-ccx-2.3/ccx_2.3/src/dualshape6tri.f --- calculix-ccx-2.1/ccx_2.3/src/dualshape6tri.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dualshape6tri.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,119 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dualshape6tri(xi,et,xl,xsj,xs,shp,iflag) +! +! iflag=2: calculate the value of the shape functions, +! their derivatives w.r.t. the local coordinates +! and the Jacobian vector (local normal to the +! surface) +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian vector (local normal +! to the surface) +! +! shape functions and derivatives for a 6-node quadratic +! isoparametric triangular element. 0<=xi,et<=1,xi+et<=1 +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,6),xs(3,2),xsi(2,3),xl(0:3,6),sh(3),xsj(3) +! + real*8 xi,et +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=4.d0*(xi+et)-3.d0 + shp(1,2)=4.d0*xi-1.d0 + shp(1,3)=0.d0 + shp(1,4)=4.d0*(1.d0-2.d0*xi-et) + shp(1,5)=4.d0*et + shp(1,6)=-4.d0*et +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=4.d0*(xi+et)-3.d0 + shp(2,2)=0.d0 + shp(2,3)=4.d0*et-1.d0 + shp(2,4)=-4.d0*xi + shp(2,5)=4.d0*xi + shp(2,6)=4.d0*(1.d0-xi-2.d0*et) +! +! standard shape functions +! + shp(3,1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et) + shp(3,2)=xi*(2.d0*xi-1.d0) + shp(3,3)=et*(2.d0*et-1.d0) + shp(3,4)=4.d0*xi*(1.d0-xi-et) + shp(3,5)=4.d0*xi*et + shp(3,6)=4.d0*et*(1.d0-xi-et) +! +! Dual shape functions +! + shp(4,1)=shp(3,1)+(shp(3,4)+shp(3,6))/12.d0 + shp(4,2)=shp(3,2)+(shp(3,4)+shp(3,5))/12.d0 + shp(4,3)=shp(3,3)+(shp(3,5)+shp(3,6))/12.d0 +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,6 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian vector +! + xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=xs(2,2)/xsj(3) + xsi(2,1)=-xs(2,1)/xsj(3) + xsi(1,2)=-xs(1,2)/xsj(3) + xsi(2,2)=xs(1,1)/xsj(3) + xsi(1,3)=-xs(2,2)/xsj(1) + xsi(2,3)=xs(2,1)/xsj(1) +! +! computation of the global derivatives of the shape functions +! + do k=1,6 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/dualshape8q.f calculix-ccx-2.3/ccx_2.3/src/dualshape8q.f --- calculix-ccx-2.1/ccx_2.3/src/dualshape8q.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dualshape8q.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,161 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine dualshape8q(xi,et,xl,xsj,xs,shp,iflag) +! +! shape functions and derivatives for a 8-node quadratic +! isoparametric quadrilateral element. -1<=xi,et<=1 +! +! iflag=2: calculate the value of the shape functions, +! their derivatives w.r.t. the local coordinates +! and the Jacobian vector (local normal to the +! surface) +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian vector (local normal +! to the surface) +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,8),xs(3,2),xsi(2,3),xl(0:3,8),sh(3),xsj(3) +! + real*8 xi,et +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=(1.d0-et)*(2.d0*xi+et)/4.d0 + shp(1,2)=(1.d0-et)*(2.d0*xi-et)/4.d0 + shp(1,3)=(1.d0+et)*(2.d0*xi+et)/4.d0 + shp(1,4)=(1.d0+et)*(2.d0*xi-et)/4.d0 + shp(1,5)=-xi*(1.d0-et) + shp(1,6)=(1.d0-et*et)/2.d0 + shp(1,7)=-xi*(1.d0+et) + shp(1,8)=-(1.d0-et*et)/2.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=(1.d0-xi)*(2.d0*et+xi)/4.d0 + shp(2,2)=(1.d0+xi)*(2.d0*et-xi)/4.d0 + shp(2,3)=(1.d0+xi)*(2.d0*et+xi)/4.d0 + shp(2,4)=(1.d0-xi)*(2.d0*et-xi)/4.d0 + shp(2,5)=-(1.d0-xi*xi)/2.d0 + shp(2,6)=-et*(1.d0+xi) + shp(2,7)=(1.d0-xi*xi)/2.d0 + shp(2,8)=-et*(1.d0-xi) +! +! standard shape functions +! + shp(3,1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0 + shp(3,2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0 + shp(3,3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0 + shp(3,4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0 + shp(3,5)=(1.d0-xi*xi)*(1.d0-et)/2.d0 + shp(3,6)=(1.d0+xi)*(1.d0-et*et)/2.d0 + shp(3,7)=(1.d0-xi*xi)*(1.d0+et)/2.d0 + shp(3,8)=(1.d0-xi)*(1.d0-et*et)/2.d0 +! +! Dual shape functions +! + shp(4,1)=shp(3,1)+(shp(3,5)+shp(3,8))/5.d0 + shp(4,2)=shp(3,2)+(shp(3,5)+shp(3,6))/5.d0 + shp(4,3)=shp(3,3)+(shp(3,6)+shp(3,7))/5.d0 + shp(4,4)=shp(3,4)+(shp(3,7)+shp(3,8))/5.d0 +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,8 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian vector +! + xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! +c xsi(1,1)=xs(2,2)/xsj(3) +c xsi(2,1)=-xs(2,1)/xsj(3) +c xsi(1,2)=-xs(1,2)/xsj(3) +c xsi(2,2)=xs(1,1)/xsj(3) +c xsi(1,3)=-xs(2,2)/xsj(1) +c xsi(2,3)=xs(2,1)/xsj(1) + if(dabs(xsj(3)).gt.1.d-10) then + xsi(1,1)=xs(2,2)/xsj(3) + xsi(2,2)=xs(1,1)/xsj(3) + xsi(1,2)=-xs(1,2)/xsj(3) + xsi(2,1)=-xs(2,1)/xsj(3) + if(dabs(xsj(2)).gt.1.d-10) then + xsi(2,3)=xs(1,1)/xsj(2) + xsi(1,3)=-xs(1,2)/xsj(2) + elseif(dabs(xsj(1)).gt.1.d-10) then + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + else + xsi(2,3)=0.d0 + xsi(1,3)=0.d0 + endif + elseif(dabs(xsj(2)).gt.1.d-10) then + xsi(1,1)=xs(3,2)/xsj(2) + xsi(2,3)=xs(1,1)/xsj(2) + xsi(1,3)=-xs(1,2)/xsj(2) + xsi(2,1)=-xs(3,1)/xsj(2) + if(dabs(xsj(1)).gt.1.d-10) then + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + else + xsi(1,2)=0.d0 + xsi(2,2)=0.d0 + endif + else + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + xsi(1,1)=0.d0 + xsi(2,1)=0.d0 + endif +! +! computation of the global derivatives of the shape functions +! + do k=1,8 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/dyna.c calculix-ccx-2.3/ccx_2.3/src/dyna.c --- calculix-ccx-2.1/ccx_2.3/src/dyna.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dyna.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1937 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif +#ifdef PARDISO + #include "pardiso.h" +#endif + +void dyna(double **cop, int *nk, int **konp, int **ipkonp, char **lakonp, int *ne, + int **nodebounp, int **ndirbounp, double **xbounp, int *nboun, + int **ipompcp, int **nodempcp, double **coefmpcp, char **labmpcp, + int *nmpc, int *nodeforc,int *ndirforc,double *xforc, + int *nforc,int *nelemload, char *sideload,double *xload, + int *nload, + int **nactdofp,int *neq, int *nzl,int *icol, int *irow, + int *nmethod, int **ikmpcp, int **ilmpcp, int **ikbounp, + int **ilbounp,double *elcon, int *nelcon, double *rhcon, + int *nrhcon,double *cocon, int *ncocon, + double *alcon, int *nalcon, double *alzero, + int **ielmatp,int **ielorienp, int *norien, double *orab, + int *ntmat_,double **t0p, + double **t1p,int *ithermal,double *prestr, int *iprestr, + double **voldp,int *iperturb, double **stip, int *nzs, + double *tinc, double *tper, double *xmodal, + double **veoldp, char *amname, double *amta, + int *namta, int *nam, int *iamforc, int *iamload, + int **iamt1p,int *jout, + int *kode, char *filab,double **emep, double *xforcold, + double *xloadold, + double **t1oldp, int **iambounp, double **xbounoldp, int *iexpl, + double *plicon, int *nplicon, double *plkcon,int *nplkcon, + double *xstate, int *npmat_, char *matname, int *mi, + int *ncmat_, int *nstate_, double **enerp, char *jobnamec, + double *ttime, char *set, int *nset, int *istartset, + int *iendset, int **ialsetp, int *nprint, char *prlab, + char *prset, int *nener, double *trab, + int **inotrp, int *ntrans, double **fmpcp, char *cbody, int *ibody, + double *xbody, int *nbody, double *xbodyold, int *istep, + int *isolver,int *jq, char *output, int *mcs, int *nkon, + int *mpcend, int *ics, double *cs, int *ntie, char *tieset, + int *idrct, int *jmax, double *tmin, double *tmax, + double *ctrl, int *itpamp, double *tietol,int *nalset, + int **nnnp){ + + char fneig[132]="",description[13]=" ",*lakon=NULL,*labmpc=NULL, + *labmpcold=NULL,lakonl[9]=" \0",*tchar1=NULL,*tchar2=NULL, + *tchar3=NULL,cflag[1]=" "; + + int nev,i,j,k,idof,*inum=NULL,*ipobody=NULL,inewton=0,id, + iinc=0,jprint=0,l,iout,ielas,icmd,iprescribedboundary,init,ifreebody, + mode=-1,noddiam=-1,*kon=NULL,*ipkon=NULL,*ielmat=NULL,*ielorien=NULL, + *inotr=NULL,*nodeboun=NULL,*ndirboun=NULL,*iamboun=NULL,*ikboun=NULL, + *ilboun=NULL,*nactdof=NULL,*ipompc=NULL,*nodempc=NULL,*ikmpc=NULL, + *ilmpc=NULL,nsectors,nmpcold,mpcendold,*ipompcold=NULL,*nodempcold=NULL, + *ikmpcold=NULL,*ilmpcold=NULL,kflag=2,nmd,nevd,*nm=NULL,*iamt1=NULL, + *itg=NULL,ntg=0,symmetryflag=0,inputformat=0,dashpot,lrw,liw,iddebdf=0, + *iwork=NULL,ngraph=1,nkg,neg,ncont,ncone,ne0,nkon0, *itietri=NULL, + *koncont=NULL,konl[20],imat,nope,kodem,indexe,j1,jdof, + *ipneigh=NULL,*neigh=NULL,niter,inext,itp=0,icutb=0, + ismallsliding=0,isteadystate,mpcfree,im,cyclicsymmetry, + memmpc_,imax,iener=0,*icole=NULL,*irowe=NULL,*jqe=NULL,nzse[3], + nalset_=*nalset,*ialset=*ialsetp,*istartset_=NULL,*iendset_=NULL, + *itiefac=NULL,*islavsurf=NULL,*islavnode=NULL,mt=mi[1]+1, + *imastnode=NULL,*nslavnode=NULL,*nmastnode=NULL,mortar=0,*imastop=NULL, + *iponoels=NULL,*inoels=NULL,*nnn=*nnnp,*imddof=NULL,nmddof,nrset, + *ikactcont=NULL,nactcont,nactcont_=100,*ikactmech=NULL,nactmech, + iabsload=0,*ipe=NULL,*ime=NULL,iprev=1,inonlinmpc=0, + *imdnode=NULL,nmdnode,*imdboun=NULL,nmdboun,*imdmpc=NULL, + nmdmpc,intpointvar,kmin,kmax,i1,ifricdamp=0,ifacecount,*izdof=NULL, + nzdof,iload,iforc; + + long long i2; + + double *d=NULL, *z=NULL, *b=NULL, *zeta=NULL,*stiini=NULL, + *cd=NULL, *cv=NULL, *xforcact=NULL, *xloadact=NULL,*cc=NULL, + *t1act=NULL, *ampli=NULL, *aa=NULL, *bb=NULL, *aanew=NULL, *bj=NULL, + *v=NULL,*aamech=NULL,*aafric=NULL,*bfric=NULL, + *stn=NULL, *stx=NULL, *een=NULL, *adb=NULL,*xstiff=NULL,*bjp=NULL, + *aub=NULL, *temp_array1=NULL, *temp_array2=NULL, *aux=NULL, + *f=NULL, *fn=NULL, *xbounact=NULL,*epn=NULL,*xstateini=NULL, + *enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL,*qfn=NULL, + *qfx=NULL, *xbodyact=NULL, *cgr=NULL, *au=NULL, *vbounact=NULL, + *abounact=NULL,dtime,reltime,*t0=NULL,*t1=NULL,*t1old=NULL, + physcon[1],zetaj,dj,ddj,h1,h2,h3,h4,h5,h6,sum,aai,bbi,tstart,tend, + qa[3],cam[5],accold[1],bet,gam,*ad=NULL,sigma=0.,alpham,betam, + *bact=NULL,*bmin=NULL,*co=NULL,*xboun=NULL,*xbounold=NULL,*vold=NULL, + *eme=NULL,*ener=NULL,*coefmpc=NULL,*fmpc=NULL,*coefmpcold,*veold=NULL, + *xini=NULL,*rwork=NULL,*adc=NULL,*auc=NULL,*zc=NULL, *rpar=NULL, + *cg=NULL,*straight=NULL,xl[27],voldl[mt*9],elas[21],fnl[27],t0l,t1l, + elconloc[21],veoldl[mt*9],setnull,deltmx,bbmax,dd,dtheta,dthetaref, + theta,*vini=NULL,dthetaold,*bcont=NULL,*vr=NULL,*vi=NULL,*bcontini=NULL, + *stnr=NULL,*stni=NULL,*vmax=NULL,*stnmax=NULL,precision,resultmaxprev, + resultmax,func,funcp,fexp,fexm,fcos,fsin,sump,*bp=NULL,h14,senergy=0.0, + *bv=NULL,*cstr=NULL,*aube=NULL,*adbe=NULL,*sti=*stip,time0=0.0, + time=0.0,*xforcdiff=NULL,*xloaddiff=NULL,*xbodydiff=NULL,*t1diff=NULL, + *xboundiff=NULL,*bprev=NULL,*bdiff=NULL,damp,um,*areaslav=NULL, + *springarea=NULL, *bold=NULL,*eenmax=NULL; + + FILE *f1; + + /* dummy variables for nonlinmpc */ + + int *iaux=NULL,maxlenmpc,icascade=0,newstep=0,iit=-1,idiscon; + +#ifdef SGI + int token; +#endif + + /* if iabsload=0: aamech is modified by the present incremental + contribution of b + iabsload=1: the last incremental contribution is + subtracted before the new one is added to b; + this latter incremental contribution is used + to update aamech + iabsload=2: aamech is determined by the absolute + contribution of b (no incremental procedure + for the load; this is necessary if + - nonlinear MPC's are applied or + - user dloads are applied */ + + co=*cop;kon=*konp;ipkon=*ipkonp;lakon=*lakonp;ielmat=*ielmatp; + ielorien=*ielorienp;inotr=*inotrp;nodeboun=*nodebounp; + ndirboun=*ndirbounp;iamboun=*iambounp;xboun=*xbounp; + xbounold=*xbounoldp;ikboun=*ikbounp;ilboun=*ilbounp;nactdof=*nactdofp; + vold=*voldp;eme=*emep;ener=*enerp;ipompc=*ipompcp;nodempc=*nodempcp; + coefmpc=*coefmpcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; + fmpc=*fmpcp;veold=*veoldp;iamt1=*iamt1p;t0=*t0p;t1=*t1p;t1old=*t1oldp; + + if(ithermal[0]<=1){ + kmin=1;kmax=3; + }else if(ithermal[0]==2){ + kmin=0;kmax=mi[1];if(kmax>2)kmax=2; + }else{ + kmin=0;kmax=3; + } + + xstiff=NNEW(double,27*mi[0]**ne); + + dtime=*tinc; + + alpham=xmodal[0]; + betam=xmodal[1]; + + dd=ctrl[16];deltmx=ctrl[26];nrset=(int)xmodal[9]; + + /* determining nzl */ + + *nzl=0; + for(i=neq[1];i>0;i--){ + if(icol[i-1]>0){ + *nzl=i; + break; + } + } + + /* check for cyclic symmetry */ + + if((*mcs==0)||(cs[1]<0)){cyclicsymmetry=0;}else{cyclicsymmetry=1;} + + /* creating imddof containing the degrees of freedom + retained by the user and imdnode containing the nodes */ + + nmddof=0;nmdnode=0;nmdboun=0;nmdmpc=0; + if(nrset!=0){ + imddof=NNEW(int,*nk*3); + imdnode=NNEW(int,*nk); + imdboun=NNEW(int,*nboun); + imdmpc=NNEW(int,*nmpc); + FORTRAN(createmddof,(imddof,&nmddof,&nrset,istartset,iendset, + ialset,nactdof,ithermal,mi,imdnode,&nmdnode, + ikmpc,ilmpc,ipompc,nodempc,nmpc, + imdmpc,&nmdmpc,imdboun,&nmdboun,ikboun, + nboun,nset,ntie,tieset,set,lakon,kon,ipkon,labmpc, + ilboun)); + + /* checking for user-defined loads: all relevant nodes belonging to + elements subject to user-defined loads are stored in imdnode + as well (vold and veold are made available in the user subroutines */ + + if(!cyclicsymmetry){ + for(i=0;i<*nload;i++){ + iload=i+1; + FORTRAN(addimdnodedload,(nelemload,sideload,ipkon,kon,lakon, + &iload,imdnode,&nmdnode,ikmpc,ilmpc,ipompc,nodempc,nmpc, + imddof,&nmddof,nactdof,mi,imdmpc,&nmdmpc,imdboun,&nmdboun, + ikboun,nboun,ilboun,ithermal)); + } + + for(i=0;i<*nforc;i++){ + iforc=i+1; + FORTRAN(addimdnodecload,(nodeforc,&iforc,imdnode,&nmdnode,xforc, + ikmpc,ilmpc,ipompc,nodempc,nmpc,imddof,&nmddof, + nactdof,mi,imdmpc,&nmdmpc,imdboun,&nmdboun, + ikboun,nboun,ilboun,ithermal)); + } + } + + RENEW(imddof,int,nmddof); + RENEW(imdnode,int,nmdnode); + RENEW(imdboun,int,nmdboun); + RENEW(imdmpc,int,nmdmpc); + } + + /* reading the eigenvalue and eigenmode information */ + + strcpy(fneig,jobnamec); + strcat(fneig,".eig"); + + if((f1=fopen(fneig,"rb"))==NULL){ + printf("*ERROR: cannot open eigenvalue file for reading..."); + exit(0); + } + nsectors=1; + + if(!cyclicsymmetry){ + + nkg=*nk; + neg=*ne; + + if(fread(&nev,sizeof(int),1,f1)!=1){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + d=NNEW(double,nev); + + if(fread(d,sizeof(double),nev,f1)!=nev){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + ad=NNEW(double,neq[1]); + adb=NNEW(double,neq[1]); + au=NNEW(double,nzs[2]); + aub=NNEW(double,nzs[1]); + + if(fread(ad,sizeof(double),neq[1],f1)!=neq[1]){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + if(fread(au,sizeof(double),nzs[2],f1)!=nzs[2]){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + if(fread(adb,sizeof(double),neq[1],f1)!=neq[1]){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + if(fread(aub,sizeof(double),nzs[1],f1)!=nzs[1]){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + z=NNEW(double,neq[1]*nev); + + if(fread(z,sizeof(double),neq[1]*nev,f1)!=neq[1]*nev){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + } + else{ + nev=0; + do{ + if(fread(&nmd,sizeof(int),1,f1)!=1){ + break; + } + if(fread(&nevd,sizeof(int),1,f1)!=1){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + if(nev==0){ + d=NNEW(double,nevd); + nm=NNEW(int,nevd); + }else{ + RENEW(d,double,nev+nevd); + RENEW(nm,int,nev+nevd); + } + + if(fread(&d[nev],sizeof(double),nevd,f1)!=nevd){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + for(i=nev;insectors) nsectors=cs[17*i]; + if(cs[17*i]>nsectors) nsectors=(int)(cs[17*i]+0.5); + } + + /* determining the maximum number of sectors to be plotted */ + + for(j=0;j<*mcs;j++){ + if(cs[17*j+4]>ngraph) ngraph=(int)cs[17*j+4]; + } + nkg=*nk*ngraph; + neg=*ne*ngraph; + + /* allocating field for the expanded structure */ + + RENEW(co,double,3**nk*nsectors); + + /* next line is necessary for multiple cyclic symmetry + conditions */ + + for(i=3**nk;i<3**nk*nsectors;i++){co[i]=0.;} + if(*ithermal!=0){ + RENEW(t0,double,*nk*nsectors); + RENEW(t1old,double,*nk*nsectors); + RENEW(t1,double,*nk*nsectors); + if(*nam>0) RENEW(iamt1,int,*nk*nsectors); + } + RENEW(nactdof,int,mt**nk*nsectors); + if(*ntrans>0) RENEW(inotr,int,2**nk*nsectors); + RENEW(kon,int,*nkon*nsectors); + RENEW(ipkon,int,*ne*nsectors); + for(i=*ne;i<*ne*nsectors;i++){ipkon[i]=-1;} + RENEW(lakon,char,8**ne*nsectors); + RENEW(ielmat,int,*ne*nsectors); + if(*norien>0) RENEW(ielorien,int,*ne*nsectors); +// RENEW(z,double,(long long)neq[1]*nev*nsectors/2); + + RENEW(nodeboun,int,*nboun*nsectors); + RENEW(ndirboun,int,*nboun*nsectors); + if(*nam>0) RENEW(iamboun,int,*nboun*nsectors); + RENEW(xboun,double,*nboun*nsectors); + RENEW(xbounold,double,*nboun*nsectors); + RENEW(ikboun,int,*nboun*nsectors); + RENEW(ilboun,int,*nboun*nsectors); + + ipompcold=NNEW(int,*nmpc); + nodempcold=NNEW(int,3**mpcend); + coefmpcold=NNEW(double,*mpcend); + labmpcold=NNEW(char,20**nmpc); + ikmpcold=NNEW(int,*nmpc); + ilmpcold=NNEW(int,*nmpc); + + for(i=0;i<*nmpc;i++){ipompcold[i]=ipompc[i];} + for(i=0;i<3**mpcend;i++){nodempcold[i]=nodempc[i];} + for(i=0;i<*mpcend;i++){coefmpcold[i]=coefmpc[i];} + for(i=0;i<20**nmpc;i++){labmpcold[i]=labmpc[i];} + for(i=0;i<*nmpc;i++){ikmpcold[i]=ikmpc[i];} + for(i=0;i<*nmpc;i++){ilmpcold[i]=ilmpc[i];} + nmpcold=*nmpc; + mpcendold=*mpcend; + + RENEW(ipompc,int,*nmpc*nsectors); + RENEW(nodempc,int,3**mpcend*nsectors); + RENEW(coefmpc,double,*mpcend*nsectors); + RENEW(labmpc,char,20**nmpc*nsectors+1); + RENEW(ikmpc,int,*nmpc*nsectors); + RENEW(ilmpc,int,*nmpc*nsectors); + RENEW(fmpc,double,*nmpc*nsectors); + + /* determining the space needed to expand the + contact surfaces */ + + tchar1=NNEW(char,81); + tchar2=NNEW(char,81); + tchar3=NNEW(char,81); + for(i=0; i<*ntie; i++){ + if(tieset[i*(81*3)+80]=='C'){ + //a contact constrain was found, so increase nalset + memcpy(tchar2,&tieset[i*(81*3)+81],81); + tchar2[80]='\0'; + memcpy(tchar3,&tieset[i*(81*3)+81+81],81); + tchar3[80]='\0'; + for(j=0; j<*nset; j++){ + memcpy(tchar1,&set[j*81],81); + tchar1[80]='\0'; + if(strcmp(tchar1,tchar2)==0){ + //dependent nodal surface was found + (*nalset)+=(iendset[j]-istartset[j]+1)*(nsectors); + } + else if(strcmp(tchar1,tchar3)==0){ + //independent element face surface was found + (*nalset)+=(iendset[j]-istartset[j]+1)*(nsectors); + } + } + } + } + free(tchar1); + free(tchar2); + free(tchar3); + + RENEW(ialset,int,*nalset); + + /* save the information in istarset and isendset */ + istartset_=NNEW(int,*nset); + iendset_=NNEW(int,*nset); + for(j=0; j<*nset; j++){ + istartset_[j]=istartset[j]; + iendset_[j]=iendset[j]; + } + +// RENEW(xstiff,double,(long long)27*mi[0]**ne*nsectors); + + /* reallocating the fields for the nodes in which the + solution has to be calculated */ + + RENEW(imddof,int,neq[1]/2*nsectors); + RENEW(imdnode,int,*nk*nsectors); + RENEW(imdboun,int,*nboun*nsectors); + RENEW(imdmpc,int,*nmpc*nsectors); + + izdof=NNEW(int,1); + + expand(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, + ipompc,nodempc,coefmpc,labmpc,nmpc,nodeforc,ndirforc,xforc, + nforc,nelemload,sideload,xload,nload,nactdof,neq, + nmethod,ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + t0,ithermal,prestr,iprestr,vold,iperturb,sti,nzs, + adb,aub,filab,eme,plicon,nplicon,plkcon,nplkcon, + xstate,npmat_,matname,mi,ics,cs,mpcend,ncmat_, + nstate_,mcs,nkon,ener,jobnamec,output,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,nener,trab, + inotr,ntrans,ttime,fmpc,&nev,&z,iamboun,xbounold, + &nsectors,nm,icol,irow,nzl,nam,ipompcold,nodempcold,coefmpcold, + labmpcold,&nmpcold,xloadold,iamload,t1old,t1,iamt1,xstiff, + &icole,&jqe,&irowe,isolver,nzse,&adbe,&aube,iexpl, + ibody,xbody,nbody,cocon,ncocon,tieset,ntie,&nnn,imddof,&nmddof, + imdnode,&nmdnode,imdboun,&nmdboun,imdmpc,&nmdmpc,&izdof,&nzdof); + + RENEW(imddof,int,nmddof); + RENEW(imdnode,int,nmdnode); + RENEW(imdboun,int,nmdboun); + RENEW(imdmpc,int,nmdmpc); + + free(vold);vold=NNEW(double,mt**nk); + free(veold);veold=NNEW(double,mt**nk); + RENEW(eme,double,6*mi[0]**ne); + RENEW(sti,double,6*mi[0]**ne); + + RENEW(xstiff,double,(long long)27*mi[0]**ne*nsectors); + if(*nener==1) RENEW(ener,double,mi[0]**ne*2); + } + + fclose(f1); + + /* checking for steadystate calculations */ + + if(*tper<0){ + precision=-*tper; + *tper=1.e10; + isteadystate=1; + }else{ + isteadystate=0; + } + + /* checking for nonlinear MPC's */ + + for(i=0;i<*nmpc;i++){ + if((strcmp1(&labmpc[20*i]," ")!=0)&& + (strcmp1(&labmpc[20*i],"CONTACT")!=0)&& + (strcmp1(&labmpc[20*i],"CYCLIC")!=0)&& + (strcmp1(&labmpc[20*i],"SUBCYCLIC")!=0)){ + inonlinmpc=1; + iabsload=2; + break; + } + } + + + /* normalizing the time */ + + FORTRAN(checktime,(itpamp,namta,tinc,ttime,amta,tmin,&inext,&itp)); + dtheta=(*tinc)/(*tper); + dthetaref=dtheta; + dthetaold=dtheta; + + *tmin=*tmin/(*tper); + *tmax=*tmax/(*tper); + theta=0.; + + /* check for rigid body modes + if there is a jump of 1.e4 in two subsequent eigenvalues + all eigenvalues preceding the jump are considered to + be rigid body modes and their frequency is set to zero */ + + setnull=1.; + for(i=nev-2;i>-1;i--){ + if(fabs(d[i])<0.0001*fabs(d[i+1])) setnull=0.; + d[i]*=setnull; + } + + /* check whether there are dashpot elements */ + + dashpot=0; + for(i=0;i<*ne;i++){ + if(ipkon[i]<0) continue; + if(strcmp1(&lakon[i*8],"ED")==0){ + dashpot=1;break;} + } + + if(dashpot){ + + if(cyclicsymmetry){ + printf("*ERROR in dyna: dashpots are not allowed in combination with cyclic symmetry\n"); + FORTRAN(stop,()); + } + + liw=51; + iwork=NNEW(int,liw); + lrw=130+42*nev; + rwork=NNEW(double,lrw); + xini=NNEW(double,2*nev); + adc=NNEW(double,neq[1]); + auc=NNEW(double,nzs[1]); + FORTRAN(mafilldm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + adc,auc,nactdof,icol,jq,irow,neq,nzl,nmethod, + ikmpc,ilmpc,ikboun,ilboun, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_, + t0,t0,ithermal,prestr,iprestr,vold,iperturb,sti, + nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, + xstiff,npmat_,&dtime,matname,mi,ncmat_, + ttime,&time0,istep,&iinc,ibody)); + + /* zc = damping matrix * eigenmodes */ + + zc=NNEW(double,neq[1]*nev); + for(i=0;i0){ + RENEW(ielorien,int,*ne+ncone); + for(k=*ne;k<*ne+ncone;k++) ielorien[k]=0; + } + RENEW(ielmat,int,*ne+ncone); + for(k=*ne;k<*ne+ncone;k++) ielmat[k]=1; + cg=NNEW(double,3*ncont); + straight=NNEW(double,16*ncont); + areaslav=NNEW(double,ifacecount); + springarea=NNEW(double,2*ncone); + vini=NNEW(double,mt**nk); + bcontini=NNEW(double,neq[1]); + bcont=NNEW(double,neq[1]); + ikactcont=NNEW(int,nactcont_); + } + + /* storing the element and topology information before introducing + contact elements */ + + ne0=*ne;nkon0=*nkon; + + zeta=NNEW(double,nev); + cstr=NNEW(double,6); + + /* calculating the damping coefficients*/ + if(xmodal[10]<0){ + for(i=0;i(1.e-10)){ + zeta[i]=(alpham+betam*d[i]*d[i])/(2.*d[i]); + } + else { + printf("*WARNING in dyna: one of the frequencies is zero\n"); + printf(" no Rayleigh mass damping allowed\n"); + zeta[i]=0.; + } + } + } + else{ + /*copy the damping coefficients for every eigenfrequencie from xmodal[11....] */ + if(nev<(int)xmodal[10]){ + imax=nev; + printf("*WARNING in dyna: too many modal damping coefficients applied\n"); + printf(" damping coefficients corresponding to nonexisting eigenvalues are ignored\n"); + } + else{ + imax=(int)xmodal[10]; + } + for(i=0; i0){ + ifreebody=*ne+1; +/* ipobody=NNEW(int,2*ifreebody**nbody);*/ + ipobody=NNEW(int,2**ne); + for(k=1;k<=*nbody;k++){ + FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, + iendset,ialset,&inewton,nset,&ifreebody,&k)); + RENEW(ipobody,int,2*(*ne+ifreebody)); + } + RENEW(ipobody,int,2*(ifreebody-1)); + } + + b=NNEW(double,neq[1]); /* load rhs vector and displacement solution vector */ + bp=NNEW(double,neq[1]); /* velocity solution vector */ + bj=NNEW(double,nev); /* response modal decomposition */ + bjp=NNEW(double,nev); /* derivative of the response modal decomposition */ + ampli=NNEW(double,*nam); /* instantaneous amplitude */ + + /* constant coefficient of the linear amplitude function */ + aa=NNEW(double,nev); + aanew=NNEW(double,nev); + aamech=NNEW(double,nev); + /* linear coefficient of the linear amplitude function */ + bb=NNEW(double,nev); + + v=NNEW(double,mt**nk); + fn=NNEW(double,mt**nk); + stn=NNEW(double,6**nk); + inum=NNEW(int,*nk); + strcpy1(&cflag[0],&filab[4],1); + FORTRAN(createinum,(ipkon,inum,kon,lakon,nk,ne,&cflag[0],nelemload, + nload,nodeboun,nboun,ndirboun,ithermal)); + + if(*ithermal>1) {qfn=NNEW(double,3**nk);qfx=NNEW(double,3*mi[0]**ne);} + + if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); + if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); + + eei=NNEW(double,6*mi[0]**ne); + if(*nener==1){ + stiini=NNEW(double,6*mi[0]**ne); + enerini=NNEW(double,mi[0]**ne);} + + /* check for nonzero SPC's */ + + iprescribedboundary=0; + for(i=0;i<*nboun;i++){ + if(fabs(xboun[i])>1.e-10){ + iprescribedboundary=1; + break; + } + } + +/* calculating the instantaneous loads (forces, surface loading, + centrifugal and gravity loading or temperature) at time 0 + setting iabsload to 2 if user subroutine dload is used */ + +/* FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc,xloadold, + xload,xloadact,iamload,nload,ibody,xbody,nbody,xbodyold, + xbodyact,t1old,t1,t1act,iamt1,nk, + amta,namta,nam,ampli,&time0,&reltime,ttime,&dtime,ithermal,nmethod, + xbounold,xboun,xbounact,iamboun,nboun, + nodeboun,ndirboun,nodeforc,ndirforc,istep,&iinc, + co,vold,itg,&ntg,amname,ikboun,ilboun,nelemload,sideload,mi));*/ + + FORTRAN(temploaddiff,(xforcold,xforc,xforcact,iamforc,nforc, + xloadold,xload,xloadact,iamload,nload,ibody,xbody, + nbody,xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal, + nmethod,xbounold,xboun,xbounact,iamboun,nboun,nodeboun, + ndirboun,nodeforc, + ndirforc,istep,&iinc,co,vold,itg,&ntg,amname,ikboun,ilboun, + nelemload,sideload,mi, + xforcdiff,xloaddiff,xbodydiff,t1diff,xboundiff,&iabsload, + &iprescribedboundary,ntrans,trab,inotr,veold,nactdof,bcont)); + + if(iabsload==2) bold=NNEW(double,neq[1]); + + /* calculating the instantaneous loading vector at time 0 */ + + ikactmech=NNEW(int,neq[1]); + nactmech=0; + FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, + nforc,nelemload,sideload,xloadact,nload,xbodyact,ipobody,nbody, + cgr,b,nactdof,&neq[1],nmethod, + ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon,alcon, + nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_,t0,t1act, + ithermal,iprestr,vold,iperturb,iexpl,plicon, + nplicon,plkcon,nplkcon,npmat_,ttime,&time0,istep,&iinc,&dtime, + physcon,ibody,xbodyold,&reltime,veold,matname,mi,ikactmech, + &nactmech)); + + /* correction for nonzero SPC's */ + + if(iprescribedboundary){ + + if(cyclicsymmetry){ + printf("*ERROR in dyna: prescribed boundaries are not allowed in combination with cyclic symmetry\n"); + FORTRAN(stop,()); + } + + if(*idrct!=1){ + printf("*ERROR in dyna: variable increment length is not allwed in combination with prescribed boundaries\n"); + FORTRAN(stop,()); + } + + /* LU decomposition of the stiffness matrix */ + + if(*isolver==0){ +#ifdef SPOOLES + spooles_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1], + &symmetryflag,&inputformat); +#else + printf("*ERROR in dyna: the SPOOLES library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==4){ +#ifdef SGI + token=1; + sgi_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1],token); +#else + printf("*ERROR in dyna: the SGI library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_factor(ad,&au,adb,aub,&sigma,icol,&irow,&neq[1],&nzs[1]); +#else + printf("*ERROR in dyna: the TAUCS library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1]); +#else + printf("*ERROR in dyna: the PARDISO library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + + bact=NNEW(double,neq[1]); + bmin=NNEW(double,neq[1]); + bv=NNEW(double,neq[1]); + bprev=NNEW(double,neq[1]); + bdiff=NNEW(double,neq[1]); + + init=1; + dynboun(amta,namta,nam,ampli,&time0,ttime,&dtime,xbounold,xboun, + xbounact,iamboun,nboun,nodeboun,ndirboun,ad,au,adb, + aub,icol,irow,neq,nzs,&sigma,b,isolver, + &alpham,&betam,nzl,&init,bact,bmin,jq,amname,bv, + bprev,bdiff,&nactmech,&iabsload,&iprev); + init=0; + } + +/* creating contact elements and calculating the contact forces + (normal and shear) */ + + if(ncont!=0){ +// for(i=0;i100){nactcont_=nactcont;}else{nactcont_=100;} + RENEW(ikactcont,int,nactcont_); + + /* check for damping/friction in the material definition (to be done) */ + + for(i=0;i<*ntie;i++){ + if(tieset[i*(81*3)+80]=='C'){ + imat=(int)tietol[2*i]; + if(*ncmat_<5) continue; + damp=elcon[(imat-1)*(*ncmat_+1)**ntmat_+2]; + if(*ncmat_<7){um=0.;}else{ + um=elcon[(imat-1)*(*ncmat_+1)**ntmat_+5]; + } + if((damp>0.)||(um>0.)){ + ifricdamp=1; + break; + } + } + } + + /* friction is set to zero at the start of a new step */ + + if(ifricdamp==1){ + aafric=NNEW(double,nev); + bfric=NNEW(double,neq[1]); + } + + } + + iit=1; + + /* load at the start of a new step: + mechanical loading without friction + contact */ + + if(!cyclicsymmetry){ + for(i=0;i1.e-6){ + + time0=time; + +// printf("\nnew increment\n"); + + if(*nener==1){ + memcpy(&enerini[0],&ener[0],sizeof(double)*mi[0]*ne0); + if(*ithermal!=2){ + memcpy(&stiini[0],&sti[0],sizeof(double)*6*mi[0]*ne0); + } + } + + if(ncont!=0){ + if(nmdnode!=0){ + for(i=0;i*jmax){ + printf(" *ERROR: max. # of increments reached\n\n"); + FORTRAN(stop,()); + } + + if(iinc>1){ + memcpy(&cd[0],&bj[0],sizeof(double)*nev); + memcpy(&cv[0],&bjp[0],sizeof(double)*nev); + } + + + if((*idrct!=1)&&(iinc!=1)){ + + /* increasing the increment size */ + + dthetaold=dtheta; + dtheta=dthetaref*dd; + + /* check increment length whether + - it does not exceed tmax + - the step length is not exceeded + - a time point is not exceeded */ + + dthetaref=dtheta; + checkinclength(&time0,ttime,&theta,&dtheta,idrct,tper,tmax, + tmin,ctrl, amta,namta,itpamp,&inext,&dthetaref,&itp, + &jprint,jout); + +// dthetaref=dtheta; + } + + reltime=theta+dtheta; + time=reltime**tper; + dtime=dtheta**tper; + +// printf("dtime=%e\n time=%e\n",dtime,time); + + + /* calculating the instantaneous loads (forces, surface loading, + centrifugal and gravity loading or temperature) */ + + FORTRAN(temploaddiff,(xforcold,xforc,xforcact,iamforc,nforc, + xloadold,xload,xloadact,iamload,nload,ibody,xbody, + nbody,xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal, + nmethod,xbounold,xboun,xbounact,iamboun,nboun,nodeboun, + ndirboun,nodeforc, + ndirforc,istep,&iinc,co,vold,itg,&ntg,amname,ikboun,ilboun, + nelemload,sideload,mi, + xforcdiff,xloaddiff,xbodydiff,t1diff,xboundiff,&iabsload, + &iprescribedboundary,ntrans,trab,inotr,veold,nactdof,bcont)); + + /* calculating the instantaneous loading vector */ + + if(iabsload!=2){ + FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcdiff, + nforc,nelemload,sideload,xloaddiff,nload,xbodydiff, + ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, + ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + t0,t1diff,ithermal,iprestr,vold,iperturb,iexpl,plicon, + nplicon,plkcon,nplkcon, + npmat_,ttime,&time,istep,&iinc,&dtime,physcon,ibody, + xbodyold,&reltime,veold,matname,mi,ikactmech,&nactmech)); + }else{ + FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, + nforc,nelemload,sideload,xloadact,nload,xbodyact, + ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, + ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + t0,t1act,ithermal,iprestr,vold,iperturb,iexpl,plicon, + nplicon,plkcon,nplkcon, + npmat_,ttime,&time,istep,&iinc,&dtime,physcon,ibody, + xbodyold,&reltime,veold,matname,mi,ikactmech,&nactmech)); + } + + /* correction for nonzero SPC's */ + + if(iprescribedboundary){ + dynboun(amta,namta,nam,ampli,&time,ttime,&dtime, + xbounold,xboun, + xbounact,iamboun,nboun,nodeboun,ndirboun,ad,au,adb, + aub,icol,irow,neq,nzs,&sigma,b,isolver, + &alpham,&betam,nzl,&init,bact,bmin,jq,amname,bv, + bprev,bdiff,&nactmech,&iabsload,&iprev); + } + + if(*idrct==0){ + bbmax=0.; + if(iabsload!=2){ + if(nactmechbbmax) bbmax=fabs(b[ikactmech[i]]); + } + }else{ + for(i=0;ibbmax) bbmax=fabs(b[i]); + } + } + }else{ + + /* bbmax is to be calculated from the difference of b and bold */ + + if(nactmechbbmax) + bbmax=fabs(b[ikactmech[i]]-bold[ikactmech[i]]); + } + }else{ + for(i=0;ibbmax) bbmax=fabs(b[i]-bold[i]); + } + } + + /* copy b into bold */ + + if(nactmechdeltmx)&&(((itp==1)&&(dtheta>*tmin))||(itp==0))){ + + /* force increase too big: increment size is decreased */ + + if(iabsload==0) iabsload=1; + dtheta=dtheta*deltmx/bbmax; +// printf("correction of dtheta due to force increase: %e\n",dtheta); + dthetaref=dtheta; + if(itp==1){ + inext--; + itp=0; + } + + /* check whether the new increment size is not too small */ + + if(dtheta<*tmin){ +// printf("\n *WARNING: increment size %e smaller than minimum %e\n",dtheta**tper,*tmin**tper); +// printf(" minimum is taken\n"); + dtheta=*tmin; + } + + reltime=theta+dtheta; + time=reltime**tper; + dtime=dtheta**tper; + + /* calculating the instantaneous loads (forces, surface loading, + centrifugal and gravity loading or temperature) */ + + FORTRAN(temploaddiff,(xforcold,xforc,xforcact,iamforc,nforc, + xloadold,xload,xloadact,iamload,nload,ibody,xbody, + nbody,xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal, + nmethod,xbounold,xboun,xbounact,iamboun,nboun,nodeboun, + ndirboun,nodeforc, + ndirforc,istep,&iinc,co,vold,itg,&ntg,amname,ikboun,ilboun, + nelemload,sideload,mi, + xforcdiff,xloaddiff,xbodydiff,t1diff,xboundiff,&iabsload, + &iprescribedboundary,ntrans,trab,inotr,veold,nactdof,bcont)); + + /* calculating the instantaneous loading vector */ + + if(iabsload!=2){ + FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcdiff, + nforc,nelemload,sideload,xloaddiff,nload,xbodydiff, + ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, + ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + t0,t1diff,ithermal,iprestr,vold,iperturb,iexpl,plicon, + nplicon,plkcon,nplkcon, + npmat_,ttime,&time,istep,&iinc,&dtime,physcon,ibody, + xbodyold,&reltime,veold,matname,mi,ikactmech,&nactmech)); + }else{ + FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, + nforc,nelemload,sideload,xloadact,nload,xbodyact, + ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, + ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + t0,t1act,ithermal,iprestr,vold,iperturb,iexpl,plicon, + nplicon,plkcon,nplkcon, + npmat_,ttime,&time,istep,&iinc,&dtime,physcon,ibody, + xbodyold,&reltime,veold,matname,mi,ikactmech,&nactmech)); + } + + /* correction for nonzero SPC's */ + + if(iprescribedboundary){ + dynboun(amta,namta,nam,ampli,&time,ttime,&dtime, + xbounold,xboun, + xbounact,iamboun,nboun,nodeboun,ndirboun,ad,au,adb, + aub,icol,irow,neq,nzs,&sigma,b,isolver, + &alpham,&betam,nzl,&init,bact,bmin,jq,amname,bv, + bprev,bdiff,&nactmech,&iabsload,&iprev); + } + if(iabsload==1) iabsload=0; + } + + if(ncont!=0){ + for(i=0;i1.+1.e-6){ + ddj=dj*sqrt(zetaj*zetaj-1.); + h1=ddj-zetaj*dj; + h2=ddj+zetaj*dj; + h3=1./h1; + h4=1./h2; + h5=h3*h3; + h6=h4*h4; + tstart=0.; + FORTRAN(fsuper,(&time,&dtime,&aa[l],&bb[l], + &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); + sum=func;sump=funcp; + FORTRAN(fsuper,(&time,&tstart,&aa[l],&bb[l], + &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); + sum-=func;sump-=funcp; + + fexm=exp(h1*dtime); + fexp=exp(-h2*dtime); + h14=zetaj*dj/ddj; + bj[l]=sum/(2.*ddj)+(fexm+fexp)*cd[l]/2.+zetaj*(fexm-fexp)/(2.* + sqrt(zetaj*zetaj-1.))*cd[l]+(fexm-fexp)*cv[l]/(2.*ddj); + bjp[l]=sump/(2.*ddj)+(h1*fexm-h2*fexp)*cd[l]/2. + +(h14*cd[l]+cv[l]/ddj)*(h1*fexm+h2*fexp)/2.; + } + + /* critical damping */ + + else{ + h1=zetaj*dj; + h2=1./h1; + h3=h2*h2; + h4=h2*h3; + tstart=0.; + FORTRAN(fcrit,(&time,&dtime,&aa[l],&bb[l],&zetaj,&dj, + &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); + sum=func;sump=funcp; + FORTRAN(fcrit,(&time,&tstart,&aa[l],&bb[l],&zetaj,&dj, + &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); + sum-=func;sump-=funcp; + fexp=exp(-h1*dtime); + bj[l]=sum+fexp*((1.+h1*dtime)*cd[l]+dtime*cv[l]); + bjp[l]=sump+fexp*(-h1*h1*dtime*cd[l]+ + (1.-h1*dtime)*cv[l]); + } + } + } + + /* composing the response */ + + if(iprescribedboundary){ + if(nmdnode==0){ + memcpy(&b[0],&bmin[0],sizeof(double)*neq[1]); + memcpy(&bp[0],&bv[0],sizeof(double)*neq[1]); + }else{ + for(i=0;i0)&&(*idrct==0)){ + if(itp==1){ + jprint=*jout; + }else{ + jprint=*jout+1; + } + } + + /* check whether output is needed */ + + if((*jout==jprint)||(1.-theta<=1.e-6)){ + iout=2; + jprint=0; + }else if(*nener==1){ + iout=-2; + }else{ + iout=0; + } + + if((iout==2)||(iout==-2)){ + if(intpointvar==1) stx=NNEW(double,6*mi[0]**ne); + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum, + stx,elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero, + ielmat,ielorien,norien,orab,ntmat_,t0,t1, + ithermal,prestr,iprestr,filab,eme,een, + iperturb,f,fn,nactdof,&iout,qa, + vold,b,nodeboun,ndirboun,xbounact,nboun, + ipompc,nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1], + veold,accold,&bet,&gam,&dtime,&time,ttime, + plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, + &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener, + enern,sti,xstaten,eei,enerini,cocon,ncocon, + set,nset,istartset,iendset,ialset,nprint,prlab,prset, + qfx,qfn,trab,inotr,ntrans,fmpc,nelemload,nload,ikmpc, + ilmpc,istep,&iinc,springarea,&reltime)); + + + if((*ithermal!=2)&&(intpointvar==1)){ + for(k=0;k<6*mi[0]*ne0;++k){ + sti[k]=stx[k]; + } + } + } + if(iout==2){ + (*kode)++; + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); + } + FORTRAN(out,(co,&nkg,kon,ipkon,lakon,&neg,v,stn,inum,nmethod,kode,filab, + een,t1,fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_, + istep,&iinc, + iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,stx,vr,vi,stnr,stni,vmax,stnmax,&ngraph, + veold,ne,cs,set,nset,istartset,iendset,ialset,eenmax)); + + if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} + } + + if((intpointvar==1)&&((iout==2)||(iout==-2))){ + free(stx); + } + + +// FORTRAN(writesummary,(istep,&iinc,&icutb,&iit,ttime,&time,&dtime)); + + if(isteadystate==1){ + + /* calculate maximum displacement/temperature */ + + resultmax=0.; + if(*ithermal<2){ + for(i=1;iresultmax) resultmax=fabs(v[i]);} + for(i=2;iresultmax) resultmax=fabs(v[i]);} + for(i=3;iresultmax) resultmax=fabs(v[i]);} + }else if(*ithermal==2){ + for(i=0;iresultmax) resultmax=fabs(v[i]);} + }else{ + printf("*ERROR in dyna: coupled temperature-displacement calculations are not allowed\n"); + } + if(fabs((resultmax-resultmaxprev)/resultmax)1) {free(qfn);free(qfx);} + + /* updating the loading at the end of the step; + important in case the amplitude at the end of the step + is not equal to one */ + + for(k=0;k<*nboun;++k){xboun[k]=xbounact[k];} + for(k=0;k<*nforc;++k){xforc[k]=xforcact[k];} + for(k=0;k<2**nload;++k){xload[k]=xloadact[k];} + for(k=0;k<7**nbody;k=k+7){xbody[k]=xbodyact[k];} + if(*ithermal==1){ + for(k=0;k<*nk;++k){t1[k]=t1act[k];} + } + + free(v);free(fn);free(stn);free(inum);free(adb); + free(aub);free(z);free(b);free(zeta);free(bj);free(cd);free(cv); + free(xforcact);free(xloadact);free(xbounact);free(aa);free(bb);free(aanew); + free(ampli);free(xbodyact);free(bjp);free(bp);free(aamech);free(ikactmech); + free(xforcdiff);free(xloaddiff);free(xboundiff),free(xbodydiff); + + if(*ithermal==1) {free(t1act);free(t1diff);} + + if(iprescribedboundary){ + if(*isolver==0){ +#ifdef SPOOLES + spooles_cleanup(); +#endif + } + else if(*isolver==4){ +#ifdef SGI + sgi_cleanup(token); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_cleanup(); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_cleanup(&neq[1]); +#endif + } + free(bact);free(bmin);free(bv);free(bprev);free(bdiff); + } + + /* deleting the contact information */ + *ne=ne0; *nkon=nkon0; + if(ncont!=0){ + RENEW(ipkon,int,*ne); + RENEW(lakon,char,8**ne); + RENEW(kon,int,*nkon); + if(*nener==1){ + RENEW(ener,double,mi[0]**ne*2); + } + if(*norien>0){ + RENEW(ielorien,int,*ne); + } + RENEW(ielmat,int,*ne); + free(cg);free(straight);free(vini);free(bcont);free(springarea); + free(ikactcont);free(imastop);free(itiefac);free(islavsurf); + free(islavnode);free(nslavnode);free(iponoels);free(inoels); + free(areaslav); + + if(ifricdamp==1){free(aafric);free(bfric);} + + } + + if(!cyclicsymmetry){ + free(ad);free(au); + }else{ + free(adbe); free(aube);free(icole); free(irowe); free(jqe);free(izdof); + + *nk/=nsectors; + *ne/=nsectors; + *nkon/=nsectors; + *nboun/=nsectors; + neq[1]=neq[1]*2/nsectors; + + RENEW(nnn,int,*nk); + + RENEW(ialset,int,nalset_); + /* restore the infomration in istartset and iendset */ + for(j=0; j<*nset; j++){ + istartset[j]=istartset_[j]; + iendset[j]=iendset_[j]; + } + free(istartset_); + free(iendset_); + + RENEW(co,double,3**nk); + if((*ithermal!=0)&&(*nam>0)) RENEW(iamt1,int,*nk); + RENEW(nactdof,int,mt**nk); + if(*ntrans>0) RENEW(inotr,int,2**nk); + RENEW(kon,int,*nkon); + RENEW(ipkon,int,*ne); + RENEW(lakon,char,8**ne); + RENEW(ielmat,int,*ne); + if(*norien>0) RENEW(ielorien,int,*ne); + RENEW(nodeboun,int,*nboun); + RENEW(ndirboun,int,*nboun); + if(*nam>0) RENEW(iamboun,int,*nboun); + RENEW(xboun,double,*nboun); + RENEW(xbounold,double,*nboun); + RENEW(ikboun,int,*nboun); + RENEW(ilboun,int,*nboun); + + /* recovering the original multiple point constraints */ + + RENEW(ipompc,int,*nmpc); + RENEW(nodempc,int,3**mpcend); + RENEW(coefmpc,double,*mpcend); + RENEW(labmpc,char,20**nmpc+1); + RENEW(ikmpc,int,*nmpc); + RENEW(ilmpc,int,*nmpc); + RENEW(fmpc,double,*nmpc); + + *nmpc=nmpcold; + *mpcend=mpcendold; + for(i=0;i<*nmpc;i++){ipompc[i]=ipompcold[i];} + for(i=0;i<3**mpcend;i++){nodempc[i]=nodempcold[i];} + for(i=0;i<*mpcend;i++){coefmpc[i]=coefmpcold[i];} + for(i=0;i<20**nmpc;i++){labmpc[i]=labmpcold[i];} + for(i=0;i<*nmpc;i++){ikmpc[i]=ikmpcold[i];} + for(i=0;i<*nmpc;i++){ilmpc[i]=ilmpcold[i];} + free(ipompcold);free(nodempcold);free(coefmpcold); + free(labmpcold);free(ikmpcold);free(ilmpcold); + + RENEW(vold,double,mt**nk); + RENEW(veold,double,mt**nk); + RENEW(eme,double,6*mi[0]**ne); + RENEW(sti,double,6*mi[0]**ne); + if(*nener==1)RENEW(ener,double,mi[0]**ne*2); + +/* distributed loads */ + + for(i=0;i<*nload;i++){ + if(nelemload[2*i]0){ + if(*nam>0){ + FORTRAN(isortiddc2,(nelemload,iamload,xload,xloadold,sideload,nload,&kflag)); + }else{ + FORTRAN(isortiddc1,(nelemload,xload,xloadold,sideload,nload,&kflag)); + } + } + +/* point loads */ + + for(i=0;i<*nforc;i++){ + if(nodeforc[2*i+1]0) free(ipobody); + + if(dashpot){ + free(xini);free(rwork);free(adc);free(auc);free(cc); + free(rpar);free(iwork);} + + free(cstr); + + if(nmdnode>0){free(imddof);free(imdnode);free(imdboun);free(imdmpc);} + + if(iabsload==2) free(bold); + + *ialsetp=ialset; + *cop=co;*konp=kon;*ipkonp=ipkon;*lakonp=lakon;*ielmatp=ielmat; + *ielorienp=ielorien;*inotrp=inotr;*nodebounp=nodeboun; + *ndirbounp=ndirboun;*iambounp=iamboun;*xbounp=xboun; + *xbounoldp=xbounold;*ikbounp=ikboun;*ilbounp=ilboun;*nactdofp=nactdof; + *voldp=vold;*emep=eme;*enerp=ener;*ipompcp=ipompc;*nodempcp=nodempc; + *coefmpcp=coefmpc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; + *fmpcp=fmpc;*veoldp=veold;*iamt1p=iamt1;*t0p=t0;*t1oldp=t1old;*t1p=t1; + *nnnp=nnn;*stip=sti; + + return; +} + diff -Nru calculix-ccx-2.1/ccx_2.3/src/dynacont.c calculix-ccx-2.3/ccx_2.3/src/dynacont.c --- calculix-ccx-2.1/ccx_2.3/src/dynacont.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/dynacont.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1010 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include +#include +#include +#include "CalculiX.h" + +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif + +void dynacont(double *co, int *nk, int *kon, int *ipkon, char *lakon, int *ne, + int *nodeboun, int *ndirboun, double *xboun, int *nboun, + int *ipompc, int *nodempc, double *coefmpc, char *labmpc, + int *nmpc, int *nodeforc,int *ndirforc,double *xforc, + int *nforc,int *nelemload, char *sideload,double *xload, + int *nload, + int *nactdof,int *neq, int *nzl,int *icol, int *irow, + int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, + int *ilboun,double *elcon, int *nelcon, double *rhcon, + int *nrhcon,double *cocon, int *ncocon, + double *alcon, int *nalcon, double *alzero, + int *ielmat,int *ielorien, int *norien, double *orab, + int *ntmat_,double *t0, + double *t1,int *ithermal,double *prestr, int *iprestr, + double *vold,int *iperturb, double *sti, int *nzs, + double *tinc, double *tper, double *xmodalsteady, + double *veold, char *amname, double *amta, + int *namta, int *nam, int *iamforc, int *iamload, + int *iamt1,int *jout,char *filab,double *eme, double *xforcold, + double *xloadold, + double *t1old, int *iamboun, double *xbounold, int *iexpl, + double *plicon, int *nplicon, double *plkcon,int *nplkcon, + double *xstate, int *npmat_, char *matname, int *mi, + int *ncmat_, int *nstate_, double *ener, char *jobnamec, + double *ttime, char *set, int *nset, int *istartset, + int *iendset, int *ialset, int *nprint, char *prlab, + char *prset, int *nener, double *trab, + int *inotr, int *ntrans, double *fmpc, char *cbody, int *ibody, + double *xbody, int *nbody, double *xbodyold, int *istep, + int *isolver,int *jq, char *output, int *mcs, int *nkon, + int *mpcend, int *ics, double *cs, int *ntie, char *tieset, + int *idrct, int *jmax, double *tmin, double *tmax, + double *ctrl, int *itpamp, double *tietol,int *iit, + int *ncont,int *ne0, double *reltime, double *dtime, + double *bcontini, double *bj, double *aux, int *iaux, + double *bcont, int *nev, double *v, + int *nkon0, double *deltmx, double *dtheta, double *theta, + int *iprescribedboundary, int *mpcfree, int *memmpc_, + int *itietri, int *koncont, double *cg, double *straight, + int *iinc, double *vini, + double *aa, double *bb, double *aanew, double *d, + double *z, double *zeta,double *b, double *time0,double *time, + int *ipobody, + double *xforcact, double *xloadact, double *t1act, + double *xbounact, double *xbodyact, double *cd, double *cv, + double *ampli, double *dthetaref, double *bjp, double *bp, + double *cstr,int *imddof, int *nmddof, + int **ikactcontp, int *nactcont,int *nactcont_, + double *aamech, double *bprev, int *iprev, int *inonlinmpc, + int **ikactmechp, int *nactmech,int *imdnode,int *nmdnode, + int *imdboun,int *nmdboun,int *imdmpc,int *nmdmpc, + int *itp, int *inext,int *ifricdamp,double *aafric, + double *bfric, int *imastop,int *nslavnode,int *islavnode, + int *islavsurf, + int *itiefac,double *areaslav,int *iponoels,int *inoels, + double *springarea,int *izdof,int *nzdof){ + + char lakonl[9]=" \0"; + + int i,j,k,l,init,*itg=NULL,ntg=0,maxlenmpc,icascade=0,loop, + konl[20],imat,nope,kodem,indexe,j1,jdof,kmin,kmax, + id,newstep=0,idiscon,*ipiv=NULL,info,nrhs=1,kode,iener=0, + *ikactcont=NULL,*ilactcont=NULL,*ikactcont1=NULL,nactcont1=0, + i1,icutb=0,iconvergence=0,idivergence=0,mt=mi[1]+1, + nactcont1_=100,*ikactmech=NULL,iabsload=0,nactfric_,nactfric, + *ikactfric=NULL,im,cyclicsymmetry; + + long long i2; + + double *adb=NULL,*aub=NULL,*cgr=NULL, *au=NULL,fexp,fcos,fsin,fexm, + physcon[1],zetaj,dj,ddj,h1,h2,h3,h4,h5,h6,sum,aai,bbi,tstart,tend, + *ad=NULL,sigma=0.,alpham,betam,*bact=NULL,*bmin=NULL,*bv=NULL, + xl[27],voldl[mt*9],elas[21],fnl[27],t0l,t1l,elconloc[21],veoldl[mt*9], + bbmax,s[3600],*aaa=NULL,*bbb=NULL,func,funcp,*bjbasp=NULL, + *bjbas=NULL, *bjinc=NULL, *dbj=NULL, *lhs=NULL,dbjmax,bjmax, + *bjincp=NULL,sump,h14,*dbjp=NULL,senergy=0.0,*xforcdiff=NULL, + df,i0,ic,ia,dbjmaxOLD1,dbjmaxOLD2,*xloaddiff=NULL,*dbcont=NULL, + zl=0.0,*xbodydiff=NULL,*t1diff=NULL,*xboundiff=NULL,*bdiff=NULL, + *xstateini=NULL; + + ikactcont=*ikactcontp;ikactmech=*ikactmechp; + + /* check for cyclic symmetry */ + + if((*mcs==0)||(cs[1]<0)){cyclicsymmetry=0;}else{cyclicsymmetry=1;} + + if(*inonlinmpc==1) iabsload=2; + + if(ithermal[0]<=1){ + kmin=1;kmax=3; + }else if(ithermal[0]==2){ + kmin=0;kmax=mi[1];if(kmax>2)kmax=2; + }else{ + kmin=0;kmax=3; + } + + xforcdiff=NNEW(double,*nforc); + xloaddiff=NNEW(double,2**nload); + xbodydiff=NNEW(double,7**nbody); + /* copying the rotation axis and/or acceleration vector */ + for(k=0;k<7**nbody;k++){xbodydiff[k]=xbody[k];} + xboundiff=NNEW(double,*nboun); + if(*ithermal==1) t1diff=NNEW(double,*nk); + + /* load the convergence constants from ctrl*/ + + i0=ctrl[0];ic=ctrl[3];ia=ctrl[7];df=ctrl[10]; + + /* set the convergence parameters*/ + + dbjmaxOLD1=0.0; + dbjmaxOLD2=0.0; + +// printf("\nstart dynacont\n"); + + /* calculating the contact forces */ + +// memset(&bcont[0],0,sizeof(double)*neq[1]); + for(j=0;j<*nactcont;j++){bcont[ikactcont[j]]=0.;} + + *ne=*ne0;*nkon=*nkon0; + + contact(ncont,ntie,tieset,nset,set,istartset,iendset, + ialset,itietri,lakon,ipkon,kon,koncont,ne,cg, + straight,nkon,co,vold,ielmat,cs,elcon,istep, + iinc,iit,ncmat_,ntmat_,ne0, + vini,nmethod,nmpc,mpcfree,memmpc_, + &ipompc,&labmpc,&ikmpc,&ilmpc,&fmpc,&nodempc,&coefmpc, + iperturb,ikboun,nboun,mi,imastop,nslavnode,islavnode,islavsurf, + itiefac,areaslav,iponoels,inoels,springarea,tietol,reltime); + + ikactcont1=NNEW(int,nactcont1_); + + for(i=*ne0;i<*ne;i++){ + indexe=ipkon[i]; + imat=ielmat[i]; + kodem=nelcon[2*imat-2]; + for(j=0;j<8;j++){lakonl[j]=lakon[8*i+j];} + nope=atoi(&lakonl[7]); + for(j=0;j0){ + if(ikactcont[id-1]==jdof){ + break; + } + } + (*nactcont)++; + if(*nactcont>*nactcont_){ + *nactcont_=(int)(1.1**nactcont_); + RENEW(ikactcont,int,*nactcont_); + } + k=*nactcont-1; + l=k-1; + while(k>id){ + ikactcont[k--]=ikactcont[l--]; + } + ikactcont[id]=jdof; + break; + }while(1); + } +// free(ikactcont1); + + /* calculate the change in contact force */ + + bbmax=0.; + if(icutb==0){ + for(i=0;i<*nactcont;i++){ + jdof=ikactcont[i]; + if(fabs(bcont[jdof]-bcontini[jdof])>bbmax){ + bbmax=fabs(bcont[jdof]-bcontini[jdof]); + } + } + } + + /* removing entries in bcont */ + + for(j=0;j0){ + for(i=0;i<*nmdnode;i++){ + i1=mt*(imdnode[i]-1); + for(j=kmin;j<=kmax;j++){ + vold[i1+j]=vini[i1+j]; + } + } + }else{ + memcpy(&vold[0],&vini[0],sizeof(double)*mt**nk); + } + + /* restoring aa[(iinc-1)*nev+i] (before change of *dtime) */ + + for(i=0;i<*nev;i++){ + aa[i]+=bb[i]*(*time-*dtime); + } + + /* increment size is reduced if: + - the contact force change is too large (only in first iteration) + - or the increment did not converge */ + + if((bbmax>*deltmx || icutb>0)&&(((*itp==1)&&(*dtheta>*tmin))||(*itp==0))){ + + /* force increase too big: increment size is decreased */ + + if(icutb>0){ + *dtheta=*dtheta*df; +// printf("*INFORMATION: increment size is decreased to %e\nthe increment is reattempted\n\n",*dtheta**tper); + } + else{ + *dtheta=*dtheta**deltmx/bbmax; + } +// printf("correction of dtime due to contact: %e\n",*dtheta**tper); + *dthetaref=*dtheta; + if(*itp==1){ + (*inext)--; + *itp=0; + } + + /* check whether the new increment size is not too small */ + + if(*dtheta<*tmin){ +// printf("\n *WARNING: increment size %e smaller than minimum %e\n",*dtheta**tper,*tmin**tper); +// printf(" minimum is taken\n"); + *dtheta=*tmin; + *dthetaref=*dtheta; + } + + *reltime=*theta+(*dtheta); + *time=*reltime**tper; + *dtime=*dtheta**tper; + + /* calculating the instantaneous loads (forces, surface loading, + centrifugal and gravity loading or temperature) */ + + FORTRAN(temploaddiff,(xforcold,xforc,xforcact,iamforc,nforc, + xloadold,xload,xloadact,iamload,nload,ibody,xbody, + nbody,xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,time,reltime,ttime,dtime,ithermal, + nmethod,xbounold,xboun,xbounact,iamboun,nboun,nodeboun, + ndirboun,nodeforc, + ndirforc,istep,iinc,co,vold,itg,&ntg,amname,ikboun,ilboun, + nelemload,sideload,mi, + xforcdiff,xloaddiff,xbodydiff,t1diff,xboundiff,&iabsload, + iprescribedboundary,ntrans,trab,inotr,veold,nactdof,bcont)); + + /* calculating the instantaneous loading vector */ + + if(iabsload!=2){ + FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcdiff, + nforc,nelemload,sideload,xloaddiff,nload,xbodydiff, + ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, + ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + t0,t1diff,ithermal,iprestr,vold,iperturb,iexpl,plicon, + nplicon,plkcon,nplkcon, + npmat_,ttime,time,istep,iinc,dtime,physcon,ibody, + xbodyold,reltime,veold,matname,mi,ikactmech,nactmech)); + }else{ + FORTRAN(rhs,(co,nk,kon,ipkon,lakon,ne, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, + nforc,nelemload,sideload,xloadact,nload,xbodyact, + ipobody,nbody,cgr,b,nactdof,&neq[1],nmethod, + ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + t0,t1act,ithermal,iprestr,vold,iperturb,iexpl,plicon, + nplicon,plkcon,nplkcon, + npmat_,ttime,time,istep,iinc,dtime,physcon,ibody, + xbodyold,reltime,veold,matname,mi,ikactmech,nactmech)); + } + + /* correction for nonzero SPC's */ + + if(*iprescribedboundary){ + dynboun(amta,namta,nam,ampli,time,ttime,dtime, + xbounold,xboun, + xbounact,iamboun,nboun,nodeboun,ndirboun,ad,au,adb, + aub,icol,irow,neq,nzs,&sigma,b,isolver, + &alpham,&betam,nzl,&init,bact,bmin,jq,amname,bv, + bprev,bdiff,nactmech,&iabsload,iprev); + } + + /* correcting aamech */ + + if(!cyclicsymmetry){ + for(i=0;i<*nev;i++){ + i2=(long long)i*neq[1]; + + if(iabsload==2){aamech[i]=0.;} + if(*nactmech1.+1.e-6){ + ddj=dj*sqrt(zetaj*zetaj-1.); + h1=ddj-zetaj*dj; + h2=ddj+zetaj*dj; + h3=1./h1; + h4=1./h2; + h5=h3*h3; + h6=h4*h4; + tstart=0; + FORTRAN(fsuper,(time,dtime,&aa[l],&bb[l], + &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); + sum=func;sump=funcp; + FORTRAN(fsuper,(time,&tstart,&aa[l],&bb[l], + &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); + sum-=func;sump-=funcp; + fexm=exp(h1**dtime); + fexp=exp(-h2**dtime); + h14=zetaj*dj/ddj; + + bjbas[l]=sum/(2.*ddj)+(fexm+fexp)*cd[l]/2.+zetaj*(fexm-fexp)/(2.*sqrt(zetaj*zetaj-1.))*cd[l]+(fexm-fexp)*cv[l]/(2.*ddj); + bjbasp[l]=sump/(2.*ddj)+(h1*fexm-h2*fexp)*cd[l]/2.+(h14*cd[l]+cv[l]/ddj)*(h1*fexm+h2*fexp)/2.; + } + + /* critical damping */ + + else{ + h1=zetaj*dj; + h2=1./h1; + h3=h2*h2; + h4=h2*h3; + tstart=0; + FORTRAN(fcrit,(time,dtime,&aa[l],&bb[l],&zetaj,&dj, + &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); + sum=func;sump=funcp; + FORTRAN(fcrit,(time,&tstart,&aa[l],&bb[l],&zetaj,&dj, + &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); + sum-=func;sump+=funcp; + fexp=exp(-h1**dtime); + bjbas[l]=sum+fexp*((1.+h1**dtime)*cd[l]+*dtime*cv[l]); + bjbasp[l]=sump+fexp*(-h1*h1**dtime*cd[l]+(1.-h1**dtime)*cv[l]); + } + } + + /* calculating the incremental response due to contact */ + + aai=-(*time-*dtime)/(*dtime); + bbi=1./(*dtime); + + bjinc=NNEW(double,*nev); /* incremental response modal decomposition */ + bjincp=NNEW(double,*nev); + for(l=0;l<*nev;l++){ + zetaj=zeta[l]; + dj=d[l]; + + /* zero eigenfrequency: rigid body mode */ + + if(fabs(d[l])<=1.e-10){ + tstart=*time0; + tend=*time; + sum=tend*(aai**time+ + tend*((bbi**time-aai)/2.-bbi*tend/3.))- + tstart*(aai**time+ + tstart*((bbi**time-aai)/2.-bbi*tstart/3.)); + sump=tend*(aai+bbi*tend/2.)-tstart*(aai+bbi*tstart/2.); + + bjinc[l]=sum; + bjincp[l]=sump; + } + + /* subcritical damping */ + + else if(zetaj<1.-1.e-6){ + ddj=dj*sqrt(1.-zetaj*zetaj); + h1=zetaj*dj; + h2=h1*h1+ddj*ddj; + h3=h1*h1-ddj*ddj; + h4=2.*h1*ddj/h2; + tstart=0.; + FORTRAN(fsub,(time,dtime,&aai,&bbi,&ddj, + &h1,&h2,&h3,&h4,&func,&funcp)); + sum=func;sump=funcp; + FORTRAN(fsub,(time,&tstart,&aai,&bbi,&ddj, + &h1,&h2,&h3,&h4,&func,&funcp)); + sum-=func;sump-=funcp; + + bjinc[l]=sum/ddj; + bjincp[l]=sump/ddj; + + } + + /* supercritical damping */ + + else if(zetaj>1.+1.e-6){ + ddj=dj*sqrt(zetaj*zetaj-1.); + h1=ddj-zetaj*dj; + h2=ddj+zetaj*dj; + h3=1./h1; + h4=1./h2; + h5=h3*h3; + h6=h4*h4; + tstart=0.; + FORTRAN(fsuper,(time,dtime,&aai,&bbi, + &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); + sum=func;sump=funcp; + FORTRAN(fsuper,(time,&tstart,&aai,&bbi, + &h1,&h2,&h3,&h4,&h5,&h6,&func,&funcp)); + sum-=func;sump-=funcp; + + bjinc[l]=sum/(2.*ddj); + bjincp[l]=sump/(2.*ddj); + + } + + /* critical damping */ + + else{ + h1=zetaj*dj; + h2=1./h1; + h3=h2*h2; + h4=h2*h3; + tstart=0.; + FORTRAN(fcrit,(time,dtime,&aai,&bbi,&zetaj,&dj, + &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); + sum=func;sump=funcp; + FORTRAN(fcrit,(time,&tstart,&aai,&bbi,&zetaj,&dj, + &ddj,&h1,&h2,&h3,&h4,&func,&funcp)); + sum-=func;sump-=funcp; + + bjinc[l]=sum; + bjincp[l]=sump; + + } + } + + aaa=NNEW(double,*nev); + bbb=NNEW(double,*nev**nev); + lhs=NNEW(double,*nev**nev); + ipiv=NNEW(int,*nev); + dbj=NNEW(double,*nev); /* change in bj */ + dbjp=NNEW(double,*nev); /* change in djp */ + + /* starting solution for the iteration loop = base solution */ + + memcpy(&bj[0],&bjbas[0],sizeof(double)**nev); + memcpy(&bjp[0],&bjbasp[0],sizeof(double)**nev); + + /* major iteration loop for the contact response */ + + loop=0; +// printf("Contact-Iteration\n"); + do{ + loop++; +// printf("loop=%d\n",loop); + + /* composing the response */ + + if(*iprescribedboundary){ + if(*nmdnode==0){ + memcpy(&b[0],&bmin[0],sizeof(double)*neq[1]); + memcpy(&bp[0],&bv[0],sizeof(double)*neq[1]); + }else{ + for(i=0;i<*nmddof;i++){ + b[imddof[i]]=bmin[imddof[i]]; + bp[imddof[i]]=bv[imddof[i]]; + } + } + } + else{ + if(*nmdnode==0){ + DMEMSET(b,0,neq[1],0.); + DMEMSET(bp,0,neq[1],0.); + }else{ + for(i=0;i<*nmddof;i++){ + b[imddof[i]]=0.; + bp[imddof[i]]=0.; + } + } + } + + if(!cyclicsymmetry){ + if(*nmdnode==0){ + for(i=0;i100){*nactcont_=*nactcont;}else{*nactcont_=100;} + RENEW(ikactcont,int,*nactcont_); + RENEW(ilactcont,int,*nactcont_); + RENEW(dbcont,double,*nactcont_**nev); + + /* aaa(i) is the internal product of the contact force at the end of the + increment with eigenmode i + bbb(i,j) is the internal product of the change of the contact force with + respect to modal coordinate j with the eigenmode i */ + + DMEMSET(bbb,0,*nev**nev,0.); + DMEMSET(aaa,0,*nev,0.); + + if(!cyclicsymmetry){ + for(k=0; k<*nactcont; k++){ + i1=ikactcont[k]; + i2=(ilactcont[k]-1)**nev; + for(j=0; j<*nev; j++){ + zl=z[(long long)j*neq[1]+i1]; + aaa[j]+=zl*bcont[i1]; + for(l=0; l<*nev; l++){ + bbb[l**nev+j]+=zl*dbcont[i2+l]; + } + } + } + }else{ + for(k=0; k<*nactcont; k++){ + i1=ikactcont[k]; + i2=(ilactcont[k]-1)**nev; + FORTRAN(nident,(izdof,&i1,nzdof,&id)); + if(id!=0){ + if(izdof[id-1]==i1){ + for(j=0; j<*nev; j++){ + zl=z[j**nzdof+id-1]; + aaa[j]+=zl*bcont[i1]; + for(l=0; l<*nev; l++){ + bbb[l**nev+j]+=zl*dbcont[i2+l]; + } + } + }else{printf("*ERROR in dynacont\n");FORTRAN(stop,());} + }else{printf("*ERROR in dynacont\n");FORTRAN(stop,());} + } + } + + for(l=0;l<*nev;l++){ + i1=l**nev; + for(j=0;j<*nev;j++){ + if(j==l){lhs[i1+j]=1.;}else{lhs[i1+j]=0.;} + lhs[i1+j]-=bjinc[j]*bbb[i1+j]; + } + dbj[l]=bjbas[l]+bjinc[l]*aaa[l]-bj[l]; + } + + /* solve the system of equations; determine dbj */ + + FORTRAN(dgesv,(nev,&nrhs,lhs,nev,ipiv,dbj,nev,&info)); + + /* check the size of dbj */ + + bjmax=0.; + dbjmaxOLD2=dbjmaxOLD1; + dbjmaxOLD1=dbjmax; + dbjmax=0.; + for(i=0;i<*nev;i++){ + if(fabs(bj[i])>bjmax) bjmax=fabs(bj[i]); + if(fabs(dbj[i])>dbjmax) dbjmax=fabs(dbj[i]); + } + + iconvergence=0; + idivergence=0; + + if(dbjmax<=0.005*bjmax){ + + //calculate bjp: the derivative of bj w.r.t. time + + for(j=0; j<*nev; j++){ + bjp[j]=bjbasp[j]+bjincp[j]*aaa[j]; + } + FORTRAN(dgetrs,("No transpose",nev,&nrhs,lhs,nev,ipiv,bjp,nev,&info)); + iconvergence=1; + } + else{ + if(loop>=i0 && loop<=ic){ + /* check for divergence */ + if((dbjmax>dbjmaxOLD1) && (dbjmax>dbjmaxOLD2)){ + /* divergence --> cutback */ +// printf("*INFORMATION: divergence --> cutback\n"); + idivergence=1; + icutb++; + break; + } + } + else{ + if(loop>ic){ + /* cutback after ic iterations*/ +// printf("*INFORMATION: too many iterations --> cutback\n"); + idivergence=1; + icutb++; + break; + } + } + } + + /* add dbj to db */ + + for(j=0;j<*nev;j++){ + bj[j]+=dbj[j]; + } + + }while(1); + }while(idivergence==1 && icutb<10); + +// printf("Contact-Iteration Done\n"); + + if(icutb>=10){ + //no convergence, stop all + printf("*ERROR: Contact did not converge.\n"); + FORTRAN(stop,()); + } + + /* convergence has been reached */ + + /* calculating the damping/friction contribution */ + + if(*ifricdamp==1){ + nactfric_=*nactcont_; + nactfric=0; + ikactfric=NNEW(int,nactfric_); + +// memset(&ikactfric[0],0,sizeof(int)*nactfric_); + DMEMSET(ikactfric,0,nactfric_,0.); + + *ne=*ne0;*nkon=*nkon0; + contact(ncont,ntie,tieset,nset,set,istartset,iendset, + ialset,itietri,lakon,ipkon,kon,koncont,ne,cg, + straight,nkon,co,vold,ielmat,cs,elcon,istep, + iinc,iit,ncmat_,ntmat_,ne0, + vini,nmethod,nmpc,mpcfree,memmpc_, + &ipompc,&labmpc,&ikmpc,&ilmpc,&fmpc,&nodempc,&coefmpc, + iperturb,ikboun,nboun,mi,imastop,nslavnode,islavnode,islavsurf, + itiefac,areaslav,iponoels,inoels,springarea,tietol,reltime); + +// printf("number of contact springs = %d\n",*ne-*ne0); + + for(i=*ne0;i<*ne;i++){ + indexe=ipkon[i]; + imat=ielmat[i]; + kodem=nelcon[2*imat-2]; + for(j=0;j<8;j++){lakonl[j]=lakon[8*i+j];} + nope=atoi(&lakonl[7]); + for(j=0;j +#include +#include +#include +#include "CalculiX.h" + +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif +#ifdef PARDISO + #include "pardiso.h" +#endif + +void dynboun(double *amta,int *namta,int *nam,double *ampli, double *time, + double *ttime,double *dtime,double *xbounold,double *xboun, + double *xbounact,int *iamboun,int *nboun,int *nodeboun, + int *ndirboun, double *ad, double *au, double *adb, + double *aub, int *icol, int *irow, int *neq, int *nzs, + double *sigma, double *b, int *isolver, + double *alpham, double *betam, int *nzl, + int *init,double *bact, double *bmin, int *jq, + char *amname,double *bv, double *bprev, double *bdiff, + int *nactmech, int *icorrect, int *iprev){ + + int idiff[3],i,j,ic,ir,im; + + double *xbounmin=NULL,*xbounplus=NULL,*bplus=NULL, + *ba=NULL,deltatime,deltatime2,deltatimesq,timemin,ttimemin, + timeplus,ttimeplus,*aux=NULL,*b1=NULL,*b2=NULL,*bnew=NULL; + +#ifdef SGI + int token=1; +#endif + + xbounmin=NNEW(double,*nboun); + xbounplus=NNEW(double,*nboun); + + /* time increment for the calculation of the change of the + particular solution (needed to account for nonzero + SPC's) */ + + deltatime=*dtime; + deltatime2=2.*deltatime; + deltatimesq=deltatime*deltatime; + + /* the SPC value at timemin is stored in xbounmin */ + + if(*init==1){ + + /* at the start of a new step it is assumed that the previous step + has reached steady state (at least for the SPC conditions) */ + + for(i=0;i<*nboun;i++){ + xbounmin[i]=xbounold[i]; + xbounact[i]=xbounold[i]; + } + } + else{ + timemin=*time-deltatime; + ttimemin=*ttime-deltatime; + FORTRAN(temploadmodal,(amta,namta,nam,ampli,&timemin,&ttimemin,dtime, + xbounold,xboun,xbounmin,iamboun,nboun,nodeboun,ndirboun, + amname)); + } + + /* the SPC value at timeplus is stored in xbounplus */ + + timeplus=*time+deltatime; + ttimeplus=*ttime+deltatime; + FORTRAN(temploadmodal,(amta,namta,nam,ampli,&timeplus,&ttimeplus,dtime, + xbounold,xboun,xbounplus,iamboun,nboun,nodeboun,ndirboun, + amname)); + + bplus=NNEW(double,neq[1]); + ba=NNEW(double,neq[1]); + b1=NNEW(double,neq[1]); + b2=NNEW(double,neq[1]); + + /* check whether boundary conditions changed + comparision of min with prev */ + + if(*init==1){ + for(i=0;i<*nboun;i++){ + ic=neq[1]+i; + for(j=jq[ic]-1;j1.e-10){ + idiff[1]=1; + break; + } + } + if(*init==1){ + for(i=0;i<*nboun;i++){ + ic=neq[1]+i; + for(j=jq[ic]-1;j1.e-10){ + idiff[2]=1; + break; + } + } + if(idiff[2]==1){ + for(i=0;i<*nboun;i++){ + ic=neq[1]+i; + for(j=jq[ic]-1;j +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif + +void expand(double *co, int *nk, int *kon, int *ipkon, char *lakon, + int *ne, int *nodeboun, int *ndirboun, double *xboun, int *nboun, + int *ipompc, int *nodempc, double *coefmpc, char *labmpc, + int *nmpc, int *nodeforc, int *ndirforc,double *xforc, + int *nforc, int *nelemload, char *sideload, double *xload, + int *nload, int *nactdof, int *neq, + int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, int *ilboun, + double *elcon, int *nelcon, double *rhcon, int *nrhcon, + double *alcon, int *nalcon, double *alzero, int *ielmat, + int *ielorien, int *norien, double *orab, int *ntmat_, + double *t0,int *ithermal,double *prestr, int *iprestr, + double *vold,int *iperturb, double *sti, int *nzs, + double *adb, double *aub,char *filab, double *eme, + double *plicon, int *nplicon, double *plkcon,int *nplkcon, + double *xstate, int *npmat_, char *matname, int *mi, + int *ics, double *cs, int *mpcend, int *ncmat_, + int *nstate_, int *mcs, int *nkon, double *ener, + char *jobnamec, char *output, char *set, int *nset,int *istartset, + int *iendset, int *ialset, int *nprint, char *prlab, + char *prset, int *nener, double *trab, + int *inotr, int *ntrans, double *ttime, double *fmpc, + int *nev, double **zp, int *iamboun, double *xbounold, + int *nsectors, int *nm,int *icol,int *irow,int *nzl, int *nam, + int *ipompcold, int *nodempcold, double *coefmpcold, + char *labmpcold, int *nmpcold, double *xloadold, int *iamload, + double *t1old,double *t1,int *iamt1, double *xstiff,int **icolep, + int **jqep,int **irowep,int *isolver, + int *nzse,double **adbep,double **aubep,int *iexpl,int *ibody, + double *xbody,int *nbody,double *cocon,int *ncocon, + char* tieset,int* ntie, int **nnnp,int *imddof,int *nmddof, + int *imdnode,int *nmdnode,int *imdboun,int *nmdboun, + int *imdmpc,int *nmdmpc, int **izdofp, int *nzdof){ + + /* calls the Arnoldi Package (ARPACK) for cyclic symmetry calculations */ + + char *filabt,*tchar1=NULL,*tchar2=NULL,*tchar3=NULL; + + int *inum=NULL,k,idir,lfin,j,iout=0,index,inode,id,i,idof,im, + ielas,icmd,kk,l,nkt,icntrl,imag=1,icomplex,kkv,kk6,iterm, + lprev,ilength,ij,i1,i2,iel,ielset,node,indexe,nope,ml1, + *inocs=NULL,*ielcs=NULL,jj,l1,l2,is,nlabel,*nshcon=NULL, + nodeleft,*noderight=NULL,numnodes,ileft,kflag=2,itr,locdir, + neqh,j1,nodenew,mass[2]={1,1},stiffness=1,buckling=0,mt=mi[1]+1, + rhsi=0,intscheme=0,coriolis=0,istep=1,iinc=1,iperturbmass[2], + *mast1e=NULL,*ipointere=NULL,*irowe=*irowep,*ipobody=NULL,*jqe=*jqep, + *icole=*icolep,tint=-1,tnstart=-1,tnend=-1,tint2=-1,*nnn=*nnnp, + noderight_,*izdof=*izdofp,iload,iforc,*iznode=NULL,nznode,ll; + + long long lint; + + double *stn=NULL,*v=NULL,*temp_array=NULL,*vini=NULL, + *een=NULL,cam[5],*f=NULL,*fn=NULL,qa[3],*epn=NULL,*stiini=NULL, + *xstateini=NULL,theta,pi,*coefmpcnew=NULL,t[3],ctl,stl, + *stx=NULL,*enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL, + *qfx=NULL,*qfn=NULL,xreal,ximag,*vt=NULL,sum,*aux=NULL, + *coefright=NULL,*physcon=NULL,coef,a[9],ratio,reltime,*ade=NULL, + *aue=NULL,*adbe=*adbep,*aube=*aubep,*fext=NULL,*cgr=NULL, + *shcon=NULL,*springarea=NULL,*z=*zp, *zdof=NULL; + + /* dummy arguments for the results call */ + + double *veold=NULL,*accold=NULL,bet,gam,dtime,time; + + pi=4.*atan(1.); + neqh=neq[1]/2; + + noderight_=10; + noderight=NNEW(int,noderight_); + coefright=NNEW(double,noderight_); + + v=NNEW(double,2*mt**nk); + vt=NNEW(double,mt**nk**nsectors); + + fn=NNEW(double,2*mt**nk); + stn=NNEW(double,12**nk); + inum=NNEW(int,*nk); + stx=NNEW(double,6*mi[0]**ne); + + nlabel=30; + filabt=NNEW(char,87*nlabel); + for(i=1;i<87*nlabel;i++) filabt[i]=' '; + filabt[0]='U'; + + temp_array=NNEW(double,neq[1]); + coefmpcnew=NNEW(double,*mpcend); + + nkt=*nsectors**nk; + + /* assigning nodes and elements to sectors */ + + inocs=NNEW(int,*nk); + ielcs=NNEW(int,*ne); + ielset=cs[12]; + if((*mcs!=1)||(ielset!=0)){ + for(i=0;i<*nk;i++) inocs[i]=-1; + for(i=0;i<*ne;i++) ielcs[i]=-1; + } + + for(i=0;i<*mcs;i++){ + is=cs[17*i]; + if(is==1) continue; + ielset=cs[17*i+12]; + if(ielset==0) continue; + for(i1=istartset[ielset-1]-1;i10){ + iel=ialset[i1]-1; + if(ipkon[iel]<0) continue; + ielcs[iel]=i; + indexe=ipkon[iel]; + if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; + else {nope=6;} + for(i2=0;i2=ialset[i1-1]-1) break; + if(ipkon[iel]<0) continue; + ielcs[iel]=i; + indexe=ipkon[iel]; + if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; + else {nope=6;} + for(i2=0;i20) inotr[2*l+i*2**nk]=inotr[2*l]; + } + } + for(l=0;l<*nkon;l++){kon[l+i**nkon]=kon[l]+i**nk;} + for(l=0;l<*ne;l++){ + if(ielcs[l]==jj){ + if(ipkon[l]>=0){ + ipkon[l+i**ne]=ipkon[l]+i**nkon; + ielmat[l+i**ne]=ielmat[l]; + if(*norien>0) ielorien[l+i**ne]=ielorien[l]; + for(l1=0;l1<8;l1++){ + l2=8*l+l1; + lakon[l2+i*8**ne]=lakon[l2]; + } + }else{ + ipkon[l+i**ne]=ipkon[l]; + } + } + } + } + } + + icntrl=-1; + + FORTRAN(rectcyl,(co,vt,fn,stn,qfn,een,cs,&nkt,&icntrl,t,filabt,&imag,mi)); + +/* expand nactdof */ + + for(i=1;i<*nsectors;i++){ + lint=i*mt**nk; + for(j=0;j0) iamboun[i**nboun+j]=iamboun[j]; + ikboun[i**nboun+j]=ikboun[j]+8*i**nk; + ilboun[i**nboun+j]=ilboun[j]+i**nboun; + } + } + + /* distributed loads */ + + for(i=0;i<*nload;i++){ + if(nelemload[2*i+1]<*nsectors){ + nelemload[2*i]+=*ne*nelemload[2*i+1]; + }else{ + nelemload[2*i]+=*ne*(nelemload[2*i+1]-(*nsectors)); + } + iload=i+1; + FORTRAN(addizdofdload,(nelemload,sideload,ipkon,kon,lakon, + nactdof,izdof,nzdof,mi,&iload,iznode,&nznode,nk, + imdnode,nmdnode)); + } + + /* body loads */ + + if(*nbody>0){ + printf("*ERROR in expand: body loads are not allowed for modal dynamics\n and steady state dynamics calculations in cyclic symmetric structures\n\n"); + FORTRAN(stop,()); + } + + /* sorting the elements with distributed loads */ + + if(*nload>0){ + if(*nam>0){ + FORTRAN(isortiddc2,(nelemload,iamload,xload,xloadold,sideload,nload,&kflag)); + }else{ + FORTRAN(isortiddc1,(nelemload,xload,xloadold,sideload,nload,&kflag)); + } + } + +/* point loads */ + + for(i=0;i<*nforc;i++){ + if(nodeforc[2*i+1]<*nsectors){ + nodeforc[2*i]+=*nk*nodeforc[2*i+1]; + }else{ + nodeforc[2*i]+=*nk*(nodeforc[2*i+1]-(*nsectors)); + } + iforc=i+1; + FORTRAN(addizdofcload,(nodeforc,ndirforc,nactdof,mi,izdof, + nzdof,&iforc,iznode,&nznode,nk,imdnode,nmdnode,xforc)); + } + + /* loop over all eigenvalues; the loop starts from the highest eigenvalue + so that the reuse of z is not a problem + z before: real and imaginary part for a segment for all eigenvalues + z after: real part for all segments for all eigenvalues */ + + zdof=NNEW(double,*nev**nzdof); + + lfin=0; + for(j=*nev-1;j>-1;--j){ + lint=2*j*neqh; + + /* calculating the cosine and sine of the phase angle */ + + for(jj=0;jj<*mcs;jj++){ + theta=nm[j]*2.*pi/cs[17*jj]; + cs[17*jj+14]=cos(theta); + cs[17*jj+15]=sin(theta); + } + + /* generating the cyclic MPC's (needed for nodal diameters + different from 0 */ + + eei=NNEW(double,6*mi[0]**ne); + + DMEMSET(v,0,2*mt**nk,0.); + + for(k=0;k<2*neqh;k+=neqh){ + + for(i=0;i<6*mi[0]**ne;i++){eme[i]=0.;} + + if(k==0) {kk=0;kkv=0;kk6=0;} + else {kk=*nk;kkv=mt**nk;kk6=6**nk;} + for(i=0;i<*nmpc;i++){ + index=ipompc[i]-1; + /* check whether thermal mpc */ + if(nodempc[3*index+1]==0) continue; + coefmpcnew[index]=coefmpc[index]; + while(1){ + index=nodempc[3*index+2]; + if(index==0) break; + index--; + + icomplex=0; + inode=nodempc[3*index]; + if(strcmp1(&labmpc[20*i],"CYCLIC")==0){ + icomplex=atoi(&labmpc[20*i+6]);} + else if(strcmp1(&labmpc[20*i],"SUBCYCLIC")==0){ + for(ij=0;ij<*mcs;ij++){ + lprev=cs[ij*17+13]; + ilength=cs[ij*17+3]; + FORTRAN(nident,(&ics[lprev],&inode,&ilength,&id)); + if(id!=0){ + if(ics[lprev+id-1]==inode){icomplex=ij+1;break;} + } + } + } + + if(icomplex!=0){ + idir=nodempc[3*index+1]; + idof=nactdof[mt*(inode-1)+idir]-1; + if(idof==-1){xreal=1.;ximag=1.;} + else{xreal=z[lint+idof];ximag=z[lint+idof+neqh];} + if(k==0) { + if(fabs(xreal)<1.e-30)xreal=1.e-30; + coefmpcnew[index]=coefmpc[index]* + (cs[17*(icomplex-1)+14]+ + ximag/xreal*cs[17*(icomplex-1)+15]);} + else { + if(fabs(ximag)<1.e-30)ximag=1.e-30; + coefmpcnew[index]=coefmpc[index]* + (cs[17*(icomplex-1)+14]- + xreal/ximag*cs[17*(icomplex-1)+15]);} + } + else{coefmpcnew[index]=coefmpc[index];} + } + } + + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,&v[kkv],&stn[kk6],inum, + stx,elcon, + nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat,ielorien, + norien,orab,ntmat_,t0,t0,ithermal, + prestr,iprestr,filab,eme,&een[kk6],iperturb, + f,&fn[kkv],nactdof,&iout,qa,vold,&z[lint+k], + nodeboun,ndirboun,xboun,nboun,ipompc, + nodempc,coefmpcnew,labmpc,nmpc,nmethod,cam,&neqh,veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,&enern[kk],sti, + xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea,&reltime)); + + } + free(eei); + + /* mapping the results to the other sectors */ + + icntrl=2;imag=1; + + FORTRAN(rectcylexp,(co,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filabt,&imag,mi, + iznode,&nznode,nsectors,nk)); + + /* basis sector */ + + for(ll=0;ll10){ + noderight_=10; + RENEW(noderight,int,noderight_); + RENEW(coefright,double,noderight_); + } + ipompc[*nmpc]=*mpcend+1; + ikmpc[*nmpc]=ikmpc[j]+8*i**nk; + ilmpc[*nmpc]=ilmpc[j]+i**nmpcold; + strcpy1(&labmpc[20**nmpc],&labmpcold[20*j],20); + if(strcmp1(&labmpcold[20*j],"CYCLIC")==0){ + index=ipompcold[j]-1; + nodeleft=nodempcold[3*index]; + idir=nodempcold[3*index+1]; + index=nodempcold[3*index+2]-1; + numnodes=0; + do{ + node=nodempcold[3*index]; + if(nodempcold[3*index+1]==idir){ + noderight[numnodes]=node; + coefright[numnodes]=coefmpcold[index]; + numnodes++; + if(numnodes>=noderight_){ + noderight_=(int)(1.5*noderight_); + RENEW(noderight,int,noderight_); + RENEW(coefright,double,noderight_); + } + } + index=nodempcold[3*index+2]-1; + if(index==-1) break; + }while(1); + if(numnodes>0){ + sum=0.; + for(k=0;k1.e-10){ + ratio=coef/a[3*locdir+idir-1]; + }else{ratio=0.;} + FORTRAN(transformatrix,(&trab[7*itr-7], + &co[3*nodenew-3],a)); + coef=ratio*a[3*locdir+idir-1]; + } + } + } + } + + nodempc[3**mpcend]=nodenew; + nodempc[3**mpcend+1]=idir; + coefmpc[*mpcend]=coef; + index=nodempcold[3*index+2]-1; + if(index==-1) break; + nodempc[3**mpcend+2]=*mpcend+2; + (*mpcend)++; + }while(1); + nodempc[3**mpcend+2]=0; + (*mpcend)++; + } + (*nmpc)++; + } + } + + /* copying the temperatures */ + + if(*ithermal!=0){ + for(i=1;i<*nsectors;i++){ + lint=i**nk; + for(j=0;j<*nk;j++){ + t0[lint+j]=t0[j]; + t1old[lint+j]=t1old[j]; + t1[lint+j]=t1[j]; + } + } + if(*nam>0){ + for(i=1;i<*nsectors;i++){ + lint=i**nk; + for(j=0;j<*nk;j++){ + iamt1[lint+j]=iamt1[j]; + } + } + } + } + + /* copying the contact definition */ + + if(*nmethod==4){ + + /* first find the startposition to append the expanded contact fields*/ + + for(j=0; j<*nset; j++){ + if(iendset[j]>tint){ + tint=iendset[j]; + } + } + tint++; + /* now append and expand the contact definitons*/ + tchar1=NNEW(char,81); + tchar2=NNEW(char,81); + tchar3=NNEW(char,81); + for(i=0; i<*ntie; i++){ + if(tieset[i*(81*3)+80]=='C'){ + memcpy(tchar2,&tieset[i*(81*3)+81],81); + tchar2[80]='\0'; + memcpy(tchar3,&tieset[i*(81*3)+81+81],81); + tchar3[80]='\0'; + //a contact constraint was found, so append and expand the information + for(j=0; j<*nset; j++){ + memcpy(tchar1,&set[j*81],81); + tchar1[80]='\0'; + if(strcmp(tchar1,tchar2)==0){ + /* dependent nodal surface was found,copy the original information first */ + tnstart=tint; + for(k=0; k +#include +#include +#include +#include "CalculiX.h" + +void frdcyc(double *co,int *nk,int *kon,int *ipkon,char *lakon,int *ne,double *v, + double *stn,int *inum,int *nmethod,int *kode,char *filab, + double *een,double *t1,double *fn,double *time,double *epn, + int *ielmat,char *matname, double *cs, int *mcs, int *nkon, + double *enern, double *xstaten, int *nstate_, int *istep, + int *iinc, int *iperturb, double *ener, int *mi, char *output, + int *ithermal, double *qfn, int *ialset, int *istartset, + int *iendset, double *trab, int *inotr, int *ntrans, + double *orab, int *ielorien, int *norien, double *sti, + double *veold, int *noddiam,char *set,int *nset){ + + /* duplicates fields for static cyclic symmetric calculations */ + + char *lakont=NULL,description[13]=" "; + + int nkt,icntrl,*kont=NULL,*ipkont=NULL,*inumt=NULL,*ielmatt=NULL,net,i,l, + imag=0,mode=-1,ngraph,*inocs=NULL,*ielcs=NULL,l1,l2,is, + jj,node,i1,i2,nope,iel,indexe,j,ielset,*inotrt=NULL,mt=mi[1]+1, + *ipneigh=NULL,*neigh=NULL; + + double *vt=NULL,*fnt=NULL,*stnt=NULL,*eent=NULL,*cot=NULL,*t1t=NULL, + *epnt=NULL,*enernt=NULL,*xstatent=NULL,theta,pi,t[3],*qfnt=NULL, + *vr=NULL,*vi=NULL,*stnr=NULL,*stni=NULL,*vmax=NULL,*stnmax=NULL, + *stit=NULL,*eenmax=NULL; + + pi=4.*atan(1.); + + /* determining the maximum number of sectors to be plotted */ + + ngraph=1; + for(j=0;j<*mcs;j++){ + if(cs[17*j+4]>ngraph) ngraph=cs[17*j+4]; + } + + /* assigning nodes and elements to sectors */ + + inocs=NNEW(int,*nk); + ielcs=NNEW(int,*ne); + ielset=cs[12]; + if((*mcs!=1)||(ielset!=0)){ + for(i=0;i<*nk;i++) inocs[i]=-1; + for(i=0;i<*ne;i++) ielcs[i]=-1; + } + + for(i=0;i<*mcs;i++){ + is=cs[17*i+4]; + if(is==1) continue; + ielset=cs[17*i+12]; + if(ielset==0) continue; + for(i1=istartset[ielset-1]-1;i10){ + iel=ialset[i1]-1; + if(ipkon[iel]<0) continue; + ielcs[iel]=i; + indexe=ipkon[iel]; + if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; + else {nope=6;} + for(i2=0;i2=ialset[i1-1]-1) break; + if(ipkon[iel]<0) continue; + ielcs[iel]=i; + indexe=ipkon[iel]; + if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; + else {nope=6;} + for(i2=0;i20)inotrt=NNEW(int,2**nk*ngraph); + + if((strcmp1(&filab[0],"U ")==0)|| + ((strcmp1(&filab[87],"NT ")==0)&&(*ithermal>=2))) + vt=NNEW(double,mt**nk*ngraph); + if((strcmp1(&filab[87],"NT ")==0)&&(*ithermal<2)) + t1t=NNEW(double,*nk*ngraph); + if((strcmp1(&filab[174],"S ")==0)||(strcmp1(&filab[1044],"ZZS ")==0)) + stnt=NNEW(double,6**nk*ngraph); + if(strcmp1(&filab[261],"E ")==0) + eent=NNEW(double,6**nk*ngraph); + if((strcmp1(&filab[348],"RF ")==0)||(strcmp1(&filab[783],"RFL ")==0)) + fnt=NNEW(double,mt**nk*ngraph); + if(strcmp1(&filab[435],"PEEQ")==0) + epnt=NNEW(double,*nk*ngraph); + if(strcmp1(&filab[522],"ENER")==0) + enernt=NNEW(double,*nk*ngraph); + if(strcmp1(&filab[609],"SDV ")==0) + xstatent=NNEW(double,*nstate_**nk*ngraph); + if(strcmp1(&filab[696],"HFL ")==0) + qfnt=NNEW(double,3**nk*ngraph); + if((strcmp1(&filab[1044],"ZZS ")==0)||(strcmp1(&filab[2175],"CONT")==0)) + stit=NNEW(double,6*mi[0]**ne*ngraph); + + /* the topology only needs duplication the first time it is + stored in the frd file (*kode=1) + the above two lines are not true: lakon is needed for + contact information in frd.f */ + +// if(*kode==1){ + kont=NNEW(int,*nkon*ngraph); + ipkont=NNEW(int,*ne*ngraph); + lakont=NNEW(char,8**ne*ngraph); + ielmatt=NNEW(int,*ne*ngraph); +// } + inumt=NNEW(int,*nk*ngraph); + + nkt=ngraph**nk; + net=ngraph**ne; + + /* copying the coordinates of the first sector */ + + for(l=0;l<3**nk;l++){cot[l]=co[l];} + if(*ntrans>0){for(l=0;l<*nk;l++){inotrt[2*l]=inotr[2*l];}} + + /* copying the topology of the first sector */ + +// if(*kode==1){ + for(l=0;l<*nkon;l++){kont[l]=kon[l];} + for(l=0;l<*ne;l++){ipkont[l]=ipkon[l];} + for(l=0;l<8**ne;l++){lakont[l]=lakon[l];} + for(l=0;l<*ne;l++){ielmatt[l]=ielmat[l];} +// } + + /* generating the coordinates for the other sectors */ + + icntrl=1; + + FORTRAN(rectcyl,(cot,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filab,&imag,mi)); + + for(jj=0;jj<*mcs;jj++){ + is=cs[17*jj+4]; + for(i=1;i0){ + for(l=0;l<*nk;l++){ + if(inocs[l]==jj){ + inotrt[2*l+i*2**nk]=inotrt[2*l]; + } + } + } + + // if(*kode==1){ + + for(l=0;l<*nkon;l++){kont[l+i**nkon]=kon[l]+i**nk;} + for(l=0;l<*ne;l++){ + if(ielcs[l]==jj){ + if(ipkon[l]>=0){ + ipkont[l+i**ne]=ipkon[l]+i**nkon; + ielmatt[l+i**ne]=ielmat[l]; + for(l1=0;l1<8;l1++){ + l2=8*l+l1; + lakont[l2+i*8**ne]=lakon[l2]; + } + } + else ipkont[l+i**ne]=-1; + } + } + // } + } + } + + icntrl=-1; + + FORTRAN(rectcyl,(cot,vt,fnt,stnt,qfnt,eent,cs,&nkt,&icntrl,t,filab, + &imag,mi)); + + /* mapping the results to the other sectors */ + + for(l=0;l<*nk;l++){inumt[l]=inum[l];} + + icntrl=2; + + FORTRAN(rectcyl,(co,v,fn,stn,qfn,een,cs,nk,&icntrl,t,filab,&imag,mi)); + + if((strcmp1(&filab[0],"U ")==0)|| + ((strcmp1(&filab[87],"NT ")==0)&&(*ithermal>=2))) + for(l=0;l=2))){ + for(l1=0;l1<*nk;l1++){ + if(inocs[l1]==jj){ + for(l2=0;l2<4;l2++){ + l=mt*l1+l2; + vt[l+mt**nk*i]=v[l]; + } + } + } + } + + if((strcmp1(&filab[87],"NT ")==0)&&(*ithermal<2)){ + for(l=0;l<*nk;l++){ + if(inocs[l]==jj) t1t[l+*nk*i]=t1[l]; + } + } + + if(strcmp1(&filab[174],"S ")==0){ + for(l1=0;l1<*nk;l1++){ + if(inocs[l1]==jj){ + for(l2=0;l2<6;l2++){ + l=6*l1+l2; + stnt[l+6**nk*i]=stn[l]; + } + } + } + } + + if(strcmp1(&filab[261],"E ")==0){ + for(l1=0;l1<*nk;l1++){ + if(inocs[l1]==jj){ + for(l2=0;l2<6;l2++){ + l=6*l1+l2; + eent[l+6**nk*i]=een[l]; + } + } + } + } + + if((strcmp1(&filab[348],"RF ")==0)||(strcmp1(&filab[783],"RFL ")==0)){ + for(l1=0;l1<*nk;l1++){ + if(inocs[l1]==jj){ + for(l2=0;l2<4;l2++){ + l=mt*l1+l2; + fnt[l+mt**nk*i]=fn[l]; + } + } + } + } + + if(strcmp1(&filab[435],"PEEQ")==0){ + for(l=0;l<*nk;l++){ + if(inocs[l]==jj) epnt[l+*nk*i]=epn[l]; + } + } + + if(strcmp1(&filab[522],"ENER")==0){ + for(l=0;l<*nk;l++){ + if(inocs[l]==jj) enernt[l+*nk*i]=enern[l]; + } + } + + if(strcmp1(&filab[609],"SDV ")==0){ + for(l1=0;l1<*nk;l1++){ + if(inocs[l1]==jj){ + for(l2=0;l2<*nstate_;l2++){ + l=*nstate_*l1+l2; + xstatent[l+*nstate_**nk*i]=xstaten[l]; + } + } + } + } + + if(strcmp1(&filab[696],"HFL ")==0){ + for(l1=0;l1<*nk;l1++){ + if(inocs[l1]==jj){ + for(l2=0;l2<3;l2++){ + l=3*l1+l2; + qfnt[l+3**nk*i]=qfn[l]; + } + } + } + } + } + } + + icntrl=-2; + + FORTRAN(rectcyl,(cot,vt,fnt,stnt,qfnt,eent,cs,&nkt,&icntrl,t,filab, + &imag,mi)); + + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40*net);ipneigh=NNEW(int,nkt); + } + FORTRAN(out,(cot,&nkt,kont,ipkont,lakont,&net,vt,stnt,inumt,nmethod,kode, + filab,eent,t1t,fnt,time,epnt,ielmatt,matname,enernt, + xstatent,nstate_,istep,iinc,iperturb,ener,mi,output, + ithermal,qfnt,&mode,noddiam,trab,inotrt,ntrans,orab,ielorien, + norien,description,ipneigh,neigh,stit,vr,vi,stnr,stni, + vmax,stnmax,&ngraph,veold,&net,cs,set,nset,istartset, + iendset,ialset,eenmax)); + if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} + + if((strcmp1(&filab[0],"U ")==0)|| + ((strcmp1(&filab[87],"NT ")==0)&&(*ithermal>=2))) free(vt); + if((strcmp1(&filab[87],"NT ")==0)&&(*ithermal<2)) free(t1t); + if((strcmp1(&filab[174],"S ")==0)||(strcmp1(&filab[1044],"ZZS ")==0)) + free(stnt); + if(strcmp1(&filab[261],"E ")==0) free(eent); + if((strcmp1(&filab[348],"RF ")==0)||(strcmp1(&filab[783],"RFL ")==0)) + free(fnt); + if(strcmp1(&filab[435],"PEEQ")==0) free(epnt); + if(strcmp1(&filab[522],"ENER")==0) free(enernt); + if(strcmp1(&filab[609],"SDV ")==0) free(xstatent); + if(strcmp1(&filab[696],"HFL ")==0) free(qfnt); + if((strcmp1(&filab[1044],"ZZS ")==0)||(strcmp1(&filab[2175],"CONT")==0)) free(stit); + +// if(*kode==1){ + free(kont);free(ipkont);free(lakont);free(ielmatt); +// } + free(inumt);free(cot);if(*ntrans>0)free(inotrt); + return; +} + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frd.f calculix-ccx-2.3/ccx_2.3/src/frd.f --- calculix-ccx-2.1/ccx_2.3/src/frd.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frd.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1433 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frd(co,nk,kon,ipkon,lakon,ne0,v,stn,inum,nmethod, + & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern,xstaten, + & nstate_,istep,iinc,ithermal,qfn,mode,noddiam,trab,inotr, + & ntrans,orab,ielorien,norien,description,ipneigh,neigh, + & mi,stx,vr,vi,stnr,stni,vmax,stnmax,ngraph,veold,ener,ne, + & cs,set,nset,istartset,iendset,ialset,eenmax) +! +! stores the results in frd format +! +! iselect selects which nodes are to be stored: +! iselect=-1 means only those nodes for which inum negative +! ist, i.e. network nodes +! iselect=+1 means only those nodes for which inum positive +! ist, i.e. structural nodes +! iselect=0 means both of the above +! + implicit none +! + character*1 c + character*3 m1,m2,m3,m4,m5 + character*5 p0,p1,p2,p3,p4,p5,p6,p8,p10,p11,p12 + character*8 lakon(*),date,newclock,fmat + character*10 clock + character*12 description + character*20 newdate + character*80 matname(*) + character*81 set(*) + character*87 filab(*) + character*132 text +! + integer kon(*),inum(*),nk,ne0,nmethod,kode,i,j,ipkon(*),indexe, + & one,ielmat(*),nstate_,l,ithermal,mode,mi(2),norien, + & noddiam,null,icounter,inotr(2,*),ntrans,ipneigh(*),neigh(2,*), + & ielorien(*),iinc,istep,nkcoords,ngraph,k,nodes,nope,ne, + & nout,nset,istartset(*),iendset(*),ialset(*),iset,m, + & noutloc,ncomp,nksegment,iselect,noutplus,noutmin,ncomma +! + real*8 co(3,*),v(0:mi(2),*),stn(6,*),een(6,*),t1(*),fn(0:mi(2),*), + & time,epn(*),enern(*),xstaten(nstate_,*),pi,qfn(3,*),oner, + & trab(7,*),stx(6,mi(1),*),orab(7,*),vr(0:mi(2),*), + & vi(0:mi(2),*),stnr(6,*),stni(6,*),vmax(0:3,*),stnmax(0:6,*), + & veold(0:mi(2),*),ener(mi(1),*),cs(17,*),eenmax(0:6,*) +! + data icounter /0/ + save icounter,nkcoords,nout,noutmin,noutplus +! + pi=4.d0*datan(1.d0) +! + c='C' +! + m1=' -1' + m2=' -2' + m3=' -3' + m4=' -4' + m5=' -5' +! + p0=' 0' + p1=' 1' + p2=' 2' + p3=' 3' + p4=' 4' + p5=' 5' + p6=' 6' + p8=' 8' + p10=' 10' + p11=' 11' + p12=' 12' +! + if((time.le.0.d0).or.(nmethod.eq.2)) then + fmat(1:8)='(e12.5) ' + elseif((dlog10(time).ge.0.d0).and.(dlog10(time).lt.10.d0)) then + fmat(1:5)='(f12.' + ncomma=10-int(dlog10(time)+1.d0) + write(fmat(6:6),'(i1)') ncomma + fmat(7:8)=') ' + else + fmat(1:8)='(e12.5) ' + endif +! + null=0 + one=1 + oner=1.d0 +! + if(kode.eq.1) then +! + write(7,'(a5,a1)') p1,c + call date_and_time(date,clock) + newdate(1:20)=' ' + newdate(1:2)=date(7:8) + newdate(3:3)='.' + if(date(5:6).eq.'01') then + newdate(4:11)='january.' + newdate(12:15)=date(1:4) + elseif(date(5:6).eq.'02') then + newdate(4:12)='february.' + newdate(13:16)=date(1:4) + elseif(date(5:6).eq.'03') then + newdate(4:9)='march.' + newdate(10:13)=date(1:4) + elseif(date(5:6).eq.'04') then + newdate(4:9)='april.' + newdate(10:13)=date(1:4) + elseif(date(5:6).eq.'05') then + newdate(4:7)='may.' + newdate(8:11)=date(1:4) + elseif(date(5:6).eq.'06') then + newdate(4:8)='june.' + newdate(9:12)=date(1:4) + elseif(date(5:6).eq.'07') then + newdate(4:8)='july.' + newdate(9:12)=date(1:4) + elseif(date(5:6).eq.'08') then + newdate(4:10)='august.' + newdate(11:14)=date(1:4) + elseif(date(5:6).eq.'09') then + newdate(4:13)='september.' + newdate(14:17)=date(1:4) + elseif(date(5:6).eq.'10') then + newdate(4:11)='october.' + newdate(12:15)=date(1:4) + elseif(date(5:6).eq.'11') then + newdate(4:12)='november.' + newdate(13:16)=date(1:4) + elseif(date(5:6).eq.'12') then + newdate(4:12)='december.' + newdate(13:16)=date(1:4) + endif + newclock(1:2)=clock(1:2) + newclock(3:3)=':' + newclock(4:5)=clock(3:4) + newclock(6:6)=':' + newclock(7:8)=clock(5:6) + write(7,'(a5,''UUSER'')') p1 + write(7,'(a5,''UDATE'',14x,a20)') p1,newdate + write(7,'(a5,''UTIME'',14x,a8)') p1,newclock + write(7,'(a5,''UHOST'')') p1 + write(7,'(a5,''UPGM CalculiX'')') p1 + write(7,'(a5,''UDIR'')') p1 + write(7,'(a5,''UDBN'')') p1 +! +! storing the coordinates of the nodes +! + write(7,'(a5,a1,67x,i1)') p2,c,one +! + if(nmethod.ne.0) then + nout=0 + noutplus=0 + noutmin=0 + do i=1,nk + if(inum(i).eq.0) cycle + write(7,101) m1,i,(co(j,i),j=1,3) + nout=nout+1 + if(inum(i).gt.0) noutplus=noutplus+1 + if(inum(i).lt.0) noutmin=noutmin+1 + enddo + else + do i=1,nk + write(7,101) m1,i,(co(j,i),j=1,3) + enddo + nout=nk + endif +! +! nkcoords is the number of nodes at the time when +! the nodal coordinates are stored in the frd file. +! + nkcoords=nk +! + write(7,'(a3)') m3 +! +! storing the element topology +! + write(7,'(a5,a1,67x,i1)') p3,c,one +! + do i=1,ne0 +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + if((lakon(i)(7:7).eq.' ').or.(filab(1)(5:5).eq.'E').or. + & (lakon(i)(7:7).eq.'I')) then + write(7,'(a3,i10,3a5)') m1,i,p4,p0,matname(ielmat(i))(1:5) + write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,10) + write(7,'(a3,10i10)') m2,(kon(indexe+j),j=11,12), + & (kon(indexe+j),j=17,19),kon(indexe+20), + & (kon(indexe+j),j=13,16) + elseif(lakon(i)(7:7).eq.'B') then + write(7,'(a3,i10,3a5)')m1,i,p12,p0,matname(ielmat(i))(1:5) + write(7,'(a3,3i10)') m2,kon(indexe+21),kon(indexe+23), + & kon(indexe+22) + else + write(7,'(a3,i10,3a5)')m1,i,p10,p0,matname(ielmat(i))(1:5) + write(7,'(a3,8i10)') m2,(kon(indexe+20+j),j=1,8) + endif + elseif(lakon(i)(4:4).eq.'8') then + write(7,'(a3,i10,3a5)') m1,i,p1,p0,matname(ielmat(i))(1:5) + write(7,'(a3,8i10)') m2,(kon(indexe+j),j=1,8) + elseif(lakon(i)(4:5).eq.'10') then + write(7,'(a3,i10,3a5)') m1,i,p6,p0,matname(ielmat(i))(1:5) + write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,10) + elseif(lakon(i)(4:4).eq.'4') then + write(7,'(a3,i10,3a5)') m1,i,p3,p0,matname(ielmat(i))(1:5) + write(7,'(a3,4i10)') m2,(kon(indexe+j),j=1,4) + elseif(lakon(i)(4:5).eq.'15') then + if((lakon(i)(7:7).eq.' ').or.(filab(1)(5:5).eq.'E')) then + write(7,'(a3,i10,3a5)') m1,i,p5,p0,matname(ielmat(i))(1:5) + write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,9), + & kon(indexe+13) + write(7,'(a3,5i10)') m2,(kon(indexe+j),j=14,15), + & (kon(indexe+j),j=10,12) + else + write(7,'(a3,i10,3a5)') m1,i,p8,p0,matname(ielmat(i))(1:5) + write(7,'(a3,6i10)') m2,(kon(indexe+15+j),j=1,6) + endif + elseif(lakon(i)(4:4).eq.'6') then + write(7,'(a3,i10,3a5)') m1,i,p2,p0,matname(ielmat(i))(1:5) + write(7,'(a3,6i10)') m2,(kon(indexe+j),j=1,6) + elseif(lakon(i)(1:1).eq.'D') then + if((kon(indexe+1).eq.0).or.(kon(indexe+3).eq.0)) cycle + write(7,'(a3,i10,3a5)')m1,i,p12,p0,matname(ielmat(i))(1:5) + write(7,'(a3,3i10)') m2,kon(indexe+1),kon(indexe+3), + & kon(indexe+2) + elseif((lakon(i)(1:1).eq.'E').and.(lakon(i)(7:7).eq.'A'))then + write(7,'(a3,i10,3a5)')m1,i,p11,p0,matname(ielmat(i))(1:5) + write(7,'(a3,2i10)') m2,(kon(indexe+j),j=1,2) + endif +! + enddo +! + write(7,'(a3)') m3 +! + if(nmethod.eq.0) return + endif +! +! for cyclic symmetry frequency calculations only results +! for even numbers (= odd modes, numbering starts at 0)are stored +! + if((nmethod.eq.2).and.(((mode/2)*2.ne.mode).and. + & (noddiam.ge.0))) return +! +! storing the displacements of the nodes +! + if(filab(1)(1:4).eq.'U ') then +! + iselect=1 + call frdset(filab(1),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 DISP 4 1' + write(7,'(a132)') text + text=' -5 D1 1 2 1 0' + write(7,'(a132)') text + text=' -5 D2 1 2 2 0' + write(7,'(a132)') text + text=' -5 D3 1 2 3 0' + write(7,'(a132)') text + text=' -5 ALL 1 2 0 0 1ALL' + write(7,'(a132)') text +! + call frdvector(v,iset,ntrans,filab(1),nkcoords,inum,m1,inotr, + & trab,co,istartset,iendset,ialset,mi,ngraph) +! + write(7,'(a3)') m3 + endif +! +! storing the imaginary part of displacements of the nodes +! for the odd modes of cyclic symmetry calculations +! + if(noddiam.ge.0) then + if(filab(1)(1:4).eq.'U ') then +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 DISP 4 1' + write(7,'(a132)') text + text=' -5 D1 1 2 1 0' + write(7,'(a132)') text + text=' -5 D2 1 2 2 0' + write(7,'(a132)') text + text=' -5 D3 1 2 3 0' + write(7,'(a132)') text + text=' -5 ALL 1 2 0 0 1ALL' + write(7,'(a132)') text +! +c call frdvector(v((mi(2)+1)*nk,1),iset,ntrans,filab,nkcoords, +c & inum,m1,inotr,trab,co,istartset,iendset,ialset,mi,ngraph) + call frdvector(v(0,nk+1),iset,ntrans,filab(1),nkcoords, + & inum,m1,inotr,trab,co,istartset,iendset,ialset,mi,ngraph) +! + write(7,'(a3)') m3 + endif + endif +! +! storing the velocities of the nodes +! + if(filab(21)(1:4).eq.'V ') then +! + iselect=1 + call frdset(filab(21),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 VELO 4 1' + write(7,'(a132)') text + text=' -5 V1 1 2 1 0' + write(7,'(a132)') text + text=' -5 V2 1 2 2 0' + write(7,'(a132)') text + text=' -5 V3 1 2 3 0' + write(7,'(a132)') text + text=' -5 ALL 1 2 0 0 1ALL' + write(7,'(a132)') text +! + call frdvector(veold,iset,ntrans,filab(21),nkcoords,inum,m1, + & inotr,trab,co,istartset,iendset,ialset,mi,ngraph) +! + write(7,'(a3)') m3 + endif +! +! storing the temperatures in the nodes +! + if(filab(2)(1:4).eq.'NT ') then +! + iselect=0 + call frdset(filab(2),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 NDTEMP 1 1' + write(7,'(a132)') text + text=' -5 T 1 1 0 0' + write(7,'(a132)') text +! + if(ithermal.le.1) then + call frdscalar(t1,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ngraph,iselect) + else + ncomp=0 + call frdvectorcomp(v,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) + endif +! + write(7,'(a3)') m3 + endif +! +! storing the stresses in the nodes +! + if(filab(3)(1:4).eq.'S ') then +! + iselect=1 + call frdset(filab(3),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 STRESS 6 1' + write(7,'(a132)') text + text=' -5 SXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 SYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 SZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 SXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 SYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 SZX 1 4 3 1' + write(7,'(a132)') text +! + call frdtensor(stn,iset,nkcoords,inum,m1,istartset,iendset, + & ialset,ngraph) +! + write(7,'(a3)') m3 + endif +! +! storing the imaginary part of the stresses in the nodes +! for the odd modes of cyclic symmetry calculations +! + if(noddiam.ge.0) then + if(filab(3)(1:4).eq.'S ') then +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 STRESS 6 1' + write(7,'(a132)') text + text=' -5 SXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 SYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 SZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 SXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 SYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 SZX 1 4 3 1' + write(7,'(a132)') text +! + call frdtensor(stn(1,nk+1),iset,nkcoords,inum,m1,istartset, + & iendset,ialset,ngraph) +! + write(7,'(a3)') m3 + endif + endif +! +! storing the strains in the nodes +! + if(filab(4)(1:4).eq.'E ') then +! + iselect=1 + call frdset(filab(4),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 STRAIN 6 1' + write(7,'(a132)') text + text=' -5 EXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 EYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 EZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 EXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 EYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 EZX 1 4 3 1' + write(7,'(a132)') text +! + call frdtensor(een,iset,nkcoords,inum,m1,istartset,iendset, + & ialset,ngraph) +! + write(7,'(a3)') m3 + endif +! +! storing the forces in the nodes +! + if(filab(5)(1:4).eq.'RF ') then +! + iselect=1 + call frdset(filab(5),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 FORC 4 1' + write(7,'(a132)') text + text=' -5 F1 1 2 1 0' + write(7,'(a132)') text + text=' -5 F2 1 2 2 0' + write(7,'(a132)') text + text=' -5 F3 1 2 3 0' + write(7,'(a132)') text + text=' -5 ALL 1 2 0 0 1ALL' + write(7,'(a132)') text +! + call frdvector(fn,iset,ntrans,filab(5),nkcoords,inum,m1,inotr, + & trab,co,istartset,iendset,ialset,mi,ngraph) +! + write(7,'(a3)') m3 + endif +! +! storing the equivalent plastic strains in the nodes +! + if(filab(6)(1:4).eq.'PEEQ') then +! + iselect=1 + call frdset(filab(6),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 PE 1 1' + write(7,'(a132)') text + text=' -5 PE 1 1 0 0' + write(7,'(a132)') text +! + call frdscalar(epn,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +! storing the energy in the nodes +! + if(filab(7)(1:4).eq.'ENER') then +! + iselect=1 + call frdset(filab(7),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 ENER 1 1' + write(7,'(a132)') text + text=' -5 ENER 1 1 0 0' + write(7,'(a132)') text +! + call frdscalar(enern,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +! storing the contact informations at the nodes +! with CDIS,CSTR +! + if(filab(26)(1:4).eq.'CONT') then +! + do i=ne,1,-1 + if((lakon(i)(2:2).ne.'S').or. + & (lakon(i)(7:7).ne.'C')) exit + enddo + noutloc=ne-i +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 CONTACT 6 1' + write(7,'(a132)') text + text=' -5 COPEN 1 4 1 1' + write(7,'(a132)') text + text=' -5 CSLIP1 1 4 2 2' + write(7,'(a132)') text + text=' -5 CSLIP2 1 4 3 3' + write(7,'(a132)') text + text=' -5 CPRESS 1 4 1 2' + write(7,'(a132)') text + text=' -5 CSHEAR1 1 4 2 3' + write(7,'(a132)') text + text=' -5 CSHEAR2 1 4 3 1' + write(7,'(a132)') text +! + do i=ne,1,-1 + if((lakon(i)(2:2).ne.'S').or. + & (lakon(i)(7:7).ne.'C')) exit + read(lakon(i)(8:8),'(i1)') nope + nodes=kon(ipkon(i)+nope) + write(7,101) m1,nodes,(stx(j,1,i),j=1,6) + enddo +! + write(7,'(a3)') m3 + endif +! +! storing the contact energy in the nodes +! + if(filab(27)(1:4).eq.'CELS') then +! + do i=ne,1,-1 + if((lakon(i)(2:2).ne.'S').or. + & (lakon(i)(7:7).ne.'C')) exit + enddo + noutloc=ne-i +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 CELS 1 1' + write(7,'(a132)') text + text=' -5 CELS 1 1 0 0' + write(7,'(a132)') text +! + do i=ne,1,-1 + if((lakon(i)(2:2).ne.'S').or. + & (lakon(i)(7:7).ne.'C')) exit + read(lakon(i)(8:8),'(i1)') nope + nodes=kon(ipkon(i)+nope) + write(7,101) m1,nodes,ener(1,i) + enddo +! + write(7,'(a3)') m3 + endif +! +! storing the internal state variables in the nodes +! + if(filab(8)(1:4).eq.'SDV ') then +! + iselect=1 + call frdset(filab(8),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 SDV 6 1' + if(nstate_.le.9) then + write(text(18:18),'(i1)') nstate_ + else + write(text(17:18),'(i2)') nstate_ + endif + write(7,'(a132)') text + do j=1,nstate_ + text=' -5 SDV 1 1 0 0' + if(j.le.9) then + write(text(9:9),'(i1)') j + else + write(text(9:10),'(i2)') j + endif + write(7,'(a132)') text + enddo +! + if(iset.eq.0) then + do i=1,nkcoords + if(inum(i).le.0) cycle + do k=1,int((nstate_+5)/6) + if(k.eq.1) then + write(7,101) m1,i,(xstaten(j,i),j=1,min(6,nstate_)) + else + write(7,102) m2,(xstaten(j,i),j=(k-1)*6+1, + & min(k*6,nstate_)) + endif + enddo + enddo + else + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + i=ialset(k) + if(inum(i).le.0) cycle + do l=1,int((nstate_+5)/6) + if(l.eq.1) then + write(7,101) m1,i, + & (xstaten(j,i),j=1,min(6,nstate_)) + else + write(7,102) m2,(xstaten(j,i),j=(l-1)*6+1, + & min(l*6,nstate_)) + endif + enddo + else + i=ialset(k-2) + do + i=i-ialset(k) + if(i.ge.ialset(k-1)) exit + if(inum(i).le.0) cycle + do l=1,int((nstate_+5)/6) + if(l.eq.1) then + write(7,101) m1,i, + & (xstaten(j,i),j=1,min(6,nstate_)) + else + write(7,102) m2,(xstaten(j,i),j=(l-1)*6+1, + & min(l*6,nstate_)) + endif + enddo + enddo + endif + enddo + endif +! + write(7,'(a3)') m3 + endif +! +! storing the heat flux in the nodes +! + if((filab(9)(1:4).eq.'HFL ').and.(ithermal.gt.1)) then +! + iselect=1 + call frdset(filab(9),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! +c text= +c & ' 100CL .00000E+00 3 1' +c write(text(25:36),'(i12)') nout +c text(37:48)=description +c text(75:75)='1' +c write(text(8:12),'(i5)') 100+kode +c write(text(13:24),fmat) time +c write(text(59:63),'(i5)') kode +c write(7,'(a132)') text + text=' -4 FLUX 4 1' + write(7,'(a132)') text + text=' -5 F1 1 2 1 0' + write(7,'(a132)') text + text=' -5 F2 1 2 2 0' + write(7,'(a132)') text + text=' -5 F3 1 2 3 0' + write(7,'(a132)') text + text=' -5 ALL 1 2 0 0 1ALL' + write(7,'(a132)') text +! + if(iset.eq.0) then + do i=1,nkcoords + if(inum(i).le.0) cycle + write(7,101) m1,i,(qfn(j,i),j=1,3) + enddo + else + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + i=ialset(k) + if(inum(i).le.0) cycle + write(7,101) m1,i,(qfn(j,i),j=1,3) + else + i=ialset(k-2) + do + i=i-ialset(k) + if(i.ge.ialset(k-1)) exit + if(inum(i).le.0) cycle + write(7,101) m1,i,(qfn(j,i),j=1,3) + enddo + endif + enddo + endif +! + write(7,'(a3)') m3 + endif +! +! storing the heat generation in the nodes +! + if((filab(10)(1:4).eq.'RFL ').and.(ithermal.gt.1)) then +! + iselect=1 + call frdset(filab(10),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! +c text= +c & ' 100CL .00000E+00 3 1' +c write(text(25:36),'(i12)') nout +c text(37:48)=description +c text(75:75)='1' +c write(text(8:12),'(i5)') 100+kode +c write(text(13:24),fmat) time +c write(text(59:63),'(i5)') kode +c write(7,'(a132)') text + text=' -4 RFL 1 1' + write(7,'(a132)') text + text=' -5 RFL 1 1 0 0' + write(7,'(a132)') text +! + ncomp=0 + call frdvectorcomp(fn,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +! storing the Zienkiewicz-Zhu improved stresses in the nodes +! + if(filab(13)(1:3).eq.'ZZS') then +! + call estimator(co,nk,kon,ipkon,lakon,ne0,stn, + & ipneigh,neigh,stx,mi(1)) +! + iselect=1 + call frdset(filab(13),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 ZZSTR 6 1' + write(7,'(a132)') text + text=' -5 SXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 SYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 SZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 SXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 SYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 SZX 1 4 3 1' + write(7,'(a132)') text +! + call frdtensor(stn,iset,nkcoords,inum,m1,istartset,iendset, + & ialset,ngraph) +! + write(7,'(a3)') m3 + endif +! +! storing the imaginary part of the Zienkiewicz-Zhu stresses in the nodes +! for the odd modes of cyclic symmetry calculations +! + if(noddiam.ge.0) then + if(filab(13)(1:3).eq.'ZZS') then +! + call estimator(co,nk,kon,ipkon,lakon,ne0,stn, + & ipneigh,neigh,stx(1,1,ne+1),mi(1)) +! + iselect=1 + call frdset(filab(13),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 ZZSTR 6 1' + write(7,'(a132)') text + text=' -5 SXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 SYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 SZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 SXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 SYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 SZX 1 4 3 1' + write(7,'(a132)') text +! + call frdtensor(stn,iset,nkcoords,inum,m1,istartset,iendset, + & ialset,ngraph) +! + write(7,'(a3)') m3 + endif + endif +! +! storing the total temperature in the fluid nodes +! + if(filab(14)(1:4).eq.'TT ') then +! + iselect=-1 + call frdset(filab(14),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 TOTEMP 1 1' + write(7,'(a132)') text + text=' -5 TT 1 1 0 0' + write(7,'(a132)') text +! + ncomp=0 + call frdvectorcomp(v,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +! storing the mass flow in the fluid nodes +! + if(filab(15)(1:4).eq.'MF ') then +! + iselect=-1 + call frdset(filab(15),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 MAFLOW 1 1' + write(7,'(a132)') text + text=' -5 MF 1 1 0 0' + write(7,'(a132)') text +! + ncomp=1 + call frdvectorcomp(v,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +! storing the total pressure in the gas network nodes +! + if(filab(16)(1:4).eq.'PT ') then +! + iselect=-1 + call frdset(filab(16),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 TOPRES 1 1' + write(7,'(a132)') text + text=' -5 PT 1 1 0 0' + write(7,'(a132)') text +! + ncomp=2 + call frdvectorcomp(v,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +! storing the static pressure in the liquid network nodes +! + if(filab(22)(1:4).eq.'PT ') then +! + iselect=-1 + call frdset(filab(22),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 STPRES 1 1' + write(7,'(a132)') text + text=' -5 PS 1 1 0 0' + write(7,'(a132)') text +! + ncomp=2 + call frdvectorcomp(v,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +! storing the liquid depth in the channel nodes +! + if(filab(28)(1:4).eq.'DEPT') then +! + iselect=-1 + call frdset(filab(28),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 DEPTH 1 1' + write(7,'(a132)') text + text=' -5 DEPTH 1 1 0 0' + write(7,'(a132)') text +! + ncomp=2 + call frdvectorcomp(v,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +! storing the liquid depth in the channel nodes +! + if(filab(29)(1:4).eq.'HCRI') then +! + iselect=-1 + call frdset(filab(29),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 HCRIT 1 1' + write(7,'(a132)') text + text=' -5 HCRIT 1 1 0 0' + write(7,'(a132)') text +! + ncomp=3 + call frdvectorcomp(v,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +! storing the static temperature in the fluid nodes +! + if(filab(17)(1:4).eq.'TS ') then +! + iselect=-1 + call frdset(filab(17),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 STTEMP 1 1' + write(7,'(a132)') text + text=' -5 TS 1 1 0 0' + write(7,'(a132)') text +! + ncomp=3 + call frdvectorcomp(v,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) +! + write(7,'(a3)') m3 + endif +! +c if((nmethod.ne.2).and.(nmethod.lt.4)) return +! +! the remaining lines only apply to frequency calculations +! with cyclic symmetry and steady state calculations +! + if((nmethod.ne.2).and.(nmethod.ne.5)) return + if((nmethod.eq.5).and.(mode.eq.-1)) return +! +! storing the displacements of the nodes (magnitude, phase) +! + if(filab(11)(1:4).eq.'PU ') then +! + iselect=1 + call frdset(filab(11),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 PDISP 6 1' + write(7,'(a132)') text + text=' -5 MAG1 1 12 1 0' + write(7,'(a132)') text + text=' -5 MAG2 1 12 2 0' + write(7,'(a132)') text + text=' -5 MAG3 1 12 3 0' + write(7,'(a132)') text + text=' -5 PHA1 1 12 4 0' + write(7,'(a132)') text + text=' -5 PHA2 1 12 5 0' + write(7,'(a132)') text + text=' -5 PHA3 1 12 6 0' + write(7,'(a132)') text +! + if(iset.eq.0) then + do i=1,nkcoords + if(inum(i).eq.0) cycle + write(7,101) m1,i,(vr(j,i),j=1,3),(vi(j,i),j=1,3) + enddo + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + if(inum(i).eq.0) cycle + write(7,101) m1,i,(vr(j,i),j=1,3),(vi(j,i),j=1,3) + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(inum(i).eq.0) cycle + write(7,101) m1,i,(vr(j,i),j=1,3), + & (vi(j,i),j=1,3) + enddo + enddo + endif + enddo + endif +! + write(7,'(a3)') m3 + endif +! +! storing the temperatures of the nodes (magnitude,phase) +! + if(filab(12)(1:4).eq.'PNT ') then +! + iselect=1 + call frdset(filab(12),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 PNDTEMP 2 1' + write(7,'(a132)') text + text=' -5 MAG1 1 1 1 0' + write(7,'(a132)') text + text=' -5 PHA1 1 1 2 0' + write(7,'(a132)') text +! + if(iset.eq.0) then + do i=1,nkcoords + if(inum(i).eq.0) cycle + write(7,101) m1,i,vr(0,i),vi(0,i) + enddo + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + if(inum(i).eq.0) cycle + write(7,101) m1,i,vr(0,i),vi(0,i) + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(inum(i).eq.0) cycle + write(7,101) m1,i,vr(0,i),vi(0,i) + enddo + enddo + endif + enddo + endif +! + write(7,'(a3)') m3 + endif +! +! storing the stresses in the nodes (magnitude,phase) +! + if(filab(18)(1:4).eq.'PHS ') then +! + iselect=1 + call frdset(filab(18),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 PSTRESS 12 1' + write(7,'(a132)') text + text=' -5 MAGXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 MAGYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 MAGZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 MAGXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 MAGYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 MAGZX 1 4 3 1' + write(7,'(a132)') text + text=' -5 PHAXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 PHAYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 PHAZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 PHAXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 PHAYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 PHAZX 1 4 3 1' + write(7,'(a132)') text +! + if(iset.eq.0) then + do i=1,nkcoords + if(inum(i).le.0) cycle + write(7,101) m1,i,(stnr(j,i),j=1,4), + & stnr(6,i),stnr(5,i) + write(7,101) m2,i,(stni(j,i),j=1,4), + & stni(6,i),stni(5,i) + enddo + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + if(inum(i).le.0) cycle + write(7,101) m1,i,(stnr(j,i),j=1,4), + & stnr(6,i),stnr(5,i) + write(7,101) m2,i,(stni(j,i),j=1,4), + & stni(6,i),stni(5,i) + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(inum(i).le.0) cycle + write(7,101) m1,i,(stnr(j,i),j=1,4), + & stnr(6,i),stnr(5,i) + write(7,101) m2,i,(stni(j,i),j=1,4), + & stni(6,i),stni(5,i) + enddo + enddo + endif + enddo + endif +! + write(7,'(a3)') m3 + endif +! + if(nmethod.ne.2) return +! +! storing the maximum displacements of the nodes +! in the basis sector +! (magnitude, components) +! + if(filab(19)(1:4).eq.'MAXU') then +! + iselect=1 + call frdset(filab(19),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 MDISP 4 1' + write(7,'(a132)') text + text=' -5 DX 1 4 1 0' + write(7,'(a132)') text + text=' -5 DY 1 4 2 0' + write(7,'(a132)') text + text=' -5 DZ 1 4 3 0' + write(7,'(a132)') text + text=' -5 ANG 1 4 4 0' + write(7,'(a132)') text +! + if(iset.eq.0) then + do i=1,nkcoords + if(inum(i).eq.0) cycle + write(7,101) m1,i,(vmax(j,i),j=1,3),vmax(0,i) + enddo + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + if(inum(i).eq.0) cycle + write(7,101) m1,i,(vmax(j,i),j=1,3),vmax(0,i) + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(inum(i).eq.0) cycle + write(7,101) m1,i,(vmax(j,i),j=1,3),vmax(0,i) + enddo + enddo + endif + enddo + endif +! + write(7,'(a3)') m3 + endif +! +! storing the worst principal stress at the nodes +! in the basis sector (components, magnitude) +! +! the worst principal stress is the maximum of the +! absolute value of all principal stresses, times +! its original sign +! + if(filab(20)(1:4).eq.'MAXS') then +! + iselect=1 + call frdset(filab(20),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 MSTRESS 7 1' + write(7,'(a132)') text + text=' -5 SXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 SYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 SZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 SXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 SYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 SZX 1 4 3 1' + write(7,'(a132)') text + text=' -5 MAG 1 4 0 0' + write(7,'(a132)') text +! + if(iset.eq.0) then + do i=1,nkcoords + if(inum(i).le.0) cycle + write(7,101) m1,i,(stnmax(j,i),j=1,4), + & stnmax(6,i),stnmax(5,i) + write(7,101) m2,i,stnmax(0,i) + enddo + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + if(inum(i).le.0) cycle + write(7,101) m1,i,(stnmax(j,i),j=1,4), + & stnmax(6,i),stnmax(5,i) + write(7,101) m2,i,stnmax(0,i) + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(inum(i).le.0) cycle + write(7,101) m1,i,(stnmax(j,i),j=1,4), + & stnmax(6,i),stnmax(5,i) + write(7,101) m2,i,stnmax(0,i) + enddo + enddo + endif + enddo + endif +! + write(7,'(a3)') m3 + endif +! +! storing the worst principal strain at the nodes +! in the basis sector (components, magnitude) +! +! the worst principal strain is the maximum of the +! absolute value of all principal strains, times +! its original sign +! + if(filab(30)(1:4).eq.'MAXE') then +! + iselect=1 + call frdset(filab(30),set,iset,istartset,iendset,ialset, + & inum,noutloc,nout,nset,noutmin,noutplus,iselect) +! + call frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! + text=' -4 MSTRAIN 7 1' + write(7,'(a132)') text + text=' -5 EXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 EYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 EZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 EXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 EYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 EZX 1 4 3 1' + write(7,'(a132)') text + text=' -5 MAG 1 4 0 0' + write(7,'(a132)') text +! + if(iset.eq.0) then + do i=1,nkcoords + if(inum(i).le.0) cycle + write(7,101) m1,i,(eenmax(j,i),j=1,4), + & eenmax(6,i),eenmax(5,i) + write(7,101) m2,i,eenmax(0,i) + enddo + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + if(inum(i).le.0) cycle + write(7,101) m1,i,(eenmax(j,i),j=1,4), + & eenmax(6,i),eenmax(5,i) + write(7,101) m2,i,eenmax(0,i) + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(inum(i).le.0) cycle + write(7,101) m1,i,(eenmax(j,i),j=1,4), + & eenmax(6,i),eenmax(5,i) + write(7,101) m2,i,eenmax(0,i) + enddo + enddo + endif + enddo + endif +! + write(7,'(a3)') m3 + endif +! + 101 format(a3,i10,1p,6e12.5) + 102 format(a3,10x,1p,6e12.5) +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frdfluid.f calculix-ccx-2.3/ccx_2.3/src/frdfluid.f --- calculix-ccx-2.1/ccx_2.3/src/frdfluid.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frdfluid.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,615 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frdfluid(co,nk,kon,ipkon,lakon,ne,v,vold, + & kode,time,ielmat,matname,nnstep,vtu,voldtu,voldcon, + & physcon,filab,inomat,ntrans,inotr,trab,mi,stn) +! +! stores the results in frd format +! + implicit none +! + character*1 c + character*3 m1,m2,m3,m4,m5 + character*5 p0,p1,p2,p3,p4,p5,p6,p8,p10,p11,p12 + character*8 lakon(*),date,newclock,fmat + character*10 clock + character*20 newdate + character*80 matname(*) + character*87 filab(*) + character*132 text +! + integer kon(*),nk,ne,kode,i,j,ipkon(*),indexe,inomat(*), + & one,ielmat(*),null,nnstep,inotr(2,*),ntrans,mi(2) +! + real*8 co(3,*),v(0:mi(2),*),time,vold(0:mi(2),*),vtu(2,*), + & voldtu(2,*),stn(6,*), + & pi,oner,voldcon(0:4,*),physcon(*),trab(7,*),a(3,3) +! + kode=kode+1 + pi=4.d0*datan(1.d0) +! + c='C' +! + m1=' -1' + m2=' -2' + m3=' -3' + m4=' -4' + m5=' -5' +! + p0=' 0' + p1=' 1' + p2=' 2' + p3=' 3' + p4=' 4' + p5=' 5' + p6=' 6' + p8=' 8' + p10=' 10' + p11=' 11' + p12=' 12' +! + if(time.le.0.d0) then + fmat(1:8)='(e12.5) ' + elseif((dlog10(time).ge.0.d0).and.(dlog10(time).lt.11.d0)) then + fmat(1:5)='(f12.' + write(fmat(6:7),'(i2)') 11-int(dlog10(time)+1.d0) + fmat(8:8)=')' + else + fmat(1:8)='(e12.5) ' + endif +! + null=0 + one=1 + oner=1.d0 +! + if(kode.eq.1) then +! + write(7,'(a5,a1)') p1,c + call date_and_time(date,clock) + newdate(1:20)=' ' + newdate(1:2)=date(7:8) + newdate(3:3)='.' + if(date(5:6).eq.'01') then + newdate(4:11)='january.' + newdate(12:15)=date(1:4) + elseif(date(5:6).eq.'02') then + newdate(4:12)='february.' + newdate(13:16)=date(1:4) + elseif(date(5:6).eq.'03') then + newdate(4:9)='march.' + newdate(10:13)=date(1:4) + elseif(date(5:6).eq.'04') then + newdate(4:9)='april.' + newdate(10:13)=date(1:4) + elseif(date(5:6).eq.'05') then + newdate(4:7)='may.' + newdate(8:11)=date(1:4) + elseif(date(5:6).eq.'06') then + newdate(4:8)='june.' + newdate(9:12)=date(1:4) + elseif(date(5:6).eq.'07') then + newdate(4:8)='july.' + newdate(9:12)=date(1:4) + elseif(date(5:6).eq.'08') then + newdate(4:10)='august.' + newdate(11:14)=date(1:4) + elseif(date(5:6).eq.'09') then + newdate(4:13)='september.' + newdate(14:17)=date(1:4) + elseif(date(5:6).eq.'10') then + newdate(4:11)='october.' + newdate(12:15)=date(1:4) + elseif(date(5:6).eq.'11') then + newdate(4:12)='november.' + newdate(13:16)=date(1:4) + elseif(date(5:6).eq.'12') then + newdate(4:12)='december.' + newdate(13:16)=date(1:4) + endif + newclock(1:2)=clock(1:2) + newclock(3:3)=':' + newclock(4:5)=clock(3:4) + newclock(6:6)=':' + newclock(7:8)=clock(5:6) + write(7,'(a5,''UUSER'')') p1 + write(7,'(a5,''UDATE'',14x,a20)') p1,newdate + write(7,'(a5,''UTIME'',14x,a8)') p1,newclock + write(7,'(a5,''UHOST'')') p1 + write(7,'(a5,''UPGM CalculiX'')') p1 + write(7,'(a5,''UDIR'')') p1 + write(7,'(a5,''UDBN'')') p1 +! +! storing the coordinates of the nodes +! + write(7,'(a5,a1,67x,i1)') p2,c,one +! + do i=1,nk + write(7,100) m1,i,(co(j,i),j=1,3) + enddo +! + write(7,'(a3)') m3 +! +! storing the element topology +! + write(7,'(a5,a1,67x,i1)') p3,c,one +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + if((lakon(i)(7:7).eq.' ').or. + & (lakon(i)(7:7).eq.'H')) then + write(7,'(a3,i10,3a5)') m1,i,p4,p0,matname(ielmat(i))(1:5) + write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,10) + write(7,'(a3,10i10)') m2,(kon(indexe+j),j=11,12), + & (kon(indexe+j),j=17,19),kon(indexe+20), + & (kon(indexe+j),j=13,16) + elseif(lakon(i)(7:7).eq.'B') then + write(7,'(a3,i10,3a5)')m1,i,p12,p0,matname(ielmat(i))(1:5) + write(7,'(a3,3i10)') m2,kon(indexe+21),kon(indexe+23), + & kon(indexe+22) + else + write(7,'(a3,i10,3a5)')m1,i,p10,p0,matname(ielmat(i))(1:5) + write(7,'(a3,8i10)') m2,(kon(indexe+20+j),j=1,8) + endif + elseif(lakon(i)(4:4).eq.'8') then + write(7,'(a3,i10,3a5)') m1,i,p1,p0,matname(ielmat(i))(1:5) + write(7,'(a3,8i10)') m2,(kon(indexe+j),j=1,8) + elseif(lakon(i)(4:5).eq.'10') then + write(7,'(a3,i10,3a5)') m1,i,p6,p0,matname(ielmat(i))(1:5) + write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,10) + elseif(lakon(i)(4:4).eq.'4') then + write(7,'(a3,i10,3a5)') m1,i,p3,p0,matname(ielmat(i))(1:5) + write(7,'(a3,4i10)') m2,(kon(indexe+j),j=1,4) + elseif(lakon(i)(4:5).eq.'15') then + if((lakon(i)(7:7).eq.' ')) then + write(7,'(a3,i10,3a5)') m1,i,p5,p0,matname(ielmat(i))(1:5) + write(7,'(a3,10i10)') m2,(kon(indexe+j),j=1,9), + & kon(indexe+13) + write(7,'(a3,5i10)') m2,(kon(indexe+j),j=14,15), + & (kon(indexe+j),j=10,12) + else + write(7,'(a3,i10,3a5)') m1,i,p8,p0,matname(ielmat(i))(1:5) + write(7,'(a3,6i10)') m2,(kon(indexe+15+j),j=1,6) + endif + elseif(lakon(i)(4:4).eq.'6') then + write(7,'(a3,i10,3a5)') m1,i,p2,p0,matname(ielmat(i))(1:5) + write(7,'(a3,6i10)') m2,(kon(indexe+j),j=1,6) + elseif(lakon(i)(1:1).eq.'D') then + if((kon(indexe+1).eq.0).or.(kon(indexe+3).eq.0)) cycle + write(7,'(a3,i10,3a5)')m1,i,p12,p0,matname(ielmat(i))(1:5) + write(7,'(a3,3i10)') m2,kon(indexe+1),kon(indexe+3), + & kon(indexe+2) + elseif(lakon(i)(1:1).eq.'E') then + write(7,'(a3,i10,3a5)')m1,i,p11,p0,matname(ielmat(i))(1:5) + write(7,'(a3,2i10)') m2,(kon(indexe+j),j=1,2) + endif +! + enddo +! + write(7,'(a3)') m3 +! + endif +! +! storing the velocities in the nodes +! + if((nnstep.eq.1).or.(nnstep.eq.3)) then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 DFVEL 4 1' + write(7,'(a132)') text + text=' -5 V1 1 2 1 0' + write(7,'(a132)') text + text=' -5 V2 1 2 2 0' + write(7,'(a132)') text + text=' -5 V3 1 2 3 0' + write(7,'(a132)') text + text=' -5 ALL 1 2 0 0 1ALL' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,(v(j,i),j=1,3) + enddo +! + write(7,'(a3)') m3 +! +! +! storing the static pressure in the nodes +! + elseif(nnstep.eq.2) then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 DDENSIT 1 1' + write(7,'(a132)') text + text=' -5 DRHO 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,v(4,i) + enddo +! + write(7,'(a3)') m3 +! +! storing the static temperature in the nodes +! + elseif(nnstep.eq.4) then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 DENERGY 1 1' + write(7,'(a132)') text + text=' -5 DRE 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,v(0,i) + enddo +! + write(7,'(a3)') m3 +! +! storing the turbulence parameters in the nodes +! + elseif(nnstep.eq.5) then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 DTURB1 1 1' + write(7,'(a132)') text + text=' -5 K 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,vtu(1,i) + enddo +! + write(7,'(a3)') m3 +! + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 DTURB2 1 1' + write(7,'(a132)') text + text=' -5 OM 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,vtu(2,i) + enddo +! + write(7,'(a3)') m3 +! + elseif(nnstep.eq.6) then +! + if(filab(21)(1:4).eq.'V ') then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 V3DF 4 1' + write(7,'(a132)') text + text=' -5 V1 1 2 1 0' + write(7,'(a132)') text + text=' -5 V2 1 2 2 0' + write(7,'(a132)') text + text=' -5 V3 1 2 3 0' + write(7,'(a132)') text + text=' -5 ALL 1 2 0 0 1ALL' + write(7,'(a132)') text +! + if((ntrans.eq.0).or.(filab(21)(6:6).eq.'G')) then + do i=1,nk + if(inomat(i).le.0) cycle + write(7,100) m1,i,(vold(j,i),j=1,3) + enddo + else + do i=1,nk + if(inomat(i).le.0) cycle + if(inotr(1,i).eq.0) then + write(7,100) m1,i,(vold(j,i),j=1,3) + else + call transformatrix(trab(1,inotr(1,i)),co(1,i),a) + write(7,100) m1,i, + & vold(1,i)*a(1,1)+vold(2,i)*a(2,1)+vold(3,i)*a(3,1), + & vold(1,i)*a(1,2)+vold(2,i)*a(2,2)+vold(3,i)*a(3,2), + & vold(1,i)*a(1,3)+vold(2,i)*a(2,3)+vold(3,i)*a(3,3) + endif + enddo + endif +! + write(7,'(a3)') m3 + endif +! + if(filab(22)(1:4).eq.'PS ') then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 PS3DF 1 1' + write(7,'(a132)') text + text=' -5 PS 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,vold(4,i) + enddo +! + write(7,'(a3)') m3 + endif +! + if(filab(17)(1:4).eq.'TS ') then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 TS3DF 1 1' + write(7,'(a132)') text + text=' -5 TS 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,vold(0,i) + enddo +! + write(7,'(a3)') m3 + endif +! + if(filab(23)(1:4).eq.'MACH') then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 M3DF 1 1' + write(7,'(a132)') text + text=' -5 MACH 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,v(1,i) + enddo +! + write(7,'(a3)') m3 + endif +! + if(filab(14)(1:4).eq.'TT ') then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 TT3DF 1 1' + write(7,'(a132)') text + text=' -5 TT 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,vold(0,i)*(1.d0+(v(0,i)-1.d0)/2*v(1,i)**2) + enddo +! + write(7,'(a3)') m3 + endif +! + if(filab(16)(1:4).eq.'PT ') then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 PT3DF 1 1' + write(7,'(a132)') text + text=' -5 PT 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,vold(4,i)* + & (1.d0+(v(0,i)-1.d0)/2*v(1,i)**2)**(v(0,i)/(v(0,i)-1.d0)) + enddo +! + write(7,'(a3)') m3 + endif +! +! storing the stresses in the nodes +! + if(filab(3)(1:4).eq.'S ') then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 STRESS 6 1' + write(7,'(a132)') text + text=' -5 SXX 1 4 1 1' + write(7,'(a132)') text + text=' -5 SYY 1 4 2 2' + write(7,'(a132)') text + text=' -5 SZZ 1 4 3 3' + write(7,'(a132)') text + text=' -5 SXY 1 4 1 2' + write(7,'(a132)') text + text=' -5 SYZ 1 4 2 3' + write(7,'(a132)') text + text=' -5 SZX 1 4 3 1' + write(7,'(a132)') text + do i=1,nk + write(7,100) m1,i,(stn(j,i),j=1,4), + & stn(6,i),stn(5,i) + enddo + write(7,'(a3)') m3 + endif +! + if(filab(24)(1:4).eq.'CP ') then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 CP3DF 1 1' + write(7,'(a132)') text + text=' -5 CP 1 1 0 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,(vold(4,i)-physcon(6))*2.d0/ + & (physcon(7)*physcon(5)**2) + enddo +! + write(7,'(a3)') m3 + endif +! + if(filab(25)(1:4).eq.'TURB') then + text=' 1PSTEP' + write(text(25:36),'(i12)') kode + write(7,'(a132)') text +! + text= + & ' 100CL .00000E+00 3 1' + text(75:75)='1' + write(text(25:36),'(i12)') nk + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text + text=' -4 TURB3DF 2 1' + write(7,'(a132)') text + text=' -5 K 1 1 1 0' + write(7,'(a132)') text + text=' -5 OM 1 2 2 0' + write(7,'(a132)') text +! + do i=1,nk + write(7,100) m1,i,voldtu(1,i),voldtu(2,i) + enddo +! + write(7,'(a3)') m3 + endif + endif +! + 100 format(a3,i10,1p,6e12.5) +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frdheader.f calculix-ccx-2.3/ccx_2.3/src/frdheader.f --- calculix-ccx-2.1/ccx_2.3/src/frdheader.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frdheader.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,95 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frdheader(icounter,oner,time,pi,noddiam,cs,null,mode, + & noutloc,description,kode,nmethod,fmat) +! +! stores the results header in frd format +! + implicit none +! + character*8 fmat + character*12 description + character*132 text +! + integer icounter,noddiam,null,mode,noutloc,kode,nmethod +! + real*8 oner,time,pi,cs(17,*) +! + text=' 1PSTEP' + icounter=icounter+1 + write(text(25:36),'(i12)') icounter + write(7,'(a132)') text + if(nmethod.eq.2) then + text=' 1PGM' + write(text(25:36),'(e12.6)') oner + write(7,'(a132)') text + text=' 1PGK' + write(text(25:36),'(e12.6)') (time*2.d0*pi)**2 + write(7,'(a132)') text + text=' 1PHID' + write(text(25:36),'(i12)') noddiam + write(7,'(a132)') text + if(noddiam.ge.0) then + text=' 1PAX' + write(text(25:36),'(1p,e12.5)') cs(6,1) + write(text(37:48),'(1p,e12.5)') cs(7,1) + write(text(49:60),'(1p,e12.5)') cs(8,1) + write(text(61:72),'(1p,e12.5)') cs(9,1) + write(text(73:84),'(1p,e12.5)') cs(10,1) + write(text(85:96),'(1p,e12.5)') cs(11,1) + write(7,'(a132)') text + endif + text=' 1PSUBC' + write(text(25:36),'(i12)') null + write(7,'(a132)') text + text=' 1PMODE' + write(text(25:36),'(i12)') mode+1 + write(7,'(a132)') text + endif +! + if(nmethod.eq.1) then + text= + & ' 100CL .00000E+00 0 1' + elseif(nmethod.eq.2) then + text= + & ' 100CL .00000E+00 2 1' + elseif(nmethod.eq.3) then + text= + & ' 100CL .00000E+00 4 1' + elseif((nmethod.eq.4).or.(nmethod.eq.5)) then + text= + & ' 100CL .00000E+00 1 1' + else + text= + & ' 100CL .00000E+00 3 1' + endif + write(text(25:36),'(i12)') noutloc + text(37:48)=description + if(nmethod.eq.2) text(64:68)='MODAL' + text(75:75)='1' + write(text(8:12),'(i5)') 100+kode + write(text(13:24),fmat) time + write(text(59:63),'(i5)') kode + write(7,'(a132)') text +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frdscalar.f calculix-ccx-2.3/ccx_2.3/src/frdscalar.f --- calculix-ccx-2.1/ccx_2.3/src/frdscalar.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frdscalar.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,79 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frdscalar(epn,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ngraph,iselect) +! +! stores a scalar result in frd format +! + implicit none +! + character*3 m1 +! + integer iset,nkcoords,inum(*),nksegment,ngraph, + & istartset(*),iendset(*),ialset(*),i,j,k,l,m,iselect +! + real*8 epn(*) +! + if(iset.eq.0) then + do i=1,nkcoords + if(iselect.eq.1) then + if(inum(i).le.0) cycle + elseif(iselect.eq.0) then + if(inum(i).eq.0) cycle + endif + write(7,101) m1,i,epn(i) + enddo + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + if(iselect.eq.1) then + if(inum(i).le.0) cycle + elseif(iselect.eq.0) then + if(inum(i).eq.0) cycle + endif + write(7,101) m1,i,epn(i) + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(iselect.eq.1) then + if(inum(i).le.0) cycle + elseif(iselect.eq.0) then + if(inum(i).eq.0) cycle + endif + write(7,101) m1,i,epn(i) + enddo + enddo + endif + enddo + endif +! + 101 format(a3,i10,1p,6e12.5) +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frdset.f calculix-ccx-2.3/ccx_2.3/src/frdset.f --- calculix-ccx-2.1/ccx_2.3/src/frdset.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frdset.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,83 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frdset(filabl,set,iset,istartset,iendset, + & ialset,inum,noutloc,nout,nset,noutmin,noutplus,iselect, + & ngraph) +! +! stores the results in frd format +! + implicit none +! + character*81 set(*),noset + character*87 filabl +! + integer iset,istartset(*),iendset(*),ialset(*),inum(*), + & noutloc,j,k,nout,nset,noutmin,noutplus,iselect,ngraph +! +! check for a set, if any +! + noset=filabl(7:87) + do iset=1,nset + if(set(iset).eq.noset) exit + enddo + if(iset.gt.nset) iset=0 +! +! determining the number of nodes in the set +! + if(iset.eq.0) then + if(iselect.eq.1) then + noutloc=noutplus + elseif(iselect.eq.-1) then + noutloc=noutmin + else + noutloc=nout + endif + else + noutloc=0 + do j=istartset(iset),iendset(iset) + if(ialset(j).gt.0) then + if(iselect.eq.-1) then + if(inum(ialset(j)).lt.0) noutloc=noutloc+1 + elseif(iselect.eq.1) then + if(inum(ialset(j)).gt.0) noutloc=noutloc+1 + else + if(inum(ialset(j)).ne.0) noutloc=noutloc+1 + endif + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + if(iselect.eq.-1) then + if(inum(k).lt.0) noutloc=noutloc+1 + elseif(iselect.eq.1) then + if(inum(k).gt.0) noutloc=noutloc+1 + else + if(inum(k).ne.0) noutloc=noutloc+1 + endif + enddo + endif + enddo + if(ngraph.gt.1) noutloc=noutloc*ngraph + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frdtensor.f calculix-ccx-2.3/ccx_2.3/src/frdtensor.f --- calculix-ccx-2.1/ccx_2.3/src/frdtensor.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frdtensor.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,72 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frdtensor(stn,iset,nkcoords,inum,m1,istartset,iendset, + & ialset,ngraph) +! +! stores a tensor result (2nd order) in frd format +! + implicit none +! + character*3 m1 +! + integer iset,nkcoords,inum(*),ngraph,nksegment, + & istartset(*),iendset(*),ialset(*),i,j,k,l,m,kal(2,6) +! + real*8 stn(6,*) +! + data kal /1,1,2,2,3,3,1,2,1,3,2,3/ +! + if(iset.eq.0) then + do i=1,nkcoords + if(inum(i).le.0) cycle + write(7,101) m1,i,(stn(j,i),j=1,4), + & stn(6,i),stn(5,i) + enddo + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + if(inum(i).le.0) cycle + write(7,101) m1,i,(stn(j,i),j=1,4), + & stn(6,i),stn(5,i) + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(inum(i).le.0) cycle + write(7,101) m1,i,(stn(j,i),j=1,4), + & stn(6,i),stn(5,i) + enddo + enddo + endif + enddo + endif +! + 101 format(a3,i10,1p,6e12.5) +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frdvectorcomp.f calculix-ccx-2.3/ccx_2.3/src/frdvectorcomp.f --- calculix-ccx-2.1/ccx_2.3/src/frdvectorcomp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frdvectorcomp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,86 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frdvectorcomp(fn,iset,nkcoords,inum,m1, + & istartset,iendset,ialset,ncomp,mi,ngraph,iselect) +! +! stores a scalar result in frd format +! + implicit none +! + character*3 m1 +! + integer iset,nkcoords,inum(*),mi(2),ngraph,nksegment, + & istartset(*),iendset(*),ialset(*),i,k,l,m,ncomp,iselect +! + real*8 fn(0:mi(2),*) +! + if(iset.eq.0) then + do i=1,nkcoords + if(iselect.eq.1) then + if(inum(i).le.0) cycle + elseif(iselect.eq.-1) then + if(inum(i).ge.0) cycle + else + if(inum(i).eq.0) cycle + endif + write(7,101) m1,i,fn(ncomp,i) + enddo + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + i=ialset(k) + if(iselect.eq.1) then + if(inum(i).le.0) cycle + elseif(iselect.eq.-1) then + if(inum(i).ge.0) cycle + else + if(inum(i).eq.0) cycle + endif + write(7,101) m1,i,fn(ncomp,i) + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(iselect.eq.1) then + if(inum(i).le.0) cycle + elseif(iselect.eq.-1) then + if(inum(i).ge.0) cycle + else + if(inum(i).eq.0) cycle + endif + write(7,101) m1,i,fn(ncomp,i) + enddo + enddo + endif + enddo + endif +! + 101 format(a3,i10,1p,6e12.5) +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frdvector.f calculix-ccx-2.3/ccx_2.3/src/frdvector.f --- calculix-ccx-2.1/ccx_2.3/src/frdvector.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frdvector.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,103 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frdvector(v,iset,ntrans,filabl,nkcoords,inum,m1,inotr, + & trab,co,istartset,iendset,ialset,mi,ngraph) +! +! stores a vector result in frd format +! + implicit none +! + character*3 m1 + character*87 filabl +! + integer mi(2),iset,ntrans,nkcoords,inum(*),inotr(2,*), + & istartset(*),iendset(*),ialset(*),i,j,k,l,m,ngraph, + & nksegment +! + real*8 v(0:mi(2),*),trab(7,*),co(3,*),a(3,3) +! + if(iset.eq.0) then + if((ntrans.eq.0).or.(filabl(6:6).eq.'G')) then + do i=1,nkcoords + if(inum(i).le.0) cycle + write(7,101) m1,i,(v(j,i),j=1,3) + enddo + else + do i=1,nkcoords + if(inum(i).le.0) cycle + if(inotr(1,i).eq.0) then + write(7,101) m1,i,(v(j,i),j=1,3) + else + call transformatrix(trab(1,inotr(1,i)),co(1,i),a) + write(7,101) m1,i, + & v(1,i)*a(1,1)+v(2,i)*a(2,1)+v(3,i)*a(3,1), + & v(1,i)*a(1,2)+v(2,i)*a(2,2)+v(3,i)*a(3,2), + & v(1,i)*a(1,3)+v(2,i)*a(2,3)+v(3,i)*a(3,3) + endif + enddo + endif + else + nksegment=nkcoords/ngraph + do k=istartset(iset),iendset(iset) + if(ialset(k).gt.0) then + do l=0,ngraph-1 + i=ialset(k)+l*nksegment + if(inum(i).le.0) cycle + if((ntrans.eq.0).or.(filabl(6:6).eq.'G').or. + & (inotr(1,i).eq.0)) then + write(7,101) m1,i,(v(j,i),j=1,3) + else + call transformatrix(trab(1,inotr(1,i)),co(1,i),a) + write(7,101) m1,i, + & v(1,i)*a(1,1)+v(2,i)*a(2,1)+v(3,i)*a(3,1), + & v(1,i)*a(1,2)+v(2,i)*a(2,2)+v(3,i)*a(3,2), + & v(1,i)*a(1,3)+v(2,i)*a(2,3)+v(3,i)*a(3,3) + endif + enddo + else + l=ialset(k-2) + do + l=l-ialset(k) + if(l.ge.ialset(k-1)) exit + do m=0,ngraph-1 + i=l+m*nksegment + if(inum(i).le.0) cycle + if((ntrans.eq.0).or.(filabl(6:6).eq.'G').or. + & (inotr(1,i).eq.0)) then + write(7,101) m1,i,(v(j,i),j=1,3) + else + call transformatrix(trab(1,inotr(1,i)), + & co(1,i),a) + write(7,101) m1,i, + & v(1,i)*a(1,1)+v(2,i)*a(2,1)+v(3,i)*a(3,1), + & v(1,i)*a(1,2)+v(2,i)*a(2,2)+v(3,i)*a(3,2), + & v(1,i)*a(1,3)+v(2,i)*a(2,3)+v(3,i)*a(3,3) + endif + enddo + enddo + endif + enddo + endif +! + 101 format(a3,i10,1p,6e12.5) +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frequencies.f calculix-ccx-2.3/ccx_2.3/src/frequencies.f --- calculix-ccx-2.1/ccx_2.3/src/frequencies.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frequencies.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,159 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frequencies(inpc,textpart,nmethod, + & mei,fei,iperturb,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,ithermal,isolver,xboun,nboun,ipoinpc) +! +! reading the input deck: *FREQUENCY +! + implicit none +! + character*1 inpc(*) + character*20 solver + character*132 textpart(16) +! + integer nmethod,mei(4),ncv,mxiter,istep,istat,iperturb(2),i,nboun, + & n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*),nev,ithermal,isolver, + & ipoinpc(0:*) +! + real*8 fei(3),pi,fmin,fmax,tol,xboun(*) +! + pi=4.d0*datan(1.d0) + mei(4)=0 +! + if(istep.lt.1) then + write(*,*) '*ERROR in frequencies: *FREQUENCY can only be used' + write(*,*) ' within a STEP' + stop + endif +! +! no heat transfer analysis +! + if(ithermal.gt.1) then + ithermal=1 + endif +! +! default solver +! + solver=' ' + if(isolver.eq.0) then + solver(1:20)='SPOOLES ' + elseif(isolver.eq.2) then + solver(1:16)='ITERATIVESCALING' + elseif(isolver.eq.3) then + solver(1:17)='ITERATIVECHOLESKY' + elseif(isolver.eq.4) then + solver(1:3)='SGI' + elseif(isolver.eq.5) then + solver(1:5)='TAUCS' + elseif(isolver.eq.7) then + solver(1:7)='PARDISO' + endif +! + do i=2,n + if(textpart(i)(1:7).eq.'SOLVER=') then + read(textpart(i)(8:27),'(a20)') solver + elseif(textpart(i)(1:11).eq.'STORAGE=YES') then + mei(4)=1 + else + write(*,*) + & '*WARNING in frequencies: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(solver(1:7).eq.'SPOOLES') then + isolver=0 + elseif(solver(1:16).eq.'ITERATIVESCALING') then + write(*,*) '*WARNING in frequencies: the iterative scaling' + write(*,*) ' procedure is not available for frequency' + write(*,*) ' calculations; the default solver is used' + elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then + write(*,*) '*WARNING in frequencies: the iterative scaling' + write(*,*) ' procedure is not available for frequency' + write(*,*) ' calculations; the default solver is used' + elseif(solver(1:3).eq.'SGI') then + isolver=4 + elseif(solver(1:5).eq.'TAUCS') then + isolver=5 + elseif(solver(1:13).eq.'MATRIXSTORAGE') then + isolver=6 + elseif(solver(1:7).eq.'PARDISO') then + isolver=7 + else + write(*,*) '*WARNING in frequencies: unknown solver;' + write(*,*) ' the default solver is used' + endif +! + if((isolver.eq.2).or.(isolver.eq.3)) then + write(*,*) '*ERROR in frequencies: the default solver ', + & solver + write(*,*) ' cannot be used for frequency calculations ' + stop + endif +! + nmethod=2 + if(iperturb(1).gt.1) iperturb(1)=0 + iperturb(2)=0 +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*) '*ERROR in frequencies: definition not complete' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + read(textpart(1)(1:10),'(i10)',iostat=istat) nev + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(nev.le.0) then + write(*,*) '*ERROR in frequencies: less than 1 eigenvalue re + &quested' + stop + endif + tol=1.d-2 + ncv=4*nev + ncv=ncv+nev + mxiter=1000 + read(textpart(2)(1:20),'(f20.0)',iostat=istat) fmin + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) fmax + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! + mei(1)=nev + mei(2)=ncv + mei(3)=mxiter + fei(1)=tol + fei(2)=fmin + fei(3)=fmax +! +! removing nonzero boundary conditions +! + do i=1,nboun + xboun(i)=0.d0 + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/friction_coefficient.f calculix-ccx-2.3/ccx_2.3/src/friction_coefficient.f --- calculix-ccx-2.1/ccx_2.3/src/friction_coefficient.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/friction_coefficient.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,115 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! This subroutine computes the friction coefficient of +! the pipe flow for laminar and turbulent flow including the +! transition region +! + subroutine friction_coefficient(l,d,ks,reynolds,form_fact,lambda) +! + implicit none +! + real*8 l,d,ks,reynolds,form_fact,lambda,alfa2, + & rey_turb_min,rey_lam_max,lzd,dd,ds,friction,dfriction, + & lambda_kr,lambda_turb,ksd +! + rey_turb_min=4000 + rey_lam_max=2000 + lzd=l/d + ksd=ks/d +! +! transition laminar turbulent domain +! + if((reynolds.gt.rey_lam_max).and.(reynolds.lt.rey_turb_min))then +! + lambda_kr=64.d0/rey_lam_max +! +! Solving the implicit White-Colebrook equation +! 1/dsqrt(friction)=-2*log10(2.51/(Reynolds*dsqrt(friction)+0.27*Ks)) +! +! Using Haaland explicit relationship for the initial friction value +! S.E. Haaland 1983 (Source en.Wikipwedia.org) +! + friction=(-1.8*dlog10(6.9d0/4000.d0+(ksd/3.7d0)**1.11d0))**-2 +! + do + ds=dsqrt(friction) + dd=2.51d0/(4000.d0*ds)+0.27d0*ksd + dfriction=(1.d0/ds+2.d0*dlog10(dd))*2.d0*friction*ds/ + & (1.d0+2.51d0/(4000.d0*dd)) + if(dfriction.le.friction*1.d-3) then + friction=friction+dfriction + exit + endif + friction=friction+dfriction + enddo + lambda_turb=friction + +! +! logarithmic interpolation in the trans laminar turbulent domain +! + lambda=lambda_kr*(lambda_turb/lambda_kr) + & **(log(reynolds/rey_lam_max)/log(rey_turb_min/rey_lam_max)) +! +! laminar flow +! using Couette-Poiseuille formula +! the form factor for non round section can be found in works such as +! Bohl,W +! "Technische Strömungslehre Stoffeigenschaften von Flüssigkeiten und +! Gasen, hydrostatik,aerostatik,incompressible Strömungen, +! Strömungsmesstechnik +! Vogel Würzburg Verlag 1980 +! + elseif(reynolds.lt.rey_lam_max) then + lambda=64.d0/reynolds + lambda=form_fact*lambda +! +! turbulent +! + else +! Solving the implicit White-Colebrook equation +! 1/dsqrt(friction)=-2*log10(2.51/(Reynolds*dsqrt(friction)+0.27*Ks)) +! +! Using Haaland explicit relationship for the initial friction value +! S.E. Haaland 1983 (Source en.Wikipwedia.org) +! + friction=(-1.8*dlog10(6.9d0/reynolds+(ksd/3.7d0) + & **1.11d0))**-2 +! + do + ds=dsqrt(friction) + dd=2.51d0/(reynolds*ds)+0.27d0*ksd + dfriction=(1.d0/ds+2.d0*dlog10(dd))*2.d0*friction*ds/ + & (1.d0+2.51d0/(reynolds*dd)) + if(dfriction.le.friction*1.d-3) then + friction=friction+dfriction + exit + endif + friction=friction+dfriction + enddo + lambda=friction + endif +! + call interpol_alfa2(lzd,reynolds,alfa2) +! + return +! + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/frictions.f calculix-ccx-2.3/ccx_2.3/src/frictions.f --- calculix-ccx-2.1/ccx_2.3/src/frictions.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/frictions.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,71 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine frictions(inpc,textpart,elcon,nelcon, + & imat,ntmat_,ncmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, + & inp,ipoinpc,nstate_,ichangefriction) +! +! reading the input deck: *FRICTION +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nelcon(2,*),imat,ntmat_,istep,istat,ipoinpc(0:*), + & n,key,i,ncmat_,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*), + & nstate_,ichangefriction +! + real*8 elcon(0:ncmat_,ntmat_,*) +! + if((istep.gt.0).and.(irstrt.ge.0).and.(ichangefriction.eq.0)) then + write(*,*) '*ERROR reading *FRICTION:' + write(*,*) ' *FRICTION should be placed' + write(*,*) ' before all step definitions' + stop + endif +! + if(imat.eq.0) then + write(*,*) '*ERROR reading *FRICTION:' + write(*,*) ' *FRICTION should be preceded' + write(*,*) ' by a *SURFACE INTERACTION card' + stop + endif +! + nstate_=max(nstate_,3) +! + nelcon(1,imat)=7 + nelcon(2,imat)=1 +! +! no temperature dependence allowed; last line is decisive +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + do i=1,2 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(5+i,1,imat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + elcon(0,1,imat)=0.d0 + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/fridaforc.f calculix-ccx-2.3/ccx_2.3/src/fridaforc.f --- calculix-ccx-2.1/ccx_2.3/src/fridaforc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/fridaforc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,275 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine fridaforc(xl,konl,vl,imat,elcon,nelcon, + & elas,fnl,ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc, + & plicon,nplicon,npmat_,veoldl,senergy,iener,cstr,mi,springarea) +! +! calculates the force of the spring +! + implicit none +! + character*8 lakonl +! + integer konl(9),i,j,imat,ncmat_,ntmat_,nope,nterms,iflag,mi(2), + & kode,nplicon(0:ntmat_,*),npmat_,nelcon(2,*),iener +! + real*8 xl(3,9),elas(21),ratio(9),t0l,t1l,al(3),vl(0:mi(2),9), + & pl(3,9),xn(3),areamaster,alpha,beta,fnl(3,9), + & veoldl(0:mi(2),9),dist,springarea, + & elcon(0:ncmat_,ntmat_,*),pproj(3),xsj2(3),xs2(3,7),val, + & shp2(7,8),xi,et,elconloc(21),plconloc(82), + & plicon(0:2*npmat_,ntmat_,*),fn, + & damp,c0,eta,um,eps,fnd(3,9),fnv(3,9),ver(3),dvernor, + & dampforc,vertan(3),dvertan,fricforc,pi,senergy,cstr(6) +! + data iflag /2/ +! +! actual positions of the nodes belonging to the contact spring +! + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i)+vl(j,i) + enddo + enddo +! + nterms=nope-1 +! +! vector vr connects the dependent node with its projection +! on the independent face +! + do i=1,3 + pproj(i)=pl(i,nope) + enddo + call attach(pl,pproj,nterms,ratio,dist,xi,et) + do i=1,3 + al(i)=pl(i,nope)-pproj(i) + enddo +! +! determining the jacobian vector on the surface +! + if(nterms.eq.8) then + call shape8q(xi,et,pl,xsj2,xs2,shp2,iflag) + elseif(nterms.eq.4) then + call shape4q(xi,et,pl,xsj2,xs2,shp2,iflag) + elseif(nterms.eq.6) then + call shape6tri(xi,et,pl,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,pl,xsj2,xs2,shp2,iflag) + endif +! +! normal on the surface +! + areamaster=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+xsj2(3)*xsj2(3)) + do i=1,3 + xn(i)=xsj2(i)/areamaster + enddo +! +! distance from surface along normal +! + val=al(1)*xn(1)+al(2)*xn(2)+al(3)*xn(3) +! +! representative area: usually the slave surface stored in +! springarea; however, if no area was assigned because the +! node does not belong to any element, the master surface +! is used +! + if(springarea.le.0.d0) then + if(nterms.eq.3) then + springarea=areamaster/2.d0 + else + springarea=areamaster*4.d0 + endif + endif +! + if(elcon(1,1,imat).gt.0.d0) then +! +! exponential overclosure +! + if(dabs(elcon(2,1,imat)).lt.1.d-30) then + elas(1)=0.d0 + beta=1.d0 + else + alpha=elcon(2,1,imat)*springarea + beta=elcon(1,1,imat) + if(-beta*val.gt.23.d0-dlog(alpha)) then + beta=(dlog(alpha)-23.d0)/val + endif + elas(1)=dexp(-beta*val+dlog(alpha)) + endif + else +! +! linear overclosure +! + pi=4.d0*datan(1.d0) + eps=-elcon(1,1,imat)*pi/elcon(2,1,imat) + elas(1)=-springarea*elcon(2,1,imat)*val* + & (0.5d0+datan(-val/eps)/pi) +c & -elcon(1,1,imat)*springarea + endif +! +! forces in the nodes of the contact element +! +c do i=1,3 +c do j=1,nterms +c fnl(i,j)=0. +c enddo +c fnl(i,nope)=0. +c enddo +c if(iener.eq.1) then +c senergy=elas(1)/beta; +c endif +! +! contact damping +! + if(ncmat_.ge.5) then + damp=elcon(3,1,imat) + if(damp.gt.0.d0) then +! +! calculate the relative velocity +! + do i=1,3 + ver(i)=0.d0 + do j=1,nterms + ver(i)=ver(i)+ratio(j)*veoldl(i,j) + enddo + ver(i)=veoldl(i,nope)-ver(i) + enddo + dvernor=ver(1)*xn(1)+ver(2)*xn(2)+ver(3)*xn(3) +! + c0=elcon(4,1,imat) + eta=elcon(5,1,imat) +! + if(val.gt.c0) then + dampforc=0.d0 + elseif(val.gt.eta*c0) then + dampforc=dvernor*(c0-val)/(c0*(1.d0-eta))*damp*springarea + else + dampforc=dvernor*damp*springarea + endif +! + do i=1,3 + do j=1,nterms + fnd(i,j)=ratio(j)*dampforc*xn(i) + enddo + fnd(i,nope)=-dampforc*xn(i) + enddo + endif + endif +! +! friction +! + if(ncmat_.ge.7) then + um=elcon(6,1,imat) + if(um.gt.0.d0) then + if(damp.le.0.d0) then +! +! calculate the relative velocity +! + do i=1,3 + ver(i)=0.d0 + do j=1,nterms + ver(i)=ver(i)+ratio(j)*veoldl(i,j) + enddo + ver(i)=veoldl(i,nope)-ver(i) + enddo + dvernor=ver(1)*xn(1)+ver(2)*xn(2)+ver(3)*xn(3) + endif +! + pi=4.d0*datan(1.d0) +! +! calculate the tangential relative velocity +! + do i=1,3 + vertan(i)=ver(i)-dvernor*xn(i) + enddo + dvertan=dsqrt(vertan(1)**2+vertan(2)**2+vertan(3)**2) +c write(*,*) 'dvertan ',dvertan +! +! normalizing the tangent vector +! + if(dvertan.gt.0.d0)then + do i=1,3 + vertan(i)=vertan(i)/dvertan + enddo + endif +! +! friction constants +! + eps=elcon(7,1,imat) +! +! normal force +! + fn=elas(1) +! +! modify the friction force in case of contact damping +! + if(damp.gt.0.d0) fn=fn+dampforc +! + fricforc=2.d0*um*datan(dvertan/eps)*fn/pi +! + do i=1,3 + do j=1,nterms +c fnv(i,j)=ratio(j)*fricforc*vertan(i) + fnv(i,j)=-ratio(j)*fricforc*vertan(i) + enddo +c fnv(i,nope)=-fricforc*vertan(i) + fnv(i,nope)=fricforc*vertan(i) + enddo + endif + endif +! +! summing all forces +! + if(ncmat_.ge.5) then + if(damp.gt.0.d0) then + do j=1,nope + do i=1,3 + fnl(i,j)=fnd(i,j) + enddo + enddo + endif + endif + if(ncmat_.ge.7) then + if((um.gt.0.d0).and.(val.lt.0.d0)) then + if(damp.gt.0.d0) then + do j=1,nope + do i=1,3 + fnl(i,j)=fnd(i,j)+fnv(i,j) + enddo + enddo + else + do j=1,nope + do i=1,3 + fnl(i,j)=fnv(i,j) + enddo + enddo +c write(*,*) 'fnl(2,nope) ',fnl(2,nope) + endif + else + do j=1,nope + do i=1,3 + fnl(i,j)=0.d0 + enddo + enddo + endif + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/fsub.f calculix-ccx-2.3/ccx_2.3/src/fsub.f --- calculix-ccx-2.1/ccx_2.3/src/fsub.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/fsub.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,47 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine fsub(time,t,a,b,dd,h1,h2,h3,h4,func,funcp) +! + implicit none +! + real*8 time,t,a,b,dd,h1,h2,h3,h4,fexp,fsin,fcos,func,funcp, + & h8,h9,h10,h11,h12,h13 +! + fexp=dexp(-h1*t) + fsin=dsin(dd*t) + fcos=dcos(dd*t) + h8=(a+b*time)*fexp/h2 + h9=-b*fexp/h2 + h10=-h8*h1 + h11=h8*dd + h12=h9*(-h1*t-h3/h2) + h13=h9*(dd*t+h4) +! +! function +! +c fsub=(a+b*time)*fexp*(-h1*fsin-dd*fcos)/h2-b*fexp/h2*((-h1*t-h3/h2)* +c & fsin-(dd*t+h4)*fcos) + func=h10*fsin-h11*fcos+h12*fsin-h13*fcos +! +! derivative of the function +! + funcp=-h1*func+dd*(h10*fcos+h11*fsin+h12*fcos+h13*fsin) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/fsuper.f calculix-ccx-2.3/ccx_2.3/src/fsuper.f --- calculix-ccx-2.1/ccx_2.3/src/fsuper.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/fsuper.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,39 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine fsuper(time,t,a,b,h1,h2,h3,h4,h5,h6,func,funcp) +! + implicit none +! + real*8 time,t,a,b,h1,h2,h3,h4,h5,h6,fexm,fexp,func,funcp +! + fexm=dexp(h1*t) + fexp=dexp(-h2*t) +! +! function +! + func=(a+b*time)*(fexm*h3+fexp*h4) + & -b*(fexm*(t*h3-h5)+fexp*(t*h4+h6)) +! +! derivative of the function +! + funcp=(a+b*time)*(fexm-fexp)-b*(fexm*(t-h3)-fexp*(t+h4)) + +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/gapconductances.f calculix-ccx-2.3/ccx_2.3/src/gapconductances.f --- calculix-ccx-2.1/ccx_2.3/src/gapconductances.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gapconductances.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,132 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gapconductances(inpc,textpart,nelcon,nmat,ntmat_, + & npmat_,plicon,nplicon,iperturb,irstrt,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *GAP CONDUCTANCE +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat_,ntmat,npmat_,npmat,istep, + & n,key,i,nplicon(0:ntmat_,*), + & iperturb(*),istat, + & irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),ipoinpc(0:*) +! + real*8 plicon(0:2*npmat_,ntmat_,*), + & temperature +! + ntmat=0 + npmat=0 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in gapconductances: *GAP CONDUCTANCE should' + write(*,*) ' be placed before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in gapconductances: *GAP CONDUCTANCE should' + write(*,*) ' be preceded by a *SURFACE INTERACTION card' + stop + endif +! + if(nelcon(1,nmat).eq.0) then + write(*,*) '*ERROR in gapconductances: *GAP CONDUCTANCE should' + write(*,*) ' be preceeded by a *SURFACE BEHAVIOR card' + stop + endif +! + iperturb(1)=2 + iperturb(2)=1 +! + nelcon(1,nmat)=-51 +! + do i=2,n + if(textpart(i)(11:14).eq.'USER') then + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + return + else + write(*,*) + & '*WARNING in gapconductances: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + read(textpart(3)(1:20),'(f20.0)',iostat=istat) temperature + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! +! first temperature +! + if(ntmat.eq.0) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in gapconductances:' + write(*,*) ' increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature +! +! new temperature +! + elseif(plicon(0,ntmat,nmat).ne.temperature) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in gapconductances:' + write(*,*) ' increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature + endif + do i=1,2 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & plicon(2*npmat+i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + npmat=npmat+1 + if(npmat.gt.npmat_) then + write(*,*) '*ERROR in gapconductances: increase npmat_' + stop + endif + nplicon(ntmat,nmat)=npmat + enddo +! + if(ntmat.eq.0) then + write(*,*) '*ERROR in gapconductances: *GAP CONDUCTANCE card' + write(*,*) ' without data' + stop + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gapcon.f calculix-ccx-2.3/ccx_2.3/src/gapcon.f --- calculix-ccx-2.1/ccx_2.3/src/gapcon.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gapcon.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,63 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gapcon(ak,d,flowm,temp,predef,time,ciname,slname, + & msname,coords,noel,node,npred,kstep,kinc) +! +! user subroutine gapcon +! +! +! INPUT: +! +! d(1) separation between the surfaces +! d(2) pressure transmitted across the surfaces +! flowm not used +! temp(1) temperature at the slave node +! temp(2) temperature at the corresponding master +! position +! predef not used +! time(1) step time at the end of the increment +! time(2) total time at the end of the increment +! ciname surface interaction name +! slname not used +! msname not used +! coords(1..3) coordinates of the slave node +! noel element number of the contact spring element +! node slave node number +! npred not used +! kstep step number +! kinc increment number +! +! OUTPUT: +! +! ak(1) gap conductance +! ak(2..5) not used +! + implicit none +! + character*80 ciname,slname,msname +! + integer noel,node,npred,kstep,kinc +! + real*8 ak(5),d(2),flowm(2),temp(2),predef(2,*),time(*),coords(3) +! +! insert code here +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gaps.f calculix-ccx-2.3/ccx_2.3/src/gaps.f --- calculix-ccx-2.1/ccx_2.3/src/gaps.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gaps.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,338 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gaps(inpc,textpart,set,istartset,iendset, + & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon,ipkon,kon,nk,nk_, + & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_,iperturb,ne_, + & co,xboun,ctrl,typeboun,istep,istat,n,iline,ipol,inl,ipoinp, + & inp,iamboun,nam,inotr,trab,ntrans,nmethod,ipoinpc,mi) +! +! reading the input deck: *GAP +! +! a gap between nodes a and b is formulated by a nonlinear MPC +! linking node a and b. To simulate the gap feature an extra node +! c is introduced. The first DOF of this node is fixed to zero by +! a boundary SPC, the second DOF is left free. If the gap is closed +! the first DOF of node c is used in the MPC leading to a linear, +! tied MPC. If the gap is open, the second DOF of node c is used, +! leading to no constraint at all. +! + implicit none +! + logical fixed,calcnormal +! + character*1 typeboun(*),type,inpc(*) + character*8 lakon(*) + character*20 labmpc(*),label + character*81 set(*),elset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),ipompc(*),nodempc(3,*), + & nset,nset_,nalset,nalset_,nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), + & ilmpc(*),ipkon(*),kon(*),i,node,ipos,istep,istat,n,ne_, + & j,k,nodeboun(*),ndirboun(*),ikboun(*),ilboun(*),iamboun(*), + & nboun,nboun_,key,iperturb(2),inode,iline,ipol,inl,ipoinpc(0:*), + & ipoinp(2,*),inp(3,*),l,index1,ibounstart,ibounend,iamplitude, + & nam,inotr(2,*),ntrans,nmethod,idummy,mi(2),node1,node2 +! + real*8 coefmpc(3,*),co(3,*),xboun(*),ctrl(*),xn(3),clearance, + & bounval,trab(7,*),vdummy(0:4),dd +! + fixed=.false. + type='B' + iamplitude=0 +! + if(istep.gt.0) then + write(*,*) + & '*ERROR in gaps: *GAP should be placed' + write(*,*) ' before all step definitions' + stop + endif +! +! reading the element set +! + elset=' + & ' + ipos=0 +! + do i=2,n + if(textpart(i)(1:6).eq.'ELSET=') then + elset=textpart(i)(7:86) + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + else + write(*,*) + & '*WARNING in gaps: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! checking whether the element set exists +! + if(ipos.eq.0) then + write(*,*) '*ERROR in gaps: no element set ',elset + write(*,*) ' was been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + do i=1,nset + if(set(i).eq.elset) exit + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR in gaps: element set ',elset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! +! the *GAP option implies a nonlinear geometric +! calculation +! + iperturb(2)=1 + if(iperturb(1).eq.0) then + iperturb(1)=2 + elseif(iperturb(1).eq.1) then + write(*,*) '*ERROR in rigidbodies: the *MPC option' + write(*,*) ' cannot be used in a perturbation step' + stop + endif +! + label='GAP ' +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + read(textpart(1)(1:20),'(f20.0)',iostat=istat) clearance + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) xn(1) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) xn(2) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(4)(1:20),'(f20.0)',iostat=istat) xn(3) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! +! check whether size of gap normal is zero; if so, the +! gap normal is calculated from the coordinates +! + calcnormal=.false. + dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) + if(dabs(dd).eq.0.d0) calcnormal=.true. +! +! generating the gap MPC's +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + if(lakon(ialset(j))(1:1).ne.'G') then + write(*,*) '*ERROR gaps: *GAP can only be used for' + write(*,*) ' GAPUNI elements' + write(*,*) ' Faulty element: ',ialset(j) + stop + endif + index1=ipkon(ialset(j)) +! +! three terms for node 1 +! + node1=kon(index1+1) + inode=0 + do l=1,3 + inode=inode+1 + call usermpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,inode,node1,co,label, + & typeboun,iperturb) + enddo +! +! three terms for node 2 +! + node2=kon(index1+2) + do l=1,3 + inode=inode+1 + call usermpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,inode,node2,co,label, + & typeboun,iperturb) + enddo +! +! extra node for the gap DOF +! + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in gaps: increase nk_' + stop + endif + node=nk + call usermpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,inode,node,co,label,typeboun, + & iperturb) +! +! calculating the gap normal +! + if(calcnormal) then + do l=1,3 + xn(l)=co(l,node2)-co(l,node1) + enddo + dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) + if(dabs(dd).eq.0.d0) then + write(*,*) '*ERROR in gaps: gap normal cannot ' + write(*,*) ' determined' + stop + endif + do l=1,3 + xn(l)=xn(l)/dd + enddo + endif +! + do l=1,3 + co(l,nk)=xn(l) + enddo +! +! restraining the first DOF of the extra node +! + ibounstart=1 + ibounend=1 + bounval=0.d0 + call bounadd(node,ibounstart,ibounend,bounval, + & nodeboun,ndirboun,xboun,nboun,nboun_, + & iamboun,iamplitude,nam,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, + & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vdummy, + & idummy,mi) +! +! nonhomogeneous term for user MPC +! + node=0 + call usermpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,inode,node,co,label,typeboun, + & iperturb) + co(1,nk)=clearance + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + if(lakon(k)(1:1).ne.'G') then + write(*,*) '*ERROR in gaps: *GAP can only be used' + write(*,*) ' for GAPUNI elements' + write(*,*) ' Faulty element: ',k + stop + endif + index1=ipkon(k) +! +! three terms for node 1 +! + node1=kon(index1+1) + inode=0 + do l=1,3 + inode=inode+1 + call usermpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,inode,node1,co,label, + & typeboun,iperturb) + enddo +! +! three terms for node 2 +! + node2=kon(index1+2) + do l=1,3 + inode=inode+1 + call usermpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,inode,node2,co,label, + & typeboun,iperturb) + enddo +! +! extra node for the gap DOF +! + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in gaps: increase nk_' + stop + endif + node=nk + call usermpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,inode,node,co,label,typeboun, + & iperturb) +! +! calculating the gap normal +! + if(calcnormal) then + do l=1,3 + xn(l)=co(l,node2)-co(l,node1) + enddo + dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) + if(dabs(dd).eq.0.d0) then + write(*,*) '*ERROR in gaps: gap normal cannot ' + write(*,*) ' determined' + stop + endif + do l=1,3 + xn(l)=xn(l)/dd + enddo + endif +! + do l=1,3 + co(l,nk)=xn(l) + enddo +! +! restraining the first DOF of the extra node +! + ibounstart=1 + ibounend=1 + bounval=0.d0 + call bounadd(node,ibounstart,ibounend,bounval, + & nodeboun,ndirboun,xboun,nboun,nboun_, + & iamboun,iamplitude,nam,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,inotr,trab, + & ntrans,ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vdummy,idummy, + & mi) +! +! nonhomogeneous term for user MPC +! + node=0 + call usermpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,inode,node,co,label,typeboun, + & iperturb) + co(1,nk)=clearance + enddo + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/gasmechbc.f calculix-ccx-2.3/ccx_2.3/src/gasmechbc.f --- calculix-ccx-2.1/ccx_2.3/src/gasmechbc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gasmechbc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,51 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gasmechbc(vold,nload,sideload, + & nelemload,xload,mi) +! + implicit none +! + character*20 sideload(*) +! + integer i,nload,node,nelemload(2,*),mi(2) +! + real*8 vold(0:mi(2),*),xload(2,*) +! +! updating the boudary conditions in a mechanical +! calculation coming from a previous thermal calculation +! +! updating the pressure boundary conditions +! + do i=1,nload + if(sideload(i)(3:4).eq.'NP') then + node=nelemload(2,i) + xload(1,i)=vold(2,node) + endif + enddo +! + return + end + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gaspipe.f calculix-ccx-2.3/ccx_2.3/src/gaspipe.f --- calculix-ccx-2.1/ccx_2.3/src/gaspipe.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gaspipe.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,540 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gaspipe(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,r,physcon,dvi,numf,set,shcon, + & nshcon,rhcon,nrhcon,ntmat_,mi) +! +! pipe with friction losses +! + implicit none +! + logical identity,crit + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(5),idirf(5),index,iflag, + & inv,ipkon(*),kon(*),icase,kgas,k_oil,nshcon(*), + & nrhcon(*),ntmat_,mi(2) +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,R,a,d,l, + & p1,p2,T1,T2,Tt1,Tt2,pt1,pt2,cp,physcon(*),p2p1,km1,dvi, + & kp1,kdkm1,reynolds,pi,e,lambda,lld,kdkp1,T2dTt2, + & T1dTt1,X_t1dTt1,X_t2dTt2,X2_den,X1_den, + & X1,X2,B1,B2,C1,C2,t_moy,tdkp1,ln,m2r2d2a2, + & pt2zpt1,ks,form_fact,Tt1dT1,Tt2dT2,M1,M2, + & Pt2zPt1_c,qred_crit,l_neg,Qred,Ts1,qred_max1,phi,xflow_oil, + & shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*) +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + + elseif (iflag.eq.1)then +! + crit=.false. +! + index=ielprop(nelem) + kappa=(cp/(cp-R)) + A=prop(index+1) + d=prop(index+2) + l=prop(index+3) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+4) + if(lakon(nelem)(2:6).eq.'GAPIA') then + icase=0 + elseif(lakon(nelem)(2:6).eq.'GAPII') then + icase=1 + endif + form_fact=prop(index+5) + xflow_oil=prop(index+6) + k_oil=int(prop(index+7)) +! + p1=v(2,node1) + p2=v(2,node2) +! + if(p1.ge.p2) then + inv=1 + T1=v(0,node1)+physcon(1) + T2=v(0,node2)+physcon(1) + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + T1=v(0,node2)+physcon(1) + T2=v(0,node1)+physcon(1) + endif +! + p2p1=p2/p1 + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + tdkp1=2.d0/kp1 + C2=tdkp1**kdkm1 +! + if(p2p1.gt.C2) then + xflow=inv*p1*a*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa) + & *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(T1) + else + xflow=inv*p1*a*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ + & dsqrt(T1) + endif +! +! calculation of the dynamic viscosity +! + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif +! + reynolds=dabs(xflow)*d/(dvi*a) +! + if(reynolds.lt.100) then + reynolds = 100 + endif +! + call friction_coefficient(l_neg,d,ks,reynolds,form_fact,lambda) +! + call pt2zpt1_crit(p2,p1,T1,T2,lambda,kappa,r,l,d,A,iflag, + & inv,Pt2zPt1_c,Qred_crit,crit,qred_max1,icase) +! +! next location is "misused" to store the critical value +! used in resultgas.f +! + v(2,nodem)=Pt2zPt1_c +! + Qred=dabs(xflow)*dsqrt(T1)/(A*P1) + if (crit) then + xflow=0.5*inv*Qred_crit*P1*A/dsqrt(T1) +! + if(lakon(nelem)(2:6).eq.'GAPII') then + call ts_calc(xflow,T1,P1,kappa,r,a,Ts1,icase) + if (inv.eq.1) then + v(3,node1)=Ts1 + v(3,node2)=Ts1 + v(0,node2)=Ts1*(1.d0+km1/(2*kappa)) + else + v(3,node2)=Ts1 + v(3,node1)=Ts1 + v(0,node1)=Ts1*(1.d0+km1/(2*kappa)) + endif + endif + elseif(Qred.gt.Qred_crit) then + xflow=0.5*inv*Qred_crit*P1*A/dsqrt(T1) + else + xflow=inv*Qred*P1*A/dsqrt(T1) + endif +! + elseif (iflag.eq.2)then +! + numf=5 + crit=.false. +! + pi=4.d0*datan(1.d0) + e=2.7182818d0 +! + kappa=(cp/(cp-R)) + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + kdkp1=kappa/kp1 +! + index=ielprop(nelem) + A=prop(index+1) + d=prop(index+2) + l=prop(index+3) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+4) + if(lakon(nelem)(2:6).eq.'GAPIA') then + icase=0 + elseif(lakon(nelem)(2:6).eq.'GAPII') then + icase=1 + endif + form_fact=prop(index+5) + xflow_oil=prop(index+6) + k_oil=int(prop(index+7)) +! + pt1=v(2,node1) + pt2=v(2,node2) + xflow=v(1,nodem) +! + if(xflow.ge.0d0) then + inv=1 + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) +! + call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 + nodef(5)=node2 + else + inv=-1 + pt1=v(2,node2) + pt2=v(2,node1) + xflow=-v(1,nodem) + Tt1=v(0,node2)+physcon(1) + Tt2=v(0,node1)+physcon(1) + call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) +! + call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) +! + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + nodef(5)=node1 + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 + idirf(5)=0 +! + pt2zpt1=pt2/pt1 +! +! calculation of the dynamic viscosity +! + if(xflow_oil.ne.0d0) then +! + if((k_oil.lt.0).or.(k_oil.gt.12)) then + write(*,*) '*ERROR:in gaspipe.f' + write(*,*) ' using two phase flow' + write(*,*) ' the type of oil is not defined' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Current calculation stops here' + stop + else + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) + lambda=lambda*phi + endif +! +! for pure air +! + else + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif +! + reynolds=dabs(xflow)*d/(dvi*a) +! + phi=1.d0 + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + endif +! + call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, + & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) +! + if(dabs(xflow)*dsqrt(Tt1)/(A*Pt1).gt.qred_max1) then + crit=.true. + endif +! +! definition of the coefficients +! + lld=lambda*l/d +! + if(.not.crit) then +! + T_moy=0.5d0*(T1+T2) + T2dTt2=T2/Tt2 + Tt2dT2=1.d0/T2dTt2 + X_T2dTt2=T2dTt2**(2*kdkm1) + T1dTt1=T1/Tt1 + Tt1dT1=1.d0/T1dTt1 + X_T1dTt1=T1dTt1**(2*kdkm1) +! + X2_den=pt2**2*X_T2dTt2 + X2=t2**2/X2_den + X1_den=pt1**2*X_T1dTt1 + X1=T1**2/X1_den +! + ln=log(Pt2zPt1*(T2dTt2/T1dTt1)**kdkm1) +! + m2r2d2a2=xflow**2*R**2/(2*A**2) +! + C1=2.d0*cp*A**2*X1_den*(1.d0-2.d0*kdkm1*(Tt1dT1-1.d0)) + & +2.d0*xflow**2*R**2*T1 +! + C2=2.d0*cp*A**2*X2_den*(1.d0-2.d0*kdkm1*(Tt2dT2-1.d0)) + & +2.d0*xflow**2*R**2*T2 +! + B1=-2.d0*m2r2d2a2*(1.d0-kdkm1)*T1/X1_den*(1.d0-0.5d0*lld) + & +0.5d0*R*(ln-kdkm1*(T2+T1)/T1) +! + B2=2.d0*m2r2d2a2*(1.d0-kdkm1)*T2/X2_den*(1.d0+0.5d0*lld) + & +0.5d0*R*(ln+kdkm1*(T2+T1)/T2) +! +! residual +! + f=(m2r2d2a2*(X2*(1.d0+0.5d0*lld)-X1*(1.d0-0.5d0*lld)) + & +R*T_moy*ln + & +b2/c2*(2*cp*A**2*(Tt2-T2)*X2_den-xflow**2*R**2*T2**2) + & +b1/c1*(2*cp*A**2*(Tt1-T1)*X1_den-xflow**2*R**2*T1**2)) +! +! pressure node1 +! + df(1)=(2.d0*m2r2d2a2*X1/pt1*(1.d0-0.5d0*lld) + & -R*T_moy/pt1 + & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1)) +! +! temperature node1 +! + df(2)=(-2.d0*m2r2d2a2*(kdkm1/Tt1*X1)*(1.d0-0.5d0*lld) + & +r*kdkm1*T_moy/Tt1 + & +b1/c1*(2*cp*A*A*X1_den*(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1))) +! +! mass flow +! + df(3)=(inv*xflow*R**2/a**2 + & *(X2*(1.d0+0.5d0*lld)-X1*(1.d0-0.5d0*lld)) + & +B2/C2*(-2.d0*inv*xflow*R*R*T2**2.d0) + & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0)) +! +! pressure node2 +! + df(4)=(-2*m2r2d2a2*X2/pt2*(1.d0+0.5d0*lld) + & +R*T_moy/pt2 + & +B2/C2*(4.d0*cp*A*A*(Tt2-T2)*pt2*X_T2dTt2)) +! +! temperature node2 +! + df(5)=(2.d0*m2r2d2a2*(kdkm1/Tt2*X2)*(1.d0+0.5d0*lld) + & -r*kdkm1*T_moy/Tt2 + & +b2/c2*(2*cp*A*A*X2_den*(1.d0-2.d0*kdkm1*(Tt2-T2)/Tt2))) +! + else +! + pt1=pt2/pt2zpt1_c + f=xflow*dsqrt(Tt1)/pt1-A*qred_crit +! +! pressure node1 +! + df(1)=-xflow*dsqrt(Tt1)/pt1**2 +! +! temperature node1 +! + df(2)=0.5d0*xflow/(pt1*dsqrt(Tt1)) +! +! mass flow +! + df(3)=inv*dsqrt(Tt1)/pt1 +! +! pressure node2 +! + df(4)=0.d0 +! +! temperature node2 +! + df(5)=0.d0 +! + endif +! + elseif(iflag.eq.3) then + + pi=4.d0*datan(1.d0) + e=2.7182818d0 +! + kappa=(cp/(cp-R)) + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + kdkp1=kappa/kp1 +! + index=ielprop(nelem) + A=prop(index+1) +! + d=prop(index+2) +! + l=prop(index+3) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+4) + if(lakon(nelem)(2:6).eq.'GAPIA') then + icase=0 + elseif(lakon(nelem)(2:6).eq.'GAPII') then + icase=1 + endif + form_fact=prop(index+5) + xflow_oil=prop(index+6) + k_oil=int(prop(index+7)) +! + pt1=v(2,node1) + pt2=v(2,node2) +! + if(xflow.ge.0d0) then + inv=1 + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) +! + call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) +! + else + inv=-1 + pt1=v(2,node2) + pt2=v(2,node1) + xflow=-v(1,nodem) + Tt1=v(0,node2)+physcon(1) + Tt2=v(0,node1)+physcon(1) +! + call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) + call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) +! + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + nodef(5)=node1 + endif +! + pt2zpt1=pt2/pt1 +! +! calculation of the dynamic viscosity +! + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif + reynolds=dabs(xflow)*d/(dvi*a) + if(reynolds.lt.100.d0) then + reynolds= 100.d0 + endif +! +! definition of the friction coefficient for 2 phase flows and pure air +! +! Lockhart-Martinelli method +! + if(lakon(nelem)(7:7).eq.'F') then +! + if((k_oil.lt.0).or.(k_oil.gt.12)) then + write(*,*) '*ERROR:in gaspipe.f' + write(*,*) ' using two phase flow' + write(*,*) ' the type of oil is not defined' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Current calculation stops here' + stop + elseif(xflow_oil.eq.0) then + write(*,*) '*WARNING:in gaspipe.f' + write(*,*) ' using two phase flow' + write(*,*) ' the oil mass flow rate is NULL' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Only pure air is considered' + phi=1 + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + else + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) + lambda=lambda*phi + endif +! +! for pure air +! + else + phi=1.d0 + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + endif +! + call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, + & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) +! +! definition of the coefficients +! + M1=dsqrt(2/km1*((Tt1/T1)-1)) + M2=dsqrt(2/km1*((Tt2/T2)-1)) + + write(1,*) '' + write(1,55) 'In line',int(nodem/100),' from node',node1, + &' to node', node2,': air massflow rate= ',xflow,'kg/s', + &', oil massflow rate= ',xflow_oil,'kg/s' + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) +! + if(inv.eq.1) then + write(1,53)' Inlet node ',node1,': Tt1= ',Tt1, + & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, + & 'Bar, M1= ',M1 + write(1,*)' element W ',set(nelem+numf)(1:20) + write(1,57)' eta=',dvi,'kg/(m*s), Re= ' + & ,reynolds,', Phi= ',phi,', lambda= ',lambda, + & ', lambda*l/d= ',lambda*l/d,', zeta= ',phi*lambda*l/d + write(1,53)' Outlet node ',node2,' Tt2= ',Tt2, + & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1e5, + & 'Bar, M2= ',M2 +! + else if(inv.eq.-1) then + write(1,53)' Inlet node ',node2,': Tt1= ',Tt1, + & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, + & 'Bar, M1= ',M1 + write(1,*)' element W ',set(nelem+numf)(1:20) + write(1,57)' eta= ',dvi,'kg/(m*s), Re= ' + & ,reynolds,' ,Phi= ',phi,', lambda= ',lambda, + & ', lambda*l/d= ',lambda*l/d,', zeta= ',phi*lambda*l/d + write(1,53)' Outlet node ',node1,' Tt2= ',Tt2, + & 'K, Ts2= ',T2,'K, Pt2=',Pt2/1e5, + & 'Bar, M2= ',M2 + endif + endif + + 53 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A,f8.5) + 57 FORMAT(1X,A,G9.4,A,G11.4,A,f8.5,A,f8.5,A,f8.5,A,f8.5) +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gaspipe_fanno.f calculix-ccx-2.3/ccx_2.3/src/gaspipe_fanno.f --- calculix-ccx-2.1/ccx_2.3/src/gaspipe_fanno.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gaspipe_fanno.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,937 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gaspipe_fanno(node1,node2,nodem,nelem,lakon,kon, + & ipkon,nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,r,physcon,dvi,numf,set, + & shcon,nshcon,rhcon,nrhcon,ntmat_,co,vold,mi) +! +! pipe with friction losses (Fanno Formulas) GAPF +! + implicit none +! + logical identity,crit + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(5),idirf(5),index,iflag, + & inv,ipkon(*),kon(*),icase,kgas,k_oil + & ,nshcon(*),nrhcon(*),ntmat_,i,mi(2),nodea,nodeb, + & nodec,iaxial +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,R,a,d,l, + & p1,p2,T1,T2,Tt1,Tt2,pt1,pt2,cp,physcon(3),p2p1,km1,dvi, + & kp1,kdkm1,reynolds,pi,e,lambda,lld,kdkp1,T2dTt2, + & T1dTt1,X_t1dTt1,X_t2dTt2,X2_den,X1_den, + & X1,X2,B1,B2,C1,C2,tdkp1, + & pt2zpt1,ks,form_fact,xflow_oil,Tt1dT1,Tt2dT2, + & Pt2zPt1_c,qred_crit,l_neg,Qred, + & expon1,expon2,cte,term1,term2,term3,term4,term5,term6, + & term,phi,M1,M2,qred2,qred1,qred_max1,qred_crit_out,co(3,*), + & shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),vold(0:mi(2),*), + & radius,initial_radius,l_initial +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1)then +! + crit=.false. +! + pi=4.d0*datan(1.d0) +! + index=ielprop(nelem) + kappa=(cp/(cp-R)) + A=prop(index+1) + d=prop(index+2) + l=prop(index+3) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+4) + if(lakon(nelem)(2:6).eq.'GAPFA') then + icase=0 + elseif(lakon(nelem)(2:6).eq.'GAPFI') then + icase=1 + endif + form_fact=prop(index+5) + xflow_oil=prop(index+6) + k_oil=int(prop(index+7)) +! + if((lakon(nelem)(2:6).eq.'GAPFF').and. + & (lakon(nelem)(2:7).ne.'GAPFF2')) then +! + icase=0 + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + iaxial=int(prop(index+3)) + radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2) +! + initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2) +! + if(iaxial.ne.0) then + A=pi*radius**2/iaxial + else + A=pi*radius**2 + endif + d=2*radius + l=prop(index+4) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+5) + form_fact=prop(index+6) + xflow_oil=prop(index+7) + k_oil=int(prop(index+8)) +! + elseif (lakon(nelem)(2:7).eq.'GAPFF2') then + write(*,*) nelem,lakon(nelem)(1:6) + icase=0 + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + nodec=int(prop(index+3)) + iaxial=int(prop(index+4)) + radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2) + initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2) + d=2*radius + if(iaxial.ne.0) then + A=pi*radius**2/iaxial + else + A=pi*radius**2 + endif + l_initial=dsqrt((co(2,nodec)-co(2,nodeb))**2) + l=dsqrt((co(2,nodec)+vold(2,nodec)- + & co(2,nodeb)-vold(2,nodeb))**2) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+5) + form_fact=prop(index+6) + xflow_oil=prop(index+7) + k_oil=int(prop(index+8)) + endif +! + pt1=v(2,node1) + pt2=v(2,node2) +! + if(pt1.ge.pt2) then + inv=1 + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) + else + inv=-1 + pt1=v(2,node2) + pt2=v(2,node1) + Tt1=v(0,node2)+physcon(1) + Tt2=v(0,node1)+physcon(1) + endif +! + p2p1=pt2/pt1 + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + tdkp1=2.d0/kp1 + C2=tdkp1**kdkm1 +! +! incompressible flow + xflow=inv*A*dsqrt(d/l*2*Pt1/(R*Tt1)*(pt1-pt2)) + if(p2p1.gt.C2) then + xflow=inv*pt1*a*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa) + & *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(Tt1) + else + xflow=inv*pt1*a*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ + & dsqrt(Tt1) + endif +! +! calculation of the dynamic viscosity +! + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,Tt1,dvi) + endif +! + reynolds=dabs(xflow)*d/(dvi*a) +! + call friction_coefficient(l_neg,d,ks,reynolds,form_fact,lambda) + xflow=inv*A*dsqrt(d/(lambda*l)*2*Pt1/(R*Tt1)*(pt1-pt2)) +! + call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, + & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) +! + Qred=dabs(xflow)*dsqrt(Tt1)/(A*pt1) +! + if (crit) then + xflow=0.5*inv*Qred_crit*Pt1*A/dsqrt(Tt1) + if(icase.eq.1) then +! + call ts_calc(xflow,Tt1,pt1,kappa,r,a,T1,icase) + if (inv.eq.1) then + v(3,node1)=T1 + v(3,node2)=T1 + if(nactdog(0,node2).eq.1) then + v(0,node2)=T1*(1.d0+km1/(2*kappa)) + endif + else + v(3,node2)=T1 + v(3,node1)=T1 + if(nactdog(0,node1).eq.1) then + v(0,node1)=T1*(1.d0+km1/(2*kappa)) + endif + endif + endif + elseif(Qred.gt.Qred_crit) then + xflow=0.5*inv*Qred_crit*pt1*A/dsqrt(Tt1) + else + xflow=inv*Qred*pt1*A/dsqrt(Tt1) + endif +! + elseif (iflag.eq.2)then +! + numf=5 + crit=.false. +! + pi=4.d0*datan(1.d0) + e=2.7182818d0 +! + kappa=(cp/(cp-R)) + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + kdkp1=kappa/kp1 +! + index=ielprop(nelem) + A=prop(index+1) + d=prop(index+2) +! + l=prop(index+3) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+4) + if(lakon(nelem)(2:6).eq.'GAPFA') then + icase=0 + elseif(lakon(nelem)(2:6).eq.'GAPFI') then + icase=1 + endif + form_fact=prop(index+5) + xflow_oil=prop(index+6) + k_oil=int(prop(index+7)) +! + if((lakon(nelem)(2:6).eq.'GAPFF').and. + & (lakon(nelem)(2:7).ne.'GAPFF2')) then + icase=0 + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + iaxial=int(prop(index+3)) + radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2) + initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2) + d=2*radius + if(iaxial.ne.0) then + A=pi*radius**2/iaxial + else + A=pi*radius**2 + endif + l=prop(index+4) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+5) + form_fact=prop(index+6) + xflow_oil=prop(index+7) + k_oil=int(prop(index+8)) +! + elseif (lakon(nelem)(2:7).eq.'GAPFF2') then + icase=0 + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + nodec=int(prop(index+3)) + iaxial=int(prop(index+4)) + radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2) + initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2) + d=2*radius + if(iaxial.ne.0) then + A=pi*radius**2/iaxial + else + A=pi*radius**2 + endif + l_initial=dsqrt((co(2,nodec)-co(2,nodeb))**2) + l=-dsqrt((co(2,nodec)+vold(2,nodec)- + & co(2,nodeb)-vold(2,nodeb))**2) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+5) + form_fact=prop(index+6) + xflow_oil=prop(index+7) + k_oil=int(prop(index+8)) + endif +! + pt1=v(2,node1) + pt2=v(2,node2) + xflow=v(1,nodem) +! + if((pt1.gt.pt2).or.(xflow.ge.0d0)) then + inv=1 + Tt1=v(0,node1)+physcon(1) + call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) + if(icase.eq.0) then + Tt2=Tt1 + call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) + else + t2=t1 + Tt2=v(0,node2)+physcon(1) + endif +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 + nodef(5)=node2 + else + inv=-1 + pt1=v(2,node2) + pt2=v(2,node1) + xflow=-v(1,nodem) + Tt1=v(0,node2)+physcon(1) + if(icase.eq.0) then + Tt2=Tt1 + else + Tt2=v(0,node1)+physcon(1) + endif +! + call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) +! + call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) +! + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + nodef(5)=node1 + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 + idirf(5)=0 +! + pt2zpt1=pt2/pt1 +! +! calculation of the dynamic viscosity +! + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif +! + reynolds=dabs(xflow)*d/(dvi*a) +! + if(reynolds.lt.1) then + reynolds = 1.d0 + endif +! +! definition of the friction coefficient for 2 phase flows and pure air +! +! Friedel's Method + if(lakon(nelem)(7:7).eq.'F') then +! + if((k_oil.lt.0).or.(k_oil.gt.12)) then + write(*,*) '*ERROR:in gaspipe.f' + write(*,*) ' using two phase flow' + write(*,*) ' the type of oil is not defined' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Current calculation stops here' + stop + elseif(xflow_oil.eq.0.d0) then + write(*,*) '*WARNING:in gaspipe.f' + write(*,*) ' using two phase flow' + write(*,*) ' the oil mass flow rate is NULL' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Only pure air is considered' + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + else + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) +! + lambda=lambda*phi +! + endif +! +! Alber's Method +! + elseif (lakon(nelem)(7:7).eq.'A') then + if((k_oil.lt.0).or.(k_oil.gt.12)) then + write(*,*) '*ERROR:in gaspipe_fanno.f' + write(*,*) ' using two phase flow' + write(*,*) ' the type of oil is not defined' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Current calculation stops here' + stop + elseif(xflow_oil.eq.0) then + write(*,*) '*WARNING:in gaspipe_fanno.f' + write(*,*) ' using two phase flow' + write(*,*) ' the oil mass flow rate is NULL' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Only pure air is considered' + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + else + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) +! + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) +! + lambda=lambda*phi +! + endif +! +! for pure air +! + else +! + phi=1.d0 + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + endif +! + call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, + & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) +! + Qred1=xflow*dsqrt(Tt1)/(A*Pt1) +! + if(dabs(xflow)*dsqrt(Tt1)/(A*Pt1).gt.qred_max1) then + crit=.true. + endif +! + Qred2=xflow*dsqrt(Tt2)/(A*Pt2) + if(icase.eq.0) then + qred_crit_out=dsqrt(kappa/R)*(2/(kappa+1))**(0.5d0* + & (kappa+1)/(kappa-1)) + else + qred_crit_out=R**(-0.5d0)*(2/(kappa+1))**(0.5d0* + & (kappa+1)/(kappa-1)) + endif +! +! definition of the coefficients +! + lld=lambda*l/d +! + M2=dsqrt(2/km1*((Tt2/T2)-1)) + if(icase.eq.0) then + if((M2.lt.1)) then + crit=.false. + if((M2.ge.1.d0).or.(dabs(M2-1).lt.1E-5)) then + pt2=pt1*pt2zpt1_c + endif + endif + elseif (icase.eq.1) then + if(M2.lt.1/dsqrt(kappa)) then + crit=.false. + else + crit=.true. + endif + endif +! +! adiabatic case +! + if(icase.eq.0) then +! + T2dTt2=T2/Tt2 + Tt2dT2=1.d0/T2dTt2 + X_T2dTt2=T2dTt2**(2*kdkm1) + T1dTt1=T1/Tt1 + Tt1dT1=1.d0/T1dTt1 + X_T1dTt1=T1dTt1**(2*kdkm1) +! + X2_den=pt2**2*X_T2dTt2 + X2=t2**2/X2_den + X1_den=pt1**2*X_T1dTt1 + X1=T1**2/X1_den +! +! C1=2.d0*cp*A**2*X1_den*(-1.d0+2.d0*kdkm1*T1dTt1) +! & -2.d0*xflow**2*R**2*T1 + C1=2.d0*cp*A**2*X1_den*(-1.d0+2.d0*kdkm1*(T1dTt1-1)) + & -2.d0*xflow**2*R**2*T1 +! +! C2=2.d0*cp*A**2*X2_den*(-1.d0+2.d0*kdkm1*T2dTt2) +! & -2.d0*xflow**2*R**2*T2 + C2=2.d0*cp*A**2*X2_den*(-1.d0+2.d0*kdkm1*(T2dTt2-1)) + & -2.d0*xflow**2*R**2*T2 +! + expon1=(kappa+1)/km1 + expon2=2*kappa/(km1) +! + cte=0.5d0*(kappa+1)/kappa +! + term1=pt1**2*T1**expon1*Tt1**(-expon2)*A**2 +! + if(.not.crit) then + term1=pt1**2*T1**expon1*Tt1**(-expon2)*A**2 + term2=pt2**2*T2**expon1*Tt2**(-expon2)*A**2 +! +! simplified version + term3=Tt2dT2 + term4=Tt1dT1 +! + term5=T1**(expon1)*Tt1**(-expon2)*(pt1**2) + term6=T2**(expon1)*Tt2**(-expon2)*(pt2**2) +! + B1=1/(R*xflow**2)*term1*expon1/T1 + & +cte*(-(2/km1)*1/T1) +! + B2=1/(R*xflow**2)*term2*(-expon1/T2) + & +cte*(2/km1*1/T2) +! +! residual +! +! Simplified version +! + f=1/(R*xflow**2)*(term1-term2) + & +cte*(log(term3)-log(term4)-log(term5)+log(term6)) + & -lld + & +b2/c2*(2*cp*A**2*(Tt2-T2) + & *X2_den-xflow**2*R**2*T2**2) + & +b1/c1*(2*cp*A**2*(Tt1-T1) + & *X1_den-xflow**2*R**2*T1**2) +! +! pressure node1 +! + df(1)=1/(R*xflow**2)*(term1*2/pt1) + & +cte*(-2/pt1) + & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1) +! +! temperature node1 +! + df(2)=1/(R*xflow**2)*term1*(-expon2)/Tt1 + & +cte*(expon1*1/Tt1) + & +b1/c1*(2*cp*A**2*X1_den + & *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1)) +! +! mass flow +! + df(3)=-2.d0/(R*(inv*xflow)**3)*(term1-term2) + & +B2/C2*(-2.d0*inv*xflow*R*R*T2**2.d0) + & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0) +! +! pressure node2 +! + df(4)=1/(R*xflow**2)*(-term2*2/pt2) + & +cte*(2/pt2) + & +B2/C2*(4.d0*cp*A**2*(Tt2-T2)*pt2*X_T2dTt2) +! +! temperature node2 +! + df(5)=1/(R*xflow**2)*term2*(expon2/Tt2) + & +cte*(-expon1*1/Tt2) + & +b2/c2*(2*cp*A**2*X2_den + & *(1.d0-2.d0*kdkm1*(Tt2-T2)/Tt2)) +! + else +! + term=kappa*term1/(xflow**2*R) + B1=expon1*1/T1*(1/kappa*term-1)+cte*1/T1 +! f=1/kappa*(term1-1)+cte*(log(T1dTt1)-log(2/kp1*term)) + f=1/kappa*(term-1)+cte*(log(T1dTt1)-log(2/kp1*term)) + & -lld + & +b1/c1*(2*cp*A**2*(Tt1-T1) + & *X1_den-xflow**2*R**2*T1**2) +! +! pressure node1 +! + df(1)=2/pt1*(1/kappa*term-cte) + & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1) +! +! temperature node1 +! + df(2)=expon2*1/Tt1*(-1/kappa*term+1)-cte*1/Tt1 + & +b1/c1*(2*cp*A**2*X1_den + & *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1)) +! +! mass flow +! + df(3)=2.d0/(inv*xflow)*(-term/kappa+cte) + & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0) +! +! pressure node2 +! + df(4)=0.d0 +! +! temperature node2 +! + df(5)=0.d0 +! + endif +! +! isothermal icase +! + elseif(icase.eq.1) then + T2dTt2=T2/Tt2 + Tt2dT2=1.d0/T2dTt2 + X_T2dTt2=T2dTt2**(2*kdkm1) + T1dTt1=T1/Tt1 + Tt1dT1=1.d0/T1dTt1 + X_T1dTt1=T1dTt1**(2*kdkm1) +! + X2_den=pt2**2*X_T2dTt2 + X2=t2**2/X2_den + X1_den=pt1**2*X_T1dTt1 + X1=T1**2/X1_den +! + C1=2.d0*cp*A**2*X1_den*(1.d0-2.d0*kdkm1*(Tt1dT1-1.d0)) + & +2.d0*xflow**2*R**2*T1 +! + C2=2.d0*cp*A**2*X2_den*(1.d0-2.d0*kdkm1*(Tt2dT2-1.d0)) + & +2.d0*xflow**2*R**2*T2 +! + expon1=(kappa+1)/km1 + expon2=2*kappa/(kappa-1) +! + cte=0.5d0*(kappa+1)/kappa +! + term1=pt1**2*T1**expon1*Tt1**(-expon2)*A**2 + term2=pt2**2*T2**expon1*Tt2**(-expon2)*A**2 +! + term5=T1**(expon1)*Tt1**(-expon2)*(pt1**2*A**2) + term6=T2**(expon1)*Tt2**(-expon2)*(pt2**2*A**2) +! + if(.not.crit) then + B1=1/(R*xflow**2)*term1*expon1/T1 + & -expon1/T1 +! + B2=1/(R*xflow**2)*term2*(-expon1/T2) + & +expon1/T2 +! +! Simplified version +! + f=1/(R*xflow**2)*(term1-term2) + & +(-log(term5)+log(term6)) + & -lld + & +b2/c2*(2*cp*A**2*(Tt2-T2) + & *X2_den-xflow**2*R**2*T2**2) + & +b1/c1*(2*cp*A**2*(Tt1-T1) + & *X1_den-xflow**2*R**2*T1**2) +! +! pressure node1 +! + df(1)=1/(R*xflow**2)*(term1*2/pt1) + & +(-(2/pt1)) + & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1) +! +! temperature node1 +! + df(2)=1/(R*xflow**2)*term1*(-expon2)/Tt1 + & +(expon2/Tt1) + & +b1/c1*(2*cp*A**2*X1_den + & *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1)) +! +! mass flow +! + df(3)=-2.d0/(R*xflow**3)*(term1-term2) + & +B2/C2*(-2.d0*inv*xflow*R*R*T2**2.d0) + & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0) +! +! pressure node2 +! + df(4)=1/(R*xflow**2)*(-term2*2/pt2) + & +(2/pt2) + & +B2/C2*(4.d0*cp*A**2*(Tt2-T2)*pt2*X_T2dTt2) +! +! +! temperature node2 +! + df(5)=1/(R*xflow**2)*term2*(expon2/Tt2) + & +(-expon2/Tt2) + & +b2/c2*(2*cp*A**2*X2_den + & *(1.d0-2.d0*kdkm1*(Tt2-T2)/Tt2)) + + else + term=term1/(xflow**2*R) + B1=expon1/T1*(term-1) +! alternate critical equation +! + f=term-1-log(term) + & -lld + & +b1/c1*(2*cp*A**2*(Tt1-T1) + & *X1_den-xflow**2*R**2*T1**2) +! +! pressure node1 +! + df(1)=2/pt1*(term-1) + & +B1/C1*(4.d0*cp*A**2*(Tt1-T1)*pt1*X_T1dTt1) +! +! temperature node1 +! + df(2)=expon2/Tt1*(-term+1) + & +b1/c1*(2*cp*A**2*X1_den + & *(1.d0-2.d0*kdkm1*(Tt1-T1)/Tt1)) +! +! mass flow +! + df(3)=2/xflow*(-term+1) + & +B1/C1*(-2.d0*inv*xflow*R*R*T1**2.d0) +! +! pressure node2 +! + df(4)=0.d0 +! +! temperature node2 +! + df(5)=0.d0 +! + endif + endif +! +! output +! + elseif(iflag.eq.3) then +! + pi=4.d0*datan(1.d0) + e=2.7182818d0 +! + kappa=(cp/(cp-R)) + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + kdkp1=kappa/kp1 +! + index=ielprop(nelem) + A=prop(index+1) + d=prop(index+2) + l=prop(index+3) + if(l.lt.0d0) then + l_neg=l + l=abs(l) + else + l_neg=l + endif + ks=prop(index+4) + if(lakon(nelem)(2:6).eq.'GAPFA') then + icase=0 + elseif(lakon(nelem)(2:6).eq.'GAPFI') then + icase=1 + endif + form_fact=prop(index+5) + xflow_oil=prop(index+6) + k_oil=int(prop(index+7)) +! + pt1=v(2,node1) + pt2=v(2,node2) +! + if(xflow.ge.0d0) then + inv=1 + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) + if(icase.eq.0) then + Tt2=Tt1 + call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) + else + T2=T1 + Tt2=v(0,node2)+physcon(1) + call tt_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase,iflag) + endif +! +! call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) +!! +! call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) +! + else + inv=-1 + pt1=v(2,node2) + pt2=v(2,node1) + xflow=v(1,nodem) +! + Tt1=v(0,node2)+physcon(1) + if(icase.eq.0) then + Tt2=Tt1 + else + Tt2=v(0,node1)+physcon(1) + endif +! + call ts_calc(xflow,Tt1,Pt1,kappa,r,a,T1,icase) + call ts_calc(xflow,Tt2,Pt2,kappa,r,a,T2,icase) +! + endif +! + pt2zpt1=pt2/pt1 +! +! calculation of the dynamic viscosity +! + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif +! + reynolds=dabs(xflow)*d/(dvi*a) +! + if(reynolds.lt.1.d0) then + reynolds= 1.d0 + endif +! +! definition of the friction coefficient for 2 phase flows and pure air +! +! Friedel's Method + if(lakon(nelem)(7:7).eq.'F') then +! + if((k_oil.lt.0).or.(k_oil.gt.12)) then + write(*,*) '*ERROR:in gaspipe.f' + write(*,*) ' using two phase flow' + write(*,*) ' the type of oil is not defined' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Current calculation stops here' + stop + elseif(xflow_oil.eq.0) then + write(*,*) '*WARNING:in gaspipe.f' + write(*,*) ' using two phase flow' + write(*,*) ' the oil mass flow rate is NULL' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Only pure air is considered' + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + else + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) +! + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) +! + endif +! + elseif (lakon(nelem)(7:7).eq.'A') then + if((k_oil.lt.0).or.(k_oil.gt.12)) then + write(*,*) '*ERROR:in gaspipe.f' + write(*,*) ' using two phase flow' + write(*,*) ' the type of oil is not defined' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Current calculation stops here' + stop + elseif(xflow_oil.eq.0) then + write(*,*) '*WARNING:in gaspipe.f' + write(*,*) ' using two phase flow' + write(*,*) ' the oil mass flow rate is NULL' + write(*,*) ' check element ',nelem,' definition' + write(*,*) ' Only pure air is considered' + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + else + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,lambda,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) +! + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) +! + endif +! +! for pure air +! + else + phi=1.d0 + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + endif +! + call pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A,iflag, + & inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) + +! +! definition of the coefficients +! + M1=dsqrt(2/km1*((Tt1/T1)-1)) + M2=dsqrt(2/km1*((Tt2/T2)-1)) +! + write(1,*) '' + write(1,55) 'In line',int(nodem/1000),' from node',node1, + &' to node', node2,': air massflow rate= ',xflow,'kg/s', + &', oil massflow rate= ',xflow_oil,'kg/s' + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) +! + if(inv.eq.1) then + write(1,53)' Inlet node ',node1,': Tt1= ',Tt1, + & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, + & 'Bar, M1= ',M1 + write(1,*)' element W ',set(numf)(1:20) + write(1,57)' Eta=',dvi,' kg/(m*s), Re= ' + & ,reynolds,', PHI= ',phi,', LAMBDA= ',lambda, + & ', LAMBDA*l/d= ',lambda*l/d,', ZETA_PHI= ',phi*lambda*l/d + write(1,53)' Outlet node ',node2,' Tt2= ',Tt2, + & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1e5, + & 'Bar, M2= ',M2 +! + else if(inv.eq.-1) then + write(1,53)' Inlet node ',node2,': Tt1= ',Tt1, + & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, + & 'Bar, M1= ',M1 + write(1,*)' element W ',set(numf)(1:20) + write(1,57)' Eta= ',dvi,' kg/(m*s), Re= ' + & ,reynolds,' ,Phi= ',phi,', lambda= ',lambda, + & ', lamda*l/d= ',lambda*l/d,', zeta_phi= ',phi*lambda*l/d + write(1,53)' Outlet node ',node1,' Tt2= ',Tt2, + & 'K, Ts2= ',T2,'K, Pt2=',Pt2/1e5, + & 'Bar, M2= ',M2 + endif + endif + 53 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A,f8.5) + 57 FORMAT(1X,A,G9.4,A,G11.5,A,f8.4,A,f8.5,A,f8.5,A,f8.5) +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gauss.f calculix-ccx-2.3/ccx_2.3/src/gauss.f --- calculix-ccx-2.1/ccx_2.3/src/gauss.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gauss.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,272 @@ +! +! contains Gauss point information +! +! gauss1d2: lin, 2-point integration (2 integration points) +! gauss1d3: lin, 3-point integration (3 integration points) +! gauss2d1: quad, 1-point integration (1 integration point) +! gauss2d2: quad, 2-point integration (4 integration points) +! gauss2d3: quad, 3-point integration (9 integration points) +! gauss2d4: tri, 1 integration point +! gauss2d5: tri, 3 integration points +! gauss2d6: tri, 7 integration points +! gauss3d1: hex, 1-point integration (1 integration point) +! gauss3d2: hex, 2-point integration (8 integration points) +! gauss3d3: hex, 3-point integration (27 integration points) +! gauss3d4: tet, 1 integration point +! gauss3d5: tet, 4 integration points +! gauss3d6: tet, 15 integration points +! gauss3d7: wedge, 2 integration points +! gauss3d8: wedge, 9 integration points +! gauss3d9: wedge, 18 integration points +! gauss3d10: wedge, 6 integration points +! gauss3d11: wedge, 1 integration points +! +! weight2d1,... contains the weights +! +! + real*8 gauss1d2(1,2),gauss1d3(1,3), + & gauss2d1(2,1),gauss2d2(2,4),gauss2d3(2,9),gauss2d4(2,1), + & gauss2d5(2,3),gauss3d1(3,1),gauss3d2(3,8),gauss3d3(3,27), + & gauss3d4(3,1),gauss3d5(3,4),gauss3d6(3,15),gauss3d7(3,2), + & gauss3d8(3,9),gauss3d9(3,18),gauss3d10(3,6),gauss3d11(3,1), + & weight1d2(2),weight1d3(3),weight2d1(1),weight2d2(4), + & weight2d3(9),weight2d4(1),weight2d5(3),weight3d1(1), + & weight3d2(8),weight3d3(27),weight3d4(1),weight3d5(4), + & weight3d6(15),weight3d7(2),weight3d8(9),weight3d9(18), + & weight3d10(6),weight3d11(1),gauss2d6(2,7),weight2d6(7) +! + data gauss1d2 / + & -0.577350269189626d0,0.577350269189626d0/ +! + data gauss1d3 / + & -0.774596669241483d0,0.d0,0.774596669241483d0/ +! + data gauss2d1 /0.,0./ +! +! the order of the Gauss points in gauss2d2 is important +! and should not be changed (used to accelerate the code +! for CAX8R axisymmetric elements in e_c3d_th.f) +! + data gauss2d2 / + & -0.577350269189626d0,-0.577350269189626d0, + & 0.577350269189626d0,-0.577350269189626d0, + & -0.577350269189626d0,0.577350269189626d0, + & 0.577350269189626d0,0.577350269189626d0/ +! + data gauss2d3 / + & -0.774596669241483d0,-0.774596669241483d0, + & -0.d0,-0.774596669241483d0, + & 0.774596669241483d0,-0.774596669241483d0, + & -0.774596669241483d0,0.d0, + & -0.d0,0.d0, + & 0.774596669241483d0,0.d0, + & -0.774596669241483d0,0.774596669241483d0, + & -0.d0,0.774596669241483d0, + & 0.774596669241483d0,0.774596669241483d0/ +! + data gauss2d4 /0.333333333333333d0,0.333333333333333d0/ +! + data gauss2d5 / + & 0.166666666666667d0,0.166666666666667d0, + & 0.666666666666667d0,0.166666666666667d0, + & 0.166666666666667d0,0.666666666666667d0/ +! + data gauss2d6 / + & 0.333333333333333d0,0.333333333333333d0, + & 0.797426985353087d0,0.101286507323456d0, + & 0.101286507323456d0,0.797426985353087d0, + & 0.101286507323456d0,0.101286507323456d0, + & 0.470142064105115d0,0.059715871789770d0, + & 0.059715871789770d0,0.470142064105115d0, + & 0.470142064105115d0,0.470142064105115d0/ +! +! + data gauss3d1 /0.,0.,0./ +! +! the order of the Gauss points in gauss3d2 is important +! and should not be changed (used to accelerate the code +! for CAX8R axisymmetric elements in e_c3d_th.f) +! + data gauss3d2 / + & -0.577350269189626d0,-0.577350269189626d0,-0.577350269189626d0, + & 0.577350269189626d0,-0.577350269189626d0,-0.577350269189626d0, + & -0.577350269189626d0,0.577350269189626d0,-0.577350269189626d0, + & 0.577350269189626d0,0.577350269189626d0,-0.577350269189626d0, + & -0.577350269189626d0,-0.577350269189626d0,0.577350269189626d0, + & 0.577350269189626d0,-0.577350269189626d0,0.577350269189626d0, + & -0.577350269189626d0,0.577350269189626d0,0.577350269189626d0, + & 0.577350269189626d0,0.577350269189626d0,0.577350269189626d0/ +! + data gauss3d3 / + & -0.774596669241483d0,-0.774596669241483d0,-0.774596669241483d0, + & 0.d0,-0.774596669241483d0,-0.774596669241483d0, + & 0.774596669241483d0,-0.774596669241483d0,-0.774596669241483d0, + & -0.774596669241483d0,0.d0,-0.774596669241483d0, + & 0.d0,0.d0,-0.774596669241483d0, + & 0.774596669241483d0,0.d0,-0.774596669241483d0, + & -0.774596669241483d0,0.774596669241483d0,-0.774596669241483d0, + & 0.d0,0.774596669241483d0,-0.774596669241483d0, + & 0.774596669241483d0,0.774596669241483d0,-0.774596669241483d0, + & -0.774596669241483d0,-0.774596669241483d0,0.d0, + & 0.d0,-0.774596669241483d0,0.d0, + & 0.774596669241483d0,-0.774596669241483d0,0.d0, + & -0.774596669241483d0,0.d0,0.d0, + & 0.d0,0.d0,0.d0, + & 0.774596669241483d0,0.d0,0.d0, + & -0.774596669241483d0,0.774596669241483d0,0.d0, + & 0.d0,0.774596669241483d0,0.d0, + & 0.774596669241483d0,0.774596669241483d0,0.d0, + & -0.774596669241483d0,-0.774596669241483d0,0.774596669241483d0, + & 0.d0,-0.774596669241483d0,0.774596669241483d0, + & 0.774596669241483d0,-0.774596669241483d0,0.774596669241483d0, + & -0.774596669241483d0,0.d0,0.774596669241483d0, + & 0.d0,0.d0,0.774596669241483d0, + & 0.774596669241483d0,0.d0,0.774596669241483d0, + & -0.774596669241483d0,0.774596669241483d0,0.774596669241483d0, + & 0.d0,0.774596669241483d0,0.774596669241483d0, + & 0.774596669241483d0,0.774596669241483d0,0.774596669241483d0/ +! + data gauss3d4 /0.25d0,0.25d0,0.25d0/ +! + data gauss3d5 / + & 0.138196601125011d0,0.138196601125011d0,0.138196601125011d0, + & 0.585410196624968d0,0.138196601125011d0,0.138196601125011d0, + & 0.138196601125011d0,0.585410196624968d0,0.138196601125011d0, + & 0.138196601125011d0,0.138196601125011d0,0.585410196624968d0/ +! + data gauss3d6 / + & 0.25,0.25,0.25d0, + & 0.091971078052723d0,0.091971078052723d0,0.091971078052723d0, + & 0.724086765841831d0,0.091971078052723d0,0.091971078052723d0, + & 0.091971078052723d0,0.724086765841831d0,0.091971078052723d0, + & 0.091971078052723d0,0.091971078052723d0,0.724086765841831d0, + & 0.319793627829630d0,0.319793627829630d0,0.319793627829630d0, + & 0.040619116511110d0,0.319793627829630d0,0.319793627829630d0, + & 0.319793627829630d0,0.040619116511110d0,0.319793627829630d0, + & 0.319793627829630d0,0.319793627829630d0,0.040619116511110d0, + & 0.056350832689629d0,0.056350832689629d0,0.443649167310371d0, + & 0.443649167310371d0,0.056350832689629d0,0.056350832689629d0, + & 0.443649167310371d0,0.443649167310371d0,0.056350832689629d0, + & 0.056350832689629d0,0.443649167310371d0,0.443649167310371d0, + & 0.056350832689629d0,0.443649167310371d0,0.056350832689629d0, + & 0.443649167310371d0,0.056350832689629d0,0.443649167310371d0/ +! + data gauss3d7 / + & 0.333333333333333d0,0.333333333333333d0,-0.577350269189626d0, + & 0.333333333333333d0,0.333333333333333d0,0.577350269189626d0/ +! + data gauss3d8 / + & 0.166666666666667d0,0.166666666666667d0,-0.774596669241483d0, + & 0.666666666666667d0,0.166666666666667d0,-0.774596669241483d0, + & 0.166666666666667d0,0.666666666666667d0,-0.774596669241483d0, + & 0.166666666666667d0,0.166666666666667d0,0.d0, + & 0.666666666666667d0,0.166666666666667d0,0.d0, + & 0.166666666666667d0,0.666666666666667d0,0.d0, + & 0.166666666666667d0,0.166666666666667d0,0.774596669241483d0, + & 0.666666666666667d0,0.166666666666667d0,0.774596669241483d0, + & 0.166666666666667d0,0.666666666666667d0,0.774596669241483d0/ +! + data gauss3d9 / + & 0.166666666666667d0,0.166666666666667d0,-0.774596669241483d0, + & 0.166666666666667d0,0.666666666666667d0,-0.774596669241483d0, + & 0.666666666666667d0,0.166666666666667d0,-0.774596669241483d0, + & 0.000000000000000d0,0.500000000000000d0,-0.774596669241483d0, + & 0.500000000000000d0,0.000000000000000d0,-0.774596669241483d0, + & 0.500000000000000d0,0.500000000000000d0,-0.774596669241483d0, + & 0.166666666666667d0,0.166666666666667d0,0.d0, + & 0.166666666666667d0,0.666666666666667d0,0.d0, + & 0.666666666666667d0,0.166666666666667d0,0.d0, + & 0.000000000000000d0,0.500000000000000d0,0.d0, + & 0.500000000000000d0,0.000000000000000d0,0.d0, + & 0.500000000000000d0,0.500000000000000d0,0.d0, + & 0.166666666666667d0,0.166666666666667d0,0.774596669241483d0, + & 0.166666666666667d0,0.666666666666667d0,0.774596669241483d0, + & 0.666666666666667d0,0.166666666666667d0,0.774596669241483d0, + & 0.000000000000000d0,0.500000000000000d0,0.774596669241483d0, + & 0.500000000000000d0,0.000000000000000d0,0.774596669241483d0, + & 0.500000000000000d0,0.500000000000000d0,0.774596669241483d0/ +! + data gauss3d10 / + & 0.166666666666667d0,0.166666666666667d0,-0.577350269189626d0, + & 0.666666666666667d0,0.166666666666667d0,-0.577350269189626d0, + & 0.166666666666667d0,0.666666666666667d0,-0.577350269189626d0, + & 0.166666666666667d0,0.166666666666667d0,0.577350269189626d0, + & 0.666666666666667d0,0.166666666666667d0,0.577350269189626d0, + & 0.166666666666667d0,0.666666666666667d0,0.577350269189626d0/ +! + data gauss3d11 / + & 0.333333333333333d0,0.333333333333333d0,0.d0/ +! + data weight1d2 /1.d0,1.d0/ +! + data weight1d3 /0.555555555555555d0,0.888888888888888d0, + & 0.555555555555555d0/ +! + data weight2d1 /4.d0/ +! + data weight2d2 /1.d0,1.d0,1.d0,1.d0/ +! + data weight2d3 / + & 0.308641975308642d0,0.493827160493827d0,0.308641975308642d0, + & 0.493827160493827d0,0.790123456790123d0,0.493827160493827d0, + & 0.308641975308642d0,0.493827160493827d0,0.308641975308642d0/ +! + data weight2d4 /0.5d0/ +! + data weight2d5 / + & 0.166666666666666d0,0.166666666666666d0,0.166666666666666d0/ +! + data weight2d6 / + & 0.225000d0,0.125939180544827d0,0.125939180544827d0, + & 0.125939180544827d0,0.132394152788506d0,0.132394152788506d0, + & 0.132394152788506d0/ +! + data weight3d1 /8.d0/ +! + data weight3d2 /1.d0,1.d0,1.d0,1.d0,1.d0,1.d0,1.d0,1.d0/ +! + data weight3d3 / + & 0.171467764060357d0,0.274348422496571d0,0.171467764060357d0, + & 0.274348422496571d0,0.438957475994513d0,0.274348422496571d0, + & 0.171467764060357d0,0.274348422496571d0,0.171467764060357d0, + & 0.274348422496571d0,0.438957475994513d0,0.274348422496571d0, + & 0.438957475994513d0,0.702331961591221d0,0.438957475994513d0, + & 0.274348422496571d0,0.438957475994513d0,0.274348422496571d0, + & 0.171467764060357d0,0.274348422496571d0,0.171467764060357d0, + & 0.274348422496571d0,0.438957475994513d0,0.274348422496571d0, + & 0.171467764060357d0,0.274348422496571d0,0.171467764060357d0/ +! + data weight3d4 /0.166666666666667d0/ +! + data weight3d5 / + & 0.041666666666667d0,0.041666666666667d0,0.041666666666667d0, + & 0.041666666666667d0/ +! + data weight3d6 / + & 0.019753086419753d0,0.011989513963170d0,0.011989513963170d0, + & 0.011989513963170d0,0.011989513963170d0,0.011511367871045d0, + & 0.011511367871045d0,0.011511367871045d0,0.011511367871045d0, + & 0.008818342151675d0,0.008818342151675d0,0.008818342151675d0, + & 0.008818342151675d0,0.008818342151675d0,0.008818342151675d0/ +! + data weight3d7 /0.5d0,0.5d0/ +! + data weight3d8 / + & 0.092592592592593d0,0.092592592592593d0,0.092592592592593d0, + & 0.148148148148148d0,0.148148148148148d0,0.148148148148148d0, + & 0.092592592592593d0,0.092592592592593d0,0.092592592592593d0/ +! + data weight3d9 / + & 0.083333333333333d0,0.083333333333333d0,0.083333333333333d0, + & 0.009259259259259d0,0.009259259259259d0,0.009259259259259d0, + & 0.133333333333333d0,0.133333333333333d0,0.133333333333333d0, + & 0.014814814814815d0,0.014814814814815d0,0.014814814814815d0, + & 0.083333333333333d0,0.083333333333333d0,0.083333333333333d0, + & 0.009259259259259d0,0.009259259259259d0,0.009259259259259d0/ +! + data weight3d10 / + & 0.166666666666666d0,0.166666666666666d0,0.166666666666666d0, + & 0.166666666666666d0,0.166666666666666d0,0.166666666666666d0/ +! + data weight3d11 /1.d0/ +! diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dboun.f calculix-ccx-2.3/ccx_2.3/src/gen3dboun.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dboun.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dboun.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,633 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dboun(ikboun,ilboun,nboun,nboun_,nodeboun,ndirboun, + & xboun,iamboun,typeboun,iponoel,inoel,iponoelmax,kon,ipkon, + & lakon,ne,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc,nmpc_, + & mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk,nk_,co, + & nmethod,iperturb,istep,vold,mi) +! +! connects nodes of 1-D and 2-D elements, for which SPC's were +! defined, to the nodes of their expanded counterparts +! + implicit none +! + logical fixed +! + character*1 type,typeboun(*) + character*8 lakon(*) + character*20 labmpc(*) +! + integer ikboun(*),ilboun(*),nboun,nboun_,nodeboun(*),ndirboun(*), + & iamboun(*),iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*),ne, + & iponor(2,*),knor(*),ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree, + & ikmpc(*),ilmpc(*),rig(*),ntrans,inotr(2,*),nbounold,i,node, + & index,ielem,j,indexe,indexk,idir,iamplitude,irotnode,nk,nk_, + & newnode,idof,id,mpcfreenew,k,nam,nmethod,iperturb,ndepnodes, + & idepnodes(80),l,iexpnode,indexx,irefnode,imax,isol,mpcfreeold, + & nod,impc,istep,nrhs,ipiv(3),info,m,mi(2) +! + real*8 xboun(*),xnor(*),coefmpc(*),trab(7,*),val,co(3,*), + & xnoref(3),dmax,d(3,3),e(3,3,3),alpha,q(3),w(3),xn(3), + & a1(3),a2(3),dd,c1,c2,c3,ww,c(3,3),vold(0:mi(2),*),a(3,3) +! + data d /1.,0.,0.,0.,1.,0.,0.,0.,1./ + data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., + & 0.,0.,1.,0.,0.,0.,-1.,0.,0., + & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ +! + fixed=.false. +! + nbounold=nboun + do i=1,nbounold + node=nodeboun(i) + if(node.gt.iponoelmax) then +c if(ndirboun(i).gt.3) then + if(ndirboun(i).gt.4) then + write(*,*) '*WARNING: in gen3dboun: node ',node, + & ' does not' + write(*,*) ' belong to a beam nor shell' + write(*,*) ' element and consequently has no' + write(*,*) ' rotational degrees of freedom' + endif + cycle + endif + index=iponoel(node) + if(index.eq.0) then +c if(ndirboun(i).gt.3) then + if(ndirboun(i).gt.4) then + write(*,*) '*WARNING: in gen3dboun: node ',node, + & ' does not' + write(*,*) ' belong to a beam nor shell' + write(*,*) ' element and consequently has no' + write(*,*) ' rotational degrees of freedom' + endif + cycle + endif + ielem=inoel(1,index) + j=inoel(2,index) + indexe=ipkon(ielem) + indexk=iponor(2,indexe+j) + idir=ndirboun(i) + val=xboun(i) + if(nam.gt.0) iamplitude=iamboun(i) +! + if(rig(node).ne.0) then +c if(idir.gt.3) then + if(idir.gt.4) then + if(rig(node).lt.0) then + write(*,*) '*ERROR in gen3dboun: in node ',node + write(*,*) ' a rotational DOF is constrained' + write(*,*) ' by a SPC; however, the elements' + write(*,*) ' to which this node belongs do not' + write(*,*) ' have rotational DOFs' + stop + endif +c j=idir-3 + j=idir-4 + irotnode=rig(node) + type='B' + call bounadd(irotnode,j,j,val,nodeboun, + & ndirboun,xboun,nboun,nboun_,iamboun, + & iamplitude,nam,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, + & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vold, + & irotnode,mi) + endif + else +! +! check for rotational DOFs defined in any but the first step +! +c if(idir.gt.3) then + if(idir.gt.4) then +! +! create a knot: determine the knot +! + ndepnodes=0 + if(lakon(ielem)(7:7).eq.'L') then + do k=1,3 + ndepnodes=ndepnodes+1 + idepnodes(ndepnodes)=knor(indexk+k) + enddo + elseif(lakon(ielem)(7:7).eq.'B') then + do k=1,8 + ndepnodes=ndepnodes+1 + idepnodes(ndepnodes)=knor(indexk+k) + enddo + else + write(*,*) + & '*ERROR in gen3dboun: a rotational DOF was applied' + write(*,*) + & '* to node',node,' without rotational DOFs' + stop + endif +! +! remove all MPC's in which the knot nodes are +! dependent nodes +! + do k=1,ndepnodes + nod=idepnodes(k) + do l=1,3 + idof=8*(nod-1)+l + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + impc=ilmpc(id) + call mpcrem(impc,mpcfree,nodempc,nmpc, + & ikmpc,ilmpc,labmpc,coefmpc,ipompc) + endif + endif + enddo + enddo +! +! generate a rigid body knot +! + irefnode=node + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in rigidbodies: increase nk_' + stop + endif + irotnode=nk + rig(node)=irotnode + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in rigidbodies: increase nk_' + stop + endif + iexpnode=nk + do k=1,ndepnodes + call knotmpc(ipompc,nodempc,coefmpc,irefnode, + & irotnode,iexpnode, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_, + & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, + & idepnodes(k),typeboun,co,xboun,istep) + enddo +! +! determine the location of the center of gravity of +! the section and its displacements +! + do l=1,3 + q(l)=0.d0 + w(l)=0.d0 + enddo + if(ndepnodes.eq.3) then + do k=1,ndepnodes,2 + nod=idepnodes(k) + do l=1,3 + q(l)=q(l)+co(l,nod) + w(l)=w(l)+vold(l,nod) + enddo + enddo + do l=1,3 + q(l)=q(l)/2.d0 + w(l)=w(l)/2.d0 + enddo + else + do k=1,ndepnodes + nod=idepnodes(k) + do l=1,3 + q(l)=q(l)+co(l,nod) + w(l)=w(l)+vold(l,nod) + enddo + enddo + do l=1,3 + q(l)=q(l)/ndepnodes + w(l)=w(l)/ndepnodes + enddo + endif +! +! determine the first displacements of iexpnode +! +c write(*,*) 'q ',q(1),q(2),q(3) +c write(*,*) 'w ',w(1),w(2),w(3) + alpha=0.d0 + do k=1,ndepnodes + nod=idepnodes(k) + dd=(co(1,nod)-q(1))**2 + & +(co(2,nod)-q(2))**2 + & +(co(3,nod)-q(3))**2 + if(dd.lt.1.d-20) cycle + alpha=alpha+dsqrt( + & ((co(1,nod)+vold(1,nod)-q(1)-w(1))**2 + & +(co(2,nod)+vold(2,nod)-q(2)-w(2))**2 + & +(co(3,nod)+vold(3,nod)-q(3)-w(3))**2)/dd) + enddo + alpha=alpha/ndepnodes +! +! determine the displacements of irotnodes +! + do l=1,3 + do m=1,3 + a(l,m)=0.d0 + enddo + xn(l)=0.d0 + enddo + do k=1,ndepnodes + nod=idepnodes(k) + dd=0.d0 + do l=1,3 + a1(l)=co(l,nod)-q(l) + a2(l)=vold(l,nod)-w(l) + dd=dd+a1(l)*a1(l) + enddo + dd=dsqrt(dd) + if(dd.lt.1.d-10) cycle + do l=1,3 + a1(l)=a1(l)/dd + a2(l)=a2(l)/dd + enddo + xn(1)=xn(1)+(a1(2)*a2(3)-a1(3)*a2(2)) + xn(2)=xn(2)+(a1(3)*a2(1)-a1(1)*a2(3)) + xn(3)=xn(3)+(a1(1)*a2(2)-a1(2)*a2(1)) + do l=1,3 + do m=1,3 + a(l,m)=a(l,m)+a1(l)*a1(m) + enddo + enddo + enddo +! + do l=1,3 + do m=1,3 + a(l,m)=a(l,m)/ndepnodes + enddo + xn(l)=xn(l)/ndepnodes + a(l,l)=1.d0-a(l,l) + enddo +! + m=3 + nrhs=1 +c write(*,*) 'xn before ',xn(1),xn(2),xn(3) + call dgesv(m,nrhs,a,m,ipiv,xn,m,info) + if(info.ne.0) then + write(*,*) '*ERROR in gen3dforc:' + write(*,*) ' singular system of equations' + stop + endif +c write(*,*) 'xn after ',xn(1),xn(2),xn(3) +! + dd=0.d0 + do l=1,3 + dd=dd+xn(l)*xn(l) + enddo + dd=dsqrt(dd) + do l=1,3 + xn(l)=dasin(dd/alpha)*xn(l)/dd + enddo +c write(*,*) 'xn afterafter ',xn(1),xn(2),xn(3) +! +! determine the displacements of irefnode +! + ww=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) +! + c1=dcos(ww) + if(ww.gt.1.d-10) then + c2=dsin(ww)/ww + else + c2=1.d0 + endif + if(ww.gt.1.d-5) then + c3=(1.d0-c1)/ww**2 + else + c3=0.5d0 + endif +! +! rotation matrix c +! + do k=1,3 + do l=1,3 + c(k,l)=c1*d(k,l)+ + & c2*(e(k,1,l)*xn(1)+e(k,2,l)*xn(2)+ + & e(k,3,l)*xn(3))+c3*xn(k)*xn(l) + enddo + enddo +! + do l=1,3 + w(l)=w(l)+(alpha*c(l,1)-d(l,1))*(co(1,irefnode)-q(1)) + & +(alpha*c(l,2)-d(l,2))*(co(2,irefnode)-q(2)) + & +(alpha*c(l,3)-d(l,3))*(co(3,irefnode)-q(3)) + enddo +! +! copying the displacements +! + do l=1,3 + vold(l,irefnode)=w(l) + vold(l,irotnode)=xn(l) + enddo + vold(1,iexpnode)=alpha +c write(*,*) 'w',w(1),w(2),w(3) +c write(*,*) 'xn',xn(1),xn(2),xn(3) +c write(*,*) 'alpha',alpha +! +! apply the boundary condition +! +c idir=idir-3 + idir=idir-4 + type='B' + call bounadd(irotnode,idir,idir,val,nodeboun, + & ndirboun,xboun,nboun,nboun_,iamboun, + & iamplitude,nam,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, + & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vold, + & irotnode,mi) +! +! check for shells whether the rotation about the normal +! on the shell has been eliminated +! + if(lakon(ielem)(7:7).eq.'L') then + indexx=iponor(1,indexe+j) + do j=1,3 + xnoref(j)=xnor(indexx+j) + enddo + dmax=0.d0 + imax=0 + do j=1,3 + if(dabs(xnoref(j)).gt.dmax) then + dmax=dabs(xnoref(j)) + imax=j + endif + enddo +! +! check whether a SPC suffices +! + if(dabs(1.d0-dmax).lt.1.d-3) then + val=0.d0 + if(nam.gt.0) iamplitude=0 + type='R' + call bounadd(irotnode,imax,imax,val,nodeboun, + & ndirboun,xboun,nboun,nboun_,iamboun, + & iamplitude,nam,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, + & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vold, + & irotnode,mi) + else +! +! check for an unused rotational DOF +! + isol=0 + do l=1,3 +c idof=8*(node-1)+3+imax + idof=8*(node-1)+4+imax + call nident(ikboun,idof,nboun,id) + if((id.gt.0).and.(ikboun(id).eq.idof)) then + imax=imax+1 + if(imax.gt.3) imax=imax-3 + cycle + endif + isol=1 + exit + enddo +! +! if one of the rotational dofs was not used so far, +! it can be taken as dependent side for fixing the +! rotation about the normal. If all dofs were used, +! no additional equation is needed. +! + if(isol.eq.1) then + idof=8*(irotnode-1)+imax + call nident(ikmpc,idof,nmpc,id) + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)=' ' +! + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=imax + coefmpc(mpcfree)=xnoref(imax) + mpcfree=nodempc(3,mpcfree) + imax=imax+1 + if(imax.gt.3) imax=imax-3 + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=imax + coefmpc(mpcfree)=xnoref(imax) + mpcfree=nodempc(3,mpcfree) + imax=imax+1 + if(imax.gt.3) imax=imax-3 + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=imax + coefmpc(mpcfree)=xnoref(imax) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + endif + endif + endif + cycle + endif +! +! 2d element shell element: generate MPC's +! + if(lakon(ielem)(7:7).eq.'L') then + newnode=knor(indexk+1) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=knor(indexk+3) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-2.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif +! +! fixing the temperature degrees of freedom +! + if(idir.eq.0) then + type='B' + call bounadd(knor(indexk+3),idir,idir,val,nodeboun, + & ndirboun,xboun,nboun,nboun_,iamboun, + & iamplitude,nam,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, + & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vold, + & irotnode,mi) + endif + elseif(lakon(ielem)(7:7).eq.'B') then +! +! 1d beam element: generate MPC's +! + newnode=knor(indexk+1) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + do k=2,4 + nodempc(1,mpcfree)=knor(indexk+k) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + enddo + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-4.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif +! +! fixing the temperature degrees of freedom +! + if(idir.eq.0) then + type='B' + do k=2,4 + call bounadd(knor(indexk+k),idir,idir,val,nodeboun, + & ndirboun,xboun,nboun,nboun_,iamboun, + & iamplitude,nam,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, + & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vold, + & knor(indexk+k),mi) + enddo + endif + else +! +! 2d plane stress, plane strain or axisymmetric +! element: MPC in all but z-direction +! + newnode=knor(indexk+2) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if(((id.le.0).or.(ikmpc(id).ne.idof)).and. + & (idir.ne.3)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-1.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + endif + endif + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dconnect.f calculix-ccx-2.3/ccx_2.3/src/gen3dconnect.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dconnect.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dconnect.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,233 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dconnect(kon,ipkon,lakon,ne,iponoel,inoel, + & iponoelmax,rig,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc, + & nmpc_,mpcfree,ikmpc,ilmpc,labmpc) +! +! connects expanded 1-D and 2-D elements with genuine 3D elements +! + implicit none +! + character*8 lakon(*) + character*20 labmpc(*) +! + integer kon(*),ipkon(*),ne,iponoel(*),inoel(3,*),iponoelmax, + & rig(*),iponor(2,*),knor(*),ipompc(*),nodempc(3,*),nmpc,nmpc_, + & mpcfree,ikmpc(*),ilmpc(*),i,indexes,nope,l,node,index2,ielem, + & indexe,j,indexk,newnode,idir,idof,id,mpcfreenew,k +! + real*8 xnor(*),coefmpc(*) +! +! generating MPC's to connect shells and beams with solid +! elements +! + do i=1,ne + indexes=ipkon(i) + if(indexes.lt.0) cycle + if((lakon(i)(7:7).ne.' ').and.(lakon(i)(1:1).ne.'E')) cycle +c if((lakon(i)(4:4).ne.'8').and. +c & (lakon(i)(4:4).ne.'1').and. +c & (lakon(i)(7:7).ne.' ')) cycle + if(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:4).eq.'1') then + nope=10 + elseif(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(1:1).eq.'E') then + read(lakon(i)(8:8),'(i1)') nope + else + cycle + endif + do l=1,nope + node=kon(indexes+l) + if(node.le.iponoelmax) then + if(rig(node).eq.0) then + index2=iponoel(node) + if(index2.eq.0) cycle + ielem=inoel(1,index2) + indexe=ipkon(ielem) + j=inoel(2,index2) + indexk=iponor(2,indexe+j) +! +! 2d shell element +! + if(lakon(ielem)(7:7).eq.'L') then + newnode=knor(indexk+1) + do idir=0,3 + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=knor(indexk+3) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-2.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + enddo + elseif(lakon(ielem)(7:7).eq.'B') then +! +! 1d beam element +! + newnode=knor(indexk+1) + do idir=0,3 + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + do k=2,4 + nodempc(1,mpcfree)=knor(indexk+k) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + enddo + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-4.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + enddo + else +! +! 2d plane stress, plane strain or axisymmetric +! element +! + newnode=knor(indexk+2) + do idir=0,2 + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-1.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dconnect: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + enddo + endif + endif + endif + enddo + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3delem.f calculix-ccx-2.3/ccx_2.3/src/gen3delem.f --- calculix-ccx-2.1/ccx_2.3/src/gen3delem.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3delem.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,732 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3delem(kon,ipkon,lakon,ne,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,ikboun,ilboun,nboun, + & nboun_,nodeboun,ndirboun,xboun,iamboun,nam, + & inotr,trab,nk,nk_,iponoel,inoel,iponor,xnor,thicke,thickn, + & knor,istep,offset,t0,t1,ikforc,ilforc,rig,nforc, + & nforc_,nodeforc,ndirforc,xforc,iamforc,nelemload,sideload, + & nload,ithermal,ntrans,co,ixfree,ikfree,inoelfree,iponoelmax, + & iperturb,tinc,tper,tmin,tmax,ctrl,typeboun,nmethod,nset,set, + & istartset,iendset,ialset,prop,ielprop,vold,mi) +! +! generates three-dimensional elements: +! for isochoric elements +! for plane stress +! for plane strain +! for plate and shell elements +! for beam elements +! + implicit none +! + logical isochoric +! + character*1 typeboun(*) + character*8 lakon(*) + character*20 labmpc(*),sideload(*),label + character*81 set(*) +! + integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,ikmpc(*), + & ilmpc(*),kon(*),ipkon(*),ne,mpc,indexe,i,j,k,node,idof, + & id,mpcfreeold,ikboun(*),ilboun(*),nboun,nboun_,kflag,idummy, + & iterm(500),nterm,neigh(7,8),l,m,nodeboun(*),ndirboun(*),nk, + & nk_,index,iponoel(*),inoel(3,*),inoelfree,istep,nmpcold, + & ikforc(*),ilforc(*),nodeforc(2,*),ndirforc(*),iamforc(*), + & nelemload(*),nforc,nforc_,ithermal(2),nload,iamboun(*), + & ntrans,inotr(2,*),nam,iponoelmax,iperturb,numnod,itransaxial, + & rig(*),nmethod,nset,istartset(*),iendset(*),ialset(*), + & ielprop(*),idir,indexref,indexold,idofold,idold,indexnew, + & idofnew,idnew,ksol,lsol,nmpc0,nmpc01,nmpcdif,mi(2),nope +! + integer iponor(2,*),knor(*),ixfree,ikfree +! + real*8 coefmpc(*),thicke(2,*),xnor(*),thickn(2,*),tinc,tper,tmin, + & tmax,offset(2,*),t0(*),t1(*),xforc(*),trab(7,*),co(3,*),b(3,3), + & xboun(*),pi,ctrl(*),prop(*),vold(0:mi(2),*),xlag(3,20), + & xeul(3,20),a(3,3),xi,et,ze,coloc(3,8),xj +! + data neigh /1,9,2,12,4,17,5,2,9,1,10,3,18,6, + & 3,11,4,10,2,19,7,4,11,3,12,1,20,8, + & 5,13,6,16,8,17,1,6,13,5,14,7,18,2, + & 7,15,8,14,6,19,3,8,15,7,16,5,20,4/ +! + data coloc /-1.,-1.,-1.,1.,-1.,-1.,1.,1.,-1.,-1.,1.,-1., + & -1.,-1.,1.,1.,-1.,1.,1.,1.,1.,-1.,1.,1./ +! + isochoric=.false. + pi=4.d0*datan(1.d0) +! +! catalogueing the element per node relationship for shell/beam +! elements and transferring the nodal thickness to the elements +! +! inoelfree=1 means that there is at least one 1D or 2D element +! in the structure. Otherwise inoelfree=0. +! + if((istep.eq.1).and.(inoelfree.eq.1)) then +! + itransaxial=0 +! + do i=1,ne + if(ipkon(i).lt.0) cycle + if((lakon(i)(1:2).ne.'C3').and.(lakon(i)(1:1).ne.'D').and. + & (lakon(i)(1:1).ne.'G').and.(lakon(i)(1:1).ne.'E')) then + if(lakon(i)(1:1).eq.'B') then + numnod=3 + elseif((lakon(i)(2:2).eq.'6').or. + & (lakon(i)(4:4).eq.'6')) then + numnod=6 + else + numnod=8 + endif + indexe=ipkon(i) + do j=1,numnod + node=kon(indexe+j) + iponoelmax=max(iponoelmax,node) + inoel(1,inoelfree)=i + inoel(2,inoelfree)=j + inoel(3,inoelfree)=iponoel(node) + iponoel(node)=inoelfree + inoelfree=inoelfree+1 + if(lakon(i)(1:2).ne.'CA') then + if(thickn(1,node).gt.0.d0) + & thicke(1,indexe+j)=thickn(1,node) + if(thickn(2,node).gt.0.d0) + & thicke(2,indexe+j)=thickn(2,node) + endif + if(thicke(1,indexe+j).le.0.d0) then + if(lakon(i)(1:1).eq.'C') then + thicke(1,indexe+j)=1.d0 + else + write(*,*)'*ERROR in gen3delem: first thickness' + write(*,*)' in node ',j,' of element ',i + write(*,*)' is zero' + stop + endif + endif + if((lakon(i)(1:1).eq.'B').and. + & (thicke(2,indexe+j).le.0.d0)) then + write(*,*) '*ERROR in gen3delem: second thickness' + write(*,*)' in node ',j,' of beam element ',i + write(*,*)' is zero' + stop + endif + enddo + endif + enddo +! +! checking whether any rotational degrees of freedom are fixed +! by SPC's, MPC's or loaded by bending moments or torques +! in the end, rig(i)=0 if no rigid knot is defined in node i, +! else rig(i)=the rotational node of the knot. The value -1 is +! a dummy. +! + do i=1,nboun +c if(ndirboun(i).gt.3) rig(nodeboun(i))=-1 + if(ndirboun(i).gt.4) rig(nodeboun(i))=-1 + enddo + do i=1,nforc +c if(ndirforc(i).gt.3) rig(nodeforc(1,i))=-1 + if(ndirforc(i).gt.4) rig(nodeforc(1,i))=-1 + enddo + do i=1,nmpc + index=ipompc(i) + do + if(index.eq.0) exit +c if(nodempc(2,index).gt.3) then + if(nodempc(2,index).gt.4) then + rig(nodempc(1,index))=-1 + endif + index=nodempc(3,index) + enddo + enddo +! +! calculating the normals in nodes belonging to shells/beams +! + nmpcold=nmpc +! + call gen3dnor(nk,nk_,co,iponoel,inoel,iponoelmax,kon,ipkon, + & lakon,ne,thicke,offset,iponor,xnor,knor,rig,iperturb,tinc, + & tper,tmin,tmax,ctrl,ipompc,nodempc,coefmpc,nmpc,nmpc_, + & mpcfree,ikmpc,ilmpc,labmpc,ikboun,ilboun,nboun,nboun_, + & nodeboun,ndirboun,xboun,iamboun,typeboun,nam,ntrans,inotr, + & trab,ikfree,ixfree,nmethod,ithermal,istep,mi) +! + endif +! + if(istep.eq.1) then +! +! incompressible elements +! + nmpc0=nmpc + nmpc01=nmpc0+1 + do i=1,ne + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:7).eq.'C3D20RI') then + isochoric=.true. + indexe=ipkon(i) +! + do j=1,20 + node=kon(indexe+j) + do k=1,3 + xlag(k,j)=co(k,node) + xeul(k,j)=xlag(k,j)+vold(k,node) + enddo + enddo +! + do j=1,8 + node=kon(indexe+j) + mpc=0 + label(1:9)='ISOCHORIC' + write(label(10:20),'(i11)') node + nmpcdif=nmpc-nmpc0 + call cident20(labmpc(nmpc01),label,nmpcdif,id) + id=id+nmpc0 + if(id.gt.0) then + if(labmpc(id).eq.label) then + mpc=id + endif + endif +! +! new MPC: look for suitable dependent dof +! + if(mpc.eq.0) then + mpc=id+1 + ksol=0 + loop: do k=1,7 + do l=1,3 + idof=8*(kon(indexe+neigh(k,j))-1)+l +! +! check for SPC's using the same DOF +! + call nident(ikboun,idof,nboun,id) + if(id.gt.0) then + if(ikboun(id).eq.idof) cycle + endif +! +! check for MPC's using the same DOF +! + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) cycle + endif +! + ksol=k + lsol=l + exit loop + enddo + enddo loop +! +! no mpc available +! + if(ksol.eq.0) then + write(*,*) + & '*WARNING in gen3delem: no free DOF in' + write(*,*) + & ' node ',node,' for isochoric' + write(*,*) ' MPC application' + cycle + endif +! +! new mpc +! + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in gen3delem: increase nmpc_' + stop + endif + do l=1,nmpc + if(ilmpc(l).ge.mpc) ilmpc(l)=ilmpc(l)+1 + enddo + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=mpc + do l=nmpc,mpc+1,-1 + ipompc(l)=ipompc(l-1) + labmpc(l)=labmpc(l-1) + enddo +! + labmpc(mpc)(1:9)='ISOCHORIC ' + write(labmpc(mpc)(10:20),'(i11)') node +! +! terms of the node itself and its neighbors +! + ipompc(mpc)=mpcfree + do l=lsol,3 + nodempc(1,mpcfree)=kon(indexe+neigh(ksol,j)) + nodempc(2,mpcfree)=l + mpcfree=nodempc(3,mpcfree) + enddo +! + do k=ksol+1,7 + do l=1,3 + nodempc(1,mpcfree)=kon(indexe+neigh(k,j)) + nodempc(2,mpcfree)=l + mpcfree=nodempc(3,mpcfree) + enddo + enddo +! + do k=1,ksol-1 + do l=1,3 + nodempc(1,mpcfree)=kon(indexe+neigh(k,j)) + nodempc(2,mpcfree)=l + mpcfree=nodempc(3,mpcfree) + enddo + enddo +! + do l=1,lsol-1 + nodempc(1,mpcfree)=kon(indexe+neigh(ksol,j)) + nodempc(2,mpcfree)=l + mpcfree=nodempc(3,mpcfree) + enddo +! +! add nonhomogeneous term +! + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in gen3delem: increase nk_' + stop + endif + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfreeold)=nk + nodempc(2,mpcfreeold)=1 + nodempc(3,mpcfreeold)=0 + idof=8*(nk-1)+1 + call nident(ikboun,idof,nboun,id) + nboun=nboun+1 + if(nboun.gt.nboun_) then + write(*,*)'*ERROR in gen3delem: increase nboun_' + stop + endif + nodeboun(nboun)=nk + ndirboun(nboun)=1 + typeboun(nboun)='I' + do l=nboun,id+2,-1 + ikboun(l)=ikboun(l-1) + ilboun(l)=ilboun(l-1) + enddo + ikboun(id+1)=idof + ilboun(id+1)=nboun +! + else +! + indexref=nodempc(3,nodempc(3,ipompc(mpc))) + index=nodempc(3,indexref) + nterm=0 + do + if(index.eq.0) exit + nterm=nterm+1 + if(nterm.gt.500) then + write(*,*) '*ERROR in gen3delem:' + write(*,*) ' increase nterm_' + stop + endif + iterm(nterm)= + & 8*(nodempc(1,index)-1)+nodempc(2,index) + index=nodempc(3,index) + enddo + kflag=1 + call isortii(iterm,idummy,nterm,kflag) +! + do k=2,7 + do l=1,3 + m=8*(kon(indexe+neigh(k,j))-1)+l + call nident(iterm,m,nterm,id) + if(id.ne.0) then + if(iterm(id).eq.m) then + cycle + endif + endif + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=nodempc(3,indexref) + nodempc(3,indexref)=mpcfreeold + nodempc(1,mpcfreeold)=kon(indexe+neigh(k,j)) + nodempc(2,mpcfreeold)=l + enddo + enddo +! + endif +! + xi=coloc(1,j) + et=coloc(2,j) + ze=coloc(3,j) +! + call deuldlag(xi,et,ze,xlag,xeul,xj,a) +! + b(1,1)=a(2,2)*a(3,3)-a(2,3)*a(3,2) + b(1,2)=a(3,1)*a(2,3)-a(2,1)*a(3,3) + b(1,3)=a(2,1)*a(3,2)-a(3,1)*a(2,2) + b(2,1)=a(3,2)*a(1,3)-a(1,2)*a(3,3) + b(2,2)=a(1,1)*a(3,3)-a(3,1)*a(1,3) + b(2,3)=a(3,1)*a(1,2)-a(1,1)*a(3,2) + b(3,1)=a(1,2)*a(2,3)-a(2,2)*a(1,3) + b(3,2)=a(2,1)*a(1,3)-a(1,1)*a(2,3) + b(3,3)=a(1,1)*a(2,2)-a(1,2)*a(2,1) +! + index=ipompc(mpc) + do + if(nodempc(3,index).eq.0) then + coefmpc(index)=1.d0 + idof=8*(nodempc(1,index)-1) + & +nodempc(2,index) + call nident(ikboun,idof,nboun,id) + xboun(ilboun(id))=xboun(ilboun(id))+ + & a(1,1)*b(1,1)+a(1,2)*b(1,2)+a(1,3)*b(1,3) + & -1.d0/xj + exit + else + node=nodempc(1,index) + idir=nodempc(2,index) + do k=1,7 + if(kon(indexe+neigh(k,j)).eq.node) then + if(k.eq.1) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index)+1.5d0* + & (xi*b(1,1)+et*b(1,2)+ze*b(1,3)) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index)+1.5d0* + & (xi*b(2,1)+et*b(2,2)+ze*b(2,3)) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index)+1.5d0* + & (xi*b(3,1)+et*b(3,2)+ze*b(3,3)) + endif + elseif(k.eq.2) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index) + & -2.d0*xi*b(1,1) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index) + & -2.d0*xi*b(2,1) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index) + & -2.d0*xi*b(3,1) + endif + elseif(k.eq.3) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index) + & +0.5d0*xi*b(1,1) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index) + & +0.5d0*xi*b(2,1) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index) + & +0.5d0*xi*b(3,1) + endif + elseif(k.eq.4) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index) + & -2.d0*et*b(1,2) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index) + & -2.d0*et*b(2,2) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index) + & -2.d0*et*b(3,2) + endif + elseif(k.eq.5) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index) + & +0.5d0*et*b(1,2) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index) + & +0.5d0*et*b(2,2) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index) + & +0.5d0*et*b(3,2) + endif + elseif(k.eq.6) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index) + & -2.d0*ze*b(1,3) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index) + & -2.d0*ze*b(2,3) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index) + & -2.d0*ze*b(3,3) + endif + elseif(k.eq.7) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index) + & +0.5d0*ze*b(1,3) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index) + & +0.5d0*ze*b(2,3) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index) + & +0.5d0*ze*b(3,3) + endif + endif + exit + endif + enddo + endif + index=nodempc(3,index) + enddo +! + enddo + endif + enddo +! +! if there is any plane stress, plane strain or axisymmetric +! element the structure should lie in the z=0 plane +! + if(inoelfree.ne.0) then + do i=1,ne + if(ipkon(i).lt.0) cycle + if((lakon(i)(1:2).eq.'CP').or. + & (lakon(i)(1:2).eq.'CA')) then + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'6') then + nope=6 + else + nope=8 + endif + do j=1,nope + node=kon(indexe+j) + if(dabs(co(3,node)).gt.0.d0) then + write(*,*) '*ERROR in gen3delem. The structure' + write(*,*) ' contains plane stress, plane' + write(*,*) ' strain or axisymmetric' + write(*,*) ' elements and should lie in ' + write(*,*) ' the z=0 plane. This is at' + write(*,*) ' least not the case for node', + & node + stop + endif + enddo + endif + enddo + endif +! +! 1D and 2D elements +! + if(inoelfree.ne.0) then + do i=1,ne + if(ipkon(i).lt.0) cycle + if((lakon(i)(1:2).eq.'CP').or. + & (lakon(i)(1:1).eq.'S').or. + & (lakon(i)(1:2).eq.'CA')) then +! + call gen3dfrom2d(i,kon,ipkon,lakon,ne,iponor,xnor,knor, + & thicke,offset,ntrans,inotr,trab,ikboun,ilboun,nboun, + & nboun_,nodeboun,ndirboun,xboun,iamboun,typeboun,ipompc, + & nodempc,coefmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc, + & nk,nk_,co,rig,nmethod,iperturb,ithermal,mi,nam) +! + elseif(lakon(i)(1:1).eq.'B') then + call gen3dfrom1d(i,kon,ipkon,lakon,ne,iponor,xnor,knor, + & thicke,ntrans,inotr,trab,nk,nk_,co,offset) + endif +! + if(lakon(i)(1:4).eq.'CPE6') then + lakon(i)(1:7)='C3D15 E' + elseif(lakon(i)(1:5).eq.'CPE8R') then + lakon(i)(1:7)='C3D20RE' + elseif(lakon(i)(1:4).eq.'CPE8') then + lakon(i)(1:7)='C3D20 E' + elseif(lakon(i)(1:4).eq.'CPS6') then + lakon(i)(1:7)='C3D15 S' + elseif(lakon(i)(1:5).eq.'CPS8R') then + lakon(i)(1:7)='C3D20RS' + elseif(lakon(i)(1:4).eq.'CPS8') then + lakon(i)(1:7)='C3D20 S' + elseif(lakon(i)(1:4).eq.'CAX6') then + lakon(i)(1:7)='C3D15 A' + elseif(lakon(i)(1:5).eq.'CAX8R') then + lakon(i)(1:7)='C3D20RA' + elseif(lakon(i)(1:4).eq.'CAX8') then + lakon(i)(1:7)='C3D20 A' + elseif(lakon(i)(1:2).eq.'S6') then + lakon(i)(1:7)='C3D15 L' + elseif(lakon(i)(1:3).eq.'S8R') then + lakon(i)(1:7)='C3D20RL' + elseif(lakon(i)(1:2).eq.'S8') then + lakon(i)(1:7)='C3D20 L' + elseif(lakon(i)(1:4).eq.'B32R') then + lakon(i)(1:7)='C3D20RB' + elseif(lakon(i)(1:1).eq.'B') then + lakon(i)(1:7)='C3D20 B' + endif + enddo +c Bernhardi start + endif + do i=1,ne + if(lakon(i)(1:5).eq.'C3D8I') then + call genmodes(i,kon,ipkon,lakon,ne,nk,nk_,co) + endif + enddo +c Bernhardi end +! +! check whether the coefficient of the dependent +! terms in ISOCHORIC MPC's is not zero +! + if(isochoric) then + do i=1,nmpc + if(labmpc(i)(1:9).ne.'ISOCHORIC') cycle + index=ipompc(i) + if(dabs(coefmpc(index)).gt.1.d-10) cycle +! +! coefficient of dependent term is zero: rearranging +! the MPC +! + indexold=index + idofold=8*(nodempc(1,index)-1)+nodempc(2,index) + call nident(ikmpc,idofold,nmpc,idold) + do j=idold,nmpc-1 + ikmpc(j)=ikmpc(j+1) + ilmpc(j)=ilmpc(j+1) + enddo + indexref=index + index=nodempc(3,index) +! + do + if(index.eq.0) then + write(*,*) '*ERROR in gen3delem: coefficient' + write(*,*) ' of dependent term is zero' + write(*,*) ' and no other DOF is available' + stop + endif + if(dabs(coefmpc(index)).gt.1.d-10) then + idofnew=8*(nodempc(1,index)-1)+nodempc(2,index) +! +! check whether DOF is not used in SPC +! + call nident(ikboun,idofnew,nboun,idnew) + if(idnew.gt.0) then + if(ikboun(idnew).eq.idofnew) then + indexref=index + index=nodempc(3,index) + cycle + endif + endif +! +! check whether DOF is not used in MPC +! + call nident(ikmpc,idofnew,nmpc,idnew) + if(idnew.gt.0) then + if(ikmpc(idnew).eq.idofnew) then + indexref=index + index=nodempc(3,index) + cycle + endif + endif +! +! DOF is OK: take it as dependent term +! + do j=nmpc,idnew+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(idnew+1)=idofnew + ilmpc(idnew+1)=i +! + indexnew=index + index=nodempc(3,index) + ipompc(i)=indexnew + nodempc(3,indexnew)=indexold + nodempc(3,indexref)=index + exit + endif + indexref=index + index=nodempc(3,index) + enddo + enddo + endif +! +! filling the new KNOT MPC's (needs the coordinates +! of the expanded nodes) +! + if(inoelfree.ne.0) then + call fillknotmpc(co,ipompc,nodempc,coefmpc,labmpc, + & nmpc,nmpcold) + call gen3dprop(prop,ielprop,iponoel,inoel,iponoelmax,kon, + & ipkon,lakon,ne,iponor,xnor,knor,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr, + & trab,nam,nk,nk_,co,nmethod,iperturb) + endif +! + endif +! +! generating MPC's to connect shells and beams with solid +! elements +! + if((inoelfree.ne.0).and.(istep.eq.1)) then + call gen3dconnect(kon,ipkon,lakon,ne,iponoel,inoel, + & iponoelmax,rig,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc, + & nmpc_,mpcfree,ikmpc,ilmpc,labmpc) + endif +! + if(inoelfree.ne.0) then +! +! multiplying existing boundary conditions +! + call gen3dboun(ikboun,ilboun,nboun,nboun_,nodeboun,ndirboun, + & xboun,iamboun,typeboun,iponoel,inoel,iponoelmax,kon,ipkon, + & lakon,ne,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc,nmpc_, + & mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk,nk_, + & co,nmethod,iperturb,istep,vold,mi) +! +! updating the nodal surfaces: establishing links between the user +! defined nodes and the newly generated nodes (mid-nodes +! for 2d elements, mean of corner nodes for 1d elements) +! + if(istep.eq.1) then + call gen3dsurf(iponoel,inoel,iponoelmax,kon,ipkon, + & lakon,ne,iponor,knor,ipompc,nodempc,coefmpc,nmpc,nmpc_, + & mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk, + & nk_,co,nmethod,iperturb,nset,set,istartset,iendset,ialset) + endif +! +! updating the MPCs: establishing links between the user +! defined nodes and the newly generated nodes (mid-nodes +! for 2d elements, mean of corner nodes for 1d elements) +! + if(istep.eq.1) then + call gen3dmpc(ipompc,nodempc,coefmpc,nmpc,nmpc_,mpcfree, + & ikmpc,ilmpc,labmpc,iponoel,inoel,iponoelmax,kon,ipkon, + & lakon,ne,iponor,xnor,knor,rig) + endif +! +! updating the temperatures +! + if(ithermal(1).gt.0) then + call gen3dtemp(iponoel,inoel,iponoelmax,kon,ipkon,lakon,ne, + & iponor,xnor,knor,t0,t1,thicke,offset,rig,nk,nk_,co, + & istep,ithermal,vold,mi) + endif +! +! updating the concentrated loading +! + call gen3dforc(ikforc,ilforc,nforc,nforc_,nodeforc, + & ndirforc,xforc,iamforc,ntrans,inotr,trab,rig,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,iponoel,inoel, + & iponoelmax,kon,ipkon,lakon,ne,iponor,xnor,knor,nam,nk,nk_, + & co,thicke,nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, + & iamboun,typeboun,xboun,nmethod,iperturb,istep,vold,mi) + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dforc.f calculix-ccx-2.3/ccx_2.3/src/gen3dforc.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dforc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dforc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,613 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dforc(ikforc,ilforc,nforc,nforc_,nodeforc, + & ndirforc,xforc,iamforc,ntrans,inotr,trab,rig,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,iponoel,inoel, + & iponoelmax,kon,ipkon,lakon,ne,iponor,xnor,knor,nam,nk,nk_, + & co,thicke,nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, + & iamboun,typeboun,xboun,nmethod,iperturb,istep,vold,mi) +! +! connects nodes of 1-D and 2-D elements, for which +! concentrated forces were +! defined, to the nodes of their expanded counterparts +! + implicit none +! + logical add,fixed,user +! + character*1 type,typeboun(*) + character*8 lakon(*) + character*20 labmpc(*) +! + integer ikforc(*),ilforc(*),nodeforc(2,*),ndirforc(*),iamforc(*), + & nforc,nforc_,ntrans,inotr(2,*),rig(*),ipompc(*),nodempc(3,*), + & nmpc,nmpc_,mpcfree,ikmpc(*),ilmpc(*),iponoel(*),inoel(3,*), + & iponoelmax,kon(*),ipkon(*),ne,iponor(2,*),knor(*),nforcold, + & i,node,index,ielem,j,indexe,indexk,nam,iamplitude,idir, + & irotnode,nk,nk_,newnode,idof,id,mpcfreenew,k,isector,ndepnodes, + & idepnodes(80),l,iexpnode,indexx,irefnode,imax,isol,mpcfreeold, + & nod,impc,istep,nodeboun(*),ndirboun(*),ikboun(*),ilboun(*), + & nboun,nboun_,iamboun(*),nmethod,iperturb,nrhs,ipiv(3),info,m, + & mi(2) +! + real*8 xforc(*),trab(7,*),coefmpc(*),xnor(*),val,co(3,*), + & thicke(2,*),pi,xboun(*),xnoref(3),dmax,d(3,3),e(3,3,3), + & alpha,q(3),w(3),xn(3),a(3,3),a1(3),a2(3),dd,c1,c2,c3,ww,c(3,3), + & vold(0:mi(2),*) +! + data d /1.,0.,0.,0.,1.,0.,0.,0.,1./ + data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., + & 0.,0.,1.,0.,0.,0.,-1.,0.,0., + & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ +! + fixed=.false. +! + add=.false. + user=.false. + pi=4.d0*datan(1.d0) + isector=0 +! + nforcold=nforc + do i=1,nforcold + node=nodeforc(1,i) + if(node.gt.iponoelmax) then + if(ndirforc(i).gt.4) then + write(*,*) '*WARNING: in gen3dforc: node ',i, + & ' does not' + write(*,*) ' belong to a beam nor shell' + write(*,*) ' element and consequently has no' + write(*,*) ' rotational degrees of freedom' + endif + cycle + endif + index=iponoel(node) + if(index.eq.0) then + if(ndirforc(i).gt.4) then + write(*,*) '*WARNING: in gen3dforc: node ',i, + & ' does not' + write(*,*) ' belong to a beam nor shell' + write(*,*) ' element and consequently has no' + write(*,*) ' rotational degrees of freedom' + endif + cycle + endif + ielem=inoel(1,index) + j=inoel(2,index) + indexe=ipkon(ielem) + indexk=iponor(2,indexe+j) + if(nam.gt.0) iamplitude=iamforc(i) + idir=ndirforc(i) +! + if(rig(node).ne.0) then + if(idir.gt.4) then + if(rig(node).lt.0) then + write(*,*) '*ERROR in gen3dforc: in node ',node + write(*,*) ' a rotational DOF is loaded;' + write(*,*) ' however, the elements to which' + write(*,*) ' this node belongs do not have' + write(*,*) ' rotational DOFs' + stop + endif + val=xforc(i) + k=idir-4 + irotnode=rig(node) + call forcadd(irotnode,k,val,nodeforc, + & ndirforc,xforc,nforc,nforc_,iamforc, + & iamplitude,nam,ntrans,trab,inotr,co, + & ikforc,ilforc,isector,add,user) + endif + else +! +! check for moments defined in any but the first step +! + if(idir.gt.4) then +! +! create a knot: determine the knot +! + ndepnodes=0 + if(lakon(ielem)(7:7).eq.'L') then + do k=1,3 + ndepnodes=ndepnodes+1 + idepnodes(ndepnodes)=knor(indexk+k) + enddo + elseif(lakon(ielem)(7:7).eq.'B') then + do k=1,8 + ndepnodes=ndepnodes+1 + idepnodes(ndepnodes)=knor(indexk+k) + enddo + else + write(*,*) + & '*ERROR in gen3dboun: a rotational DOF was applied' + write(*,*) + & '* to node',node,' without rotational DOFs' + stop + endif +! +! remove all MPC's in which the knot nodes are +! dependent nodes +! + do k=1,ndepnodes + nod=idepnodes(k) + do l=1,3 + idof=8*(nod-1)+l + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + impc=ilmpc(id) + call mpcrem(impc,mpcfree,nodempc,nmpc, + & ikmpc,ilmpc,labmpc,coefmpc,ipompc) + endif + endif + enddo + enddo +! +! generate a rigid body knot +! + irefnode=node + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in rigidbodies: increase nk_' + stop + endif + irotnode=nk + rig(node)=irotnode + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in rigidbodies: increase nk_' + stop + endif + iexpnode=nk + do k=1,ndepnodes + call knotmpc(ipompc,nodempc,coefmpc,irefnode, + & irotnode,iexpnode, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_, + & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, + & idepnodes(k),typeboun,co,xboun,istep) + enddo +! +! determine the location of the center of gravity of +! the section and its displacements +! + do l=1,3 + q(l)=0.d0 + w(l)=0.d0 + enddo + if(ndepnodes.eq.3) then + do k=1,ndepnodes,2 + nod=idepnodes(k) + do l=1,3 + q(l)=q(l)+co(l,nod) + w(l)=w(l)+vold(l,nod) + enddo + enddo + do l=1,3 + q(l)=q(l)/2.d0 + w(l)=w(l)/2.d0 + enddo + else + do k=1,ndepnodes + nod=idepnodes(k) + do l=1,3 + q(l)=q(l)+co(l,nod) + w(l)=w(l)+vold(l,nod) + enddo + enddo + do l=1,3 + q(l)=q(l)/ndepnodes + w(l)=w(l)/ndepnodes + enddo + endif +! +! determine the first displacements of iexpnode +! + alpha=0.d0 + do k=1,ndepnodes + nod=idepnodes(k) + dd=(co(1,nod)-q(1))**2 + & +(co(2,nod)-q(2))**2 + & +(co(3,nod)-q(3))**2 + if(dd.lt.1.d-20) cycle + alpha=alpha+dsqrt( + & ((co(1,nod)+vold(1,nod)-q(1)-w(1))**2 + & +(co(2,nod)+vold(2,nod)-q(2)-w(2))**2 + & +(co(3,nod)+vold(3,nod)-q(3)-w(3))**2)/dd) + enddo + alpha=alpha/ndepnodes +! +! determine the displacements of irotnodes +! + do l=1,3 + do m=1,3 + a(l,m)=0.d0 + enddo + xn(l)=0.d0 + enddo + do k=1,ndepnodes + nod=idepnodes(k) + dd=0.d0 + do l=1,3 + a1(l)=co(l,nod)-q(l) + a2(l)=vold(l,nod)-w(l) + dd=dd+a1(l)*a1(l) + enddo + dd=dsqrt(dd) + if(dd.lt.1.d-10) cycle + do l=1,3 + a1(l)=a1(l)/dd + a2(l)=a2(l)/dd + enddo + xn(1)=xn(1)+(a1(2)*a2(3)-a1(3)*a2(2)) + xn(2)=xn(2)+(a1(3)*a2(1)-a1(1)*a2(3)) + xn(3)=xn(3)+(a1(1)*a2(2)-a1(2)*a2(1)) + do l=1,3 + do m=1,3 + a(l,m)=a(l,m)+a1(l)*a1(m) + enddo + enddo + enddo +! + do l=1,3 + do m=1,3 + a(l,m)=a(l,m)/ndepnodes + enddo + xn(l)=xn(l)/ndepnodes + a(l,l)=1.d0-a(l,l) + enddo +! + m=3 + nrhs=1 + call dgesv(m,nrhs,a,m,ipiv,xn,m,info) + if(info.ne.0) then + write(*,*) '*ERROR in gen3dforc:' + write(*,*) ' singular system of equations' + stop + endif +! + dd=0.d0 + do l=1,3 + dd=dd+xn(l)*xn(l) + enddo + dd=dsqrt(dd) + do l=1,3 + xn(l)=dasin(dd/alpha)*xn(l)/dd + enddo +! +! determine the displacements of irefnode +! + ww=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) +! + c1=dcos(ww) + if(ww.gt.1.d-10) then + c2=dsin(ww)/ww + else + c2=1.d0 + endif + if(ww.gt.1.d-5) then + c3=(1.d0-c1)/ww**2 + else + c3=0.5d0 + endif +! +! rotation matrix c +! + do k=1,3 + do l=1,3 + c(k,l)=c1*d(k,l)+ + & c2*(e(k,1,l)*xn(1)+e(k,2,l)*xn(2)+ + & e(k,3,l)*xn(3))+c3*xn(k)*xn(l) + enddo + enddo +! + do l=1,3 + w(l)=w(l)+(alpha*c(l,1)-d(l,1))*(co(1,irefnode)-q(1)) + & +(alpha*c(l,2)-d(l,2))*(co(2,irefnode)-q(2)) + & +(alpha*c(l,3)-d(l,3))*(co(3,irefnode)-q(3)) + enddo +! +! copying the displacements +! + do l=1,3 + vold(l,irefnode)=w(l) + vold(l,irotnode)=xn(l) + enddo + vold(1,iexpnode)=alpha +! +! apply the moment +! + idir=idir-4 + val=xforc(i) + call forcadd(irotnode,idir,val,nodeforc, + & ndirforc,xforc,nforc,nforc_,iamforc, + & iamplitude,nam,ntrans,trab,inotr,co, + & ikforc,ilforc,isector,add,user) +! +! check for shells whether the rotation about the normal +! on the shell has been eliminated +! + if(lakon(ielem)(7:7).eq.'L') then + indexx=iponor(1,indexe+j) + do k=1,3 + xnoref(k)=xnor(indexx+k) + enddo + dmax=0.d0 + imax=0 + do k=1,3 + if(dabs(xnoref(k)).gt.dmax) then + dmax=dabs(xnoref(k)) + imax=k + endif + enddo +! +! check whether a SPC suffices +! + if(dabs(1.d0-dmax).lt.1.d-3) then + val=0.d0 + if(nam.gt.0) iamplitude=0 + type='R' + call bounadd(irotnode,imax,imax,val,nodeboun, + & ndirboun,xboun,nboun,nboun_,iamboun, + & iamplitude,nam,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, + & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vold, + & irotnode,mi) + else +! +! check for an unused rotational DOF +! + isol=0 + do l=1,3 + idof=8*(node-1)+4+imax + call nident(ikboun,idof,nboun,id) + if((id.gt.0).and.(ikboun(id).eq.idof)) then + imax=imax+1 + if(imax.gt.3) imax=imax-3 + cycle + endif + isol=1 + exit + enddo +! +! if one of the rotational dofs was not used so far, +! it can be taken as dependent side for fixing the +! rotation about the normal. If all dofs were used, +! no additional equation is needed. +! + if(isol.eq.1) then + idof=8*(irotnode-1)+imax + call nident(ikmpc,idof,nmpc,id) + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dnor: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)=' ' +! + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=imax + coefmpc(mpcfree)=xnoref(imax) + mpcfree=nodempc(3,mpcfree) + imax=imax+1 + if(imax.gt.3) imax=imax-3 + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=imax + coefmpc(mpcfree)=xnoref(imax) + mpcfree=nodempc(3,mpcfree) + imax=imax+1 + if(imax.gt.3) imax=imax-3 + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=imax + coefmpc(mpcfree)=xnoref(imax) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + endif + endif + endif + cycle + endif +! +! 2d element shell element: generate MPC's +! + if(lakon(ielem)(7:7).eq.'L') then + newnode=knor(indexk+1) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dforc: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do k=nmpc,id+2,-1 + ikmpc(k)=ikmpc(k-1) + ilmpc(k)=ilmpc(k-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! +! for middle nodes: u_1+u_3-2*u_node=0 +! for end nodes: -u_1+4*u_2-u_3-2*u_node=0 +! +! u_1 corresponds to knor(indexk+1).... +! + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + if(j.gt.4) then + coefmpc(mpcfree)=1.d0 + else + coefmpc(mpcfree)=-1.d0 + endif + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dforc: increase nmpc_' + stop + endif +! + if(j.le.4) then + nodempc(1,mpcfree)=knor(indexk+2) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=4.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dforc: increase nmpc_' + stop + endif + endif +! + nodempc(1,mpcfree)=knor(indexk+3) + nodempc(2,mpcfree)=idir + if(j.gt.4) then + coefmpc(mpcfree)=1.d0 + else + coefmpc(mpcfree)=-1.d0 + endif + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dforc: increase nmpc_' + stop + endif +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-2.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dforc: increase nmpc_' + stop + endif +! + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + elseif(lakon(ielem)(7:7).eq.'B') then +! +! 1d beam element: generate MPC's +! + newnode=knor(indexk+1) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dforc: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do k=nmpc,id+2,-1 + ikmpc(k)=ikmpc(k-1) + ilmpc(k)=ilmpc(k-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +c nodempc(1,mpcfree)=newnode +c nodempc(2,mpcfree)=idir +c coefmpc(mpcfree)=1.d0 +c mpcfree=nodempc(3,mpcfree) +c if(mpcfree.eq.0) then +c write(*,*) +c & '*ERROR in gen3dforc: increase nmpc_' +c stop +c endif +c if(j.eq.2) then + do k=1,4 + nodempc(1,mpcfree)=knor(indexk+k) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dforc: increase nmpc_' + stop + endif + enddo +c else +c do k=1,4 +c nodempc(1,mpcfree)=knor(indexk+k) +c nodempc(2,mpcfree)=idir +c coefmpc(mpcfree)=-1.d0/3.d0 +c mpcfree=nodempc(3,mpcfree) +c if(mpcfree.eq.0) then +c write(*,*) +c & '*ERROR in gen3dforc: increase nmpc_' +c stop +c endif +c enddo +c do k=5,8 +c nodempc(1,mpcfree)=knor(indexk+k) +c nodempc(2,mpcfree)=idir +c coefmpc(mpcfree)=4.d0/3.d0 +c mpcfree=nodempc(3,mpcfree) +c if(mpcfree.eq.0) then +c write(*,*) +c & '*ERROR in gen3dforc: increase nmpc_' +c stop +c endif +c enddo +c endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-4.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dforc: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + else +! +! 2d plane strain, plane stress or axisymmetric +! element +! + node=knor(indexk+2) + val=xforc(i) + call forcadd(node,idir,val,nodeforc, + & ndirforc,xforc,nforc,nforc_,iamforc, + & iamplitude,nam,ntrans,trab,inotr,co, + & ikforc,ilforc,isector,add,user) + endif + endif + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dfrom1d.f calculix-ccx-2.3/ccx_2.3/src/gen3dfrom1d.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dfrom1d.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dfrom1d.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,312 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dfrom1d(i,kon,ipkon,lakon,ne,iponor,xnor,knor, + & thicke,ntrans,inotr,trab,nk,nk_,co,offset) +! +! expands 1d element i into a 3d element +! + implicit none +! + character*8 lakon(*) +! + integer i,kon(*),ipkon(*),ne,iponor(2,*),knor(*),ntrans, + & inotr(2,*),nk,nk_,indexe,j,nodel(8),indexx,indexk,k,nodeb(8,3) +! + real*8 xnor(*),thicke(2,*),trab(7,*),co(3,*),offset(2,*), + & thickb(2,3),xnorb(6,3),sc +! + indexe=ipkon(i) +! +! localizing the nodes, thicknesses and normals for the +! beam element +! + do j=1,3 + nodel(j)=kon(indexe+j) + kon(indexe+20+j)=nodel(j) + indexx=iponor(1,indexe+j) + indexk=iponor(2,indexe+j) + thickb(1,j)=thicke(1,indexe+j) + thickb(2,j)=thicke(2,indexe+j) + do k=1,6 + xnorb(k,j)=xnor(indexx+k) + enddo + do k=1,8 + nodeb(k,j)=knor(indexk+k) + enddo + if(ntrans.gt.0) then + do k=1,8 + inotr(1,nodeb(k,j))=inotr(1,nodel(j)) + enddo + endif + enddo +! +! generating the 3-D element topology for beam elements +! + if(lakon(i)(8:8).eq.'R') then + kon(indexe+1)=nodeb(1,1) + do j=1,3 + co(j,nodeb(1,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*(.5d0+offset(1,i)) + & +thickb(2,1)*xnorb(j+3,1)*(.5d0-offset(2,i)) + enddo + kon(indexe+2)=nodeb(1,3) + do j=1,3 + co(j,nodeb(1,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*(.5d0+offset(1,i)) + & +thickb(2,3)*xnorb(j+3,3)*(.5d0-offset(2,i)) + enddo + kon(indexe+3)=nodeb(2,3) + do j=1,3 + co(j,nodeb(2,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*(.5d0+offset(1,i)) + & -thickb(2,3)*xnorb(j+3,3)*(.5d0+offset(2,i)) + enddo + kon(indexe+4)=nodeb(2,1) + do j=1,3 + co(j,nodeb(2,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*(.5d0+offset(1,i)) + & -thickb(2,1)*xnorb(j+3,1)*(.5d0+offset(2,i)) + enddo + kon(indexe+5)=nodeb(4,1) + do j=1,3 + co(j,nodeb(4,1))=co(j,nodel(1)) + & +thickb(1,1)*xnorb(j,1)*(.5d0-offset(1,i)) + & +thickb(2,1)*xnorb(j+3,1)*(.5d0-offset(2,i)) + enddo + kon(indexe+6)=nodeb(4,3) + do j=1,3 + co(j,nodeb(4,3))=co(j,nodel(3)) + & +thickb(1,3)*xnorb(j,3)*(.5d0-offset(1,i)) + & +thickb(2,3)*xnorb(j+3,3)*(.5d0-offset(2,i)) + enddo + kon(indexe+7)=nodeb(3,3) + do j=1,3 + co(j,nodeb(3,3))=co(j,nodel(3)) + & +thickb(1,3)*xnorb(j,3)*(.5d0-offset(1,i)) + & -thickb(2,3)*xnorb(j+3,3)*(.5d0+offset(2,i)) + enddo + kon(indexe+8)=nodeb(3,1) + do j=1,3 + co(j,nodeb(3,1))=co(j,nodel(1)) + & +thickb(1,1)*xnorb(j,1)*(.5d0-offset(1,i)) + & -thickb(2,1)*xnorb(j+3,1)*(.5d0+offset(2,i)) + enddo + kon(indexe+9)=nodeb(1,2) + do j=1,3 + co(j,nodeb(1,2))=co(j,nodel(2)) + & -thickb(1,2)*xnorb(j,2)*(.5d0+offset(1,i)) + & +thickb(2,2)*xnorb(j+3,2)*(.5d0-offset(2,i)) + enddo + kon(indexe+10)=nodeb(5,3) + do j=1,3 + co(j,nodeb(5,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*(.5d0+offset(1,i)) + & -thickb(2,3)*xnorb(j+3,3)*offset(2,i) + enddo + kon(indexe+11)=nodeb(2,2) + do j=1,3 + co(j,nodeb(2,2))=co(j,nodel(2)) + & -thickb(1,2)*xnorb(j,2)*(.5d0+offset(1,i)) + & -thickb(2,2)*xnorb(j+3,2)*(.5d0+offset(2,i)) + enddo + kon(indexe+12)=nodeb(5,1) + do j=1,3 + co(j,nodeb(5,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*(.5d0+offset(1,i)) + & -thickb(2,1)*xnorb(j+3,1)*offset(2,i) + enddo + kon(indexe+13)=nodeb(4,2) + do j=1,3 + co(j,nodeb(4,2))=co(j,nodel(2)) + & +thickb(1,2)*xnorb(j,2)*(.5d0-offset(1,i)) + & +thickb(2,2)*xnorb(j+3,2)*(.5d0-offset(2,i)) + enddo + kon(indexe+14)=nodeb(7,3) + do j=1,3 + co(j,nodeb(7,3))=co(j,nodel(3)) + & +thickb(1,3)*xnorb(j,3)*(.5d0-offset(1,i)) + & -thickb(2,3)*xnorb(j+3,3)*offset(2,i) + enddo + kon(indexe+15)=nodeb(3,2) + do j=1,3 + co(j,nodeb(3,2))=co(j,nodel(2)) + & +thickb(1,2)*xnorb(j,2)*(.5d0-offset(1,i)) + & -thickb(2,2)*xnorb(j+3,2)*(.5d0+offset(2,i)) + enddo + kon(indexe+16)=nodeb(7,1) + do j=1,3 + co(j,nodeb(7,1))=co(j,nodel(1)) + & +thickb(1,1)*xnorb(j,1)*(.5d0-offset(1,i)) + & -thickb(2,1)*xnorb(j+3,1)*offset(2,i) + enddo + kon(indexe+17)=nodeb(8,1) + do j=1,3 + co(j,nodeb(8,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*offset(1,i) + & +thickb(2,1)*xnorb(j+3,1)*(.5d0-offset(2,i)) + enddo + kon(indexe+18)=nodeb(8,3) + do j=1,3 + co(j,nodeb(8,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*offset(1,i) + & +thickb(2,3)*xnorb(j+3,3)*(.5d0-offset(2,i)) + enddo + kon(indexe+19)=nodeb(6,3) + do j=1,3 + co(j,nodeb(6,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*offset(1,i) + & -thickb(2,3)*xnorb(j+3,3)*(.5d0+offset(2,i)) + enddo + kon(indexe+20)=nodeb(6,1) + do j=1,3 + co(j,nodeb(6,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*offset(1,i) + & -thickb(2,1)*xnorb(j+3,1)*(.5d0+offset(2,i)) + enddo + else +! +! circular cross section +! + sc=.5d0/dsqrt(2.d0) + kon(indexe+1)=nodeb(1,1) + do j=1,3 + co(j,nodeb(1,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*(sc+offset(1,i)) + & +thickb(2,1)*xnorb(j+3,1)*(sc-offset(2,i)) + enddo + kon(indexe+2)=nodeb(1,3) + do j=1,3 + co(j,nodeb(1,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*(sc+offset(1,i)) + & +thickb(2,3)*xnorb(j+3,3)*(sc-offset(2,i)) + enddo + kon(indexe+3)=nodeb(2,3) + do j=1,3 + co(j,nodeb(2,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*(sc+offset(1,i)) + & -thickb(2,3)*xnorb(j+3,3)*(sc+offset(2,i)) + enddo + kon(indexe+4)=nodeb(2,1) + do j=1,3 + co(j,nodeb(2,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*(sc+offset(1,i)) + & -thickb(2,1)*xnorb(j+3,1)*(sc+offset(2,i)) + enddo + kon(indexe+5)=nodeb(4,1) + do j=1,3 + co(j,nodeb(4,1))=co(j,nodel(1)) + & +thickb(1,1)*xnorb(j,1)*(sc-offset(1,i)) + & +thickb(2,1)*xnorb(j+3,1)*(sc-offset(2,i)) + enddo + kon(indexe+6)=nodeb(4,3) + do j=1,3 + co(j,nodeb(4,3))=co(j,nodel(3)) + & +thickb(1,3)*xnorb(j,3)*(sc-offset(1,i)) + & +thickb(2,3)*xnorb(j+3,3)*(sc-offset(2,i)) + enddo + kon(indexe+7)=nodeb(3,3) + do j=1,3 + co(j,nodeb(3,3))=co(j,nodel(3)) + & +thickb(1,3)*xnorb(j,3)*(sc-offset(1,i)) + & -thickb(2,3)*xnorb(j+3,3)*(sc+offset(2,i)) + enddo + kon(indexe+8)=nodeb(3,1) + do j=1,3 + co(j,nodeb(3,1))=co(j,nodel(1)) + & +thickb(1,1)*xnorb(j,1)*(sc-offset(1,i)) + & -thickb(2,1)*xnorb(j+3,1)*(sc+offset(2,i)) + enddo + kon(indexe+9)=nodeb(1,2) + do j=1,3 + co(j,nodeb(1,2))=co(j,nodel(2)) + & -thickb(1,2)*xnorb(j,2)*(sc+offset(1,i)) + & +thickb(2,2)*xnorb(j+3,2)*(sc-offset(2,i)) + enddo + kon(indexe+10)=nodeb(5,3) + do j=1,3 + co(j,nodeb(5,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*(.5d0+offset(1,i)) + & -thickb(2,3)*xnorb(j+3,3)*offset(2,i) + enddo + kon(indexe+11)=nodeb(2,2) + do j=1,3 + co(j,nodeb(2,2))=co(j,nodel(2)) + & -thickb(1,2)*xnorb(j,2)*(sc+offset(1,i)) + & -thickb(2,2)*xnorb(j+3,2)*(sc+offset(2,i)) + enddo + kon(indexe+12)=nodeb(5,1) + do j=1,3 + co(j,nodeb(5,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*(.5d0+offset(1,i)) + & -thickb(2,1)*xnorb(j+3,1)*offset(2,i) + enddo + kon(indexe+13)=nodeb(4,2) + do j=1,3 + co(j,nodeb(4,2))=co(j,nodel(2)) + & +thickb(1,2)*xnorb(j,2)*(sc-offset(1,i)) + & +thickb(2,2)*xnorb(j+3,2)*(sc-offset(2,i)) + enddo + kon(indexe+14)=nodeb(7,3) + do j=1,3 + co(j,nodeb(7,3))=co(j,nodel(3)) + & +thickb(1,3)*xnorb(j,3)*(.5d0-offset(1,i)) + & -thickb(2,3)*xnorb(j+3,3)*offset(2,i) + enddo + kon(indexe+15)=nodeb(3,2) + do j=1,3 + co(j,nodeb(3,2))=co(j,nodel(2)) + & +thickb(1,2)*xnorb(j,2)*(sc-offset(1,i)) + & -thickb(2,2)*xnorb(j+3,2)*(sc+offset(2,i)) + enddo + kon(indexe+16)=nodeb(7,1) + do j=1,3 + co(j,nodeb(7,1))=co(j,nodel(1)) + & +thickb(1,1)*xnorb(j,1)*(.5d0-offset(1,i)) + & -thickb(2,1)*xnorb(j+3,1)*offset(2,i) + enddo + kon(indexe+17)=nodeb(8,1) + do j=1,3 + co(j,nodeb(8,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*offset(1,i) + & +thickb(2,1)*xnorb(j+3,1)*(.5d0-offset(2,i)) + enddo + kon(indexe+18)=nodeb(8,3) + do j=1,3 + co(j,nodeb(8,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*offset(1,i) + & +thickb(2,3)*xnorb(j+3,3)*(.5d0-offset(2,i)) + enddo + kon(indexe+19)=nodeb(6,3) + do j=1,3 + co(j,nodeb(6,3))=co(j,nodel(3)) + & -thickb(1,3)*xnorb(j,3)*offset(1,i) + & -thickb(2,3)*xnorb(j+3,3)*(.5d0+offset(2,i)) + enddo + kon(indexe+20)=nodeb(6,1) + do j=1,3 + co(j,nodeb(6,1))=co(j,nodel(1)) + & -thickb(1,1)*xnorb(j,1)*offset(1,i) + & -thickb(2,1)*xnorb(j+3,1)*(.5d0+offset(2,i)) + enddo + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dfrom2d.f calculix-ccx-2.3/ccx_2.3/src/gen3dfrom2d.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dfrom2d.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dfrom2d.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,297 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dfrom2d(i,kon,ipkon,lakon,ne,iponor,xnor,knor, + & thicke,offset,ntrans,inotr,trab,ikboun,ilboun,nboun,nboun_, + & nodeboun,ndirboun,xboun,iamboun,typeboun,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,ikmpc,ilmpc,labmpc,nk,nk_,co,rig,nmethod, + & iperturb,ithermal,mi,nam) +! +! expands 2d element i into a 3d element +! +! generates additional MPC's for plane stress, plane strain and +! axisymmetric elements +! + implicit none +! + logical axial,fixed +! + character*1 type,typeboun(*) + character*8 lakon(*) + character*20 labmpc(*) +! + integer kon(*),ipkon(*),ne,iponor(2,*),knor(*),ntrans,inotr(2,*), + & ikboun(*),ilboun(*),nboun,nboun_,nodeboun(*),ndirboun(*), + & iamboun(*),nam,ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree, + & ikmpc(*),ilmpc(*),nk,nk_,i,rig(*),nmethod,iperturb,ishift +! + integer indexe,j,nodel(8),indexx,indexk,k,nedge,nodes(3,8), + & iamplitude,l,newnode,idir,idof,id,m,mpcfreenew,node,ithermal(2), + & jmin,jmax,idummy,mi(2) +! + real*8 xnor(*),thicke(2,*),offset(2,*),trab(7,*),xboun(*), + & coefmpc(*),co(3,*),vdummy(0:4) +! + real*8 thicks(8),xnors(3,8),dc,ds,val,x,y +! + fixed=.false. +! +! check for axial elements +! + if(lakon(i)(1:2).eq.'CA') then + axial=.true. + else + axial=.false. + endif +! + indexe=ipkon(i) +! +! localizing the nodes, thicknesses and normals for the +! 2-D element +! + if((lakon(i)(2:2).eq.'6').or. + & (lakon(i)(4:4).eq.'6')) then + nedge=3 + ishift=15 + else + nedge=4 + ishift=20 + endif +! + do j=1,2*nedge + nodel(j)=kon(indexe+j) + kon(indexe+ishift+j)=nodel(j) + indexk=iponor(2,indexe+j) + thicks(j)=thicke(1,indexe+j) + do k=1,3 + nodes(k,j)=knor(indexk+k) + enddo + enddo +! +! generating the 3-D element topology for shell and plane +! stress/strain elements +! + if(lakon(i)(1:2).ne.'CA') then + do j=1,2*nedge + indexx=iponor(1,indexe+j) + do k=1,3 + xnors(k,j)=xnor(indexx+k) + enddo + if(ntrans.gt.0) then + do k=1,3 + inotr(1,nodes(k,j))=inotr(1,nodel(j)) + enddo + endif + enddo +! + do k=1,nedge + kon(indexe+k)=nodes(1,k) +! + do j=1,3 + co(j,nodes(1,k))=co(j,nodel(k)) + & -thicks(k)*xnors(j,k)*(.5d0+offset(1,i)) + enddo + enddo + do k=1,nedge + kon(indexe+nedge+k)=nodes(3,k) + do j=1,3 + co(j,nodes(3,k))=co(j,nodel(k)) + & +thicks(k)*xnors(j,k)*(.5d0-offset(1,i)) + enddo + enddo + do k=nedge+1,2*nedge + kon(indexe+nedge+k)=nodes(1,k) + do j=1,3 + co(j,nodes(1,k))=co(j,nodel(k)) + & -thicks(k)*xnors(j,k)*(.5d0+offset(1,i)) + enddo + enddo + do k=nedge+1,2*nedge + kon(indexe+2*nedge+k)=nodes(3,k) + do j=1,3 + co(j,nodes(3,k))=co(j,nodel(k)) + & +thicks(k)*xnors(j,k)*(.5d0-offset(1,i)) + enddo + enddo + do k=1,nedge + kon(indexe+4*nedge+k)=nodes(2,k) + do j=1,3 + co(j,nodes(2,k))=co(j,nodel(k)) + & -thicks(k)*xnors(j,k)*offset(1,i) + enddo + enddo + else +! +! generating the 3-D element topology for axisymmetric elements +! + dc=dcos(thicks(1)/2.d0) + ds=dsin(thicks(1)/2.d0) + do j=1,nedge + indexk=iponor(2,indexe+j) + x=co(1,nodel(j)) + y=co(2,nodel(j)) +! + node=knor(indexk+1) + co(1,node)=x*dc + co(2,node)=y + co(3,node)=-x*ds + kon(indexe+j)=node +! + node=knor(indexk+2) + co(1,node)=x + co(2,node)=y + co(3,node)=0.d0 + kon(indexe+4*nedge+j)=node +! + node=knor(indexk+3) + co(1,node)=x*dc + co(2,node)=y + co(3,node)=x*ds + kon(indexe+nedge+j)=node + enddo +! + do j=nedge+1,2*nedge + indexk=iponor(2,indexe+j) + x=co(1,nodel(j)) + y=co(2,nodel(j)) +! + node=knor(indexk+1) + co(1,node)=x*dc + co(2,node)=y + co(3,node)=-x*ds + kon(indexe+nedge+j)=node +! + node=knor(indexk+3) + co(1,node)=x*dc + co(2,node)=y + co(3,node)=x*ds + kon(indexe+2*nedge+j)=node + enddo + endif +! +! additional SPC's due to plane strain/plane stress/axisymmetric +! conditions +! + do j=1,2*nedge + if(lakon(i)(1:1).ne.'S') then +! +! fixing the middle plane +! + if(rig(nodel(j)).gt.0) cycle +! + if(ithermal(2).ne.2) then + val=0.d0 + k=3 + if(nam.gt.0) iamplitude=0 + type='M' + call bounadd(nodes(2,j),k,k,val,nodeboun, + & ndirboun,xboun,nboun,nboun_,iamboun, + & iamplitude,nam,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, + & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_, + & labmpc,type,typeboun,nmethod,iperturb, + & fixed,vdummy,idummy,mi) + endif +! +! specifying that the side planes do the same +! as the middle plane (in all directions for +! plane strain and axisymmetric elements, in the +! plane for plane stress elements) +! + if(ithermal(2).le.1) then + jmin=1 + jmax=3 + elseif(ithermal(2).eq.2) then + jmin=0 + jmax=0 + else + jmin=0 + jmax=3 + endif +! + do l=1,3,2 + newnode=nodes(l,j) + do idir=jmin,jmax + if((idir.eq.3).and.(lakon(i)(1:3).eq.'CPS')) + & cycle + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dfrom2d: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do m=nmpc,id+2,-1 + ikmpc(m)=ikmpc(m-1) + ilmpc(m)=ilmpc(m-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dfrom2d: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=nodes(2,j) + if((lakon(i)(2:2).eq.'A').and.(idir.eq.3)) + & then + nodempc(2,mpcfree)=1 + else + nodempc(2,mpcfree)=idir + endif + if(lakon(i)(2:2).eq.'A') then + if(idir.eq.1) then + coefmpc(mpcfree)=-dc + elseif(idir.eq.3) then + if(l.eq.1) then + coefmpc(mpcfree)=ds + else + coefmpc(mpcfree)=-ds + endif + else + coefmpc(mpcfree)=-1.d0 + endif + else + coefmpc(mpcfree)=-1.d0 + endif + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dfrom2d: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + enddo + enddo + endif + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dmpc.f calculix-ccx-2.3/ccx_2.3/src/gen3dmpc.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dmpc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dmpc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,238 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dmpc(ipompc,nodempc,coefmpc,nmpc,nmpc_,mpcfree, + & ikmpc,ilmpc,labmpc,iponoel,inoel,iponoelmax,kon,ipkon,lakon, + & ne,iponor,xnor,knor,rig) +! +! connects nodes of 1-D and 2-D elements, for which MPC's were +! defined, to the nodes of their expanded counterparts +! + implicit none +! + character*8 lakon(*) + character*20 labmpc(*) +! + integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,ikmpc(*), + & ilmpc(*),iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*), + & ne,iponor(2,*),knor(*),rig(*),i,index1,node,index2,ielem, + & indexe,j,indexk,newnode,idir,idof,id,mpcfreenew,k +! + real*8 coefmpc(*),xnor(*) +! + do i=1,nmpc + index1=ipompc(i) + do + node=nodempc(1,index1) + if(node.le.iponoelmax) then + if(rig(node).ne.0) then +c if(nodempc(2,index1).gt.3) then + if(nodempc(2,index1).gt.4) then + if(rig(node).lt.0) then + write(*,*) '*ERROR in gen3dmpc: in node ',node + write(*,*) ' a rotational DOF is constrained' + write(*,*) ' by a SPC; however, the elements' + write(*,*) ' to which this node belongs do not' + write(*,*) ' have rotational DOFs' + stop + endif + nodempc(1,index1)=rig(node) +c nodempc(2,index1)=nodempc(2,index1)-3 + nodempc(2,index1)=nodempc(2,index1)-4 + endif + else + index2=iponoel(node) +c +c check for nodes not belonging to 1d or 2d elements +c + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) exit + cycle + endif +c + ielem=inoel(1,index2) + indexe=ipkon(ielem) + j=inoel(2,index2) + indexk=iponor(2,indexe+j) +! +! 2d element shell element +! + if(lakon(ielem)(7:7).eq.'L') then + newnode=knor(indexk+1) + idir=nodempc(2,index1) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=knor(indexk+3) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-2.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + elseif(lakon(ielem)(7:7).eq.'B') then +! +! 1d beam element +! + newnode=knor(indexk+1) + idir=nodempc(2,index1) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + do k=2,4 + nodempc(1,mpcfree)=knor(indexk+k) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + enddo + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-4.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + else +! +! 2d plane stress, plane strain or axisymmetric +! element +! + newnode=knor(indexk+2) + idir=nodempc(2,index1) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if(((id.le.0).or.(ikmpc(id).ne.idof)).and. + & (idir.ne.3)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-1.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + endif + endif + endif + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dnor.f calculix-ccx-2.3/ccx_2.3/src/gen3dnor.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dnor.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dnor.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,897 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dnor(nk,nk_,co,iponoel,inoel,iponoelmax,kon,ipkon, + & lakon,ne,thicke,offset,iponor,xnor,knor,rig,iperturb,tinc, + & tper,tmin,tmax,ctrl,ipompc,nodempc,coefmpc,nmpc,nmpc_,mpcfree, + & ikmpc,ilmpc,labmpc,ikboun,ilboun,nboun,nboun_,nodeboun,ndirboun, + & xboun,iamboun,typeboun,nam,ntrans,inotr,trab,ikfree,ixfree, + & nmethod,ithermal,istep,mi) +! +! calculates normals on 1-D and 2-D elements +! + implicit none +! + logical fixed +! + character*1 type,typeboun(*) + character*8 lakon(*) + character*20 labmpc(*) +! + integer nk,nk_,iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*), + & ne,iponor(2,*),knor(*),rig(*),iperturb,ipompc(*),nodempc(3,*), + & nmpc,nmpc_,mpcfree,ikmpc(*),ilmpc(*),ikboun(*),ilboun(*),nboun, + & nboun_,nodeboun(*),ndirboun(*),iamboun(*),nam,ntrans,inotr(2,*), + & isol,istep,idummy,mi(2) +! + integer i,ndepnodes,index,nexp,nnor,nel,ielem,indexe,j,iel(100), + & jl(100),ial(100),ifi(100),idepnodes(80),indexx,k,l,ifix,nemin, + & jact,ixfree,ikfree,node,nelshell,irefnode,idof,id,mpcfreeold, + & irotnode,imax,iamplitude,nmethod,ithermal(2),iexpnode +! + real*8 co(3,*),thicke(2,*),offset(2,*),xnor(*),tinc,tper,tmin, + & tmax,ctrl(*),coefmpc(*),xboun(*),trab(7,*),vdummy(0:4) +! + real*8 xno(3,100),xta(3,100),xn1(3,100),thl1(100),thl2(100), + & off1(100),off2(100),xi,et,coloc6(2,6),coloc8(2,8),xl(3,8), + & dd,xnoref(3),dot,coloc3(3),dot1,dot2,dmax,val +! + data coloc3 /-1.d0,0.d0,1.d0/ + data coloc6 /0.d0,0.d0,1.d0,0.d0,0.d0,1.d0,0.5d0,0.d0, + & 0.5d0,0.5d0,0.d0,0.5d0/ + data coloc8 /-1.d0,-1.d0,1.d0,-1.d0,1.d0,1.d0,-1.d0,1.d0, + & 0.d0,-1.d0,1.d0,0.d0,0.d0,1.d0,-1.d0,0.d0/ +! + fixed=.false. +! +! calculating the normals in nodes belonging to shells/beams +! + do i=1,nk + ndepnodes=0 + index=iponoel(i) + if(index.eq.0) cycle +! +! nexp indicates how many times the node was expanded +! + nexp=0 +! +! nnor indicates whether the expanded nodes lie on a point +! (nnor=0, only for plane stress, plane strain or axisymmetric +! elements), on a line (nnor=1) or in a plane (nnor=2) +! + nnor=0 +! +! locating the shell elements to which node i belongs +! + nel=0 + do + if(index.eq.0) exit + ielem=inoel(1,index) + if(lakon(ielem)(1:1).ne.'B') then + if(lakon(ielem)(1:1).eq.'S') nnor=1 + indexe=ipkon(ielem) + nel=nel+1 + if(nel.gt.100) then + write(*,*) '*ERROR in gen3dnor: more than 100' + write(*,*) ' shell elements share the' + write(*,*) ' same node' + stop + endif + j=inoel(2,index) + jl(nel)=j + iel(nel)=ielem + thl1(nel)=thicke(1,indexe+j) + off1(nel)=offset(1,ielem) + endif + index=inoel(3,index) + enddo +! + if(nel.gt.0) then + do j=1,nel + ial(j)=0 + enddo +! +! estimate the normal +! + do j=1,nel + indexe=ipkon(iel(j)) + indexx=iponor(1,indexe+jl(j)) + if(indexx.ge.0) then + do k=1,3 + xno(k,j)=xnor(indexx+k) + enddo + ifi(j)=1 + cycle + else + ifi(j)=0 + endif + if((lakon(iel(j))(2:2).eq.'6').or. + & (lakon(iel(j))(4:4).eq.'6')) then + xi=coloc6(1,jl(j)) + et=coloc6(2,jl(j)) + do k=1,6 + node=kon(indexe+k) + do l=1,3 + xl(l,k)=co(l,node) + enddo + enddo + call norshell6(xi,et,xl,xno(1,j)) + else + xi=coloc8(1,jl(j)) + et=coloc8(2,jl(j)) + do k=1,8 + node=kon(indexe+k) + do l=1,3 + xl(l,k)=co(l,node) + enddo + enddo + call norshell8(xi,et,xl,xno(1,j)) + endif + dd=dsqrt(xno(1,j)**2+xno(2,j)**2+xno(3,j)**2) + if(dd.lt.1.d-10) then + write(*,*) '*ERROR in gen3dnor: size of estimated' + write(*,*) ' shell normal in node ',i, + & ' element ',iel(j) + write(*,*) ' is smaller than 1.e-10' + stop + endif + do k=1,3 + xno(k,j)=xno(k,j)/dd + enddo + enddo +! + do +! +! determining a fixed normal which was not treated yet, +! or, if none is left, the minimum element number of all +! elements containing node i and for which no normal was +! determined yet +! +! if ial(j)=0: the normal on this element has not been +! treated yet +! if ial(j)=2: normal has been treated +! + ifix=0 + nemin=ne+1 + do j=1,nel + if(ial(j).ne.0) cycle + if(ifi(j).eq.1) then + jact=j + ifix=1 + exit + endif + enddo + if(ifix.eq.0) then + do j=1,nel + if(ial(j).eq.0) then + if(iel(j).lt.nemin) then + nemin=iel(j) + jact=j + endif + endif + enddo + if(nemin.eq.ne+1) exit + endif +! + do j=1,3 + xnoref(j)=xno(j,jact) + enddo +! +! determining all elements whose normal in node i makes an +! angle smaller than 0.5 or 20 degrees with the reference normal, +! depending whether the reference normal was given by the +! user or is being calculated; the thickness and offset must +! also fit. +! +! if ial(j)=1: normal on element is being treated now +! + do j=1,nel + if(ial(j).eq.2) cycle + if(j.eq.jact) then + ial(jact)=1 + else + dot=xno(1,j)*xnoref(1)+xno(2,j)*xnoref(2)+ + & xno(3,j)*xnoref(3) + if(ifix.eq.0) then + if(dot.gt.0.939693d0)then + if((dabs(thl1(j)-thl1(jact)).lt.1.d-10) + & .and. + & (dabs(off1(j)-off1(jact)).lt.1.d-10) + & .and. + & ((lakon(iel(j))(1:3).eq.lakon(iel(jact))(1:3)) + & .or. + & ((lakon(iel(j))(1:1).eq.'S').and. + & (lakon(iel(jact))(1:1).eq.'S')))) + & ial(j)=1 +c + if(dot.lt.0.999962) nnor=2 +c + else + if((lakon(iel(j))(1:1).eq.'S').and. + & (lakon(iel(jact))(1:1).eq.'S')) then +! +! if the normals have the opposite +! direction, the expanded nodes are on a +! straight line +! + if(dot.gt.-0.999962) then + nnor=2 + else + write(*,*) '*INFO in gen3dnor: in some + & nodes opposite normals are defined' + endif + endif + endif + else + if(dot.gt.0.999962d0) then + if((dabs(thl1(j)-thl1(jact)).lt.1.d-10) + & .and. + & (dabs(off1(j)-off1(jact)).lt.1.d-10) + & .and. + & ((lakon(iel(j))(1:3).eq.lakon(iel(jact))(1:3)) + & .or. + & ((lakon(iel(j))(1:1).eq.'S').and. + & (lakon(iel(jact))(1:1).eq.'S')))) + & ial(j)=1 +c + if(dot.lt.0.999962) nnor=2 +c + else + if((lakon(iel(j))(1:1).eq.'S').and. + & (lakon(iel(jact))(1:1).eq.'S')) then +! +! if the normals have the opposite +! direction, the expanded nodes are on a +! straight line +! + if(dot.gt.-0.999962) then + nnor=2 + else + write(*,*) '*INFO in gen3dnor: in some + & nodes opposite normals are defined' + endif + endif + endif + endif + endif + enddo +! +! determining the mean normal for the selected elements +! + if(ifix.eq.0) then + do j=1,3 + xnoref(j)=0.d0 + enddo + do j=1,nel + if(ial(j).eq.1) then + do k=1,3 + xnoref(k)=xnoref(k)+xno(k,j) + enddo + endif + enddo + dd=dsqrt(xnoref(1)**2+xnoref(2)**2+xnoref(3)**2) + if(dd.lt.1.d-10) then + write(*,*) '*ERROR in gen3dnor: size of' + write(*,*) ' estimated shell normal is' + write(*,*) ' smaller than 1.e-10' + stop + endif + do j=1,3 + xnoref(j)=xnoref(j)/dd + enddo + endif +! +! updating the pointers iponor +! + nexp=nexp+1 + do j=1,nel + if(ial(j).eq.1) then + ial(j)=2 + if(ifix.eq.0) then + iponor(1,ipkon(iel(j))+jl(j))=ixfree + elseif(j.ne.jact) then + iponor(1,ipkon(iel(j))+jl(j))= + & iponor(1,ipkon(iel(jact))+jl(jact)) + endif + iponor(2,ipkon(iel(j))+jl(j))=ikfree + endif + enddo +! +! storing the normal in xnor and generating 3 nodes +! for knor +! + if(ifix.eq.0) then + do j=1,3 + xnor(ixfree+j)=xnoref(j) + enddo + ixfree=ixfree+3 + endif +! + do k=1,3 + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in nodes: increase nk_' + stop + endif + knor(ikfree+k)=nk +! +! for plane stress, plane strain and axisymmetric +! elements only the middle node is included in the +! rigid body definition +! + if((lakon(iel(jact))(2:2).ne.'P').and. + & (lakon(iel(jact))(2:2).ne.'A')) then + idepnodes(ndepnodes+1)=nk + ndepnodes=ndepnodes+1 + elseif(k.eq.2) then +c if(jl(jact).le.4) then +c write(*,*) 'depnode ',nk + idepnodes(ndepnodes+1)=nk + ndepnodes=ndepnodes+1 +c endif + endif + enddo + ikfree=ikfree+3 + enddo + endif +! + nelshell=nel+1 +! +! locating the beam elements to which node i belongs +! + index=iponoel(i) + do + if(index.eq.0) exit + ielem=inoel(1,index) + if(lakon(ielem)(1:1).eq.'B') then + indexe=ipkon(ielem) + nel=nel+1 + if(nel.gt.100) then + write(*,*) '*ERROR in gen3dnor: more than 100' + write(*,*) ' beam/shell elements share' + write(*,*) ' the same node' + stop + endif + j=inoel(2,index) + jl(nel)=j + iel(nel)=ielem + thl1(nel)=thicke(1,indexe+j) + thl2(nel)=thicke(2,indexe+j) + off1(nel)=offset(1,ielem) + off2(nel)=offset(2,ielem) + endif + index=inoel(3,index) + enddo +! + if(nel.ge.nelshell) then + nnor=2 + do j=nelshell,nel + ial(j)=0 + enddo +! +! estimate the normal +! + do j=nelshell,nel + xi=coloc3(jl(j)) + indexe=ipkon(iel(j)) + do k=1,3 + node=kon(indexe+k) + do l=1,3 + xl(l,k)=co(l,node) + enddo + enddo +! +! determining the tangent vector xta +! + do k=1,3 + xta(k,j)=(xi-0.5d0)*xl(k,1)-2.d0*xi*xl(k,2)+ + & (xi+0.5d0)*xl(k,3) + enddo + dd=dsqrt(xta(1,j)**2+xta(2,j)**2+xta(3,j)**2) + if(dd.lt.1.d-10) then + write(*,*) '*ERROR in gen3dnor: size of estimated' + write(*,*)' beam tangent in node ',i,' element ' + &,iel(j) + write(*,*) ' is smaller than 1.e-10' + stop + endif + do k=1,3 + xta(k,j)=xta(k,j)/dd + enddo +! +! check whether normal was defined with *NORMAL and +! determine vector n1 +! + if(iponor(1,indexe+jl(j)).ge.0) then + indexx=iponor(1,indexe+jl(j)) + if(dabs(xnor(indexx+4)**2+xnor(indexx+5)**2+ + & xnor(indexx+6)**2-1.d0).lt.1.d-5) then + do k=1,3 + xno(k,j)=xnor(indexx+3+k) + enddo + ifi(j)=1 + cycle + endif + ifi(j)=0 + do k=1,3 + xn1(k,j)=xnor(indexx+k) + enddo + else + ifi(j)=0 + xn1(1,j)=0.d0 + xn1(2,j)=0.d0 + xn1(3,j)=-1.d0 + endif +! +! normal (=n2) = xta x xn1 +! + xno(1,j)=xta(2,j)*xn1(3,j)-xta(3,j)*xn1(2,j) + xno(2,j)=xta(3,j)*xn1(1,j)-xta(1,j)*xn1(3,j) + xno(3,j)=xta(1,j)*xn1(2,j)-xta(2,j)*xn1(1,j) + dd=dsqrt(xno(1,j)**2+xno(2,j)**2+xno(3,j)**2) + if(dd.lt.1.d-10) then + write(*,*) '*ERROR in gen3dnor: size of estimated' + write(*,*)' beam normal in 2-direction in node ' + &,i,' element ',iel(j) + write(*,*) ' is smaller than 1.e-10' + stop + endif + do k=1,3 + xno(k,j)=xno(k,j)/dd + enddo + enddo +! + do +! +! determining a fixed normal which was not treated yet, +! or, if none is left, the minimum element number of all +! elements containing node i and for which no normal was +! determined yet +! + ifix=0 + nemin=ne+1 + do j=nelshell,nel + if(ial(j).ne.0) cycle + if(ifi(j).eq.1) then + jact=j + ifix=1 + exit + endif + enddo + if(ifix.eq.0) then + do j=nelshell,nel + if(ial(j).eq.0) then + if(iel(j).lt.nemin) then + nemin=iel(j) + jact=j + endif + endif + enddo + if(nemin.eq.ne+1) exit + endif +! +! the reference normal is the one on the element with the +! smallest element number +! + do j=1,3 + xnoref(j)=xno(j,jact) + enddo +! +! determining all elements whose normal in node i makes an +! angle smaller than 0.5 or 20 degrees with the reference normal, +! depending whether the reference normal was given by the +! user or is being calculated; the thickness and offset must +! also fit. +! + do j=nelshell,nel + if(j.eq.jact) then + ial(jact)=1 + else + dot1=xno(1,j)*xnoref(1)+xno(2,j)*xnoref(2)+ + & xno(3,j)*xnoref(3) + dot2=xta(1,j)*xta(1,jact)+xta(2,j)*xta(2,jact)+ + & xta(3,j)*xta(3,jact) + if(ifix.eq.0) then + if((dot1.gt.0.939693d0).and. + & (dot2.gt.0.939693d0)) then + if((dabs(thl1(j)-thl1(jact)).lt.1.d-10) + & .and. + & (dabs(thl2(j)-thl2(jact)).lt.1.d-10) + & .and. + & (dabs(off1(j)-off1(jact)).lt.1.d-10) + & .and. + & (dabs(off2(j)-off2(jact)).lt.1.d-10) + & .and. + & (lakon(iel(j))(8:8).eq.lakon(iel(jact))(8:8))) + & ial(j)=1 + endif + else + if((dot1.gt.0.999962d0).and. + & (dot2.gt.0.999962d0)) then + if((dabs(thl1(j)-thl1(jact)).lt.1.d-10) + & .and. + & (dabs(thl2(j)-thl2(jact)).lt.1.d-10) + & .and. + & (dabs(off1(j)-off1(jact)).lt.1.d-10) + & .and. + & (dabs(off2(j)-off2(jact)).lt.1.d-10) + & .and. + & (lakon(iel(j))(8:8).eq.lakon(iel(jact))(8:8))) + & ial(j)=1 + endif + endif + endif + enddo +! +! determining the mean normal for the selected elements +! + if(ifix.eq.0) then + do j=1,3 + xnoref(j)=0.d0 + enddo + do j=nelshell,nel + if(ial(j).eq.1) then + do k=1,3 + xnoref(k)=xnoref(k)+xno(k,j) + enddo + endif + enddo + endif +! +! calculating the mean tangent +! + do j=nelshell,nel + if((ial(j).eq.1).and.(j.ne.jact)) then + do k=1,3 + xta(k,jact)=xta(k,jact)+xta(k,j) + enddo + endif + enddo + dd=dsqrt(xta(1,jact)**2+xta(2,jact)**2+xta(3,jact)**2) + if(dd.lt.1.d-10) then + write(*,*) '*ERROR in gen3dnor: size of mean' + write(*,*)' beam tangent is smaller than 1.e-10' + stop + endif + do k=1,3 + xta(k,jact)=xta(k,jact)/dd + enddo +! +! taking care that the mean normal is orthogonal towards +! the mean tangent +! + dd=xnoref(1)*xta(1,jact)+xnoref(2)*xta(2,jact)+ + & xnoref(3)*xta(3,jact) + do j=1,3 + xnoref(j)=xnoref(j)-dd*xta(j,jact) + enddo + dd=dsqrt(xnoref(1)**2+xnoref(2)**2+xnoref(3)**2) + if(dd.lt.1.d-10) then + write(*,*) '*ERROR in gen3dnor: size of' + write(*,*) ' estimated beam normal is' + write(*,*) ' smaller than 1.e-10' + stop + endif + do j=1,3 + xnoref(j)=xnoref(j)/dd + enddo +! +! calculating xn1 = xn2 x tangent +! + xn1(1,jact)=xnoref(2)*xta(3,jact)-xnoref(3)*xta(2,jact) + xn1(2,jact)=xnoref(3)*xta(1,jact)-xnoref(1)*xta(3,jact) + xn1(3,jact)=xnoref(1)*xta(2,jact)-xnoref(2)*xta(1,jact) +! +! storing the normals in xnor and generating 8 nodes +! for knor +! + nexp=nexp+1 + do j=nelshell,nel + if(ial(j).eq.1) then + ial(j)=2 + if(ifix.eq.0) then + iponor(1,ipkon(iel(j))+jl(j))=ixfree + else + iponor(1,ipkon(iel(j))+jl(j))= + & iponor(1,ipkon(iel(jact))+jl(jact)) + endif + iponor(2,ipkon(iel(j))+jl(j))=ikfree + endif + enddo +! + do j=1,3 + xnor(ixfree+j)=xn1(j,jact) + enddo + do j=1,3 + xnor(ixfree+3+j)=xnoref(j) + enddo + ixfree=ixfree+6 + do k=1,8 + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in nodes: increase nk_' + stop + endif + knor(ikfree+k)=nk + idepnodes(ndepnodes+k)=nk + enddo + ikfree=ikfree+8 + ndepnodes=ndepnodes+8 + enddo + endif +! +! check whether the user has specified rotational degrees +! of freedom (in that case rig(i)=-1 was assigned in +! subroutine gen3delem); if so, a rigid MPC must be defined +! + if(rig(i).ne.0) then + rig(i)=0 + if(nexp.le.1) then + nexp=2 + endif + endif +! +! storing the expanded nodes +! +c write(*,*) i,(idepnodes(k),k=1,ndepnodes) +! +! generate rigid MPC's if necessary +! + if(nexp.gt.1) then +cc write(*,*) i,'= KNOT !' +cc if(iperturb.eq.0) then +c if((iperturb.eq.0).and.(nmethod.eq.1)) then +c iperturb=2 +c tinc=1.d0 +c tper=1.d0 +c tmin=1.d-5 +c tmax=1.d+30 +c elseif(iperturb.eq.1) then +c write(*,*) '*ERROR in gen3dnor: the expansion of' +c write(*,*) ' 1D/2D elements has led to the' +c write(*,*) ' creation of rigid body MPCs.' +c write(*,*) ' This is not allowed in a' +c write(*,*) ' perturbation analysis. Please' +c write(*,*) ' generate a truely 3D structure' +c stop +c endif + irefnode=i +! + rig(i)=-1 +! + if(ithermal(2).ne.2) then + if(nnor.eq.0) then +! +! the node belongs to plane stress, plane strain +! or axisymmetric elements only. These are only linked +! through the node in the midplane: the nodes +! coincide; only DOF1 and DOF2 are linked. +! rig(i)=-1 to indicate that a knot has +! been generated without rotational node +! +c rig(i)=-1 +c changed for purely thermal calculations +! + do k=1,ndepnodes + node=idepnodes(k) + do j=1,2 + idof=8*(node-1)+j + call nident(ikmpc,idof,nmpc,id) + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in rigidmpc: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)=' ' +! + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node +c write(*,*) 'dependent node: ',node + nodempc(2,mpcfree)=j + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=irefnode + nodempc(2,mpcfree)=j + coefmpc(mpcfree)=-1.d0 + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + enddo + enddo + else +! +! generate a rigid body knot; rig(i) contains the +! rotational node of the knot +! + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in rigidbodies: increase nk_' + stop + endif + irotnode=nk + rig(i)=irotnode + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in rigidbodies: increase nk_' + stop + endif + iexpnode=nk + do k=1,ndepnodes + call knotmpc(ipompc,nodempc,coefmpc,irefnode, + & irotnode,iexpnode, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_, + & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_, + & idepnodes(k),typeboun,co,xboun,istep) + enddo + endif + endif +! +! MPC's for the temperature DOFs +! + if(ithermal(2).ge.2) then + do k=1,ndepnodes + node=idepnodes(k) + idof=8*(node-1) + call nident(ikmpc,idof,nmpc,id) + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dnor: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)=' ' +! + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=0 + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=irefnode + nodempc(2,mpcfree)=0 + coefmpc(mpcfree)=-1.d0 + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + enddo + endif +! + if((nnor.eq.1).and.(ithermal(2).ne.2)) then +! +! generate an additional SPC or MPC for rigid body nodes +! lying on a line to prevent rotation about the +! line +! + dmax=0.d0 + imax=0 + do j=1,3 + if(dabs(xnoref(j)).gt.dmax) then + dmax=dabs(xnoref(j)) + imax=j + endif + enddo +! +! check whether a SPC suffices +! + if(dabs(1.d0-dmax).lt.1.d-3) then + val=0.d0 + if(nam.gt.0) iamplitude=0 + type='R' + call bounadd(irotnode,imax,imax,val,nodeboun, + & ndirboun,xboun,nboun,nboun_,iamboun, + & iamplitude,nam,ipompc,nodempc,coefmpc, + & nmpc,nmpc_,mpcfree,inotr,trab,ntrans, + & ikboun,ilboun,ikmpc,ilmpc,co,nk,nk_,labmpc, + & type,typeboun,nmethod,iperturb,fixed,vdummy, + & idummy,mi) + else +! +! check whether the rotational degree of freedom +! imax is fixed through a SPC +! + isol=0 + do l=1,3 +c idof=8*(i-1)+3+imax + idof=8*(i-1)+4+imax + call nident(ikboun,idof,nboun,id) + if(((id.gt.0).and.(ikboun(id).eq.idof)).or. + & (dabs(xnoref(imax)).lt.1.d-10)) then + imax=imax+1 + if(imax.gt.3) imax=imax-3 + cycle + endif + isol=1 + exit + enddo +! +! if one of the rotational dofs was not used so far, +! it can be taken as dependent side for fixing the +! rotation about the normal. If all dofs were used, +! no additional equation is needed. +! + if(isol.eq.1) then + idof=8*(irotnode-1)+imax + call nident(ikmpc,idof,nmpc,id) + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dnor: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)=' ' +! + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=imax + coefmpc(mpcfree)=xnoref(imax) + mpcfree=nodempc(3,mpcfree) + imax=imax+1 + if(imax.gt.3) imax=imax-3 + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=imax + coefmpc(mpcfree)=xnoref(imax) + mpcfree=nodempc(3,mpcfree) + imax=imax+1 + if(imax.gt.3) imax=imax-3 + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=imax + coefmpc(mpcfree)=xnoref(imax) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + endif + endif + endif + endif + enddo +! +c do i=1,nmpc +c call writempc(ipompc,nodempc,coefmpc,labmpc,i) +c enddo +c do i=1,nboun +c write(*,*) nodeboun(i),ndirboun(i),xboun(i) +c enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dprop.f calculix-ccx-2.3/ccx_2.3/src/gen3dprop.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dprop.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dprop.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,218 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dprop(prop,ielprop,iponoel,inoel,iponoelmax,kon, + & ipkon,lakon,ne,iponor,xnor,knor,ipompc,nodempc,coefmpc,nmpc, + & nmpc_,mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk, + & nk_,co,nmethod,iperturb) +! +! connects nodes of 1-D and 2-D elements which are used in fluid +! property definitions to the nodes of their expanded counterparts +! + implicit none +! + character*8 lakon(*) + character*20 labmpc(*) +! + integer iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*),ne, + & iponor(2,*),knor(*),ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree, + & ikmpc(*),ilmpc(*),rig(*),ntrans,inotr(2,*),i,node,ielprop(*), + & index,ielem,j,indexe,indexk,idir,nk,nk_, + & newnode,idof,id,mpcfreenew,k,nam,nmethod,iperturb,ii +! + real*8 xnor(*),coefmpc(*),trab(7,*),co(3,*),prop(*) +! + do i=1,ne +C if((lakon(i).ne.'DLIPIMAF').and.(lakon(i).ne.'DLIPIWCF')) cycle + if((lakon(i).ne.'DLIPIMAF').and.(lakon(i).ne.'DLIPIWCF') + & .and.(lakon(i)(1:5).ne.'DLABF') + & .and.(lakon(i)(1:6).ne.'DGAPFF') + & .and.(lakon(i)(1:5).ne.'DORFL') + & .and.(lakon(i)(1:6).ne.'DGAPIF')) cycle + do ii=1,6 + node=int(prop(ielprop(i)+int((ii+2.5d0)/3.d0))) + if(node.gt.iponoelmax) cycle + index=iponoel(node) + if(index.eq.0) cycle + ielem=inoel(1,index) + j=inoel(2,index) + indexe=ipkon(ielem) + indexk=iponor(2,indexe+j) + idir=ii-3*(int((ii+2.5d0)/3.d0)-1) +c write(*,*) 'gen3dprop,node,idir',node,idir +! + if(rig(node).ne.0) cycle +! +! 2d element shell element: generate MPC's +! + if(lakon(ielem)(7:7).eq.'L') then + newnode=knor(indexk+1) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dprop: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dprop: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=knor(indexk+3) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dprop: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-2.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dprop: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + elseif(lakon(ielem)(7:7).eq.'B') then +! +! 1d beam element: generate MPC's +! + newnode=knor(indexk+1) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dprop: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dprop: increase nmpc_' + stop + endif + do k=2,4 + nodempc(1,mpcfree)=knor(indexk+k) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dprop: increase nmpc_' + stop + endif + enddo + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-4.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dprop: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + else +! +! 2d plane stress, plane strain or axisymmetric +! element: SPC +! + newnode=knor(indexk+2) + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if(((id.le.0).or.(ikmpc(id).ne.idof)).and. + & (idir.ne.3)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-1.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dmpc: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + endif + enddo + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dsurf.f calculix-ccx-2.3/ccx_2.3/src/gen3dsurf.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dsurf.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dsurf.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,192 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dsurf(iponoel,inoel,iponoelmax,kon,ipkon, + & lakon,ne,iponor,knor,ipompc,nodempc,coefmpc,nmpc,nmpc_, + & mpcfree,ikmpc,ilmpc,labmpc,rig,ntrans,inotr,trab,nam,nk,nk_,co, + & nmethod,iperturb,nset,set,istartset,iendset,ialset) +! +! connects nodes of 1-D and 2-D elements, for which SPC's were +! defined, to the nodes of their expanded counterparts +! + implicit none +! + character*8 lakon(*) + character*20 labmpc(*) + character*81 set(*) +! + integer iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*),ne, + & iponor(2,*),knor(*),ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree, + & ikmpc(*),ilmpc(*),rig(*),ntrans,inotr(2,*),i,node, + & indexx,ielem,j,indexe,indexk,idir,nk,nk_, + & newnode,idof,id,mpcfreenew,k,nam,nmethod,iperturb,istartset(*), + & iendset(*),ialset(*),nset,ipos,l +! + real*8 coefmpc(*),trab(7,*),co(3,*) +! + do i=1,nset + ipos=index(set(i),' ') + if(set(i)(ipos-1:ipos-1).ne.'S') cycle + do l=istartset(i),iendset(i) + node=ialset(l) + if(node.gt.iponoelmax) cycle + indexx=iponoel(node) + if(indexx.eq.0) cycle + ielem=inoel(1,indexx) + j=inoel(2,indexx) + indexe=ipkon(ielem) + indexk=iponor(2,indexe+j) +! + if(rig(node).eq.0) then +! +! 2d element shell element: generate MPC's +! + if(lakon(ielem)(7:7).eq.'L') then + newnode=knor(indexk+1) + do idir=1,3 + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=knor(indexk+3) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-2.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif + enddo + elseif(lakon(ielem)(7:7).eq.'B') then +! +! 1d beam element: generate MPC's +! + newnode=knor(indexk+1) + do idir=1,3 + idof=8*(newnode-1)+idir + call nident(ikmpc,idof,nmpc,id) + if((id.le.0).or.(ikmpc(id).ne.idof)) then + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + nodempc(1,mpcfree)=newnode + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + do k=2,4 + nodempc(1,mpcfree)=knor(indexk+k) + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + enddo + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-4.d0 + mpcfreenew=nodempc(3,mpcfree) + if(mpcfreenew.eq.0) then + write(*,*) + & '*ERROR in gen3dboun: increase nmpc_' + stop + endif + nodempc(3,mpcfree)=0 + mpcfree=mpcfreenew + endif +! + enddo + else +! +! 2d plane stress, plane strain or axisymmetric +! element: dependent node is replaced by new node in the middle +! +! keeping the old node and generating an additional MPC leads +! to problems since the old node is not restricted in the +! z-direction, only the new node in the middle is. If the old +! node is used subsequently in a contact spring element all +! its DOFs are used and the unrestricted z-DOF leads to a +! singular equation system +! +c write(*,*) ialset(l),' replaced by ',knor(indexk+2) + co(1,knor(indexk+2))=co(1,ialset(l)) + co(2,knor(indexk+2))=co(2,ialset(l)) + co(3,knor(indexk+2))=co(3,ialset(l)) + ialset(l)=knor(indexk+2) + endif + endif + enddo + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gen3dtemp.f calculix-ccx-2.3/ccx_2.3/src/gen3dtemp.f --- calculix-ccx-2.1/ccx_2.3/src/gen3dtemp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gen3dtemp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,182 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gen3dtemp(iponoel,inoel,iponoelmax,kon,ipkon,lakon,ne, + & iponor,xnor,knor,t0,t1,thicke,offset,rig,nk,nk_,co,istep, + & ithermal,vold,mi) +! +! maps the temperatures and temperature gradients in 1-D and 2-D +! elements on their expanded counterparts +! + implicit none +! + character*8 lakon(*) +! + integer iponoel(*),inoel(3,*),iponoelmax,kon(*),ipkon(*),ne, + & iponor(2,*),knor(*),rig(*),i,i1,nk,nk_,i2,index,ielem,j, + & indexe,indexk,k,node,istep,ithermal,mi(2) +! + real*8 xnor(*),t0(*),t1(*),thicke(2,*),offset(2,*),co(3,*), + & vold(0:mi(2),*) +! +! initial conditions +! + if(istep.eq.1) then + do i=1,iponoelmax + i1=i+nk_ + i2=i+2*nk_ + index=iponoel(i) + do + if(index.eq.0) exit + ielem=inoel(1,index) + j=inoel(2,index) + indexe=ipkon(ielem) + indexk=iponor(2,indexe+j) + if((lakon(ielem)(7:7).eq.'E').or. + & (lakon(ielem)(7:7).eq.'A').or. + & (lakon(ielem)(7:7).eq.'S')) then + do k=1,3 + node=knor(indexk+k) + t0(node)=t0(i) + if(ithermal.gt.1) vold(0,node)=t0(node) + enddo + elseif(lakon(ielem)(7:7).eq.'L') then + node=knor(indexk+1) + t0(node)=t0(i) + & -t0(i1)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + node=knor(indexk+2) + t0(node)=t0(i) + if(ithermal.gt.1) vold(0,node)=t0(node) + node=knor(indexk+3) + t0(node)=t0(i) + & +t0(i1)*thicke(1,indexe+j)*(0.5d0-offset(1,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + elseif(lakon(ielem)(7:7).eq.'B') then + node=knor(indexk+1) + t0(node)=t0(i) + & -t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + & +t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + node=knor(indexk+2) + t0(node)=t0(i) + & -t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + & -t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + node=knor(indexk+3) + t0(node)=t0(i) + & +t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + & -t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + node=knor(indexk+4) + t0(node)=t0(i) + & +t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + & +t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + node=knor(indexk+5) + t0(node)=t0(i) + & -t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + node=knor(indexk+6) + t0(node)=t0(i) + & -t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + node=knor(indexk+7) + t0(node)=t0(i) + & +t0(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + node=knor(indexk+8) + t0(node)=t0(i) + & +t0(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + if(ithermal.gt.1) vold(0,node)=t0(node) + endif + if(rig(i).eq.0) exit + index=inoel(3,index) + enddo + enddo + endif +! +! temperature loading for mechanical calculations +! + if(ithermal.eq.1) then + do i=1,iponoelmax + i1=i+nk_ + i2=i+2*nk_ + index=iponoel(i) + do + if(index.eq.0) exit + ielem=inoel(1,index) + j=inoel(2,index) + indexe=ipkon(ielem) + indexk=iponor(2,indexe+j) + if((lakon(ielem)(7:7).eq.'E').or. + & (lakon(ielem)(7:7).eq.'A').or. + & (lakon(ielem)(7:7).eq.'S')) then + do k=1,3 + node=knor(indexk+k) + t1(node)=t1(i) + enddo + elseif(lakon(ielem)(7:7).eq.'L') then + node=knor(indexk+1) + t1(node)=t1(i) + & -t1(i1)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + node=knor(indexk+2) + t1(node)=t1(i) + node=knor(indexk+3) + t1(node)=t1(i) + & +t1(i1)*thicke(1,indexe+j)*(0.5d0-offset(1,ielem)) + elseif(lakon(ielem)(7:7).eq.'B') then + node=knor(indexk+1) + t1(node)=t1(i) + & -t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + & +t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + node=knor(indexk+2) + t1(node)=t1(i) + & -t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + & -t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + node=knor(indexk+3) + t1(node)=t1(i) + & +t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + & -t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + node=knor(indexk+4) + t1(node)=t1(i) + & +t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + & +t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + node=knor(indexk+5) + t1(node)=t1(i) + & -t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + node=knor(indexk+6) + t1(node)=t1(i) + & -t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + node=knor(indexk+7) + t1(node)=t1(i) + & +t1(i2)*thicke(1,indexe+j)*(0.5d0+offset(1,ielem)) + node=knor(indexk+8) + t1(node)=t1(i) + & +t1(i1)*thicke(2,indexe+j)*(0.5d0+offset(2,ielem)) + endif + if(rig(i).eq.0) exit + index=inoel(3,index) + enddo + enddo + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gencontelem.f calculix-ccx-2.3/ccx_2.3/src/gencontelem.f --- calculix-ccx-2.1/ccx_2.3/src/gencontelem.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gencontelem.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,561 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gencontelem(tieset,ntie,itietri,ne,ipkon,kon, + & lakon,cg,straight,ifree, + & koncont,co,vold,xo,yo,zo,x,y,z,nx,ny,nz,ielmat,cs, + & elcon,istep,iinc,iit,ncmat_,ntmat_,ne0, + & vini,nmethod,mi,imastop,nslavnode,islavnode,islavsurf, + & itiefac,areaslav,iponoels,inoels,springarea,ikmpc, + & ilmpc,nmpc,ipompc,nodempc,coefmpc,set,nset,istartset, + & iendset,ialset,tietol,reltime) +! +! generate contact elements for the slave contact nodes +! + implicit none +! + character*8 lakon(*) +c character*18 cfile + character*81 tieset(3,*),slavset,set(*),noset +! + integer ntie,ifree, + & itietri(2,ntie),ipkon(*),kon(*),koncont(4,*),ne,node, + & neigh(1),iflag,kneigh,i,j,k,l,isol,iset,idummy, + & itri,ll,kflag,n,nx(*),ny(*),istep,iinc, + & nz(*),nstart,ielmat(*),material,ifaceq(8,6),ifacet(6,4), + & ifacew1(4,5),ifacew2(8,5),nelem,jface,indexe,iit, + & nnodelem,nface,nope,nodef(8),ncmat_,ntmat_,index1, + & ne0,nmethod,mi(2),iteller,ifaces,jfaces, + & imastop(3,*), itriangle(100),ntriangle,ntriangle_,itriold, + & itrinew,id,nslavnode(*),islavnode(*),islavsurf(2,*), + & itiefac(2,*),iponoels(*),inoels(3,*),konl(20),nelems,m, + & mint2d,nopes,idof,index2,ikmpc(*),ilmpc(*),nmpc, + & nodempc(3,*),ipompc(*),ipos,nset,istartset(*),iendset(*), + & ialset(*) +! + real*8 cg(3,*),straight(16,*),co(3,*),vold(0:mi(2),*),p(3), + & dist,xo(*),yo(*),zo(*),x(*),y(*),z(*),cs(17,*), + & beta,c0,elcon(0:ncmat_,ntmat_,*),vini(0:mi(2),*),weight, + & areaslav(*),springarea(2,*),xl2(3,8),area,xi,et,shp2(7,8), + & xs2(3,2),xsj2(3),coefmpc(*),adjust,tietol(2,*),reltime +! + include "gauss.f" +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! +! flag for shape functions +! + data iflag /2/ +! + data iteller /0/ + save iteller +! +! opening a file to store the contact spring elements +! +c iteller=iteller+1 +c cfile(1:18)='contactelem ' +c if(iteller.lt.10) then +c write(cfile(12:12),'(i1)') iteller +c cfile(13:16)='.inp' +c elseif(iteller.lt.100) then +c write(cfile(12:13),'(i2)') iteller +c cfile(14:17)='.inp' +c elseif(iteller.lt.1000) then +c write(cfile(12:14),'(i3)') iteller +c cfile(15:18)='.inp' +c else +c write(*,*) '*ERROR in gencontelem: more than 1000' +c write(*,*) ' contact element files' +c stop +c endif +c open(27,file=cfile,status='unknown') +! + do i=1,ntie + if(tieset(1,i)(81:81).ne.'C') cycle + kneigh=1 + slavset=tieset(2,i) + material=int(tietol(2,i)) +! +! check whether an adjust node set has been defined +! only checked at the start of the first step +! +c if((istep.eq.1).and.(iinc.eq.1).and.(iit.le.0)) then + if((istep.eq.1).and.(iit.lt.0)) then + iset=0 + if(tieset(1,i)(1:1).ne.' ') then + noset(1:80)=tieset(1,i)(1:80) + noset(81:81)=' ' + ipos=index(noset,' ') + noset(ipos:ipos)='N' + do iset=1,nset + if(set(iset).eq.noset) exit + enddo + kflag=1 + call isortii(ialset(istartset(iset)),idummy, + & iendset(iset)-istartset(iset)+1,kflag) + endif + endif +! +! determine the area of the slave surfaces +! + do l = itiefac(1,i), itiefac(2,i) + ifaces = islavsurf(1,l) + nelems = int(ifaces/10) + jfaces = ifaces - nelems*10 +! +! Decide on the max integration points number, just consider 2D situation +! + if(lakon(nelems)(4:5).eq.'8R') then + mint2d=1 + nopes=4 + nope=8 + elseif(lakon(nelems)(4:4).eq.'8') then + mint2d=4 + nopes=4 + nope=8 + elseif(lakon(nelems)(4:6).eq.'20R') then + mint2d=4 + nopes=8 + nope=20 + elseif(lakon(nelems)(4:4).eq.'2') then + mint2d=9 + nopes=8 + nope=20 + elseif(lakon(nelems)(4:5).eq.'10') then + mint2d=3 + nopes=6 + nope=10 + elseif(lakon(nelems)(4:4).eq.'4') then + mint2d=1 + nopes=3 + nope=4 +! +! treatment of wedge faces +! + elseif(lakon(nelems)(4:4).eq.'6') then + mint2d=1 + nope=6 + if(jfaces.le.2) then + nopes=3 + else + nopes=4 + endif + elseif(lakon(nelems)(4:5).eq.'15') then + nope=15 + if(jfaces.le.2) then + mint2d=3 + nopes=6 + else + mint2d=4 + nopes=8 + endif + endif +! +! actual position of the nodes belonging to the +! slave surface +! + do j=1,nope + konl(j)=kon(ipkon(nelems)+j) + enddo +! + if((nope.eq.20).or.(nope.eq.8)) then + do m=1,nopes + do j=1,3 + xl2(j,m)=co(j,konl(ifaceq(m,jfaces)))+ + & vold(j,konl(ifaceq(m,jfaces))) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + do m=1,nopes + do j=1,3 + xl2(j,m)=co(j,konl(ifacet(m,jfaces)))+ + & vold(j,konl(ifacet(m,jfaces))) + enddo + enddo + else + do m=1,nopes + do j=1,3 + xl2(j,m)=co(j,konl(ifacew1(m,jfaces)))+ + & vold(j,konl(ifacew1(m,jfaces))) + enddo + enddo + endif +! +! calculating the area of the slave face +! + area=0.d0 + do m=1,mint2d + if((lakon(nelems)(4:5).eq.'8R').or. + & ((lakon(nelems)(4:4).eq.'6').and.(nopes.eq.4))) then + xi=gauss2d1(1,m) + et=gauss2d1(2,m) + weight=weight2d1(m) + elseif((lakon(nelems)(4:4).eq.'8').or. + & (lakon(nelems)(4:6).eq.'20R').or. + & ((lakon(nelems)(4:5).eq.'15').and. + & (nopes.eq.8))) then + xi=gauss2d2(1,m) + et=gauss2d2(2,m) + weight=weight2d2(m) + elseif(lakon(nelems)(4:4).eq.'2') then + xi=gauss2d3(1,m) + et=gauss2d3(2,m) + weight=weight2d3(m) + elseif((lakon(nelems)(4:5).eq.'10').or. + & ((lakon(nelems)(4:5).eq.'15').and. + & (nopes.eq.6))) then + xi=gauss2d5(1,m) + et=gauss2d5(2,m) + weight=weight2d5(m) + elseif((lakon(nelems)(4:4).eq.'4').or. + & ((lakon(nelems)(4:4).eq.'6').and. + & (nopes.eq.3))) then + xi=gauss2d4(1,m) + et=gauss2d4(2,m) + weight=weight2d4(m) + endif +! + if(nopes.eq.8) then + call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + endif + area=area+weight*dsqrt(xsj2(1)**2+xsj2(2)**2+ + & xsj2(3)**2) + enddo + areaslav(l)=area + enddo +! +! search a master face for each slave node and generate a contact +! spring element if successful +! + nstart=itietri(1,i)-1 + n=itietri(2,i)-nstart + if(n.lt.kneigh) kneigh=n + do j=1,n + xo(j)=cg(1,nstart+j) + x(j)=xo(j) + nx(j)=j + yo(j)=cg(2,nstart+j) + y(j)=yo(j) + ny(j)=j + zo(j)=cg(3,nstart+j) + z(j)=zo(j) + nz(j)=j + enddo + kflag=2 + call dsort(x,nx,n,kflag) + call dsort(y,ny,n,kflag) + call dsort(z,nz,n,kflag) +! + do j=nslavnode(i)+1,nslavnode(i+1) + node=islavnode(j) +! +! calculating the area corresponding to the +! slave node; is made up of the area +! of the neighboring slave faces +! + area=0.d0 + index1=iponoels(node) + do + if(index1.eq.0) exit + area=area+areaslav(inoels(1,index1))/ + & inoels(2,index1) + index1=inoels(3,index1) + enddo +! + do k=1,3 + p(k)=co(k,node)+vold(k,node) + enddo +! +! determining the kneigh neighboring master contact +! triangle centers of gravity +! + call near3d(xo,yo,zo,x,y,z,nx,ny,nz,p(1),p(2),p(3), + & n,neigh,kneigh) +! + isol=0 +! + itriold=0 + itri=neigh(1)+itietri(1,i)-1 + ntriangle=0 + ntriangle_=100 +! + loop1: do + do l=1,3 + ll=4*l-3 + dist=straight(ll,itri)*p(1)+ + & straight(ll+1,itri)*p(2)+ + & straight(ll+2,itri)*p(3)+ + & straight(ll+3,itri) +c if(dist.gt.0.d0) then + if(dist.gt.1.d-6) then + itrinew=imastop(l,itri) + if(itrinew.eq.0) then +c write(*,*) '**border reached' + exit loop1 + elseif(itrinew.eq.itriold) then +c write(*,*) '**solution in between triangles' + isol=itri + exit loop1 + else + call nident(itriangle,itrinew,ntriangle,id) + if(id.gt.0) then + if(itriangle(id).eq.itrinew) then +c write(*,*) '**circular path; no solution' + exit loop1 + endif + endif + ntriangle=ntriangle+1 + if(ntriangle.gt.ntriangle_) then +c write(*,*) '**too many iterations' + exit loop1 + endif + do k=ntriangle,id+2,-1 + itriangle(k)=itriangle(k-1) + enddo + itriangle(id+1)=itrinew + itriold=itri + itri=itrinew + cycle loop1 + endif + elseif(l.eq.3) then +c write(*,*) '**regular solution' + isol=itri + exit loop1 + endif + enddo + enddo loop1 +! +! check whether distance is larger than c0: +! no element is generated +! + if(isol.ne.0) then + dist=straight(13,itri)*p(1)+ + & straight(14,itri)*p(2)+ + & straight(15,itri)*p(3)+ + & straight(16,itri) +! +! check for an adjust parameter (only at the start +! of the first step) +! +c if((istep.eq.1).and.(iinc.eq.1).and.(iit.le.0)) then + if((istep.eq.1).and.(iit.lt.0)) then + if(iset.ne.0) then +! +! check whether node belongs to the adjust node +! set +! + call nident(ialset(istartset(iset)),node, + & iendset(iset)-istartset(iset)+1,id) + if(id.gt.0) then + if(ialset(istartset(iset)+id-1).eq.node) then + do k=1,3 + co(k,node)=co(k,node)- + & dist*straight(12+k,itri) + enddo + dist=0.d0 + endif + endif + elseif(dabs(tietol(1,i)).ge.2.d0) then +! +! adjust parameter +! + adjust=dabs(tietol(1,i))-2.d0 + if(dist.le.adjust) then + do k=1,3 + co(k,node)=co(k,node)- + & dist*straight(12+k,itri) + enddo + dist=0.d0 + endif + endif + endif +! + beta=elcon(1,1,material) + if(beta.gt.0.d0) then + c0=dlog(100.d0)/beta + else + if(dabs(area).gt.0.d0) then + c0=1.d-6*dsqrt(area) + else + c0=1.d-10 + endif + endif + if(dist.gt.c0) then + isol=0 +! +! adjusting the bodies at the start of the +! calculation such that they touch +! +c elseif((istep.eq.1).and.(iinc.eq.1).and. +c & (iit.le.0).and.(dist.lt.0.d0).and. +c & (nmethod.eq.1)) then +c do k=1,3 +c vold(k,node)=vold(k,node)- +c & dist*straight(12+k,itri) +c vini(k,node)=vold(k,node) +c enddo + endif + endif +! + if(isol.ne.0) then +! +! plane spring +! + ne=ne+1 + ipkon(ne)=ifree + lakon(ne)='ESPRNGC ' + ielmat(ne)=material + nelem=int(koncont(4,itri)/10.d0) + jface=koncont(4,itri)-10*nelem +! +! storing the area corresponding to the slave node +! and the clearance if penetration takes place, +! i.e. dist <0 at the start of every step +! + springarea(1,j)=area + if(iit.lt.0.d0) then + if(dist.lt.0.d0) then + springarea(2,j)=dist + else + springarea(2,j)=0.d0 + endif + endif +! + indexe=ipkon(nelem) + if(lakon(nelem)(4:4).eq.'2') then + nnodelem=8 + nface=6 + elseif(lakon(nelem)(4:4).eq.'8') then + nnodelem=4 + nface=6 + elseif(lakon(nelem)(4:5).eq.'10') then + nnodelem=6 + nface=4 + elseif(lakon(nelem)(4:4).eq.'4') then + nnodelem=3 + nface=4 + elseif(lakon(nelem)(4:5).eq.'15') then + if(jface.le.2) then + nnodelem=6 + else + nnodelem=8 + endif + nface=5 + nope=15 + elseif(lakon(nelem)(4:4).eq.'6') then + if(jface.le.2) then + nnodelem=3 + else + nnodelem=4 + endif + nface=5 + nope=6 + else + cycle + endif +! +! determining the nodes of the face +! + if(nface.eq.4) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacet(k,jface)) + enddo + elseif(nface.eq.5) then + if(nope.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew1(k,jface)) + enddo + elseif(nope.eq.15) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew2(k,jface)) + enddo + endif + elseif(nface.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifaceq(k,jface)) + enddo + endif +! + do k=1,nnodelem + kon(ifree+k)=nodef(k) + enddo + ifree=ifree+nnodelem+1 + kon(ifree)=node + ifree=ifree+1 + kon(ifree)=j +! + write(lakon(ne)(8:8),'(i1)') nnodelem+1 +c write(*,*) 'new elem',ne,(nodef(k),k=1,nnodelem),node + if((nnodelem.eq.3).or.(nnodelem.eq.6)) then +c write(27,100) +c 100 format('*ELEMENT,TYPE=C3D4') +c write(27,*) ne,',',nodef(1),',',nodef(2),',', +c & nodef(3),',',node + else +c write(27,101) +c 101 format('*ELEMENT,TYPE=C3D6') +c write(27,*) ne,',',nodef(2),',',node,',',nodef(3), +c & ',',nodef(1),',',node,',',nodef(4) + endif + endif +! + enddo + enddo +! +! +c close(27) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gencontmpc.c calculix-ccx-2.3/ccx_2.3/src/gencontmpc.c --- calculix-ccx-2.1/ccx_2.3/src/gencontmpc.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gencontmpc.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,687 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +void gencontmpc(int *ne, int *iface, char *lakon, int *ipkon, int *kon, + int *nmpc, int **ikmpcp, int **ilmpcp, int **ipompcp, + int *mpcfree, + double **fmpcp, char **labmpcp, int **nodempcp, int *memmpc_, + double **coefmpcp, int *nmpc_, int *ikboun, int *nboun){ + + /* creates contact MPC's for the middle nodes of the + dependent surface*/ + + char *labmpc=NULL; + + int i,j,k,indexe, + node,id,idir,idof,node1,node2,index,*ipompc=NULL,*ikmpc=NULL, + *ilmpc=NULL,*nodempc=NULL,jface,jmin,jmax,ij; + int kk; + + int nonei6[9]={7,13,14,8,14,15,9,15,13}; + + int nonei8[12]={9,17,18,10,18,19,11,19,20,12,20,17}; + + int nonei10[18]={5,1,2,6,2,3,7,3,1,8,1,4,9,2,4,10,3,4}; + + int nonei15[27]={7,1,2,8,2,3,9,3,1,10,4,5,11,5,6,12,6,4, + 13,1,4,14,2,5,15,3,6}; + + int nonei20[36]={9,1,2,10,2,3,11,3,4,12,4,1, + 13,5,6,14,6,7,15,7,8,16,8,5, + 17,1,5,18,2,6,19,3,7,20,4,8}; + + int ifaceq[48]={4,3,2,1,11,10,9,12, + 5,6,7,8,13,14,15,16, + 1,2,6,5,9,18,13,17, + 2,3,7,6,10,19,14,18, + 3,4,8,7,11,20,15,19, + 4,1,5,8,12,17,16,20}; + + int ifacet[24]={1,3,2,7,6,5, + 1,2,4,5,9,8, + 2,3,4,6,10,9, + 1,4,3,8,10,7}; + + int ifacew[40]={1,3,2,9,8,7,0,0, + 4,5,6,10,11,12,0,0, + 1,2,5,4,7,14,10,13, + 2,3,6,5,8,15,11,14, + 3,1,4,6,9,13,12,15}; + + double *fmpc=NULL, *coefmpc=NULL; + + ipompc=*ipompcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; + fmpc=*fmpcp;nodempc=*nodempcp;coefmpc=*coefmpcp; + + /* determining which nodes are middle nodes */ + + i=(int)(*iface/10.); + jface=*iface-i*10; + + /* C-convention */ + + i--; + + indexe=ipkon[i]; + if(indexe<0) return; + if(strcmp1(&lakon[8*i+3],"2")==0){ + if(strcmp1(&lakon[8*i+6]," ")==0){ + + /* genuine 20-node element */ + + for(ij=4;ij<8;ij++){ + j=ifaceq[(jface-1)*8+ij]-1; + node=kon[indexe+j]; + + /* create a MPC between node and the + corresponding end nodes */ + + node1=kon[indexe+nonei20[(j-8)*3+1]-1]; + node2=kon[indexe+nonei20[(j-8)*3+2]-1]; + + /* create a MPC between node, node1 and node2 */ + + for(idir=1;idir<4;idir++){ + idof=8*(node-1)+idir; + FORTRAN(nident,(ikboun,&idof,nboun,&id)); + if(id>0){ + if(ikboun[id-1]==idof)continue; + } + FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); + if(id>0){ + if(ikmpc[id-1]==idof)continue; + } + (*nmpc)++; + if(*nmpc>*nmpc_){ + if(*nmpc_<11)*nmpc_=11; + *nmpc_=(int)(1.1**nmpc_); + RENEW(ipompc,int,*nmpc_); + RENEW(labmpc,char,20**nmpc_+1); + RENEW(ikmpc,int,*nmpc_); + RENEW(ilmpc,int,*nmpc_); + RENEW(fmpc,double,*nmpc_); + } + ipompc[*nmpc-1]=*mpcfree; + strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); + for(k=*nmpc-1;k>id;k--){ + ikmpc[k]=ikmpc[k-1]; + ilmpc[k]=ilmpc[k-1]; + } + ikmpc[id]=idof; + ilmpc[id]=*nmpc; + + /* first term */ + + nodempc[3**mpcfree-3]=node; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=2.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* second term */ + + nodempc[3**mpcfree-3]=node1; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* third term */ + + nodempc[3**mpcfree-3]=node2; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + nodempc[3*index-1]=0; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + } + } /* j */ + + }else if(strcmp1(&lakon[8*i+6],"B")!=0){ + + /* plane strain, plane stress, axisymmetric elements + or shell elements */ + + if(jface<3){ + jmax=8; + }else{ + jmax=5; + } + for(ij=4;ij2){ + node=(kon[indexe+j]+kon[indexe+j+4])/2; + node1=kon[indexe+nonei8[(j-8)*3+1]-1]; + node2=kon[indexe+nonei8[(j-8)*3+2]-1]; + }else{ + node=kon[indexe+j]; + node1=kon[indexe+nonei20[(j-8)*3+1]-1]; + node2=kon[indexe+nonei20[(j-8)*3+2]-1]; + } + + /* create a MPC between node and the + corresponding end nodes */ + +// printf("gencontmpc %d %d %d\n",j,jface,ij); +// kk=nonei8[(j-8)*3+1]; +// printf("gencontmpc %d \n",kk); +// printf("gencontmpc %d \n",indexe); +// printf("gencontmpc %d \n",indexe+kk-1); + + /* create a MPC between node, node1 and node2 */ + + for(idir=1;idir<3;idir++){ + idof=8*(node-1)+idir; + FORTRAN(nident,(ikboun,&idof,nboun,&id)); + if(id>0){ + if(ikboun[id-1]==idof)continue; + } + FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); + if(id>0){ + if(ikmpc[id-1]==idof)continue; + } + (*nmpc)++; + if(*nmpc>*nmpc_){ + if(*nmpc_<11)*nmpc_=11; + *nmpc_=(int)(1.1**nmpc_); + RENEW(ipompc,int,*nmpc_); + RENEW(labmpc,char,20**nmpc_+1); + RENEW(ikmpc,int,*nmpc_); + RENEW(ilmpc,int,*nmpc_); + RENEW(fmpc,double,*nmpc_); + } + ipompc[*nmpc-1]=*mpcfree; + strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); + for(k=*nmpc-1;k>id;k--){ + ikmpc[k]=ikmpc[k-1]; + ilmpc[k]=ilmpc[k-1]; + } + ikmpc[id]=idof; + ilmpc[id]=*nmpc; + + /* first term */ + + nodempc[3**mpcfree-3]=node; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=2.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* second term */ + + nodempc[3**mpcfree-3]=node1; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* third term */ + + nodempc[3**mpcfree-3]=node2; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + nodempc[3*index-1]=0; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + } + } + } + + }else if(strcmp1(&lakon[8*i+3],"15")==0){ + + if(strcmp1(&lakon[8*i+6]," ")==0){ + + /* genuine 15-node element */ + + if(jface<3){ + jmin=3;jmax=6; + }else{ + jmin=4;jmax=8; + } + for(ij=jmin;ij0){ + if(ikboun[id-1]==idof)continue; + } + FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); + if(id>0){ + if(ikmpc[id-1]==idof)continue; + } + (*nmpc)++; + if(*nmpc>*nmpc_){ + if(*nmpc_<11)*nmpc_=11; + *nmpc_=(int)(1.1**nmpc_); + RENEW(ipompc,int,*nmpc_); + RENEW(labmpc,char,20**nmpc_+1); + RENEW(ikmpc,int,*nmpc_); + RENEW(ilmpc,int,*nmpc_); + RENEW(fmpc,double,*nmpc_); + } + ipompc[*nmpc-1]=*mpcfree; + strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); + for(k=*nmpc-1;k>id;k--){ + ikmpc[k]=ikmpc[k-1]; + ilmpc[k]=ilmpc[k-1]; + } + ikmpc[id]=idof; + ilmpc[id]=*nmpc; + + /* first term */ + + nodempc[3**mpcfree-3]=node; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=2.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* second term */ + + nodempc[3**mpcfree-3]=node1; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* third term */ + + nodempc[3**mpcfree-3]=node2; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + nodempc[3*index-1]=0; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + } + } /* j */ + + }else if(strcmp1(&lakon[8*i+6],"B")!=0){ + + /* plane strain, plane stress, axisymmetric elements + or shell elements */ + + if(jface<3){ + jmin=3;jmax=6; + }else{ + jmin=4;jmax=5; + } + for(ij=jmin;ij2){ + node=(kon[indexe+j]+kon[indexe+j+3])/2; + node1=kon[indexe+nonei6[(j-6)*3+1]-1]; + node2=kon[indexe+nonei6[(j-6)*3+2]-1]; + }else{ + node=kon[indexe+j]; + node1=kon[indexe+nonei15[(j-6)*3+1]-1]; + node2=kon[indexe+nonei15[(j-6)*3+2]-1]; + } + + + /* create a MPC between node, node1 and node2 */ + + for(idir=1;idir<3;idir++){ + idof=8*(node-1)+idir; + FORTRAN(nident,(ikboun,&idof,nboun,&id)); + if(id>0){ + if(ikboun[id-1]==idof)continue; + } + FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); + if(id>0){ + if(ikmpc[id-1]==idof)continue; + } + (*nmpc)++; + if(*nmpc>*nmpc_){ + if(*nmpc_<11)*nmpc_=11; + *nmpc_=(int)(1.1**nmpc_); + RENEW(ipompc,int,*nmpc_); + RENEW(labmpc,char,20**nmpc_+1); + RENEW(ikmpc,int,*nmpc_); + RENEW(ilmpc,int,*nmpc_); + RENEW(fmpc,double,*nmpc_); + } + ipompc[*nmpc-1]=*mpcfree; + strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); + for(k=*nmpc-1;k>id;k--){ + ikmpc[k]=ikmpc[k-1]; + ilmpc[k]=ilmpc[k-1]; + } + ikmpc[id]=idof; + ilmpc[id]=*nmpc; + + /* first term */ + + nodempc[3**mpcfree-3]=node; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=2.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* second term */ + + nodempc[3**mpcfree-3]=node1; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* third term */ + + nodempc[3**mpcfree-3]=node2; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + nodempc[3*index-1]=0; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + } + } + } + + }else if(strcmp1(&lakon[8*i+3],"10")==0){ + + /* genuine 10-node element */ + + for(ij=3;ij<6;ij++){ + j=ifacet[(jface-1)*6+ij]-1; + node=kon[indexe+j]; + + /* create a MPC between node and the + corresponding end nodes */ + + node1=kon[indexe+nonei10[(j-4)*3+1]-1]; + node2=kon[indexe+nonei10[(j-4)*3+2]-1]; + + /* create a MPC between node, node1 and node2 */ + + for(idir=1;idir<4;idir++){ + idof=8*(node-1)+idir; + FORTRAN(nident,(ikboun,&idof,nboun,&id)); + if(id>0){ + if(ikboun[id-1]==idof)continue; + } + FORTRAN(nident,(ikmpc,&idof,nmpc,&id)); + if(id>0){ + if(ikmpc[id-1]==idof)continue; + } + (*nmpc)++; + if(*nmpc>*nmpc_){ + if(*nmpc_<11)*nmpc_=11; + *nmpc_=(int)(1.1**nmpc_); + RENEW(ipompc,int,*nmpc_); + RENEW(labmpc,char,20**nmpc_+1); + RENEW(ikmpc,int,*nmpc_); + RENEW(ilmpc,int,*nmpc_); + RENEW(fmpc,double,*nmpc_); + } + ipompc[*nmpc-1]=*mpcfree; + strcpy1(&labmpc[20*(*nmpc-1)],"CONTACT ",20); + for(k=*nmpc-1;k>id;k--){ + ikmpc[k]=ikmpc[k-1]; + ilmpc[k]=ilmpc[k-1]; + } + ikmpc[id]=idof; + ilmpc[id]=*nmpc; + + /* first term */ + + nodempc[3**mpcfree-3]=node; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=2.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* second term */ + + nodempc[3**mpcfree-3]=node1; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + nodempc[3*index-1]=*mpcfree; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + + /* third term */ + + nodempc[3**mpcfree-3]=node2; + nodempc[3**mpcfree-2]=idir; + coefmpc[*mpcfree-1]=-1.; + index=*mpcfree; + *mpcfree=nodempc[3**mpcfree-1]; + nodempc[3*index-1]=0; + if(*mpcfree==0){ + *mpcfree=*memmpc_+1; + if(*memmpc_<11)*memmpc_=11; + *memmpc_=(int)(1.1**memmpc_); + printf("*INFO in gencontmpc: reallocating nodempc; new size = %d\n\n",*memmpc_); + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=*mpcfree;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + } + } + } /* j */ + + } + + /* RENEW(ipompc,int,*nmpc); + RENEW(labmpc,char,20**nmpc+1); + RENEW(ikmpc,int,*nmpc); + RENEW(ilmpc,int,*nmpc); + RENEW(fmpc,double,*nmpc);*/ + + *ipompcp=ipompc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; + *fmpcp=fmpc;*nodempcp=nodempc;*coefmpcp=coefmpc; + + return; + +} + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gencontrel.f calculix-ccx-2.3/ccx_2.3/src/gencontrel.f --- calculix-ccx-2.1/ccx_2.3/src/gencontrel.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gencontrel.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,561 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gencontrel(tieset,ntie,itietri,ipkon,kon, + & lakon,set,cg,straight, + & koncont,co,vold,xo,yo,zo,x,y,z,nx,ny,nz,nset, + & iinc,iit, + & islavsurf,imastsurf,pmastsurf,itiefac, + & islavnode,nslavnode,slavnor,slavtan,imastop, + & mi,ncont,ipe,ime,pslavsurf,pslavdual) +! +! Calculating the normals and tangential vectors in the nodes of +! the slave surface (slavnor, slavtan) +! Determining the coefficients of the dual shape functions on +! the slave surface +! +! Author: Li, Yang; Rakotonanahary, Samoela; +! + implicit none +! + character*1 c + character*3 m11,m2,m3 + character*5 p0,p1,p2,p3,p7,p9999 + character*8 lakon(*) + character*81 tieset(3,*),slavset,set(*) +! + integer ntie,nset,ifree,imastop(3,*),kmax(3),ncont, + & itietri(2,ntie),ipkon(*),kon(*),koncont(4,*),node, + & neigh(10),iflag,kneigh,i,j,k,l,islav,isol, + & itri,kflag,ntri,ipos,nx(*),ny(*),iinc, + & nz(*),nstart,ifaceq(8,6),ifacet(6,4),index1,ifreeintersec, + & ifacew1(4,5),ifacew2(8,5),nelemm,jfacem,indexe,iit, + & nnodelem,nface,nope,nodef(8),m1,km1,km2,km3,number, + & islavsurf(2,*),islavnode(*),nslavnode(ntie+1), + & imastsurf(*),itiefac(2,*),ifaces,nelems,jfaces,mi(2), + & mint2d,m,nopes,konl(20),id,indexnode(8), + & itria(4),ntria,itriacorner(4,4),inodesin(3*ncont),line, + & nnodesin,inodesout(3*ncont),nnodesout,iactiveline(3,3*ncont), + & nactiveline,intersec(2,6*ncont),ipe(*),ime(4,*),nintpoint,k1,j1, + & ipiv(4),info,ipnt,one,number_of_nodes,itel +! + real*8 cg(3,*),straight(16,*),co(3,*),vold(0:mi(2),*),p(3), + & xntersec(3,6*ncont),xo(*),yo(*),zo(*),x(*),y(*),z(*), + & pmastsurf(2,*),xl2m(3,8),et,xi,weight,xl2s(3,8),xsj2(3), + & shp2(7,8), + & xs2(3,2),slavnor(3,*),slavtan(6,*), xquad(2,8), xtri(2,6),dd, + & al,al1,al2,xn(3),xnabs(3),slavstraight(20), + & pslavdual(16,*),diag_els(4),m_els(10),contribution,work(4) +! + real*4 rand + real*8 pslavsurf(3,*),err,pnodesin(3,3*ncont) +! + include "gauss.f" +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! + data iflag /2/ +! +! new added data for the local coodinates for nodes +! + data xquad /-1, -1, + & 1, -1, + & 1, 1, + & -1, 1, + & 0, -1, + & 1, 0, + & 0, 1, + & -1, 0/ +! + data xtri /0, 0, + & 1, 0, + & 0, 1, + & 0.5, 0, + & 0.5, 0.5, + & 0, 0.5/ +! + open(40,file='contact.fbd',status='unknown') +! +! maximum number of neighboring master triangles for a slave node +! + kflag=2 + ifree = 0 +! + err=1.d-6 +! +! storing the triangulation of the master surfaces +! + open(70,file='TriMasterContactPair.frd',status='unknown') + c='C' + m11=' -1' + m2=' -2' + m3=' -3' + p0=' 0' + p1=' 1' + p2=' 2' + p3=' 3' + p7=' 7' + p9999=' 9999' + one=1 + write(70,'(a5,a1)') p1,c + write(70,'(a5,a1,67x,i1)') p2,c,one + number_of_nodes=0 + do i=1,itietri(2,ntie) + number_of_nodes=max(number_of_nodes,koncont(1,i)) + number_of_nodes=max(number_of_nodes,koncont(2,i)) + number_of_nodes=max(number_of_nodes,koncont(3,i)) + enddo + do i=1,number_of_nodes + write(70,'(a3,i10,1p,3e12.5)') m11,i,(co(j,i),j=1,3) + enddo + write(70,'(a3)') m3 + write(70,'(a5,a1,67x,i1)') p3,c,one + do i=1,itietri(2,ntie) + write(70,'(a3,i10,2a5)')m11,i,p7,p0 + write(70,'(a3,3i10)') m2,(koncont(j,i),j=1,3) + enddo + write(70,'(a3)') m3 + write(70,'(a5)') p9999 + close(70) +! + do i=1,ntie + if(tieset(1,i)(81:81).ne.'C') cycle + kneigh=1 +! + slavset=tieset(2,i) + ipos=index(slavset,' ') + if(slavset(ipos-1:ipos-1).eq.'S') cycle +! +! determining the slave set +! + do j=1,nset + if(set(j).eq.slavset) exit + enddo + if(j.gt.nset) then + write(*,*) '*ERROR in gencontrel: contact slave set', + & slavset + write(*,*) ' does not exist' + stop + endif + islav=j +! +! ntri: number of triangles in the triangulation of the master +! surface corresponding to tie i +! + nstart=itietri(1,i)-1 + ntri=itietri(2,i)-nstart + if(ntri.lt.kneigh) kneigh=ntri + do j=1,ntri + xo(j)=cg(1,nstart+j) + x(j)=xo(j) + nx(j)=j + yo(j)=cg(2,nstart+j) + y(j)=yo(j) + ny(j)=j + zo(j)=cg(3,nstart+j) + z(j)=zo(j) + nz(j)=j + enddo + call dsort(x,nx,ntri,kflag) + call dsort(y,ny,ntri,kflag) + call dsort(z,nz,ntri,kflag) +c do j=1,ntri +c write(*,*) j,x(j),y(j),z(j),nx(j),ny(j),nz(j) +c enddo +! + do l = itiefac(1,i), itiefac(2,i) + ifaces = islavsurf(1,l) + nelems = int(ifaces/10) + jfaces = ifaces - nelems*10 +! +! initialization for Dualshape Coefficient matrix +! + ipnt=0 + do k=1,4 + diag_els(k)=0.0 +c do j=k,4 + do j=1,k + ipnt=ipnt+1 + m_els(ipnt)=0.0 + enddo + enddo +! +! Decide on the max integration point number, just consider 2D situation +! + if(lakon(nelems)(4:5).eq.'8R') then + mint2d=1 + nopes=4 + nope=8 + elseif(lakon(nelems)(4:4).eq.'8') then + mint2d=4 + nopes=4 + nope=8 + elseif(lakon(nelems)(4:6).eq.'20R') then + mint2d=4 + nopes=8 + nope=20 + elseif(lakon(nelems)(4:4).eq.'2') then + mint2d=9 + nopes=8 + nope=20 + elseif(lakon(nelems)(4:5).eq.'10') then + mint2d=3 + nopes=6 + nope=10 + elseif(lakon(nelems)(4:4).eq.'4') then + mint2d=1 + nopes=3 + nope=4 +! +! treatment of wedge faces +! + elseif(lakon(nelems)(4:4).eq.'6') then + mint2d=1 + nope=6 + if(jfaces.le.2) then + nopes=3 + else + nopes=4 + endif + elseif(lakon(nelems)(4:5).eq.'15') then + nope=15 + if(jfaces.le.2) then + mint2d=3 + nopes=6 + else + mint2d=4 + nopes=8 + endif + endif +! +! actual position of the nodes belonging to the +! slave surface +! + do j=1,nope + konl(j)=kon(ipkon(nelems)+j) + enddo +! + if((nope.eq.20).or.(nope.eq.8)) then + do m=1,nopes + do j=1,3 + xl2s(j,m)=co(j,konl(ifaceq(m,jfaces)))+ + & vold(j,konl(ifaceq(m,jfaces))) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + do m=1,nopes + do j=1,3 + xl2s(j,m)=co(j,konl(ifacet(m,jfaces)))+ + & vold(j,konl(ifacet(m,jfaces))) + enddo + enddo + else + do m=1,nopes + do j=1,3 + xl2s(j,m)=co(j,konl(ifacew1(m,jfaces)))+ + & vold(j,konl(ifacew1(m,jfaces))) + enddo + enddo + endif + +! calculate the normal vector in the nodes belonging to the slave surface +! + if(nopes.eq.8) then + do m = 1, nopes + xi = xquad(1,m) + et = xquad(2,m) + call shape8q(xi,et,xl2s,xsj2,xs2,shp2,iflag) + dd = dsqrt(xsj2(1)*xsj2(1) + xsj2(2)*xsj2(2) + & + xsj2(3)*xsj2(3)) + xsj2(1) = xsj2(1)/dd + xsj2(2) = xsj2(2)/dd + xsj2(3) = xsj2(3)/dd +! + if(nope.eq.20) then + node = konl(ifaceq(m,jfaces)) + elseif(nope.eq.15) then + node=konl(ifacew2(m,jfaces)) + endif +! + call nident(islavnode(nslavnode(i)+1), node, + & nslavnode(i+1)-nslavnode(i), id) + index1=nslavnode(i)+id + indexnode(m)=index1 + slavnor(1,index1) = slavnor(1,index1) + & +xsj2(1) + slavnor(2,index1) = slavnor(2,index1) + & +xsj2(2) + slavnor(3,index1) = slavnor(3,index1) + & +xsj2(3) + enddo + elseif(nopes.eq.4) then + do m = 1, nopes + xi = xquad(1,m) + et = xquad(2,m) + call shape4q(xi,et,xl2s,xsj2,xs2,shp2,iflag) + dd = dsqrt(xsj2(1)*xsj2(1) + xsj2(2)*xsj2(2) + & + xsj2(3)*xsj2(3)) + xsj2(1) = xsj2(1)/dd + xsj2(2) = xsj2(2)/dd + xsj2(3) = xsj2(3)/dd +! + if(nope.eq.8) then + node = konl(ifaceq(m,jfaces)) + elseif(nope.eq.6) then + node=konl(ifacew1(m,jfaces)) + endif +! + call nident(islavnode(nslavnode(i)+1), node, + & nslavnode(i+1)-nslavnode(i), id) +! + index1=nslavnode(i)+id + indexnode(m)=index1 + slavnor(1,index1) = slavnor(1,index1) + & +xsj2(1) + slavnor(2,index1) = slavnor(2,index1) + & +xsj2(2) + slavnor(3,index1) = slavnor(3,index1) + & +xsj2(3) + enddo + elseif(nopes.eq.6) then + do m = 1, nopes + xi = xquad(1,m) + et = xquad(2,m) + call shape6tri(xi,et,xl2s,xsj2,xs2,shp2,iflag) + dd = dsqrt(xsj2(1)*xsj2(1) + xsj2(2)*xsj2(2) + & + xsj2(3)*xsj2(3)) + xsj2(1) = xsj2(1)/dd + xsj2(2) = xsj2(2)/dd + xsj2(3) = xsj2(3)/dd +! + if(nope.eq.10) then + node = konl(ifacet(m,jfaces)) + elseif(nope.eq.15) then + node = konl(ifacew2(m,jfaces)) + endif +! + call nident(islavnode(nslavnode(i)+1), node, + & nslavnode(i+1)-nslavnode(i), id) + index1=nslavnode(i)+id + indexnode(m)=index1 + slavnor(1,index1) = slavnor(1,index1) + & +xsj2(1) + slavnor(2,index1) = slavnor(2,index1) + & +xsj2(2) + slavnor(3,index1) = slavnor(3,index1) + & +xsj2(3) + enddo + else + do m = 1, nopes + xi = xquad(1,m) + et = xquad(2,m) + call shape3tri(xi,et,xl2s,xsj2,xs2,shp2,iflag) + dd = dsqrt(xsj2(1)*xsj2(1) + xsj2(2)*xsj2(2) + & + xsj2(3)*xsj2(3)) + xsj2(1) = xsj2(1)/dd + xsj2(2) = xsj2(2)/dd + xsj2(3) = xsj2(3)/dd +! + if(nope.eq.6) then + node = konl(ifacew1(m,jfaces)) + elseif(nope.eq.4) then + node = konl(ifacet(m,jfaces)) + endif +! + call nident(islavnode(nslavnode(i)+1), node, + & nslavnode(i+1)-nslavnode(i), id) + index1=nslavnode(i)+id + indexnode(m)=index1 + slavnor(1,nslavnode(i)+id) = slavnor(1,index1) + & +xsj2(1) + slavnor(2,nslavnode(i)+id) = slavnor(2,index1) + & +xsj2(2) + slavnor(3,nslavnode(i)+id) = slavnor(3,index1) + & +xsj2(3) + enddo + endif +! +! determining the gap contribution of the integration points +! and the coefficient for the slave dualshape functions +! + do m = 1,mint2d + ifree = ifree + 1 + if((lakon(nelems)(4:5).eq.'8R').or. + & ((lakon(nelems)(4:4).eq.'6').and.(nopes.eq.4))) then + xi=gauss2d1(1,m) + et=gauss2d1(2,m) + weight=weight2d1(m) + elseif((lakon(nelems)(4:4).eq.'8').or. + & (lakon(nelems)(4:6).eq.'20R').or. + & ((lakon(nelems)(4:5).eq.'15').and. + & (nopes.eq.8))) then + xi=gauss2d2(1,m) + et=gauss2d2(2,m) + weight=weight2d2(m) + elseif(lakon(nelems)(4:4).eq.'2') then + xi=gauss2d3(1,m) + et=gauss2d3(2,m) + weight=weight2d3(m) + elseif((lakon(nelems)(4:5).eq.'10').or. + & ((lakon(nelems)(4:5).eq.'15').and. + & (nopes.eq.6))) then + xi=gauss2d5(1,m) + et=gauss2d5(2,m) + weight=weight2d5(m) + elseif((lakon(nelems)(4:4).eq.'4').or. + & ((lakon(nelems)(4:4).eq.'6').and. + & (nopes.eq.3))) then + xi=gauss2d4(1,m) + et=gauss2d4(2,m) + weight=weight2d4(m) + endif +! + if(nopes.eq.8) then + call shape8q(xi,et,xl2s,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl2s,xsj2,xs2,shp2,iflag) + contribution=weight*dsqrt(xsj2(1)**2+xsj2(2)**2+ + & xsj2(3)**2) + ipnt=0 + do k=1,4 + diag_els(k)=diag_els(k)+shp2(4,k)*contribution + do j=1,k + ipnt=ipnt+1 + m_els(ipnt)=m_els(ipnt)+shp2(4,k)*shp2(4,j)* + & contribution + enddo + enddo + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl2s,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl2s,xsj2,xs2,shp2,iflag) + endif + enddo +! +! Calculate the Mass matrix for compilation of the dualshapefunction +! pslavdual(16,*) +! +! compute inverse of me_ls +! factorisation +! + call dsptrf('U',4,m_els,ipiv,info) +! inverse + call dsptri('U',4,m_els,ipiv,work,info) +! +! stack of pslavdual multiplication with diag_els +! + pslavdual(1,l)=diag_els(1)*m_els(1) + pslavdual(2,l)=diag_els(1)*m_els(2) + pslavdual(3,l)=diag_els(1)*m_els(4) + pslavdual(4,l)=diag_els(1)*m_els(7) + pslavdual(5,l)=diag_els(2)*m_els(2) + pslavdual(6,l)=diag_els(2)*m_els(3) + pslavdual(7,l)=diag_els(2)*m_els(5) + pslavdual(8,l)=diag_els(2)*m_els(8) + pslavdual(9,l)=diag_els(3)*m_els(4) + pslavdual(10,l)=diag_els(3)*m_els(5) + pslavdual(11,l)=diag_els(3)*m_els(6) + pslavdual(12,l)=diag_els(3)*m_els(9) + pslavdual(13,l)=diag_els(4)*m_els(7) + pslavdual(14,l)=diag_els(4)*m_els(8) + pslavdual(15,l)=diag_els(4)*m_els(9) + pslavdual(16,l)=diag_els(4)*m_els(10) + enddo +! +! FIRST SLAVE SURFACE LOOP DONE +! +! normalizing the normals +! + do l=nslavnode(i)+1,nslavnode(i+1) + dd=dsqrt(slavnor(1,l)**2+slavnor(2,l)**2+ + & slavnor(3,l)**2) + do m=1,3 + slavnor(m,l)=slavnor(m,l)/dd + enddo +! +! determining the tangential directions +! + do m=1,3 + xn(m)=slavnor(m,l) + xnabs(m)=dabs(xn(m)) + enddo + number=3 + kmax(1)=1 + kmax(2)=2 + kmax(3)=3 + kflag=2 +! +! sorting the components of the normal +! + call dsort(xnabs,kmax,number,kflag) +! + km1=kmax(3) + km2=km1+1 + if(km2.gt.3) km2=1 + km3=km2+1 + if(km3.gt.3) km3=1 +! + slavtan(km1,l)=-slavnor(km2,l) + slavtan(km2,l)=slavnor(km1,l) + slavtan(km3,l)=0.d0 + dd=dsqrt(slavtan(km1,l)**2+slavtan(km2,l)**2) + slavtan(km1,l)=slavtan(km1,l)/dd + slavtan(km2,l)=slavtan(km2,l)/dd +! + slavtan(4,l)=xn(2)*slavtan(3,l) + & -xn(3)*slavtan(2,l) + slavtan(5,l)=xn(3)*slavtan(1,l) + & -xn(1)*slavtan(3,l) + slavtan(6,l)=xn(1)*slavtan(2,l) + & -xn(2)*slavtan(1,l) + enddo +! + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/generatecycmpcs.f calculix-ccx-2.3/ccx_2.3/src/generatecycmpcs.f --- calculix-ccx-2.1/ccx_2.3/src/generatecycmpcs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/generatecycmpcs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,449 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine generatecycmpcs(tolloc,co,nk,ipompc,nodempc, + & coefmpc,nmpc,ikmpc,ilmpc,mpcfree,rcs,zcs,ics,nr,nz, + & rcs0,zcs0,labmpc, + & mcs,triangulation,csab,xn,yn,zn,phi,noded,ncsnodes, + & rcscg,rcs0cg,zcscg,zcs0cg,nrcg,nzcg,jcs,lcs, + & kontri,straight,ne,ipkon,kon,lakon,ifacetet,inodface,ncounter, + & jobnamec,vold,cfd,mi) +! +! generate cyclic mpc's +! + implicit none +! + logical triangulation,interpolation +! + character*1 c + character*3 m1,m2,m3 + character*5 p0,p1,p2,p3,p7,p9999 + character*8 lakon(*) + character*20 labmpc(*),label + character*132 jobnamec(*),fntria +! + integer ipompc(*),nodempc(3,*),nneigh,ne,ipkon(*),kon(*), + & j,k,nk,nmpc,mpcfree,ics(*),nterms,ncyclicsymmetrymodel, + & nr(*),nz(*),noded,nodei,ikmpc(*),ilmpc(*),kontri(3,*), + & number,idof,ndir,node,ncsnodes,id,mpcfreeold, + & mcs,nrcg(*),nzcg(*),jcs(*),lcs(*),nodef(8), + & netri,ifacetet(*),inodface(*),lathyp(3,6),inum,one,i, + & noden(10),ncounter,ier,ipos,cfd,mi(2) +! + real*8 tolloc,co(3,*),coefmpc(*),rcs(*),zcs(*),rcs0(*),zcs0(*), + & csab(7),xn,yn,zn,xap,yap,zap,rp,zp,al(3,3),ar(3,3),phi, + & x2,y2,z2,x3,y3,z3,rcscg(*),rcs0cg(*),zcscg(*),zcs0cg(*), + & straight(9,*),ratio(8),vold(0:mi(2),*) +! + save netri,ncyclicsymmetrymodel +! + data ncyclicsymmetrymodel /0/ +! +! latin hypercube positions in a 3 x 3 matrix +! + data lathyp /1,2,3,1,3,2,2,1,3,2,3,1,3,1,2,3,2,1/ +! + nneigh=10 +! + xap=co(1,noded)-csab(1) + yap=co(2,noded)-csab(2) + zap=co(3,noded)-csab(3) +! + zp=xap*xn+yap*yn+zap*zn + rp=dsqrt((xap-zp*xn)**2+(yap-zp*yn)**2+(zap-zp*zn)**2) +! + call near2d(rcs0,zcs0,rcs,zcs,nr,nz,rp,zp,ncsnodes,noden,nneigh) + node=noden(1) + nodei=abs(ics(noden(1))) +! +! check whether node is on axis +! + if(nodei.eq.noded) then + return + endif +! + interpolation=.false. +! + if(rp.gt.1.d-10) then + x2=(xap-zp*xn)/rp + y2=(yap-zp*yn)/rp + z2=(zap-zp*zn)/rp + x3=yn*z2-y2*zn + y3=x2*zn-xn*z2 + z3=xn*y2-x2*yn + endif +! + if((tolloc.ge.0.d0).and. + & (tolloc.le.dsqrt((rp-rcs0(node))**2+(zp-zcs0(node))**2))) + & then +! +! the nodal positions on the dependent and independent +! sides of the mpc's do no agree: interpolation is +! necessary. +! +c write(*,*) '*WARNING in generatecycmpcs: no cyclic' +c write(*,*) ' symmetric partner found for' +c write(*,*) ' dependent node ',noded,'.' +c write(*,*) ' allowed tolerance:',tolloc +c write(*,*) ' best partner node number:',nodei +c write(*,*) ' actual distance in a radial plane: ', +c & dsqrt((rp-rcs0(node))**2+(zp-zcs0(node))**2) +c write(*,*) ' Remedy: the node is connected to an' +c write(*,*) ' independent element side.' +c write(*,*) +! + interpolation=.true. +! + if(.not.triangulation) then + call triangulate(ics,rcs0,zcs0,ncsnodes, + & rcscg,rcs0cg,zcscg,zcs0cg,nrcg,nzcg,jcs,kontri, + & straight,ne,ipkon,kon,lakon,lcs,netri,ifacetet, + & inodface) + triangulation=.true. +! + fntria(1:28)='TriMasterCyclicSymmetryModel' + ncyclicsymmetrymodel=ncyclicsymmetrymodel+1 + if(ncyclicsymmetrymodel.lt.10) then + write(fntria(29:29),'(i1)')ncyclicsymmetrymodel + ipos=30 + elseif(ncyclicsymmetrymodel.lt.100) then + write(fntria(29:30),'(i2)')ncyclicsymmetrymodel + ipos=31 + else + write(*,*) '*ERROR in generatecycmpcs: no more than' + write(*,*) ' 99 cyclic symmetry model cards' + write(*,*) ' allowed' + stop + endif + do i=ipos,132 + fntria(i:i)=' ' + enddo +! + open(70,file=fntria,status='unknown') + c='C' + m1=' -1' + m2=' -2' + m3=' -3' + p0=' 0' + p1=' 1' + p2=' 2' + p3=' 3' + p7=' 7' + p9999=' 9999' + one=1 + write(70,'(a5,a1)') p1,c + write(70,'(a5,a1,67x,i1)') p2,c,one + do i=1,nk + write(70,'(a3,i10,1p,3e12.5)') m1,i,(co(j,i),j=1,3) + enddo + write(70,'(a3)') m3 + write(70,'(a5,a1,67x,i1)') p3,c,one + do i=1,netri + write(70,'(a3,i10,2a5)')m1,i,p7,p0 + write(70,'(a3,3i10)') m2,(kontri(j,i),j=1,3) + enddo + write(70,'(a3)') m3 + write(70,'(a5)') p9999 + close(70) +! + endif +! + label='CYCLIC ' + if(mcs.lt.10) then + write(label(7:7),'(i1)') mcs + elseif(mcs.lt.100) then + write(label(7:8),'(i2)') mcs + else + write(*,*)'*ERROR in generatecycmpcs: no more than 99' + write(*,*)' cyclic symmetry definitions allowed' + stop + endif +! + nodei=nk+1 +! +! copying the initial conditions for the new node +! + do i=0,mi(2) + vold(i,nodei)=vold(i,noded) + enddo +! + co(1,nodei)=csab(1)+zp*xn+rp*(x2*dcos(phi)+x3*dsin(phi)) + co(2,nodei)=csab(2)+zp*yn+rp*(y2*dcos(phi)+y3*dsin(phi)) + co(3,nodei)=csab(3)+zp*zn+rp*(z2*dcos(phi)+z3*dsin(phi)) +! + ier=0 +! + call linkdissimilar(co,csab, + & rcscg,rcs0cg,zcscg,zcs0cg,nrcg,nzcg,straight, + & nodef,ratio,nterms,rp,zp,netri, + & nodei,ifacetet,inodface,noded,xn,yn, + & zn,ier) +! + if(ier.ne.0) then + ncounter=ncounter+1 + return + endif +! + else + if(ics(node).lt.0) return + endif +! +! generating the mechanical MPC's; the generated MPC's are for +! nodal diameter 0. For other nodal diameters the MPC's are +! changed implicitly in mastructcs and mafillsmcs +! + call transformatrix(csab,co(1,noded),al) + call transformatrix(csab,co(1,nodei),ar) +! +! checking for latin hypercube positions in matrix al none of +! which are zero +! + do inum=1,6 + if((dabs(al(lathyp(1,inum),1)).gt.1.d-3).and. + & (dabs(al(lathyp(2,inum),2)).gt.1.d-3).and. + & (dabs(al(lathyp(3,inum),3)).gt.1.d-3)) exit + enddo +! + do ndir=1,3 +! +! determining which direction to use for the +! dependent side: should not occur on the dependent +! side in another MPC and should have a nonzero +! coefficient +! + number=lathyp(ndir,inum) + idof=8*(noded-1)+number + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*WARNING in generatecycmpcs: cyclic MPC in no + &de' + write(*,*) ' ',noded,' and direction ',ndir + write(*,*) ' cannot be created: the' + write(*,*) ' DOF in this node is already used' + cycle + endif + endif + number=number-1 +! + nmpc=nmpc+1 + labmpc(nmpc)='CYCLIC ' + if(mcs.lt.10) then + write(labmpc(nmpc)(7:7),'(i1)') mcs + elseif(mcs.lt.100) then + write(labmpc(nmpc)(7:8),'(i2)') mcs + else + write(*,*)'*ERROR in generatecycmpcs: no more than 99' + write(*,*)' cyclic symmetry definitions allowed' + stop + endif + ipompc(nmpc)=mpcfree +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + do j=1,3 + number=number+1 + if(number.gt.3) number=1 + if(dabs(al(number,ndir)).lt.1.d-5) cycle + nodempc(1,mpcfree)=noded + nodempc(2,mpcfree)=number + coefmpc(mpcfree)=al(number,ndir) + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' + stop + endif + enddo + do j=1,3 + number=number+1 + if(number.gt.3) number=1 + if(dabs(ar(number,ndir)).lt.1.d-5) cycle + if(.not.interpolation) then + nodempc(1,mpcfree)=nodei + nodempc(2,mpcfree)=number + coefmpc(mpcfree)=-ar(number,ndir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' + stop + endif + else + do k=1,nterms + nodempc(1,mpcfree)=nodef(k) + nodempc(2,mpcfree)=number + coefmpc(mpcfree)=-ar(number,ndir)*ratio(k) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) '*ERROR in generatecycmpcs: increase nmp + &c_' + stop + endif + enddo + endif + enddo + nodempc(3,mpcfreeold)=0 + enddo +! +! generating the thermal MPC's; the generated MPC's are for nodal +! diameter 0. +! + nmpc=nmpc+1 + labmpc(nmpc)='CYCLIC ' + if(mcs.lt.10) then + write(labmpc(nmpc)(7:7),'(i1)') mcs + elseif(mcs.lt.100) then + write(labmpc(nmpc)(7:8),'(i2)') mcs + else + write(*,*)'*ERROR in generatecycmpcs: no more than 99' + write(*,*)' cyclic symmetry definitions allowed' + stop + endif + ipompc(nmpc)=mpcfree + idof=8*(noded-1) + call nident(ikmpc,idof,nmpc-1,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*ERROR in generatecycmpcs: temperature' + write(*,*) ' in node',noded,'is already used' + stop + endif + endif +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=noded + nodempc(2,mpcfree)=0 + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' + stop + endif + if(.not.interpolation) then + nodempc(1,mpcfree)=nodei + nodempc(2,mpcfree)=0 + coefmpc(mpcfree)=-1.d0 + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' + stop + endif + else + do k=1,nterms + nodempc(1,mpcfree)=nodef(k) + nodempc(2,mpcfree)=0 + coefmpc(mpcfree)=-ratio(k) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' + stop + endif + enddo + endif + nodempc(3,mpcfreeold)=0 +! +! generating the static pressure MPC's for 3D fluid calculations; +! the generated MPC's are for nodal diameter 0. +! + if(cfd.eq.1) then + nmpc=nmpc+1 + labmpc(nmpc)='CYCLIC ' + if(mcs.lt.10) then + write(labmpc(nmpc)(7:7),'(i1)') mcs + elseif(mcs.lt.100) then + write(labmpc(nmpc)(7:8),'(i2)') mcs + else + write(*,*)'*ERROR in generatecycmpcs: no more than 99' + write(*,*)' cyclic symmetry definitions allowed' + stop + endif + ipompc(nmpc)=mpcfree + idof=8*(noded-1)+4 + call nident(ikmpc,idof,nmpc-1,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*ERROR in generatecycmpcs: temperature' + write(*,*) ' in node',noded,'is already used' + stop + endif + endif +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=noded + nodempc(2,mpcfree)=4 + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' + stop + endif + if(.not.interpolation) then + nodempc(1,mpcfree)=nodei + nodempc(2,mpcfree)=4 + coefmpc(mpcfree)=-1.d0 + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' + stop + endif + else + do k=1,nterms + nodempc(1,mpcfree)=nodef(k) + nodempc(2,mpcfree)=4 + coefmpc(mpcfree)=-ratio(k) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*)'*ERROR in generatecycmpcs: increase nmpc_' + stop + endif + enddo + endif + nodempc(3,mpcfreeold)=0 + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/genfirstactif.f calculix-ccx-2.3/ccx_2.3/src/genfirstactif.f --- calculix-ccx-2.1/ccx_2.3/src/genfirstactif.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/genfirstactif.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,448 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine genfirstactif(tieset,ntie,itietri,ne,ipkon,kon, + & lakon,cg,straight, + & koncont,co,vold,xo,yo,zo,x,y,z,nx,ny,nz,ielmat,cs, + & elcon,istep,iinc,iit,ncmat_,ntmat_,ne0, + & vini,nmethod,mi,imastop,nslavnode,islavnode,islavsurf, + & itiefac,areaslav,iponoels,inoels, + & set,nset,istartset, + & iendset,ialset,islavact,ifree,tietol) +! +! Initialization of the Active slave nodes set +! + implicit none +! + character*8 lakon(*) +c character*18 cfile + character*81 tieset(3,*),slavset,set(*),noset +! + integer ntie, + & itietri(2,ntie),ipkon(*),kon(*),koncont(4,*),ne,node, + & neigh(1),iflag,kneigh,i,j,k,l,isol,iset,idummy, + & itri,ll,kflag,n,nx(*),ny(*),istep,iinc, + & nz(*),nstart,ielmat(*),material,ifaceq(8,6),ifacet(6,4), + & ifacew1(4,5),ifacew2(8,5),nelem,jface,indexe,iit, + & nnodelem,nface,nope,nodef(8),ncmat_,ntmat_,index1, + & ne0,nmethod,mi(2),iteller,ifaces,jfaces, + & imastop(3,*), itriangle(100),ntriangle,ntriangle_,itriold, + & itrinew,id,nslavnode(*),islavnode(*),islavsurf(2,*), + & itiefac(2,*),iponoels(*),inoels(3,*),konl(20),nelems,m, + & mint2d,nopes,idof,index2, + & ipos,nset,istartset(*),iendset(*), + & ialset(*),islavact(*),ifree +! + real*8 cg(3,*),straight(16,*),co(3,*),vold(0:mi(2),*),p(3), + & dist,xo(*),yo(*),zo(*),x(*),y(*),z(*),cs(17,*), + & beta,c0,elcon(0:ncmat_,ntmat_,*),vini(0:mi(2),*),weight, + & areaslav(*),xl2(3,8),area,xi,et,shp2(7,8), + & xs2(3,2),xsj2(3),adjust,tietol(2,*) +! + include "gauss.f" +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! +! flag for shape functions +! + data iflag /2/ +! + data iteller /0/ + save iteller +! +! + do i=1,ntie + if(tieset(1,i)(81:81).ne.'C') cycle + kneigh=1 + slavset=tieset(2,i) + material=int(cs(1,i)) +! +! check whether an adjust node set has been defined +! only checked in the first increment of the first step +! + if((istep.eq.1).and.(iinc.eq.1).and.(iit.le.1)) then + iset=0 + if(tieset(1,i)(1:1).ne.' ') then + noset(1:80)=tieset(1,i)(1:80) + noset(81:81)=' ' + ipos=index(noset,' ') + noset(ipos:ipos)='N' + do iset=1,nset + if(set(iset).eq.noset) exit + enddo + kflag=1 + call isortii(ialset(istartset(iset)),idummy, + & iendset(iset)-istartset(iset)+1,kflag) + endif + endif +! +! determine the area of the slave surfaces +! + do l = itiefac(1,i), itiefac(2,i) + ifaces = islavsurf(1,l) + nelems = int(ifaces/10) + jfaces = ifaces - nelems*10 +! +! Decide on the max integration points number, just consider 2D situation +! + if(lakon(nelems)(4:5).eq.'8R') then + mint2d=1 + nopes=4 + nope=8 + elseif(lakon(nelems)(4:4).eq.'8') then + mint2d=4 + nopes=4 + nope=8 + elseif(lakon(nelems)(4:6).eq.'20R') then + mint2d=4 + nopes=8 + nope=20 + elseif(lakon(nelems)(4:4).eq.'2') then + mint2d=9 + nopes=8 + nope=20 + elseif(lakon(nelems)(4:5).eq.'10') then + mint2d=3 + nopes=6 + nope=10 + elseif(lakon(nelems)(4:4).eq.'4') then + mint2d=1 + nopes=3 + nope=4 +! +! treatment of wedge faces +! + elseif(lakon(nelems)(4:4).eq.'6') then + mint2d=1 + nope=6 + if(jfaces.le.2) then + nopes=3 + else + nopes=4 + endif + elseif(lakon(nelems)(4:5).eq.'15') then + nope=15 + if(jfaces.le.2) then + mint2d=3 + nopes=6 + else + mint2d=4 + nopes=8 + endif + endif +! +! actual position of the nodes belonging to the +! slave surface +! + do j=1,nope + konl(j)=kon(ipkon(nelems)+j) + enddo +! + if((nope.eq.20).or.(nope.eq.8)) then + do m=1,nopes + do j=1,3 + xl2(j,m)=co(j,konl(ifaceq(m,jfaces)))+ + & vold(j,konl(ifaceq(m,jfaces))) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + do m=1,nopes + do j=1,3 + xl2(j,m)=co(j,konl(ifacet(m,jfaces)))+ + & vold(j,konl(ifacet(m,jfaces))) + enddo + enddo + else + do m=1,nopes + do j=1,3 + xl2(j,m)=co(j,konl(ifacew1(m,jfaces)))+ + & vold(j,konl(ifacew1(m,jfaces))) + enddo + enddo + endif +! +! calculating the area of the slave face +! + area=0.d0 + do m = 1,mint2d + if((lakon(nelems)(4:5).eq.'8R').or. + & ((lakon(nelems)(4:4).eq.'6').and.(nopes.eq.4))) then + xi=gauss2d1(1,m) + et=gauss2d1(2,m) + weight=weight2d1(m) + elseif((lakon(nelems)(4:4).eq.'8').or. + & (lakon(nelems)(4:6).eq.'20R').or. + & ((lakon(nelems)(4:5).eq.'15').and. + & (nopes.eq.8))) then + xi=gauss2d2(1,m) + et=gauss2d2(2,m) + weight=weight2d2(m) + elseif(lakon(nelems)(4:4).eq.'2') then + xi=gauss2d3(1,m) + et=gauss2d3(2,m) + weight=weight2d3(m) + elseif((lakon(nelems)(4:5).eq.'10').or. + & ((lakon(nelems)(4:5).eq.'15').and. + & (nopes.eq.6))) then + xi=gauss2d5(1,m) + et=gauss2d5(2,m) + weight=weight2d5(m) + elseif((lakon(nelems)(4:4).eq.'4').or. + & ((lakon(nelems)(4:4).eq.'6').and. + & (nopes.eq.3))) then + xi=gauss2d4(1,m) + et=gauss2d4(2,m) + weight=weight2d4(m) + endif +! + if(nopes.eq.8) then + call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + endif + area=area+weight*dsqrt(xsj2(1)**2+xsj2(2)**2+ + & xsj2(3)**2) + enddo + areaslav(l)=area + enddo +! +! search a master face for each slave node and generate a contact +! spring element if successful +! + nstart=itietri(1,i)-1 + n=itietri(2,i)-nstart + if(n.lt.kneigh) kneigh=n + do j=1,n + xo(j)=cg(1,nstart+j) + x(j)=xo(j) + nx(j)=j + yo(j)=cg(2,nstart+j) + y(j)=yo(j) + ny(j)=j + zo(j)=cg(3,nstart+j) + z(j)=zo(j) + nz(j)=j + enddo + kflag=2 + call dsort(x,nx,n,kflag) + call dsort(y,ny,n,kflag) + call dsort(z,nz,n,kflag) +! + do j=nslavnode(i)+1,nslavnode(i+1) + node=islavnode(j) +! +! calculating the area corresponding to the +! slave node; is made up of the area +! of the neighboring slave faces +! + area=0.d0 + index1=iponoels(node) + do + if(index1.eq.0) exit + area=area+areaslav(inoels(1,index1))/ + & inoels(2,index1) + index1=inoels(3,index1) + enddo +! + do k=1,3 + p(k)=co(k,node)+vold(k,node) + enddo +! +! determining the kneigh neighboring master contact +! triangle centers of gravity +! + call near3d(xo,yo,zo,x,y,z,nx,ny,nz,p(1),p(2),p(3), + & n,neigh,kneigh) +! + isol=0 +! + itriold=0 + itri=neigh(1)+itietri(1,i)-1 + ntriangle=0 + ntriangle_=100 +! + loop1: do + do l=1,3 + ll=4*l-3 + dist=straight(ll,itri)*p(1)+ + & straight(ll+1,itri)*p(2)+ + & straight(ll+2,itri)*p(3)+ + & straight(ll+3,itri) +c if(dist.gt.0.d0) then + if(dist.gt.1.d-6) then + itrinew=imastop(l,itri) + if(itrinew.eq.0) then +c write(*,*) '**border reached' + exit loop1 + elseif(itrinew.eq.itriold) then +c write(*,*) '**solution in between triangles' + isol=itri + exit loop1 + else + call nident(itriangle,itrinew,ntriangle,id) + if(id.gt.0) then + if(itriangle(id).eq.itrinew) then +c write(*,*) '**circular path; no solution' + exit loop1 + endif + endif + ntriangle=ntriangle+1 + if(ntriangle.gt.ntriangle_) then +c write(*,*) '**too many iterations' + exit loop1 + endif + do k=ntriangle,id+2,-1 + itriangle(k)=itriangle(k-1) + enddo + itriangle(id+1)=itrinew + itriold=itri + itri=itrinew + cycle loop1 + endif + elseif(l.eq.3) then +c write(*,*) '**regular solution' + isol=itri + exit loop1 + endif + enddo + enddo loop1 +! +! check whether distance is larger than c0: +! no element is generated +! + if(isol.ne.0) then + dist=straight(13,itri)*p(1)+ + & straight(14,itri)*p(2)+ + & straight(15,itri)*p(3)+ + & straight(16,itri) +! +! check for an adjust parameter (only in the first +! increment of the first step) +! + if((istep.eq.1).and.(iinc.eq.1).and.(iit.le.1)) then + if(iset.ne.0) then +! +! check whether node belongs to the adjust node +! set +! + call nident(ialset(istartset(iset)),node, + & iendset(iset)-istartset(iset)+1,id) + if(id.gt.0) then + if(ialset(istartset(iset)+id-1).eq.node) then + do k=1,3 +c co(k,node)=co(k,node)- +c & dist*straight(12+k,itri) + enddo + dist=0.d0 + endif + endif + elseif(dabs(tietol(1,i)).ge.2.d0) then +! +! adjust parameter +! + adjust=dabs(tietol(1,i))-2.d0 + if(dist.le.adjust) then + do k=1,3 +c co(k,node)=co(k,node)- +c & dist*straight(12+k,itri) + enddo + dist=0.d0 + endif + endif + endif +! + beta=elcon(1,1,material) + if(beta.gt.0.d0) then + c0=dlog(100.d0)/beta + else + if(dabs(area).gt.0.d0) then + c0=1.d-6*dsqrt(area) + else + c0=1.d-10 + endif + endif +c WRITE(*,*) dist + if(dist.gt.c0) then +c isol=0 + isol=0 +! +! adjusting the bodies at the start of the +! calculation such that they touch +! + elseif((istep.eq.1).and.(iinc.eq.1).and. + & (iit.le.0).and.(dist.lt.0.d0).and. + & (nmethod.eq.1)) then + do k=1,3 + vold(k,node)=vold(k,node)- + & dist*straight(12+k,itri) + vini(k,node)=vold(k,node) + enddo + endif + endif +! + if(isol.ne.0) then +! +! Active node + islavact(j)=1 +c WRITE(*,*) "GENFIRSTACTIF",j + ifree=ifree+1 + else + islavact(j)=-1 +! + endif +! + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/genislavactdof.f calculix-ccx-2.3/ccx_2.3/src/genislavactdof.f --- calculix-ccx-2.1/ccx_2.3/src/genislavactdof.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/genislavactdof.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,52 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine genislavactdof(ntie,neq,nactdof,nslavnode,islavact, + & islavactdof,islavnode,mi) +! +! Author : Samoela Rakotonanahary +! genislavactdof get the field islavactdof in order to +! help calculating the tangential matrices. +! +! islavactdof is the inverse of nactdof for active slave nodes: +! it links an active slave degree of freedom to the +! corresponding slave node position in field islavnode and the +! global (x-y-z) degree of freedom +! + integer i,j,k,ntie,neq(*),node,nslavnode(*),mi(2), + & nactdof(0:mi(2),*), + & islavact(*),islavactdof(*),islavnode(*) +! +! close the contact.fbd file +! + close(40) +! + do i=1,ntie + do j = nslavnode(i)+1,nslavnode(i+1) + node=islavnode(j) + if(islavact(j).eq.1) then + do k=1,3 + if (nactdof(k,node).eq.0) cycle + islavactdof(nactdof(k,node))=10*j+k + enddo + endif + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/genmodes.f calculix-ccx-2.3/ccx_2.3/src/genmodes.f --- calculix-ccx-2.1/ccx_2.3/src/genmodes.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/genmodes.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,60 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +c Bernhardi start + subroutine genmodes(i,kon,ipkon,lakon,ne,nk,nk_,co) +! +! generate nodes for incompatible modes +! + implicit none +! + character*8 lakon(*) +c + real*8 co(3,*) +c + integer i,kon(*),ipkon(*),ne,nope,nopeexp, + & nk,nk_,j,indexe,k,nodeb(8,3) +c + indexe=ipkon(i) +c + if(lakon(i)(1:5).eq.'C3D8I')then + nope=8 + nopeexp=3 + else + write(6,*) "error wrong element type in genmodes, element=", + & lakon(i) + endif +! +! generating additional nodes for the incompatible element. +! + do j=1,nopeexp + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in genmodes: increase nk_' + stop + endif + kon(indexe+nope+j)=nk + do k=1,3 + co(k,nk)=0.0d0 + enddo + enddo +! + return + end +c Bernhardi end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/gennactdofinv.f calculix-ccx-2.3/ccx_2.3/src/gennactdofinv.f --- calculix-ccx-2.1/ccx_2.3/src/gennactdofinv.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gennactdofinv.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,127 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gennactdofinv(nactdof,nactdofinv,nk,mi,nodorig, + & ipkon,lakon,kon,ne) +! +! inverting field nactdof, i.e. creating field nactdofinv +! listing the node for each independent dof. For expanded +! 2-D structures this is the original 2-D node. Field +! nactdofinv is used for the messages listing the node in +! which the actual deviation or residual force is maximum +! + implicit none +! + character*8 lakon(*),lakonl +! + integer mi(*),nactdof(0:mi(2),*),nactdofinv(*),nk,nodorig(*), + & ipkon(*),i,j,l,ne,indexe,node2d,node3d,indexe2d, + & node3(8,3),node6(3,6),node8(3,8),kon(*),mt +! + data node3 /1,4,8,5,12,20,16,17,9,11,15,13, + & 0,0,0,0,2,3,7,6,10,19,14,18/ + data node6 /1,13,4,2,14,5,3,15,6,7,0,10,8,0,11,9,0,12/ + data node8 /1,17,5,2,18,6,3,19,7,4,20,8,9,0,13,10,0,14, + & 11,0,15,12,0,16/ +! +! initialization of nodorig (node-original) +! + do i=1,nk + nodorig(i)=i + enddo +! +! replacing the 3-D nodes by their 2-D equivalents for 1d/2d +! structures +! + do i=1,ne + if(ipkon(i).lt.0) cycle + lakonl=lakon(i) +c if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'G').or. +c & (lakonl(1:1).ne.'C')) cycle + if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'I').or. + & (lakonl(1:1).ne.'C')) cycle + indexe=ipkon(i) +! + if(lakonl(4:5).eq.'15') then +! +! 6-noded 2D element +! + indexe2d=indexe+15 + do j=1,6 + node2d=kon(indexe2d+j) +c do l=1,3 +c if(node6(l,j).ne.0) then + node3d=kon(indexe+node6(1,j)) + nodorig(node3d)=node2d + nodorig(node3d+1)=node2d + nodorig(node3d+2)=node2d +c endif +c enddo + enddo + elseif(lakonl(7:7).eq.'B') then +! +! 3-noded beam element +! + indexe2d=indexe+20 + do j=1,3 + node2d=kon(indexe2d+j) + do l=1,8 + if(node3(l,j).ne.0) then + node3d=kon(indexe+node3(l,j)) + nodorig(node3d)=node2d + endif + enddo + enddo + else +! +! 8-noded 2D element +! + indexe2d=indexe+20 + do j=1,8 + node2d=kon(indexe2d+j) +c do l=1,3 +c if(node8(l,j).ne.0) then + node3d=kon(indexe+node8(1,j)) + nodorig(node3d)=node2d +c write(*,*) node3d,node2d + nodorig(node3d+1)=node2d +c write(*,*) node3d+1,node2d + nodorig(node3d+2)=node2d +c write(*,*) node3d+2,node2d +c endif +c enddo + enddo + endif + enddo +! +! storing the nodes (in C convention, i.e. starting with 0) +! in field nactdofinv +! + mt=mi(2)+1 + do i=1,nk + do j=0,mi(2) + if(nactdof(j,i).eq.0) cycle + nactdofinv(nactdof(j,i))=(nodorig(i)-1)*mt+j + enddo + enddo +c do i=1,25 +c write(*,*) i-1,nactdofinv(i),nactdofinv(i)/mt+1 +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/genran.f calculix-ccx-2.3/ccx_2.3/src/genran.f --- calculix-ccx-2.1/ccx_2.3/src/genran.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/genran.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,43 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine genran(iix,g,k) +! +! used in the Lanczos routines (cf. netlib CD) +! generates k random numbers between 0. and 1. from seed iix +! and stores them in g +! + integer iix,k + real*4 g(k) +! + i1=nint(iix*1974./2546.) + i2=nint(iix*235./2546.) + i3=nint(iix*337./2546.) +! +! initialisation of ranewr +! + call iniran(i1,i2,i3) +! +! repeatedly calling ranewr to generate k random numbers +! + do i=1,k + g(i)=ranewr() + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/gentiedmpc.f calculix-ccx-2.3/ccx_2.3/src/gentiedmpc.f --- calculix-ccx-2.1/ccx_2.3/src/gentiedmpc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/gentiedmpc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,777 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine gentiedmpc(tieset,ntie,itietri,ipkon,kon, + & lakon,set,istartset,iendset,ialset,cg,straight, + & koncont,co,xo,yo,zo,x,y,z,nx,ny,nz,nset, + & ifaceslave,istartfield,iendfield,ifield, + & ipompc,nodempc,coefmpc,nmpc,nmpctied,mpcfree,ikmpc,ilmpc, + & labmpc,ithermal,tietol,cfd,ncont,imastop) +! +! generates MPC's for the slave tied contact nodes +! + implicit none +! + character*1 c + character*3 m11,m2,m3 + character*5 p0,p1,p2,p3,p7,p9999 + character*8 lakon(*) + character*20 labmpc(*) + character*81 tieset(3,*),slavset,set(*) +! + integer ntie,nset,istartset(*),iendset(*),ialset(*), + & itietri(2,ntie),ipkon(*),kon(*),koncont(4,*),node, + & neigh(1),iflag,kneigh,i,j,k,l,isol,itri,ll,kflag,n,nx(*), + & ny(*),ipointer(1),nz(*),nstart,ifaceq(8,6),ifacet(6,4), + & ifacew1(4,5),ifacew2(8,5),nelem,jface,indexe,imastop(3,*), + & nnodelem,nface,nope,nodef(8),idof,kstart,kend,jstart,id, + & jend,ifield(*),istartfield(*),iendfield(*),ifaceslave(*), + & ipompc(*),nodempc(3,*),nmpc,nmpctied,mpcfree,ikmpc(*), + & ilmpc(*),ithermal(2),cfd,ncont,mpcfreeold,m,one,number_of_nodes, + & itriold,itrinew,ntriangle,ntriangle_,itriangle(100) +! + real*8 cg(3,*),straight(16,*),co(3,*),p(3), + & dist,xo(*),yo(*),zo(*),x(*),y(*),z(*),pl(3,8), + & ratio(8),xi,et,coefmpc(*),tietol(2,*),tolloc +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! +! opening a file to store the nodes which are not connected +! +c open(9,file='nodes_not_connected.fbd',status='unknown',err=51) +c close(9,status='delete',err=52) +c open(9,file='nodes_not_connected.fbd',status='unknown',err=51) + open(40,file='WarnNodeMissMasterIntersect.nam',status='unknown') + write(40,*) '*NSET,NSET=WarnNodeMissMasterIntersect' +! +! storing the triangulation of the master surfaces +! + open(70,file='TriMasterContactTie.frd',status='unknown') + c='C' + m11=' -1' + m2=' -2' + m3=' -3' + p0=' 0' + p1=' 1' + p2=' 2' + p3=' 3' + p7=' 7' + p9999=' 9999' + one=1 + write(70,'(a5,a1)') p1,c + write(70,'(a5,a1,67x,i1)') p2,c,one + number_of_nodes=0 + do i=1,itietri(2,ntie) + number_of_nodes=max(number_of_nodes,koncont(1,i)) + number_of_nodes=max(number_of_nodes,koncont(2,i)) + number_of_nodes=max(number_of_nodes,koncont(3,i)) + enddo + do i=1,number_of_nodes + write(70,'(a3,i10,1p,3e12.5)') m11,i,(co(j,i),j=1,3) + enddo + write(70,'(a3)') m3 + write(70,'(a5,a1,67x,i1)') p3,c,one + do i=1,itietri(2,ntie) + write(70,'(a3,i10,2a5)')m11,i,p7,p0 + write(70,'(a3,3i10)') m2,(koncont(j,i),j=1,3) + enddo + write(70,'(a3)') m3 + write(70,'(a5)') p9999 + close(70) +! + nmpctied=nmpc +! +! calculating a typical element size +! + tolloc=0.d0 + do i=1,ncont + tolloc=tolloc+dabs(straight(1,i)*cg(1,i)+ + & straight(2,i)*cg(2,i)+ + & straight(3,i)*cg(3,i)+ + & straight(4,i)) + enddo + tolloc=0.025*tolloc/ncont +! +! determining for which dofs MPC's have to be generated +! + if(cfd.eq.1) then + if(ithermal(2).le.1) then + kstart=1 + kend=4 + else + kstart=0 + kend=4 + endif + else + if(ithermal(2).le.1) then + kstart=1 + kend=3 + elseif(ithermal(2).eq.2) then + kstart=0 + kend=0 + else + kstart=0 + kend=3 + endif + endif +! +! maximum number of neighboring master triangles for a slave node +! + kflag=2 +! + do i=1,ntie + if(tieset(1,i)(81:81).ne.'T') cycle + iflag=0 + kneigh=1 + slavset=tieset(2,i) +! +! default tolerance if none is specified +! + if(tietol(1,i).lt.1.d-10) tietol(1,i)=tolloc +! +! determining the slave set +! + if(ifaceslave(i).eq.0) then +c ipos=index(slavset,' ') +c slavset(ipos:ipos)='S' + do j=1,nset + if(set(j).eq.slavset) then + exit + endif + enddo +c if(j.gt.nset) then +c write(*,*) +c & '*ERROR in gentiedmpc: tied contact slave set', +c & slavset +c write(*,*) ' does not exist' +c stop +c endif + jstart=istartset(j) + jend=iendset(j) + else + jstart=istartfield(i) + jend=iendfield(i) + endif +! + nstart=itietri(1,i)-1 + n=itietri(2,i)-nstart + if(n.lt.kneigh) kneigh=n + do j=1,n + xo(j)=cg(1,nstart+j) + x(j)=xo(j) + nx(j)=j + yo(j)=cg(2,nstart+j) + y(j)=yo(j) + ny(j)=j + zo(j)=cg(3,nstart+j) + z(j)=zo(j) + nz(j)=j + enddo + call dsort(x,nx,n,kflag) + call dsort(y,ny,n,kflag) + call dsort(z,nz,n,kflag) +! + do j=jstart,jend + if(((ifaceslave(i).eq.0).and.(ialset(j).gt.0)).or. + & (ifaceslave(i).eq.1)) then +! + if(ifaceslave(i).eq.0) then + node=ialset(j) + else + node=ifield(j) + endif +! +c write(*,*) 'gentiedmpc ',j,node + do k=1,3 + p(k)=co(k,node) + enddo +! +! determining the kneigh neighboring master contact +! triangle centers of gravity +! + call near3d(xo,yo,zo,x,y,z,nx,ny,nz,p(1),p(2),p(3), + & n,neigh,kneigh) +! + isol=0 +! +c do k=1,kneigh +c itri=neigh(k)+itietri(1,i)-1 +c! +c totdist(k)=0.d0 +c! +c do l=1,3 +c ll=4*l-3 +c dist=straight(ll,itri)*p(1)+ +c & straight(ll+1,itri)*p(2)+ +c & straight(ll+2,itri)*p(3)+ +c & straight(ll+3,itri) +c if(dist.gt.0.d0) then +c totdist(k)=totdist(k)+dist +c endif +c enddo +cc write(*,*) 'gentiedmpc ',k,itri,koncont(4,itri), +cc & totdist(k) +c totdist(k)=dsqrt(totdist(k)**2+ +c & (straight(13,itri)*p(1)+ +c & straight(14,itri)*p(2)+ +c & straight(15,itri)*p(3)+ +c & straight(16,itri))**2) +cc cgdist=dsqrt((p(1)-cg(1,itri))**2+ +cc & (p(2)-cg(2,itri))**2+ +cc & (p(3)-cg(3,itri))**2) +cc write(*,*) 'gentiedmpc ',k,itri,koncont(4,itri), +cc & totdist(k),cgdist +c! +c if(totdist(k).le.tietol(1,i)) then +c isol=k +c exit +c endif +c enddo +! + isol=0 +! + itriold=0 + itri=neigh(1)+itietri(1,i)-1 + ntriangle=0 + ntriangle_=100 +! + loop1: do + do l=1,3 + ll=4*l-3 + dist=straight(ll,itri)*p(1)+ + & straight(ll+1,itri)*p(2)+ + & straight(ll+2,itri)*p(3)+ + & straight(ll+3,itri) +c if(dist.gt.1.d-6) then + if(dist.gt.tietol(1,i)) then + itrinew=imastop(l,itri) + if(itrinew.eq.0) then +c write(*,*) '**border reached' + isol=-1 + exit loop1 + elseif(itrinew.eq.itriold) then +c write(*,*) '**solution in between triangles' + isol=itri + exit loop1 + else + call nident(itriangle,itrinew,ntriangle,id) + if(id.gt.0) then + if(itriangle(id).eq.itrinew) then +c write(*,*) '**circular path; no solution' + isol=-2 + exit loop1 + endif + endif + ntriangle=ntriangle+1 + if(ntriangle.gt.ntriangle_) then +c write(*,*) '**too many iterations' + isol=-3 + exit loop1 + endif + do k=ntriangle,id+2,-1 + itriangle(k)=itriangle(k-1) + enddo + itriangle(id+1)=itrinew + itriold=itri + itri=itrinew + cycle loop1 + endif + elseif(l.eq.3) then +c write(*,*) '**regular solution' + isol=itri + exit loop1 + endif + enddo + enddo loop1 +! +! if an opposite triangle is found: check the distance +! perpendicular to the triangle +! + if(isol.gt.0) then + dist=dsqrt(straight(13,itri)*p(1)+ + & straight(14,itri)*p(2)+ + & straight(15,itri)*p(3)+ + & straight(16,itri))**2 + if(dist.gt.tietol(1,i)) isol=0 + endif +! + if(isol.le.0) then +! +! no MPC is generated +! + write(*,*) '*WARNING in gentiedmpc: no tied MPC' + write(*,*) ' generated for node ',node + if(isol.eq.0) then + write(*,*) ' master face too far away' + write(*,*) ' distance: ',dist + write(*,*) ' tolerance: ',tietol(1,i) + else + write(*,*) ' no corresponding master face' + write(*,*) ' found; tolerance: ', + & tietol(1,i) + endif + write(40,*) node + else +! + nelem=int(koncont(4,itri)/10.d0) + jface=koncont(4,itri)-10*nelem +! + indexe=ipkon(nelem) + if(lakon(nelem)(4:4).eq.'2') then + nnodelem=8 + nface=6 + elseif(lakon(nelem)(4:4).eq.'8') then + nnodelem=4 + nface=6 + elseif(lakon(nelem)(4:5).eq.'10') then + nnodelem=6 + nface=4 + elseif(lakon(nelem)(4:4).eq.'4') then + nnodelem=3 + nface=4 + elseif(lakon(nelem)(4:5).eq.'15') then + if(jface.le.2) then + nnodelem=6 + else + nnodelem=8 + endif + nface=5 + nope=15 + elseif(lakon(nelem)(4:4).eq.'6') then + if(jface.le.2) then + nnodelem=3 + else + nnodelem=4 + endif + nface=5 + nope=6 + else + cycle + endif +! +! determining the nodes of the face +! + if(nface.eq.4) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacet(k,jface)) + enddo + elseif(nface.eq.5) then + if(nope.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew1(k,jface)) + enddo + elseif(nope.eq.15) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew2(k,jface)) + enddo + endif + elseif(nface.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifaceq(k,jface)) + enddo + endif +! +! attaching the node with coordinates in p +! to the face +! + do k=1,nnodelem + do l=1,3 + pl(l,k)=co(l,nodef(k)) + enddo + enddo + call attach(pl,p,nnodelem,ratio,dist,xi,et) + do k=1,3 + co(k,node)=p(k) + enddo +! +! generating MPC's +! + do l=kstart,kend + idof=8*(node-1)+l + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*WARNING in gentiedmpc:' + write(*,*) ' DOF ',l,' of node ', + & node,' is not active;' + write(*,*) ' no tied constraint ', + & 'is generated' + write(40,*) node + cycle + endif + endif +! + nmpc=nmpc+1 + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree +! +! updating ikmpc and ilmpc +! + do m=nmpc,id+2,-1 + ikmpc(m)=ikmpc(m-1) + ilmpc(m)=ilmpc(m-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=l + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gentiedmpc: increase memmpc_' + stop + endif + do k=1,nnodelem + nodempc(1,mpcfree)=nodef(k) + nodempc(2,mpcfree)=l + coefmpc(mpcfree)=-ratio(k) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gentiedmpc: increase memmpc_' + stop + endif + enddo + nodempc(3,mpcfreeold)=0 + +c call writempc(ipompc,nodempc,coefmpc,labmpc,nmpc) + enddo +! + endif +! + else + node=ialset(j-2) + do + node=node-ialset(j) + if(node.ge.ialset(j-1)) exit +! + do k=1,3 + p(k)=co(k,node) + enddo +! +! determining the kneigh neighboring master contact +! triangle centers of gravity +! + call near3d(xo,yo,zo,x,y,z,nx,ny,nz,p(1),p(2),p(3), + & n,neigh,kneigh) +! + isol=0 +! +c do k=1,kneigh +c itri=neigh(k)+itietri(1,i)-1 +c! +c totdist(k)=0.d0 +c! +c do l=1,3 +c ll=4*l-3 +c dist=straight(ll,itri)*p(1)+ +c & straight(ll+1,itri)*p(2)+ +c & straight(ll+2,itri)*p(3)+ +c & straight(ll+3,itri) +c if(dist.gt.0.d0) then +c totdist(k)=totdist(k)+dist +c endif +c enddo +cc write(*,*) 'gentiedmpc ',k,itri,koncont(4,itri), +cc & totdist(k) +c totdist(k)=dsqrt(totdist(k)**2+ +c & (straight(13,itri)*p(1)+ +c & straight(14,itri)*p(2)+ +c & straight(15,itri)*p(3)+ +c & straight(16,itri))**2) +cc cgdist=dsqrt((p(1)-cg(1,itri))**2+ +cc & (p(2)-cg(2,itri))**2+ +cc & (p(3)-cg(3,itri))**2) +cc write(*,*) 'gentiedmpc ',k,itri,koncont(4,itri), +cc & totdist(k),cgdist +c! +c if(totdist(k).le.tietol(1,i)) then +c isol=k +c exit +c endif +c enddo +! + isol=0 +! + itriold=0 + itri=neigh(1)+itietri(1,i)-1 + ntriangle=0 + ntriangle_=100 +! + loop2: do + do l=1,3 + ll=4*l-3 + dist=straight(ll,itri)*p(1)+ + & straight(ll+1,itri)*p(2)+ + & straight(ll+2,itri)*p(3)+ + & straight(ll+3,itri) +c if(dist.gt.1.d-6) then + if(dist.gt.tietol(1,i)) then + itrinew=imastop(l,itri) + if(itrinew.eq.0) then +c write(*,*) '**border reached' + isol=-1 + exit loop2 + elseif(itrinew.eq.itriold) then +c write(*,*) '**solution in between triangles' + isol=itri + exit loop2 + else + call nident(itriangle,itrinew,ntriangle,id) + if(id.gt.0) then + if(itriangle(id).eq.itrinew) then +c write(*,*) '**circular path; no solution' + isol=-2 + exit loop2 + endif + endif + ntriangle=ntriangle+1 + if(ntriangle.gt.ntriangle_) then +c write(*,*) '**too many iterations' + isol=-3 + exit loop2 + endif + do k=ntriangle,id+2,-1 + itriangle(k)=itriangle(k-1) + enddo + itriangle(id+1)=itrinew + itriold=itri + itri=itrinew + cycle loop2 + endif + elseif(l.eq.3) then +c write(*,*) '**regular solution' + isol=itri + exit loop2 + endif + enddo + enddo loop2 +! +! if an opposite triangle is found: check the distance +! perpendicular to the triangle +! + if(isol.gt.0) then + dist=dsqrt(straight(13,itri)*p(1)+ + & straight(14,itri)*p(2)+ + & straight(15,itri)*p(3)+ + & straight(16,itri))**2 + if(dist.gt.tietol(1,i)) isol=0 + endif +! +! check whether distance is larger than tietol(1,i): +! no element is generated +! + if(isol.eq.0) then +! +! no MPC is generated +! + write(*,*) '*WARNING in gentiedmpc: no tied MPC' + write(*,*) ' generated for node ',node + if(isol.eq.0) then + write(*,*) ' master face too far away' + write(*,*) ' distance: ',dist + write(*,*) ' tolerance: ',tietol(1,i) + else + write(*,*) ' no corresponding master face' + write(*,*) ' found; tolerance: ', + & tietol(1,i) + endif + write(40,*) node + else +! + nelem=int(koncont(4,itri)/10.d0) + jface=koncont(4,itri)-10*nelem +! + indexe=ipkon(nelem) + if(lakon(nelem)(4:4).eq.'2') then + nnodelem=8 + nface=6 + elseif(lakon(nelem)(4:4).eq.'8') then + nnodelem=4 + nface=6 + elseif(lakon(nelem)(4:5).eq.'10') then + nnodelem=6 + nface=4 + elseif(lakon(nelem)(4:4).eq.'4') then + nnodelem=3 + nface=4 + elseif(lakon(nelem)(4:5).eq.'15') then + if(jface.le.2) then + nnodelem=6 + else + nnodelem=8 + endif + nface=5 + nope=15 + elseif(lakon(nelem)(4:4).eq.'6') then + if(jface.le.2) then + nnodelem=3 + else + nnodelem=4 + endif + nface=5 + nope=6 + else + cycle + endif +! +! determining the nodes of the face +! + if(nface.eq.4) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacet(k,jface)) + enddo + elseif(nface.eq.5) then + if(nope.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew1(k,jface)) + enddo + elseif(nope.eq.15) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew2(k,jface)) + enddo + endif + elseif(nface.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifaceq(k,jface)) + enddo + endif +! +! attaching the node with coordinates in p +! to the face +! + do k=1,nnodelem + do l=1,3 + pl(l,k)=co(l,nodef(k)) + enddo + enddo + call attach(pl,p,nnodelem,ratio,dist,xi,et) + do k=1,3 + co(k,node)=p(k) + enddo +! +! generating MPC's +! + do l=kstart,kend + idof=8*(node-1)+l + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*WARNING in gentiedmpc:' + write(*,*) ' DOF ',l,' of node ', + & node,' is not active;' + write(*,*) ' no tied constraint ', + & 'is generated' + write(40,*) node + cycle + endif + endif +! + nmpc=nmpc+1 + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree +! +! updating ikmpc and ilmpc +! + do m=nmpc,id+2,-1 + ikmpc(m)=ikmpc(m-1) + ilmpc(m)=ilmpc(m-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=l + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gentiedmpc: increase memmpc_' + stop + endif + do k=1,nnodelem + nodempc(1,mpcfree)=nodef(k) + nodempc(2,mpcfree)=l + coefmpc(mpcfree)=-ratio(k) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) + & '*ERROR in gentiedmpc: increase memmpc_' + stop + endif + enddo + nodempc(3,mpcfreeold)=0 + enddo + endif +! + enddo + endif + enddo + enddo +! +! number of tied MPC's +! + nmpctied=nmpc-nmpctied +! + close(40) +! + return +! +c 51 write(*,*) '*ERROR in openfile: could not open file ', +c & 'nodes_not_connected.fbd' +c stop +c 52 write(*,*) '*ERROR in openfile: could not delete file ', +c & 'nodes_not_connected.fbd' +c stop +! + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/getnewline.f calculix-ccx-2.3/ccx_2.3/src/getnewline.f --- calculix-ccx-2.1/ccx_2.3/src/getnewline.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/getnewline.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,86 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine getnewline(inpc,textpart,istat,n,key,iline, + & ipol,inl,ipoinp,inp,ipoinpc) +! + implicit none +! + integer nentries + parameter(nentries=14) +! +! parser for the input file (original order) +! + integer istat,n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*), + & ipoinpc(0:*),i,j +! + character*1 inpc(*) + character*132 text,textpart(16) +! +! reading a new line +! + if(iline.eq.inp(2,inl)) then + if(inp(3,inl).eq.0) then +c ipoinp(1,ipol)=0 + do + ipol=ipol+1 + if(ipol.gt.nentries) then + istat=-1 + return + elseif(ipoinp(1,ipol).ne.0) then + exit + endif + enddo + inl=ipoinp(1,ipol) + iline=inp(1,inl) + else + inl=inp(3,inl) + iline=inp(1,inl) + endif + else + iline=iline+1 + endif +c text=inpc(iline) + j=0 + do i=ipoinpc(iline-1)+1,ipoinpc(iline) + j=j+1 + text(j:j)=inpc(i) + enddo + text(j+1:j+1)=' ' +! + istat=0 + key=0 +! +! only free format is supported +! + if((text(1:1).eq.'*').and.(text(2:2).ne.'*')) then + key=1 + endif +! +c write(*,*) text + call splitline(text,textpart,n) +c write(*,*) text +c write(*,*) textpart(1) +c write(*,*) textpart(2) +c write(*,*) textpart(3) +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/graph.f calculix-ccx-2.3/ccx_2.3/src/graph.f --- calculix-ccx-2.1/ccx_2.3/src/graph.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/graph.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,97 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine graph(n,ne,inpn,npn,xnpn,iadj,adj,xadj) +! +! Sloan routine (Int.J.Num.Meth.Engng 28, 2651-2679(1989)) +! + integer n,ne,nodej,nodek,mstrt,iadj,i,j,k,jstrt,jstop,lstrt,lstop, + & l,nen1,mstop,m,inpn,xnpn(ne+1),npn(inpn),adj(iadj),xadj(n+1) +! + do 5 i=1,iadj + adj(i)=0 + 5 continue + do 10 i=1,n + xadj(i)=0 + 10 continue +! + do 30 i=1,ne + jstrt=xnpn(i) + jstop=xnpn(i+1)-1 + nen1=jstop-jstrt + do 20 j=jstrt,jstop + nodej=npn(j) + xadj(nodej)=xadj(nodej)+nen1 + 20 continue + 30 continue +! + l=1 + do 40 i=1,n + l=l+xadj(i) + xadj(i)=l-xadj(i) + 40 continue + xadj(n+1)=l +! + do 90 i=1,ne + jstrt=xnpn(i) + jstop=xnpn(i+1)-1 + do 80 j=jstrt,jstop-1 + nodej=npn(j) + lstrt=xadj(nodej) + lstop=xadj(nodej+1)-1 + do 70 k=j+1,jstop + nodek=npn(k) + do 50 l=lstrt,lstop + if(adj(l).eq.nodek) go to 70 + if(adj(l).eq.0) go to 55 + 50 continue + write(6,1000) + stop + 55 continue + adj(l)=nodek + mstrt=xadj(nodek) + mstop=xadj(nodek+1)-1 + do 60 m=mstrt,mstop + if(adj(m).eq.0) go to 65 + 60 continue + write(6,1000) + stop + 65 continue + adj(m)=nodej + 70 continue + 80 continue + 90 continue +! + k=0 + jstrt=1 + do 110 i=1,n + jstop=xadj(i+1)-1 + do 100 j=jstrt,jstop + if(adj(j).eq.0) go to 105 + k=k+1 + adj(k)=adj(j) + 100 continue + 105 continue + xadj(i+1)=k+1 + jstrt=jstop+1 + 110 continue +! + 1000 format(//,1x,'***error in graph***', + & //,1x,'cannot assemble node adjacency list', + & //,1x,'check npn and xnpn arrays') + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/hcrit.f calculix-ccx-2.3/ccx_2.3/src/hcrit.f --- calculix-ccx-2.1/ccx_2.3/src/hcrit.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/hcrit.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,51 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine hcrit(xflow,rho,b,theta,dg,sqrts0,hk) +! +! determine the critical depth +! + implicit none +! + real*8 xflow,rho,b,dg,sqrts0,hk,theta,tth,c1,xflow2, + & A,dBBdh,dAdh,BB,dhk +! + hk=((xflow/(rho*b))**2/(dg*sqrts0))**(1.d0/3.d0) +! + if(dabs(theta).lt.1.d-10) return +! +! critical depth for trapezoid, non-rectangular cross section +! + tth=dtan(theta) + c1=rho*rho*dg*sqrts0 + xflow2=xflow*xflow +! + do + A=hk*(b+hk*tth) + dBBdh=2.d0*tth + dAdh=b+hk*dBBdh + BB=dAdh + dhk=(xflow2*BB-c1*A**3)/(xflow2*dBBdh-3.d0*c1*A*A*dAdh) + if(dabs(dhk)/dhk.lt.1.d-3) exit + hk=hk-dhk + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/headings.f calculix-ccx-2.3/ccx_2.3/src/headings.f --- calculix-ccx-2.1/ccx_2.3/src/headings.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/headings.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,48 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine headings(inpc,textpart,istat,n,iline,ipol,inl,ipoinp, + & inp,ipoinpc) +! +! reading the input deck: *HEADING +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer istat,n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*), + & ipoinpc(0:*),i +! + do i=2,n + write(*,*) + & '*WARNING in headings: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + enddo +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((key.ne.0).or.(istat.lt.0))exit + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/heattransfers.f calculix-ccx-2.3/ccx_2.3/src/heattransfers.f --- calculix-ccx-2.1/ccx_2.3/src/heattransfers.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/heattransfers.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,273 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine heattransfers(inpc,textpart,nmethod,iperturb,isolver, + & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline,ipol, + & inl,ipoinp,inp,alpha,mei,fei,ipoinpc,ctrl,ttime) +! +! reading the input deck: *HEAT TRANSFER +! +! isolver=0: SPOOLES +! 2: iterative solver with diagonal scaling +! 3: iterative solver with Cholesky preconditioning +! 4: sgi solver +! 5: TAUCS +! 7: pardiso +! + implicit none +! + logical timereset +! + character*1 inpc(*) + character*20 solver + character*132 textpart(16) +! + integer nmethod,iperturb,isolver,istep,istat,n,key,i,idrct,nev, + & ithermal,iline,ipol,inl,ipoinp(2,*),inp(3,*),mei(4),ncv,mxiter, + & ipoinpc(0:*),idirect +! + real*8 tinc,tper,tmin,tmax,alpha,fei(3),tol,fmin,fmax,ctrl(*), + & ttime +! + tmin=0.d0 + tmax=0.d0 + nmethod=4 + alpha=0.d0 + mei(4)=0 + timereset=.false. +! + if(iperturb.eq.0) then + iperturb=2 + elseif((iperturb.eq.1).and.(istep.gt.1)) then + write(*,*) '*ERROR in heattransfers: perturbation analysis is' + write(*,*) ' not provided in a *HEAT TRANSFER step.' + stop + endif +! + if(istep.lt.1) then + write(*,*) '*ERROR in heattransfers: *HEAT TRANSFER can only' + write(*,*) ' be used within a STEP' + stop + endif +! +! default solver +! + solver=' ' + if(isolver.eq.0) then + solver(1:7)='SPOOLES' + elseif(isolver.eq.2) then + solver(1:16)='ITERATIVESCALING' + elseif(isolver.eq.3) then + solver(1:17)='ITERATIVECHOLESKY' + elseif(isolver.eq.4) then + solver(1:3)='SGI' + elseif(isolver.eq.5) then + solver(1:5)='TAUCS' + elseif(isolver.eq.7) then + solver(1:7)='PARDISO' + endif +! + idirect=2 + do i=2,n + if(textpart(i)(1:7).eq.'SOLVER=') then + read(textpart(i)(8:27),'(a20)') solver + elseif((textpart(i)(1:6).eq.'DIRECT').and. + & (textpart(i)(1:9).ne.'DIRECT=NO')) then + idirect=1 + elseif(textpart(i)(1:9).eq.'DIRECT=NO') then + idirect=0 + elseif(textpart(i)(1:11).eq.'STEADYSTATE') then + nmethod=1 + elseif(textpart(i)(1:9).eq.'FREQUENCY') then + nmethod=2 + elseif(textpart(i)(1:12).eq.'MODALDYNAMIC') then + iperturb=0 + elseif(textpart(i)(1:11).eq.'STORAGE=YES') then + mei(4)=1 + elseif(textpart(i)(1:7).eq.'DELTMX=') then + read(textpart(i)(8:27),'(f20.0)',iostat=istat) ctrl(27) + elseif(textpart(i)(1:9).eq.'TIMERESET') then + timereset=.true. + else + write(*,*) + & '*WARNING in heattransfers: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo + if(nmethod.eq.1) ctrl(27)=1.d30 +! +! default for modal dynamic calculations is DIRECT, +! for static or dynamic calculations DIRECT=NO +! + if(iperturb.eq.0) then + idrct=1 + if(idirect.eq.0)idrct=0 + else + idrct=0 + if(idirect.eq.1)idrct=1 + endif +! + if((ithermal.eq.0).and.(nmethod.ne.1).and. + & (nmethod.ne.2).and.(iperturb.ne.0)) then + write(*,*) '*ERROR in heattransfers: please define initial ' + write(*,*) ' conditions for the temperature' + stop + else + ithermal=2 + endif +! + if((nmethod.ne.2).and.(iperturb.ne.0)) then +! +! static or dynamic thermal analysis +! + if(solver(1:7).eq.'SPOOLES') then + isolver=0 + elseif(solver(1:16).eq.'ITERATIVESCALING') then + isolver=2 + elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then + isolver=3 + elseif(solver(1:3).eq.'SGI') then + isolver=4 + elseif(solver(1:5).eq.'TAUCS') then + isolver=5 + elseif(solver(1:7).eq.'PARDISO') then + isolver=7 + else + write(*,*) '*WARNING in heattransfers: unknown solver;' + write(*,*) ' the default solver is used' + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + if(iperturb.ge.2) then + write(*,*) '*WARNING in heattransfers: a nonlinear geomet + &ric analysis is requested' + write(*,*) ' but no time increment nor step is sp + &ecified' + write(*,*) ' the defaults (1,1) are used' + tinc=1.d0 + tper=1.d0 + tmin=1.d-5 + tmax=1.d+30 + endif + if(timereset)ttime=ttime-tper + return + endif +! + read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) tmin + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(4)(1:20),'(f20.0)',iostat=istat) tmax + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! + if(tinc.le.0.d0) then + write(*,*) '*ERROR in heattransfers: initial increment size + &is negative' + endif + if(tper.le.0.d0) then + write(*,*) '*ERROR in heattransfers: step size is negative' + endif + if(tinc.gt.tper) then + write(*,*) '*ERROR in heattransfers: initial increment size + &exceeds step size' + endif +! + if(idrct.ne.1) then + if(dabs(tmin).lt.1.d-10) then + tmin=min(tinc,1.d-5*tper) + endif + if(dabs(tmax).lt.1.d-10) then + tmax=1.d+30 + endif + endif + elseif(nmethod.eq.2) then +! +! thermal eigenmode analysis +! + iperturb=0 +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*)'*ERROR in heattransfers: definition not complete' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + read(textpart(1)(1:10),'(i10)',iostat=istat) nev + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(nev.le.0) then + write(*,*) '*ERROR in frequencies: less than 1 eigenvalue re + &quested' + stop + endif + tol=1.d-2 + ncv=4*nev + ncv=ncv+nev + mxiter=1000 + read(textpart(2)(1:20),'(f20.0)',iostat=istat) fmin + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) fmax + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! + mei(1)=nev + mei(2)=ncv + mei(3)=mxiter + fei(1)=tol + fei(2)=fmin + fei(3)=fmax + else +! +! modal dynamic analysis for variables which satisfy the +! Helmholtz equation +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*)'*ERROR in heattransfers: definition not complete' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + endif +! + if(timereset)ttime=ttime-tper +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/hgforce.f calculix-ccx-2.3/ccx_2.3/src/hgforce.f --- calculix-ccx-2.1/ccx_2.3/src/hgforce.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/hgforce.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,53 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine hgforce (fn,elas,a,gs,vl,mi,konl) +! +! hourglass control forces for 8-node solid mean strain element +! +! Reference: Flanagan, D.P., Belytschko, T.; "Uniform strain hexahedron +! and quadrilateral with orthogonal Hourglass control". Int. J. Num. +! Meth. Engg., Vol. 17, 679-706, 1981. +! + implicit none + integer i,j,k,mi(2),konl(20) + real*8 gs(8,4),a,elas(1),ahr + real*8 vl(0:mi(2),20), fn(0:mi(2),*) + real*8 hglf(3,4) +! + ahr=elas(1)*a +c write(6,*) "force:", ahr +! + do i=1,3 + do k=1,4 + hglf(i,k)=0.0d0 + do j=1,8 + hglf(i,k)=hglf(i,k)+gs(j,k)*vl(i,j) + enddo + hglf(i,k)=hglf(i,k)*ahr + enddo + enddo + do i=1,3 + do j=1,8 + do k=1,4 + fn(i,konl(j))=fn(i,konl(j))+hglf(i,k)*gs(j,k) + enddo + enddo + enddo + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/hgstiffness.f calculix-ccx-2.3/ccx_2.3/src/hgstiffness.f --- calculix-ccx-2.1/ccx_2.3/src/hgstiffness.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/hgstiffness.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,51 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine hgstiffness(s,elas,a,gs) +! +! hourglass control stiffness for 8-node solid mean strain element +! +! Reference: Flanagan, D.P., Belytschko, T.; "Uniform strain hexahedron +! and quadrilateral with orthogonal Hourglass control". Int. J. Num. +! Meth. Engg., Vol. 17, 679-706, 1981. +! + implicit none + integer ii1,jj1,ii,jj,m1 + real*8 s(60,60),gs(8,4),a,elas(1),hgls,ahr +! + ahr=elas(1)*a +c write(6,*) "stiffness:", ahr +! + jj1=1 + do jj=1,8 + ii1=1 + do ii=1,jj + hgls=0.0d0 + do m1=1,4 + hgls=hgls+gs(jj,m1)*gs(ii,m1) + enddo + hgls=hgls*ahr + s(ii1,jj1)=s(ii1,jj1)+hgls + s(ii1+1,jj1+1)=s(ii1+1,jj1+1)+hgls + s(ii1+2,jj1+2)=s(ii1+2,jj1+2)+hgls + ii1=ii1+3 + enddo + jj1=jj1+3 + enddo + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/hns.f calculix-ccx-2.3/ccx_2.3/src/hns.f --- calculix-ccx-2.1/ccx_2.3/src/hns.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/hns.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,65 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine hns(b,theta,rho,dg,sqrts0,xflow,h1,h2) +! +! determine the flow depth h2 downstream of a hydraulic jump, +! corresponding to a upstream flow depth of h1 +! + implicit none +! + real*8 b,rho,dg,sqrts0,xflow,h1,h2,c2,f,df,dh2,hk, + & xflow2,tth,A1,yg1,A2,yg2,dA2dh2,dyg2dh2,theta +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) +! + h2=h1*(-1.d0+dsqrt(1.d0+8.d0*(hk/h1)**3))/2.d0 +! + if(dabs(theta).lt.1.d-10) return +! +! hns for a trapezoid, non-rectangular cross section +! + c2=rho*rho*dg*sqrts0 + xflow2=xflow*xflow + tth=dtan(theta) + A1=h1*(b+h1*tth) + yg1=h1*(3.d0*b+2.d0*h1*tth)/(6.d0*(b+h1*tth)) +! +! Newton-Raphson iterations +! + do + A2=h2*(b+h2*tth) + yg2=h2*(3.d0*b+2.d0*h2*tth)/(6.d0*(b+h2*tth)) + dA2dh2=b+2.d0*h2*tth + dyg2dh2=((3.d0*b+4.d0*h2*tth)*(b+tth) + & -tth*h2*(3.d0*b+2.d0*h2*tth))/ + & (6.d0*(b+h2*tth)**2) + f=A2*xflow2+c2*(A1*A1*A2*yg1-A1*A2*A2*yg2)-A1*xflow2 + df=dA2dh2*xflow2+c2*(A1*A1*yg1*dA2dh2-2.d0*A1*A2*dA2dh2*yg2 + & -A1*A2*A2*dyg2dh2) + dh2=f/df + if(dabs(dh2)/h2.lt.1.d-3) exit + h2=h2-dh2 + enddo +! + write(*,*) 'hns ','h1= ',h1,'h2= ',h2,'hk= ',hk +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/hybsvd.f calculix-ccx-2.3/ccx_2.3/src/hybsvd.f --- calculix-ccx-2.1/ccx_2.3/src/hybsvd.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/hybsvd.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1010 @@ + SUBROUTINE HYBSVD(NA, NU, NV, NZ, NB, M, N, A, W, MATU, U, MATV, + * V, Z, B, IRHS, IERR, RV1) + INTEGER NA, NU, NV, NZ, M, N, IRHS, IERR, MIN0 + REAL*8 A(NA,1), W(1), U(NU,1), V(NV,1), Z(NZ,1), B(NB,IRHS) + REAL*8 RV1(1) + LOGICAL MATU, MATV +C +C THIS ROUTINE IS A MODIFICATION OF THE GOLUB-REINSCH PROCEDURE (1) +C T +C FOR COMPUTING THE SINGULAR VALUE DECOMPOSITION A = UWV OF A +C REAL M BY N RECTANGULAR MATRIX. U IS M BY MIN(M,N) CONTAINING +C THE LEFT SINGULAR VECTORS, W IS A MIN(M,N) BY MIN(M,N) DIAGONAL +C MATRIX CONTAINING THE SINGULAR VALUES, AND V IS N BY MIN(M,N) +C CONTAINING THE RIGHT SINGULAR VECTORS. +C +C THE ALGORITHM IMPLEMENTED IN THIS +C ROUTINE HAS A HYBRID NATURE. WHEN M IS APPROXIMATELY EQUAL TO N, +C THE GOLUB-REINSCH ALGORITHM IS USED, BUT WHEN EITHER OF THE RATIOS +C M/N OR N/M IS GREATER THAN ABOUT 2, +C A MODIFIED VERSION OF THE GOLUB-REINSCH +C ALGORITHM IS USED. THIS MODIFIED ALGORITHM FIRST TRANSFORMS A +C T +C INTO UPPER TRIANGULAR FORM BY HOUSEHOLDER TRANSFORMATIONS L +C AND THEN USES THE GOLUB-REINSCH ALGORITHM TO FIND THE SINGULAR +C VALUE DECOMPOSITION OF THE RESULTING UPPER TRIANGULAR MATRIX R. +C WHEN U IS NEEDED EXPLICITLY IN THE CASE M.GE.N (OR V IN THE CASE +C M.LT.N), AN EXTRA ARRAY Z (OF SIZE AT LEAST +C MIN(M,N)**2) IS NEEDED, BUT OTHERWISE Z IS NOT REFERENCED +C AND NO EXTRA STORAGE IS REQUIRED. THIS HYBRID METHOD +C SHOULD BE MORE EFFICIENT THAN THE GOLUB-REINSCH ALGORITHM WHEN +C M/N OR N/M IS LARGE. FOR DETAILS, SEE (2). +C +C WHEN M .GE. N, +C HYBSVD CAN ALSO BE USED TO COMPUTE THE MINIMAL LENGTH LEAST +C SQUARES SOLUTION TO THE OVERDETERMINED LINEAR SYSTEM A*X=B. +C IF M .LT. N (I.E. FOR UNDERDETERMINED SYSTEMS), THE RHS B +C IS NOT PROCESSED. +C +C NOTICE THAT THE SINGULAR VALUE DECOMPOSITION OF A MATRIX +C IS UNIQUE ONLY UP TO THE SIGN OF THE CORRESPONDING COLUMNS +C OF U AND V. +C +C THIS ROUTINE HAS BEEN CHECKED BY THE PFORT VERIFIER (3) FOR +C ADHERENCE TO A LARGE, CAREFULLY DEFINED, PORTABLE SUBSET OF +C AMERICAN NATIONAL STANDARD FORTRAN CALLED PFORT. +C +C REFERENCES: +C +C (1) GOLUB,G.H. AND REINSCH,C. (1970) 'SINGULAR VALUE +C DECOMPOSITION AND LEAST SQUARES SOLUTIONS,' +C NUMER. MATH. 14,403-420, 1970. +C +C (2) CHAN,T.F. (1982) 'AN IMPROVED ALGORITHM FOR COMPUTING +C THE SINGULAR VALUE DECOMPOSITION,' ACM TOMS, VOL.8, +C NO. 1, MARCH, 1982. +C +C (3) RYDER,B.G. (1974) 'THE PFORT VERIFIER,' SOFTWARE - +C PRACTICE AND EXPERIENCE, VOL.4, 359-377, 1974. +C +C ON INPUT: +C +C NA MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETER A AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. NOTE THAT NA MUST BE AT LEAST +C AS LARGE AS M. +C +C NU MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY U AS DECLARED IN THE CALLING PROGRAM DIMENSION +C STATEMENT. NU MUST BE AT LEAST AS LARGE AS M. +C +C NV MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETER V AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. NV MUST BE AT LEAST AS LARGE AS N. +C +C NZ MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETER Z AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. NOTE THAT NZ MUST BE AT LEAST +C AS LARGE AS MIN(M,N). +C +C NB MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETER B AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. NB MUST BE AT LEAST AS LARGE AS M. +C +C M IS THE NUMBER OF ROWS OF A (AND U). +C +C N IS THE NUMBER OF COLUMNS OF A (AND NUMBER OF ROWS OF V). +C +C A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED. +C +C B CONTAINS THE IRHS RIGHT-HAND-SIDES OF THE OVERDETERMINED +C LINEAR SYSTEM A*X=B. IF IRHS .GT. 0 AND M .GE. N, +C THEN ON OUTPUT, THE FIRST N COMPONENTS OF THESE IRHS COLUMNS +C T +C WILL CONTAIN U B. THUS, TO COMPUTE THE MINIMAL LENGTH LEAST +C + +C SQUARES SOLUTION, ONE MUST COMPUTE V*W TIMES THE COLUMNS OF +C + + +C B, WHERE W IS A DIAGONAL MATRIX, W (I)=0 IF W(I) IS +C NEGLIGIBLE, OTHERWISE IS 1/W(I). IF IRHS=0 OR M.LT.N, +C B IS NOT REFERENCED. +C +C IRHS IS THE NUMBER OF RIGHT-HAND-SIDES OF THE OVERDETERMINED +C SYSTEM A*X=B. IRHS SHOULD BE SET TO ZERO IF ONLY THE SINGULAR +C VALUE DECOMPOSITION OF A IS DESIRED. +C +C MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE +C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. +C +C MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE +C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. +C +C WHEN HYBSVD IS USED TO COMPUTE THE MINIMAL LENGTH LEAST +C SQUARES SOLUTION TO AN OVERDETERMINED SYSTEM, MATU SHOULD +C BE SET TO .FALSE. , AND MATV SHOULD BE SET TO .TRUE. . +C +C ON OUTPUT: +C +C A IS UNALTERED (UNLESS OVERWRITTEN BY U OR V). +C +C W CONTAINS THE (NON-NEGATIVE) SINGULAR VALUES OF A (THE +C DIAGONAL ELEMENTS OF W). THEY ARE SORTED IN DESCENDING +C ORDER. IF AN ERROR EXIT IS MADE, THE SINGULAR VALUES +C SHOULD BE CORRECT AND SORTED FOR INDICES IERR+1,...,MIN(M,N). +C +C U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE +C DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE. IF MATU IS +C FALSE, THEN U IS EITHER USED AS A TEMPORARY STORAGE (IF +C M .GE. N) OR NOT REFERENCED (IF M .LT. N). +C U MAY COINCIDE WITH A IN THE CALLING SEQUENCE. +C IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING +C TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT. +C +C V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF +C MATV HAS BEEN SET TO .TRUE. IF MATV IS +C FALSE, THEN V IS EITHER USED AS A TEMPORARY STORAGE (IF +C M .LT. N) OR NOT REFERENCED (IF M .GE. N). +C IF M .GE. N, V MAY ALSO COINCIDE WITH A. IF AN ERROR +C EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO INDICES OF +C CORRECT SINGULAR VALUES SHOULD BE CORRECT. +C +C Z CONTAINS THE MATRIX X IN THE SINGULAR VALUE DECOMPOSITION +C T +C OF R=XSY, IF THE MODIFIED ALGORITHM IS USED. IF THE +C GOLUB-REINSCH PROCEDURE IS USED, THEN IT IS NOT REFERENCED. +C IF MATU HAS BEEN SET TO .FALSE. IN THE CASE M.GE.N (OR +C MATV SET TO .FALSE. IN THE CASE M.LT.N), THEN Z IS NOT +C REFERENCED AND NO EXTRA STORAGE IS REQUIRED. +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C K IF THE K-TH SINGULAR VALUE HAS NOT BEEN +C DETERMINED AFTER 30 ITERATIONS. +C -1 IF IRHS .LT. 0 . +C -2 IF M .LT. 1 .OR. N .LT. 1 +C -3 IF NA .LT. M .OR. NU .LT. M .OR. NB .LT. M. +C -4 IF NV .LT. N . +C -5 IF NZ .LT. MIN(M,N). +C +C RV1 IS A TEMPORARY STORAGE ARRAY OF LENGTH AT LEAST MIN(M,N). +C +C PROGRAMMED BY : TONY CHAN +C BOX 2158, YALE STATION, +C COMPUTER SCIENCE DEPT, YALE UNIV., +C NEW HAVEN, CT 06520. +C LAST MODIFIED : JANUARY, 1982. +C +C HYBSVD USES THE FOLLOWING FUNCTIONS AND SUBROUTINES. +C INTERNAL GRSVD, MGNSVD, SRELPR +C FORTRAN MIN0,DABS,DSQRT,DFLOAT,DSIGN,DMAX1 +C BLAS SSWAP +C +C ----------------------------------------------------------------- +C ERROR CHECK. +C + IERR = 0 + IF (IRHS.GE.0) GO TO 10 + IERR = -1 + RETURN + 10 IF (M.GE.1 .AND. N.GE.1) GO TO 20 + IERR = -2 + RETURN + 20 IF (NA.GE.M .AND. NU.GE.M .AND. NB.GE.M) GO TO 30 + IERR = -3 + RETURN + 30 IF (NV.GE.N) GO TO 40 + IERR = -4 + RETURN + 40 IF (NZ.GE.MIN0(M,N)) GO TO 50 + IERR = -5 + RETURN + 50 CONTINUE +C +C FIRST COPIES A INTO EITHER U OR V ACCORDING TO WHETHER +C M .GE. N OR M .LT. N, AND THEN CALLS SUBROUTINE MGNSVD +C WHICH ASSUMES THAT NUMBER OF ROWS .GE. NUMBER OF COLUMNS. +C + IF (M.LT.N) GO TO 80 +C +C M .GE. N CASE. +C + DO 70 I=1,M + DO 60 J=1,N + U(I,J) = A(I,J) + 60 CONTINUE + 70 CONTINUE +C + CALL MGNSVD(NU, NV, NZ, NB, M, N, W, MATU, U, MATV, V, Z, B, + * IRHS, IERR, RV1) + RETURN +C + 80 CONTINUE +C T +C M .LT. N CASE. COPIES A INTO V. +C + DO 100 I=1,M + DO 90 J=1,N + V(J,I) = A(I,J) + 90 CONTINUE + 100 CONTINUE + CALL MGNSVD(NV, NU, NZ, NB, N, M, W, MATV, V, MATU, U, Z, B, 0, + * IERR, RV1) + RETURN + END +C MGN 10 + SUBROUTINE MGNSVD(NU, NV, NZ, NB, M, N, W, MATU, U, MATV, V, Z, MGN 20 + * B, IRHS, IERR, RV1) +C +C THE DESCRIPTION OF SUBROUTINE MGNSVD IS ALMOST IDENTICAL +C TO THAT FOR SUBROUTINE HYBSVD ABOVE, WITH THE EXCEPTION +C THAT MGNSVD ASSUMES M .GE. N. +C IT ALSO ASSUMES THAT A COPY OF THE MATRIX A IS IN THE ARRAY U. +C + INTEGER NU, NV, NZ, M, N, IRHS, IERR, IP1, I, J, K, IM1, IBACK + REAL*8 W(1), U(NU,1), V(NV,1), Z(NZ,1), B(NB,IRHS), RV1(1) + REAL*8 XOVRPT, C, R, G, SCALE, DSIGN, DABS, DSQRT, F, S, H + REAL*8 DFLOAT + LOGICAL MATU, MATV +C +C SET VALUE FOR C. THE VALUE FOR C DEPENDS ON THE RELATIVE +C EFFICIENCY OF FLOATING POINT MULTIPLICATIONS, FLOATING POINT +C ADDITIONS AND TWO-DIMENSIONAL ARRAY INDEXINGS ON THE +C COMPUTER WHERE THIS SUBROUTINE IS TO BE RUN. C SHOULD +C USUALLY BE BETWEEN 2 AND 4. FOR DETAILS ON CHOOSING C, SEE +C (2). THE ALGORITHM IS NOT SENSITIVE TO THE VALUE OF C +C ACTUALLY USED AS LONG AS C IS BETWEEN 2 AND 4. +C + C = 4.d0 +C +C DETERMINE CROSS-OVER POINT +C + IF (MATU .AND. MATV) XOVRPT = (C+7.d0/3.d0)/C + IF (MATU .AND. .NOT.MATV) XOVRPT = (C+7.d0/3.d0)/C + IF (.NOT.MATU .AND. MATV) XOVRPT = 5.d0/3.d0 + IF (.NOT.MATU .AND. .NOT.MATV) XOVRPT = 5.d0/3.d0 +C +C DETERMINE WHETHER TO USE GOLUB-REINSCH OR THE MODIFIED +C ALGORITHM. +C + R = DFLOAT(M)/DFLOAT(N) + IF (R.GE.XOVRPT) GO TO 10 +C +C USE GOLUB-REINSCH PROCEDURE +C + CALL GRSVD(NU, NV, NB, M, N, W, MATU, U, MATV, V, B, IRHS, IERR, + * RV1) + GO TO 330 +C +C USE MODIFIED ALGORITHM +C + 10 CONTINUE +C +C TRIANGULARIZE U BY HOUSEHOLDER TRANSFORMATIONS, USING +C W AND RV1 AS TEMPORARY STORAGE. +C + DO 110 I=1,N + G = 0.d0 + S = 0.d0 + SCALE = 0.d0 +C +C PERFORM SCALING OF COLUMNS TO AVOID UNNECSSARY OVERFLOW +C OR UNDERFLOW +C + DO 20 K=I,M + SCALE = SCALE + DABS(U(K,I)) + 20 CONTINUE + IF (SCALE.EQ.0.d0) GO TO 110 + DO 30 K=I,M + U(K,I) = U(K,I)/SCALE + S = S + U(K,I)*U(K,I) + 30 CONTINUE +C +C THE VECTOR E OF THE HOUSEHOLDER TRANSFORMATION I + EE'/H +C WILL BE STORED IN COLUMN I OF U. THE TRANSFORMED ELEMENT +C U(I,I) WILL BE STORED IN W(I) AND THE SCALAR H IN +C RV1(I). +C + F = U(I,I) + G = -DSIGN(DSQRT(S),F) + H = F*G - S + U(I,I) = F - G + RV1(I) = H + W(I) = SCALE*G +C + IF (I.EQ.N) GO TO 70 +C +C APPLY TRANSFORMATIONS TO REMAINING COLUMNS OF A +C + IP1 = I + 1 + DO 60 J=IP1,N + S = 0.d0 + DO 40 K=I,M + S = S + U(K,I)*U(K,J) + 40 CONTINUE + F = S/H + DO 50 K=I,M + U(K,J) = U(K,J) + F*U(K,I) + 50 CONTINUE + 60 CONTINUE +C +C APPLY TRANSFORMATIONS TO COLUMNS OF B IF IRHS .GT. 0 +C + 70 IF (IRHS.EQ.0) GO TO 110 + DO 100 J=1,IRHS + S = 0.d0 + DO 80 K=I,M + S = S + U(K,I)*B(K,J) + 80 CONTINUE + F = S/H + DO 90 K=I,M + B(K,J) = B(K,J) + F*U(K,I) + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE +C +C COPY R INTO Z IF MATU = .TRUE. +C + IF (.NOT.MATU) GO TO 290 + DO 130 I=1,N + DO 120 J=I,N + Z(J,I) = 0.d0 + Z(I,J) = U(I,J) + 120 CONTINUE + Z(I,I) = W(I) + 130 CONTINUE +C +C ACCUMULATE HOUSEHOLDER TRANSFORMATIONS IN U +C + DO 240 IBACK=1,N + I = N - IBACK + 1 + IP1 = I + 1 + G = W(I) + H = RV1(I) + IF (I.EQ.N) GO TO 150 +C + DO 140 J=IP1,N + U(I,J) = 0.d0 + 140 CONTINUE +C + 150 IF (H.EQ.0.d0) GO TO 210 + IF (I.EQ.N) GO TO 190 +C + DO 180 J=IP1,N + S = 0.d0 + DO 160 K=IP1,M + S = S + U(K,I)*U(K,J) + 160 CONTINUE + F = S/H + DO 170 K=I,M + U(K,J) = U(K,J) + F*U(K,I) + 170 CONTINUE + 180 CONTINUE +C + 190 S = U(I,I)/H + DO 200 J=I,M + U(J,I) = U(J,I)*S + 200 CONTINUE + GO TO 230 +C + 210 DO 220 J=I,M + U(J,I) = 0.d0 + 220 CONTINUE + 230 U(I,I) = U(I,I) + 1.d0 + 240 CONTINUE +C +C COMPUTE SVD OF R (WHICH IS STORED IN Z) +C + CALL GRSVD(NZ, NV, NB, N, N, W, MATU, Z, MATV, V, B, IRHS, IERR, + * RV1) +C +C T +C FORM L*X TO OBTAIN U (WHERE R=XWY ). X IS RETURNED IN Z +C BY GRSVD. THE MATRIX MULTIPLY IS DONE ONE ROW AT A TIME, +C USING RV1 AS SCRATCH SPACE. +C + DO 280 I=1,M + DO 260 J=1,N + S = 0.d0 + DO 250 K=1,N + S = S + U(I,K)*Z(K,J) + 250 CONTINUE + RV1(J) = S + 260 CONTINUE + DO 270 J=1,N + U(I,J) = RV1(J) + 270 CONTINUE + 280 CONTINUE + GO TO 330 +C +C FORM R IN U BY ZEROING THE LOWER TRIANGULAR PART OF R IN U +C + 290 IF (N.EQ.1) GO TO 320 + DO 310 I=2,N + IM1 = I - 1 + DO 300 J=1,IM1 + U(I,J) = 0.d0 + 300 CONTINUE + U(I,I) = W(I) + 310 CONTINUE + 320 U(1,1) = W(1) +C + CALL GRSVD(NU, NV, NB, N, N, W, MATU, U, MATV, V, B, IRHS, IERR, + * RV1) + 330 CONTINUE + IERRP1 = IERR + 1 + IF (IERR.LT.0 .OR. N.LE.1 .OR. IERRP1.EQ.N) RETURN +C +C SORT SINGULAR VALUES AND EXCHANGE COLUMNS OF U AND V ACCORDINGLY. +C SELECTION SORT MINIMIZES SWAPPING OF U AND V. +C + NM1 = N - 1 + DO 360 I=IERRP1,NM1 +C... FIND INDEX OF MAXIMUM SINGULAR VALUE + ID = I + IP1 = I + 1 + DO 340 J=IP1,N + IF (W(J).GT.W(ID)) ID = J + 340 CONTINUE + IF (ID.EQ.I) GO TO 360 +C... SWAP SINGULAR VALUES AND VECTORS + T = W(I) + W(I) = W(ID) + W(ID) = T + IF (MATV) CALL SSWAP(N, V(1,I), 1, V(1,ID), 1) + IF (MATU) CALL SSWAP(M, U(1,I), 1, U(1,ID), 1) + IF (IRHS.LT.1) GO TO 360 + DO 350 KRHS=1,IRHS + T = B(I,KRHS) + B(I,KRHS) = B(ID,KRHS) + B(ID,KRHS) = T + 350 CONTINUE + 360 CONTINUE + RETURN +C ************** LAST CARD OF HYBSVD ***************** + END + SUBROUTINE GRSVD(NU, NV, NB, M, N, W, MATU, U, MATV, V, B, IRHS, GRS 10 + * IERR, RV1) +C + INTEGER I, J, K, L, M, N, II, I1, KK, K1, LL, L1, MN, NU, NV, NB, + * ITS, IERR, IRHS + REAL*8 W(1), U(NU,1), V(NV,1), B(NB,IRHS), RV1(1) + REAL*8 C, F, G, H, S, X, Y, Z, EPS, SCALE, SRELPR, DUMMY + REAL*8 DSQRT, DMAX1, DABS, DSIGN + LOGICAL MATU, MATV +C +C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE SVD, +C NUM. MATH. 14, 403-420(1970) BY GOLUB AND REINSCH. +C HANDBOOK FOR AUTO. COMP., VOL II-LINEAR ALGEBRA, 134-151(1971). +C +C THIS SUBROUTINE DETERMINES THE SINGULAR VALUE DECOMPOSITION +C T +C A=USV OF A REAL M BY N RECTANGULAR MATRIX. HOUSEHOLDER +C BIDIAGONALIZATION AND A VARIANT OF THE QR ALGORITHM ARE USED. +C GRSVD ASSUMES THAT A COPY OF THE MATRIX A IS IN THE ARRAY U. IT +C ALSO ASSUMES M .GE. N. IF M .LT. N, THEN COMPUTE THE SINGULAR +C T T T T +C VALUE DECOMPOSITION OF A . IF A =UWV , THEN A=VWU . +C +C GRSVD CAN ALSO BE USED TO COMPUTE THE MINIMAL LENGTH LEAST SQUARES +C SOLUTION TO THE OVERDETERMINED LINEAR SYSTEM A*X=B. +C +C ON INPUT- +C +C NU MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS U AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. NOTE THAT NU MUST BE AT LEAST +C AS LARGE AS M, +C +C NV MUST BE SET TO THE ROW DIMENSION OF THE TWO-DIMENSIONAL +C ARRAY PARAMETER V AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. NV MUST BE AT LEAST AS LARGE AS N, +C +C NB MUST BE SET TO THE ROW DIMENSION OF TWO-DIMENSIONAL +C ARRAY PARAMETERS B AS DECLARED IN THE CALLING PROGRAM +C DIMENSION STATEMENT. NOTE THAT NB MUST BE AT LEAST +C AS LARGE AS M, +C +C M IS THE NUMBER OF ROWS OF A (AND U), +C +C N IS THE NUMBER OF COLUMNS OF A (AND U) AND THE ORDER OF V, +C +C A CONTAINS THE RECTANGULAR INPUT MATRIX TO BE DECOMPOSED, +C +C B CONTAINS THE IRHS RIGHT-HAND-SIDES OF THE OVERDETERMINED +C LINEAR SYSTEM A*X=B. IF IRHS .GT. 0, THEN ON OUTPUT, +C THE FIRST N COMPONENTS OF THESE IRHS COLUMNS OF B +C T +C WILL CONTAIN U B. THUS, TO COMPUTE THE MINIMAL LENGTH LEAST +C + +C SQUARES SOLUTION, ONE MUST COMPUTE V*W TIMES THE COLUMNS OF +C + + +C B, WHERE W IS A DIAGONAL MATRIX, W (I)=0 IF W(I) IS +C NEGLIGIBLE, OTHERWISE IS 1/W(I). IF IRHS=0, B MAY COINCIDE +C WITH A OR U AND WILL NOT BE REFERENCED, +C +C IRHS IS THE NUMBER OF RIGHT-HAND-SIDES OF THE OVERDETERMINED +C SYSTEM A*X=B. IRHS SHOULD BE SET TO ZERO IF ONLY THE SINGULA +C VALUE DECOMPOSITION OF A IS DESIRED, +C +C MATU SHOULD BE SET TO .TRUE. IF THE U MATRIX IN THE +C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE, +C +C MATV SHOULD BE SET TO .TRUE. IF THE V MATRIX IN THE +C DECOMPOSITION IS DESIRED, AND TO .FALSE. OTHERWISE. +C +C ON OUTPUT- +C +C W CONTAINS THE N (NON-NEGATIVE) SINGULAR VALUES OF A (THE +C DIAGONAL ELEMENTS OF S). THEY ARE UNORDERED. IF AN +C ERROR EXIT IS MADE, THE SINGULAR VALUES SHOULD BE CORRECT +C FOR INDICES IERR+1,IERR+2,...,N, +C +C U CONTAINS THE MATRIX U (ORTHOGONAL COLUMN VECTORS) OF THE +C DECOMPOSITION IF MATU HAS BEEN SET TO .TRUE. OTHERWISE +C U IS USED AS A TEMPORARY ARRAY. +C IF AN ERROR EXIT IS MADE, THE COLUMNS OF U CORRESPONDING +C TO INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT, +C +C V CONTAINS THE MATRIX V (ORTHOGONAL) OF THE DECOMPOSITION IF +C MATV HAS BEEN SET TO .TRUE. OTHERWISE V IS NOT REFERENCED. +C IF AN ERROR EXIT IS MADE, THE COLUMNS OF V CORRESPONDING TO +C INDICES OF CORRECT SINGULAR VALUES SHOULD BE CORRECT, +C +C IERR IS SET TO +C ZERO FOR NORMAL RETURN, +C K IF THE K-TH SINGULAR VALUE HAS NOT BEEN +C DETERMINED AFTER 30 ITERATIONS, +C -1 IF IRHS .LT. 0 , +C -2 IF M .LT. N , +C -3 IF NU .LT. M .OR. NB .LT. M, +C -4 IF NV .LT. N . +C +C RV1 IS A TEMPORARY STORAGE ARRAY. +C +C THIS SUBROUTINE HAS BEEN CHECKED BY THE PFORT VERIFIER +C (RYDER, B.G. 'THE PFORT VERIFIER', SOFTWARE - PRACTICE AND +C EXPERIENCE, VOL.4, 359-377, 1974) FOR ADHERENCE TO A LARGE, +C CAREFULLY DEFINED, PORTABLE SUBSET OF AMERICAN NATIONAL STANDAR +C FORTRAN CALLED PFORT. +C +C ORIGINAL VERSION OF THIS CODE IS SUBROUTINE SVD IN RELEASE 2 OF +C EISPACK. +C +C MODIFIED BY TONY F. CHAN, +C COMP. SCI. DEPT, YALE UNIV., +C BOX 2158, YALE STATION, +C CT 06520 +C LAST MODIFIED : JANUARY, 1982. +C +C ------------------------------------------------------------------ +C +C ********** SRELPR IS A MACHINE-DEPENDENT FUNCTION SPECIFYING +C THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC. +C +C ********** +C + IERR = 0 + IF (IRHS.GE.0) GO TO 10 + IERR = -1 + RETURN + 10 IF (M.GE.N) GO TO 20 + IERR = -2 + RETURN + 20 IF (NU.GE.M .AND. NB.GE.M) GO TO 30 + IERR = -3 + RETURN + 30 IF (NV.GE.N) GO TO 40 + IERR = -4 + RETURN + 40 CONTINUE +C +C ********** HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM ********** + G = 0.d0 + SCALE = 0.d0 + X = 0.d0 +C + DO 260 I=1,N + L = I + 1 + RV1(I) = SCALE*G + G = 0.d0 + S = 0.d0 + SCALE = 0.d0 +C +C COMPUTE LEFT TRANSFORMATIONS THAT ZERO THE SUBDIAGONAL ELEMENTS +C OF THE I-TH COLUMN. +C + DO 50 K=I,M + SCALE = SCALE + DABS(U(K,I)) + 50 CONTINUE +C + IF (SCALE.EQ.0.d0) GO TO 160 +C + DO 60 K=I,M + U(K,I) = U(K,I)/SCALE + S = S + U(K,I)**2 + 60 CONTINUE +C + F = U(I,I) + G = -DSIGN(DSQRT(S),F) + H = F*G - S + U(I,I) = F - G + IF (I.EQ.N) GO TO 100 +C +C APPLY LEFT TRANSFORMATIONS TO REMAINING COLUMNS OF A. +C + DO 90 J=L,N + S = 0.d0 +C + DO 70 K=I,M + S = S + U(K,I)*U(K,J) + 70 CONTINUE +C + F = S/H +C + DO 80 K=I,M + U(K,J) = U(K,J) + F*U(K,I) + 80 CONTINUE + 90 CONTINUE +C +C APPLY LEFT TRANSFORMATIONS TO THE COLUMNS OF B IF IRHS .GT. 0 +C + 100 IF (IRHS.EQ.0) GO TO 140 + DO 130 J=1,IRHS + S = 0.d0 + DO 110 K=I,M + S = S + U(K,I)*B(K,J) + 110 CONTINUE + F = S/H + DO 120 K=I,M + B(K,J) = B(K,J) + F*U(K,I) + 120 CONTINUE + 130 CONTINUE +C +C COMPUTE RIGHT TRANSFORMATIONS. +C + 140 DO 150 K=I,M + U(K,I) = SCALE*U(K,I) + 150 CONTINUE +C + 160 W(I) = SCALE*G + G = 0.d0 + S = 0.d0 + SCALE = 0.d0 + IF (I.GT.M .OR. I.EQ.N) GO TO 250 +C + DO 170 K=L,N + SCALE = SCALE + DABS(U(I,K)) + 170 CONTINUE +C + IF (SCALE.EQ.0.d0) GO TO 250 +C + DO 180 K=L,N + U(I,K) = U(I,K)/SCALE + S = S + U(I,K)**2 + 180 CONTINUE +C + F = U(I,L) + G = -DSIGN(DSQRT(S),F) + H = F*G - S + U(I,L) = F - G +C + DO 190 K=L,N + RV1(K) = U(I,K)/H + 190 CONTINUE +C + IF (I.EQ.M) GO TO 230 +C + DO 220 J=L,M + S = 0.d0 +C + DO 200 K=L,N + S = S + U(J,K)*U(I,K) + 200 CONTINUE +C + DO 210 K=L,N + U(J,K) = U(J,K) + S*RV1(K) + 210 CONTINUE + 220 CONTINUE +C + 230 DO 240 K=L,N + U(I,K) = SCALE*U(I,K) + 240 CONTINUE +C + 250 X = DMAX1(X,DABS(W(I))+DABS(RV1(I))) + 260 CONTINUE +C ********** ACCUMULATION OF RIGHT-HAND TRANSFORMATIONS ********** + IF (.NOT.MATV) GO TO 350 +C ********** FOR I=N STEP -1 UNTIL 1 DO -- ********** + DO 340 II=1,N + I = N + 1 - II + IF (I.EQ.N) GO TO 330 + IF (G.EQ.0.d0) GO TO 310 +C + DO 270 J=L,N +C ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** + V(J,I) = (U(I,J)/U(I,L))/G + 270 CONTINUE +C + DO 300 J=L,N + S = 0.d0 +C + DO 280 K=L,N + S = S + U(I,K)*V(K,J) + 280 CONTINUE +C + DO 290 K=L,N + V(K,J) = V(K,J) + S*V(K,I) + 290 CONTINUE + 300 CONTINUE +C + 310 DO 320 J=L,N + V(I,J) = 0.d0 + V(J,I) = 0.d0 + 320 CONTINUE +C + 330 V(I,I) = 1.d0 + G = RV1(I) + L = I + 340 CONTINUE +C ********** ACCUMULATION OF LEFT-HAND TRANSFORMATIONS ********** + 350 IF (.NOT.MATU) GO TO 470 +C **********FOR I=MIN(M,N) STEP -1 UNTIL 1 DO -- ********** + MN = N + IF (M.LT.N) MN = M +C + DO 460 II=1,MN + I = MN + 1 - II + L = I + 1 + G = W(I) + IF (I.EQ.N) GO TO 370 +C + DO 360 J=L,N + U(I,J) = 0.d0 + 360 CONTINUE +C + 370 IF (G.EQ.0.d0) GO TO 430 + IF (I.EQ.MN) GO TO 410 +C + DO 400 J=L,N + S = 0.d0 +C + DO 380 K=L,M + S = S + U(K,I)*U(K,J) + 380 CONTINUE +C ********** DOUBLE DIVISION AVOIDS POSSIBLE UNDERFLOW ********** + F = (S/U(I,I))/G +C + DO 390 K=I,M + U(K,J) = U(K,J) + F*U(K,I) + 390 CONTINUE + 400 CONTINUE +C + 410 DO 420 J=I,M + U(J,I) = U(J,I)/G + 420 CONTINUE +C + GO TO 450 +C + 430 DO 440 J=I,M + U(J,I) = 0.d0 + 440 CONTINUE +C + 450 U(I,I) = U(I,I) + 1.d0 + 460 CONTINUE +C ********** DIAGONALIZATION OF THE BIDIAGONAL FORM ********** + 470 EPS = SRELPR(DUMMY)*X +C ********** FOR K=N STEP -1 UNTIL 1 DO -- ********** + DO 650 KK=1,N + K1 = N - KK + K = K1 + 1 + ITS = 0 +C ********** TEST FOR SPLITTING. +C FOR L=K STEP -1 UNTIL 1 DO -- ********** + 480 DO 490 LL=1,K + L1 = K - LL + L = L1 + 1 + IF (DABS(RV1(L)).LE.EPS) GO TO 550 +C ********** RV1(1) IS ALWAYS ZERO, SO THERE IS NO EXIT +C THROUGH THE BOTTOM OF THE LOOP ********** + IF (DABS(W(L1)).LE.EPS) GO TO 500 + 490 CONTINUE +C ********** CANCELLATION OF RV1(L) IF L GREATER THAN 1 ********** + 500 C = 0.d0 + S = 1.d0 +C + DO 540 I=L,K + F = S*RV1(I) + RV1(I) = C*RV1(I) + IF (DABS(F).LE.EPS) GO TO 550 + G = W(I) + H = DSQRT(F*F+G*G) + W(I) = H + C = G/H + S = -F/H +C +C APPLY LEFT TRANSFORMATIONS TO B IF IRHS .GT. 0 +C + IF (IRHS.EQ.0) GO TO 520 + DO 510 J=1,IRHS + Y = B(L1,J) + Z = B(I,J) + B(L1,J) = Y*C + Z*S + B(I,J) = -Y*S + Z*C + 510 CONTINUE + 520 CONTINUE +C + IF (.NOT.MATU) GO TO 540 +C + DO 530 J=1,M + Y = U(J,L1) + Z = U(J,I) + U(J,L1) = Y*C + Z*S + U(J,I) = -Y*S + Z*C + 530 CONTINUE +C + 540 CONTINUE +C ********** TEST FOR CONVERGENCE ********** + 550 Z = W(K) + IF (L.EQ.K) GO TO 630 +C ********** SHIFT FROM BOTTOM 2 BY 2 MINOR ********** + IF (ITS.EQ.30) GO TO 660 + ITS = ITS + 1 + X = W(L) + Y = W(K1) + G = RV1(K1) + H = RV1(K) + F = ((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.d0*H*Y) + G = DSQRT(F*F+1.0) + F = ((X-Z)*(X+Z)+H*(Y/(F+DSIGN(G,F))-H))/X +C ********** NEXT QR TRANSFORMATION ********** + C = 1.0 + S = 1.0 +C + DO 620 I1=L,K1 + I = I1 + 1 + G = RV1(I) + Y = W(I) + H = S*G + G = C*G + Z = DSQRT(F*F+H*H) + RV1(I1) = Z + C = F/Z + S = H/Z + F = X*C + G*S + G = -X*S + G*C + H = Y*S + Y = Y*C + IF (.NOT.MATV) GO TO 570 +C + DO 560 J=1,N + X = V(J,I1) + Z = V(J,I) + V(J,I1) = X*C + Z*S + V(J,I) = -X*S + Z*C + 560 CONTINUE +C + 570 Z = DSQRT(F*F+H*H) + W(I1) = Z +C ********** ROTATION CAN BE ARBITRARY IF Z IS ZERO ********** + IF (Z.EQ.0.d0) GO TO 580 + C = F/Z + S = H/Z + 580 F = C*G + S*Y + X = -S*G + C*Y +C +C APPLY LEFT TRANSFORMATIONS TO B IF IRHS .GT. 0 +C + IF (IRHS.EQ.0) GO TO 600 + DO 590 J=1,IRHS + Y = B(I1,J) + Z = B(I,J) + B(I1,J) = Y*C + Z*S + B(I,J) = -Y*S + Z*C + 590 CONTINUE + 600 CONTINUE +C + IF (.NOT.MATU) GO TO 620 +C + DO 610 J=1,M + Y = U(J,I1) + Z = U(J,I) + U(J,I1) = Y*C + Z*S + U(J,I) = -Y*S + Z*C + 610 CONTINUE +C + 620 CONTINUE +C + RV1(L) = 0.d0 + RV1(K) = F + W(K) = X + GO TO 480 +C ********** CONVERGENCE ********** + 630 IF (Z.GE.0.d0) GO TO 650 +C ********** W(K) IS MADE NON-NEGATIVE ********** + W(K) = -Z + IF (.NOT.MATV) GO TO 650 +C + DO 640 J=1,N + V(J,K) = -V(J,K) + 640 CONTINUE +C + 650 CONTINUE +C + GO TO 670 +C ********** SET ERROR -- NO CONVERGENCE TO A +C SINGULAR VALUE AFTER 30 ITERATIONS ********** + 660 IERR = K + 670 RETURN +C ********** LAST CARD OF GRSVD ********** + END + SUBROUTINE SSWAP(N, SX, INCX, SY, INCY) SSW 10 +C +C INTERCHANGES TWO VECTORS. +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO 1. +C JACK DONGARRA, LINPACK, 3/11/78. +C + REAL*8 SX(1), SY(1), STEMP + INTEGER I, INCX, INCY, IX, IY, M, MP1, N +C + IF (N.LE.0) RETURN + IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL +C TO 1 +C + IX = 1 + IY = 1 + IF (INCX.LT.0) IX = (-N+1)*INCX + 1 + IF (INCY.LT.0) IY = (-N+1)*INCY + 1 + DO 10 I=1,N + STEMP = SX(IX) + SX(IX) = SY(IY) + SY(IY) = STEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,3) + IF (M.EQ.0) GO TO 40 + DO 30 I=1,M + STEMP = SX(I) + SX(I) = SY(I) + SY(I) = STEMP + 30 CONTINUE + IF (N.LT.3) RETURN + 40 MP1 = M + 1 + DO 50 I=MP1,N,3 + STEMP = SX(I) + SX(I) = SY(I) + SY(I) = STEMP + STEMP = SX(I+1) + SX(I+1) = SY(I+1) + SY(I+1) = STEMP + STEMP = SX(I+2) + SX(I+2) = SY(I+2) + SY(I+2) = STEMP + 50 CONTINUE + RETURN + END + REAL*8 FUNCTION SRELPR(DUMMY) SRE 10 + REAL*8 DUMMY +C +C SRELPR COMPUTES THE RELATIVE PRECISION OF THE FLOATING POINT +C ARITHMETIC OF THE MACHINE. +C +C IF TROUBLE WITH AUTOMATIC COMPUTATION OF THESE QUANTITIES, +C THEY CAN BE SET BY DIRECT ASSIGNMENT STATEMENTS. +C ASSUME THE COMPUTER HAS +C +C B = BASE OF ARITHMETIC +C T = NUMBER OF BASE B DIGITS +C +C THEN +C +C SRELPR = B**(1-T) +C + REAL*8 S +C + SRELPR = 1.d0 + 10 SRELPR = SRELPR/2.d0 + S = 1.d0 + SRELPR + IF (S.GT.1.d0) GO TO 10 + SRELPR = 2.d0*SRELPR + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/hyperelastics.f calculix-ccx-2.3/ccx_2.3/src/hyperelastics.f --- calculix-ccx-2.1/ccx_2.3/src/hyperelastics.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/hyperelastics.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,244 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine hyperelastics(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb,iline,ipol, + & inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *HYPERELASTIC +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat,ntmat_,istep,istat,ipoinpc(0:*), + & n,key,i,j,k,ityp,iperturb(*),iend,jcoef(3,14),ncmat_,irstrt, + & iline,ipol,inl,ipoinp(2,*),inp(3,*) +! + real*8 elcon(0:ncmat_,ntmat_,*),um +! +! jcoef indicates for each hyperelastic model the position of +! the compressibility coefficients in the field elcon (max. 3 +! positions per model) +! + data jcoef /3,0,0,3,0,0,2,0,0,3,0,0,5,6,0,7,8,9,3,0,0, + & 6,7,0,12,13,14,2,0,0,3,4,0,4,5,6,5,0,0,4,5,6/ +! + ntmat=0 + iperturb(1)=3 + iperturb(2)=1 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in hyperelastics: *HYPERELASTIC should be' + write(*,*) ' placed before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in hyperelastics: *HYPERELASTIC should be' + write(*,*) ' preceded by a *MATERIAL card' + stop + endif +! + ityp=-7 +! + do i=2,n + if(textpart(i)(1:12).eq.'ARRUDA-BOYCE') then + ityp=-1 + elseif(textpart(i)(1:13).eq.'MOONEY-RIVLIN') then + ityp=-2 + elseif(textpart(i)(1:8).eq.'NEOHOOKE') then + ityp=-3 + elseif(textpart(i)(1:5).eq.'OGDEN') then + ityp=-4 + elseif(textpart(i)(1:10).eq.'POLYNOMIAL') then + ityp=-7 + elseif(textpart(i)(1:17).eq.'REDUCEDPOLYNOMIAL') then + ityp=-10 + elseif(textpart(i)(1:11).eq.'VANDERWAALS') then + ityp=-13 + elseif(textpart(i)(1:4).eq.'YEOH') then + ityp=-14 + elseif(textpart(i)(1:2).eq.'N=') then + if(textpart(i)(3:3).eq.'1') then + elseif(textpart(i)(3:3).eq.'2') then + if(ityp.eq.-4) then + ityp=-5 + elseif(ityp.eq.-7) then + ityp=-8 + elseif(ityp.eq.-10) then + ityp=-11 + else + write(*,*) '*WARNING in hyperelastics: N=2 is not appl + &icable for this material type; ' + call inputerror(inpc,ipoinpc,iline) + endif + elseif(textpart(i)(3:3).eq.'3') then + if(ityp.eq.-4) then + ityp=-6 + elseif(ityp.eq.-7) then + ityp=-9 + elseif(ityp.eq.-10) then + ityp=-12 + else + write(*,*) '*WARNING in hyperelastics: N=3 is not appl + &icable for this material type; ' + call inputerror(inpc,ipoinpc,iline) + endif + else + write(*,*) '*WARNING in hyperelastics: only N=1, N=2, or + &N=3 are allowed; ' + call inputerror(inpc,ipoinpc,iline) + endif + else + write(*,*) + & '*WARNING in hyperelastics: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + nelcon(1,nmat)=ityp +! + if((ityp.ne.-6).and.(ityp.ne.-9)) then + if((ityp.eq.-3).or.(ityp.eq.-10)) then + iend=2 + elseif((ityp.eq.-1).or.(ityp.eq.-2).or.(ityp.eq.-4).or. + & (ityp.eq.-7)) then + iend=3 + elseif(ityp.eq.-11) then + iend=4 + elseif(ityp.eq.-13) then + iend=5 + elseif((ityp.eq.-5).or.(ityp.eq.-12).or.(ityp.eq.-14)) then + iend=6 + elseif(ityp.eq.-8) then + iend=7 + endif + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + ntmat=ntmat+1 + nelcon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in hyperelastics: increase ntmat_' + stop + endif + do i=1,iend + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + read(textpart(iend+1)(1:20),'(f20.0)',iostat=istat) + & elcon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + else + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + ntmat=ntmat+1 + nelcon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in hyperelastics: increase ntmat_' + stop + endif + do i=1,8 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! + if(ityp.eq.-6) then + iend=1 + else + iend=4 + endif + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*) + & '*ERROR in hyperelastics: hyperelastic definition' + write(*,*) ' is not complete. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + do i=1,iend + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(8+i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + read(textpart(iend+1)(1:20),'(f20.0)',iostat=istat) + & elcon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + endif +! +! if any of the compressibility coefficients is zero (incompressible +! material), it is replaced. The lowest order coefficient is replaced +! such that it corresponds to a Poisson coeffient of 0.475, the +! following ones are replaced by a power of the first one +! + do j=1,ntmat +! +! calculating the shear coefficient in the undeformed state +! + if(ityp.eq.-1) then + um=elcon(1,j,nmat) + elseif(ityp.eq.-2) then + um=2.d0*(elcon(1,j,nmat)+elcon(2,j,nmat)) + elseif(ityp.eq.-3) then + um=2.d0*elcon(1,j,nmat) + elseif(ityp.eq.-4) then + um=elcon(1,j,nmat) + elseif(ityp.eq.-5) then + um=elcon(1,j,nmat)+elcon(3,j,nmat) + elseif(ityp.eq.-6) then + um=elcon(1,j,nmat)+elcon(3,j,nmat)+elcon(5,j,nmat) + elseif((ityp.eq.-7).or.(ityp.eq.-8).or.(ityp.eq.-9)) then + um=2.d0*(elcon(1,j,nmat)+elcon(2,j,nmat)) + elseif((ityp.eq.-10).or.(ityp.eq.-11).or.(ityp.eq.-12)) then + um=2.d0*elcon(1,j,nmat) + elseif(ityp.eq.-13) then + um=elcon(1,j,nmat) + elseif(ityp.eq.-14) then + um=2.d0*elcon(1,j,nmat) + endif +! + do i=1,3 + k=jcoef(i,abs(ityp)) + if(k.eq.0) exit + if(dabs(elcon(k,j,nmat)).lt.1.d-10) then + elcon(k,j,nmat)=(0.1d0/um)**i + write(*,*) '*WARNING in hyperelastics: default value was' + write(*,*) ' used for compressibility coefficient + &s' + write(*,100) i,elcon(k,j,nmat) + endif + enddo + enddo +! + 100 format(' D',i1,' = ',e11.4) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/hyperfoams.f calculix-ccx-2.3/ccx_2.3/src/hyperfoams.f --- calculix-ccx-2.1/ccx_2.3/src/hyperfoams.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/hyperfoams.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,141 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine hyperfoams(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,irstrt,istep,istat,n,iperturb,iline,ipol, + & inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *HYPERFOAM +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat,ntmat_,istep,istat,ipoinpc(0:*), + & n,key,i,ityp,iperturb(*),iend,ncmat_,irstrt,iline,ipol,inl, + & ipoinp(2,*),inp(3,*) +! + real*8 elcon(0:ncmat_,ntmat_,*) +! + ntmat=0 + iperturb(1)=3 + iperturb(2)=1 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in hyperfoams: *HYPERFOAM should be' + write(*,*) ' placed before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in hyperfoams: *HYPERFOAM should be' + write(*,*) ' preceded by a *MATERIAL card' + stop + endif +! + ityp=-15 +! + do i=2,n + if(textpart(i)(1:2).eq.'N=') then + if(textpart(i)(3:3).eq.'1') then + elseif(textpart(i)(3:3).eq.'2') then + ityp=-16 + elseif(textpart(i)(3:3).eq.'3') then + ityp=-17 + else + write(*,*) '*WARNING in hyperfoams: only N=1, N=2, or + &N=3 are allowed; ' + call inputerror(inpc,ipoinpc,iline) + endif + else + write(*,*) + & '*WARNING in hyperfoams: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + nelcon(1,nmat)=ityp +! + if(ityp.ne.-17) then + if(ityp.eq.-15) then + iend=3 + elseif(ityp.eq.-16) then + iend=6 + endif + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + nelcon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in hyperfoams: increase ntmat_' + stop + endif + do i=1,iend + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + read(textpart(3)(1:20),'(f20.0)',iostat=istat) + & elcon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + else + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + nelcon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in hyperfoams: increase ntmat_' + stop + endif + do i=1,8 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! + iend=1 + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*) '*ERROR in hyperfoams: orthotropic definition' + write(*,*) ' is not complete. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + do i=1,iend + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(8+i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + read(textpart(2)(1:20),'(f20.0)',iostat=istat) + & elcon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/ident2.f calculix-ccx-2.3/ccx_2.3/src/ident2.f --- calculix-ccx-2.1/ccx_2.3/src/ident2.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ident2.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,43 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! +! identifies the position id of px in an ordered array +! x of real numbers; The numbers in x are at positions +! 1, 1+ninc, 1+2*ninc, 1+3*ninc... up to 1+(n-1)*ninc +! +! id is such that x(id).le.px and x(id+1).gt.px +! + SUBROUTINE IDENT2(X,PX,N,ninc,ID) + IMPLICIT none + integer n,id,n2,m,ninc + real*8 X(N*ninc),px + id=0 + if(n.eq.0) return + N2=N+1 + DO + M=(N2+ID)/2 + IF(PX.GE.X(1+ninc*(M-1))) then + ID=M + else + N2=M + endif + IF((N2-ID).EQ.1) return + enddo + END + diff -Nru calculix-ccx-2.1/ccx_2.3/src/identamta.f calculix-ccx-2.3/ccx_2.3/src/identamta.f --- calculix-ccx-2.1/ccx_2.3/src/identamta.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/identamta.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,42 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! +! identifies the position id of reftime in an ordered array +! amta(1,istart...iend) of real numbers; amta is defined as amta(2,*) +! +! id is such that amta(1,id).le.reftime and amta(1,id+1).gt.reftime +! + SUBROUTINE identamta(amta,reftime,istart,iend,ID) + IMPLICIT none +! + integer id,istart,iend,n2,m + real*8 amta(2,*),reftime + id=istart-1 + if(iend.lt.istart) return + N2=iend+1 + DO + M=(N2+ID)/2 + IF(reftime.GE.amta(1,M)) then + ID=M + else + N2=M + endif + IF((N2-ID).EQ.1) return + enddo + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/ident.f calculix-ccx-2.3/ccx_2.3/src/ident.f --- calculix-ccx-2.1/ccx_2.3/src/ident.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ident.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,42 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! +! identifies the position id of px in an ordered array +! x of real numbers; +! +! id is such that x(id).le.px and x(id+1).gt.px +! + SUBROUTINE IDENT(X,PX,N,ID) + IMPLICIT none + integer n,id,n2,m + real*8 X(N),px + id=0 + if(n.eq.0) return + N2=N+1 + DO + M=(N2+ID)/2 + IF(PX.GE.X(M)) then + ID=M + else + N2=M + endif + IF((N2-ID).EQ.1) return + enddo + END + diff -Nru calculix-ccx-2.1/ccx_2.3/src/identifytiedface.f calculix-ccx-2.3/ccx_2.3/src/identifytiedface.f --- calculix-ccx-2.1/ccx_2.3/src/identifytiedface.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/identifytiedface.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,64 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine identifytiedface(tieset,ntie,set,nset,ifaceslave) +! +! identifies slave nodes in tied slave faces +! + implicit none +! + character*81 tieset(3,*),slavset,set(*) +! + integer ifaceslave(*),i,j,nset,ipos,ntie +! +! nodes per face for tet elements +! + do i=1,ntie + if(tieset(1,i)(81:81).ne.'T') cycle + slavset=tieset(2,i) + ipos=index(slavset,' ') + slavset(ipos:ipos)='T' + do j=1,nset + if(set(j).eq.slavset) exit + enddo + if(j.gt.nset) then + slavset(ipos:ipos)='S' + do j=1,nset + if(set(j).eq.slavset) then + exit + endif + enddo + if(j.gt.nset) then + write(*,*) + & '*ERROR in identifytiedface: ', + & 'tied contact nodal slave surface', + & slavset + write(*,*) ' does not exist' + stop + else + tieset(2,i)(ipos:ipos)='S' + ifaceslave(i)=0 + endif + else + tieset(2,i)(ipos:ipos)='T' + ifaceslave(i)=1 + endif + enddo + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/includefilename.f calculix-ccx-2.3/ccx_2.3/src/includefilename.f --- calculix-ccx-2.1/ccx_2.3/src/includefilename.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/includefilename.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,89 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine includefilename(text,includefn,lincludefn) +! +! determines the name of an include file +! + implicit none +! + character*132 includefn + character*1320 text +! + integer nstart,nend,ii,jj,kk,lincludefn +! + nstart=0 + nend=0 +! + loop: do ii=1,lincludefn + if(text(ii:ii).eq.'=') then + jj=ii+1 + if(text(jj:jj).eq.'"') then + nstart=jj+1 + do kk=jj+1,lincludefn + if(text(kk:kk).eq.'"') then + nend=kk-1 + exit loop + endif + enddo + write(*,*)'*ERROR in includefilename: ', + & 'finishing quotes are lacking' + write(*,*) '*ERROR in the input deck. Card image:' + write(*,'(132a1)') + & (text(kk:kk),kk=1,lincludefn) + stop + else + nstart=jj + nend=lincludefn + exit + endif + endif + enddo loop + if(ii.eq.lincludefn+1) then + write(*,*) '*ERROR in includefilename: syntax error' + write(*,*) '*ERROR in the input deck. Card image:' + write(*,'(132a1)') + & (text(kk:kk),kk=1,lincludefn) + stop + endif +! + if(nend.ge.nstart) then + if(nend-nstart+1.le.132) then + includefn(1:nend-nstart+1)=text(nstart:nend) + lincludefn=nend-nstart+1 + else + write(*,*) '*ERROR in includefilename: file name too long' + write(*,*) '*ERROR in the input deck. Card image:' + write(*,'(132a1)') + & (text(kk:kk),kk=1,lincludefn) + stop + endif + else + write(*,*) '*ERROR in includefilename: file name is lacking' + write(*,*) '*ERROR in the input deck. Card image:' + write(*,'(132a1)') + & (text(kk:kk),kk=1,lincludefn) + stop + endif +! + return + end + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/incplas.f calculix-ccx-2.3/ccx_2.3/src/incplas.f --- calculix-ccx-2.1/ccx_2.3/src/incplas.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/incplas.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,738 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine incplas(elconloc,plconloc,xstate,xstateini, + & elas,emec,emec0,ithermal,icmd,beta,stre,vj,kode, + & ielas,amat,t1l,dtime,time,ttime,iel,iint,nstate_,mi, + & eloc,pgauss) +! +! calculates stiffness and stresses for the incremental plasticity +! material law (Ref: J.C. Simo, A framework for finite strain +! elastoplasticity, Comp. Meth. Appl. Mech. Engng., 66(1988)199-219 +! and 68(1988)1-31) +! +! icmd=3: calculates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! the stresses in the routine proposed by Simo are Kirchhoff +! stresses. Since the stress in the hardening laws are Chauchy +! stresses, they are converted into Kirchhoff stress by +! multiplication with the Jacobian determinant +! + implicit none +! + logical user_hardening,user_creep +! + character*80 amat +! + integer ithermal,icmd,i,j,k,l,m,n,nt,kk(84),kode, + & niso,nkin,ielas,iel,iint,nstate_,mi(2),id,leximp,lend,layer, + & kspt,kstep,kinc,iloop +! + real*8 elconloc(21),elas(21),emec(6),emec0(6),beta(6),stre(6), + & vj,plconloc(82),stbl(6),epl,stril(6),xitril(6), + & ee,un,um,al,xk,cop,umb,umbb,dxitril,f0,d0,f1,d1,d2,xg(3,3), + & xs(3,3),xx(3,3),xn(3,3),xd(3,3),cpl(6),c(6),ci(6), + & c1,c2,c3,c4,c5,c6,c7,c8,c9,cplb(6),stblb(6), + & ftrial,xiso(20),yiso(20),xkin(20),ykin(20), + & fiso,dfiso,fkin,dfkin,fiso0,fkin0,ep,t1l,dtime, + & epini,a1,dsvm,xxa,xxn,vj2,vj23, + & cop1,cop2,fu1,fu2,fu,dcop,time,ttime,eloc(6), + & xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*), + & g1,g2,g3,g4,g5,g6,g7,g8,g9,g10,g11,g12,g13,g14,g15,g16, + & g17,g18,g28,g29,g30,g31,g32,g33,decra(5),deswa(5),serd, + & esw(2),ec(2),p,qtild,predef(1),dpred(1),timeabq(2),pgauss(3), + & dtemp +! + data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, + & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, + & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, + & 2,3,2,3/ +! + data xg /1.,0.,0.,0.,1.,0.,0.,0.,1./ +! + data leximp /1/ + data lend /2/ +! +c write(*,*) 'iel,iint ',iel,iint +! +! localizing the plastic fields +! + do i=1,6 + cpl(i)=-2.d0*xstateini(1+i,iint,iel) + stbl(i)=xstateini(7+i,iint,iel) + enddo + do i=1,3 + cpl(i)=cpl(i)+1.d0 + enddo + epl=xstateini(1,iint,iel) + epini=xstateini(1,iint,iel) +! + ee=elconloc(1) + un=elconloc(2) + um=ee/(1.d0+un) + al=um*un/(1.d0-2.d0*un) + xk=al+um/3.d0 + um=um/2.d0 +! + ep=epl +! +! right Cauchy-Green tensor (eloc contains the Lagrange strain, +! including thermal strain) +! + c(1)=2.d0*emec(1)+1.d0 + c(2)=2.d0*emec(2)+1.d0 + c(3)=2.d0*emec(3)+1.d0 + c(4)=2.d0*emec(4) + c(5)=2.d0*emec(5) + c(6)=2.d0*emec(6) +! +! calculating the Jacobian +! + vj=c(1)*(c(2)*c(3)-c(6)*c(6)) + & -c(4)*(c(4)*c(3)-c(6)*c(5)) + & +c(5)*(c(4)*c(6)-c(2)*c(5)) + if(vj.gt.1.d-30) then + vj=dsqrt(vj) + else + write(*,*) '*WARNING in incplas: deformation inside-out' +! +! deformation is reset to zero in order to continue the +! calculation. Alternatively, a flag could be set forcing +! a reiteration of the increment with a smaller size (to +! be done) +! + c(1)=1.d0 + c(2)=1.d0 + c(3)=1.d0 + c(4)=0.d0 + c(5)=0.d0 + c(6)=0.d0 + vj=1.d0 + endif +! +! check for user subroutines +! + if((plconloc(81).lt.0.8d0).and.(plconloc(82).lt.0.8d0)) then + user_hardening=.true. + else + user_hardening=.false. + endif + if(kode.eq.-52) then + if(elconloc(3).lt.0.d0) then + user_creep=.true. + else + user_creep=.false. +c if(xxa.lt.1.d-20) xxa=1.d-20 + xxa=elconloc(3)*(ttime+dtime)**elconloc(5) + if(xxa.lt.1.d-20) xxa=1.d-20 + xxn=elconloc(4) + a1=xxa*dtime +c a2=xxn*a1 +c a3=1.d0/xxn + endif + endif +! +! inversion of the right Cauchy-Green tensor +! + vj2=vj*vj + ci(1)=(c(2)*c(3)-c(6)*c(6))/vj2 + ci(2)=(c(1)*c(3)-c(5)*c(5))/vj2 + ci(3)=(c(1)*c(2)-c(4)*c(4))/vj2 + ci(4)=(c(5)*c(6)-c(4)*c(3))/vj2 + ci(5)=(c(4)*c(6)-c(2)*c(5))/vj2 + ci(6)=(c(4)*c(5)-c(1)*c(6))/vj2 +! +! reducing the plastic right Cauchy-Green tensor and +! the back stress to "isochoric" quantities (b stands +! for bar) +! + vj23=vj**(2.d0/3.d0) + do i=1,6 + cplb(i)=cpl(i)/vj23 + stblb(i)=stbl(i)/vj23 + enddo +! +! calculating the (n+1) trace and the (n+1) deviation of +! the (n) "isochoric" plastic right Cauchy-Green tensor +! + umb=(c(1)*cplb(1)+c(2)*cplb(2)+c(3)*cplb(3)+ + & 2.d0*(c(4)*cplb(4)+c(5)*cplb(5)+c(6)*cplb(6)))/3.d0 + do i=1,6 + cplb(i)=cplb(i)-umb*ci(i) + enddo +! +! calculating the (n+1) trace and the (n+1) deviation of +! the (n) "isochoric" back stress tensor +! + umbb=(c(1)*stblb(1)+c(2)*stblb(2)+c(3)*stblb(3)+ + & 2.d0*(c(4)*stblb(4)+c(5)*stblb(5)+c(6)*stblb(6)))/3.d0 + do i=1,6 + stblb(i)=stblb(i)-umbb*ci(i) + enddo +! +! calculating the trial stress +! + do i=1,6 + stril(i)=um*cplb(i)-beta(i) + enddo +! +! calculating the trial radius vector of the yield surface +! + do i=1,6 + xitril(i)=stril(i)-stblb(i) + enddo + g1=c(6) + g2=xitril(6) + g3=xitril(3) + g4=xitril(2) + g5=c(5) + g6=xitril(5) + g7=xitril(4) + g8=c(4) + g9=c(3) + g10=c(2) + g11=c(1) + g12=xitril(1) + g13=g12*g11 + g14=g10*g4 + g15=g9*g3 + g16=g8*g7 + g17=g6*g5 + g18=g2*g1 + g28=4*(g16 + g15) + g29=4*g13 + g30=4*g14 + g31=4*g6*g1 + g32=4*g8*g2 + g33=4*g7*g5 + dxitril=(g13*g13 + g14*g14 + g15*g15 + g16*(g30 + g29 + 2* + & g16) + g17*(g29 + g28 + 2*g17) + g18*(g30 + g28 + 2* + & g18 + 4*g17) + g11*g7*(g31 + 2*g10*g7) + g9*g6*(g32 + + & 2*g11*g6) + g10*g2*(g33 + 2*g9*g2) + g8*g4*(g31 + 2* + & g12*g8) + g12*g5*(g32 + 2*g5*g3) + g3*g1*(g33 + 2*g4* + & g1)) + if(dxitril.lt.0.d0) then + write(*,*) '*WARNING in incplas: dxitril < 0' + dxitril=0.d0 + else + dxitril=dsqrt(dxitril) + endif +! +! restoring the hardening curves for the actual temperature +! plconloc contains the true stresses. By multiplying by +! the Jacobian, yiso and ykin are Kirchhoff stresses, as +! required by the hyperelastic theory (cf. Simo, 1988). +! + niso=int(plconloc(81)) + nkin=int(plconloc(82)) + if(niso.ne.0) then + do i=1,niso + xiso(i)=plconloc(2*i-1) + yiso(i)=vj*plconloc(2*i) + enddo + endif + if(nkin.ne.0) then + do i=1,nkin + xkin(i)=plconloc(39+2*i) + ykin(i)=vj*plconloc(40+2*i) + enddo + endif +! +! check for yielding +! + if(user_hardening) then + call uhardening(amat,iel,iint,t1l,epini,ep,dtime, + & fiso,dfiso,fkin,dfkin) + fiso=fiso*vj + else + if(niso.ne.0) then + call ident(xiso,ep,niso,id) + if(id.eq.0) then + fiso=yiso(1) + elseif(id.eq.niso) then + fiso=yiso(niso) + else + dfiso=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) + fiso=yiso(id)+dfiso*(ep-xiso(id)) + endif + elseif(nkin.ne.0) then + fiso=ykin(1) + else + fiso=0.d0 + endif + endif +! + ftrial=dxitril-dsqrt(2.d0/3.d0)*fiso + if((ftrial.le.1.d-10).or.(ielas.eq.1)) then +! +! no plastic deformation +! beta contains the Cauchy residual stresses +! +c write(*,*) 'no plastic deformation' + c8=xk*(vj2-1.d0)/2.d0 +! +! residual stresses are de facto PK2 stresses +! (Piola-Kirchhoff of the second kind) +! + stre(1)=c8*ci(1)+stril(1)-beta(1) + stre(2)=c8*ci(2)+stril(2)-beta(2) + stre(3)=c8*ci(3)+stril(3)-beta(3) + stre(4)=c8*ci(4)+stril(4)-beta(4) + stre(5)=c8*ci(5)+stril(5)-beta(5) + stre(6)=c8*ci(6)+stril(6)-beta(6) +! + if(icmd.ne.3) then +! + umb=um*umb +! +! calculating the local stiffness matrix +! + xg(1,1)=(c(2)*c(3)-c(6)*c(6))/vj2 + xg(2,2)=(c(1)*c(3)-c(5)*c(5))/vj2 + xg(3,3)=(c(1)*c(2)-c(4)*c(4))/vj2 + xg(1,2)=(c(5)*c(6)-c(4)*c(3))/vj2 + xg(1,3)=(c(4)*c(6)-c(2)*c(5))/vj2 + xg(2,3)=(c(4)*c(5)-c(1)*c(6))/vj2 + xg(2,1)=xg(1,2) + xg(3,1)=xg(1,3) + xg(3,2)=xg(2,3) +! + xs(1,1)=stril(1) + xs(2,2)=stril(2) + xs(3,3)=stril(3) + xs(1,2)=stril(4) + xs(2,1)=stril(4) + xs(1,3)=stril(5) + xs(3,1)=stril(5) + xs(2,3)=stril(6) + xs(3,2)=stril(6) +! + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + elas(i)=umb*(xg(k,m)*xg(l,n)+xg(k,n)*xg(l,m)- + & 2.d0*xg(k,l)*xg(m,n)/3.d0) + & -2.d0*(xs(k,l)*xg(m,n)+xg(k,l)*xs(m,n))/3.d0 + & +xk*vj2*xg(k,l)*xg(m,n) + & -xk*(vj2-1.d0)*(xg(k,m)*xg(l,n) + & +xg(k,n)*xg(l,m))/2.d0 + enddo +! + endif +! + return + endif +! +! plastic deformation +! + umb=um*umb + umbb=umb-umbb +! +! calculating the consistency parameter +! + c1=2.d0/3.d0 + c2=dsqrt(c1) + c3=c1/um + c4=c2/um +! + iloop=0 + cop=0.d0 +! + loop: do + iloop=iloop+1 + ep=epl+c2*cop +! + if(user_hardening) then + call uhardening(amat,iel,iint,t1l,epini,ep,dtime, + & fiso,dfiso,fkin,dfkin) + fiso=fiso*vj + dfiso=dfiso*vj + fkin=fkin*vj + dfkin=dfkin*vj + else + if(niso.ne.0) then + call ident(xiso,ep,niso,id) + if(id.eq.0) then + fiso=yiso(1) + dfiso=0.d0 + elseif(id.eq.niso) then + fiso=yiso(niso) + dfiso=0.d0 + else + dfiso=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) + fiso=yiso(id)+dfiso*(ep-xiso(id)) + endif + elseif(nkin.ne.0) then + fiso=ykin(1) + dfiso=0.d0 + else + fiso=0.d0 + dfiso=0.d0 + endif +! + if(nkin.ne.0) then + call ident(xkin,ep,nkin,id) + if(id.eq.0) then + fkin=ykin(1) + dfkin=0.d0 + elseif(id.eq.nkin) then + fkin=ykin(nkin) + dfkin=0.d0 + else + dfkin=(ykin(id+1)-ykin(id))/(xkin(id+1)-xkin(id)) + fkin=ykin(id)+dfkin*(ep-xkin(id)) + endif + elseif(niso.ne.0) then + fkin=yiso(1) + dfkin=0.d0 + else + fkin=0.d0 + dfkin=0.d0 + endif + endif +! + if(dabs(cop).lt.1.d-10) then + fiso0=fiso + fkin0=fkin + endif +! + if(kode.eq.-51) then + dcop=(ftrial-c2*(fiso-fiso0) + & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/ + & (-c1*dfiso-umbb*(2.d0+c3*dfkin)) + else + if(user_creep) then + if(ithermal.eq.0) then + write(*,*) '*ERROR in incplas: no temperature defined' + stop + endif + timeabq(1)=time + timeabq(2)=ttime + qtild=(ftrial-c2*(fiso-fiso0) + & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/(c2*vj) +! +! the Von Mises stress must be positive +! + if(qtild.lt.1.d-10) qtild=1.d-10 + ec(1)=epini + call creep(decra,deswa,xstateini(1,iint,iel),serd,ec, + & esw,p,qtild,t1l,dtemp,predef,dpred,timeabq,dtime, + & amat,leximp,lend,pgauss,nstate_,iel,iint,layer,kspt, + & kstep,kinc) + dsvm=1.d0/decra(5) + dcop=-(decra(1)-c2*cop)/ + & (c2*(decra(5)*(dfiso+umbb*(3.d0+dfkin/um))+1.d0)) + else + qtild=(ftrial-c2*(fiso-fiso0) + & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/(c2*vj) +! +! the Von Mises stress must be positive +! + if(qtild.lt.1.d-10) qtild=1.d-10 + decra(1)=a1*qtild**xxn + decra(5)=xxn*decra(1)/qtild + dsvm=1.d0/decra(5) + dcop=-(decra(1)-c2*cop)/ + & (c2*(decra(5)*(dfiso+umbb*(3.d0+dfkin/um))+1.d0)) + endif + endif + cop=cop-dcop +! + if((dabs(dcop).lt.cop*1.d-4).or. + & (dabs(dcop).lt.1.d-10)) exit +! +! check for endless loops or a negative consistency +! parameter +! + if((iloop.gt.15).or.(cop.le.0.d0)) then + iloop=1 + cop=0.d0 + do + ep=epl+c2*cop +! + if(user_hardening) then + call uhardening(amat,iel,iint,t1l,epini,ep,dtime, + & fiso,dfiso,fkin,dfkin) + fiso=fiso*vj + fkin=fkin*vj + else + if(niso.ne.0) then + call ident(xiso,ep,niso,id) + if(id.eq.0) then + fiso=yiso(1) + elseif(id.eq.niso) then + fiso=yiso(niso) + else + dfiso=(yiso(id+1)-yiso(id))/ + & (xiso(id+1)-xiso(id)) + fiso=yiso(id)+dfiso*(ep-xiso(id)) + endif + elseif(nkin.ne.0) then + fiso=ykin(1) + else + fiso=0.d0 + endif +! + if(nkin.ne.0) then + call ident(xkin,ep,nkin,id) + if(id.eq.0) then + fkin=ykin(1) + elseif(id.eq.nkin) then + fkin=ykin(nkin) + else + dfkin=(ykin(id+1)-ykin(id))/ + & (xkin(id+1)-xkin(id)) + fkin=ykin(id)+dfkin*(ep-xkin(id)) + endif + elseif(niso.ne.0) then + fkin=yiso(1) + else + fkin=0.d0 + endif + endif +! + if(dabs(cop).lt.1.d-10) then + fiso0=fiso + fkin0=fkin + endif +! + if(kode.eq.-51) then + fu=(ftrial-c2*(fiso-fiso0) + & -umbb*(2.d0*cop+c4*(fkin-fkin0))) + else + if(user_creep) then + timeabq(1)=time + timeabq(2)=ttime + qtild=(ftrial-c2*(fiso-fiso0) + & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/(c2*vj) +! +! the Von Mises stress must be positive +! + if(qtild.lt.1.d-10) qtild=1.d-10 + ec(1)=epini + call creep(decra,deswa,xstateini(1,iint,iel),serd, + & ec,esw,p,qtild,t1l,dtemp,predef,dpred,timeabq, + & dtime,amat,leximp,lend,pgauss,nstate_,iel, + & iint,layer,kspt,kstep,kinc) + dsvm=1.d0/decra(5) + fu=decra(1)-c2*cop + else + qtild=(ftrial-c2*(fiso-fiso0) + & -umbb*(2.d0*cop+c4*(fkin-fkin0)))/(c2*vj) +! +! the Von Mises stress must be positive +! + if(qtild.lt.1.d-10) qtild=1.d-10 + decra(1)=a1*qtild**xxn + decra(5)=xxn*decra(1)/qtild + dsvm=1.d0/decra(5) + fu=decra(1)-c2*cop + endif + endif +! + if(iloop.eq.1) then +c write(*,*) 'cop,fu ',cop,fu + cop1=0.d0 + fu1=fu + iloop=2 + cop=1.d-10 + elseif(iloop.eq.2) then + if(fu*fu1.le.0.d0) then +c write(*,*) cop,fu + iloop=3 + fu2=fu + cop2=cop + cop=(cop1+cop2)/2.d0 + dcop=(cop2-cop1)/2.d0 + else +c write(*,*) cop,fu + cop=cop*10.d0 + if(cop.gt.100.d0) then + write(*,*) '*ERROR: no convergence in incplas' + stop + endif + endif + else +c write(*,*) cop,fu + if(fu*fu1.ge.0.d0) then + cop1=cop + fu1=fu + else + cop2=cop + fu2=fu + endif + cop=(cop1+cop2)/2.d0 + dcop=(cop2-cop1)/2.d0 + if((dabs(dcop).lt.cop*1.d-4).or. + & (dabs(dcop).lt.1.d-10)) exit loop + endif + enddo + endif +! + enddo loop +! +! updating the equivalent plastic strain +! + epl=epl+c2*cop +! +! updating the back stress +! + c5=2.d0*umbb*cop/dxitril + c6=c5/(3.d0*um) + c7=c6*dfkin*vj23 + do i=1,6 + stbl(i)=stbl(i)+c7*xitril(i) + enddo +! +! updating the stress +! vj: Jacobian of the total deformation gradient +! + c8=xk*(vj2-1.d0)/2.d0 +! + do i=1,6 + stre(i)=c8*ci(i)-beta(i)+stril(i)-c5*xitril(i) + enddo +! +! updating the plastic right Cauchy-Green tensor +! + c9=c6*3.d0*vj23 + do i=1,6 + cpl(i)=cpl(i)-c9*xitril(i) + enddo +! + if(icmd.ne.3) then +! +! calculating the local stiffness matrix +! + xg(1,1)=(c(2)*c(3)-c(6)*c(6))/vj2 + xg(2,2)=(c(1)*c(3)-c(5)*c(5))/vj2 + xg(3,3)=(c(1)*c(2)-c(4)*c(4))/vj2 + xg(1,2)=(c(5)*c(6)-c(4)*c(3))/vj2 + xg(1,3)=(c(4)*c(6)-c(2)*c(5))/vj2 + xg(2,3)=(c(4)*c(5)-c(1)*c(6))/vj2 + xg(2,1)=xg(1,2) + xg(3,1)=xg(1,3) + xg(3,2)=xg(2,3) +! + xs(1,1)=stril(1) + xs(2,2)=stril(2) + xs(3,3)=stril(3) + xs(1,2)=stril(4) + xs(2,1)=stril(4) + xs(1,3)=stril(5) + xs(3,1)=stril(5) + xs(2,3)=stril(6) + xs(3,2)=stril(6) +! + f0=2.d0*umbb*cop/dxitril + d0=1.d0+(dfkin/um+dfiso/umbb)/3.d0 +! +! creep contribution +! + if(kode.eq.-52) then + d0=d0+dsvm/(3.d0*umbb) + endif +! + f1=1.d0/d0-f0 + d1=2.d0*f1*umbb-((1.d0+dfkin/(3.d0*um))/d0-1.d0)* + & 4.d0*cop*dxitril/3.d0 + d2=2d0*dxitril*f1 +! + xx(1,1)=xitril(1) + xx(2,2)=xitril(2) + xx(3,3)=xitril(3) + xx(1,2)=xitril(4) + xx(2,1)=xitril(4) + xx(1,3)=xitril(5) + xx(3,1)=xitril(5) + xx(2,3)=xitril(6) + xx(3,2)=xitril(6) +! + xn(1,1)=xitril(1)/dxitril + xn(2,2)=xitril(2)/dxitril + xn(3,3)=xitril(3)/dxitril + xn(1,2)=xitril(4)/dxitril + xn(2,1)=xitril(4)/dxitril + xn(1,3)=xitril(5)/dxitril + xn(3,1)=xitril(5)/dxitril + xn(2,3)=xitril(6)/dxitril + xn(3,2)=xitril(6)/dxitril +! + do i=1,3 + do j=i,3 + xd(i,j)=xn(i,1)*xn(1,j)*c(1)+xn(i,1)*xn(2,j)*c(4)+ + & xn(i,1)*xn(3,j)*c(5)+xn(i,2)*xn(1,j)*c(4)+ + & xn(i,2)*xn(2,j)*c(2)+xn(i,2)*xn(3,j)*c(6)+ + & xn(i,3)*xn(1,j)*c(5)+xn(i,3)*xn(2,j)*c(6)+ + & xn(i,3)*xn(3,j)*c(3) + enddo + enddo + xd(2,1)=xd(1,2) + xd(3,1)=xd(1,3) + xd(3,2)=xd(2,3) +! +! deviatoric part +! + c1=(xd(1,1)*c(1)+xd(2,2)*c(2)+xd(3,3)*c(3)+ + & 2.d0*(xd(1,2)*c(4)+xd(1,3)*c(5)+xd(2,3)*c(6)))/3.d0 + do i=1,3 + do j=i,3 + xd(i,j)=xd(i,j)-c1*xg(i,j) + enddo + enddo + xd(2,1)=xd(1,2) + xd(3,1)=xd(1,3) + xd(3,2)=xd(2,3) +! + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + elas(i)=(umb-f0*umbb)*(xg(k,m)*xg(l,n)+xg(k,n)*xg(l,m)- + & 2.d0*xg(k,l)*xg(m,n)/3.d0) + & -2.d0*(xs(k,l)*xg(m,n)+xg(k,l)*xs(m,n))/3.d0 + & +f0*2.d0*(xx(k,l)*xg(m,n)+xg(k,l)*xx(m,n))/3.d0 + & -d1*xn(k,l)*xn(m,n)-d2*(xn(k,l)*xd(m,n)+ + & xd(k,l)*xn(m,n))/2.d0+xk*vj2*xg(k,l)*xg(m,n) + & -xk*(vj2-1.d0)*(xg(k,m)*xg(l,n)+xg(k,n)*xg(l,m))/2.d0 + enddo +! + endif +! +! updating the plastic fields +! + do i=1,3 + cpl(i)=cpl(i)-1.d0 + enddo + do i=1,6 + xstate(1+i,iint,iel)=-cpl(i)/2.d0 + xstate(7+i,iint,iel)=stbl(i) + enddo + xstate(1,iint,iel)=epl +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/inicont.c calculix-ccx-2.3/ccx_2.3/src/inicont.c --- calculix-ccx-2.1/ccx_2.3/src/inicont.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/inicont.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,188 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +void inicont(int * nk,int *ncont, int *ntie, char *tieset, int *nset, char *set, + int *istartset, int *iendset, int *ialset, int **itietrip, + char *lakon, int *ipkon, int *kon, int **koncontp, + int *nslavs, double *tietol, int *ismallsliding, int **itiefacp, + int **islavsurfp, int **islavnodep, int **imastnodep, + int **nslavnodep, int **nmastnodep, int *mortar, + int **imastopp,int *nkon,int **iponoelsp,int **inoelsp, + int **ipep, int **imep, int *ne, int *ifacecount, + int *nmpc, int *mpcfree, int *memmpc_, + int **ipompcp, char **labmpcp, int **ikmpcp, int **ilmpcp, + double **fmpcp, int **nodempcp, double **coefmpcp, + int *iperturb, int *ikboun, int *nboun){ + + char kind1[2]="C",kind2[2]="-", *tchar1=NULL, *tchar3=NULL, *labmpc=NULL; + + int *itietri=NULL,*koncont=NULL, *itiefac=NULL, *islavsurf=NULL,im, + *islavnode=NULL,*imastnode=NULL,*nslavnode=NULL,*nmastnode=NULL, + nmasts, *ipe=NULL, *ime=NULL, *imastop=NULL, + *iponoels=NULL,*inoels=NULL,ifreenoels,ifreeme, *ipoface=NULL, + *nodface=NULL,iface,*ipompc=NULL,*ikmpc=NULL, + *ilmpc=NULL,*nodempc=NULL,nmpc_,i,j,k,ncone; + + double *fmpc=NULL, *coefmpc=NULL; + + itietri=*itietrip;koncont=*koncontp;itiefac=*itiefacp;islavsurf=*islavsurfp; + islavnode=*islavnodep;imastnode=*imastnodep;nslavnode=*nslavnodep; + nmastnode=*nmastnodep;imastop=*imastopp,iponoels=*iponoelsp, + inoels=*inoelsp;ipe=*ipep;ime=*imep; + + ipompc=*ipompcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; + fmpc=*fmpcp;nodempc=*nodempcp;coefmpc=*coefmpcp; + nmpc_=*nmpc; + + /* determining the number of slave entities (nodes or faces, ncone), + and the number of master triangles (ncont) */ + + FORTRAN(allocont,(ncont,ntie,tieset,nset,set,istartset,iendset, + ialset,lakon,&ncone,tietol,ismallsliding,kind1,kind2,mortar)); + if(ncont==0) return; + + itietri=NNEW(int,2**ntie); + koncont=NNEW(int,4**ncont); + + /* triangulation of the master side */ + + FORTRAN(triangucont,(ncont,ntie,tieset,nset,set,istartset,iendset, + ialset,itietri,lakon,ipkon,kon,koncont,kind1,kind2)); + + RENEW(ipe,int,*nk); + RENEW(ime,int,12**ncont); +// memset(&ipe[0],0,sizeof(int)**nk); +// memset(&ime[0],0,sizeof(int)*12**ncont); + DMEMSET(ipe,0,*nk,0.); + DMEMSET(ime,0,12**ncont,0.); + imastop=NNEW(int,3**ncont); + + FORTRAN(trianeighbor,(ipe,ime,imastop,ncont,koncont, + &ifreeme)); + + if(*mortar==0){free(ipe);free(ime);} + else{RENEW(ime,int,4*ifreeme);} + + /* catalogueing the external faces (only for node-to-face + contact with a nodal slave surface */ + + ipoface=NNEW(int,*nk); + nodface=NNEW(int,5*6**ne); + FORTRAN(findsurface,(ipoface,nodface,ne,ipkon,kon,lakon,ntie, + tieset)); + + itiefac=NNEW(int,2**ntie); + islavsurf=NNEW(int,2*6**ne); + islavnode=NNEW(int,8*ncone); + nslavnode=NNEW(int,*ntie+1); + iponoels=NNEW(int,*nk); + inoels=NNEW(int,3**nkon); + + if(*mortar==1){ + imastnode=NNEW(int,3**ncont); + nmastnode=NNEW(int,*ntie+1); + } + + /* catalogueing the slave faces and slave nodes + catalogueing the master nodes (only for Mortar contact) */ + + FORTRAN(tiefaccont,(lakon,ipkon,kon,ntie,tieset,nset,set, + istartset,iendset,ialset,itiefac,islavsurf,islavnode, + imastnode,nslavnode,nmastnode,nslavs,&nmasts,ifacecount, + iponoels,inoels,&ifreenoels,mortar,ipoface,nodface,nk)); + + RENEW(islavsurf,int,2**ifacecount+2); + RENEW(islavnode,int,*nslavs); + RENEW(inoels,int,3*ifreenoels); + free(ipoface);free(nodface); + + if(*mortar==1){ + RENEW(imastnode,int,nmasts); + } + + /* constraining the middle nodes for the slave surfaces (not + for modal dynamics calculations) */ + + if(*iperturb>1){ + for(i=0;i<*ifacecount;i++){ + iface=islavsurf[2*i]; + gencontmpc(ne,&iface,lakon,ipkon,kon,nmpc,&ikmpc,&ilmpc,&ipompc, + mpcfree,&fmpc,&labmpc,&nodempc,memmpc_,&coefmpc,&nmpc_,ikboun, + nboun); + } + + /* constraining the middle nodes for the master surfaces (not + for modal dynamics calculations) */ + + tchar1=NNEW(char,81); + tchar3=NNEW(char,81); + for(i=0; i<*ntie; i++){ + if(tieset[i*(81*3)+80]=='C'){ + //a contact constraint was found, so increase nalset + memcpy(tchar3,&tieset[i*(81*3)+81+81],81); + tchar3[80]='\0'; + for(j=0; j<*nset; j++){ + memcpy(tchar1,&set[j*81],81); + tchar1[80]='\0'; + if(strcmp(tchar1,tchar3)==0){ + //independent element face surface was found + for(k=istartset[j]-1;k stop +! + if((nactdog(2,node1).eq.0) + & .and.(nactdog(2,node2).eq.0)) then + WRITE(*,*) '**************************************' + write(*,*) '*ERROR:in subroutine initialgas.f' + write(*,*) ' in element', nelem + write(*,*) ' Inlet and outlet pressures are ' + write(*,*) ' boundary conditions ' + write(*,*) ' node1',node1,' pressure', + & v(2,node1) + write(*,*) ' node2',node2,' pressure', + & v(2,node2) + stop +! +! if inlet pressure is an active degree of freedom +! + else if((nactdog(2,node1).ne.0) + & .and.(nactdog(2,node2).eq.0))then + WRITE(*,*) '**************************************' + write(*,*) '*WARNING:in subroutine initialgas.f' + write(*,*) ' in element', nelem + write(*,*) + & ' Inlet pressure initial condition ' + write(*,*) ' is changed ' + write(*,*) ' node1',node1, + & ' given initial pressure',v(2,node1) + v(2,node1)=1.1*v(2,node1) + write(*,*) ' node1',node1, + & ' new initial pressure',v(2,node1) + write(*,*) ' node2',node2,' pressure', + & v(2,node2) +! +! if outlet pressure is an active D.O.F. +! + else if((nactdog(2,node1).eq.0) + & .and.(nactdog(2,node2).ne.0))then + WRITE(*,*) '**************************************' + write(*,*) '*WARNING:in subroutine initialgas.f' + write(*,*) ' in element', nelem + write(*,*) + & ' Outlet pressure initial condition ' + write(*,*) ' is changed ' + write(*,*) ' node1',node1,' pressure' + & ,v(2,node1) + write(*,*) ' node2',node2, + & 'given intial pressure', + & v(2,node2) + v(2,node2)=0.9*v(2,node2) + write(*,*) ' node2',node2, + & ' new initial pressure',v(2,node2) +! +! if both inlet and outlet pressures are active D.O.F. +! + else if((nactdog(2,node1).ne.0) + & .and.(nactdog(2,node2).ne.0))then + WRITE(*,*) '**************************************' + write(*,*) '*WARNING:in subroutine initialgas.f' + write(*,*) ' in element', nelem + write(*,*) ' Inlet and outlet pressure ' + write(*,*) ' initial condition are changed ' + write(*,*) ' node1',node1, + & ' given initial pressure',v(2,node1) + v(2,node1)=1.05*v(2,node2) + write(*,*) ' node1',node1, + & ' new intial pressure',v(2,node1) + write(*,*) ' node2',node2, + & ' given initial pressure',v(2,node2) + v(2,node2)=0.95*v(2,node2) + write(*,*) ' node2',node2, + & ' new intial pressure',v(2,node2) + endif + endif +! + call flux(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,kflag,v,xflow,f, + & nodef,idirf,df,cp,r,rho,physcon,g,co,dvi,numf, + & vold,set,shcon,nshcon,rhcon,nrhcon,ntmat_,mi) +! + if(nactdog(1,nodem).ne.0) v(1,nodem)=xflow +! + if(lakon(nelem)(2:4).ne.'LIP') then + if(v(1,nodem).eq.0d0) then + WRITE(*,*) '**************************************' + write(*,*) '*ERROR:in subroutine initialgas.f' + write(*,*) ' in element', nelem, + & lakon(nelem)(1:6) + write(*,*) ' mass flow rate value = 0 !' + write(*,*) ' node1',node1,' pressure', + & v(2,node1) + write(*,*) ' node2',node2,' pressure', + & v(2,node2) + stop + endif + if (v(1,nodem).lt.0) then + WRITE(*,*) '**************************************' + write(*,*) '*WARNING: in subroutine initialgas.f' + write(*,*) ' in element', nelem + write(*,*) ' mass flow rate value .le. 0 !' + write(*,*) ' node1',node1,'pressure', + & v(2,node1) + write(*,*) ' node2',node2,'pressure', + & v(2,node2) + write(*,*) ' check element definition' + endif + endif + enddo +! +! treating liquid channels +! first calculate the initial mass flow +! +! check whether the mass flow is given as a boundary condition +! + else + do j=1,nflow + nelem=ieg(j) + index=ipkon(nelem) + nodem=kon(index+2) + if(nactdog(1,nodem).eq.0) then + idof=8*(nodem-1)+1 + call nident(ikboun,idof,nboun,id) + if(id.gt.0) then + if(ikboun(id).eq.idof) then + xflow=xbounact(ilboun(id)) + if(dabs(xflow).gt.1.d-30) exit + endif + endif + endif + enddo +! + if(dabs(xflow).gt.1.d-30) then +! +! if nonzero: set all mass flow to this value +! + do j=1,nflow + nelem=ieg(j) + index=ipkon(nelem) + nodem=kon(index+2) + if(nactdog(1,nodem).ne.0) v(1,nodem)=xflow + enddo + else +! +! calculate the mass flow: look for a sluice gate or weir +! + do j=1,nflow + nelem=ieg(j) + if((lakon(nelem)(6:7).ne.'SG').and. + & (lakon(nelem)(6:7).ne.'WE')) cycle + index=ipkon(nelem) + node1=kon(index+1) + node2=kon(index+3) + if((node1.eq.0).or.(node2.eq.0)) cycle + nodem=kon(index+2) +! +! determine the gravity vector +! + gravity=.false. + do k=1,3 + g(k)=0.d0 + enddo + if(nbody.gt.0) then + index=nelem + do + k=ipobody(1,index) + if(k.eq.0) exit + if(ibody(1,k).eq.2) then + g(1)=g(1)+xbodyact(1,k)*xbodyact(2,k) + g(2)=g(2)+xbodyact(1,k)*xbodyact(3,k) + g(3)=g(3)+xbodyact(1,k)*xbodyact(4,k) + gravity=.true. + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif + if(.not.gravity) then + write(*,*)'*ERROR in initialgas: no gravity vector' + write(*,*) ' was defined for liquid element', + & nelem + stop + endif +! + tg1=v(0,node1) + tg2=v(0,node2) + gastemp=(tg1+tg2)/2.d0 + imat=ielmat(nelem) + call materialdata_tg(imat,ntmat_,gastemp,shcon,nshcon, + & cp,r,dvi,rhcon,nrhcon,rho) +! + call flux(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,kflag,v,xflow,f, + & nodef,idirf,df,cp,r,rho,physcon,g,co,dvi,numf, + & vold,set,shcon,nshcon,rhcon,nrhcon,ntmat_,mi) +! + if(dabs(xflow).gt.1.d-30) exit + enddo +! + if(dabs(xflow).gt.1.d-30) then +! +! if nonzero: set all mass flow to this value +! + do j=1,nflow + nelem=ieg(j) + index=ipkon(nelem) + nodem=kon(index+2) + if(nactdog(1,nodem).ne.0) v(1,nodem)=xflow + enddo + else + write(*,*) '*ERROR in initialgas: initial mass flow' + write(*,*) ' cannot be determined' + stop + endif + endif +! +! calculate the depth +! + if(calcinitialpressure) then +! +! determine the streamdown depth for sluice gates, +! weirs and discontinuous slopes +! + do j=1,nflow + nelem=ieg(j) + if((lakon(nelem)(6:7).ne.'SG').and. + & (lakon(nelem)(6:7).ne.'WE').and. + & (lakon(nelem)(6:7).ne.'DS')) cycle + index=ipkon(nelem) + node1=kon(index+1) + node2=kon(index+3) + if((node1.eq.0).or.(node2.eq.0)) cycle + nodem=kon(index+2) +! +! determine the gravity vector +! + gravity=.false. + do k=1,3 + g(k)=0.d0 + enddo + if(nbody.gt.0) then + index=nelem + do + k=ipobody(1,index) + if(k.eq.0) exit + if(ibody(1,k).eq.2) then + g(1)=g(1)+xbodyact(1,k)*xbodyact(2,k) + g(2)=g(2)+xbodyact(1,k)*xbodyact(3,k) + g(3)=g(3)+xbodyact(1,k)*xbodyact(4,k) + gravity=.true. + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif + if(.not.gravity) then + write(*,*)'*ERROR in initialgas: no gravity vector' + write(*,*) ' was defined for liquid element', + & nelem + stop + endif +! + tg1=v(0,node1) + tg2=v(0,node2) + gastemp=(tg1+tg2)/2.d0 + imat=ielmat(nelem) + call materialdata_tg(imat,ntmat_,gastemp,shcon,nshcon, + & cp,r,dvi,rhcon,nrhcon,rho) +! + call flux(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,kflag,v,xflow,f, + & nodef,idirf,df,cp,r,rho,physcon,g,co,dvi,numf, + & vold,set,shcon,nshcon,rhcon,nrhcon,ntmat_,mi) +! + enddo +! +! for all other elements the depth is taken to be +! 0.9 of the depth in the downstream node of the +! streamup reference element +! + do j=1,nflow + nelem=ieg(j) + if((lakon(nelem)(6:7).eq.'SG').or. + & (lakon(nelem)(6:7).eq.'WE').or. + & (lakon(nelem)(6:7).eq.'DS')) cycle +! + index=ipkon(nelem) + node1=kon(index+1) + node2=kon(index+3) + if((node1.eq.0).or.(node2.eq.0)) cycle +! + index=ielprop(nelem) + nelemup=int(prop(index+6)) + node2up=kon(ipkon(nelemup)+3) + href=0.9d0*v(2,node2up) + if(nactdog(2,node1).ne.0) + & v(2,node1)=href + if(nactdog(2,node2).ne.0) + & v(2,node2)=href + enddo +! +! reapplying the boundary conditions (the depth of the +! sluice gate may have changed if it exceeded the critical +! value +! + do j=1,nboun + v(ndirboun(j),nodeboun(j))=xbounact(j) + enddo + endif + endif +! +! calculating the static temperature for nodes belonging to gas pipes +! and restrictors (except RESTRICTOR WALL ORIFICE) +! +c if(gaspipe) then +c node=nelem +c endif +c if(iin_abs.eq.0) then +c node=nelem +c endif + if (gaspipe.and.(iin_abs.eq.0)) then +! +! ineighe(i) is set to -1 for chamber nodes +! + do i=1,ntg +c if(ineighe(i).lt.0) ineighe(i)=0 +cc if(ineighe(i).gt.2) ineighe(i)=-ineighe(i) + if(ineighe(i).gt.2) then +c ineighe(i)=0 + ineighe(i)=-1 + write(*,*) '*WARNING :in subroutine initialgas.f' + write(*,*) ' more than 2 elements GASPIPE' + write(*,*) ' or RESTRICTOR are connected ' + write(*,*) ' to node',ieg(i),'. The common' + write(*,*) + & ' node is converted into a chamber.' + write(*,*) ' Total and static parameters are' + write(*,*) ' equal' + endif + enddo +! + do i=1,nflow + nelem=ieg(i) + index=ipkon(nelem) + node1=kon(index+1) + node2=kon(index+3) + call nident(itg,node1,ntg,id1) + call nident(itg,node2,ntg,id2) +! +! for each end node i: if ineighe(i)=-1: chamber +! if ineighe(i)=0: middle node +! else: ineighe(i)=number of pipe connections +! (max. 2 allowed) +! +! if exactly one or two pipes are connected to a node then +! the number of the element the node belongs to is stored +! in ineighe(idi) +! + if(node1.gt.0) then + if((ineighe(id1).eq.1).or. + & (ineighe(id1).eq.2)) then + if(node2.ne.0)then + ineighe(id1)=nelem + endif + endif + endif +! + if(node2.gt.0) then + if((ineighe(id2).eq.1).or. + & (ineighe(id2).eq.2)) then + if (node1.ne.0) then + ineighe(id2)=nelem + endif + endif + endif + enddo +! +! The static temperature is calculated and stored in v(3,node) +! total temperatures are supposed equal (adiabatic pipe) +! + do i=1,ntg + node=itg(i) + if(ineighe(i).gt.0) then +! + nelem=ineighe(i) + index=ielprop(nelem) + nodem=kon(ipkon(nelem)+2) +! + imat=ielmat(nelem) + call materialdata_tg(imat,ntmat_,v(0,node), + & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho) + kappa=cp/(cp-R) + xflow=v(1,nodem) + Tt=v(0,node) + Pt=v(2,node) +! + if((lakon(nelem)(2:5).eq.'GAPF') + & .or.(lakon(nelem)(2:5).eq.'GAPI')) then + A=prop(index+1) + if((lakon(nelem)(2:6).eq.'GAPFA') + & .or.(lakon(nelem)(2:6).eq.'GAPIA')) then + icase=0 + elseif((lakon(nelem)(2:6).eq.'GAPFI') + & .or.(lakon(nelem)(2:6).eq.'GAPII')) then + icase=1 + endif +! + elseif(lakon(nelem)(2:3).eq.'RE') then + index2=ipkon(nelem) + node1=kon(index2+1) + node2=kon(index2+3) + if(lakon(nelem)(4:5).eq.'EX') then + if((lakon(int(prop(index+4)))(2:6).eq.'GAPFA') + & .or.(lakon(int(prop(index+4)))(2:6).eq.'GAPIA')) + & then + icase=0 + elseif + & ((lakon(int(prop(index+4)))(2:6).eq.'GAPFI') + & .or.(lakon(int(prop(index+4)))(2:6).eq.'GAPII')) + & then + icase=1 + endif + else + icase=0 + endif +! + if(lakon(nelem)(4:5).eq.'BE') then + a=prop(index+1) +! + elseif(lakon(nelem)(4:5).eq.'BR') then + if(lakon(nelem)(4:6).eq.'BRJ') then + if(nelem.eq.nint(prop(index+2)))then + A=prop(index+5) + elseif(nelem.eq.nint(prop(index+3))) then + A=prop(index+6) + endif + elseif(lakon(nelem)(4:6).eq.'BRS') then + if(nelem.eq.nint(prop(index+2)))then + A=prop(index+5) + elseif(nelem.eq.nint(prop(index+3))) then + A=prop(index+6) + endif + endif +! + else + if(node.eq.node1) then + a=prop(index+1) + elseif(node.eq.node2) then + a=prop(index+2) + endif + endif + endif +! + if(v(3,node).eq.0) then + call ts_calc(xflow,Tt,Pt,kappa,r,a,Ts,icase) + v(3,node)=Ts + endif +! +! if the element is not of gaspipe or branch type, +! total and static temperatures are equal for all endnodes +! +c elseif((node.ne.0).and.(ineighe(i).ne.0)) then +c v(3,node)=v(0,node) + endif + enddo + endif + endif +! +! for chambers the static temperature equals the total +! temperature +! + do i=1,ntg + if(ineighe(i).eq.-1) v(3,itg(i))=v(0,itg(i)) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/inputerror.f calculix-ccx-2.3/ccx_2.3/src/inputerror.f --- calculix-ccx-2.1/ccx_2.3/src/inputerror.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/inputerror.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,35 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine inputerror(inpc,ipoinpc,iline) +! +! input error message subroutine +! + implicit none +! + character*1 inpc(*) +! + integer ipoinpc(0:*),iline,i +! + write(*,*) '*ERROR in the input deck. Card image:' + write(*,'(8x,1320a1)') + & (inpc(i),i=ipoinpc(iline-1)+1,ipoinpc(iline)) + write(*,*) +! + stop + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/inputinfo.f calculix-ccx-2.3/ccx_2.3/src/inputinfo.f --- calculix-ccx-2.1/ccx_2.3/src/inputinfo.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/inputinfo.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,35 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine inputinfo(inpc,ipoinpc,iline) +! +! input error message subroutine +! + implicit none +! + character*1 inpc(*) +! + integer ipoinpc(0:*),iline,i +! + write(*,*) '*INFO in the input deck. Card image:' + write(*,'(7x,1320a1)') + & (inpc(i),i=ipoinpc(iline-1)+1,ipoinpc(iline)) + write(*,*) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/inputwarning.f calculix-ccx-2.3/ccx_2.3/src/inputwarning.f --- calculix-ccx-2.1/ccx_2.3/src/inputwarning.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/inputwarning.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,35 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine inputwarning(inpc,ipoinpc,iline) +! +! input error message subroutine +! + implicit none +! + character*1 inpc(*) +! + integer ipoinpc(0:*),iline,i +! + write(*,*) '*WARNING in the input deck. Card image:' + write(*,'(10x,1320a1)') + & (inpc(i),i=ipoinpc(iline-1)+1,ipoinpc(iline)) + write(*,*) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/insertas.c calculix-ccx-2.3/ccx_2.3/src/insertas.c --- calculix-ccx-2.1/ccx_2.3/src/insertas.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/insertas.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,63 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +void insertas(int **irowp, int **mast1p, int *i1, + int *i2, int *ifree, int *nzs_, double *contribution, double **bdp){ + + /* inserts a new nonzero matrix position into the data structure + the structure is not assumed to be symmetric + i1: row number (FORTRAN convention) + i2: column number (FORTRAN convention) */ + + int idof1,idof2,*irow=NULL,*mast1=NULL; + double *bd=NULL; + + irow=*irowp; + mast1=*mast1p; + bd=*bdp; + + idof1 = *i1; + idof2 = *i2; + + if(*ifree>*nzs_){ +// printf("Insertas RENEW ifree = %d,nzs = %d\n",*ifree,*nzs_); +// *nzs_=(int)(1.1**nzs_); + *nzs_=(int)(1.5**nzs_); + RENEW(irow,int,*nzs_); + if (irow==NULL) printf("WARNING !!!!\n"); + RENEW(mast1,int,*nzs_); + RENEW(bd,double,*nzs_); + } + mast1[*ifree-1]=idof2; + irow[*ifree-1]=idof1; + bd[*ifree-1]=*contribution; + ++*ifree; +// printf("ifree %d\n",*ifree); + + *irowp=irow; + *mast1p=mast1; + *bdp=bd; + + return; + +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/insertas_ws.c calculix-ccx-2.3/ccx_2.3/src/insertas_ws.c --- calculix-ccx-2.1/ccx_2.3/src/insertas_ws.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/insertas_ws.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,59 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +void insertas_ws(int **irowp, int *i1, + int *i2, int *ifree, int *nzs_, double *contribution, double **bdp){ + + /* inserts a new nonzero matrix position into the data structure + the structure is not assumed to be symmetric + i1: row number (FORTRAN convention) + i2: column number (FORTRAN convention) */ + + int idof1,idof2,*irow=NULL,*mast1=NULL; + double *bd=NULL; + + irow=*irowp; + bd=*bdp; + + idof1 = *i1; + idof2 = *i2; + + if(*ifree>*nzs_){ +// printf("Insertas RENEW ifree = %d,nzs = %d\n",*ifree,*nzs_); +// *nzs_=(int)(1.1**nzs_); + *nzs_=(int)(1.5**nzs_); + RENEW(irow,int,*nzs_); + if (irow==NULL) printf("WARNING !!!!\n"); + RENEW(bd,double,*nzs_); + } + irow[*ifree-1]=idof1; + bd[*ifree-1]=*contribution; + ++*ifree; +// printf("ifree %d\n",*ifree); + + *irowp=irow; + *bdp=bd; + + return; + +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/insert.c calculix-ccx-2.3/ccx_2.3/src/insert.c --- calculix-ccx-2.1/ccx_2.3/src/insert.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/insert.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,140 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +void insert(int *ipointer, int **mast1p, int **mast2p, int *i1, + int *i2, int *ifree, int *nzs_){ + + /* inserts a new nonzero matrix position into the data structure */ + + int idof1,idof2,istart,*mast1=NULL,*mast2=NULL; + + mast1=*mast1p; + mast2=*mast2p; + + if(*i1<*i2){ + idof1=*i1; + idof2=*i2; + } + else{ + idof1=*i2; + idof2=*i1; + } + + if(ipointer[idof2-1]==0){ + ++*ifree; + if(*ifree>*nzs_){ + *nzs_=(int)(1.1**nzs_); + RENEW(mast1,int,*nzs_); + RENEW(mast2,int,*nzs_); + /* printf(" reallocation: nzs_=%d\n\n",*nzs_);*/ + } + ipointer[idof2-1]=*ifree; +/* printf("idof1=%d,idof2=%d,ifree=%d\n",idof1,idof2,*ifree);*/ + mast1[*ifree-1]=idof1; + mast2[*ifree-1]=0; + } + else{ + istart=ipointer[idof2-1]; + while(1){ + if(mast1[istart-1]==idof1) break; + if(mast2[istart-1]==0){ + ++*ifree; + if(*ifree>*nzs_){ + *nzs_=(int)(1.1**nzs_); + RENEW(mast1,int,*nzs_); + RENEW(mast2,int,*nzs_); +/* printf(" reallocation: nzs_=%d\n\n",*nzs_);*/ + } + mast2[istart-1]=*ifree; + mast1[*ifree-1]=idof1; + mast2[*ifree-1]=0; + break; + } + else{ + istart=mast2[istart-1]; + } + } + } + + *mast1p=mast1; + *mast2p=mast2; + + return; + +} + +/* + +Here starts the original FORTRAN code, which was transferred to the +C-code above in order to allow automatic reallocation + + subroutine insert(ipointer,mast1,mast2,i1,i2,ifree,nzs_) +! +! inserts a new nonzero matrix position into the data structure +! + implicit none +! + integer ipointer(*),mast1(*),mast2(*),i1,i2,ifree,nzs_,idof1, + & idof2,istart +! + if(i1.lt.i2) then + idof1=i1 + idof2=i2 + else + idof1=i2 + idof2=i1 + endif +! + if(ipointer(idof2).eq.0) then + ifree=ifree+1 + if(ifree.gt.nzs_) then + write(*,*) '*ERROR in insert: increase nzs_' + stop + endif + ipointer(idof2)=ifree + mast1(ifree)=idof1 + mast2(ifree)=0 + else + istart=ipointer(idof2) + do + if(mast1(istart).eq.idof1) exit + if(mast2(istart).eq.0) then + ifree=ifree+1 + if(ifree.gt.nzs_) then + write(*,*) '*ERROR in insert: increase nzs_' + stop + endif + mast2(istart)=ifree + mast1(ifree)=idof1 + mast2(ifree)=0 + exit + else + istart=mast2(istart) + endif + enddo + endif +! + return + end + + */ diff -Nru calculix-ccx-2.1/ccx_2.3/src/interpol_alfa2.f calculix-ccx-2.3/ccx_2.3/src/interpol_alfa2.f --- calculix-ccx-2.1/ccx_2.3/src/interpol_alfa2.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/interpol_alfa2.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,29 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine interpol_alfa2(lzd,reynolds,alfa2) +! + implicit none +! + real*8 alfa2,lzd,reynolds +! + alfa2=1.d0 + +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/isort2i.f calculix-ccx-2.3/ccx_2.3/src/isort2i.f --- calculix-ccx-2.1/ccx_2.3/src/isort2i.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/isort2i.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,331 @@ +*DECK ISORT + SUBROUTINE ISORT2I (IX, N, KFLAG) +C***BEGIN PROLOGUE ISORT +C***PURPOSE Sort an array and optionally make the same interchanges in +C an auxiliary array. The array may be sorted in increasing +C or decreasing order. A slightly modified QUICKSORT +C algorithm is used. +C***LIBRARY SLATEC +C***CATEGORY N6A2A +C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) +C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING +C***AUTHOR Jones, R. E., (SNLA) +C Kahaner, D. K., (NBS) +C Wisniewski, J. A., (SNLA) +C***DESCRIPTION +C +C ISORT sorts array IX and optionally makes the same interchanges in +C array IY. The array IX may be sorted in increasing order or +C decreasing order. A slightly modified quicksort algorithm is used. +C +C Description of Parameters +C IX(2,*) - integer array of values to be sorted +C IX(1,*) - integer array to be (optionally) carried along +C N - number of values in integer array IX to be sorted +C KFLAG - control parameter +C = 2 means sort IX(2,*) in increasing order and carry IX(1,*) +C along. +C = 1 means sort IX(2,*) in increasing order (ignoring IX(1,*)) +C = -1 means sort IX(2,*) in decreasing order (ignoring IX(1,*)) +C = -2 means sort IX(2,*) in decreasing order and carry IX(1,*) +C along. +C +C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm +C for sorting with minimal storage, Communications of +C the ACM, 12, 3 (1969), pp. 185-187. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 761118 DATE WRITTEN +C 810801 Modified by David K. Kahaner. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891009 Removed unreferenced statement labels. (WRB) +C 891009 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) +C 920501 Reformatted the REFERENCES section. (DWL, WRB) +C 920519 Clarified error messages. (DWL) +C 920801 Declarations section rebuilt and code restructured to use +C IF-THEN-ELSE-ENDIF. (RWC, WRB) +! 100411 changed the dimension of IL and IU from 21 to 31. +! +! field IL and IU have the dimension 31. This is log2 of the largest +! array size to be sorted. If arrays larger than 2**31 in length have +! to be sorted, this dimension has to be modified accordingly +! +C***END PROLOGUE ISORT +C .. Scalar Arguments .. + INTEGER KFLAG, N +C .. Array Arguments .. + INTEGER IX(2,*) +C .. Local Scalars .. + REAL R + INTEGER I, IJ, J, K, KK, L, M, NN, T, TT, TTY, TY +C .. Local Arrays .. + INTEGER IL(31), IU(31) +C .. External Subroutines .. +! EXTERNAL XERMSG +C .. Intrinsic Functions .. + INTRINSIC ABS, INT +C***FIRST EXECUTABLE STATEMENT ISORT + NN = N + IF (NN .LT. 1) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The number of values to be sorted is not positive.', 1, 1) + RETURN + ENDIF +C + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, +! + 1) + RETURN + ENDIF +C +C Alter array IX to get decreasing order if needed +C + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + IX(2,I) = -IX(2,I) + 10 CONTINUE + ENDIF +C + IF (KK .EQ. 2) GO TO 100 +C +C Sort IX only +C + M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 30 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(2,IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(2,I) .GT. T) THEN + IX(2,IJ) = IX(2,I) + IX(2,I) = T + T = IX(2,IJ) + ENDIF + L = J +C +C If last element of array is less than than T, interchange with T +C + IF (IX(2,J) .LT. T) THEN + IX(2,IJ) = IX(2,J) + IX(2,J) = T + T = IX(2,IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(2,I) .GT. T) THEN + IX(2,IJ) = IX(2,I) + IX(2,I) = T + T = IX(2,IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 40 L = L-1 + IF (IX(2,L) .GT. T) GO TO 40 +C +C Find an element in the first half of the array which is greater +C than T +C + 50 K = K+1 + IF (IX(2,K) .LT. T) GO TO 50 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(2,L) + IX(2,L) = IX(2,K) + IX(2,K) = TT + GO TO 40 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 +C +C Begin again on another portion of the unsorted array +C + 60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 +C + 80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = IX(2,I+1) + IF (IX(2,I) .LE. T) GO TO 80 + K = I +C + 90 IX(2,K+1) = IX(2,K) + K = K-1 + IF (T .LT. IX(2,K)) GO TO 90 + IX(2,K+1) = T + GO TO 80 +C +C Sort IX and carry IY along +C + 100 M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 120 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(2,IJ) + TY = IX(1,IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(2,I) .GT. T) THEN + IX(2,IJ) = IX(2,I) + IX(2,I) = T + T = IX(2,IJ) + IX(1,IJ) = IX(1,I) + IX(1,I) = TY + TY = IX(1,IJ) + ENDIF + L = J +C +C If last element of array is less than T, interchange with T +C + IF (IX(2,J) .LT. T) THEN + IX(2,IJ) = IX(2,J) + IX(2,J) = T + T = IX(2,IJ) + IX(1,IJ) = IX(1,J) + IX(1,J) = TY + TY = IX(1,IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(2,I) .GT. T) THEN + IX(2,IJ) = IX(2,I) + IX(2,I) = T + T = IX(2,IJ) + IX(1,IJ) = IX(1,I) + IX(1,I) = TY + TY = IX(1,IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 130 L = L-1 + IF (IX(2,L) .GT. T) GO TO 130 +C +C Find an element in the first half of the array which is greater +C than T +C + 140 K = K+1 + IF (IX(2,K) .LT. T) GO TO 140 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(2,L) + IX(2,L) = IX(2,K) + IX(2,K) = TT + TTY = IX(1,L) + IX(1,L) = IX(1,K) + IX(1,K) = TTY + GO TO 130 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 +C +C Begin again on another portion of the unsorted array +C + 150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 +C + 170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = IX(2,I+1) + TY = IX(1,I+1) + IF (IX(2,I) .LE. T) GO TO 170 + K = I +C + 180 IX(2,K+1) = IX(2,K) + IX(1,K+1) = IX(1,K) + K = K-1 + IF (T .LT. IX(2,K)) GO TO 180 + IX(2,K+1) = T + IX(1,K+1) = TY + GO TO 170 +C +C Clean up +C + 190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + IX(2,I) = -IX(2,I) + 200 CONTINUE + ENDIF + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/isortic.f calculix-ccx-2.3/ccx_2.3/src/isortic.f --- calculix-ccx-2.1/ccx_2.3/src/isortic.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/isortic.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,332 @@ +C*DECK ISORT + SUBROUTINE ISORTIC (IX, IY, N, KFLAG) +C***BEGIN PROLOGUE ISORT +C***PURPOSE Sort an array and optionally make the same interchanges in +C an auxiliary array. The array may be sorted in increasing +C or decreasing order. A slightly modified QUICKSORT +C algorithm is used. +C***LIBRARY SLATEC +C***CATEGORY N6A2A +C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) +C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING +C***AUTHOR Jones, R. E., (SNLA) +C Kahaner, D. K., (NBS) +C Wisniewski, J. A., (SNLA) +C***DESCRIPTION +C +C ISORT sorts array IX and optionally makes the same interchanges in +C array IY. The array IX may be sorted in increasing order or +C decreasing order. A slightly modified quicksort algorithm is used. +C +C Description of Parameters +C IX - integer array of values to be sorted +C IY - character*1 array to be (optionally) carried along +C N - number of values in integer array IX to be sorted +C KFLAG - control parameter +C = 2 means sort IX in increasing order and carry IY along. +C = 1 means sort IX in increasing order (ignoring IY) +C = -1 means sort IX in decreasing order (ignoring IY) +C = -2 means sort IX in decreasing order and carry IY along. +C +C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm +C for sorting with minimal storage, Communications of +C the ACM, 12, 3 (1969), pp. 185-187. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 761118 DATE WRITTEN +C 810801 Modified by David K. Kahaner. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891009 Removed unreferenced statement labels. (WRB) +C 891009 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) +C 920501 Reformatted the REFERENCES section. (DWL, WRB) +C 920519 Clarified error messages. (DWL) +C 920801 Declarations section rebuilt and code restructured to use +C IF-THEN-ELSE-ENDIF. (RWC, WRB) +! 100411 changed the dimension of IL and IU from 21 to 31. +! +! field IL and IU have the dimension 31. This is log2 of the largest +! array size to be sorted. If arrays larger than 2**31 in length have +! to be sorted, this dimension has to be modified accordingly +! +C***END PROLOGUE ISORT +C .. Scalar Arguments .. + INTEGER KFLAG, N +C .. Array Arguments .. + INTEGER IX(*) + character*1 IY(*) +C .. Local Scalars .. + REAL R + INTEGER I, IJ, J, K, KK, L, M, NN, T, TT + character*1 TTY, TY +C .. Local Arrays .. + INTEGER IL(31), IU(31) +C .. External Subroutines .. +! EXTERNAL XERMSG +C .. Intrinsic Functions .. + INTRINSIC ABS, INT +C***FIRST EXECUTABLE STATEMENT ISORT + NN = N + IF (NN .LT. 1) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The number of values to be sorted is not positive.', 1, 1) + RETURN + ENDIF +C + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, +! + 1) + RETURN + ENDIF +C +C Alter array IX to get decreasing order if needed +C + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + IX(I) = -IX(I) + 10 CONTINUE + ENDIF +C + IF (KK .EQ. 2) GO TO 100 +C +C Sort IX only +C + M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 30 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + ENDIF + L = J +C +C If last element of array is less than than T, interchange with T +C + IF (IX(J) .LT. T) THEN + IX(IJ) = IX(J) + IX(J) = T + T = IX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 40 L = L-1 + IF (IX(L) .GT. T) GO TO 40 +C +C Find an element in the first half of the array which is greater +C than T +C + 50 K = K+1 + IF (IX(K) .LT. T) GO TO 50 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(L) + IX(L) = IX(K) + IX(K) = TT + GO TO 40 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 +C +C Begin again on another portion of the unsorted array +C + 60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 +C + 80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = IX(I+1) + IF (IX(I) .LE. T) GO TO 80 + K = I +C + 90 IX(K+1) = IX(K) + K = K-1 + IF (T .LT. IX(K)) GO TO 90 + IX(K+1) = T + GO TO 80 +C +C Sort IX and carry IY along +C + 100 M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 120 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(IJ) + TY = IY(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + IY(IJ) = IY(I) + IY(I) = TY + TY = IY(IJ) + ENDIF + L = J +C +C If last element of array is less than T, interchange with T +C + IF (IX(J) .LT. T) THEN + IX(IJ) = IX(J) + IX(J) = T + T = IX(IJ) + IY(IJ) = IY(J) + IY(J) = TY + TY = IY(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + IY(IJ) = IY(I) + IY(I) = TY + TY = IY(IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 130 L = L-1 + IF (IX(L) .GT. T) GO TO 130 +C +C Find an element in the first half of the array which is greater +C than T +C + 140 K = K+1 + IF (IX(K) .LT. T) GO TO 140 +C +C Interchange these elements +C +c IF (K .LE. L) THEN + IF (K .lt. L) THEN + TT = IX(L) + IX(L) = IX(K) + IX(K) = TT + TTY = IY(L) + IY(L) = IY(K) + IY(K) = TTY + GO TO 130 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 +C +C Begin again on another portion of the unsorted array +C + 150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 +C + 170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = IX(I+1) + TY = IY(I+1) + IF (IX(I) .LE. T) GO TO 170 + K = I +C + 180 IX(K+1) = IX(K) + IY(K+1) = IY(K) + K = K-1 + IF (T .LT. IX(K)) GO TO 180 + IX(K+1) = T + IY(K+1) = TY + GO TO 170 +C +C Clean up +C + 190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + IX(I) = -IX(I) + 200 CONTINUE + ENDIF + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/isortiddc1.f calculix-ccx-2.3/ccx_2.3/src/isortiddc1.f --- calculix-ccx-2.1/ccx_2.3/src/isortiddc1.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/isortiddc1.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,430 @@ +*DECK ISORT + SUBROUTINE ISORTIDDC1 (IX, DY1,DY2,CY, N, KFLAG) +! +! modified to sort in addition a double (dy) and char*20 (cy) array! +! +C***BEGIN PROLOGUE ISORT +C***PURPOSE Sort an array and optionally make the same interchanges in +C an auxiliary array. The array may be sorted in increasing +C or decreasing order. A slightly modified QUICKSORT +C algorithm is used. +C***LIBRARY SLATEC +C***CATEGORY N6A2A +C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) +C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING +C***AUTHOR Jones, R. E., (SNLA) +C Kahaner, D. K., (NBS) +C Wisniewski, J. A., (SNLA) +C***DESCRIPTION +C +C ISORT sorts array IX and optionally makes the same interchanges in +C array IY. The array IX may be sorted in increasing order or +C decreasing order. A slightly modified quicksort algorithm is used. +C +C Description of Parameters +C IX - integer array of values to be sorted +C IY - integer array to be (optionally) carried along +C N - number of values in integer array IX to be sorted +C KFLAG - control parameter +C = 2 means sort IX in increasing order and carry IY along. +C = 1 means sort IX in increasing order (ignoring IY) +C = -1 means sort IX in decreasing order (ignoring IY) +C = -2 means sort IX in decreasing order and carry IY along. +C +C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm +C for sorting with minimal storage, Communications of +C the ACM, 12, 3 (1969), pp. 185-187. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 761118 DATE WRITTEN +C 810801 Modified by David K. Kahaner. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891009 Removed unreferenced statement labels. (WRB) +C 891009 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) +C 920501 Reformatted the REFERENCES section. (DWL, WRB) +C 920519 Clarified error messages. (DWL) +C 920801 Declarations section rebuilt and code restructured to use +C IF-THEN-ELSE-ENDIF. (RWC, WRB) +! 100411 changed the dimension of IL and IU from 21 to 31. +! +! field IL and IU have the dimension 31. This is log2 of the largest +! array size to be sorted. If arrays larger than 2**31 in length have +! to be sorted, this dimension has to be modified accordingly +! +C***END PROLOGUE ISORT +C .. Scalar Arguments .. + INTEGER KFLAG, N,iside,istat +C .. Array Arguments .. + INTEGER IX(2,*) + real*8 DY1(2,*),DY2(2,*) + character*20 CY(*) +C .. Local Scalars .. + REAL R + INTEGER I, IJ, J, K, KK, L, M, NN, T, TT + real*8 TTY11,TTY12,TY11,TY12,TTY21,TTY22,TY21,TY22,TTX2,TX2 + character*20 UUY,UY +C .. Local Arrays .. + INTEGER IL(31), IU(31) +C .. External Subroutines .. +! EXTERNAL XERMSG +C .. Intrinsic Functions .. + INTRINSIC ABS, INT +C***FIRST EXECUTABLE STATEMENT ISORT +! + do i=1,n + read(cy(i)(2:2),'(i1)',iostat=istat) iside + if(istat.gt.0) iside=0 + ix(1,i)=10*ix(1,i)+iside + enddo +! + NN = N + IF (NN .LT. 1) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The number of values to be sorted is not positive.', 1, 1) + RETURN + ENDIF +C + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, +! + 1) + RETURN + ENDIF +C +C Alter array IX to get decreasing order if needed +C + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + IX(1,I) = -IX(1,I) + 10 CONTINUE + ENDIF +C + IF (KK .EQ. 2) GO TO 100 +C +C Sort IX only +C + M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 30 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(1,IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(1,I) .GT. T) THEN + IX(1,IJ) = IX(1,I) + IX(1,I) = T + T = IX(1,IJ) + ENDIF + L = J +C +C If last element of array is less than than T, interchange with T +C + IF (IX(1,J) .LT. T) THEN + IX(1,IJ) = IX(1,J) + IX(1,J) = T + T = IX(1,IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(1,I) .GT. T) THEN + IX(1,IJ) = IX(1,I) + IX(1,I) = T + T = IX(1,IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 40 L = L-1 + IF (IX(1,L) .GT. T) GO TO 40 +C +C Find an element in the first half of the array which is greater +C than T +C + 50 K = K+1 + IF (IX(1,K) .LT. T) GO TO 50 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(1,L) + IX(1,L) = IX(1,K) + IX(1,K) = TT + GO TO 40 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 +C +C Begin again on another portion of the unsorted array +C + 60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 +C + 80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = IX(1,I+1) + IF (IX(1,I) .LE. T) GO TO 80 + K = I +C + 90 IX(1,K+1) = IX(1,K) + K = K-1 + IF (T .LT. IX(1,K)) GO TO 90 + IX(1,K+1) = T + GO TO 80 +C +C Sort IX and carry IY along +C + 100 M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 120 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(1,IJ) + TY11 = DY1(1,IJ) + TY21 = DY1(2,IJ) + TY12 = DY2(1,IJ) + TY22 = DY2(2,IJ) + TX2 = IX(2,IJ) + uy = cy(ij) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(1,I) .GT. T) THEN + IX(1,IJ) = IX(1,I) + IX(1,I) = T + T = IX(1,IJ) + DY1(1,IJ) = DY1(1,I) + DY1(2,IJ) = DY1(2,I) + DY2(1,IJ) = DY2(1,I) + DY2(2,IJ) = DY2(2,I) + IX(2,IJ) = IX(2,I) + cy(ij) = cy(i) + DY1(1,I) = TY11 + DY1(2,I) = TY21 + DY2(1,I) = TY12 + DY2(2,I) = TY22 + IX(2,I) = TX2 + cy(i) = uy + TY11 = DY1(1,IJ) + TY21 = DY1(2,IJ) + TY12 = DY2(1,IJ) + TY22 = DY2(2,IJ) + TX2 = IX(2,IJ) + uy = cy(ij) + ENDIF + L = J +C +C If last element of array is less than T, interchange with T +C + IF (IX(1,J) .LT. T) THEN + IX(1,IJ) = IX(1,J) + IX(1,J) = T + T = IX(1,IJ) + DY1(1,IJ) = DY1(1,J) + DY1(2,IJ) = DY1(2,J) + DY2(1,IJ) = DY2(1,J) + DY2(2,IJ) = DY2(2,J) + IX(2,IJ) = IX(2,J) + cy(ij) = cy(j) + DY1(1,J) = TY11 + DY1(2,J) = TY21 + DY2(1,J) = TY12 + DY2(2,J) = TY22 + IX(2,J) = TX2 + cy(j) = uy + TY11 = DY1(1,IJ) + TY21 = DY1(2,IJ) + TY12 = DY2(1,IJ) + TY22 = DY2(2,IJ) + TX2 = IX(2,IJ) + uy = cy(ij) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(1,I) .GT. T) THEN + IX(1,IJ) = IX(1,I) + IX(1,I) = T + T = IX(1,IJ) + DY1(1,IJ) = DY1(1,I) + DY1(2,IJ) = DY1(2,I) + DY2(1,IJ) = DY2(1,I) + DY2(2,IJ) = DY2(2,I) + IX(2,IJ) = IX(2,I) + cy(ij) = cy(i) + DY1(1,I) = TY11 + DY1(2,I) = TY21 + DY2(1,I) = TY12 + DY2(2,I) = TY22 + IX(2,I) = TX2 + cy(i) = uy + TY11 = DY1(1,IJ) + TY21 = DY1(2,IJ) + TY12 = DY2(1,IJ) + TY22 = DY2(2,IJ) + TX2 = IX(2,IJ) + uy = cy(ij) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 130 L = L-1 + IF (IX(1,L) .GT. T) GO TO 130 +C +C Find an element in the first half of the array which is greater +C than T +C + 140 K = K+1 + IF (IX(1,K) .LT. T) GO TO 140 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(1,L) + IX(1,L) = IX(1,K) + IX(1,K) = TT + TTY11 = DY1(1,L) + TTY21 = DY1(2,L) + TTY12 = DY2(1,L) + TTY22 = DY2(2,L) + TTX2 = IX(2,L) + uuy = cy(l) + DY1(1,L) = DY1(1,K) + DY1(2,L) = DY1(2,K) + DY2(1,L) = DY2(1,K) + DY2(2,L) = DY2(2,K) + IX(2,L) = IX(2,K) + cy(l) = cy(k) + DY1(1,K) = TTY11 + DY1(2,K) = TTY21 + DY2(1,K) = TTY12 + DY2(2,K) = TTY22 + IX(2,K) = TTX2 + cy(k) = uuy + GO TO 130 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 +C +C Begin again on another portion of the unsorted array +C + 150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 +C + 170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = IX(1,I+1) + TY11 = DY1(1,I+1) + TY21 = DY1(2,I+1) + TY12 = DY2(1,I+1) + TY22 = DY2(2,I+1) + TX2 = IX(2,I+1) + uy = cy(i+1) + IF (IX(1,I) .LE. T) GO TO 170 + K = I +C + 180 IX(1,K+1) = IX(1,K) + DY1(1,K+1) = DY1(1,K) + DY1(2,K+1) = DY1(2,K) + DY2(1,K+1) = DY2(1,K) + DY2(2,K+1) = DY2(2,K) + IX(2,K+1) = IX(2,K) + cy(k+1) = cy(k) + K = K-1 + IF (T .LT. IX(1,K)) GO TO 180 + IX(1,K+1) = T + DY1(1,K+1) = TY11 + DY1(2,K+1) = TY21 + DY2(1,K+1) = TY12 + DY2(2,K+1) = TY22 + IX(2,K+1) = TX2 + cy(k+1) = uy + GO TO 170 +C +C Clean up +C + 190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + IX(1,I) = -IX(1,I) + 200 CONTINUE + ENDIF +! + do i=1,nn + read(cy(i)(2:2),'(i1)',iostat=istat) iside + if(istat.gt.0) iside=0 + ix(1,i)=(ix(1,i)-iside)/10 + enddo +! + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/isortiddc2.f calculix-ccx-2.3/ccx_2.3/src/isortiddc2.f --- calculix-ccx-2.1/ccx_2.3/src/isortiddc2.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/isortiddc2.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,465 @@ +*DECK ISORT + SUBROUTINE ISORTIDDC2 (IX1,ix2, DY1,DY2,CY, N, KFLAG) +! +! modified to sort in addition a double (dy) and char*20 (cy) array! +! +C***BEGIN PROLOGUE ISORT +C***PURPOSE Sort an array and optionally make the same interchanges in +C an auxiliary array. The array may be sorted in increasing +C or decreasing order. A slightly modified QUICKSORT +C algorithm is used. +C***LIBRARY SLATEC +C***CATEGORY N6A2A +C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) +C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING +C***AUTHOR Jones, R. E., (SNLA) +C Kahaner, D. K., (NBS) +C Wisniewski, J. A., (SNLA) +C***DESCRIPTION +C +C ISORT sorts array IX1 and optionally makes the same interchanges in +C array IY. The array IX1 may be sorted in increasing order or +C decreasing order. A slightly modified quicksort algorithm is used. +C +C Description of Parameters +C IX1 - integer array of values to be sorted +C IY - integer array to be (optionally) carried along +C N - number of values in integer array IX1 to be sorted +C KFLAG - control parameter +C = 2 means sort IX1 in increasing order and carry IY along. +C = 1 means sort IX1 in increasing order (ignoring IY) +C = -1 means sort IX1 in decreasing order (ignoring IY) +C = -2 means sort IX1 in decreasing order and carry IY along. +C +C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm +C for sorting with minimal storage, Communications of +C the ACM, 12, 3 (1969), pp. 185-187. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 761118 DATE WRITTEN +C 810801 Modified by David K. Kahaner. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891009 Removed unreferenced statement labels. (WRB) +C 891009 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901012 Declared all variables; changed X,Y to IX1,IY. (M. McClain) +C 920501 Reformatted the REFERENCES section. (DWL, WRB) +C 920519 Clarified error messages. (DWL) +C 920801 Declarations section rebuilt and code restructured to use +C IF-THEN-ELSE-ENDIF. (RWC, WRB) +! 100411 changed the dimension of IL and IU from 21 to 31. +! +! field IL and IU have the dimension 31. This is log2 of the largest +! array size to be sorted. If arrays larger than 2**31 in length have +! to be sorted, this dimension has to be modified accordingly +! +C***END PROLOGUE ISORT +C .. Scalar Arguments .. + implicit none +c + INTEGER KFLAG, N,iside,istat +C .. Array Arguments .. + INTEGER IX1(2,*),ix2(2,*) + real*8 DY1(2,*),DY2(2,*) + character*20 CY(*) +C .. Local Scalars .. + REAL R + INTEGER I, IJ, J, K, KK, L, M, NN, T, TT,tx21,tx12,tx22, + & ttx21,ttx12,ttx22 + real*8 TTY11,TTY12,TY11,TY12,TTY21,TTY22,TY21,TY22 + character*20 UUY,UY +C .. Local Arrays .. + INTEGER IL(31), IU(31) +C .. External Subroutines .. +! EXTERNAL XERMSG +C .. Intrinsic Functions .. + INTRINSIC ABS, INT +C***FIRST EXECUTABLE STATEMENT ISORT +! + do i=1,n + read(cy(i)(2:2),'(i1)',iostat=istat) iside + if(istat.gt.0) iside=0 + ix1(1,i)=10*ix1(1,i)+iside + enddo +! + NN = N + IF (NN .LT. 1) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The number of values to be sorted is not positive.', 1, 1) + RETURN + ENDIF +C + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, +! + 1) + RETURN + ENDIF +C +C Alter array IX1 to get decreasing order if needed +C + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + IX1(1,I) = -IX1(1,I) + 10 CONTINUE + ENDIF +C + IF (KK .EQ. 2) GO TO 100 +C +C Sort IX1 only +C + M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 30 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX1(1,IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX1(1,I) .GT. T) THEN + IX1(1,IJ) = IX1(1,I) + IX1(1,I) = T + T = IX1(1,IJ) + ENDIF + L = J +C +C If last element of array is less than than T, interchange with T +C + IF (IX1(1,J) .LT. T) THEN + IX1(1,IJ) = IX1(1,J) + IX1(1,J) = T + T = IX1(1,IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX1(1,I) .GT. T) THEN + IX1(1,IJ) = IX1(1,I) + IX1(1,I) = T + T = IX1(1,IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 40 L = L-1 + IF (IX1(1,L) .GT. T) GO TO 40 +C +C Find an element in the first half of the array which is greater +C than T +C + 50 K = K+1 + IF (IX1(1,K) .LT. T) GO TO 50 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX1(1,L) + IX1(1,L) = IX1(1,K) + IX1(1,K) = TT + GO TO 40 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 +C +C Begin again on another portion of the unsorted array +C + 60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 +C + 80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = IX1(1,I+1) + IF (IX1(1,I) .LE. T) GO TO 80 + K = I +C + 90 IX1(1,K+1) = IX1(1,K) + K = K-1 + IF (T .LT. IX1(1,K)) GO TO 90 + IX1(1,K+1) = T + GO TO 80 +C +C Sort IX1 and carry IY along +C + 100 M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 120 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX1(1,IJ) + TY11 = DY1(1,IJ) + TY21 = DY1(2,IJ) + TY12 = DY2(1,IJ) + TY22 = DY2(2,IJ) + TX21 = IX1(2,IJ) + tx12=ix2(1,ij) + tx22=ix2(2,ij) + uy = cy(ij) +C +C If first element of array is greater than T, interchange with T +C + IF (IX1(1,I) .GT. T) THEN + IX1(1,IJ) = IX1(1,I) + IX1(1,I) = T + T = IX1(1,IJ) + DY1(1,IJ) = DY1(1,I) + DY1(2,IJ) = DY1(2,I) + DY2(1,IJ) = DY2(1,I) + DY2(2,IJ) = DY2(2,I) + IX1(2,IJ) = IX1(2,I) + ix2(1,ij)=ix2(1,i) + ix2(2,ij)=ix2(2,i) + cy(ij) = cy(i) + DY1(1,I) = TY11 + DY1(2,I) = TY21 + DY2(1,I) = TY12 + DY2(2,I) = TY22 + IX1(2,I) = TX21 + ix2(1,i)=tx12 + ix2(2,i)=tx22 + cy(i) = uy + TY11 = DY1(1,IJ) + TY21 = DY1(2,IJ) + TY12 = DY2(1,IJ) + TY22 = DY2(2,IJ) + TX21 = IX1(2,IJ) + tx12=ix2(1,ij) + tx22=ix2(2,ij) + uy = cy(ij) + ENDIF + L = J +C +C If last element of array is less than T, interchange with T +C + IF (IX1(1,J) .LT. T) THEN + IX1(1,IJ) = IX1(1,J) + IX1(1,J) = T + T = IX1(1,IJ) + DY1(1,IJ) = DY1(1,J) + DY1(2,IJ) = DY1(2,J) + DY2(1,IJ) = DY2(1,J) + DY2(2,IJ) = DY2(2,J) + IX1(2,IJ) = IX1(2,J) + ix2(1,ij)=ix2(1,j) + ix2(2,ij)=ix2(2,j) + cy(ij) = cy(j) + DY1(1,J) = TY11 + DY1(2,J) = TY21 + DY2(1,J) = TY12 + DY2(2,J) = TY22 + IX1(2,J) = TX21 + ix2(1,j)=tx12 + ix2(2,j)=tx22 + cy(j) = uy + TY11 = DY1(1,IJ) + TY21 = DY1(2,IJ) + TY12 = DY2(1,IJ) + TY22 = DY2(2,IJ) + TX21 = IX1(2,IJ) + tx12=ix2(1,ij) + tx22=ix2(2,ij) + uy = cy(ij) +C +C If first element of array is greater than T, interchange with T +C + IF (IX1(1,I) .GT. T) THEN + IX1(1,IJ) = IX1(1,I) + IX1(1,I) = T + T = IX1(1,IJ) + DY1(1,IJ) = DY1(1,I) + DY1(2,IJ) = DY1(2,I) + DY2(1,IJ) = DY2(1,I) + DY2(2,IJ) = DY2(2,I) + IX1(2,IJ) = IX1(2,I) + ix2(1,ij)=ix2(1,i) + ix2(2,ij)=ix2(2,i) + cy(ij) = cy(i) + DY1(1,I) = TY11 + DY1(2,I) = TY21 + DY2(1,I) = TY12 + DY2(2,I) = TY22 + IX1(2,I) = TX21 + ix2(1,i)=tx12 + ix2(2,i)=tx22 + cy(i) = uy + TY11 = DY1(1,IJ) + TY21 = DY1(2,IJ) + TY12 = DY2(1,IJ) + TY22 = DY2(2,IJ) + TX21 = IX1(2,IJ) + tx12=ix2(1,ij) + tx22=ix2(2,ij) + uy = cy(ij) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 130 L = L-1 + IF (IX1(1,L) .GT. T) GO TO 130 +C +C Find an element in the first half of the array which is greater +C than T +C + 140 K = K+1 + IF (IX1(1,K) .LT. T) GO TO 140 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX1(1,L) + IX1(1,L) = IX1(1,K) + IX1(1,K) = TT + TTY11 = DY1(1,L) + TTY21 = DY1(2,L) + TTY12 = DY2(1,L) + TTY22 = DY2(2,L) + TTX21 = IX1(2,L) + ttx12=ix2(1,l) + ttx22=ix2(2,l) + uuy = cy(l) + DY1(1,L) = DY1(1,K) + DY1(2,L) = DY1(2,K) + DY2(1,L) = DY2(1,K) + DY2(2,L) = DY2(2,K) + IX1(2,L) = IX1(2,K) + ix2(1,l)=ix2(1,k) + ix2(2,l)=ix2(2,k) + cy(l) = cy(k) + DY1(1,K) = TTY11 + DY1(2,K) = TTY21 + DY2(1,K) = TTY12 + DY2(2,K) = TTY22 + IX1(2,K) = TTX21 + ix2(1,k)=ttx12 + ix2(2,k)=ttx22 + cy(k) = uuy + GO TO 130 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 +C +C Begin again on another portion of the unsorted array +C + 150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 +C + 170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = IX1(1,I+1) + TY11 = DY1(1,I+1) + TY21 = DY1(2,I+1) + TY12 = DY2(1,I+1) + TY22 = DY2(2,I+1) + TX21 = IX1(2,I+1) + tx12=ix2(1,i+1) + tx22=ix2(2,i+1) + uy = cy(i+1) + IF (IX1(1,I) .LE. T) GO TO 170 + K = I +C + 180 IX1(1,K+1) = IX1(1,K) + DY1(1,K+1) = DY1(1,K) + DY1(2,K+1) = DY1(2,K) + DY2(1,K+1) = DY2(1,K) + DY2(2,K+1) = DY2(2,K) + IX1(2,K+1) = IX1(2,K) + ix2(1,k+1)=ix2(1,k) + ix2(2,k+1)=ix2(2,k) + cy(k+1) = cy(k) + K = K-1 + IF (T .LT. IX1(1,K)) GO TO 180 + IX1(1,K+1) = T + DY1(1,K+1) = TY11 + DY1(2,K+1) = TY21 + DY2(1,K+1) = TY12 + DY2(2,K+1) = TY22 + IX1(2,K+1) = TX21 + ix2(1,k+1)=tx12 + ix2(2,k+1)=tx22 + cy(k+1) = uy + GO TO 170 +C +C Clean up +C + 190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + IX1(1,I) = -IX1(1,I) + 200 CONTINUE + ENDIF +! + do i=1,nn + read(cy(i)(2:2),'(i1)',iostat=istat) iside + if(istat.gt.0) iside=0 + ix1(1,i)=(ix1(1,i)-iside)/10 + enddo +! + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/isortid.f calculix-ccx-2.3/ccx_2.3/src/isortid.f --- calculix-ccx-2.1/ccx_2.3/src/isortid.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/isortid.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,333 @@ +*DECK ISORT + SUBROUTINE ISORTID (IX, DY, N, KFLAG) +c +c changed on 01.02.2001: auxiliary array is now real*8 +c +C***BEGIN PROLOGUE ISORT +C***PURPOSE Sort an array and optionally make the same interchanges in +C an auxiliary array. The array may be sorted in increasing +C or decreasing order. A slightly modified QUICKSORT +C algorithm is used. +C***LIBRARY SLATEC +C***CATEGORY N6A2A +C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) +C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING +C***AUTHOR Jones, R. E., (SNLA) +C Kahaner, D. K., (NBS) +C Wisniewski, J. A., (SNLA) +C***DESCRIPTION +C +C ISORT sorts array IX and optionally makes the same interchanges in +C array DY. The array IX may be sorted in increasing order or +C decreasing order. A slightly modified quicksort algorithm is used. +C +C Description of Parameters +C IX - integer array of values to be sorted +C DY - real*8 array to be (optionally) carried along +C N - number of values in integer array IX to be sorted +C KFLAG - control parameter +C = 2 means sort IX in increasing order and carry DY along. +C = 1 means sort IX in increasing order (ignoring DY) +C = -1 means sort IX in decreasing order (ignoring DY) +C = -2 means sort IX in decreasing order and carry DY along. +C +C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm +C for sorting with minimal storage, Communications of +C the ACM, 12, 3 (1969), pp. 185-187. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 761118 DATE WRITTEN +C 810801 Modified by David K. Kahaner. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891009 Removed unreferenced statement labels. (WRB) +C 891009 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901012 Declared all variables; changed X,Y to IX,DY. (M. McClain) +C 920501 Reformatted the REFERENCES section. (DWL, WRB) +C 920519 Clarified error messages. (DWL) +C 920801 Declarations section rebuilt and code restructured to use +C IF-THEN-ELSE-ENDIF. (RWC, WRB) +! 100411 changed the dimension of IL and IU from 21 to 31. +! +! field IL and IU have the dimension 31. This is log2 of the largest +! array size to be sorted. If arrays larger than 2**31 in length have +! to be sorted, this dimension has to be modified accordingly +! +C***END PROLOGUE ISORT +C .. Scalar Arguments .. + INTEGER KFLAG, N +C .. Array Arguments .. + INTEGER IX(*) + real*8 DY(*),TY,TTY +C .. Local Scalars .. + REAL R + INTEGER I, IJ, J, K, KK, L, M, NN, T, TT +C .. Local Arrays .. + INTEGER IL(31), IU(31) +C .. External Subroutines .. +! EXTERNAL XERMSG +C .. Intrinsic Functions .. + INTRINSIC ABS, INT +C***FIRST EXECUTABLE STATEMENT ISORT + NN = N + IF (NN .LT. 1) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The number of values to be sorted is not positive.', 1, 1) + RETURN + ENDIF +C + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, +! + 1) + RETURN + ENDIF +C +C Alter array IX to get decreasing order if needed +C + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + IX(I) = -IX(I) + 10 CONTINUE + ENDIF +C + IF (KK .EQ. 2) GO TO 100 +C +C Sort IX only +C + M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 30 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + ENDIF + L = J +C +C If last element of array is less than than T, interchange with T +C + IF (IX(J) .LT. T) THEN + IX(IJ) = IX(J) + IX(J) = T + T = IX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 40 L = L-1 + IF (IX(L) .GT. T) GO TO 40 +C +C Find an element in the first half of the array which is greater +C than T +C + 50 K = K+1 + IF (IX(K) .LT. T) GO TO 50 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(L) + IX(L) = IX(K) + IX(K) = TT + GO TO 40 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 +C +C Begin again on another portion of the unsorted array +C + 60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 +C + 80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = IX(I+1) + IF (IX(I) .LE. T) GO TO 80 + K = I +C + 90 IX(K+1) = IX(K) + K = K-1 + IF (T .LT. IX(K)) GO TO 90 + IX(K+1) = T + GO TO 80 +C +C Sort IX and carry DY along +C + 100 M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 120 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(IJ) + TY = DY(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + DY(IJ) = DY(I) + DY(I) = TY + TY = DY(IJ) + ENDIF + L = J +C +C If last element of array is less than T, interchange with T +C + IF (IX(J) .LT. T) THEN + IX(IJ) = IX(J) + IX(J) = T + T = IX(IJ) + DY(IJ) = DY(J) + DY(J) = TY + TY = DY(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + DY(IJ) = DY(I) + DY(I) = TY + TY = DY(IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 130 L = L-1 + IF (IX(L) .GT. T) GO TO 130 +C +C Find an element in the first half of the array which is greater +C than T +C + 140 K = K+1 + IF (IX(K) .LT. T) GO TO 140 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(L) + IX(L) = IX(K) + IX(K) = TT + TTY = DY(L) + DY(L) = DY(K) + DY(K) = TTY + GO TO 130 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 +C +C Begin again on another portion of the unsorted array +C + 150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 +C + 170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = IX(I+1) + TY = DY(I+1) + IF (IX(I) .LE. T) GO TO 170 + K = I +C + 180 IX(K+1) = IX(K) + DY(K+1) = DY(K) + K = K-1 + IF (T .LT. IX(K)) GO TO 180 + IX(K+1) = T + DY(K+1) = TY + GO TO 170 +C +C Clean up +C + 190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + IX(I) = -IX(I) + 200 CONTINUE + ENDIF + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/isorti.f calculix-ccx-2.3/ccx_2.3/src/isorti.f --- calculix-ccx-2.1/ccx_2.3/src/isorti.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/isorti.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,36 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine isorti(nl,list,nk,key) +! +! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) +! + integer nl,nk,i,j,t,value,list(nl),key(nk) + do 20 i=2,nl + t=list(i) + value=key(t) + do 10 j=i-1,1,-1 + if(value.ge.key(list(j))) then + list(j+1)=t + go to 20 + endif + list(j+1)=list(j) + 10 continue + list(1)=t + 20 continue + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/isortiid.f calculix-ccx-2.3/ccx_2.3/src/isortiid.f --- calculix-ccx-2.1/ccx_2.3/src/isortiid.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/isortiid.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,352 @@ +*DECK ISORT + SUBROUTINE ISORTIID (IX,CY,DY,N,KFLAG) +! +! modified to sort in addition an integer (cy) and double (dy) array! +! +C***BEGIN PROLOGUE ISORT +C***PURPOSE Sort an array and optionally make the same interchanges in +C an auxiliary array. The array may be sorted in increasing +C or decreasing order. A slightly modified QUICKSORT +C algorithm is used. +C***LIBRARY SLATEC +C***CATEGORY N6A2A +C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) +C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING +C***AUTHOR Jones, R. E., (SNLA) +C Kahaner, D. K., (NBS) +C Wisniewski, J. A., (SNLA) +C***DESCRIPTION +C +C ISORT sorts array IX and optionally makes the same interchanges in +C array IY. The array IX may be sorted in increasing order or +C decreasing order. A slightly modified quicksort algorithm is used. +C +C Description of Parameters +C IX - integer array of values to be sorted +C IY - integer array to be (optionally) carried along +C N - number of values in integer array IX to be sorted +C KFLAG - control parameter +C = 2 means sort IX in increasing order and carry IY along. +C = 1 means sort IX in increasing order (ignoring IY) +C = -1 means sort IX in decreasing order (ignoring IY) +C = -2 means sort IX in decreasing order and carry IY along. +C +C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm +C for sorting with minimal storage, Communications of +C the ACM, 12, 3 (1969), pp. 185-187. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 761118 DATE WRITTEN +C 810801 Modified by David K. Kahaner. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891009 Removed unreferenced statement labels. (WRB) +C 891009 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) +C 920501 Reformatted the REFERENCES section. (DWL, WRB) +C 920519 Clarified error messages. (DWL) +C 920801 Declarations section rebuilt and code restructured to use +C IF-THEN-ELSE-ENDIF. (RWC, WRB) +! 100411 changed the dimension of IL and IU from 21 to 31. +! +! field IL and IU have the dimension 31. This is log2 of the largest +! array size to be sorted. If arrays larger than 2**31 in length have +! to be sorted, this dimension has to be modified accordingly +! +C***END PROLOGUE ISORT +C .. Scalar Arguments .. + INTEGER KFLAG, N +C .. Array Arguments .. + INTEGER IX(*) + real*8 dy(*) + integer cy(*) +C .. Local Scalars .. + REAL R + INTEGER I, IJ, J, K, KK, L, M, NN, T, TT + real*8 tty,ty + integer uuy,uy +C .. Local Arrays .. + INTEGER IL(31), IU(31) +C .. External Subroutines .. +! EXTERNAL XERMSG +C .. Intrinsic Functions .. + INTRINSIC ABS, INT +C***FIRST EXECUTABLE STATEMENT ISORT + NN = N + IF (NN .LT. 1) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The number of values to be sorted is not positive.', 1, 1) + RETURN + ENDIF +C + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, +! + 1) + RETURN + ENDIF +C +C Alter array IX to get decreasing order if needed +C + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + IX(I) = -IX(I) + 10 CONTINUE + ENDIF +C + IF (KK .EQ. 2) GO TO 100 +C +C Sort IX only +C + M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 30 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + ENDIF + L = J +C +C If last element of array is less than than T, interchange with T +C + IF (IX(J) .LT. T) THEN + IX(IJ) = IX(J) + IX(J) = T + T = IX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 40 L = L-1 + IF (IX(L) .GT. T) GO TO 40 +C +C Find an element in the first half of the array which is greater +C than T +C + 50 K = K+1 + IF (IX(K) .LT. T) GO TO 50 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(L) + IX(L) = IX(K) + IX(K) = TT + GO TO 40 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 +C +C Begin again on another portion of the unsorted array +C + 60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 +C + 80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = IX(I+1) + IF (IX(I) .LE. T) GO TO 80 + K = I +C + 90 IX(K+1) = IX(K) + K = K-1 + IF (T .LT. IX(K)) GO TO 90 + IX(K+1) = T + GO TO 80 +C +C Sort IX and carry IY along +C + 100 M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 120 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(IJ) + TY = DY(IJ) + uy = cy(ij) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + DY(IJ) = DY(I) + cy(ij) = cy(i) + DY(I) = TY + cy(i) = uy + TY = DY(IJ) + uy = cy(ij) + ENDIF + L = J +C +C If last element of array is less than T, interchange with T +C + IF (IX(J) .LT. T) THEN + IX(IJ) = IX(J) + IX(J) = T + T = IX(IJ) + DY(IJ) = DY(J) + cy(ij) = cy(j) + DY(J) = TY + cy(j) = uy + TY = DY(IJ) + uy = cy(ij) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + DY(IJ) = DY(I) + cy(ij) = cy(i) + DY(I) = TY + cy(i) = uy + TY = DY(IJ) + uy = cy(ij) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 130 L = L-1 + IF (IX(L) .GT. T) GO TO 130 +C +C Find an element in the first half of the array which is greater +C than T +C + 140 K = K+1 + IF (IX(K) .LT. T) GO TO 140 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(L) + IX(L) = IX(K) + IX(K) = TT + TTY = DY(L) + uuy = cy(l) + DY(L) = DY(K) + cy(l) = cy(k) + DY(K) = TTY + cy(k) = uuy + GO TO 130 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 +C +C Begin again on another portion of the unsorted array +C + 150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 +C + 170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = IX(I+1) + TY = DY(I+1) + uy = cy(i+1) + IF (IX(I) .LE. T) GO TO 170 + K = I +C + 180 IX(K+1) = IX(K) + DY(K+1) = DY(K) + cy(k+1) = cy(k) + K = K-1 + IF (T .LT. IX(K)) GO TO 180 + IX(K+1) = T + DY(K+1) = TY + cy(k+1) = uy + GO TO 170 +C +C Clean up +C + 190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + IX(I) = -IX(I) + 200 CONTINUE + ENDIF + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/isortii.f calculix-ccx-2.3/ccx_2.3/src/isortii.f --- calculix-ccx-2.1/ccx_2.3/src/isortii.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/isortii.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,329 @@ +*DECK ISORT + SUBROUTINE ISORTII (IX, IY, N, KFLAG) +C***BEGIN PROLOGUE ISORT +C***PURPOSE Sort an array and optionally make the same interchanges in +C an auxiliary array. The array may be sorted in increasing +C or decreasing order. A slightly modified QUICKSORT +C algorithm is used. +C***LIBRARY SLATEC +C***CATEGORY N6A2A +C***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) +C***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING +C***AUTHOR Jones, R. E., (SNLA) +C Kahaner, D. K., (NBS) +C Wisniewski, J. A., (SNLA) +C***DESCRIPTION +C +C ISORT sorts array IX and optionally makes the same interchanges in +C array IY. The array IX may be sorted in increasing order or +C decreasing order. A slightly modified quicksort algorithm is used. +C +C Description of Parameters +C IX - integer array of values to be sorted +C IY - integer array to be (optionally) carried along +C N - number of values in integer array IX to be sorted +C KFLAG - control parameter +C = 2 means sort IX in increasing order and carry IY along. +C = 1 means sort IX in increasing order (ignoring IY) +C = -1 means sort IX in decreasing order (ignoring IY) +C = -2 means sort IX in decreasing order and carry IY along. +C +C***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm +C for sorting with minimal storage, Communications of +C the ACM, 12, 3 (1969), pp. 185-187. +C***ROUTINES CALLED XERMSG +C***REVISION HISTORY (YYMMDD) +C 761118 DATE WRITTEN +C 810801 Modified by David K. Kahaner. +C 890531 Changed all specific intrinsics to generic. (WRB) +C 890831 Modified array declarations. (WRB) +C 891009 Removed unreferenced statement labels. (WRB) +C 891009 REVISION DATE from Version 3.2 +C 891214 Prologue converted to Version 4.0 format. (BAB) +C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) +C 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) +C 920501 Reformatted the REFERENCES section. (DWL, WRB) +C 920519 Clarified error messages. (DWL) +C 920801 Declarations section rebuilt and code restructured to use +C IF-THEN-ELSE-ENDIF. (RWC, WRB) +! 100411 changed the dimension of IL and IU from 21 to 31. +! +! field IL and IU have the dimension 31. This is log2 of the largest +! array size to be sorted. If arrays larger than 2**31 in length have +! to be sorted, this dimension has to be modified accordingly +! +C***END PROLOGUE ISORT +C .. Scalar Arguments .. + INTEGER KFLAG, N +C .. Array Arguments .. + INTEGER IX(*), IY(*) +C .. Local Scalars .. + REAL R + INTEGER I, IJ, J, K, KK, L, M, NN, T, TT, TTY, TY +C .. Local Arrays .. + INTEGER IL(31), IU(31) +C .. External Subroutines .. +! EXTERNAL XERMSG +C .. Intrinsic Functions .. + INTRINSIC ABS, INT +C***FIRST EXECUTABLE STATEMENT ISORT + NN = N + IF (NN .LT. 1) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The number of values to be sorted is not positive.', 1, 1) + RETURN + ENDIF +C + KK = ABS(KFLAG) + IF (KK.NE.1 .AND. KK.NE.2) THEN +! CALL XERMSG ('SLATEC', 'ISORT', +! + 'The sort control parameter, K, is not 2, 1, -1, or -2.', 2, +! + 1) + RETURN + ENDIF +C +C Alter array IX to get decreasing order if needed +C + IF (KFLAG .LE. -1) THEN + DO 10 I=1,NN + IX(I) = -IX(I) + 10 CONTINUE + ENDIF +C + IF (KK .EQ. 2) GO TO 100 +C +C Sort IX only +C + M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 20 IF (I .EQ. J) GO TO 60 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 30 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + ENDIF + L = J +C +C If last element of array is less than than T, interchange with T +C + IF (IX(J) .LT. T) THEN + IX(IJ) = IX(J) + IX(J) = T + T = IX(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 40 L = L-1 + IF (IX(L) .GT. T) GO TO 40 +C +C Find an element in the first half of the array which is greater +C than T +C + 50 K = K+1 + IF (IX(K) .LT. T) GO TO 50 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(L) + IX(L) = IX(K) + IX(K) = TT + GO TO 40 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 70 +C +C Begin again on another portion of the unsorted array +C + 60 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 70 IF (J-I .GE. 1) GO TO 30 + IF (I .EQ. 1) GO TO 20 + I = I-1 +C + 80 I = I+1 + IF (I .EQ. J) GO TO 60 + T = IX(I+1) + IF (IX(I) .LE. T) GO TO 80 + K = I +C + 90 IX(K+1) = IX(K) + K = K-1 + IF (T .LT. IX(K)) GO TO 90 + IX(K+1) = T + GO TO 80 +C +C Sort IX and carry IY along +C + 100 M = 1 + I = 1 + J = NN + R = 0.375E0 +C + 110 IF (I .EQ. J) GO TO 150 + IF (R .LE. 0.5898437E0) THEN + R = R+3.90625E-2 + ELSE + R = R-0.21875E0 + ENDIF +C + 120 K = I +C +C Select a central element of the array and save it in location T +C + IJ = I + INT((J-I)*R) + T = IX(IJ) + TY = IY(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + IY(IJ) = IY(I) + IY(I) = TY + TY = IY(IJ) + ENDIF + L = J +C +C If last element of array is less than T, interchange with T +C + IF (IX(J) .LT. T) THEN + IX(IJ) = IX(J) + IX(J) = T + T = IX(IJ) + IY(IJ) = IY(J) + IY(J) = TY + TY = IY(IJ) +C +C If first element of array is greater than T, interchange with T +C + IF (IX(I) .GT. T) THEN + IX(IJ) = IX(I) + IX(I) = T + T = IX(IJ) + IY(IJ) = IY(I) + IY(I) = TY + TY = IY(IJ) + ENDIF + ENDIF +C +C Find an element in the second half of the array which is smaller +C than T +C + 130 L = L-1 + IF (IX(L) .GT. T) GO TO 130 +C +C Find an element in the first half of the array which is greater +C than T +C + 140 K = K+1 + IF (IX(K) .LT. T) GO TO 140 +C +C Interchange these elements +C + IF (K .LE. L) THEN + TT = IX(L) + IX(L) = IX(K) + IX(K) = TT + TTY = IY(L) + IY(L) = IY(K) + IY(K) = TTY + GO TO 130 + ENDIF +C +C Save upper and lower subscripts of the array yet to be sorted +C + IF (L-I .GT. J-K) THEN + IL(M) = I + IU(M) = L + I = K + M = M+1 + ELSE + IL(M) = K + IU(M) = J + J = L + M = M+1 + ENDIF + GO TO 160 +C +C Begin again on another portion of the unsorted array +C + 150 M = M-1 + IF (M .EQ. 0) GO TO 190 + I = IL(M) + J = IU(M) +C + 160 IF (J-I .GE. 1) GO TO 120 + IF (I .EQ. 1) GO TO 110 + I = I-1 +C + 170 I = I+1 + IF (I .EQ. J) GO TO 150 + T = IX(I+1) + TY = IY(I+1) + IF (IX(I) .LE. T) GO TO 170 + K = I +C + 180 IX(K+1) = IX(K) + IY(K+1) = IY(K) + K = K-1 + IF (T .LT. IX(K)) GO TO 180 + IX(K+1) = T + IY(K+1) = TY + GO TO 170 +C +C Clean up +C + 190 IF (KFLAG .LE. -1) THEN + DO 200 I=1,NN + IX(I) = -IX(I) + 200 CONTINUE + ENDIF + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/keystart.f calculix-ccx-2.3/ccx_2.3/src/keystart.f --- calculix-ccx-2.1/ccx_2.3/src/keystart.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/keystart.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,80 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine keystart(ifreeinp,ipoinp,inp,name,iline,ikey) +! + implicit none +! +! stores the order in which the input is to be read in fields +! ipoinp and inp; for details on these fields, look at file +! variables.txt +! +! order: +! 1) *RESTART,READ +! 2) *NODE +! 3) *ELEMENT +! 4) *NSET +! 5) *ELSET +! 6) *TRANSFORM +! 7) *MATERIAL +! 8) *ORIENTATION +! 9) *SURFACE +! 10) *TIE +! 11) *SURFACE INTERACTION +! 12) *INITIAL CONDITIONS +! 13) *AMPLITUDE +! 14) everything else +! + integer nentries + parameter(nentries=14) +! + character*20 name,nameref(nentries) +! + integer ifreeinp,ipoinp(2,*),inp(3,*),namelen(nentries),i,ikey, + & iline +! +! order in which the cards have to be read +! + data nameref /'RESTART,READ','NODE','ELEMENT','NSET', + & 'ELSET','TRANSFORM','MATERIAL','ORIENTATION', + & 'SURFACE','TIE','SURFACEINTERACTION', + & 'INITIALCONDITIONS','AMPLITUDE','REST'/ +! +! length of the names in field nameref +! + data namelen /12,4,7,4,5,9,8,11,7,3,18,17,9,4/ +! + do i=1,nentries + if(name(1:namelen(i)).eq.nameref(i)(1:namelen(i))) then + if(ikey.eq.i) return + if(ikey.gt.0) inp(2,ipoinp(2,ikey))=iline-1 + ikey=i + if(ipoinp(1,i).eq.0) then + ipoinp(1,i)=ifreeinp + else + inp(3,ipoinp(2,i))=ifreeinp + endif + ipoinp(2,i)=ifreeinp + exit + endif + enddo + inp(1,ifreeinp)=iline + ifreeinp=ifreeinp+1 +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/knotmpc.f calculix-ccx-2.3/ccx_2.3/src/knotmpc.f --- calculix-ccx-2.1/ccx_2.3/src/knotmpc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/knotmpc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,149 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine knotmpc(ipompc,nodempc,coefmpc,irefnode,irotnode, + & iexpnode, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, + & ikboun,ilboun,nboun,nboun_,node,typeboun,co,xboun,istep) +! +! generates three knot MPC's for node "node" about reference +! (translational) node irefnode and rotational node irotnode +! + implicit none +! + character*1 typeboun(*) + character*20 labmpc(*) +! + integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), + & ilmpc(*),node,id,mpcfreeold,j,idof,l,nodeboun(*), + & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,irefnode, + & irotnode,iexpnode,istep +! + real*8 coefmpc(*),co(3,*),xboun(*),e(3,3,3) +! + data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., + & 0.,0.,1.,0.,0.,0.,-1.,0.,0., + & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ +! + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in knotmpc: increase nk_' + stop + endif + do j=1,3 + idof=8*(node-1)+j + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + cycle + endif + endif + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in knotmpc: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)='KNOT ' +! + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=j + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) +! +! translation term +! + nodempc(1,mpcfree)=irefnode + nodempc(2,mpcfree)=j + coefmpc(mpcfree)=-1.d0 + mpcfree=nodempc(3,mpcfree) +! +! expansion term +! + nodempc(1,mpcfree)=iexpnode + nodempc(2,mpcfree)=1 + if(istep.gt.1) then + coefmpc(mpcfree)=co(j,irefnode)-co(j,node) + endif + mpcfree=nodempc(3,mpcfree) +! +! rotation terms +! + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=1 + if(istep.gt.1) then + coefmpc(mpcfree)=e(j,1,1)*(co(1,irefnode)-co(1,node))+ + & e(j,2,1)*(co(2,irefnode)-co(2,node))+ + & e(j,3,1)*(co(3,irefnode)-co(3,node)) + endif + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=2 + if(istep.gt.1) then + coefmpc(mpcfree)=e(j,1,2)*(co(1,irefnode)-co(1,node))+ + & e(j,2,2)*(co(2,irefnode)-co(2,node))+ + & e(j,3,2)*(co(3,irefnode)-co(3,node)) + endif + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=3 + if(istep.gt.1) then + coefmpc(mpcfree)=e(j,1,3)*(co(1,irefnode)-co(1,node))+ + & e(j,2,3)*(co(2,irefnode)-co(2,node))+ + & e(j,3,3)*(co(3,irefnode)-co(3,node)) + endif + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=j + coefmpc(mpcfree)=1.d0 + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + idof=8*(nk-1)+j + call nident(ikboun,idof,nboun,id) + nboun=nboun+1 + if(nboun.gt.nboun_) then + write(*,*) '*ERROR in knotmpc: increase nboun_' + stop + endif + nodeboun(nboun)=nk + ndirboun(nboun)=j + typeboun(nboun)='R' + if(istep.gt.1) then + xboun(nboun)=0.d0 + endif + do l=nboun,id+2,-1 + ikboun(l)=ikboun(l-1) + ilboun(l)=ilboun(l-1) + enddo + ikboun(id+1)=idof + ilboun(id+1)=nboun + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/label.f calculix-ccx-2.3/ccx_2.3/src/label.f --- calculix-ccx-2.1/ccx_2.3/src/label.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/label.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,55 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine label(n,e2,adj,xadj,nnn,iw,oldpro,newpro, + & oldpro_exp,newpro_exp) +! +! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) +! + integer n,i1,i2,i3,i,snode,lstnum,nc,oldpro,newpro,e2,xadj(n+1), + & adj(e2),nnn(n),iw(3*n+1),oldpro_exp,newpro_exp +! + do 10 i=1,n + nnn(i)=0 + 10 continue +! + i1=1 + i2=i1+n + i3=i2+n+1 +! + lstnum=0 + 20 if(lstnum.lt.n) then +! + call diamtr(n,e2,adj,xadj,nnn,iw(i1),iw(i2),iw(i3),snode,nc) +! + call number(n,nc,snode,lstnum,e2,adj,xadj,nnn,iw(i1),iw(i2)) + go to 20 + endif +! + call profil(n,nnn,e2,adj,xadj,oldpro,newpro,oldpro_exp, + & newpro_exp) +! + if((oldpro_exp.lt.newpro_exp).or. + & ((oldpro_exp.eq.newpro_exp).and.(oldpro.lt.newpro))) then + do 30 i=1,n + nnn(i)=i + 30 continue + newpro=oldpro + newpro_exp=oldpro_exp + endif + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/lab_straight_ppkrit.f calculix-ccx-2.3/ccx_2.3/src/lab_straight_ppkrit.f --- calculix-ccx-2.1/ccx_2.3/src/lab_straight_ppkrit.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/lab_straight_ppkrit.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,45 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! this subroutines enables to calculate the critical pressure ratio of a straight +! labyrinth seal as a function of the number of spikes (n). +! +! The following table is obtained by solving iteratively the equation : +! Ps_inf/Pt0=ppkrit=1/dsqrt(1+2.n-ln(ppkrit)) +! +! this equation can be found by using the formula for the ideal mass flow in a straight labyrinth +! see "Air system Correlations Part 1 : Labyrith Seals" H.Zimmermann and K.H. Wollf ASME98-GT-206 +! and determining the maximum flow for a given number of fin. +! + subroutine lab_straight_ppkrit (n,ppkrit) +! + implicit none +! + integer n +! + real*8 fppkrit(9),ppkrit +! + data fppkrit + & /0.47113022d0,0.37968106d0,0.32930492d0,0.29569704d0, + & 0.27105479d0,0.25191791d0,0.23646609d0,0.22363192d0, + & 0.21274011/ +! + ppkrit=fppkrit(n) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/labyrinth.f calculix-ccx-2.3/ccx_2.3/src/labyrinth.f --- calculix-ccx-2.1/ccx_2.3/src/labyrinth.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/labyrinth.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,669 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine labyrinth(node1,node2,nodem,nelem,lakon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,R,physcon,co,dvi,numf,vold,set, + & kon,ipkon,mi) +! +! labyrinth element +! + implicit none +! + logical identity + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(4),idirf(4),index,iflag,mi(2), + & inv,kgas,n,iaxial,nodea,nodeb,ipkon(*),kon(*),i,itype +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R,a,d, + & p1,p2,T1,Aeff,C1,C2,C3,cd,cp,physcon(3),p2p1,km1,dvi, + & kp1,kdkm1,tdkp1,km1dk,x,y,ca1,cb1,ca2,cb2,dT1,alambda, + & rad,reynolds,pi,ppkrit,co(3,*), + & carry_over,lc,hst,e,szt,num,denom,t,s,b,h,cdu, + & cd_radius,cst,dh,cd_honeycomb,cd_lab,bdh, + & pt0zps1,cd_1spike,cdbragg,rzdh, + & cd_correction,p1p2,xflow_oil,T2,vold(0:mi(2),*) +! + itype=1 + pi=4.d0*datan(1.d0) + e=2.718281828459045d0 +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1)then +! + index=ielprop(nelem) + kappa=(cp/(cp-R)) +! +! Usual Labyrinth +! + if(lakon(nelem)(2:5).ne.'LABF') then + t=prop(index+1) + s=prop(index+2) + iaxial=int(prop(index+3)) + d=prop(index+4) + n=int(prop(index+5)) + b=prop(index+6) + h=prop(index+7) + lc=prop(index+8) + rad=prop(index+9) + X=prop(index+10) + Hst=prop(index+11) +! + A=pi*D*s +! +! "flexible" labyrinth for thermomechanical coupling +! + elseif(lakon(nelem)(2:5).eq.'LABF') then + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + iaxial=int(prop(index+3)) + t=prop(index+4) + d=prop(index+5) + n=int(prop(index+6)) + b=prop(index+7) + h=prop(index+8) +! hc=prop(index+7) + lc=prop(index+9) + rad=prop(index+10) + X=prop(index+11) + Hst=prop(index+12) + +! +! gap definition + s=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2) + if(iaxial.ne.0) then + a=pi*d*s/iaxial + else + a=pi*d*s + endif + endif +! + p1=v(2,node1) + p2=v(2,node2) + if(p1.ge.p2) then + inv=1 + T1=v(0,node1)+physcon(1) + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + T1=v(0,node2)+physcon(1) + endif +! + cd=1.d0 + Aeff=A*cd + p2p1=p2/p1 +! +!************************ +! one fin +!************************* + if(n.eq.1.d0) then +! + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + tdkp1=2.d0/kp1 + C2=tdkp1**kdkm1 +! +! subcritical +! + if(p2p1.gt.C2) then + xflow=inv*p1*Aeff*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa) + & *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(T1) +! +! critical +! + else + xflow=inv*p1*Aeff*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ + & dsqrt(T1) + endif + endif +! +!*********************** +! straight labyrinth and stepped labyrinth +! method found in "Air system Correlations Part1 Labyrinth Seals" +! H.Zimmermann and K.H. Wolff +! ASME 98-GT-206 +!********************** +! + if (n.ge.2) then +! + call lab_straight_ppkrit(n,ppkrit) +! +! subcritical case +! + if (p2p1.gt.ppkrit) then + xflow=inv*p1*Aeff/dsqrt(T1)*dsqrt((1.d0-p2p1**2.d0) + & /(R*(n-log(p2p1)/log(e)))) +! +! critical case +! + else + xflow=inv*p1*Aeff/dsqrt(T1)*dsqrt(2.d0/R)*ppkrit + endif + endif +! + elseif (iflag.eq.2)then + numf=4 + alambda=10000.d0 +! + p1=v(2,node1) + p2=v(2,node2) + if(p1.ge.p2) then + inv=1 + xflow=v(1,nodem) + T1=v(0,node1)+physcon(1) + T2=v(0,node2)+physcon(1) + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + xflow=-v(1,nodem) + T1=v(0,node2)+physcon(1) + T2=v(0,node1)+physcon(1) + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 +! +! Usual labyrinth +! + if(lakon(nelem)(2:5).ne. 'LABF') then + index=ielprop(nelem) + kappa=(cp/(cp-R)) + t=prop(index+1) + s=prop(index+2) + iaxial=int(prop(index+3)) + d=prop(index+4) + n=int(prop(index+5)) + b=prop(index+6) + h=prop(index+7) + lc=prop(index+8) + rad=prop(index+9) + X=prop(index+10) + Hst=prop(index+11) + A=pi*D*s +! +! Flexible labyrinth for coupled calculations +! + elseif(lakon(nelem)(2:5).eq.'LABF') then + index=ielprop(nelem) + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + iaxial=int(prop(index+3)) + t=prop(index+4) + d=prop(index+5) + n=int(prop(index+6)) + b=prop(index+7) + h=prop(index+8) + lc=prop(index+9) + rad=prop(index+10) + X=prop(index+11) + Hst=prop(index+12) +! +! gap definition + s=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2) + if(iaxial.ne.0) then + a=pi*d*s/iaxial + else + a=pi*d*s + endif + endif +! + p2p1=p2/p1 + dT1=dsqrt(T1) +! + Aeff=A +! +! honeycomb stator correction +! + cd_honeycomb=1.d0 + if (lc.ne.0.d0)then + call cd_lab_honeycomb(s,lc,cd_honeycomb) + cd_honeycomb=1+cd_honeycomb/100 + endif +! +! inlet radius correction +! + cd_radius=1.d0 + if((rad.ne.0.d0).and.(n.ne.1d0)) then + call cd_lab_radius(rad,s,Hst,cd_radius) + endif +! +! carry over factor (only for straight throught labyrinth) +! + if ((n.ge.2).and.(hst.eq.0d0)) then + cst=n/(n-1.d0) + szt=s/t + carry_over=cst/dsqrt(cst-szt/(szt+0.02)) + Aeff=Aeff*carry_over + endif +! +! calculation of the dynamic viscosity +! + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif +! +! calculation of the number of reynolds for a gap +! + reynolds=dabs(xflow)*2.d0*s/(dvi*A*cd_honeycomb/cd_radius) +! +!************************************** +! single fin labyrinth +! the resolution procedure is the same as for the restrictor +!************************************** +! + if(n.eq.1)then +! +! single fin labyrinth +! +! incompressible basis cd , reynolds correction,and radius correction +! +! "Flow Characteristics of long orifices with rotation and corner radiusing" +! W.F. Mcgreehan and M.J. Schotsch +! ASME 87-GT-162 +! + dh=2*s + bdh=b/dh + rzdh=rad/dh +! + call cd_Mcgreehan_Schotsch(rzdh,bdh,reynolds,cdu) +! +! compressibility correction factor +! +! S.L.Bragg +! "Effect of conpressibility on the discharge coefficient of orifices and convergent nozzles" +! Journal of Mechanical engineering vol 2 No 1 1960 +! + call cd_bragg(cdu,p2p1,cdbragg,itype) + cd=cdbragg + Aeff=Aeff*cd +! + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + tdkp1=2.d0/kp1 + C2=tdkp1**kdkm1 +! + if(p2p1.gt.C2) then + C1=dsqrt(2.d0*kdkm1/r)*Aeff + km1dk=1.d0/kdkm1 + y=p2p1**km1dk + x=dsqrt(1.d0-y) + ca1=-C1*x/(kappa*p1*y) + cb1=C1*km1dk/(2.d0*p1) + ca2=-ca1*p2p1-xflow*dT1/(p1*p1) + cb2=-cb1*p2p1 + f=xflow*dT1/p1-C1*p2p1**(1.d0/kappa)*x + if(cb2.le.-(alambda+ca2)*x) then + df(1)=-alambda + elseif(cb2.ge.(alambda-ca2)*x) then + df(1)=alambda + else + df(1)=ca2+cb2/x + endif + df(2)=xflow/(2.d0*p1*dT1) + df(3)=inv*dT1/p1 + if(cb1.le.-(alambda+ca1)*x) then + df(4)=-alambda + elseif(cb1.ge.(alambda-ca1)*x) then + df(4)=alambda + else + df(4)=ca1+cb1/x + endif + else + C3=dsqrt(kappa/r)*(tdkp1)**(kp1/(2.d0*km1))*Aeff + f=xflow*dT1/p1-C3 + df(1)=-xflow*dT1/(p1)**2 + df(2)=xflow/(2*p1*dT1) + df(3)=inv*dT1/p1 + df(4)=0.d0 + endif + endif +! +!**************************************** +! straight labyrinth & stepped labyrinth +! method found in "Air system Correlations Part1 Labyrinth Seals" +! H.Zimmermann and K.H. Wolff +! ASME 98-GT-206 +!**************************************** +! + if(n.ge.2) then + num=(1.d0-p2p1**2) + denom=R*(n-log(p2p1)/log(e)) +! +! straight labyrinth +! + if((hst.eq.0.d0).and.(n.ne.1)) then + call cd_lab_straight(n,p2p1,s,b,reynolds,cd_lab) + Aeff=Aeff*cd_lab*cd_honeycomb*cd_radius +! +! Stepped Labyrinth +! + else +! corrective term for the first spike + p1p2=p1/p2 + pt0zps1=(p1p2)**(1/prop(index+4)) + call cd_lab_1spike (pt0zps1,s,b,cd_1spike) +! +! corrective term for cd_lab_1spike +! + call cd_lab_correction (p1p2,s,b,cd_correction) +! +! calculation of the discharge coefficient of the stepped labyrinth +! + cd=cd_1spike*cd_correction + cd_lab=cd +! + Aeff=Aeff*cd_lab*cd_radius*cd_honeycomb + endif +! + call lab_straight_ppkrit(n,ppkrit) +! +! subcritical case +! + if (p2p1.gt.ppkrit) then +! + f=xflow*dT1/p1-dsqrt(num/denom)*Aeff +! + df(1)=xflow*dt1/p1**2.d0-Aeff/2.d0 + & *dsqrt(denom/num)*(2.d0*(p2**2.d0/p1**3.d0)/denom) + & +num/denom**2.d0*r/p1 + df(2)=xflow/(2.d0*p1*dT1) + df(3)=inv*dT1/p1 + df(4)=-Aeff/2.d0*dsqrt(denom/num)*(-2.d0*(p2/p1**2.d0) + & /denom)+num/denom**2.d0*r/p2 +! +! critical case +! + else + C2=dsqrt(2/R)*Aeff*ppkrit +! + f=xflow*dT1/p1-C2 + df(1)=-xflow*dT1/(p1**2) + df(2)=xflow/(2.d0*p1*dT1) + df(3)=inv*dT1/p1 + df(4)=0.d0 + endif + endif +! +! output +! + elseif(iflag.eq.3)then +! + + p1=v(2,node1) + p2=v(2,node2) + if(p1.ge.p2) then + inv=1 + xflow=v(1,nodem) + T1=v(0,node1)+physcon(1) + T2=v(0,node2)+physcon(1) + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + xflow=-v(1,nodem) + T1=v(0,node2)+physcon(1) + T2=v(0,node2)+physcon(1) + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif +! + index=ielprop(nelem) + kappa=(cp/(cp-R)) + t=prop(index+1) + s=prop(index+2) + d=prop(index+3) + n=int(prop(index+4)) + b=prop(index+5) + h=prop(index+6) + lc=prop(index+7) + rad=prop(index+8) + X=prop(index+9) + Hst=prop(index+10) +! + p2p1=p2/p1 + dT1=dsqrt(T1) +! + pi=4.d0*datan(1.d0) + A=pi*D*s + Aeff=A + e=2.718281828459045d0 +! +! honeycomb stator correction +! + if (lc.ne.0.d0)then + call cd_lab_honeycomb(s,lc,cd_honeycomb) + Aeff=Aeff*(1.d0+cd_honeycomb/100.d0) + else + cd_honeycomb=0 + endif +! +! inlet radius correction +! + if((rad.ne.0.d0).and.(n.ne.1d0)) then + call cd_lab_radius(rad,s,Hst,cd_radius) + Aeff=Aeff*cd_radius + else + cd_radius=1 + endif +! +! carry over factor (only for straight throught labyrinth) +! + if((n.gt.1).and.(hst.eq.0d0)) then + cst=n/(n-1.d0) + szt=s/t + carry_over=cst/dsqrt(cst-szt/(szt+0.02)) + Aeff=Aeff*carry_over + endif +! +! calculation of the dynamic viscosity +! + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif +! +! calculation of the number of reynolds for a gap +! + reynolds=dabs(xflow)*2.d0*s/(dvi*A) +!************************************** +! single fin labyrinth +! the resolution procedure is the same as for the restrictor +!************************************** +! + if(n.eq.1)then +! +! single fin labyrinth +! +! incompressible basis cd , reynolds correction,and radius correction +! +! "Flow Characteristics of long orifices with rotation and corner radiusing" +! W.F. Mcgreehan and M.J. Schotsch +! ASME 87-GT-162 +! + dh=2*s + bdh=b/dh + rzdh=rad/dh +! + call cd_Mcgreehan_Schotsch(rzdh,bdh,reynolds,cdu) +! +! compressibility correction factor +! +! S.L.Bragg +! "Effect of conpressibility on the discharge coefficient of orifices and convergent nozzles" +! Journal of Mechanical engineering vol 2 No 1 1960 +! + call cd_bragg(cdu,p2p1,cdbragg,itype) + cd=cdbragg + Aeff=Aeff*cd + endif +! +!**************************************** +! straight labyrinth & stepped labyrinth +! method found in "Air system Correlations Part1 Labyrinth Seals" +! H.Zimmermann and K.H. Wolff +! ASME 98-GT-206 +!**************************************** +! + if(n.ge.2) then + num=(1.d0-p2p1**2) + denom=R*(n-log(p2p1)/log(e)) +! +! straight labyrinth +! + if((hst.eq.0.d0).and.(n.ne.1)) then + call cd_lab_straight(n,p2p1,s,b,reynolds,cd_lab) + Aeff=Aeff*cd_lab*cd_honeycomb*cd_radius +! +! Stepped Labyrinth +! + else +! corrective term for the first spike + p1p2=p1/p2 + pt0zps1=(p1p2)**(1/prop(index+4)) + call cd_lab_1spike (pt0zps1,s,b,cd_1spike) +! +! corrective term for cd_lab_1spike +! + call cd_lab_correction (p1p2,s,b,cd_correction) +! +! calculation of the discharge coefficient of the stepped labyrinth +! + cd=cd_1spike*cd_correction + cd_lab=cd +! + Aeff=Aeff*cd_lab*cd_radius*cd_honeycomb + endif +! + call lab_straight_ppkrit(n,ppkrit) + + endif + + xflow_oil=0 + + write(1,*) '' + write(1,55) 'In line',int(nodem/100),' from node',node1, + &' to node', node2,': air massflow rate= ',xflow,'kg/s', + &', oil massflow rate= ',xflow_oil,'kg/s' + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) + + if(inv.eq.1) then + write(1,56)' Inlet node ',node1,': Tt1=',T1, + & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' + + write(1,*)' element S ',set(numf)(1:20) + write(1,57)' eta= ',dvi,'kg/(m*s), Re= ' , + & reynolds, + &', Cd_radius= ',cd_radius,', Cd_honeycomb= ', 1+cd_honeycomb/100 + +! straight labyrinth + if((hst.eq.0.d0).and.(n.ne.1)) then + write(1,58)' COF= ',carry_over, + & ', Cd_lab= ',cd_lab,', Cd= ',carry_over*cd_lab + +! stepped labyrinth + elseif(hst.ne.0d0) then + write(1,59)' Cd_1_fin= ', + & cd_1spike, ', Cd= ',cd,', pt0/ps1= ',pt0zps1, + & ', p0/pn= ',p1/p2 + +! single fin labyrinth + elseif(n.eq.1) then + write(1,60) ' Cd_Mcgreehan= ',cdu, + & ', Cd= ',cdbragg + endif + + write(1,56)' Outlet node ',node2,': Tt2= ',T2, + & 'K, Ts2= ',T2,'K, Pt2= ',P2/1e5,'Bar' + +! + else if(inv.eq.-1) then + write(1,56)' Inlet node ',node2,': Tt1= ',T1, + & 'K, Ts1= ',T1,'K, Pt1= ',P1/1E5, 'Bar' + + write(1,*)' element S ',set(numf)(1:20) + write(1,57)' eta=',dvi,'kg/(m*s), Re= ' + & ,reynolds, + & ', Cd_radius= ',cd_radius,', Cd_honeycomb= ',1+cd_honeycomb/100 +! +! straight labyrinth + if((hst.eq.0.d0).and.(n.ne.1)) then + write(1,58)' COF = ',carry_over, + & ', Cd_lab= ',cd_lab,', Cd= ',carry_over*cd_lab +! +! stepped labyrinth + elseif(hst.ne.0d0) then + write(1,59)' Cd_1_fin= ', + & cd_1spike,', Cd= ',cd,', pt0/ps1= ',pt0zps1, + & ', p0/pn= ',p1/p2 + +! single fin labyrinth + elseif(n.eq.1) then + write(1,60) ' Cd_Mcgreehan= ', + & cdu,' Cd= ',cdbragg + endif + write(1,56)' Outlet node ',node1,': Tt2= ',T2, + & 'K, Ts2= ',T2,'K, Pt2= ',P2/1e5, 'Bar' + + endif +! + 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A) + 57 FORMAT(1X,A,E11.5,A,G9.4,A,f6.4,A,f6.4) + 58 FORMAT(1X,A,f7.5,A,f7.5,A,f7.5) + 59 FORMAT(1X,A,f7.5,A,f7.5,A,f7.5,A,f5.3) + 60 FORMAT(1X,A,f7.5,A,f7.5) + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/limit_case_calc.f calculix-ccx-2.3/ccx_2.3/src/limit_case_calc.f --- calculix-ccx-2.1/ccx_2.3/src/limit_case_calc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/limit_case_calc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,89 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2005 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine limit_case_calc(a2,pt1,Tt2,xflow,zeta,r,kappa, + & pt2_lim,M2) +! +! For restrictor elements A1 equation is not needed +! iflag=1: calculation of the initial flux +! iflag=2: evaluate the element equation and all derivatives +! iflag=3: correct the channel depth in order to move a jump +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif((iflag.eq.1).or.(iflag.eq.2))then +! + index=ielprop(nelem) +! + h1=v(2,node1) + h2=v(2,node2) +! + z1=-g(1)*co(1,node1)-g(2)*co(2,node1)-g(3)*co(3,node1) + z2=-g(1)*co(1,node2)-g(2)*co(2,node2)-g(3)*co(3,node2) +! + dg=dsqrt(g(1)*g(1)+g(2)*g(2)+g(3)*g(3)) +! + if(iflag.eq.1) then +! +! in a first call of liquidchannel the flow is determined, +! in a second call the channel depth is calculated +! + if(lakon(nelem)(6:7).eq.'SG') then +! +! sluice gate +! + b=prop(index+1) + s0=prop(index+2) + if(s0.lt.-1.d0) then + s0=dasin((z1-z2)/dl) + endif + sqrts0=dsqrt(1.d0-s0*s0) + theta=0.d0 + h2=prop(index+3) +! + if(dabs(xflow).lt.1.d-30) then +! +! determine initial mass flow +! + if(nactdog(2,node1).ne.0) then +! +! upstream level not known +! + xflow=0.d0 + else + xflow=2.d0*dg*(rho*b*h2)**2*(h1-h2*sqrts0) + if(xflow.lt.0.d0) then + write(*,*)'*ERROR in liquidchannel: water level' + write(*,*) ' upstream of sluice gate is ' + write(*,*) ' smaller than downstream heigh + &t' + stop + else + xflow=dsqrt(xflow) + endif + endif + else +! +! determine the downstream depth +! and the upstream depth if not defined as BC +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk + if(h2.gt.hk) then +! +! for initial conditions +! + if(nactdog(2,node1).ne.0) v(2,node1)=3.d0*hk/2.d0 + v(2,node2)=hk + else +! +! for initial conditions +! + if(nactdog(2,node1).ne.0) v(2,node1)= + & xflow**2/(2.d0*dg*(rho*b*h2)**2)+h2*sqrts0 + v(2,node2)=h2 + endif + endif + elseif(lakon(nelem)(6:7).eq.'WE') then +! +! weir +! + b=prop(index+1) + p=prop(index+2) + c=prop(index+3) + sqrts0=1.d0 + theta=0.d0 +! + if(dabs(xflow).lt.1.d-30) then +! +! determine initial mass flow +! + if(nactdog(2,node1).ne.0) then +! +! upstream level unknown +! + xflow=0.d0 + else + if(h1.le.p) then + write(*,*) '*ERROR in liquidchannel' + write(*,*) ' weir height exceeds' + write(*,*) ' upstream level' + stop + endif + xflow=rho*c*b*(h1-p)**(1.5d0) + endif + else +! +! determine the downstream depth +! and the upstream depth if not defined as BC +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk +! +! for initial conditions +! + if(nactdog(2,node1).ne.0) v(2,node1)=p+3.d0*hk/2.d0 +! +! next value is used for downstream initial values +! + v(2,node2)=hk + endif +! + elseif(lakon(nelem)(6:7).eq.'DS') then + if(dabs(xflow).lt.1.d-30) then +! +! initial mass flow cannot be determined for this +! type of element +! + xflow=0.d0 + else +! +! determine the downstream depth +! + b=prop(index+1) + s0=prop(index+2) + if(s0.lt.-1.d0) then + s0=dasin((z1-z2)/dl) + endif + sqrts0=dsqrt(1.d0-s0*s0) + theta=prop(index+4) +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk +! +! initial condition for fluid depth +! supercritical value +! + v(2,node2)=hk/2.d0 + endif +! + endif + else +! +! calculating f and its derivatives +! + bresse=.false. + jump=.false. +! + xflow2=xflow*xflow +! +! element properties +! + if((lakon(nelem)(6:7).eq.'SG').or. + & (lakon(nelem)(6:7).eq.'SO').or. + & (lakon(nelem)(6:7).eq.'WO').or. + & (lakon(nelem)(6:7).eq.'RE').or. + & (lakon(nelem)(6:7).eq.' ').or. + & (lakon(nelem)(6:7).eq.'DS').or. + & (lakon(nelem)(6:7).eq.'DO')) then + b=prop(index+1) + s0=prop(index+2) + if(s0.lt.-1.d0) then + s0=dasin((z1-z2)/dl) + endif + sqrts0=dsqrt(1.d0-s0*s0) + if(lakon(nelem)(6:7).ne.'SG') then + dl=prop(index+3) + theta=prop(index+4) + xks=prop(index+5) + if(dl.le.0.d0) then + dl=dsqrt((co(1,node2)-co(1,node1))**2+ + & (co(2,node2)-co(2,node1))**2+ + & (co(3,node2)-co(3,node1))**2) + endif + else + theta=0.d0 + endif + elseif(lakon(nelem)(6:7).eq.'WE') then + b=prop(index+1) + p=prop(index+2) + c=prop(index+3) + sqrts0=1.d0 + theta=0.d0 + elseif((lakon(nelem)(6:7).eq.'CO').or. + & (lakon(nelem)(6:7).eq.'EL')) then + b1=prop(index+1) +! + s0=prop(index+2) + if(s0.lt.-1.d0) then + s0=0.d0 + endif + sqrts0=dsqrt(1.d0-s0*s0) +! + dl=prop(index+3) + if(dl.le.0.d0) then + dl=dsqrt((co(1,node2)-co(1,node1))**2+ + & (co(2,node2)-co(2,node1))**2+ + & (co(3,node2)-co(3,node1))**2) + endif +! + b2=prop(index+4) + b=(b1+b2)/2.d0 + theta=0.d0 + xks=0.d0 + elseif((lakon(nelem)(6:7).eq.'ST').or. + & (lakon(nelem)(6:7).eq.'DR')) then + b=prop(index+1) +! + s0=prop(index+2) + if(s0.lt.-1.d0) then + s0=0.d0 + endif + sqrts0=dsqrt(1.d0-s0*s0) +! + dl=prop(index+3) + if(dl.le.0.d0) then + dl=dsqrt((co(1,node2)-co(1,node1))**2+ + & (co(2,node2)-co(2,node1))**2+ + & (co(3,node2)-co(3,node1))**2) + endif +! + d=prop(index+4) + b1=b + b2=b + theta=0.d0 + xks=0.d0 + endif +! + if(xflow.ge.0.d0) then + inv=1 + else + inv=-1 + endif +! +! standard element equation: unknowns are the mass flow +! and the depth upstream and downstream +! + numf=3 + nodef(1)=node1 + nodef(2)=nodem + nodef(3)=node2 + idirf(1)=2 + idirf(2)=1 + idirf(3)=2 +! + if(lakon(nelem)(6:7).eq.'SG') then +! +! sluice gate +! 1-SG-2-SO-3 +! +! h2 cannot exceed HKmax +! + h2=prop(index+3) + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk + if(h2.gt.hk) h2=hk +! + nelemdown=int(prop(index+5)) + h3=v(2,kon(ipkon(nelemdown)+3)) + call hns(b,theta,rho,dg,sqrts0,xflow,h2,h2ns) + if(h3.lt.h2ns) then +! +! Q=f_SG(h1,h2): sluice gate equation between +! 1 and 2 +! +! next line for output only +! + v(2,node2)=h2 +c write(30,*) 'SG: sluice gate equation ' +c write(30,*)'h1= ',h1,'h2= ',h2,'h3= ',h3,'h2ns= ',h2ns + df(1)=2.d0*dg*(rho*b*h2)**2 + df(2)=-2.d0*xflow + f=df(1)*(h1-h2*sqrts0) + df(3)=2.d0*f/h2-df(1)*sqrts0 + f=f-xflow2 + else +! +! fake equation +! +c write(30,*) 'SG: fake equation ' +c write(30,*)'h1= ',h1,'h2= ',h2,'h3= ',h3,'h2ns= ',h2ns + numf=1 + nodef(1)=nodem + idirf(1)=3 + f=prop(index+4)-0.5d0 + df(1)=1.d0 + endif + elseif(lakon(nelem)(6:7).eq.'SO') then +! +! sluice opening (element streamdown of sluice gate) +! 0-SG-1-SO-2 +! + nelemup=int(prop(index+6)) + node0=kon(ipkon(nelemup)+1) + h0=v(2,node0) + h1=prop(ielprop(nelemup)+3) +! +! h1 cannot exceed HKmax +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk + if(h1.gt.hk) h1=hk +! + call hns(b,theta,rho,dg,sqrts0,xflow,h1,h1ns) + if(h2.lt.h1ns) then +! +! bresse (frontwater) +! +c write(30,*) 'SO: Bresse equation ' +c write(30,*)'h0= ',h0,'h1= ',h1,'h2= ',h2,'h1ns= ',h1ns + bresse=.true. + else +! +! Q=f_SG(h0,h2): sluice gate equation between 0 and 2 +! (backwater) +! +! reset gate height +! + h1=prop(ielprop(nelemup)+3) +! +c write(30,*) 'SO: Sluice gate eqn. between 0 and 2 ' +c write(30,*)'h0= ',h0,'h1= ',h1,'h2= ',h2,'h1ns= ',h1ns + numf=4 + nodef(4)=node0 + idirf(4)=2 +! + if(h2.gt.h1) then +! +! gate flow (water touches gate) +! section = b * h1 +! +! next line for output only +! + v(2,node1)=h1 + df(4)=2.d0*dg*(rho*b*h1)**2 + df(3)=-df(4)*sqrts0 + df(2)=-2.d0*xflow + f=df(4)*(h0-h2*sqrts0) + df(1)=2.d0*f/h1 + else +! +! incomplete inflexion (water does not touch gate) +! section = b * h2 +! +! next line for output only +! + v(2,node1)=h2 + df(4)=2.d0*dg*(rho*b*h2)**2 + df(3)=-df(4)*sqrts0 + df(2)=-2.d0*xflow + f=df(4)*(h0-h2*sqrts0) + df(3)=df(3)+2.d0*f/h2 + df(1)=0.d0 + endif + f=f-xflow2 + endif + elseif(lakon(nelem)(6:7).eq.'WE') then +! +! weir +! 1-WE-2-WO-3 +! + nelemdown=int(prop(index+5)) + h3=v(2,kon(ipkon(nelemdown)+3)) +! +! default depth for weir is hk +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk +! + if(h3.lt.p+hk) then +! +! output only +! + v(2,node2)=p+hk +! +! Q=f_WE(h1): weir equation +! +c write(30,*) 'WE: weir equation ' +c write(30,*)'h1= ',h1,'h2= ',h2,'h3= ',h3,'hk= ',hk + f=rho*c*b*(h1-p)**(1.5d0) + df(1)=3.d0*f/(2.d0*(h1-p)) + f=f-xflow + df(2)=-1.d0 + df(3)=0.d0 + else +! +! fake equation +! +c write(30,*) 'WE: weir equation ' +c write(30,*)'h1= ',h1,'h2= ',h2,'h3= ',h3,'hk= ',hk + numf=1 + nodef(1)=nodem + idirf(1)=3 + f=prop(index+4)-0.5d0 + df(1)=1.d0 + endif + elseif(lakon(nelem)(6:7).eq.'WO') then +! +! weir opening (element streamdown of weir) +! 0-WE-1-WO-2 +! + nelemup=int(prop(index+6)) + node0=kon(ipkon(nelemup)+1) + h0=v(2,node0) +! + p=prop(ielprop(nelemup)+2) +! +! default depth for weir is hk +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk +! + if(h2.lt.p+hk) then +! +! bresse between 1 and 2 +! + h1=hk +c write(30,*) 'WO: Bresse equation ' +c write(30,*)'h0= ',h0,'h1= ',h1,'h2= ',h2,'hk= ',hk + p=prop(ielprop(nelemup)+2) + s0=dasin(p/dsqrt(dl**2+p**2)) +c write(*,*) 's0=',p,dl,s0 + sqrts0=dsqrt(1.d0-s0*s0) + bresse=.true. + else +! +! output only +! + v(2,node1)=h2 +! +! bresse between 0 and 2 +! +c write(30,*) 'WO: Bresse eqn. between 0 and 2 ' +c write(30,*)'h0= ',h0,'h1= ',h1,'h2= ',h2,'hk= ',hk + nodef(1)=node0 + h1=h0 + bresse=.true. + endif + elseif(lakon(nelem)(6:7).eq.'DS') then +! +! discontinuous slope +! 1-DS-2-DO-3 +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk +! + if(h1.gt.hk) then + nelemdown=int(prop(index+8)) + h3=v(2,kon(ipkon(nelemdown)+3)) + if(h3.le.hk) then +! +! upstream: backwater curve +! downstream: frontwater curve +! + h2=hk + bresse=.true. +c write(30,*) 'DS: back/front bresse' +c write(30,*)'h1= ',h1,'h2= ',h2,'h3= ',h3 +! +! for output purposes +! + v(2,node2)=h2 + else +! +! both curves are backwater curves +! fake equation +! +c write(30,*) 'DS: back/back fake equation ' +c write(30,*)'h1= ',h1,'h2= ',h2,'h3= ',h3 + numf=1 + nodef(1)=nodem + idirf(1)=3 + f=prop(index+7)-0.5d0 + df(1)=1.d0 + endif + else +! +! both curves are frontwater curves +! fake equation +! +c write(30,*) 'DS: front/front fake equation ' +c write(30,*)'h1= ',h1,'h2= ',h2 + nelemup=int(prop(index+6)) + numf=1 + nodef(1)=kon(ipkon(nelemup)+2) + idirf(1)=3 + f=prop(index+7)-0.5d0 + df(1)=1.d0 + endif + elseif(lakon(nelem)(6:7).eq.'DO') then +! +! discontinuous slope opening +! (element streamdown of discontinuous slope) +! 0-DS-1-DO-2 +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk +! + nelemup=int(prop(index+6)) + node0=kon(ipkon(nelemup)+1) + h0=v(2,node0) +! + if(h0.gt.hk) then + if(h2.le.hk) then +! +! upstream: backwater curve +! downstream: frontwater curve +! bresse between 1 and 2 +! + h1=hk +c write(30,*) 'DO: back/front bresse 1-2' +c write(30,*)'h0= ',h0,'h1= ',h1,'h2= ',h2 + bresse=.true. + else +! +! both curves are backwater curves +! bresse between 0 and 2 +! +c write(30,*) 'DO: back/back bresse 0-2' +c write(30,*)'h0= ',h0,'h1= ',h1,'h2= ',h2 + nodef(1)=node0 + h1=h0 + bresse=.true. +! +! output purposes +! + v(2,node1)=(h0+h2)/2.d0 + endif + else +! +! both curves are frontwater curves +! bresse between 0 and 2 +! +c write(30,*) 'DO: front/front bresse 0-2' +c write(30,*)'h0= ',h0,'h1= ',h1,'h2= ',h2 + nodef(1)=node0 + h1=h0 + bresse=.true. +! +! output purposes +! + v(2,node1)=(h0+h2)/2.d0 + endif + elseif(lakon(nelem)(6:7).eq.'RE') then +! +! element upstream of a reservoir +! calculating the critical depth +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk + if(h1.ge.hk) then +! +! backwater curve +! + if(h2.lt.hk) h2=hk +c write(30,*) 'RE: Bresse downstream equation ' +c write(30,*) 'h1= ',h1,'h2= ',h2,'hk= ',hk + bresse=.true. + else +! +! frontwater curve +! + call hns(b,theta,rho,dg,sqrts0,xflow,h1,h1ns) + if(h2.le.h1ns) then +c write(30,*) 'RE: fake equation ' +c write(30,*) 'h1= ',h1,'h2= ',h2,'h1ns= ',h1ns +! +! fake equation +! + nelemup=int(prop(index+6)) + nodesg=kon(ipkon(nelemup)+2) + numf=1 + nodef(1)=nodesg + idirf(1)=3 +! +! retrieving previous value of eta +! + index=ielprop(nelemup) + if(lakon(nelemup)(6:7).eq.'SG') then + f=prop(index+4)-0.5d0 + elseif(lakon(nelemup)(6:7).eq.'WE') then + f=prop(index+4)-0.5d0 + elseif(lakon(nelemup)(6:7).eq.'DS') then + f=prop(index+7)-0.5d0 + endif + df(1)=1.d0 + else +c write(30,*) 'RE: Bresse downstream equation ' +c write(30,*) 'h1= ',h1,'h2= ',h2,'h1ns= ',h1ns + bresse=.true. + endif + endif + elseif(lakon(nelem)(6:7).eq.'CO') then +c write(30,*) 'CO: contraction ' +c write(30,*)'h1= ',h1,'h2= ',h2 +! + call hcrit(xflow,rho,b2,theta,dg,sqrts0,hk) + v(3,node2)=hk +! + if(inv.eq.-1) then + if((h1.gt.hk).and.(h2.lt.hk)) then + jump=.true. + endif + else + if((h1.lt.hk).and.(h2.gt.hk)) then + jump=.true. + endif + endif +! + write(*,*) 'CO ',jump +! + if(.not.jump) then + c1=rho*rho*dg + c2=b1*b2*h1*h2 + df(1)=b1*(2.d0*xflow2+c1*b1*b2*h2**3) + df(3)=b2*(2.d0*xflow2+c1*b1*b1*h1**3) + f=h1*df(1)-h2*df(3) + df(1)=df(1)-3.d0*c1*c2*b1*h1 + df(3)=3.d0*c1*c2*b1*h2-df(3) + df(2)=4.d0*(b1*h1-b2*h2)*xflow + endif + elseif(lakon(nelem)(6:7).eq.'EL') then +c write(30,*) 'EL: enlargement ' +c write(30,*)'h1= ',h1,'h2= ',h2 +! + call hcrit(xflow,rho,b2,theta,dg,sqrts0,hk) + v(3,node2)=hk +! + if(inv.eq.-1) then + if((h1.gt.hk).and.(h2.lt.hk)) then + jump=.true. + endif + else + if((h1.lt.hk).and.(h2.gt.hk)) then + jump=.true. + endif + endif +! + write(*,*) 'EL ',jump +! + if(.not.jump) then + c1=rho*rho*dg + c2=b1*b2*h1*h2 + df(1)=b1*(2.d0*xflow2+c1*b2*b2*h2**3) + df(3)=b2*(2.d0*xflow2+c1*b1*b2*h1**3) + f=h1*df(1)-h2*df(3) + df(1)=df(1)-3.d0*c1*c2*b2*h1 + df(3)=3.d0*c1*c2*b2*h2-df(3) + df(2)=4.d0*(b1*h1-b2*h2)*xflow + endif + elseif(lakon(nelem)(6:7).eq.'DR') then +c write(30,*) 'DR: drop ' +c write(30,*)'h1= ',h1,'h2= ',h2 +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk +! + if(inv.eq.-1) then + if((h1.gt.hk).and.(h2.lt.hk)) then + jump=.true. + endif + else + if((h1.lt.hk).and.(h2.gt.hk)) then + jump=.true. + endif + endif +! + if(.not.jump) then + c1=rho*rho*dg + df(1)=2.d0*xflow2+c1*b*b*h2**3 + df(3)=2.d0*xflow2+c1*b*b*h1*(h1+d)**2 + f=h1*df(1)-h2*df(3) + df(1)=df(1)-c1*b*b*h2*(3.d0*h1+d)*(h1+d) + df(3)=3.d0*c1*b*b*h1*h2*h2-df(3) + df(2)=4.d0*(h1-h2)*xflow + endif + elseif(lakon(nelem)(6:7).eq.'ST') then +c write(30,*) 'ST: step ' +c write(30,*)'h1= ',h1,'h2= ',h2 +! + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk +! + if(inv.eq.-1) then + if((h1.gt.hk).and.(h2.lt.hk)) then + jump=.true. + endif + else + if((h1.lt.hk).and.(h2.gt.hk)) then + jump=.true. + endif + endif +! + if(.not.jump) then + c1=rho*rho*dg + df(1)=2.d0*xflow2+c1*b*b*h2*(h2+d)**2 + df(3)=2.d0*xflow2+c1*b*b*h1**3 + f=h1*df(1)-h2*df(3) + df(1)=df(1)-3.d0*c1*b*b*h1*h1*h2 + df(3)=c1*b*b*h1*(3.d0*h2+d)*(h2+d)-df(3) + df(2)=4.d0*(h1-h2)*xflow + endif + elseif(lakon(nelem)(6:7).eq.' ') then + bresse=.true. +c write(30,*) 'straight: Bresse equation ' +c write(30,*) 'h1= ',h1,'h2= ',h2 + endif +! +! bresse equation +! + if((bresse).or.(jump)) then +! + if(xks.gt.0.d0) then +! +! White-Coolebrook +! +! hydraulic diameter +! + d=2.d0*(h1+h2) + reynolds=4.d0*xflow/(b*dvi) + form_fact=1.d0 + call friction_coefficient(dl,d,xks,reynolds,form_fact, + & friction) + endif +! + if(bresse) then + call hcrit(xflow,rho,b,theta,dg,sqrts0,hk) + v(3,node2)=hk + if(inv.eq.-1) then + if((h1.gt.hk).and.(h2.lt.hk)) then + jump=.true. + endif + else + if((h1.lt.hk).and.(h2.gt.hk)) then + jump=.true. + endif + endif + b1=b + b2=b + endif +! +! geometric data +! + cth=dcos(theta) + tth=dtan(theta) +! +! nonprismatic cross section +! + if(lakon(nelem)(6:7).eq.' ') then + dbds=prop(index+7) + else + dbds=0.d0 + endif +! +! width at water surface +! + dD1dh1=2.d0*tth + dD2dh2=dD1dh1 + D1=b1+h1*dD1dh1 + D2=b2+dl*dbds+h2*dD2dh2 +! +! cross section +! + A1=h1*(b1+h1*tth) + A2=h2*(b2+dl*dbds+h2*tth) + dA1dh1=D1 + dA2dh2=D2 +! +! perimeter +! + P1=b1+2.d0*h1/cth + P2=b2+dl*dbds+2.d0*h2/cth + dP1dh1=2.d0/cth + dP2dh2=dP1dh1 +! +! factor for friction +! + if(xks.gt.0.d0) then +! White-Coolebrook + um1=friction/8.d0 + um2=um1 + dum1dh1=0.d0 + dum2dh2=0.d0 + else +! Manning + um1=xks*xks*dg*(P1/A1)**(1.d0/3.d0) + um2=xks*xks*dg*(P2/A2)**(1.d0/3.d0) + dum1dh1=xks*xks*dg* + & (P1**(-2.d0/3.d0)*dP1dh1*A1**(1.d0/3.d0)- + & A1**(-2.d0/3.d0)*dA1dh1*P1**(1.d0/3.d0))/ + & (3.d0*A1**(2.d0/3d0)) + dum2dh2=xks*xks*dg* + & (P2**(-2.d0/3.d0)*dP2dh2*A2**(1.d0/3.d0)- + & A2**(-2.d0/3.d0)*dA2dh2*P2**(1.d0/3.d0))/ + & (3.d0*A2**(2.d0/3d0)) + endif +! +! constants +! + c1=rho*rho*dg + c2=c1*sqrts0 + c1=c1*s0 +! +! hydraulic jump +! + if(jump) then +c write(30,*) +c & 'liquidchannel: jump in element,hk ',nelem,hk + nelemup=prop(index+6) + indexup=ielprop(nelemup) + if(lakon(nelemup)(6:7).eq.'SG') then + eta=prop(indexup+4) + prop(indexup+7)=nelem+0.5d0 + elseif(lakon(nelemup)(6:7).eq.'WE') then + eta=prop(indexup+4) + prop(indexup+7)=nelem+0.5d0 + elseif(lakon(nelemup)(6:7).eq.'DS') then + eta=prop(indexup+7) + prop(indexup+9)=nelem+0.5d0 + endif +! +! determining h3, h4 and derivatives +! +! numerator +! + xt1=c1*A1**3+(h1*dbds-um1*P1)*xflow2 + xt2=c1*A2**3+(h2*dbds-um2*P2)*xflow2 +! +! denominator +! + xn1=c2*A1**3-D1*xflow2 + xn2=c2*A2**3-D2*xflow2 +! +! h3 and h4 +! + h3=h1+dl*xt1/xn1*eta + h4=h2-dl*xt2/xn2*(1.d0-eta) +c write(30,*) +c & 'liquidchannel: h3,h4,eta ',h3,h4,eta +! + if(bresse) then +! +! width at jump +! + bj=b+dbds*eta*dl +! +! cross sections and derivatives +! + A3=h3*(bj+h3*tth) + A4=h4*(bj+h4*tth) + dA3dh3=bj+2.d0*h3*tth + dA4dh4=bj+2.d0*h4*tth +! +! center of gravity and derivatives +! + yg3=h3*(3.d0*bj+2.d0*h3*tth)/(6.d0*(bj+h3*tth)) + yg4=h4*(3.d0*bj+2.d0*h4*tth)/(6.d0*(bj+h4*tth)) + dyg3dh3=((3.d0*bj+4.d0*h3*tth)*(bj+tth) + & -tth*h3*(3.d0*bj+2.d0*h3*tth))/ + & (6.d0*(bj+h3*tth)**2) + dyg4dh4=((3.d0*bj+4.d0*h4*tth)*(bj+tth) + & -tth*h4*(3.d0*bj+2.d0*h4*tth))/ + & (6.d0*(bj+h4*tth)**2) + dyg3dbj=h3*h3*tth/(6.d0*(bj+h3*tth)**2) + dyg4dbj=h4*h4*tth/(6.d0*(bj+h4*tth)**2) + endif +! +! derivative of h3 w.r.t. h1 and of h4 w.r.t. h2 +! + dh3dh1=1.d0+((3.d0*c1*A1*A1*dA1dh1 + & +(dbds-dum1dh1*P1-um1*dP1dh1)*xflow2)*xn1 + & -(3.d0*c2*A1*A1*dA1dh1-dD1dh1*xflow2)*xt1)/ + & (xn1*xn1)*eta*dl + dh4dh2=1.d0-((3.d0*c1*A2*A2*dA2dh2 + & +(dbds-dum2dh2*P2-um2*dP2dh2)*xflow2)*xn2 + & -(3.d0*c2*A2*A2*dA2dh2-dD2dh2*xflow2)*xt2)/ + & (xn2*xn2)*(1.d0-eta)*dl +! + if(bresse) then + dA3dh1=dA3dh3*dh3dh1 + dA4dh2=dA4dh4*dh4dh2 + dyg3dh1=dyg3dh3*dh3dh1 + dyg4dh2=dyg4dh4*dh4dh2 + endif +! +! derivative of h3 and h4 w.r.t. the mass flow +! + dh3dm=((dbds*h1-um1*P1)*xn1+D1*xt1)*2.d0*xflow/ + & (xn1*xn1)*eta*dl + dh4dm=-((dbds*h2-um2*P2)*xn2+D2*xt2)*2.d0*xflow/ + & (xn2*xn2)*(1.d0-eta)*dl +! + if(bresse) then + dA3dm=dA3dh3*dh3dm + dA4dm=dA4dh4*dh4dm + dyg3dm=dyg3dh3*dh3dm + dyg4dm=dyg4dh4*dh4dm + endif +! +! derivative of h3 and h4 w.r.t. eta +! + dh3deta=dl*xt1/xn1 + dh4deta=dl*xt2/xn2 +! + if(bresse) then + dbjdeta=dbds*dl +! +! derivative of A3, A4, yg3 and yg4 w.r.t. eta +! + dA3deta=dA3dh3*dh3deta+h3*dbjdeta + dA4deta=dA4dh4*dh4deta+h4*dbjdeta + dyg3deta=dyg3dh3*dh3deta+dyg3dbj*dbjdeta + dyg4deta=dyg4dh4*dh4deta+dyg4dbj*dbjdeta + endif +! + numf=4 + nodef(4)=kon(ipkon(nelemup)+2) + idirf(4)=3 +! + if(bresse) then + f=A4*xflow2+c2*(A3*A3*A4*yg3-A3*A4*A4*yg4) + & -A3*xflow2 + df(1)=c2*(2.d0*A3*dA3dh1*A4*yg3+A3*A3*A4*dyg3dh1 + & -dA3dh1*A4*A4*yg4)-dA3dh1*xflow2 + df(2)=2.d0*xflow*(A4-A3)+ + & (c2*(2.d0*A3*A4*yg3-A4*A4*yg4)-xflow2)*dA3dm+ + & (c2*(A3*A3*yg3-2.d0*A3*A4*yg4)+xflow2)*dA4dm+ + & c2*A3*A3*A4*dyg3dm-c2*A3*A4*A4*dyg4dm + df(3)=c2*(A3*A3*dA4dh2*yg3-2.d0*A3*A4*dA4dh2*yg4 + & -A3*A4*A4*dyg4dh2)+dA4dh2*xflow2 + df(4)=dA4deta*xflow2+ + & c2*(2.d0*A3*dA3deta*A4*yg3+A3*A3*dA4deta*yg3 + & +A3*A3*A4*dyg3deta-dA3deta*A4*A4*yg4 + & -A3*2.d0*A4*dA4deta*yg4-A3*A4*A4*dyg4deta) + & -dA3deta*xflow2 + elseif(lakon(nelem)(6:7).eq.'CO') then + f=b2*h4*(2.d0*xflow2+c2*b1*b1*h3**3)- + & b1*h3*(2.d0*xflow2+c2*b1*b2*h4**3) +! dfdh3 + df(1)=3.d0*b2*h4*c2*b1*b1*h3*h3- + & b1*(2.d0*xflow2+c2*b1*b2*h4**3) +! dfdh4 + df(3)=b2*(2.d0*xflow2+c2*b1*b1*h3**3)- + & 3.d0*b1*h3*c2*b1*b2*h4*h4 +! dfdm + df(2)=4.d0*xflow*(b2*h4-b1*h3)+ + & df(1)*dh3dm+df(3)*dh4dm +! dfdeta + df(4)=df(1)*dh3deta+df(3)*dh4deta +! dfdh1 + df(1)=df(1)*dh3dh1 +! dfdh2 + df(3)=df(3)*dh4dh2 + elseif(lakon(nelem)(6:7).eq.'EL') then + f=b2*h4*(2.d0*xflow2+c2*b1*b2*h3**3)- + & b1*h3*(2.d0*xflow2+c2*b2*b2*h4**3) +! dfdh3 + df(1)=3.d0*b2*h4*c2*b1*b2*h3*h3- + & b1*(2.d0*xflow2+c2*b2*b2*h4**3) +! dfdh4 + df(3)=b2*(2.d0*xflow2+c2*b1*b2*h3**3)- + & 3.d0*b1*h3*c2*b2*b2*h4*h4 +! dfdm + df(2)=4.d0*xflow*(b2*h4-b1*h3)+ + & df(1)*dh3dm+df(3)*dh4dm +! dfdeta + df(4)=df(1)*dh3deta+df(3)*dh4deta +! dfdh1 + df(1)=df(1)*dh3dh1 +! dfdh2 + df(3)=df(3)*dh4dh2 + elseif(lakon(nelem)(6:7).eq.'DR') then + f=h4*(2.d0*xflow2+c2*b*b*h3*(h3+d)**2)- + & h3*(2.d0*xflow2+c2*b*b*h4**3) +! dfdh3 + df(1)=h4*c2*b*b*(3.d0*h3+d)*(h3+d)- + & (2.d0*xflow2+c2*b*b*h4**3) +! dfdh4 + df(3)=(2.d0*xflow2+c2*b*b*h3*(h3+d)**2)- + & 3.d0*h3*c2*b*b*h4*h4 +! dfdm + df(2)=4.d0*xflow*(h4-h3)+ + & df(1)*dh3dm+df(3)*dh4dm +! dfdeta + df(4)=df(1)*dh3deta+df(3)*dh4deta +! dfdh1 + df(1)=df(1)*dh3dh1 +! dfdh2 + df(3)=df(3)*dh4dh2 + elseif(lakon(nelem)(6:7).eq.'ST') then + f=h4*(2.d0*xflow2+c2*b*b*h3**3)- + & h3*(2.d0*xflow2+c2*b*b*h4*(h4+d)**2) +! dfdh3 + df(1)=3.d0*h4*c2*b*b*h3*h3- + & (2.d0*xflow2+c2*b*b*h4*(h4+d)**2) +! dfdh4 + df(3)=(2.d0*xflow2+c2*b*b*h3**3)- + & h3*c2*b*b*(3.d0*h4+d)*(h4+d) +! dfdm + df(2)=4.d0*xflow*(h4-h3)+ + & df(1)*dh3dm+df(3)*dh4dm +! dfdeta + df(4)=df(1)*dh3deta+df(3)*dh4deta +! dfdh1 + df(1)=df(1)*dh3dh1 +! dfdh2 + df(3)=df(3)*dh4dh2 + endif + else +! +! regular Bresse equation +! + f=c2*(A1**3+A2**3)-xflow2*(D1+D2) + df(1)=-f+(h2-h1)*(c2*dA1dh1*3.d0*A1*A1-xflow2*dD1dh1) + & -dl*(c1*3.d0*A1*A1*dA1dh1 + & -(dum1dh1*P1+um1*dP1dh1-dbds)*xflow2) + df(2)=(-(h2-h1)*(D1+D2) + & +dl*(um1*P1+um2*P2-(h1+h2)*dbds))*2.d0*xflow + df(3)=f+(h2-h1)*(c2*dA2dh2*3.d0*A2*A2-xflow2*dD2dh2) + & -dl*(c1*3.d0*A2*A2*dA2dh2 + & -(dum2dh2*P2+um2*dP2dh2-dbds)*xflow2) + f=(h2-h1)*f-dl*(c1*(A1**3+A2**3) + & -(um1*P1+um2*P2-(h1+h2)*dbds)*xflow2) + endif + endif + endif + elseif(iflag.eq.3) then +! +! only if called from resultgas in case the element contains +! a hydraulic jump and eta<0 or eta>1. This means that the +! jump does not take place in the element itself. By adjusting +! h1 or h2 the jump is forced into a neighboring element +! + index=ielprop(nelem) +c write(30,*) 'iflag=3, nelem',nelem,lakon(nelem) +! + h1=v(2,node1) + h2=v(2,node2) +! + z1=-g(1)*co(1,node1)-g(2)*co(2,node1)-g(3)*co(3,node1) + z2=-g(1)*co(1,node2)-g(2)*co(2,node2)-g(3)*co(3,node2) +! + dg=dsqrt(g(1)*g(1)+g(2)*g(2)+g(3)*g(3)) +! + xflow2=xflow*xflow +! +! determine eta (present location of jump) +! + nelemup=prop(index+6) + indexup=ielprop(nelemup) + if(lakon(nelemup)(6:7).eq.'SG') then + eta=prop(indexup+4) + prop(indexup+4)=0.5d0 + prop(indexup+7)=0.5d0 + elseif(lakon(nelemup)(6:7).eq.'WE') then + eta=prop(indexup+4) + prop(indexup+4)=0.5d0 + prop(indexup+7)=0.5d0 + elseif(lakon(nelemup)(6:7).eq.'DS') then + eta=prop(indexup+7) + prop(indexup+7)=0.5d0 + prop(indexup+9)=0.5d0 + endif +! +! element properties +! + if((lakon(nelem)(6:7).eq.'SG').or. + & (lakon(nelem)(6:7).eq.'SO').or. + & (lakon(nelem)(6:7).eq.'RE').or. + & (lakon(nelem)(6:7).eq.' ').or. + & (lakon(nelem)(6:7).eq.'DS').or. + & (lakon(nelem)(6:7).eq.'DO')) then + b=prop(index+1) + s0=prop(index+2) + if(s0.lt.-1.d0) then + s0=dasin((z1-z2)/dl) + endif + sqrts0=dsqrt(1.d0-s0*s0) + if(lakon(nelem)(6:7).ne.'SG') then + dl=prop(index+3) + theta=prop(index+4) + xks=prop(index+5) + if(dl.le.0.d0) then + dl=dsqrt((co(1,node2)-co(1,node1))**2+ + & (co(2,node2)-co(2,node1))**2+ + & (co(3,node2)-co(3,node1))**2) + endif + else + theta=0.d0 + endif + elseif(lakon(nelem)(6:7).eq.'WE') then + b=prop(index+1) + p=prop(index+2) + c=prop(index+3) + elseif((lakon(nelem)(6:7).eq.'CO').or. + & (lakon(nelem)(6:7).eq.'EL')) then + b1=prop(index+1) + s0=prop(index+2) + if(s0.lt.-1.d0) then + s0=dasin((z1-z2)/dl) + endif + sqrts0=dsqrt(1.d0-s0*s0) + b2=prop(index+4) + elseif((lakon(nelem)(6:7).eq.'DR').or. + & (lakon(nelem)(6:7).eq.'ST'))then + b=prop(index+1) + s0=prop(index+2) + if(s0.lt.-1.d0) then + s0=dasin((z1-z2)/dl) + endif + sqrts0=dsqrt(1.d0-s0*s0) + d=prop(index+4) + endif +! +! contraction, enlargement, drop and step: +! adjust h1 or h2 by solving the appropriate +! momentum equation +! + if((lakon(nelem)(6:7).eq.'CO').or. + & (lakon(nelem)(6:7).eq.'EL').or. + & (lakon(nelem)(6:7).eq.'DR').or. + & (lakon(nelem)(6:7).eq.'ST'))then + c2=rho*rho*dg*sqrts0 +! + if(eta.gt.1.d0) then +! +! h1 is given, h2 is unknown +! + if(lakon(nelem)(6:7).eq.'CO') then + e3=b1*h1*c2*b1*b2 + e0=2.d0*b1*h1*xflow2/e3 + e1=-(2.d0*xflow2+c2*b1*b1*h1**3)*b2/e3 + e2=0.d0 + elseif(lakon(nelem)(6:7).eq.'EL') then + e3=b1*h1*c2*b2*b2 + e0=2.d0*b1*h1*xflow2/e3 + e1=-(2.d0*xflow2+c2*b1*b2*h1**3)*b2/e3 + e2=0.d0 + elseif(lakon(nelem)(6:7).eq.'DR') then + e3=h1*c2*b*b + e0=h1*2.d0*xflow2/e3 + e1=-(2.d0*xflow2+c2*b*b*h1*(h1+d)**2)/e3 + e2=0.d0 + elseif(lakon(nelem)(6:7).eq.'ST') then + e3=h1*c2*b*b + e0=h1*2.d0*xflow2/e3 + e1=(h1*c2*b*b*d*d-(2.d0*xflow2+c2*b*b*h1**3))/e3 + e2=h1*c2*b*b*2.d0*d/e3 + endif +! +! solve the cubic equation +! + call cubic(e0,e1,e2,solreal,solimag,nsol) +! +! determine the real solution closest to h1 +! + dist=1.d30 + do i=1,nsol + if(dabs(solreal(i)-h1).lt.dist) then + dist=dabs(solreal(i)-h1) + h2=solreal(i) + endif + enddo + if(nactdog(2,node2).ne.0) v(2,node2)=h2 + elseif(eta.lt.0.d0) then +! +! h2 is given, h1 is unknown +! + if(lakon(nelem)(6:7).eq.'CO') then + e3=c2*b1*b1*b2*h2 + e0=2.d0*xflow2*b2*h2/e3 + e1=-b1*(2.d0*xflow2+c2*b1*b2*h2**3)/e3 + e2=0.d0 + elseif(lakon(nelem)(6:7).eq.'EL') then + e3=c2*b1*b2*b2*h2 + e0=2.d0*xflow2*b2*h2/e3 + e1=-b1*(2.d0*xflow2+c2*b2*b2*h2**3)/e3 + e2=0.d0 + elseif(lakon(nelem)(6:7).eq.'DR') then + e3=c2*b*b*h2 + e0=2.d0*xflow2*h2/e3 + e1=(c2*b*b*d*d*h2-(2.d0*xflow2+c2*b*b*h2**3))/e3 + e2=c2*b*b*2.d0*d*h2/e3 + elseif(lakon(nelem)(6:7).eq.'ST') then + e3=c2*b*b*h2 + e0=2.d0*xflow2*h2/e3 + e1=-(2.d0*xflow2+c2*b*b*h2*(h2+d)**2)/e3 + e2=0.d0 + endif +! +! solve the cubic equation +! + call cubic(e0,e1,e2,solreal,solimag,nsol) +c write(30,*) 'check ',solreal(1)**3+e1*solreal(1)+e0 +! +c write(30,*) 'nsol',nsol +c write(30,*) 'solreal',(solreal(i),i=1,3) +c write(30,*) 'solimag',(solimag(i),i=1,3) +! +! determine the real solution closest to h2 +! + dist=1.d30 + do i=1,nsol + if(dabs(solreal(i)-h2).lt.dist) then + dist=dabs(solreal(i)-h2) + h1=solreal(i) + endif + enddo + if(nactdog(2,node1).ne.0) v(2,node1)=h1 + endif + return + endif +! + if(xks.gt.0.d0) then +! +! White-Coolebrook +! +! hydraulic diameter +! + d=2.d0*(h1+h2) + reynolds=4.d0*xflow/(b*dvi) + form_fact=1.d0 + call friction_coefficient(dl,d,xks,reynolds,form_fact, + & friction) + endif +! +! geometric data +! + cth=dcos(theta) + tth=dtan(theta) +! +! nonprismatic cross section +! + if(lakon(nelem)(6:7).eq.' ') then + dbds=prop(index+7) + else + dbds=0.d0 + endif +! +! width at water surface +! + dD1dh1=2.d0*tth + dD2dh2=dD1dh1 + D1=b+h1*dD1dh1 + D2=b+dl*dbds+h2*dD2dh2 +! +! cross section +! + A1=h1*(b+h1*tth) + A2=h2*(b+dl*dbds+h2*tth) +! +! perimeter +! + P1=b+2.d0*h1/cth + P2=b+dl*dbds+2.d0*h2/cth +! +! factor for friction +! + if(xks.gt.0.d0) then +! White-Coolebrook + um1=friction/8.d0 + um2=um1 + else +! Manning + um1=xks*xks*dg*(P1/A1)**(1.d0/3.d0) + um2=xks*xks*dg*(P2/A2)**(1.d0/3.d0) + endif +! +! constants +! + c1=rho*rho*dg + c2=c1*sqrts0 + c1=c1*s0 +! + if(eta.gt.1.d0) then + xt1=c1*A1**3+(h1*dbds-um1*P1)*xflow2 + xn1=c2*A2**3-D2*xflow2 + if(nactdog(2,node2).ne.0) v(2,node2)=h1+dl*xt1/xn1 +c write(30,*) 'move jump: h1 h2,h2new ',h1,h2,v(2,node2) + elseif(eta.lt.0.d0) then + xt2=c1*A2**3+(h2*dbds-um2*P2)*xflow2 + xn2=c2*A2**3-D2*xflow2 + if(nactdog(2,node1).ne.0) + & v(2,node1)=h2-dl*xt2/xn2 +c write(30,*) 'move jump: h1 h1new h2 ',h1,v(2,node1),h2 + endif + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/liquidpipe.f calculix-ccx-2.3/ccx_2.3/src/liquidpipe.f --- calculix-ccx-2.1/ccx_2.3/src/liquidpipe.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/liquidpipe.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1050 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine liquidpipe(node1,node2,nodem,nelem,lakon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,rho,g,co,dvi,numf,vold,mi,ipkon,kon,set) +! +! pipe element for incompressible media +! + implicit none +! + logical identity,flowunknown + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,iaxial, + & ielprop(*),nodef(4),idirf(4),index,iflag,mi(2), + & inv,ncoel,ndi,nbe,id,nen,ngv,numf,nodea,nodeb, + & ipkon(*),isothermal,kon(*),nelemswirl +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),a,d,pi,radius, + & p1,p2,rho,dvi,friction,reynolds,vold(0:mi(2),*), + & g(3),a1,a2,xn,xk,xk1,xk2,zeta,dl,dg,rh,a0,alpha, + & coarseness,rd,xks,z1,z2,co(3,*),xcoel(11),yel(11), + & yco(11),xdi(10),ydi(10),xbe(7),ybe(7),zbe(7),ratio, + & xen(10),yen(10),xgv(8),ygv(8),xkn,xkp, + & dh,kappa,r,dkda,form_fact,dzetadalpha,t_chang, + & xflow_vol,r1d,r2d,r1,r2,eta, K1, Kr, U1,Ui, ciu, c1u, + & c2u, omega,rpm,cinput,un,T +! + data ncoel /7/ + data xcoel /0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/ + data yco /0.5,0.46,0.41,0.36,0.30,0.24,0.18,0.12,0.06,0.02,0./ + data yel /1.,0.81,0.64,0.49,0.36,0.25,0.16,0.09,0.04,0.01,0./ +! + data ndi /10/ + data xdi /0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1./ + data ydi /226.,47.5,17.5,7.8,3.75,1.80,0.8,0.29,0.06,0./ +! + data nbe /7/ + data xbe /1.,1.5,2.,3.,4.,6.,10./ + data ybe /0.21,0.12,0.10,0.09,0.09,0.08,0.2/ + data zbe /0.51,0.32,0.29,0.26,0.26,0.17,0.31/ +! + data nen /10/ + data xen /0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1./ + data yen /232.,51.,18.8,9.6,5.26,3.08,1.88,1.17,0.734,0.46/ +! + data ngv /8/ + data xgv /0.125,0.25,0.375,0.5,0.625,0.75,0.875,1./ + data ygv /98.,17.,5.52,2.,0.81,0.26,0.15,0.12/ +! + numf=4 +! + pi=4.d0*datan(1.d0) + dkda=0.d0 +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + elseif(nactdog(3,nodem).ne.0) then + identity=.false. + endif +! + elseif((iflag.eq.1).or.(iflag.eq.2).or.(iflag.eq.3))then +! + index=ielprop(nelem) +! + p1=v(2,node1) + p2=v(2,node2) +! + z1=-g(1)*co(1,node1)-g(2)*co(2,node1)-g(3)*co(3,node1) + z2=-g(1)*co(1,node2)-g(2)*co(2,node2)-g(3)*co(3,node2) +! + T=v(0,node1) +! + if(iflag.eq.1) then + inv=0 + if(nactdog(1,nodem).ne.0) then + flowunknown=.true. + else + flowunknown=.false. + xflow=v(1,nodem) + endif + else + xflow=v(1,nodem) + if(xflow.ge.0.d0) then + inv=1 + else + inv=-1 + endif + nodef(1)=node1 + nodef(2)=nodem + nodef(3)=node2 + nodef(4)=nodem + idirf(1)=2 + idirf(2)=1 + idirf(3)=2 + idirf(4)=3 + endif +! + if((lakon(nelem)(4:5).ne.'BE').and. + & (lakon(nelem)(6:7).eq.'MA')) then +! +! pipe, Manning (LIPIMA) +! + if(lakon(nelem)(8:8).eq.'F') then + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + xn=prop(index+3) + iaxial=int(prop(index+4)) + radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2+ + & (co(2,nodeb)+vold(2,nodeb)- + & co(2,nodea)-vold(2,nodea))**2+ + & (co(3,nodeb)+vold(3,nodeb)- + & co(3,nodea)-vold(3,nodea))**2) + if(iaxial.ne.0) then + a=pi*radius*radius/iaxial + else + a=pi*radius*radius + endif + rh=radius/2.d0 + else + a=prop(index+1) + rh=prop(index+2) + endif + xn=prop(index+3) + a1=a + a2=a + dl=dsqrt((co(1,node2)-co(1,node1))**2+ + & (co(2,node2)-co(2,node1))**2+ + & (co(3,node2)-co(3,node1))**2) + dg=dsqrt(g(1)*g(1)+g(2)*g(2)+g(3)*g(3)) + if(inv.ne.0) then + xk=2.d0*xn*xn*dl*dg/(a*a*rh**(4.d0/3.d0)) + else + xkn=2.d0*xn*xn*dl*dg/(a*a*rh**(4.d0/3.d0)) + xkp=xkn + endif + elseif(lakon(nelem)(6:7).eq.'WC') then +! +! pipe, White-Colebrook +! + if(lakon(nelem)(8:8).eq.'F') then + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + xn=prop(index+3) + iaxial=int(prop(index+4)) + radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2+ + & (co(2,nodeb)+vold(2,nodeb)- + & co(2,nodea)-vold(2,nodea))**2+ + & (co(3,nodeb)+vold(3,nodeb)- + & co(3,nodea)-vold(3,nodea))**2) + if(iaxial.ne.0) then + a=pi*radius*radius/iaxial + else + a=pi*radius*radius + endif + d=2.d0*radius + else + a=prop(index+1) + d=prop(index+2) + endif + dl=prop(index+3) + if(dl.le.0.d0) then + dl=dsqrt((co(1,node2)-co(1,node1))**2+ + & (co(2,node2)-co(2,node1))**2+ + & (co(3,node2)-co(3,node1))**2) + endif + xks=prop(index+4) + form_fact=prop(index+5) + a1=a + a2=a + if(iflag.eq.1) then +! +! assuming large reynolds number +! + friction=1.d0/(2.03*dlog10(xks/(d*3.7)))**2 + else +! +! solving the implicit White-Colebrook equation +! + reynolds=xflow*d/(a*dvi) + call friction_coefficient(dl,d,xks,reynolds,form_fact, + & friction) + endif + if(inv.ne.0) then + xk=friction*dl/(d*a*a) + dkda=-2.5d0*xk/a + else + xkn=friction*dl/(d*a*a) + xkp=xkn + endif + elseif(lakon(nelem)(6:7).eq.'EL') then +! +! pipe, sudden enlargement Berlamont version: fully turbulent +! all section ratios +! + a1=prop(index+1) + a2=prop(index+2) + ratio=a1/a2 + call ident(xcoel,ratio,ncoel,id) + if(inv.ge.0) then + if(id.eq.0) then + zeta=yel(1) + elseif(id.eq.ncoel) then + zeta=yel(ncoel) + else + zeta=yel(id)+(yel(id+1)-yel(id))*(ratio-xcoel(id))/ + & (xcoel(id+1)-xcoel(id)) + endif + if(inv.ne.0) then + xk=zeta/(a1*a1) + else + xkp=zeta/(a1*a1) + endif + endif + if(inv.le.0) then + if(id.eq.0) then + zeta=yco(1) + elseif(id.eq.ncoel) then + zeta=yco(ncoel) + else + zeta=yco(id)+(yco(id+1)-yco(id))*(ratio-xcoel(id))/ + & (xcoel(id+1)-xcoel(id)) + endif + if(inv.ne.0) then + xk=zeta/(a1*a1) + else + xkn=zeta/(a1*a1) + endif + endif + elseif(lakon(nelem)(4:5).eq.'EL') then +! +! pipe, sudden enlargement Idelchik version: reynolds dependent, +! 0.01 <= section ratio <= 0.6 +! + a1=prop(index+1) + a2=prop(index+2) + dh=prop(index+3) + if(dh.eq.0.d0) then + dh=dsqrt(4*a1/pi) + endif + if(inv.eq.0) then + reynolds=5000.d0 + else + reynolds=xflow*dh/(dvi*a1) + endif + if(inv.ge.0) then + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + if(inv.ne.0) then + xk=zeta/(a1*a1) + else + xkp=zeta/(a1*a1) + endif + endif + if(inv.le.0) then + reynolds=-reynolds +! +! setting length and angle for contraction to zero +! + prop(index+4)=0.d0 + prop(index+5)=0.d0 + lakon(nelem)(4:5)='CO' + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + lakon(nelem)(4:5)='EL' + if(inv.ne.0) then + xk=zeta/(a1*a1) + else + xkn=zeta/(a1*a1) + endif + endif + elseif(lakon(nelem)(6:7).eq.'CO') then +! +! pipe, sudden contraction Berlamont version: fully turbulent +! all section ratios +! + a1=prop(index+1) + a2=prop(index+2) + ratio=a2/a1 + call ident(xcoel,ratio,ncoel,id) + if(inv.ge.0) then + if(id.eq.0) then + zeta=yco(1) + elseif(id.eq.ncoel) then + zeta=yco(ncoel) + else + zeta=yco(id)+(yco(id+1)-yco(id))*(ratio-xcoel(id))/ + & (xcoel(id+1)-xcoel(id)) + endif + if(inv.ne.0) then + xk=zeta/(a2*a2) + else + xkp=zeta/(a2*a2) + endif + endif + if(inv.le.0) then + if(id.eq.0) then + zeta=yel(1) + elseif(id.eq.ncoel) then + zeta=yel(ncoel) + else + zeta=yel(id)+(yel(id+1)-yel(id))*(ratio-xcoel(id))/ + & (xcoel(id+1)-xcoel(id)) + endif + if(inv.ne.0) then + xk=zeta/(a2*a2) + else + xkn=zeta/(a2*a2) + endif + endif + elseif(lakon(nelem)(4:5).eq.'CO') then +! +! pipe, sudden contraction Idelchik version: reynolds dependent, +! 0.1 <= section ratio <= 0.6 +! + a1=prop(index+1) + a2=prop(index+2) + dh=prop(index+3) + if(dh.eq.0.d0) then + dh=dsqrt(4*a2/pi) + endif + if(inv.eq.0) then + reynolds=5000.d0 + else + reynolds=xflow*dh/(dvi*a2) + endif + if(inv.ge.0) then + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + if(inv.ne.0) then + xk=zeta/(a2*a2) + else + xkp=zeta/(a2*a2) + endif + endif + if(inv.le.0) then + reynolds=-reynolds + lakon(nelem)(4:5)='EL' + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + lakon(nelem)(4:5)='CO' + if(inv.ne.0) then + xk=zeta/(a2*a2) + else + xkn=zeta/(a2*a2) + endif + endif + elseif(lakon(nelem)(6:7).eq.'DI') then +! +! pipe, diaphragm +! + a=prop(index+1) + a0=prop(index+2) + a1=a + a2=a + ratio=a0/a + call ident(xdi,ratio,ndi,id) + if(id.eq.0) then + zeta=ydi(1) + elseif(id.eq.ndi) then + zeta=ydi(ndi) + else + zeta=ydi(id)+(ydi(id+1)-ydi(id))*(ratio-xdi(id))/ + & (xdi(id+1)-xdi(id)) + endif + if(inv.ne.0) then + xk=zeta/(a*a) + else + xkn=zeta/(a*a) + xkp=xkn + endif + elseif(lakon(nelem)(6:7).eq.'EN') then +! +! pipe, entrance (Berlamont data) +! + a=prop(index+1) + a0=prop(index+2) + a1=a*1.d10 + a2=a + ratio=a0/a + call ident(xen,ratio,nen,id) + if(id.eq.0) then + zeta=yen(1) + elseif(id.eq.nen) then + zeta=yen(nen) + else + zeta=yen(id)+(yen(id+1)-yen(id))*(ratio-xen(id))/ + & (xen(id+1)-xen(id)) + endif + if(inv.ne.0) then + if(inv.gt.0) then +! entrance + xk=zeta/(a*a) + else +! exit + xk=1.d0/(a*a) + endif + else + xkn=1.d0/(a*a) + xkp=zeta/(a*a) + endif + elseif(lakon(nelem)(4:5).eq.'EN') then +! +! pipe, entrance (Idelchik) +! + a1=prop(index+1) + a2=prop(index+2) + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) +! +! check for negative flow: in that case the loss +! coefficient is wrong +! + if(inv.lt.0) then + write(*,*) '*ERROR in liquidpipe: loss coefficients' + write(*,*) ' for entrance (Idelchik) do not apply' + write(*,*) ' to reversed flow' + stop + endif +! + dh=prop(index+3) + if(dh.eq.0.d0) then + dh=dsqrt(4*a2/pi) + endif + if(inv.eq.0) then + reynolds=5000.d0 + else + reynolds=dabs(xflow)*dh/(dvi*a2) + endif +! + if(inv.ne.0) then + xk=zeta/(a2*a2) + else + xkn=zeta/(a2*a2) + xkp=xkn + endif + elseif(lakon(nelem)(4:5).eq.'EX') then +! +! pipe, exit (Idelchik) +! + a1=prop(index+1) + a2=prop(index+2) + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + if(inv.lt.0) then + write(*,*) '*ERROR in liquidpipe: loss coefficients' + write(*,*) ' for exit (Idelchik) do not apply to' + write(*,*) ' reversed flow' + stop + endif +! + dh=prop(index+3) + if(dh.eq.0.d0) then + dh=dsqrt(4*a1/pi) + endif + if(inv.eq.0) then + reynolds=5000.d0 + else + reynolds=dabs(xflow)*dh/(dvi*a1) + endif +! + if(inv.ne.0) then + xk=zeta/(a1*a1) + else + xkn=zeta/(a1*a1) + xkp=xkn + endif + elseif(lakon(nelem)(4:5).eq.'US') then +! +! pipe, user defined loss coefficient +! + a1=prop(index+1) + a2=prop(index+2) + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + if(inv.lt.0) then + write(*,*) '*ERROR in liquidpipe: loss coefficients' + write(*,*) ' for a user element do not apply to' + write(*,*) ' reversed flow' + stop + endif + if(a1.lt.a2) then + a=a1 + a2=a1 + else + a=a2 + a1=a2 + endif +! + dh=prop(index+3) + if(dh.eq.0.d0) then + dh=dsqrt(4*a/pi) + endif + if(inv.eq.0) then + reynolds=5000.d0 + else + reynolds=dabs(xflow)*dh/(dvi*a) + endif +! + if(inv.ne.0) then + xk=zeta/(a*a) + else + xkn=zeta/(a*a) + xkp=xkn + endif + elseif(lakon(nelem)(6:7).eq.'GV') then +! +! pipe, gate valve (Berlamont) +! + a=prop(index+1) + if(nactdog(3,nodem).eq.0) then +! geometry is fixed + alpha=prop(index+2) + else +! geometry is unknown + alpha=v(3,nodem) + endif + a1=a + a2=a + dzetadalpha=0.d0 + call ident(xgv,alpha,ngv,id) + if(id.eq.0) then + zeta=ygv(1) + elseif(id.eq.ngv) then + zeta=ygv(ngv) + else + dzetadalpha=(ygv(id+1)-ygv(id))/(xgv(id+1)-xgv(id)) + zeta=ygv(id)+dzetadalpha*(alpha-xgv(id)) + endif + if(inv.ne.0) then + xk=zeta/(a*a) + dkda=dzetadalpha/(a*a) + else + if(flowunknown) then + xkn=zeta/(a*a) + xkp=xkn + endif + endif + elseif(lakon(nelem)(6:7).eq.'BE') then +! +! pipe, bend; values from Berlamont +! + a=prop(index+1) + rd=prop(index+2) + alpha=prop(index+3) + coarseness=prop(index+4) + a1=a + a2=a + call ident(xbe,rd,nbe,id) + if(id.eq.0) then + zeta=ybe(1)+(zbe(1)-ybe(1))*coarseness + elseif(id.eq.nbe) then + zeta=ybe(nbe)+(zbe(nbe)-ybe(nbe))*coarseness + else + zeta=(1.d0-coarseness)* + & (ybe(id)+(ybe(id+1)-ybe(id))*(rd-xbe(id))/ + & (xbe(id+1)-xbe(id))) + & +coarseness* + & (zbe(id)+(zbe(id+1)-zbe(id))*(rd-xbe(id))/ + & (xbe(id+1)-xbe(id))) + endif + zeta=zeta*alpha/90.d0 + if(inv.ne.0) then + xk=zeta/(a*a) + else + xkn=zeta/(a*a) + xkp=xkn + endif + elseif(lakon(nelem)(4:5).eq.'BE') then +! +! pipe, bend; values from Idelchik or Miller, OWN +! + a=prop(index+1) + dh=prop(index+3) + if(dh.eq.0.d0) then + dh=dsqrt(4*a/pi) + endif + if(inv.eq.0) then + reynolds=5000.d0 + else + reynolds=dabs(xflow)*dh/(dvi*a) + endif + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + if(inv.ne.0) then + xk=zeta/(a*a) + else + xkn=zeta/(a*a) + xkp=xkn + endif + a1=a + a2=a + elseif(lakon(nelem)(4:5).eq.'LO') then +! +! long orifice; values from Idelchik or Lichtarowicz +! + a1=prop(index+1) + dh=prop(index+3) + if(inv.eq.0) then + reynolds=5000.d0 + else + reynolds=dabs(xflow)*dh/(dvi*a1) + endif + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + if(inv.ne.0) then + xk=zeta/(a1*a1) + else + xkn=zeta/(a1*a1) + xkp=xkn + endif + a2=a1 + elseif(lakon(nelem)(4:5).eq.'WA') then +! +! wall orifice; values from Idelchik +! +! entrance is infinitely large +! + a1=1.d10*prop(index+1) +! +! reduced cross section +! + a2=prop(index+2) + dh=prop(index+3) + if(inv.eq.0) then + reynolds=5000.d0 + else + reynolds=dabs(xflow)*dh/(dvi*a2) + endif + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) +! +! check for negative flow: in that case the loss +! coefficient is wrong +! + if(inv.lt.0) then + write(*,*) '*ERROR in liquidpipe: loss coefficients' + write(*,*) ' for wall orifice do not apply to' + write(*,*) ' reversed flow' + stop + endif + if(inv.ne.0) then + xk=zeta/(a2*a2) + else + xkn=zeta/(a2*a2) + xkp=xkn + endif + elseif(lakon(nelem)(4:5).eq.'BR') then +! +! branches (joints and splits); values from Idelchik and GE +! + if(nelem.eq.int(prop(index+2))) then + a=prop(index+5) + else + a=prop(index+6) + endif + a1=a + a2=a +! +! check for negative flow: in that case the loss +! coefficient is wroing +! + if(inv.lt.0) then + write(*,*) '*ERROR in liquidpipe: loss coefficients' + write(*,*) ' for branches do not apply to' + write(*,*) ' reversed flow' + stop + endif + if(inv.ne.0) then + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + xk=zeta/(a*a) + else +! +! here, the flow is unknown. To this end zeta is needed. However, +! zeta depends on the flow: circular argument. Therefore a +! fixed initial value for zeta is taken +! + zeta=0.5d0 + xkn=zeta/(a*a) + xkp=xkn + endif +! +! all types of orifices +! + elseif((lakon(nelem)(4:5).eq.'C1')) then + a1=prop(index+1) + a2=a1 + dh=prop(index+2) + if(inv.eq.0) then + reynolds=5000.d0 + else + reynolds=dabs(xflow)*dh/(dvi*a1) + endif + zeta=1.d0 +! + a=a1 + zeta=1/zeta**2 + if(inv.ne.0) then + xk=zeta/(a*a) + else + xkn=zeta/(a*a) + xkp=xkn + endif +! +! all types of vorticies +! + elseif((lakon(nelem)(4:4).eq.'V')) then +! +! radius downstream + r2d=prop(index+1) +! +! radius upstream + r1d=prop(index+2) +! +! pressure correction factor + eta=prop(index+3) +! + if(((xflow.gt.0.d0).and.(R2d.gt.R1d)) + & .or.((R2.lt.R1).and.(xflow.lt.0d0))) then + inv=1.d0 + p1=v(2,node1) + p2=v(2,node2) + R1=r1d + R2=r2d +! + elseif(((xflow.gt.0.d0).and.(R2d.lt.R1d)) + & .or.((R2.gt.R1).and.(xflow.lt.0d0))) then + inv=-1.d0 + R1=r2d + R2=r1d + p1=v(2,node2) + p2=v(2,node1) + xflow=-v(1,nodem) +! + nodef(1)=node2 + nodef(2)=nodem + nodef(3)=node1 +! + endif +! + idirf(1)=2 + idirf(2)=1 + idirf(3)=2 +! +! FREE VORTEX +! + if((lakon(nelem)(4:5).eq.'VF')) then +! rotation induced loss (correction factor) + K1= prop(index+4) +! +! tangential velocity of the disk at vortex entry + U1=prop(index+5) +! +! number of the element generating the upstream swirl + nelemswirl=int(prop(index+6)) +! +! rotation speed (revolution per minutes) + rpm=prop(index+7) +! +! Temperature change + t_chang=prop(index+8) +! + if(rpm.gt.0) then +! +! rotation speed is given (rpm) if the swirl comes from a rotating part +! typically the blade of a coverplate +! + omega=pi/30d0*rpm + +! C_u is given by radius r1d (see definition of the flow direction) +! C_u related to radius r2d is a function of r1d +! + if(inv.gt.0) then + c1u=omega*r1 +! +! flow rotation at outlet + c2u=c1u*r1/r2 +! + elseif(inv.lt.0) then + c2u=omega*r2 +! + c1u=c2u*r2/r1 + endif +! + elseif(nelemswirl.gt.0) then + if(lakon(nelemswirl)(2:5).eq.'LPPN') then + cinput=prop(ielprop(nelemswirl)+5) + elseif(lakon(nelemswirl)(2:5).eq.'LPVF') then + cinput=prop(ielprop(nelemswirl)+9) + elseif(lakon(nelemswirl)(2:5).eq.'LPFS') then + cinput=prop(ielprop(nelemswirl)+7) + endif +! + cinput=U1+K1*(cinput-U1) +! + if(inv.gt.0) then + c1u=cinput + c2u=c1u*R1/R2 + elseif(inv.lt.0) then + c2u=cinput + c1u=c2u*R2/R1 + endif + endif +! storing the tengential velocity for later use (wirbel cascade) + if(inv.gt.0) then + prop(index+9)=c2u + elseif(inv.lt.0) then + prop(index+9)=c1u + endif +! +! inner rotation +! + if(R1.lt.R2) then + ciu=c1u + elseif(R1.ge.R2) then + ciu=c2u + endif +! +! if (iflag.eq.1) then + a1=1E-6 + a2=a1 + if(inv.ne.0) then + xkn=rho/2*ciu**2*(1-(R1/R2)**2) + xkp=xkn + else + xkn=rho/2*ciu**2*(1-(R1/R2)**2) + xkp=xkn + endif + endif +! +! FORCED VORTEX +! + if((lakon(nelem)(4:5).eq.'VS')) then +! +! core swirl ratio + Kr=prop(index+4) +! +! rotation speed (revolution per minutes) of the rotating part +! responsible for the swirl + rpm=prop(index+5) +! +! Temperature change + t_chang=prop(index+6) +! +! rotation speed + omega=pi/30*rpm +! + Ui=omega*R1 + c1u=Ui*kr + c2u=c1u*R2/R1 +! +! storing the tengential velocity for later use (wirbel cascade) + if(inv.gt.0) then + prop(index+7)=c2u + elseif(inv.lt.0) then + prop(index+7)=c1u + endif +! + a1=1E-6 + a2=a1 + if(iflag.eq.1)then + xflow=0.5d0 + endif +! + if(inv.ne.0) then + xkn=rho/2*Ui**2*((R2/R1)**2-1) + xkp=xkn + else + xkn=rho/2*Ui**2*((R2/R1)**2-1) + xkp=xkn + endif + endif + endif +! + if(iflag.eq.1) then + if(flowunknown) then +! + xk1=1.d0/(a1*a1) + xk2=1.d0/(a2*a2) + xflow=(z1-z2+(p1-p2)/rho)/(xk2-xk1+xkp) + if(xflow.lt.0.d0) then + xflow=(z1-z2+(p1-p2)/rho)/(xk2-xk1-xkn) + if(xflow.lt.0.d0) then + write(*,*) '*WARNING in liquidpipe:' + write(*,*) ' initial mass flow could' + write(*,*) ' not be determined' + write(*,*) ' 1.d-10 is taken' + xflow=1.d-10 + else + xflow=-rho*dsqrt(2.d0*xflow) + endif + else + xflow=rho*dsqrt(2.d0*xflow) + endif + else +! +! mass flow known, geometry unknown +! + if(lakon(nelem)(6:7).eq.'GV') then + prop(index+2)=0.5d0 + endif + endif + elseif(iflag.eq.2) then + xk1=1.d0/(a1*a1) + xk2=1.d0/(a2*a2) +! + if(lakon(nelem)(4:4).ne.'V') then +! + numf=4 + df(3)=1.d0/rho + df(1)=-df(3) + df(2)=(xk2-xk1+inv*xk)*xflow/(rho*rho) + df(4)=(xflow*xflow*inv*dkda)/(2.d0*rho*rho) + f=df(3)*p2+df(1)*p1+df(2)*xflow/2.d0+z2-z1 +! + else if (lakon(nelem)(4:5).eq.'VF') then + numf=3 + if(R2.ge.R1) then + f=P1-P2+xkp + df(1)=1 + df(2)=0 + df(3)=-1 + elseif(R2.lt.R1) then + f=P1-P2-xkp + df(1)=1 + df(2)=0 + df(3)=-1 + endif + else if (lakon(nelem)(4:5).eq.'VS') then + if(((R2.ge.R1).and.(xflow.gt.0d0)) + & .or.((R2.lt.R1).and.(xflow.lt.0d0)))then +! + f=p1-p2+xkn +! pressure node1 + df(1)=1 +! massflow nodem + df(2)=0 +! pressure node2 + df(3)=-1 +! + elseif(((R2.lt.R1).and.(xflow.gt.0d0)) + & .or.((R2.gt.R1).and.(xflow.lt.0d0)))then +! + f=p2-p1+xkn +! pressure node1 + df(1)=-1 +! massflow nodem + df(2)=0 +! pressure node2 + df(3)=1 + endif + endif +! + else if (iflag.eq.3) then + xflow_vol=xflow/rho + un=dvi/rho + if(inv.eq.1) then + T=v(0,node1) + else + T=v(0,node2) + endif +! + write(1,*) '' + write(1,55) 'In line',int(nodem/1000),' from node',node1, + & ' to node', node2,': oil massflow rate = ',xflow, + & ' kg/s i.e. ',xflow_vol, ' m**3/s' + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,F9.6,A) + write(1,57)' + &Rho= ',rho,' kg/m**3, Nu= ',un,' m**2/s, Eta= ',dvi, + &' kg/(m*s)' + + if(inv.eq.1) then + write(1,56)' Inlet node ',node1,': Tt1=',T, + & 'K, Pt1=',P1/1E5, 'Bar' + if(lakon(nelem)(4:5).eq.'EL'.or. + & lakon(nelem)(4:5).eq.'CO'.or. + & lakon(nelem)(4:5).eq.'EN'.or. + & lakon(nelem)(4:5).eq.'EX'.or. + & lakon(nelem)(4:5).eq.'US'.or. + & lakon(nelem)(4:5).eq.'BE'.or. + & lakon(nelem)(4:5).eq.'LO'.or. + & lakon(nelem)(4:5).eq.'WA'.or. + & lakon(nelem)(4:5).eq.'BR')then + + write(1,*)' element F ',set(numf)(1:20) + write(1,58)' Re= ',reynolds,' zeta= ', + & zeta +! + elseif((lakon(nelem)(4:5).eq.'C1')) then + write(1,*)' element R ',set(numf)(1:20) + write(1,58)' Re= ',reynolds,' cd= ', + & zeta +! + else if(lakon(nelem)(4:5).eq.'FR')then + write(1,*)' element W ',set(numf)(1:20) + write(1,59)' Re= ',reynolds,' lambda= + &',friction,' lambda*L/D= ',friction*dl/d +! + else if (lakon(nelem)(4:4).eq.'V')then + write(1,*)' element V ',set(numf)(1:20) + write(1,*)' C1u= ',C1u,'m/s ,C2u= ' + &,C2u,'m/s',' ,DeltaP= ',xkn/1E5,' Bar' + endif +! + write(1,56)' Outlet node ',node2,': Tt2=',T, + & 'K, Pt2=',P2/1e5,'Bar' +! + else if(inv.eq.-1) then + + endif +! + 56 FORMAT(1X,A,I6.3,A,f6.1,A,f9.5,A) + 57 FORMAT(1X,A,f8.3,A,G9.4,A,G9.4,A) + 58 FORMAT(1X,A,G9.4,A,F6.4) + 59 FORMAT(1X,A,G9.4,A,F6.4,A,F6.4) + endif +! + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/liquidpump.f calculix-ccx-2.3/ccx_2.3/src/liquidpump.f --- calculix-ccx-2.1/ccx_2.3/src/liquidpump.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/liquidpump.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,132 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine liquidpump(node1,node2,nodem,nelem, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,rho,g,co,numf,mi) +! +! pump for incompressible media +! + implicit none +! + logical identity +! + integer nelem,nactdog(0:3,*),node1,node2,nodem, + & ielprop(*),nodef(4),idirf(4),index,iflag, + & inv,id,numf,npu,i,mi(2) +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4), + & p1,p2,rho,g(3),dg,z1,z2,co(3,*), + & xpu(10),ypu(10),xxpu(10),yypu(10),dh +! + numf=3 +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif((iflag.eq.1).or.(iflag.eq.2))then +! + index=ielprop(nelem) +! + npu=nint(prop(index+1)) + do i=1,npu + xpu(i)=prop(index+2*i) + ypu(i)=prop(index+2*i+1) + enddo +! + p1=v(2,node1) + p2=v(2,node2) +! + z1=-g(1)*co(1,node1)-g(2)*co(2,node1)-g(3)*co(3,node1) + z2=-g(1)*co(1,node2)-g(2)*co(2,node2)-g(3)*co(3,node2) +! + if(iflag.eq.2) then + xflow=v(1,nodem) + if(xflow.ge.0.d0) then + inv=1 + else + inv=-1 + endif + nodef(1)=node1 + nodef(2)=nodem + nodef(3)=node2 + idirf(1)=2 + idirf(2)=1 + idirf(3)=2 + endif +! + dg=dsqrt(g(1)*g(1)+g(2)*g(2)+g(3)*g(3)) +! + if(iflag.eq.1) then + dh=(z2-z1+(p2-p1)/rho)/dg +! +! reverting the order in xpu and ypu and storing the +! result in xxpu and yypu +! + do i=1,npu + xxpu(i)=xpu(npu+1-i) + yypu(i)=ypu(npu+1-i) + enddo + call ident(yypu,dh,npu,id) + if(id.eq.0) then + xflow=xxpu(1) + elseif(id.eq.npu) then + xflow=0.d0 + else + xflow=xxpu(id)+(xxpu(id+1)-xxpu(id))*(dh-yypu(id))/ + & (yypu(id+1)-yypu(id)) + endif + else + df(1)=1.d0/rho + df(3)=-df(1) + xflow=xflow/rho + call ident(xpu,xflow,npu,id) + if(id.eq.0) then + if(xflow.ge.0.d0) then + f=z1-z2+(p1-p2)/rho+dg*ypu(1) + df(2)=0.d0 + else + df(2)=-1.d10 + f=z1-z2+(p1-p2)/rho+dg*(ypu(1)+xflow*df(2)) + df(2)=df(2)*dg/rho + endif + elseif(id.eq.npu) then + df(2)=-1.d10 + f=z1-z2+(p1-p2)/rho+dg*(ypu(npu)+df(2)*(xflow-xpu(npu))) + df(2)=df(2)*dg/rho + else + df(2)=(ypu(id+1)-ypu(id))/(xpu(id+1)-xpu(id)) + f=z1-z2+(p1-p2)/rho+dg*(ypu(id)+(xflow-xpu(id))*df(2)) + df(2)=df(2)*dg/rho + endif + endif +! + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/loadadd.f calculix-ccx-2.3/ccx_2.3/src/loadadd.f --- calculix-ccx-2.1/ccx_2.3/src/loadadd.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/loadadd.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,116 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine loadadd(nelement,label,value,nelemload,sideload, + & xload,nload,nload_,iamload,iamplitude,nam,isector) +! +! adds a facial dload condition to the data base +! + implicit none +! + character*20 label,sideload(*) +! + integer nelemload(2,*),iamload(2,*),nelement,nload,nload_,j, + & iamplitude,nam,isector,id +! + real*8 xload(2,*),value +! + call nident2(nelemload,nelement,nload,id) + if(id.gt.0) then +! +! it is possible that several *DLOAD, *FILM or +! *RADIATE boundary conditions are applied to one +! and the same element +! + if(nelemload(1,id).eq.nelement) then + do + if (sideload(id).eq.label) then + if(nelemload(2,id).eq.isector) then +! +! loading on same element face and sector +! detected: values are replaced +! + xload(1,id)=value + xload(2,id)=0.d0 + if(nam.gt.0) then + iamload(1,id)=iamplitude + iamload(2,id)=iamplitude + endif + return + elseif(nelemload(2,id).lt.isector) then +c id=id-1 + exit + endif + elseif(sideload(id).lt.label) then +c id=id-1 + exit + endif + id=id-1 + if((id.eq.0).or.(nelemload(1,id).ne.nelement)) then +c id=id-1 + exit + endif + enddo + endif + endif +! +! loading a element face on which no previous loading +! was applied +! +! loading conditions on one and the same element are +! alphabetized based on field sideload +! +! loading conditions on one and the same element and +! of one and the same sideload type are ordered based +! on field nelemload(2,*) +! + nload=nload+1 + if(nload.gt.nload_) then + write(*,*) '*ERROR in loadadd: increase nload_' + stop + endif +! +! shifting existing loading +! + do j=nload,id+2,-1 + nelemload(1,j)=nelemload(1,j-1) + nelemload(2,j)=nelemload(2,j-1) + sideload(j)=sideload(j-1) + xload(1,j)=xload(1,j-1) + xload(2,j)=xload(2,j-1) + if(nam.gt.0) then + iamload(1,j)=iamload(1,j-1) + iamload(2,j)=iamload(2,j-1) + endif + enddo +! +! inserting new loading +! + nelemload(1,id+1)=nelement + nelemload(2,id+1)=isector + sideload(id+1)=label + xload(1,id+1)=value + xload(2,id+1)=0. + if(nam.gt.0) then + iamload(1,id+1)=iamplitude + iamload(2,id+1)=0 + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/loadaddp.f calculix-ccx-2.3/ccx_2.3/src/loadaddp.f --- calculix-ccx-2.1/ccx_2.3/src/loadaddp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/loadaddp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,107 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine loadaddp(nelement,label,nelemload,sideload, + & xload,nload,nload_,iamload,iamplitude,nam,node) +! +! adds a facial dload condition to the data base +! + implicit none +! + character*20 label,sideload(*) +! + integer nelemload(2,*),iamload(2,*),nelement,nload,nload_,j, + & iamplitude,nam,node,id +! + real*8 xload(2,*) +! + call nident2(nelemload,nelement,nload,id) + if(id.gt.0) then +! +! it is possible that several *DLOAD, *FILM or +! *RADIATE boundary conditions are applied to one +! and the same element +! + if(nelemload(1,id).eq.nelement) then + do + if(sideload(id).eq.label) then +! +! loading on same element face and sector +! detected: values are replaced +! + xload(1,id)=0.d0 + xload(2,id)=0.d0 + if(nam.gt.0) then + iamload(1,id)=iamplitude + iamload(2,id)=0.d0 + endif + return + elseif(sideload(id).lt.label) then +c id=id-1 + exit + endif + id=id-1 + if((id.eq.0).or.(nelemload(1,id).ne.nelement)) then +c id=id-1 + exit + endif + enddo + endif + endif +! +! loading a element face on which no previous loading +! was applied +! +! loading conditions on one and the same element are +! alphabetized based on field sideload +! + nload=nload+1 + if(nload.gt.nload_) then + write(*,*) '*ERROR in loadadd: increase nload_' + stop + endif +! +! shifting existing loading +! + do j=nload,id+2,-1 + nelemload(1,j)=nelemload(1,j-1) + nelemload(2,j)=nelemload(2,j-1) + sideload(j)=sideload(j-1) + xload(1,j)=xload(1,j-1) + xload(2,j)=xload(2,j-1) + if(nam.gt.0) then + iamload(1,j)=iamload(1,j-1) + iamload(2,j)=iamload(2,j-1) + endif + enddo +! +! inserting new loading +! + nelemload(1,id+1)=nelement + nelemload(2,id+1)=node + sideload(id+1)=label + xload(1,id+1)=0.d0 + xload(2,id+1)=0. + if(nam.gt.0) then + iamload(1,id+1)=iamplitude + iamload(2,id+1)=0 + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/loadaddt.f calculix-ccx-2.3/ccx_2.3/src/loadaddt.f --- calculix-ccx-2.1/ccx_2.3/src/loadaddt.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/loadaddt.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,109 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine loadaddt(nelement,label,valfilm,valtemp,nelemload, + & sideload,xload,nload,nload_,iamload,iamptemp, + & iampfilm,nam,node) +! +! adds a thermal dload condition to the data base +! + implicit none +! + character*20 label,sideload(*) +! + integer nelemload(2,*),iamload(2,*),id, + & nelement,nload,nload_,j,iamptemp,nam,iampfilm,node +! + real*8 xload(2,*),valfilm,valtemp +! + call nident2(nelemload,nelement,nload,id) + if(id.gt.0) then +! +! it is possible that several *DLOAD, *FILM or +! *RADIATE boundary conditions are applied to one +! and the same element +! + if(nelemload(1,id).eq.nelement) then + do + if(sideload(id).eq.label) then +! +! loading on same element face detected: values +! are replaced +! + xload(1,id)=valfilm + xload(2,id)=valtemp + nelemload(2,id)=node + if(nam.gt.0) then + iamload(1,id)=iampfilm + iamload(2,id)=iamptemp + endif + return + elseif(sideload(id).lt.label) then +c id=id-1 + exit + endif + id=id-1 + if((id.eq.0).or.(nelemload(1,id).ne.nelement)) then +c id=id-1 + exit + endif + enddo + endif + endif +! +! loading a element face on which no previous loading +! was applied +! +! loading conditions on one and the same element are +! alphabetized based on field sideload +! + nload=nload+1 + if(nload.gt.nload_) then + write(*,*) '*ERROR in loadadd: increase nload_' + stop + endif +! +! shifting existing loading +! + do j=nload,id+2,-1 + nelemload(1,j)=nelemload(1,j-1) + nelemload(2,j)=nelemload(2,j-1) + sideload(j)=sideload(j-1) + xload(1,j)=xload(1,j-1) + xload(2,j)=xload(2,j-1) + if(nam.gt.0) then + iamload(1,j)=iamload(1,j-1) + iamload(2,j)=iamload(2,j-1) + endif + enddo +! +! inserting new loading +! + nelemload(1,id+1)=nelement + nelemload(2,id+1)=node + sideload(id+1)=label + xload(1,id+1)=valfilm + xload(2,id+1)=valtemp + if(nam.gt.0) then + iamload(1,id+1)=iampfilm + iamload(2,id+1)=iamptemp + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/LOGBOOK calculix-ccx-2.3/ccx_2.3/src/LOGBOOK --- calculix-ccx-2.1/ccx_2.3/src/LOGBOOK 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/LOGBOOK 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1803 @@ +======== +LOG-BOOK Version 2.3 +======== + +09 Nov 1998 - removed mistake from anisotropic.f + - faster code for orthotropic materials in stress.f and + elemmatr_pr.f (replacement of orthotropic.f); to be + implemented in elemmatr_la.f too. + +10 Nov 1998 - definition of sets within *NODE and *ELEMENT. + +11 Nov 1998 - several steps within one calculation. + - no allocation of mast1 and mast2 for static calculations. + +16 Nov 1998 - small correction to orientations. + - correction to material transformation in kyrinput. + +17 Nov 1998 - small corrections for multiple step calculations. + +23 Nov 1998 - correction for second order frequency calculations. + - resetting the loads for perturbative steps + +24 Nov 1998 - check for second order static calculations OK. + +26 Nov 1998 - frequency calculations with prestress works! At + buckling load the frequency reduces to zero. + +10 Dec 1998 - corrected an error in kyrinput (call of nquickx2). + +Jan 1999 - implemented LANSO for eigenvalue calculations: + did not work; abandoned. + - implemented ARPACK for eigenvalue calculations: + problems under Linux, which do not occur on the + IRIX. TO BE ANALYZED! + - implemented UMFPACK for static calculations: for + small problems half as fast as PROFILE; for big + problems too much memory grabbed; abandoned. + - implemented SPOOLES for static calculations: works + fine; for big problems and nested dissection ordering + about 25% faster than PROFILE (18,000 equations). + Probably even faster for really big problems and low + fill-in (> 50,000 equations and < 5 % fill-in). + +3 Feb 1999 - on a SGI, SPOOLES is about 7 times faster than the + profile method for about 110,000 degrees of freedom + (900 MB RAM needed). + +7 Feb 1999 - started reorganization: (*) instead of (1), implicit + none instead of implicit real*8(a-h,o-z) + +Mar 1999 - ARPACK works on Linux when compiled with FC=f77-f2c; reason + unclear; however, it is not necessarily faster than + LEVALH. Maybe calculating the largest eigenvalues of the + inverse matrix is faster? + +27 Mar 1999 - MODAL DYNAMIC works. Testing of buckling with ARPACK started. + +8 April 1999 - calculating frequencies in shift-invert mode with ARPACK/ + SPOOLES works and is significantly faster than the direct + mode (factor 4 or 5). + - BUCKLING works! + +18 April 1999 - checked shift-invert mode for big problems. Up to a factor + of 90 faster than the direct method! + - refined output selection: U, NT, S or E. + +21 April 1999 - united the routine composing the eigenvalue matrices + with the routine constructing the static stiffness matrix + (elemmatr_ei.f and elemmatr_st.f -> c_3d20.f) + - automation of the test routine (compare) + +20 May 1999 - reorganisation of the element topology information + - inclusion of C3D8 elements. + +7 juni 1999 - in previous releases 2nd order static calculations used + the large displacment stiffness only, 2nd order modal + calculations used the stress stiffness only. Now both + stiffnesses are used in any of these cases. What is + left to do is the use of the differential large deformation + matrix for buckling calculations (independent of iperturb), + in addition to the stress stiffness differential used now. + +6 juli 1999 - correction of small errors + +7 juli 1999 - removed lumping in modal analysis. Results match ABAQUS + results very well (deviation < 0.5 %). + +10 juli 1999 - started removing lumping from linear dynamic calculations. + eigenmodes should be normalized with respect to the mass + matrix. To do! + +11 juli 1999 - normalization with respect to the mass matrix done. Still + differences with ABAQUS for beta (damping coef) != 0. Maybe + there is still an error for the supercritical regime. To + check + - removed levalh and subprograms: default and only solver for + modal analysis is ARPACK + +31 juli 1999 - took care of inhomogeneous equations: introduce a dummy + node with fixed displacements. + +Sept. 1999 - started to work on geometrically nonlinear calculations + +26 Oct. 1999 - geometrically nonlinear option implemented and checked. + - in second order frequency calculations the material + temperatures from the previous nonperturbative step are + kept. + +2 Dec. 1999 - changed the extrapolated stress and strain values in the + midpoints of the 20-node elements to the ABAQUS convention, + i.e. extrapolation is made within each element after which + the mean is taken of values in neighboring elements. + +Dec. 1999 - started the implementation of hyperelastic solids, + hyperfoam materials and deformation plasticity. + +25 Dec. 1999 - removed an error in mafillsm and mafillpr: introduced + a new variable idof3 + +Jan-Feb 2000 - check of the hyperelastic capabilities; merges disp and + stress into one subroutine results to cover nonlinear + calculations with prescribed displacements. + +7 Feb 2000 - corrected an error in materialdata for mixed isotropic/ + orthotropic/anisotropic materials + +20 Feb 2000 - accelerated hyperelastic calculations by a factor of 15 + +5 Mar 2000 - deformation plasticity works (mechanical forces)! + +9 Mar 2000 - deformation plasticity subject to thermal forces works! + +30 April 2000 - C3D20R seems to work very well for thick and thin shells + (just one layer of brick elements) + - upgraded to SPOOLES.2.2. + +19 May 2000 - started implementing implicit and explicit integration + dynamics + +June 2000 - implementation nonlinear dynamics finished; + needs checking + - material data are determined in each integration point + separately instead of per element + +3 July 2000 - corrected an error occurring in nonlinear calculations + with mpc's + +July 2000 - changed the stress-strain curve to be given for deformation + plasticity from 2nd Piola-Kirchhoff stress vs. Lagrangian + strain to true stress vs. Eulerian strain. + +18 July 2000 - included extrapolation of one increment to the next: + accelerates convergence + +5 Aug 2000 - started implementing incremental plasticity with + isotropic and/or kinematic hardening + +Sept 2000 - started checking implicit and explicit dynamics + +18 Sept 2000 - corrected the allocation of jq: 3*nk+1 (needed in + mastruct) + - implicit and explicit dynamics seem to work! + However, the calculation of the initial acceleration due + to a sudden load change at the start of a step, requiring + the solution of a linear equation set with the full mass + matrix causes problems: the solution of the system is not + plausible (1.e24). The problem improves drastically by + adding some stiffness to the mass. + +1 Oct 2000 - the only environment variable left is the job-name + all other file names are derived from the job-name: + .inp,.dat,.frd,.eig and .sta + - changed CALCULIX into CalculiX + - stored increment information in the .sta file + +15 Oct 2000 - started to replace the FORTRAN input files by C input + files; purpose: automatic reallocation if the problem + data size exceed preset values + +16 Oct 2000 - postponed the replacement of FORTRAN by C to a later date; + +6 Nov 2000 - isotropic incremental plasticity works for beam + example! + +16 Nov 2000 - implemented interpolation between hardening curves at + different temperatures + +9 Dec 2000 - accelerated nonlinear calculations for given + displacements or temperatures: first iteration in + a new increment must be purely linear elastic + +23 Dec 2000 - put version 0.9 on our webpage + +28 Dec 2000 - started to implement creep; user routines option provided + for plastic hardening curves and the creep law. + +17 Jan 2001 - creep (viscoplasticity) works + +25 Jan 2001 - looked into iterative solvers (ITPACK-nspcg and + pcgsolver-TU-Muenchen) + +4 Feb 2001 - abandoned iterative solvers: worked for small + examples (1,000 DOFs) but not for intermediate ones + (20,000 DOFs) + +5 Feb 2001 - started to implement cyclic symmetry + +6 Feb 2001 - fixed format is not longer supported. Use free format. + +16 Feb 2001 - invested some more time in pcgsolver. Works well + with Cholesky preconditioning. Convergence slow for + 2-D problems such as plates. For large, compact 3-D problems + faster than SPOOLES. Pcgsolver can be selected for + linear problems (test phase). + +27 Feb 2001 - started to implement C3D8R, C3D20 and C3D10 elements. + +10 Mar 2001 - changed the Nested Dissection Ordering in SPOOLES to + Multi-Section Ordering. Seems to be faster for medium + size problems (150,000 DOF). + - implemention of C3D8R, C3D20 and C3D10 elements + successfully finished. + +26 Mar 2001 - introduced pre-processor directives to cope with different + C - FORTRAN interface conventions on different machines + (underscore or not) + +27 Mar 2001 - changes input and output format from record length 80 to + record length 132 + - started to code transformations (rectangular and + cylindrical) (*TRANSFORM). + +21 Apr 2001 - introduced an iterative procedure to improve the + results in a *BUCKLE procedure: the buckling factor + is linked to the value of sigma (ARPACK) + - transformations work + - started to implement the iterative procedure for + nonlinear calculations + +22 Apr 2001 - iterative procedure for nonlinear calculations works + +30 Apr 2001 - collapsed elements work now! (changed the add*f subroutines) + - corrected some storage inconsistensies in CalculiX.c; should + solve the problems encountered when several steps occur in + the same input deck. + +2 May 2001 - corrected an error leading to wrong results for + element types with weight different from 1 and anisotropic + material behavior (subroutines orthonl.f and anisonl.f: + forgot to multiply with weight) + +14 May 2001 - changed the Sloan renumbering routines to allow skylines + larger than 4-byte integers (>2147483647). + +17 May 2001 - started to change mastruct from FORTRAN to C in order to + be able to reallocate the # of nonzero's in the matrix + +21 May 2001 - automatic reallocation of nonzero's works + +26 May 2001 - started automatic allocation of input data + (subroutine allocation.f) + +5 June 2001 - auomatic allocation works; + - started implementation of cyclic symmetry conditions + for frequency calculations + +23 June 2001 - corrected an error in the residual stress (- sign) + +19 July 2001 - started to work on tetrahedral meshing of point + clouds + +9 Aug 2001 - tetrahedral meshing of a box enclosing a point + cloud works + +14 Sep 2001 - corrected an error in file incplas.f: + "c9=c6*umb*3.d0" replaced by "c9=c6*3.d0" + +18 Sep 2001 - started change from updated Lagrangian to total + Lagrangian for incremental plasticity + +7 Oct 2001 - concluded change to total Lagrangian formulation + - started introduction of field xstiff and xstate + in preparation for umat routine + +25 Oct 2001 - wrote first user material subroutine + +29 Oct 2001 - umat (material) subroutine seems to work + +24 Nov 2001 - included stress at start of increment in umat + - new investigation of cyclic symmetry: frequencies + are correct, eigenmodes too, except at the + dependent boundary + +25 Nov 2001 - cyclic symmetry seems to work! + +29 Nov 2001 - correction for MPC's with only one term (= zero + SPC) + +9 Dec 2001 - mapping of the results for one sector to other sectors + in a cyclic symmetry calculation works. + +7 Jan 2002 - started coding rigid body motion + - worked on tension-only umat routine + +8 Jan 2002 - corrected an error in the C translation in mastructcs.c + +11 Jan 2002 - corrected an integer internal overflow in arpackcs.c + +30 Jan 2002 - finished coding rigid body motion + - cyclic symmetry in conjunction with other MPC's works + +7 Feb 2002 - fixed some minor errors related to *FREQUENCY and + *BUCKLING + +March 2002 - started to work on the theory manual. + +2 Apr 2002 - corrected an error in frdcyc: the coordinates have + to be duplicated also for kode>1 + +10 Apr 2002 - corrected an error in boundaries: deletion of SPCs + in local coordinate systems with OP=NEW did not work + properly + +16 Apr 2002 - continued to work on rigid body motion and nonlinear + mpc's in general + +27 Apr 2002 - *RIGID BODY works + - with RF only EXTERNAL forces are obtained. If a MPC + connects two nodes of the structure, the force + is internal and cannot be obtained using RF. + +5 June 2002 - allowed for nested *INCLUDE statements up to three + levels deep + +12 June 2002 - took out the normalization of the displacements in + arpackbu.c (buckling). + +6 July 2002 - changed getnewline: the input is freed from blanks + and changed to upper case. Thus, input is more + flexible. + +17 July 2002 - same name can be used for node sets and element sets + internally, a "N" or "E" is appended to distinguish + them + +18 July 2002 - sets can be defined using previously defined sets + - abbreviating u_calloc with NNEW + +24 July 2002 - a set can be defined using multiple *NSET or *ELSET + cards + - abbreviating realloc with RENEW + +29 July 2002 - corrected a bug in boundaries.f which occurred when + SPC's in transformed coordinates were removed with + OP=NEW + +6 Sept 2002 - corrected wrong file names in some of the *WARNING + and *ERROR messages + - initialized all allocation size variables in + CalculiX.c + +16 Sept 2002 - started to code umat_elastic_fiber.f to model fiber + reinforced hyperelastic materials + +26 Sept 2002 - umat_elastic_fiber.f seems to work + +28 Sept 2002 - changed the names of the stress tensors + +1 Oct 2002 - started to code the energy calculation + +3 Oct 2002 - the energy calculation seems to work + - implemented the local orientation option in the + umat routine + +5 Oct 2002 - got rid of the environment variable; ccx is started + with -i flag for the input file (without .inp) + +9 Oct 2002 - started to change cascade: solving for the dependent + DOFs in the MPCs using SPOOLES + +29 Oct 2002 - finished C-version of cascade. The decascading is + performed by calling SPOOLES to solve the + nonsymmetric system of equations. + +3 Nov 2002 - execution of renumber.f is removed for SPOOLES + +4 Nov 2002 - started to treat nonlinear MPC's more generally: + variable number of MPC terms between iterations + must be taken into account + +8 Nov 2002 - corrected an error in cycsymmods.f + +16 Nov 2002 - started to work on STRAIGHT, PLANE and MEAN ROTATION + nonlinear MPCs + +21 Nov 2002 - started to work on plane strain, plane stress, + axisymmetric, shell and beam elements + +Dec 2002 - started to work on single crystal plasticity + +15 Jan 2003 - STRAIGHT, PLANE and MEAN ROTATION MPCs seem to work + +18 Jan 2003 - *AMPLITUDE can also be used for linear static + calculations + - linear MPCs can have more than 9 terms + +26 Jan 2003 - updating the User's Manual and the test example set + - finishing the tests on plane strain, plane stress, + axisymmetric, shell and beam elements + - the use of SPOOLES in cascade leads to significant + longer run times. Original method is restored and + translated into C. SPOOLES maybe useful for MPC's + with a large radius of influence such as + incompressibility. + - fixed the connection between solid elements and 1-D + or 2-D elements. + +8 Feb 2003 - the internal state variables can be stored in the + .dat and .frd file + - improved the boundary conditions for plane strain, + plane stress and axisymmetric elements. + +9 Feb 2003 - single crystal umat seems to work + (caveat: for ithermal=0 the field eth(1..6) is not + defined) + +13 Feb 2003 - corrected some mistakes in cycsymmods.f + +27 Feb 2003 - changed the meaning of OP=NEW + - changed the effect of output options in multi-step + analyses + +01 Mar 2003 - corrected an error in the energy calculation and + incremental plasticity: calculation of irreversible + quantities must start from the values at the start + of the increment and not rely on intermediate values + +04 Mar 2003 - solved the problem with beammr (definition of neq + in CalculiX.c for icascade!=0) + +02 Apr 2003 - started to work on wedges and 4-node tets + - corrected the implementation of the alpha method + (starting acceleration zero); convergence is + accelerated + +09 Apr 2003 - changed integration scheme for the mass matrix in + dynamic calculations with discontinuous forces + +10 Apr 2003 - simplified shape functions for 20-node hexa elements + +13 Apr 2003 - changed extrapolation coefficients for C3D20 + - replaced alp=.2215 by alp=.2917 for explicit dynamic + calculations with 20-node elements (e_c3d.f) + - important change in ikmpc and ikboun: 6 DOFs are + assigned to each node instead of 3 DOFs + +27 Apr 2003 - introduced for frequency calculations a stiffness + contribution due to centrifugal forces + +01 May 2003 - started working on stiffness contribution of + distributed surface loads + +06 May 2003 - stiffness contribution of distributed surface + loads seems to work + +10 May 2003 - introduced rotational DOFs for shells and beams + +26 May 2003 - added the parameter TIME=TOTAL TIME to the + *AMPLITUDE keyword card + +04 June 2003 - introduced bending moment and torque for 1d and 2d + structures + - allowed for seven DOFs in ikboun, ikforc and ikmpc: + DOF zero is reserved for the temperature + - tet4, wedge6 and wedge15 seem to work + +08 June 2003 - MPC's can contain rotational degrees of freedom now + +11 June 2003 - started to code thermal calculations + +14 June 2003 - changed the first dimension of v,vold,vini,veold, + accold,veini,accini,fn,nactdof,vt and fnt to four in + order to accommodate temperature and thermal flux + +23 June 2003 - introduced the logical parameters mass, stiffness, + buckling and rhs to decide which entities to build. + +25 June 2003 - changed xload(i) to xload(1..2,i), similarly for + nelemload and iamload to accommodate both convection/ + radiation coefficients and environmental temperatures + for heat transfer calculations + +17 Juli 2003 - started forced convection and cavity radiation + +31 Juli 2003 - introduced the keyword card *CONTROLS to control + convergence and allow for linear calculations with + 1d and 2d elements. + +2 Aug 2003 - allowed for linear calculations with 1-D and 2-D + elements (beams, shells..) by setting the + convergence criteria to 1.d+30. + +3 Aug 2003 - allowed for linearization of *MPC constraints and + *RIGID BODY constraints by adapting the convergence + criteria to 1.d+30. + +31 Aug 2003 - change integration point numbering for C3D15 + (conform to ABAQUS) + +5 Oct 2003 - reintroduced damping in direct dynamic calculations; + improves performance without deteriorating the + quality of the results + +7 Oct 2003 - started to work on a restart file + +29 Oct 2003 - corrected a bug in the calculation of the + distributed load stiffness + - finished the restart capability + +29 Nov 2003 - reorganization of the output in the .dat file: + output is grouped per set (node set/element set) + - implementation of whole element output: ELSE and + EVOL, TOTALS=YES and TOTALS=ONLY + +03 Dec 2003 - read and write files for a RESTART are now + different: extension .rin for RESTART,READ and + .rout for RESTART,WRITE + - there is no default any more for *EL FILE and + *NODE FILE + +09 Dec 2003 - corrected a mistake in restartshort.f + +23 Dec 2003 - finished the theory manual! + +26 Dec 2003 - maxlenmpc is stored in the restart file + - removed a possible division through zero in + arpackcs.c (cyclic symmetry) + +5 Jan 2004 - introduced a new field typeboun to classify the type + of boundary conditions. Only the BC's defined by + *BOUNDARY should be deleted for OP=NEW. + types: R=rigidbody, P=planempc, S=straightmpc + M=midplane, U=usermpc and B=boundary. + +6 Jan 2004 - prescribing the displacements of all DOFs is now + possible (neq=0) + +12 Jan 2004 - improved the convergence of STRAIGHT and PLANE MPC's + +14 Jan 2004 - changed the syntax of + *INITIAL CONDITIONS,TYPE=STRESS: the residual stress + tensor must be given in each integration point, + not just one tensor per element + - corrected an error in allocation.f + +19 Jan 2004 - made a correction for dynamic calculations in + allocation.f + - made a correction for restart calculations: + additional definitions of amplitudes and sets is + allowed. + +20 Jan 2004 - started to check thermal analysis + +21 Jan 2004 - made a correction in incplas.f for thermal + viscoplastic calculations (J_mech) + +24 Jan 2004 - corrected an error in cycsymmods.f + +26 Jan 2004 - coded the output of heat flux and heat generation + +2 Feb 2004 - introduced nenerold to take energy requests into + account in frequency steps with preload. + +22 Feb 2004 - started the user subroutines for heat flux, the film + coefficient and the emissivity + +24 Feb 2004 - the elastically anisotropic material model with von + Mises viscoplasticity is automatically selected as + soon as a *PLASTIC, *CYCLIC HARDENING or *CREEP card + is combined with a *ELASTIC,TYPE=ORTHO card. + +26 Feb 2004 - finished the user subroutines dflux.f, film.f, + radiate.f and dload.f + +28 Feb 2004 - introduced uniform and nonuniform body-generated + heat flux; seems to work. + +2 Mar 2004 - started changing the way the input is read: the + importance of the order of the cards is minimized + +8 Mar 2004 - made the step time and total time available in the + umat routines + +9 Mar 2004 - started to make changes to distinguish between the + mechanical and thermal part of the equation system + (e.g. neq is replace by neq[0] and neq[1]). This + is needed for instationary thermal calculations + +13 Mar 2004 - blank lines in the input file are disregarded + - new materials can be defined after a restart + - primary creep was included in the Norton creep law + (power of total time) + +17 Mar 2004 - started to work on reducing the effect of the order + of the keywords in the input deck + +22 Mar 2004 - changed the calculation of the strain in + perturbative frequency and buckling steps: the + strain is calculated about the deformed + configuration + +25 Mar 2004 - reduction of the effect of the order in the input + deck seems to work + +30 Mar 2004 - the input data for *FREQUENCY were changed: now, you + can restrict the eigenfrequencies to an interval by + specifying its lower and upper value. + +31 Mar 2004 - transient heat transfer calculations seem to work + +21 April 2004 - forced convection heat transfer works + +23 April 2004 - first calculations with cavity radiation + +22 May 2004 - first acoustic frequency calculations + - static step following heat transfer step works + +10 June 2004 - changed sideload from character*5 to character*20 + allows user-defined name for user-defined loading + +12 June 2004 - started changes to allow for modal dynamic calculations + of the standard wave equation (e.g. in acoustics, + shallow waves etc.) + +30 June 2004 - forces can be summed and the sum printed in the + .dat file (TOTALS=YES or TOTALS=ONLY) + - modal dynamics of phenomena governed by the + Helmholtz equations seems to work + +12 July 2004 - changed the * format in internal reads for integers + into '(i40)' + +22 July 2004 - included the changes by Manfred Spraul enabling + multithreading with SPOOLES + +3 Aug 2004 - made the SPOOLES call modular (in order to easily + include TAUCS and other solvers). + +8 Aug 2004 - changed the * format in internal reads for reals + into '(f40)' + - included options to call TAUCS and the SGIsolver + (at compile time with -DTAUCS and -DSGI) + +11 Aug 2004 - started to work on the storage of results in local + coordinates + +13 Aug 2004 - storing results in local coordinates works. + (GLOBAL=YES or GLOBAL=NO after the *EL PRINT, *EL FILE + *NODE PRINT and *NODE FILE keyword cards). + +4 Sept 2004 - the value of jout is kept across the increments + unless a new value is defined + +5 Sept 2004 - removed an error: xload was sorted, xloadold was not + now xloadold is sorted as well (routine isortiddc) + +8 Sept 2004 - coupled temperature-displacement calculations work + +14 Sept 2004 - started to code 6-noded triangular 2-d elements + (they are expanded to 15-node wedges) + - started to work on 1-D and 2-D elements for + thermal and thermomechanical calculations + +16 Sept 2004 - splitting of gen3delem.f in smaller subroutines started + +17 Sept 2004 - splitting of gen3delem.f finished + +6 Oct 2004 - 6-nodes 2-d elements work + - 1-d and 2-d elements for thermal calculations work + - started to work on axisymmetric elements for + cavity radiation + +7 Oct 2004 - cavity radiation for axisymmetric elements works + +10 Oct 2004 - in case of divergence the actual solution fields + and residual forces are stored in the frd file + +14 Oct 2004 - started an interface between the ABAQUS umat user + routine and CalculiX umat user routine. + +19 Oct 2004 - introduced mechanical strain to calculate the + energy density and for the ABAQUS umat user routine + +25 Oct 2004 - changed the syntax of *NODAL DAMPING to provide + compatibility with ABAQUS + - introduced the heat transfer elements DC3D4,DC3D6, + DC3D10,DC3D15 and DC3D20 for compatility with ABAQUS. + Internally, they are identical to C3D4, C3D6 etc. + +30 Oct 2004 - CalculiX checks length of set names, amplitude names.. + to verify whether they do not exceed 20 characters + +31 Oct 2004 - removed alph from linel: everything is based on + eth now (thermal strain) + +7 Nov 2004 - started to work on maximum distance MPC + +16 Nov 2004 - removed an error in mastruct.c (loop should start from + 0 instead of 1) + +18 Nov 2004 - introduced a field fmpc for the MPC force + +24 Nov 2004 - corrected an error in mastructcs.c (cf. 16 Nov). + +25 Nov 2004 - introduced a variable idiscon to mark a discontinuity; + if a discontinuity occurs the displacements at the + start of the next increment are not extrapolated + +28 Nov 2004 - introduced a new field irowsgi in routine sgi.c + +8 Dec 2004 - included tieset and ntie in the restart files + +11 Dec 2004 - started to code the gap MPC. + +21 Dec 2004 - corrected some small errors in dyna and dynsolv + +23 Dec 2004 - introduced sorted search for amplitudes (identamta.f) + +4 Jan 2005 - finalized the DIST and GAP MPC; made the GAP MPC + accessible through a GAPUNI element and *GAP card. + - adjusted the year in the copyright statement + +5 Jan 2005 - worked on dealing with ABAQUS umat routines for nonlinear + materials (umat_abaqusnl) + +22 Jan 2005 - started to implement the possibility to define several + volumetric forces within one structure + +2 Feb 2005 - removed an error in e_c3d.f (for lumping) + - allowed for smaller increments in dynamic explicit + calculations + - checked the size of force and displacement residuals + if too big, the increment size is reduced + +13 Feb 2005 - several volumetric forces within one structure work; + - generalized gravity works + +18 Feb 2005 - applied constraints to nodes on a cyclic symmetry + axis in static calculations + +26 Feb 2005 - material, orientation, amplitude and set names + are scheduled to be 80 characters long, textpart + is scheduled to be 132 characters long. + +2 Mar 2005 - finished extending names and textpart + +3 Mar 2005 - create user routines utemp and cflux; added field vold + in user routines dflux, film and radiate. + +12 Mar 2005 - introduced the parameter TIME DELAY to shift the time + within an amplitude + +29 Mar 2005 - started the inclusion of nonzero SPCs in modal dynamic + calculations (similar to *BASE MOTION in ABAQUS) + +2 Apr 2005 - changed dynsolv from FORTRAN to C + +17 Apr 2005 - inclusion of nonzero SPCs in modal dynamic calculations + works + +19 Apr 2005 - started to work on steady state dynamics (harmonic loading) + +3 May 2005 - steady state dynamics works (harmonic loading) + +10 May 2005 - started steady state dynamics for nonharmonic periodic + loading + +16 May 2005 - started *SENSITIVITY to determine eigenvalues of + geometrically slightly perturbed structures + +30 May 2005 - steady state dynamics for nonharmonic periodic loading + works + +22 Juni 2005 - started a more efficient storage of the boundary + stiffness coefficients (those stiffness coefficients + which correspond to SPC's; important for modal + dynamic calculations) + +29 Juni 2005 - changed application of force to axisymmetric elements: + now, the force is the one applied to the sector the angle + of which is defined on the *SOLID SECTION card, and not + the total force over 2*pi + - new storage works (fields neq and nzs have now a + length 3) + +5 July 2005 - created user subroutine massflowrate.f + +6 July 2005 - removed an error in CalculiX.c: if nam>0, iamload + must be sorted too in routine isortiddc. + +10 July 2005 - corrected an error in radflowload.f + - allowed for description in .frd file + +16 July 2005 - corrected an error in gen3dconnect.f + +23 July 2005 - simplified some code in results.f + - worked on 1d/2d output of 1d/2d elements + +26 July 2005 - worked on section forces + +30 July 2005 - 1d/2d output and section forces work + - for axisymmetric elements *CLOAD, *CFLUX and + *MASS FLOW RATE are to be defined for the complete + circumference + +31 July 2005 - for 1d/2d elements NLGEOM is selected automatically + +11 Aug 2005 - corrected an error in map3dto1d2d.f + +5 Sept 2005 - corrected an error in solidsections (axisymmetric + elements) + +7 Sept 2005 - changed nonlingeo, radflowload and results: now the + gas temperatures are taken into account in the + convergence check (cam) + +9 Sept 2005 - same issue is on Sept 7: if gas temperatures are + calculated the "displacement" convergence check is + mandatory, no matter the size of the residual forces + +13 Sept 2005 - removed sensitivity.c and sensitivities.f (did not + bring any gain). + +14 Sept 2005 - changed renumber.f such that gaps in the node numbering + do not increase the execution time + +21 Sept 2005 - inserted temporarily the Zienckiewicz-Zhu error + estimator + +23 Sept 2005 - finished the coding of the Zienckiewicz-Zhu error + estimator for C3D20R elements + +28 Sept 2005 - put part of nonlingeo.c into checkconvergence.c + +29 Sept 2005 - put part of nonlingeo.c into calcresidual.c + rename residual.f into storeresidual.f + +1 Oct 2005 - extrapolation of previous results as start values + for the next increment is not done at the start + of a new step, else it is always done (nonlingeo.c) + +2 Oct 2005 - introduced user routine sigini.f for the + specification of initial stress fields + +10 Oct 2005 - started a major revision of the fluid elements for + forced convection purposes: now + they consist of three nodes, in the end nodes the + temperature is unknown, in the middle node the mass + flow rate is to be given (DOF 1) with *BOUNDARY + - revision of the convection equations in radflowload.f + to reach agreement with QTRAN + +11 Oct 2005 - finished forced convection changes + +24 Oct 2005 - started the generation of cyclic symmetry conditions + for dissimilar meshes + +6 Nov 2005 - cyclic symmetry conditions for dissimilar meshes work + +14 Nov 2005 - corrected an error in mastructcs.c (element types + C3D4, C3D6 and C3D15 were not taken into account) + +16 Nov 2005 - got rid of the NORENUMBER option: not needed any more + +1 Dec 2005 - corrected an error in e_c3d.f and linel.f + (initial shear stresses) + +9 Dec 2005 - corrected an error in some umat routines: +beta + should be -beta + +12 Dec 2005 - started to work on modal dynamics and steady state + dynamics for cyclic symmetric structures + +22 Jan 2006 - adapted dyna.c (modal dynamics) for cyclic symmetry + calculations + +30 Jan 2006 - performed some changes to prepare for gas dynamics + calculations: instead of *SOLID SECTION, *GAS SECTION + should be used. + +9 Feb 2006 - corrected an error related to nam and nam_ in CalculiX.c + and calinput.f + +27 Feb 2006 - corrected an error in dyna.c and steadystate.c: t0, + t1old, t1 and iamt1 must be reallocated for cyclic + symmetric structures + +28 Feb 2006 - started the implementation of a thermal user material + +5 March 2006 - refined the cyclic symmetry conditions for + dissimilar meshes. + +6 March 2006 - starting a harmonized treatment of linear and + nonlinear materials. + +7 March 2006 - the profile solver is inactivated + +12 March 2006 - the harmonization of linear and nonlinear materials + is finished. + +17 March 2006 - allowing for more than one gravity load in an element + +26 March 2006 - heat conduction through the edges of a shell element + and the face of a plane stress element is possible + +2 April 2006 - started the extension of the forced convection + formulation into an aerodynamic network: + implementation of the orifice element + +14 April 2006 - introduced a Laplace-type method to find initial + pressures in an aerodynamic network + +20 April 2006 - started coding liquid networks + +23 April 2006 - calculations with liquid networks work + +9 May 2006 - allowed for imaginary gravity and centrifugal + loading (for steady state dynamics) + +12 May 2006 - speeded up all *ident*f files + +25 May 2006 - completed the discharge coefficient files for the + orifice, bleed tapping and preswirl nozzle + +30 May 2006 - change in tempload: gas nodes do not move during + the calculation + +3 June 2006 - started to code contact conditions + +21 June 2006 - corrected an error in mafillsm.f and + materialdata_th.f + +11 Juli 2006 - CYCLIC SYMMETRY and TYPE=NODE are required parameters + for the *TIE card and the *SURFACE card, respectively + +26 Juli 2006 - small corrections in radmatrix + - nodes with prescribed boundary conditions but not + belonging to elements are also stored in the frd file + +30 Juli 2006 - implemented time points at which output can be + requested + +7 Sept 2006 - one .onf file instead of several + - changed the order of the Gauss points for 4-node + integration of faces of hexahedral elements + +11 Sept 2006 - speeded up cyclic symmetric thermal calculations + (took the symmetry of the integration points into + account in subroutine e_c3d_th.f) + +27 Sept 2006 - changed spooles.c to accommodate for nonsymmetric + systems of equations + +28 Sept 2006 - switched to spooles for the solution of the + nonsymmetric fluid network equation sets. + +7 Oct 2006 - switched back to dgesv (spooles is slower for small + systems) + - accelerated e_c3d_th.f + +9 Oct 2006 - incorporated some slight accelerations in e_c3d_th.f + +14 Oct 2006 - introduced a shape function routine specifically + for axisymmetric elements + +15 Oct 2006 - corrected an error in rubber.f + +16 Oct 2006 - accelerated axisymmetric calculations in results.f + +17 Oct 2006 - accelerated gen3dfrom2d.f + - contact with one element works + +2 Nov 2006 - introduced the parameter CAVITY on the *RADIATE + card + +6 Nov 2006 - accelerated axisymmetric calculations in mafillgas.f + and resultgas.f + - got rid of a segmentation fault in nonlingeo.c + +7 Nov 2006 - corrected a typing mistake for axisymmetric elements + in results.f + +14 Nov 2006 - changed the angle for axisymmetric elements to 2 + degrees + +17 Nov 2006 - improved the connection with the user routine radiate + in radmatrix.f + +23 Nov 2006 - changed the argument list of attach.f + +25 Nov 2006 - changed 4-node contact elements into 4 to 9-node ones + +3 Dec 2006 - change did not improve convergence: 23 Nov state + reinstalled + - included the gas pipe element and a new convergence + strategy for fluids + +10 Dec 2006 - introduced *SURFACE INTERACTION and *SURFACE BEHAVIOR + +13 Dec 2006 - changed contact force into contact pressure (alpha is + multiplied with the area of the triangle) + +17 Dec 2006 - allowed for user-defined viewfactor inputdeck name + - use of shape20h_pl for plane stress and plane strain + elements + - extension for viewfactor file is .vwf + +18 Dec 2006 - only nonzero viewfactors are stored + - error estimator (Sascha Merz) included + - sorting of nelemload includes face number + +21 Dec 2006 - corrected an error in radflowload.c and nonlingeo.c + +22 Dec 2006 - made some changes in gen3dnor.f + +26 Dec 2006 - accelerated plane stress/strain and axisymmetric + calculations in e_c3d.f + +6 Jan 2007 - changed contact stiffness matrix slightly + +7 Jan 2007 - changed 4-node contact elements into 5 to 9-node ones: + second try (consistent stiffness matrix). + +9 Jan 2007 - 5 to 9-node contact elements seem to work. + +14 Jan 2007 - adapted surfaces.f in order to cover beam, shell and + 2-D elements + +15 Jan 2007 - corrected an error in e_c3d.f + +16 Jan 2007 - corrected an error in gaspipe.f + +20 Jan 2007 - started some changes to take 2D contact into account + (file gen3dsurf.f) + +23 Jan 2007 - corrected a mistake in the restart file + - treated Norton in the same way as the creep routine + (incplas.f) + +31 Jan 2007 - frequency calculations for 1D and 2D elements seem to + work. + +9 Feb 2007 - made a small change in frdcyc.c + +22 Feb 2007 - corrected an error in mafillsm.f + +25 Feb 2007 - made a change in map3dto1d2d.f, arpack.c and arpackcs.c + (rotational speed needed for stiffness matrix in + frequency calculations) + +4 Mar 2007 - introducted restrictor elements in the gas network + +6 Mar 2007 - made a change in arpack.c to allow for frequency + calculations after plastic calculations + - changes in the restrictor element files + +11 Mar 2007 - removed error occurring for empty node or element sets + +20 Mar 2007 - added parameter ADD to *CFLUX card + +22 Mar 2007 - updated umat_aniso_creep.f + +24 Mar 2007 - corrected an error in linear 1d/2d calculations: + created file fillrigidmpc.f + +26 Mar 2007 - removed vjj from subroutine incplas; modified the + influence of the thermal strain + +3 April 2007 - modified umat_aniso_creep.f + +16 April 2007 - replaced the rigid body formulation by a knot + formulation for 1d/2d elements: allows expansion + +19 April 2007 - corrected an error in allocation.f + +20 April 2007 - changed the size of field inpc to (long long) in order + to be able to read larger input files + +21 April 2007 - allowed for initial plastic strains + +24 April 2007 - made a correction in readinput.c + +30 April 2007 - started to make corrections for consecutive thermal + and mechanical calculations (especially for 1d/2d + elements) + +2 May 2007 - inclusion of branch fluid elements (start) + +4 May 2007 - made a correction in gen3dboun.f + +15 May 2007 - reduced the storage needs for the input deck: + introduced field ipoinpc to take variable length + lines into account + +20 May 2007 - updated the documention for fluid elements + of type branch + +21 May 2007 - allowed for linear rigid body calculations + +23 May 2007 - modified ithermal into a field to treat the BC's + for plane stress, plane strain and axisymmetric + elements in mixed *STATIC and *HEAT TRANSFER + calculations. + +28 May 2007 - created fully liquid-structure coupling for a one- + dimensional flow in a flexible tube + +30 May 2007 - simplified materialdata_me.f + +3 June 2007 - started to split overall check of mechanical + and thermal convergence: qa,cam.. vectors of + length 2 instead of scalars + +5 June 2007 - corrected an error in couptempdisps.f + +7 June 2007 - simplified initialaccel.c + +9 June 2007 - simplified mafillsm.f + +16 June 2007 - transformed the logical mass into a vector: index 0 + for mechanical calculations, index 1 for thermal + calculations + +20 June 2007 - started to implement spring elements + +27 June 2007 - linear and nonlinear springs seem to work + +7 July 2007 - started to code dashpots for linear dynamic calculations + +10 July 2007 - corrected a couple of small errors in gen3dnor.f. + +26 July 2007 - tried different differential equation solvers for + damped linear dynamics (dderkf, ddeabm and ddebdf) + +30 July 2007 - dashpots in combination with steady state dynamics + works + +6 Aug 2007 - new fluid elements: free and forced vortex, absolute- + to-relative elements and vice-versa, Moehring elements + +10 Sep 2007 - closed the .inp, .dat and .sta file properly at the + end of the calculation + +11 Sep 2007 - changed ithermal into ithermal(2) in file gen3dnor.f + +16 Sep 2007 - introduced an error message in gen3dboun and gen3dforc + to cover the situation in which rotational loadings + or constrains are applied to a node in any but the + first step + +24 Sep 2007 - made a change in results.f (treatment of MPC's) + +25 Sep 2007 - made a change to nonlingeo.c and prediction.c: + mechanical results were not correctly saved during + a heat transfer step. + +30 Sep 2007 - resolved the problem from 16 Sep 2007: definition of + rotational BC's and moments in any but the first step + is now OK. + +2 Oct 2007 - small corrections to creeps.f, plastics.f, gen3dboun.f, + gen3dforc.f and checkconvergence.c + +6 Oct 2007 - made a change in steadystate.c: for cyclic symmetry + only ngraph sectors are stored + - allowed for a user-defined amplitude definition + +10 Oct 2007 - continued to work on frequency-dependent dashpot + constants + +15 Oct 2007 - correction in the expansion of MPC's in expand.c + +16 Oct 2007 - replaced umat_aniso_creep.f and expand.c + for an anisotropic creep subroutine the creep + strain goes in and the stress comes out + +20 Oct 2007 - started to implement an uncoupled + temperature-displacement procedure + +25 Oct 2007 - changed the way the imaginary part of cloads and + dloads is stored + +7 Nov 2007 - improvements in frd output in case of divergence + - linear application of user defined loads for + static calculations + +14 Nov 2007 - included participation factors for steady state + dynamics calculations in the .dat file + +19 Nov 2007 - modified dyna.c in order to take contact + into account + +21 Nov 2007 - added the variable OUTPUT to *VIEWFACTOR,WRITE. + - P*NP can be used for *STATIC calculations as well + +01 Dec 2007 - started to combine contact with modal dynamic + calculations + +15 Dec 2007 - removed an error in rhs.f and mafillsm.f: force on + dependent node in MPC is redistributed among the + independent nodes + +18 Dec 2007 - thickness of plane strain elements is reduced if + there are axisymmetric elements in the model + +20 Dec 2007 - corrected an error in tempload + +9 Jan 2008 - started the implementation of computational fluid + dynamics + +10 Jan 2008 - changed the format for elements in the .dat file to + allow for element numbers exceeding 99999 + - implemented engineering constants for orthotropic + elastic materials + +14 Jan 2008 - made a change in gen3dnor.f + +22 Jan 2008 - worked on the implementation of isochoric elements + (C3D20RH; was started years ago) + +23 Jan 2008 - made a correction in nonlingeo.c, mafillgas.f and + resultgas.f + +30 Jan 2008 - corrected the node order of 3-node elements in frd.f + - replaced f20.10 by f20.0 in buckles.f, frequencies.f + and heattransfers.f + +02 Feb 2008 - finished a preliminary version of cfd (coding only); + +05 Feb 2008 - continued work on rotational rigid body motion with + linear dynamics + - continued work on incompressible elements + +09 Feb 2008 - expanded v,vold,vini,vr,vi and vt to contain 5 + entries for the variables (one extra space for + static pressure) + +10 Feb 2008 - checking expansion; nearly OK, only segststate + still deviates + +11 Feb 2008 - expansion to 5 entries works + +12 Feb 2008 - the calculation of idof is changed to allow for 8 dofs: + temperature, 3 displacements or velocities, static + pressure, 3 angles or rotation (instead of 7: static + pressure is new) + - changed the internal dofs for rotations to 5,6 and 7. + dof 4 is for static pressure. The external dofs for + rotations remain 4,5 and 6, for static pressure it is 8. + For temperature the internal dof is 0, the external + dof is 11. + +16 Feb 2008 - calculated a default position tolerance in case none is + given by the user. + +17 Feb 2008 - removed an error in calinput.f and near2d.f + - continued checking of precfd.f + +21 Feb 2008 - removed an error in arpackcs.c + +24 Feb 2008 - debugged initialcfd.f + +1 Mar 2008 - started adaptive increment size in modal dynamic + calculations. + +4 Mar 2008 - modal dynamics with adaptive increment size seems to + run + +5 Mar 2008 - corrected an error in dyna.c + +11 Mar 2008 - corrected an error in selcycsymmods.f and mpcrem.f + - in modal dynamics and steady state dynamics calulations + any previous loading is removed + +12 Mar 2008 - isochoric elements seem to work + - .sta file is written for modal dynamics calculations + too + +21 Mar 2008 - included code for multistage MPC's + - continued computational fluid dynamics + +27 Mar 2008 - made some changes to multistages.f + - modified the header of user subroutine dflux.f + +31 Mar 2008 - continued debugging of 3D fluid dynamics + +3 April 2008 - modifications to dyna.c + +10 April 2008 - started an update of the gas network elements + +15 April 2008 - continued update of gas network elements + +19 April 2008 - finished update of gas network elements + - extended output for cyclic frequency calculations + (PHS,MAXU,MAXS) + +23 April 2008 - made some quality improvements in incplas.f + +28 April 2008 - continued computational fluid dynamics + ordered nelemface + - corrected an error in mafilltrhs.f + +29 April 2008 - update of dyna.c + +7 May 2008 - introduced contact damping and friction for + modal dynamic calculations + +15 May 2008 - different meaning of MAXU and MAXS in arpackcs.c + - correction in steadystate.c + +27 May 2008 - changed the order of the integration points in + gauss3d6 + +31 May 2008 - coded a linearized version of the mean rotation MPC + +3 June 2008 - implemented pre-tension section to simulate + pre-tension in bolts (3D only). + +5 June 2008 - connected the linear equations solvers to compfluid.c + for liquids (pressure equation) + - improved error message for zero columns in the + stiffness matrix + +12 June 2008 - started to work on the improvement of the viewfactor + calculations + +18 June 2008 - corrections in expand.c and pretensionsections.c + +21 June 2008 - corrected an error in expand.c + - introduced the FIXED parameter on the *BOUNDARY card + +23 June 2008 - changed 1.d-10 to 1.d-5 as smallest allowable + coefficient in a MPC + +28 June 2008 - implemented STEADY STATE calculations for the + linear dynamics procedure + +1 July 2008 - coded an update of CYCLIC MPC's for nonlinear + calculations (nonlinmpc) + +3 July 2008 - corrected an error in envtemp.f + +6 July 2008 - made some changes in compfluid.c: stable time increment + is calculated in each iteration anew + +9 July 2008 - continued fluid dynamics: change of boundary conditions + has to be limited to guarantee stability. + +13 July 2008 - improved the time increment management for + computational fluid dynamics + +19 July 2008 - set the mechanical strain to zero at the end of a + frequency step + - started changes in the contact formulation: 1. adjust + in the first iteration of the first increment of the + first step; 2. zero force for too large distances + 3. contact area division number + +30 July 2008 - made a change to surfaces.f + +8 August 2008 - corrected an error in printoutint.f + +4 Sept 2008 - coded 2nd order derivatives in shape3tri,shape6tri, + shape4q and shape8q + +9 Sept 2008 - supplemented subroutine springstiff with the derivatives + of xi and eta; contact convergence should improve + - corrected errors in nonlinmpc (CYCLIC) and bounadd + +14 Sept 2008 - made corrections in radiates.f, incplas.f and + usermaterials.f + +20 Sept 2008 - introduced CE for the equivalent creep strain + for anisotropic materials + +24 Sept 2008 - changed to another viewfactor calculation + - minor changes in radmatrix, e_c3d_th and cascade + +11 Oct 2008 - change of extrapolation of the mass flow to the + end nodes (fluidextrapolate.f) + - correction in umat_abaqus.f and umat_abaqusnl.f + - correction for section forces in map3dto1d2d.f + +13 Oct 2008 - the FREQUENCY and TIME POINTS parameters are + mutually exclusive for data storage keyword cards. + +28 Oct 2008 - modified the calculation of section forces to + accommodate for large deformations + +7 Nov 2008 - modified the output format for SDV in the .dat + and .frd file + +9 Nov 2008 - no correction of dependent node for nonmatching + cyclic symmetry conditions + - cyclic conditions are considered to be linear + (no update due to large deformation) + - changed interface for umatht and dload (for + lubrication problems) + +13 Nov 2008 - wrote user routines for coupled mechanical- + lubrication problems + +15 Nov 2008 - made a change in springstiff: consistent tangent + matrix was not correct + +17 Nov 2008 - started to change dyna to take contact into account + +30 Nov 2008 - driven lid cavity (incompressibile fluid dynamics) + works! + - started the implementation of additional MPC's for + middle nodes belonging to dependent contact + surfaces + +7 Dec 2008 - additional MPC's for 3D and 2D elements seem to work + +10 Dec 2008 - changed PE into PEEQ and CE into CEEQ (print requests + or frd requests for the equivalent plastic/creep + strain) + - created printing output (.dat file) for gas networks: + static pressure (PS), total pressure (PT) and + mass flow (MF) + +11 Dec 2008 - created printing output (.dat file) for 3D fluid flow: + velocities (V) and static pressure (PT) + +15 Dec 2008 - no motion of dependent variables in cyclic + symmetric calculations (generatecycmpcs.f) + +16 Dec 2008 - the triangulation file for cyclic symmetry conditions + with dissimilar meshes takes the job name and + ending .tri + +18 Dec 2008 - corrected an error in shape8q (calculation of xsi) and + all other 2D shape functions + +24 Jan 2009 - got to work airfoil with near zero viscosity and zero + wall conditions (compressible fluid); smoothing is + not exactly the same as in Nithiarasu's program; + +25 Jan 2009 - got to work airfoil with Euler conditions (MPC's for + fluids) + +2 Feb 2009 - corrected an error in gen3dnor.f + +4 Feb 2009 - Zienkiewicz-Zhu error estimator now also works for + frequency, buckling, modal dynamics and steady + state dynamics calculations (stx instead of sti in + the call of out.f) + +7 Feb 2009 - coded shock viscosity smoothing + - included PARDISO as solver + +10 Feb 2009 - corrected an error in remastruct: mass[0]=1 + +21 Feb 2009 - wrote a routine to calculate the lift and drag force + +5 Mar 2009 - calculation of the velocity through derivation + in dyna and dynacont + - replaced logical by integer in fluid calculations + +7 Mar 2009 - worked on turbulence (SST model) + +8 Mar 2009 - started work on pre-tension for 2D elements + +10 Mar 2009 - finished pre-tension for 2D elements + +19 Mar 2009 - introduced the variable pnewdt in umat_user.f + +21 Mar 2009 - coded direct modal damping + +22 Mar 2009 - continued to work on 3Dfluids and cyclic MPC's + +4 April 2009 - provided for BX, BY and BZ as volumetric loading + including nonuniform loading (BXNU...) + - included the velocity in the subroutine parameters + of dload.f + +10 April 2009 - started acceleration of dyna + +19 April 2009 - added some parameters to user routine dload + +21 April 2009 - coded direct damping for steady state dynamics + +22 April 2009 - PU and PHS are calculated for all sectors + requested + +26 April 2009 - corrected an error in incplas.f (residual stress) + +2 May 2009 - started tied contact + +10 May 2009 - tied contact works + - corrected an error in e_c3d_trhs.f + +19 May 2009 - started Mortar contact + +15 June 2009 - allowed for local coordinate systems for + fluid output + +20 June 2009 - changed the calculation of rf for nodes belonging + to MPC's and 1-d or 2-d elements + - made an update for gas networks (not finished) + - started debugging turbulence + +23 June 2009 - made a correction in results.f and pretensionsections.f + +26 June 2009 - added the cylic symmetry axis to the displacement + headers in the frd file + +27 June 2009 - provided two entries in field iperturb in order to + distinguish between material and geometrical + nonlinearities; nlgeom not automatically active for + *DYNAMIC and *COMBINED TEMPERATURE-DISPLACEMENT + procedures + +28 June 2009 - started the multithreading version of compfluid + +8 July 2009 - update of mortar contact + +10 July 2009 - removed an error in radmatrix.f + - updated modal dynamic and contact + +23 July 2009 - accelerated the execution of dynacont and dfdbj + +25 July 2009 - change in nonlingeo: ielas=1 is only active in the first + iteration of the first increment if ilin=1 AND if the + step is not dynamic + +3 August 2009 - some small changes to Mortar contact + +5 August 2009 - added istep and iinc to the ABAQUS umat files + - user material does not automatically imply geometric + nonlinearity + +11 August 2009 - checked for SPC's in contact middle slave nodes in + routine gencontmpc.c + +20 Sept 2009 - updated Mortar contact + +21 Sept 2009 - made a correction in frequencies.f, buckles.f, + modaldynamics.f and steadystatedynamics.f + +3 Oct 2009 - accounted for 'NLGEOM=NO' for ABAQUS compatibility + - made some corrections in dynacont.c + +11 Oct 2009 - allowed for a selection of nodes for modal dynamics + calculations in order to speed up the calculations + +12 Oct 2009 - started to change mint_ into mi(2) in order to store + the maximum number of dofs per node + +13 Oct 2009 - continued (not finished yet) + +24 Oct 2009 - changed nactdof(1:3,*) into nactdof(1:mi(2),*) + +25 Oct 2009 - introduced the parameter TIME RESET on the *STATIC and + *HEAT TRANSFER keyword card + +26 Oct 2009 - in nonlinear calculations the nodes are listed where the + residual forces and variable changes are maximum + +28 Oct 2009 - corrected an error in springstiff.f + - inverted the order of working through the amplitudes: + last comes first (a redefined amplitude overrules + the earlier definitions) + +31 Oct 2009 - ran valgrind and started removing complaints by + valgrind + +1 Nov 2009 - started to use mi(2) for defining the size of field + v, vold... -> smaller fields for thermal and + mechanical calculations + +4 Nov 2009 - mi(2) works for values >= 3. + - started introducing sets to limit output to the + frd file + +10 Nov 2009 - output to the frd file can be limited to a node set + +14 Nov 2009 - made substantial changes in dyna.c and dynacont.c + to speed up modal dynamic contact calculations + +15 Nov 2009 - xl2 and similar fields start now from 1, not 0. + +22 Nov 2009 - made substantial changes in dyna.c and subprograms + to speed up execution (force CHANGES are calculated) + +28 Nov 2009 - major speed up changes for modal dynamics finished + +12 Dec 2009 - continued speed optimization of modal dynamics + calculations + +15 Dec 2009 - implemented local system output for tensors in + frdtensor.f + +9 Jan 2010 - started coding liquid channels as 1-D networks + +12 Jan 2010 - von Karman vortex street about a cylinder works + +17 Jan 2010 - coded linear pressure-overclosure + +23 Jan 2010 - changed once again output for MAXS in arpackcs + (quousque tandem abutere......) + - worked on friction in modal dynamics + contact + - started coding a different shock capturing + procedure + +25 Jan 2010 - made some changes in e_c3d_th.f (no displacement + information available for purely thermal calculations) + +31 Jan 2010 - expanded restrictors and branches to liquid + applications (1D networks). + +4 Feb 2010 - changed the way in which, for a given slave node, the + corresponding master triangle is found for spring contact + purposes + +14 Feb 2010 - made a change in results.f + +21 Feb 2010 - for contact springs the pressure should be multiplied by + the slave area; this major change was started today. + +25 Feb 2010 - changed the proximity check in linkdissimilar.f + +7 Mar 2010 - made corrections for ZZS output and ngraph>1 + - coded slave area calculations for 2D contact applications + +13 Mar 2010 - coded the parameter ADJUST on the *CONTACT PAIR card + - got rid of IN-FACE SLIDING + +15 Mar 2010 - introduced local time stepping for steady state CFD + - cleaned up e_c3d_[v1,p,v2,t]rhs.f + - previous stable cfd version: 13 Mar 2010 + +22 Mar 2010 - nodes with largest displacements etc. in 2d structures + are the original node numbers now, not the expanded + numbers + +26 Mar 2010 - corrected bodyforce.f + - defined the size of xstiff in dyna.c and steadystate.c + as (long long) + - corrected an error in frdvector.f + +28 Mar 2010 - local time stepping in steady state CFD calculations seems + to work + +30 Mar 2010 - made some changes in preparation for the Bishop 4-node + shell element + +11 Apr 2010 - changed the dimension of field IL and IU in all sort + routines from 21 to 31. + - started to code friction for static contact calculations + (penalty) + +18 Apr 2010 - changed the definition of c0 for linear contact springs in + gencontelem.f + - changed the search for corresponding master triangles + in gentiedmpc to kneigh=1 and neighbor search + +19 Apr 2010 - plane stress, plane strain and axisymmetric elements + should be defined in the z=0 plane. This is now checked + in gen3delem.f + +20 Apr 2010 - started to compare frd files for selected test examples + (in addition to dat files) + +25 Apr 2010 - changed fields for networks in order to allow for + geometric data as unknowns + - default for *EL FILE is GLOBAL=YES + +1 May 2010 - for a gate valve the extent of closure can be solved for: + example for geometric unknowns in networks + +17 May 2010 - worked on liquid channels + - corrected an error in allocation.f + +20 May 2010 - made a correct in dyna.c (in case a dload subroutine has + been defined) + +27 May 2010 - improved the linear contact spring relationship + - worked on liquid channels + +9 June 2010 - modified the linear contact spring relationship slightly + +14 June 2010 - started debugging backwater calculations + +16 June 2010 - change the convergence rules for changing numbers of + contact spring elements (LARGE SLIDING) + +30 June 2010 - simple backwater calculations work (sluice gate/reservoir) + +12 July 2010 - weir calculations work + +5 Aug 2010 - made some small corrections + +5 Sep 2010 - 2d results are calculated in each iteration so that they + are available in the user subroutines + +9 Sep 2010 - added a user subroutine for concentrated loads + +10 Sep 2010 - worked on gap conductance + +11 Sep 2010 - corrected an error in frdcyc (output of CONT) + +13 Sep 2010 - included the C3D8I and C3D8R formulation coded by + otto bernhardi + +16 Sep 2010 - gap conductance works (heat transfer through mechanical + contact) + +23 Sep 2010 - coded an acoustic material (pressure only) + - coded Coulomb friction for penalty contact + +6 Oct 2010 - changed MPC's for nodal forces on shells in + gen3dforc.f + +9 Oct 2010 - worked on contraction, enlargement, drop and step + for liquid channels + +12 Oct 2010 - contraction, enlargement, drop and step for liquid + channels seem to work + +20 Oct 2010 - corrected an error in dyna.c and steadystate.c + +23 Oct 2010 - changed dyna for cyclic symmetry: only the part of the + eigenvectors which is needed is expanded. + +31 Oct 2010 - implemented a slightly different scheme for compressible + CFD-calculations + +5 Nov 2010 - original CFD-scheme proved to be superior + +7 Nov 2010 - started to work on the acceleration of steadystate + +12 Nov 2010 - finished acceleration of dyna and steadystate + +15 Nov 2010 - accelerated expand.c + - extended the arguments of cload.f + - coded MAXE as output variable (for frequency + calculations with cyclic symmetry) + +20 Nov 2010 - started acceleration of CFD-code + +21 Nov 2010 - corrected small errors in dyna.c, dynacontc. and dfdbj.c + +13 Dec 2010 - tried another variant of shock smoothing (exact + simulation of the second order derivative ) + +1 Jan 2011 - calculating presgradient after applying the pressure + boundary conditions + +3 Jan 2011 - calculating the pressure switch as a truely second + derivative (normed such that max in field is 1) + +5 Jan 2011 - removed shocksmoothing based on local von Mises stress + +20 Jan 2011 - introduced basic smoothing of 0.1 for Euler calculations + - included Couette and Poiseuille examples + +6 Feb 2011 - changed applybounp.f (MPC's) + +9 Feb 2011 - started to work on MPC's for networks + +12 Feb 2011 - MPC's for networks work + +15 Feb 2011 - updated fridaforc.f + - added nonhomogeneous terms to network MPC's + +28 Feb 2011 - modified results (network output) + +2 Mar 2011 - started changes for contact: + - proportional reduction of penetration for + overclosures + - change friction (*CHANGE FRICTION) + - model change for contact pairs (*MODEL CHANGE) + +8 Mar 2011 - improved *PRETENSION-SECTION + - *FRICTION CHANGE works + - *CHANGE MODEL works + - proportional reduction of penetration for + overclosures works + +9 Mar 2011 - corrected an error in pretensionsections.f and all + restart routines (restartread.f, restartwrite.f and + skip.f) + +14 Mar 2011 - ordered nelemload as soon as loading is being read + from file + +15 Mar 2011 - the radiation matrix is recalculated only if the + emissivity or the viewfactors changed + +24 Mar 2011 - corrected an error in radmatrix.f + diff -Nru calculix-ccx-2.1/ccx_2.3/src/lump.f calculix-ccx-2.3/ccx_2.3/src/lump.f --- calculix-ccx-2.1/ccx_2.3/src/lump.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/lump.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,52 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine lump(adb,aub,adl,irow,jq,neq) +! +! lumping the matrix stored in adb,aub and storing the result +! in adl +! + implicit none +! + integer irow(*),jq(*),neq,i,j,k +! + real*8 adb(*),aub(*),adl(*) +! + do i=1,neq + adl(i)=adb(i) + enddo +! + do j=1,neq + do k=jq(j),jq(j+1)-1 + i=irow(k) + adl(i)=adl(i)+aub(k) + adl(j)=adl(j)+aub(k) + enddo + enddo +! +! change of meaning of adb and adl +! first adb is replaced by adb-adl +! then, adl is replaced by 1./adl +! + do i=1,neq + adb(i)=adb(i)-adl(i) + adl(i)=1.d0/adl(i) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafill1lhs.f calculix-ccx-2.3/ccx_2.3/src/mafill1lhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafill1lhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafill1lhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,227 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafill1lhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, + & nactdoh,icolt,jqt,irowt,neqt,nzlt, + & ikmpc,ilmpc,ikboun,ilboun,nzst,adbt,aubt,ipvar,var) +! +! filling the stiffness matrix in spare matrix format (sm) +! + implicit none +! + character*8 lakon(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & icolt(*),jqt(*),ikmpc(*),nzst,nmethod,ipvar(*), + & ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20),irowt(*), + & ipkon(*),nk,ne,nboun,nmpc,neqt,nzlt,i,j,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,node1,node2, + & indexe,nope,i0 +! + real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbt(*),aubt(*), + & var(*),value +! + i0=0 +! +! determining nzlt +! + nzlt=0 + do i=neqt,1,-1 + if(icolt(i).gt.0) then + nzlt=i + exit + endif + enddo +! + do i=1,neqt + adbt(i)=0.d0 + enddo + do i=1,nzst + aubt(i)=0.d0 + enddo +! +! loop over all elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + call e_c3d_1lhs(co,nk,konl,lakon(i),sm,i,ipvar,var) +! + do jj=1,nope +! + node1=kon(indexe+jj) + jdof1=nactdoh(0,node1) +! + do ll=jj,nope +! + node2=kon(indexe+ll) + jdof2=nactdoh(0,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call add_sm_fl(aubt,adbt,jqt,irowt,jdof1,jdof2, + & sm(jj,ll),jj,ll) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8 + else + idof1=jdof1 + idof2=(node2-1)*8 + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdoh(nodempc(2,index),nodempc(1,index)) + if(idof2.ne.0) then + value=-coefmpc(index)*sm(jj,ll)/ + & coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubt,adbt,jqt,irowt, + & idof1,idof2,value,i0,i0) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif + else + idof1=(node1-1)*8 + idof2=(node2-1)*8 + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdoh(nodempc(2,index1), + & nodempc(1,index1)) + index2=index1 + do + idof2=nactdoh(nodempc(2,index2), + & nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + call add_sm_fl(aubt,adbt,jqt, + & irowt,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdoh(nodempc(2,index1), + & nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdoh(nodempc(2,index2), + & nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubt,adbt,jqt, + & irowt,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafill3lhs.f calculix-ccx-2.3/ccx_2.3/src/mafill3lhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafill3lhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafill3lhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,245 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafill3lhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, + & nactdoh,icolv,jqv,irowv,neqv,nzlv, + & ikmpc,ilmpc,ikboun,ilboun,nzsv,adbv,aubv,ipvar,var) +! +! filling the stiffness matrix in spare matrix format (sm) +! + implicit none +! + character*8 lakon(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & icolv(*),jqv(*),ikmpc(*),nzsv,nmethod, + & ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20),irowv(*), + & ipkon(*),ipvar(*) +! + integer nk,ne,nboun,nmpc,neqv,nzlv,i,j,k,l,m,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,node1,node2, + & indexe,nope,i0 +! + real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbv(*),aubv(*), + & var(*) +! + real*8 value +! +c write(*,*) 'print nactdoh' +c do i=1,nk +c write(*,*) i,(nactdoh(j,i),j=0,4) +c enddo +! + i0=0 +! +! determining nzlv +! + nzlv=0 + do i=neqv,1,-1 + if(icolv(i).gt.0) then + nzlv=i + exit + endif + enddo +! + do i=1,neqv + adbv(i)=0.d0 + enddo + do i=1,nzsv + aubv(i)=0.d0 + enddo +! +! loop over all fluid elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + call e_c3d_3lhs(co,nk,konl,lakon(i),sm,i,ipvar,var) +! + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdoh(k,node1) +! + do ll=jj,3*nope +! + l=(ll-1)/3+1 + m=ll-3*(l-1) +! + node2=kon(indexe+l) + jdof2=nactdoh(m,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call add_sm_fl(aubv,adbv,jqv,irowv,jdof1,jdof2, + & sm(jj,ll),jj,ll) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8+k + else + idof1=jdof1 + idof2=(node2-1)*8+m + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdoh(nodempc(2,index),nodempc(1,index)) + if(idof2.ne.0) then + value=-coefmpc(index)*sm(jj,ll)/ + & coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubv,adbv,jqv,irowv, + & idof1,idof2,value,i0,i0) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif + else + idof1=(node1-1)*8+k + idof2=(node2-1)*8+m + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdoh(nodempc(2,index1), + & nodempc(1,index1)) + index2=index1 + do + idof2=nactdoh(nodempc(2,index2), + & nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + call add_sm_fl(aubv,adbv,jqv, + & irowv,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdoh(nodempc(2,index1), + & nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdoh(nodempc(2,index2), + & nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubv,adbv,jqv, + & irowv,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo + enddo + enddo +! +c do i=1,neqv +c write(*,*) 'mafill3lhs ',i,adbv(i) +c enddo + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafilldm.f calculix-ccx-2.3/ccx_2.3/src/mafilldm.f --- calculix-ccx-2.1/ccx_2.3/src/mafilldm.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafilldm.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,264 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafilldm(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun, + & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + & ad,au,nactdof,icol,jq,irow,neq,nzl,nmethod, + & ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon, + & nrhcon,alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + & t0,t1,ithermal,prestr, + & iprestr,vold,iperturb,sti,nzs,stx,adb,aub,iexpl,plicon, + & nplicon,plkcon,nplkcon,xstiff,npmat_,dtime, + & matname,mi,ncmat_,ttime,time,istep,iinc,ibody) +! +! filling the damping matrix in spare matrix format (sm) +! + implicit none +! + character*8 lakon(*) + character*20 sideload(*) + character*80 matname(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & nodeforc(2,*),ndirforc(*),nelemload(2,*),icol(*),jq(*),ikmpc(*), + & ilmpc(*),ikboun(*),ilboun(*),mi(2),nactdof(0:mi(2),*),konl(20), + & irow(*), + & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), + & ipkon(*),ipobody(2,*),nbody, + & ibody(3,*) +! + integer nk,ne,nboun,nmpc,nforc,nload,neq(2),nzl,nmethod,icolumn, + & ithermal,iprestr,iperturb,nzs(3),i,j,k,l,m,idist,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,node1,node2, + & ntmat_,indexe,nope,norien,iexpl,i0,ncmat_,istep,iinc +! + integer nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ +! + real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), + & p2(3),ad(*),au(*),bodyf(3), + & t0(*),t1(*),prestr(6,mi(1),*),vold(0:mi(2),*),s(60,60),ff(60), + & sti(6,mi(1),*),sm(60,60),stx(6,mi(1),*),adb(*),aub(*), + & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*), + & alcon(0:6,ntmat_,*),alzero(*),orab(7,*),xbody(7,*),cgr(4,*) +! + real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), + & xstiff(27,mi(1),*) +! + real*8 om,value,dtime,ttime,time +! + i0=0 +! +! determining nzl +! + nzl=0 + do i=neq(2),1,-1 + if(icol(i).gt.0) then + nzl=i + exit + endif + enddo +! +! initializing the matrices +! + do i=1,neq(2) + ad(i)=0.d0 + enddo + do i=1,nzs(2) + au(i)=0.d0 + enddo +! + if((ithermal.le.1).or.(ithermal.eq.3)) then +! +! mechanical analysis: loop over all elements +! + do i=1,ne +! + if(lakon(i)(1:2).ne.'ED') cycle + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + read(lakon(i)(8:8),'(i1)') nope +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + call e_damp(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody,s,sm,ff,i, + & elcon,nelcon,rhcon,nrhcon,alcon,nalcon, + & alzero,ielmat,ielorien,norien,orab,ntmat_, + & t0,t1,ithermal,vold,iperturb, + & nelemload,sideload,xload,nload,idist,sti,stx, + & iexpl,plicon,nplicon,plkcon,nplkcon,xstiff,npmat_, + & dtime,matname,mi(1),ncmat_,ttime,time,istep,iinc, + & nmethod) +! + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdof(k,node1) +! + do ll=jj,3*nope +! + l=(ll-1)/3+1 + m=ll-3*(l-1) +! + node2=kon(indexe+l) + jdof2=nactdof(m,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call add_sm_st(au,ad,jq,irow,jdof1,jdof2, + & s(jj,ll),jj,ll) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8+k + else + idof1=jdof1 + idof2=(node2-1)*8+m + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdof(nodempc(2,index),nodempc(1,index)) + value=-coefmpc(index)*s(jj,ll)/coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + if(idof2.ne.0) then + call add_sm_st(au,ad,jq,irow,idof1, + & idof2,value,i0,i0) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif + else + idof1=(node1-1)*8+k + idof2=(node2-1)*8+m + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdof(nodempc(2,index1), + & nodempc(1,index1)) + index2=index1 + do + idof2=nactdof(nodempc(2,index2), + & nodempc(1,index2)) + value=coefmpc(index1)*coefmpc(index2)* + & s(jj,ll)/coefmpc(ist)/coefmpc(ist) + if((idof1.ne.0).and.(idof2.ne.0)) then + call add_sm_st(au,ad,jq,irow, + & idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdof(nodempc(2,index1), + & nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdof(nodempc(2,index2), + & nodempc(1,index2)) + value=coefmpc(index1)*coefmpc(index2)* + & s(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + if((idof1.ne.0).and.(idof2.ne.0)) then + call add_sm_st(au,ad,jq,irow, + & idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo +! + enddo + enddo +! + endif +! +c do i=1,neq(2) +c write(*,*) i,ad(i) +c enddo +c do i=1,nzs(2) +c write(*,*) i,au(i) +c enddo + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillklhs.f calculix-ccx-2.3/ccx_2.3/src/mafillklhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafillklhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillklhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,234 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillklhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, + & nactdok,icolk,jqk,irowk,neqk,nzlk, + & ikmpc,ilmpc,ikboun,ilboun,nzsk,adbk,aubk,ipvar,var) +! +! filling the lhs turbulence matrix in spare matrix format (sm) +! +! it is assumed that the temperature MPC's also apply to the +! turbulence. Temperature MPC's are not allowed to contain +! other variables than the temperature. +! + implicit none +! + character*8 lakon(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & icolk(*),jqk(*),ikmpc(*),nzsk,nmethod, + & ilmpc(*),ikboun(*),ilboun(*),nactdok(*),konl(20),irowk(*), + & ipkon(*),ipvar(*) +! + integer nk,ne,nboun,nmpc,neqk,nzlk,i,j,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,node1,node2, + & indexe,nope,i0 +! + real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbk(*),aubk(*), + & var(*) +! + real*8 value +! + i0=0 +! +! determining nzlk +! + nzlk=0 + do i=neqk,1,-1 + if(icolk(i).gt.0) then + nzlk=i + exit + endif + enddo +! + do i=1,neqk + adbk(i)=0.d0 + enddo + do i=1,nzsk + aubk(i)=0.d0 + enddo +! +! loop over all fluid elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! +! the temperature element routine = the turbulence element +! routine +! + call e_c3d_tlhs(co,nk,konl,lakon(i),sm,i,ipvar,var) +! + do jj=1,nope +! + node1=kon(indexe+jj) + jdof1=nactdok(node1) +! + do ll=jj,nope +! + node2=kon(indexe+ll) + jdof2=nactdok(node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call add_sm_fl(aubk,adbk,jqk,irowk,jdof1,jdof2, + & sm(jj,ll),jj,ll) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8 + else + idof1=jdof1 + idof2=(node2-1)*8 + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdok(nodempc(1,index)) + if(idof2.ne.0) then + value=-coefmpc(index)*sm(jj,ll)/ + & coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubk,adbk,jqk,irowk, + & idof1,idof2,value,i0,i0) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif + else + idof1=(node1-1)*8 + idof2=(node2-1)*8 + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdok(nodempc(1,index1)) + index2=index1 + do + idof2=nactdok(nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + call add_sm_fl(aubk,adbk,jqk, + & irowk,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdok(nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdok(nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubk,adbk,jqk, + & irowk,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillkrhs.f calculix-ccx-2.3/ccx_2.3/src/mafillkrhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafillkrhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillkrhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,139 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillkrhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nelemface,sideface, + & nface,nactdok,neqk,nmethod,ikmpc,ilmpc, + & ikboun,ilboun,rhcon,nrhcon,ielmat,ntmat_,vold,voldcon,nzsk, + & dtime,matname,mi,ncmat_,shcon,nshcon,v,theta1, + & bk,bt,voldtu,isolidsurf,nsolidsurf,ifreestream,nfreestream, + & xsolidsurf,yy,compressible,turbulent,ithermal) +! +! filling the rhs b of the turbulence equations (step 5) +! +! it is assumed that the temperature MPC's also apply to the +! turbulence. The temperature MPC's are not allowed to contain +! any other variables but temperatures +! + implicit none +! + character*1 sideface(*) + character*8 lakon(*) + character*80 matname(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & nelemface(*),ikmpc(*),ilmpc(*),ikboun(*),compressible, + & ilboun(*),nactdok(*),konl(20),nrhcon(*),ielmat(*), + & ipkon(*),nshcon(*),ifreestream(*),nfreestream,isolidsurf(*), + & nsolidsurf,turbulent,ithermal +! + integer nk,ne,nboun,nmpc,nface,neqk,nmethod,nzsk,i,j,k,jj, + & id,ist,index,jdof1,idof1,node1,kflag,ntmat_,indexe,nope, + & mi(2),i0,ncmat_ +! + real*8 co(3,*),xboun(*),coefmpc(*),bk(*),v(0:mi(2),*), + & vold(0:mi(2),*), + & voldcon(0:4,*),ffk(60),rhcon(0:1,ntmat_,*),yy(*), + & shcon(0:3,ntmat_,*),theta1,bt(*),fft(60),voldtu(2,*), + & xsolidsurf(*) +! + real*8 dtime +! + kflag=2 + i0=0 +! + do i=1,neqk + bk(i)=0.d0 + bt(i)=0.d0 + enddo +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! +c do j=1,nope +c konl(j)=kon(indexe+j) +c enddo +! + call e_c3d_krhs(co,nk,kon(indexe+1),lakon(i),ffk,fft,i,nmethod, + & rhcon, + & nrhcon,ielmat,ntmat_,vold,voldcon,dtime,matname,mi(1), + & shcon,nshcon,voldtu,compressible,yy,nelemface,sideface, + & nface,turbulent,ithermal) +! + do jj=1,nope +! + j=jj + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdok(node1) +! +! inclusion of ffk and fft +! + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8 + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof1=nactdok(nodempc(1,index)) + if(jdof1.ne.0) then + bk(jdof1)=bk(jdof1) + & -coefmpc(index)*ffk(jj) + & /coefmpc(ist) + bt(jdof1)=bt(jdof1) + & -coefmpc(index)*fft(jj) + & /coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + bk(jdof1)=bk(jdof1)+ffk(jj) + bt(jdof1)=bt(jdof1)+fft(jj) +! + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillnet.f calculix-ccx-2.3/ccx_2.3/src/mafillnet.f --- calculix-ccx-2.1/ccx_2.3/src/mafillnet.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillnet.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,675 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! This subroutine creates the matrix ac for gas problems +! + subroutine mafillnet(itg,ieg,ntg,ac,nload,sideload,nelemload, + & xloadact,lakon,ntmat_,v,shcon,nshcon,ipkon,kon,co,nflow,iinc, + & istep,dtime,ttime,time, + & ielmat,nteq,prop,ielprop,nactdog,nacteq,physcon, + & rhcon,nrhcon,ipobody,ibody,xbodyact,nbody,vold,xloadold, + & reltime,nmethod,set,mi,nmpc,nodempc,ipompc,coefmpc,labmpc) +! + implicit none +! + logical identity + character*8 lakonl,lakon(*) + character*20 sideload(*),labmpc(*) + character*81 set(*) +! + integer itg(*),ieg(*),ntg,nteq,nflow,nload,ielmat(*), + & nelemload(2,*),nope,nopes,mint2d,i,j,k,l,iflag, + & node,imat,ntmat_,id,ifaceq(8,6),ifacet(6,4), + & ifacew(8,5),node1,node2,nshcon(*),nelem,ig,index,konl(20), + & ipkon(*),kon(*),idof,iinc,ibody(3,*),istep,jltyp,nfield, + & ipobody(2,*),nodem,ieq,kflag,nrhcon(*),numf, + & idofp1,idofp2,idofm,idoft1,idoft2,idoft,nactdog(0:3,*), + & nacteq(0:3,*),ielprop(*),nodef(5),idirf(5),nbody, + & nmethod,icase,mi(2),nmpc,nodempc(3,*),ipompc(*),idir +! + real*8 ac(nteq,*),xloadact(2,*),cp,h(2),physcon(*),dvi, + & xl2(3,8),coords(3),dxsj2,temp,xi,et,weight,xsj2(3), + & gastemp,v(0:mi(2),*),shcon(0:3,ntmat_,*),co(3,*),shp2(7,8), + & ftot,field,prop(*),f,df(5),tg1,tg2,r,rho,tl2(8), + & dtime,ttime,time,areaj,xflow,tvar(2),g(3),coefmpc(*), + & rhcon(0:1,ntmat_,*),xbodyact(7,*),sinktemp,ts1,ts2,xs2(3,7), + & xdenom1,xdenom2,xcst,xk1,xk2,expon,a,dt1,dt2,kappa, + & pt1,pt2,inv,vold(0:mi(2),*),xloadold(2,*),reltime,pi +! + include "gauss.f" +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! + data iflag /2/ +! + kflag=2 +! + Pi=4.d0*datan(1.d0) + tvar(1)=time + tvar(2)=ttime+dtime +! +! reinitialisation of the Ac matrix +! + do i=1,nteq + do j=1,nteq + ac(i,j)=0.d0 + enddo + enddo +! +! solving for the gas temperatures in forced convection +! + ftot=0.d0 +! +! element contribution. +! + + do i=1,nflow + nelem=ieg(i) + index=ipkon(nelem) + node1=kon(index+1) + nodem=kon(index+2) + node2=kon(index+3) +! + xflow=v(1,nodem) +! + if((lakon(nelem)(2:3).ne.'LP').and. + & (lakon(nelem)(2:3).ne.'LI')) then + if(node1.eq.0) then + tg1=v(0,node2) + tg2=tg1 + ts1=v(3,node2) + ts2=ts1 + elseif(node2.eq.0) then + tg1=v(0,node1) + tg2=tg1 + ts1=v(3,node1) + ts2=ts1 + else + tg1=v(0,node1) + tg2=v(0,node2) + ts1=v(3,node1) + ts2=v(3,node2) + endif +! + gastemp=(ts1+ts2)/2.d0 +! +! for liquid pipe element only the upstream temperature is used to +! determine thematerial properties +! + else + + if(xflow.gt.0) then + if(node1.eq.0) then + gastemp=v(0,node2) + else + gastemp=v(0,node1) + endif + else + if(node2.eq.0) then + gastemp=v(0,node1) + else + gastemp=v(0,node2) + endif + endif + endif +! + imat=ielmat(nelem) +! + call materialdata_tg(imat,ntmat_,gastemp,shcon,nshcon,cp,r,dvi, + & rhcon,nrhcon,rho) +! + kappa=(cp/(cp-R)) +! +! Definitions of the constant for isothermal flow elements +! + if((lakon(nelem)(2:6).eq.'GAPFI') + & .or.(lakon(nelem)(2:6).eq.'GAPII'))then + if((node1.ne.0).and.(node2.ne.0)) then +! + icase=1 + A=prop(ielprop(nelem)+1) + pt1=v(2,node1) + pt2=v(2,node2) + if(pt1.ge.pt2)then + inv=1.d0 + pt1=v(2,node1) + pt2=v(2,node2) + if(dabs(tg2/ts2-(1+0.5*(kappa-1)/kappa)).lt.1E-5) then + + pt2=dabs(xflow)*dsqrt(Tg2*R)/A + & *(1+0.5*(kappa-1)/kappa) + & **(0.5*(kappa+1)/(kappa-1)) + endif + tg1=v(0,node1) + call ts_calc(xflow,Tg1,Pt1,kappa,r,a,Ts1,icase) + + + tg2=v(0,node2) + call ts_calc(xflow,Tg2,Pt2,kappa,r,a,Ts2,icase) + else + + inv=-1.d0 + pt1=v(2,node2) + pt2=v(2,node1) + if(dabs(tg2/ts2-(1+0.5*(kappa-1)/kappa)).lt.1E-5) then + + pt2=dabs(xflow)*dsqrt(Tg2*R)/A + & *(1+0.5*(kappa-1)/kappa) + & **(0.5*(kappa+1)/(kappa-1)) + endif + tg1=v(0,node2) + call ts_calc(xflow,Tg1,Pt1,kappa,r,a,Ts1,icase) + tg2=v(0,node1) + call ts_calc(xflow,Tg2,Pt2,kappa,r,a,Ts2,icase) + endif + dt1=tg1/ts1-1d0 + dt2=tg2/ts2-1d0 + expon=2.d0*kappa/(kappa-1.d0) + xcst=2.d0*Cp*A**2/r**2 + xk1=pt1**2*(ts1/tg1)**expon + xdenom1=xcst*xk1*(1.d0-expon*(tg1/ts1-1.d0)) + & /ts1+2.d0*xflow**2 + xk2=pt2**2*(ts2/tg2)**expon + xdenom2=xcst*xk2*(1.d0-expon*(tg2/ts2-1.d0)) + & /ts2+2.d0*xflow**2 + endif + endif +! + if(node1.ne.0) then + idoft1=nactdog(0,node1) + idofp1=nactdog(2,node1) + else + idoft1=0 + idofp1=0 + endif + if(node2.ne.0) then + idoft2=nactdog(0,node2) + idofp2=nactdog(2,node2) + else + idoft2=0 + idofp2=0 + endif + idofm=nactdog(1,nodem) +! + if(node1.ne.0) then +! +! energy equation contribution node1 +! + if (nacteq(0,node1).ne.0) then + ieq=nacteq(0,node1) + if ((xflow.le.0d0).and.(nacteq(3,node1).eq.0))then +! +! adiabatic element +! + if(idoft1.ne.0) then + ac(ieq,idoft1)=ac(ieq,idoft1)-cp*xflow + endif +! + if(idoft2.ne.0)then + ac(ieq,idoft2)=ac(ieq,idoft2)+cp*xflow + endif +! + if(idofm.ne.0) then + ac(ieq,idofm)=ac(ieq,idofm)-cp*(tg1-tg2) + endif +! + elseif(nacteq(3,node1).ne.0)then +! +! isothermal element +! + if(nacteq(3,node1).eq.node2) then +! + if(inv.eq.-1d0) then + if(idoft1.ne.0) then + ac(ieq,idoft1)=-xcst*xk1*(1.d0-expon + & *(1.d0-ts1/tg1))/(xdenom1*ts1) + endif +! + if(idoft2.ne.0)then + ac(ieq,idoft2)=xcst*xk2*(1.d0-expon + & *(1.d0-ts2/tg2))/(xdenom2*ts2) + endif +! + if(idofm.ne.0) then + ac(ieq,idofm)=(-2.d0*xflow*ts2 + & /xdenom2+2.d0*xflow*ts1/xdenom1) + endif +! + if(idofp1.ne.0) then + ieq=nacteq(2,idofp1) + ac(ieq,idofp1)=2.d0*xcst*dt1*xk1 + & /(pt1*xdenom1) + endif +! + if(idofp2.ne.0) then + ac(ieq,idofp2)=-2.d0*xcst*dt2*xk2 + & /(pt2*xdenom2) + endif +! + elseif(inv.eq.1d0)then + if(idoft1.ne.0) then + ac(ieq,idoft1)=xcst*xk1*(1.d0-expon + & *(1.d0-ts1/tg1))/(xdenom1*ts1) + endif +! + if(idoft2.ne.0)then + ac(ieq,idoft2)=-xcst*xk2*(1.d0-expon + & *(1.d0-ts2/tg2))/(xdenom2*ts2) + endif +! + if(idofm.ne.0) then + ac(ieq,idofm)=-(-2.d0*xflow*ts2 + & /xdenom2+2.d0*xflow*ts1/xdenom1) + endif +! + if(idofp1.ne.0) then + ieq=nacteq(2,idofp1) + ac(ieq,idofp1)=-2.d0*xcst*dt1*xk1 + & /(pt1*xdenom1) + endif +! + if(idofp2.ne.0) then + ac(ieq,idofp2)=2.d0*xcst*dt2*xk2 + & /(pt2*xdenom2) + endif +! + endif + endif + endif + endif +! +! mass equation contribution node1 +! + if (nacteq(1,node1).ne.0) then + ieq=nacteq(1,node1) + if (idofm.ne.0) then + ac(ieq,idofm)=1.d0 + endif + endif + endif +! + if(node2.ne.0) then +! +! energy equation contribution node2 +! + if (nacteq(0,node2).ne.0) then + ieq=nacteq(0,node2) + if ((xflow.ge.0d0).and.(nacteq(3,node2).eq.0))then +! +! adiabatic element +! + if(idoft1.ne.0)then + ac(ieq,idoft1)=ac(ieq,idoft1)-cp*xflow + endif +! + if(idoft2.ne.0) then + ac(ieq,idoft2)=ac(ieq,idoft2)+cp*xflow + endif +! + if(idofm.ne.0) then + ac(ieq,idofm)=ac(ieq,idofm)+cp*(tg2-tg1) + endif +! + elseif((nacteq(3,node2).eq.node1))then +! +! isothermal element +! + if(inv.eq.-1d0) then + if(idoft1.ne.0)then + ac(ieq,idoft1)=-xcst*xk1*(1.d0-expon + & *(1.d0-ts1/tg1))/(xdenom1*ts1) + endif +! + if(idoft2.ne.0) then + ac(ieq,idoft2)=(xcst*xk2*(1.d0-expon + & *(1.d0-ts2/tg2))/(xdenom2*ts2)) + endif +! + if(idofm.ne.0) then + ac(ieq,idofm)=(-2.d0*xflow*ts2 + & /xdenom2+2.d0*xflow*ts1/xdenom1) + endif +! + if(idofp1.ne.0) then + ac(ieq,idofp1)=+2.d0*xcst*dt1*xk1 + & /(pt1*xdenom1) + endif +! + if(idofp2.ne.0) then + ac(ieq,idofp2)=-2.d0*xcst*dt2*xk2 + & /(pt2*xdenom2) + endif +! + elseif(inv.eq.1d0) then + + if(idoft1.ne.0)then + ac(ieq,idoft1)=xcst*xk1*(1.d0-expon + & *(1.d0-ts1/tg1))/(xdenom1*ts1) + endif +! + if(idoft2.ne.0) then + ac(ieq,idoft2)=-(xcst*xk2*(1.d0-expon + & *(1.d0-ts2/tg2))/(xdenom2*ts2)) + endif +! + if(idofm.ne.0) then + ac(ieq,idofm)=-(-2.d0*xflow*ts2 + & /xdenom2+2.d0*xflow*ts1/xdenom1) + endif +! + if(idofp1.ne.0) then + ac(ieq,idofp1)=+2.d0*xcst*dt1*xk1 + & /(pt1*xdenom1) + endif +! + if(idofp2.ne.0) then + ac(ieq,idofp2)=-2.d0*xcst*dt2*xk2 + & /(pt2*xdenom2) + endif + endif +! + endif + endif +! +! mass equation contribution node2 +! + if (nacteq(1,node2).ne.0) then + ieq=nacteq(1,node2) + if(idofm.ne.0)then + ac(ieq,idofm)=-1.d0 + endif + endif + endif +! +! element equation +! + if (nacteq(2,nodem).ne.0) then + ieq=nacteq(2,nodem) +! +! for liquids: determine the gravity vector +! + if(lakon(nelem)(2:3).eq.'LI') then + do j=1,3 + g(j)=0.d0 + enddo + if(nbody.gt.0) then + index=nelem + do + j=ipobody(1,index) + if(j.eq.0) exit + if(ibody(1,j).eq.2) then + g(1)=g(1)+xbodyact(1,j)*xbodyact(2,j) + g(2)=g(2)+xbodyact(1,j)*xbodyact(3,j) + g(3)=g(3)+xbodyact(1,j)*xbodyact(4,j) + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif + endif +! + call flux(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,kflag,v,xflow,f, + & nodef,idirf,df,cp,R,rho,physcon,g,co,dvi,numf, + & vold,set,shcon,nshcon,rhcon,nrhcon,ntmat_,mi) +! + do k=1,numf + idof=nactdog(idirf(k),nodef(k)) + if(idof.ne.0)then + ac(ieq,idof)=df(k) + endif + enddo + endif + enddo +! +! convection with the walls +! + do i=1,nload + if(sideload(i)(3:4).eq.'FC') then + nelem=nelemload(1,i) + lakonl=lakon(nelem) + node=nelemload(2,i) + ieq=nacteq(0,node) + if(ieq.eq.0) then + cycle + endif +! + call nident(itg,node,ntg,id) +! +! calculate the area +! + read(sideload(i)(2:2),'(i1)') ig +! +! number of nodes and integration points in the face +! + if(lakonl(4:4).eq.'2') then + nope=20 + nopes=8 + elseif(lakonl(4:4).eq.'8') then + nope=8 + nopes=4 + elseif(lakonl(4:5).eq.'10') then + nope=10 + nopes=6 + elseif(lakonl(4:4).eq.'4') then + nope=4 + nopes=3 + elseif(lakonl(4:5).eq.'15') then + nope=15 + else + nope=6 + endif +! + if(lakonl(4:5).eq.'8R') then + mint2d=1 + elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R')) + & then + if(lakonl(7:7).eq.'A') then + mint2d=2 + else + mint2d=4 + endif + elseif(lakonl(4:4).eq.'2') then + mint2d=9 + elseif(lakonl(4:5).eq.'10') then + mint2d=3 + elseif(lakonl(4:4).eq.'4') then + mint2d=1 + endif +! + if(lakonl(4:4).eq.'6') then + mint2d=1 + if(ig.le.2) then + nopes=3 + else + nopes=4 + endif + endif + if(lakonl(4:5).eq.'15') then + if(ig.le.2) then + mint2d=3 + nopes=6 + else + mint2d=4 + nopes=8 + endif + endif +! +! connectivity of the element +! + index=ipkon(nelem) + if(index.lt.0) then + write(*,*) '*ERROR in mafillnet: element ',nelem + write(*,*) ' is not defined' + stop + endif + do k=1,nope + konl(k)=kon(index+k) + enddo +! +! coordinates of the nodes belonging to the face +! + if((nope.eq.20).or.(nope.eq.8)) then + do k=1,nopes + tl2(k)=v(0,konl(ifaceq(k,ig))) + do j=1,3 + xl2(j,k)=co(j,konl(ifaceq(k,ig)))+ + & v(j,konl(ifaceq(k,ig))) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + do k=1,nopes + tl2(k)=v(0,konl(ifacet(k,ig))) + do j=1,3 + xl2(j,k)=co(j,konl(ifacet(k,ig)))+ + & v(j,konl(ifacet(k,ig))) + enddo + enddo + else + do k=1,nopes + tl2(k)=v(0,konl(ifacew(k,ig))) + do j=1,3 + xl2(j,k)=co(j,konl(ifacew(k,ig)))+ + & v(j,konl(ifacew(k,ig))) + enddo + enddo + endif +! +! integration to obtain the area and the mean +! temperature +! + do l=1,mint2d + if((lakonl(4:5).eq.'8R').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then + xi=gauss2d1(1,l) + et=gauss2d1(2,l) + weight=weight2d1(l) + elseif((lakonl(4:4).eq.'8').or. + & (lakonl(4:6).eq.'20R').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then + xi=gauss2d2(1,l) + et=gauss2d2(2,l) + weight=weight2d2(l) + elseif(lakonl(4:4).eq.'2') then + xi=gauss2d3(1,l) + et=gauss2d3(2,l) + weight=weight2d3(l) + elseif((lakonl(4:5).eq.'10').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then + xi=gauss2d5(1,l) + et=gauss2d5(2,l) + weight=weight2d5(l) + elseif((lakonl(4:4).eq.'4').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then + xi=gauss2d4(1,l) + et=gauss2d4(2,l) + weight=weight2d4(l) + endif +! + if(nopes.eq.8) then + call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + endif +! + dxsj2=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+ + & xsj2(3)*xsj2(3)) + areaj=dxsj2*weight +! + temp=0.d0 + do k=1,3 + coords(k)=0.d0 + enddo + do j=1,nopes + temp=temp+tl2(j)*shp2(4,j) + do k=1,3 + coords(k)=coords(k)+xl2(k,j)*shp2(4,j) + enddo + enddo +! + if(sideload(i)(5:6).ne.'NU') then + h(1)=xloadact(1,i) + else + read(sideload(i)(2:2),'(i1)') jltyp + jltyp=jltyp+10 + sinktemp=v(0,node) + call film(h,sinktemp,temp,istep, + & iinc,tvar,nelem,l,coords,jltyp,field,nfield, + & sideload(i),node,areaj,v,mi) + if(nmethod.eq.1) h(1)=xloadold(1,i)+ + & (h(1)-xloadold(1,i))*reltime + endif +! + idoft=nactdog(0,node) + if(idoft.gt.0) then + if(lakonl(5:7).eq.'0RA') then + ac(ieq,idoft)=ac(ieq,idoft)+2.d0*h(1)*dxsj2*weight + else + ac(ieq,idoft)=ac(ieq,idoft)+h(1)*dxsj2*weight + endif + endif + enddo + endif + enddo +! +! additional multiple point constraints +! + j=nteq+1 + do i=nmpc,1,-1 + if(labmpc(i)(1:7).ne.'NETWORK') cycle + j=j-1 + index=ipompc(i) +! + do + node=nodempc(1,index) + idir=nodempc(2,index) + if(nactdog(idir,node).ne.0) then + ac(j,nactdog(idir,node))=coefmpc(index) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + enddo +! +c write(30,*) 'ac in mafillgas' +c do i=1,17 +c write(30,'(17(1x,e11.4))') (ac(i,j),j=1,17) +c enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillplhs.f calculix-ccx-2.3/ccx_2.3/src/mafillplhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafillplhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillplhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,232 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillplhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nactdoh,icolp,jqp,irowp, + & neqp,nzlp,ikmpc,ilmpc,ikboun,ilboun,nzsp,adbp,aubp,nmethod, + & iexplicit,ipvar,var) +! +! filling the lhs pressure matrix in sparse matrix format +! +! it is assumed that the temperature MPC's also apply to the +! pressure. Temperature MPC's are not allowed to contain +! other variables than the temperature. +! + implicit none +! + character*8 lakon(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & icolp(*),jqp(*),ikmpc(*),nzsp,nmethod,iexplicit, + & ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20),irowp(*), + & ipkon(*),ipvar(*) +! + integer nk,ne,nboun,nmpc,neqp,nzlp,i,j,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,node1,node2, + & indexe,nope,i0 +! + real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbp(*),aubp(*), + & var(*) +! + real*8 value +! + i0=0 +! +! determining nzlp +! + nzlp=0 + do i=neqp,1,-1 + if(icolp(i).gt.0) then + nzlp=i + exit + endif + enddo +! + do i=1,neqp + adbp(i)=0.d0 + enddo + do i=1,nzsp + aubp(i)=0.d0 + enddo +! +! loop over all fluid elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + call e_c3d_plhs(co,nk,konl,lakon(i),sm,i,nmethod,iexplicit, + & ipvar,var) +! + do jj=1,nope +! + node1=kon(indexe+jj) + jdof1=nactdoh(4,node1) +! + do ll=jj,nope +! + node2=kon(indexe+ll) + jdof2=nactdoh(4,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call add_sm_fl(aubp,adbp,jqp,irowp,jdof1,jdof2, + & sm(jj,ll),jj,ll) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8+4 + else + idof1=jdof1 + idof2=(node2-1)*8+4 + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdoh(4,nodempc(1,index)) + if(idof2.ne.0) then + value=-coefmpc(index)*sm(jj,ll)/ + & coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubp,adbp,jqp,irowp, + & idof1,idof2,value,i0,i0) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif + else + idof1=(node1-1)*8+4 + idof2=(node2-1)*8+4 + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdoh(4,nodempc(1,index1)) + index2=index1 + do + idof2=nactdoh(4,nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + call add_sm_fl(aubp,adbp,jqp, + & irowp,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdoh(4,nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdoh(4,nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubp,adbp,jqp, + & irowp,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillprhs.f calculix-ccx-2.3/ccx_2.3/src/mafillprhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafillprhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillprhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,374 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillprhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nelemface,sideface, + & nface,b,nactdoh,icolp,jqp,irowp,neqp,nzlp,nmethod,ikmpc,ilmpc, + & ikboun,ilboun,rhcon,nrhcon,ielmat,ntmat_,vold,voldcon,nzsp, + & dtl,matname,mi,ncmat_,shcon,nshcon,v,theta1, + & iexplicit,physcon,nea,neb,dtimef,ipvar,var,ipvarf,varf) +! +! filling the rhs b of the pressure equations (step 2) +! + implicit none +! + character*1 sideface(*) + character*8 lakon(*) + character*80 matname(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & nelemface(*),icolp(*),jqp(*),ikmpc(*),ilmpc(*),ikboun(*), + & ilboun(*),nactdoh(0:4,*),konl(20),irowp(*),nrhcon(*),ielmat(*), + & ipkon(*),nshcon(*),iexplicit,nea,neb,ipvar(*),ipvarf(*) +! + integer nk,ne,nboun,nmpc,nface,neqp,nzlp,nmethod,nzsp,i,j,k,l,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,node1,node2,kflag,ntmat_,indexe,nope, + & mi(2),i0,ncmat_,idof3 +! + real*8 co(3,*),xboun(*),coefmpc(*),b(*),v(0:mi(2),*), + & vold(0:mi(2),*), + & voldcon(0:4,*),ff(60),sm(60,60),rhcon(0:1,ntmat_,*), + & shcon(0:3,ntmat_,*),theta1,physcon(*),var(*),varf(*) +! + real*8 value,dtl(*),dtimef +! + kflag=2 + i0=0 +! +! determining nzlp +! +c if(iexplicit) then +c nzlp=0 +c do i=neqp,1,-1 +c if(icolp(i).gt.0) then +c nzlp=i +c exit +c endif +c enddo +c endif +! + do i=1,neqp + b(i)=0.d0 + enddo +! + do i=nea,neb +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! +c do j=1,nope +c konl(j)=kon(indexe+j) +c enddo +! + call e_c3d_prhs(co,nk,kon(indexe+1),lakon(i),sm,ff,i,nmethod, + & rhcon, + & nrhcon,ielmat,ntmat_,v,vold,voldcon,nelemface,sideface, + & nface,dtimef,matname,mi(1),shcon,nshcon,theta1,physcon, + & iexplicit,ipvar,var,ipvarf,varf) +! + do jj=1,nope +! + j=jj + k=jj-3*(j-1) +! + node1=kon(indexe+j) +c ff(jj)=ff(jj)*dtl(node1)/dtimef + jdof1=nactdoh(4,node1) +! + do ll=jj,nope +! + l=ll +! + node2=kon(indexe+l) + jdof2=nactdoh(4,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then +c call add_sm_fl(aubp,adbp,jqp,irowp,jdof1,jdof2, +c & sm(jj,ll),jj,ll) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8+4 + else + idof1=jdof1 + idof2=(node2-1)*8+4 + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdoh(4,nodempc(1,index)) + value=-coefmpc(index)*sm(jj,ll)/coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + if(idof2.ne.0) then +c call add_sm_fl(aubp,adbp,jqp,irowp, +cd & idof1,idof2,value,i0,i0) +c else +c if(iexplicit.eq.0) then +c idof2=8*(nodempc(1,index)-1)+ +c & nodempc(2,index) +c call nident(ikboun,idof2,nboun,id) +c b(idof1)=b(idof1) +c & -xboun(ilboun(id))*value +c endif +cd + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif +c! +c! regular DOF / SPC +c! +cd +c if(iexplicit.eq.0) then +cc idof2=idof2+4 +c call nident(ikboun,idof2,nboun,id) +c b(idof1)=b(idof1)-xboun(ilboun(id))*sm(jj,ll) +c endif +cd + else + idof1=(node1-1)*8+4 + idof2=(node2-1)*8+4 + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdoh(4,nodempc(1,index1)) + index2=index1 + do + idof2=nactdoh(4,nodempc(1,index2)) + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + if((idof1.ne.0).and.(idof2.ne.0)) then +c call add_sm_fl(aubp,adbp,jqp, +c & irowp,idof1,idof2,value,i0,i0) +cd +c elseif((iexplicit.eq.0).and. +c & ((idof1.ne.0).or.(idof2.ne.0))) then +c if(idof2.ne.0) then +c idof3=idof2 +c idof2=8*(nodempc(1,index1)-1)+ +c & nodempc(2,index1) +c else +c idof3=idof1 +c idof2=8*(nodempc(1,index2)-1)+ +c & nodempc(2,index2) +c endif +c call nident(ikboun,idof2,nboun,id) +c b(idof3)=b(idof3) +c & -value*xboun(ilboun(id)) +cd + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdoh(4,nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdoh(4,nodempc(1,index2)) + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + if((idof1.ne.0).and.(idof2.ne.0)) then +c call add_sm_fl(aubp,adbp,jqp, +c & irowp,idof1,idof2,value,i0,i0) +cd +c elseif((iexplicit.eq.0).and. +c & ((idof1.ne.0).or.(idof2.ne.0))) then +c if(idof2.ne.0) then +c idof3=idof2 +c idof2=8*(nodempc(1,index1)-1)+ +c & nodempc(2,index1) +c else +c idof3=idof1 +c idof2=8*(nodempc(1,index2)-1)+ +c & nodempc(2,index2) +c endif +c call nident(ikboun,idof2,nboun,id) +c b(idof3)=b(idof3) +c & -value*xboun(ilboun(id)) +cd + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif +cd +c elseif(((mpc1.eq.1).or.(mpc2.eq.1)).and.(iexplicit.eq.0)) +c & then +c if(mpc1.eq.1) then +c! +c! MPC id1 / SPC +c! +cc idof2=idof2+4 +c call nident(ikboun,idof2,nboun,id2) +c idof2=ilboun(id2) +c ist1=ipompc(id1) +c index1=nodempc(3,ist1) +c if(index1.eq.0) cycle +c do +c idof1=nactdoh(nodempc(2,index1), +c & nodempc(1,index1)) +c if(idof1.ne.0) then +c b(idof1)=b(idof1)+xboun(idof2)* +c & coefmpc(index1)*sm(jj,ll)/coefmpc(ist1) +c endif +c index1=nodempc(3,index1) +c if(index1.eq.0) exit +c enddo +c elseif(mpc2.eq.1) then +c! +c! MPC id2 / SPC +c! +cc idof1=idof1+4 +c call nident(ikboun,idof1,nboun,id1) +c idof1=ilboun(id1) +c ist2=ipompc(id2) +c index2=nodempc(3,ist2) +c if(index2.eq.0) cycle +c do +c idof2=nactdoh(nodempc(2,index2), +c & nodempc(1,index2)) +c if(idof2.ne.0) then +c b(idof2)=b(idof2)+xboun(idof1)* +c & coefmpc(index2)*sm(jj,ll)/coefmpc(ist2) +c endif +c index2=nodempc(3,index2) +c if(index2.eq.0) exit +c enddo +c endif +cd + endif + endif + enddo +! +! inclusion of ff +! + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8+4 + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof1=nactdoh(4,nodempc(1,index)) + if(jdof1.ne.0) then + b(jdof1)=b(jdof1) + & -coefmpc(index)*ff(jj) + & /coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + b(jdof1)=b(jdof1)+ff(jj) +! + enddo + enddo +! +! nonlocal time stepping for compressible steady state calculations +! +c if((iexplicit.eq.1).and.(nmethod.eq.1)) then +c do i=1,nk +c if(nactdoh(4,i).gt.0) then +c b(nactdoh(4,i))=b(nactdoh(4,i))*dtl(i)/dtimef +c endif +c enddo +c endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillsmas.f calculix-ccx-2.3/ccx_2.3/src/mafillsmas.f --- calculix-ccx-2.1/ccx_2.3/src/mafillsmas.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillsmas.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,130 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillsmas(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun, + & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + & ad,au,bb,nactdof,icol,jq,irow,neq,nzl,nmethod, + & ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon, + & nrhcon,alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + & t0,t1,ithermal,prestr, + & iprestr,vold,iperturb,sti,nzs,stx,adb,aub,iexpl,plicon, + & nplicon,plkcon,nplkcon,xstiff,npmat_,dtime, + & matname,mi,ncmat_,mass,stiffness,buckling,rhsi,intscheme, + & physcon,shcon,nshcon,cocon,ncocon,ttime,time,istep,iinc, + & coriolis,ibody,xloadold,reltime,veold,springarea) +! +! filling the stiffness matrix in spare matrix format (sm) +! asymmetric contributions +! + implicit none +! + logical mass,stiffness,buckling,rhsi,coriolis +! + character*8 lakon(*) + character*20 sideload(*) + character*80 matname(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & nodeforc(2,*),ndirforc(*),nelemload(2,*),icol(*),jq(*),ikmpc(*), + & ilmpc(*),ikboun(*),ilboun(*),mi(2), + & nactdof(0:mi(2),*),konl(20),irow(*), + & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), + & ipkon(*),intscheme,ncocon(2,*),nshcon(*),ipobody(2,*),nbody, + & ibody(3,*) +! + integer nk,ne,nboun,nmpc,nforc,nload,neq,nzl,nmethod, + & ithermal,iprestr,iperturb(*),nzs(3),i,j,k,l,m,idist,jj, + & ll,jdof1,jdof2,node1,node2, + & ntmat_,indexe,nope,norien,iexpl,ncmat_,istep,iinc +! + integer nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ +! + real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), + & p2(3),ad(*),au(*),bodyf(3),bb(*),xloadold(2,*), + & t0(*),t1(*),prestr(6,mi(1),*),vold(0:mi(2),*),s(60,60),ff(60), + & sti(6,mi(1),*),sm(60,60),stx(6,mi(1),*),adb(*),aub(*), + & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*),reltime, + & alcon(0:6,ntmat_,*),physcon(*),cocon(0:6,ntmat_,*), + & shcon(0:3,ntmat_,*),alzero(*),orab(7,*),xbody(7,*),cgr(4,*), + & springarea(2,*) +! + real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), + & xstiff(27,mi(1),*),veold(0:mi(2),*) +! + real*8 om,dtime,ttime,time +! +! storing the symmetric matrix in asymmetric format +! + do i=1,nzs(3) + au(nzs(3)+i)=au(i) + enddo +! +! mechanical analysis: asymmetric contributions +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'E') cycle + indexe=ipkon(i) + nope=4 +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + call e_c3d(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody,s,sm,ff,i, + & nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon, + & alzero,ielmat,ielorien,norien,orab,ntmat_, + & t0,t1,ithermal,vold,iperturb,nelemload,sideload,xload, + & nload,idist,sti,stx,iexpl,plicon, + & nplicon,plkcon,nplkcon,xstiff,npmat_, + & dtime,matname,mi(1),ncmat_,mass,stiffness,buckling,rhsi, + & intscheme,ttime,time,istep,iinc,coriolis,xloadold, + & reltime,ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold, + & springarea) +! + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdof(k,node1) +! + do ll=1,3*nope +! + l=(ll-1)/3+1 + m=ll-3*(l-1) +! + node2=kon(indexe+l) + jdof2=nactdof(m,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call add_sm_st_as(au,ad,jq,irow,jdof1,jdof2, + & s(jj,ll),jj,ll,nzs) + endif + enddo + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillsmcs.f calculix-ccx-2.3/ccx_2.3/src/mafillsmcs.f --- calculix-ccx-2.1/ccx_2.3/src/mafillsmcs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillsmcs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,623 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillsmcs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun, + & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + & ad,au,bb,nactdof,icol,jq,irow,neq,nzl,nmethod, + & ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon, + & nrhcon,alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + & t0,t1,ithermal,prestr, + & iprestr,vold,iperturb,sti,nzs,stx,adb,aub,iexpl,plicon, + & nplicon,plkcon,nplkcon,xstiff,npmat_,dtime, + & matname,mi,ics,cs,nm,ncmat_,labmpc,mass,stiffness,buckling, + & rhsi,intscheme,mcs,coriolis,ibody,xloadold,reltime,ielcs, + & veold,springarea) +! +! filling the stiffness matrix in spare matrix format (sm) +! for cyclic symmetry calculations +! + implicit none +! + logical mass,stiffness,buckling,rhsi,coriolis +! + character*8 lakon(*) + character*20 labmpc(*),sideload(*) + character*80 matname(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & nodeforc(2,*),ndirforc(*),nelemload(2,*),icol(*),jq(*),ikmpc(*), + & ilmpc(*),ikboun(*),ilboun(*),mi(2),nstate_,ne0, + & nactdof(0:mi(2),*),konl(20),irow(*), + & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), + & ipkon(*),ics(*),ij,ilength,lprev,ipobody(2,*),nbody, + & ibody(3,*),nk,ne,nboun,nmpc,nforc,nload,neq,nzl,nmethod, + & ithermal,iprestr,iperturb(*),nzs,i,j,k,l,m,idist,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,node1,node2,kflag, + & ntmat_,indexe,nope,norien,iexpl,i0,nm,inode,icomplex, + & inode1,icomplex1,inode2,icomplex2,ner,ncmat_,intscheme,istep, + & iinc,mcs,ielcs(*),nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ +! + real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), + & p2(3),ad(*),au(*),bodyf(3),bb(*),xbody(7,*),cgr(4,*), + & t0(*),t1(*),prestr(6,mi(1),*),vold(0:mi(2),*),s(60,60),ff(60), + & sti(6,mi(1),*),sm(60,60),stx(6,mi(1),*),adb(*),aub(*), + & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*),xloadold(2,*), + & alcon(0:6,ntmat_,*),cs(17,*),alzero(*),orab(7,*),reltime, + & springarea(2,*),plicon(0:2*npmat_,ntmat_,*),xstate,xstateini, + & plkcon(0:2*npmat_,ntmat_,*), + & xstiff(27,mi(1),*),pi,theta,ti,tr,veold(0:mi(2),*),om,valu2, + & value,dtime,walue,walu2,time,ttime +! +! +! calculating the scaling factors for the cyclic symmetry calculation +! +c do i=1,nmpc +c write(*,*) i,labmpc(i) +c index=ipompc(i) +c do +c write(*,'(i5,1x,i5,1x,e11.4)') nodempc(1,index), +c & nodempc(2,index),coefmpc(index) +c index=nodempc(3,index) +c if(index.eq.0) exit +c enddo +c write(*,*) +c enddo +! + pi=4.d0*datan(1.d0) + nstate_=0 +! + do i=1,mcs + theta=nm*2.d0*pi/cs(1,i) + cs(15,i)=dcos(theta) + cs(16,i)=dsin(theta) + enddo +! + kflag=2 + i0=0 +! +! determining nzl +! + nzl=0 + do i=neq,1,-1 + if(icol(i).gt.0) then + nzl=i + exit + endif + enddo +! +! initializing the matrices +! + do i=1,neq + ad(i)=0.d0 + enddo + do i=1,nzs + au(i)=0.d0 + enddo +! + do i=1,neq + adb(i)=0.d0 + enddo + do i=1,nzs + aub(i)=0.d0 + enddo +! + ner=neq/2 +! +! loop over all elements +! +! initialisation of the error parameter +! + ne0=0 + do i=1,ne +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) +c Bernhardi start + if(lakon(i)(4:5).eq.'8I') then + nope=11 + elseif(lakon(i)(4:4).eq.'2') then +c Bernhardi end + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + else + nope=6 + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +c! +c! assigning centrifugal forces +c! +c j=ipobody(1,i) +c if(j.ne.0) then +c om=xbody(1,j) +c p1(1)=xbody(2,j) +c p1(2)=xbody(3,j) +c p1(3)=xbody(4,j) +c p2(1)=xbody(5,j) +c p2(2)=xbody(6,j) +c p2(3)=xbody(7,j) +c else +c om=0.d0 +c endif +! + om=0.d0 +! + if(nbody.gt.0) then +! +! assigning centrifugal forces +! + index=i + do + j=ipobody(1,index) + if(j.eq.0) exit + if(ibody(1,j).eq.1) then + om=xbody(1,j) + p1(1)=xbody(2,j) + p1(2)=xbody(3,j) + p1(3)=xbody(4,j) + p2(1)=xbody(5,j) + p2(2)=xbody(6,j) + p2(3)=xbody(7,j) + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif +! + call e_c3d(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody,s,sm,ff,i, + & nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon, + & alzero,ielmat,ielorien,norien,orab,ntmat_, + & t0,t1,ithermal,vold,iperturb,nelemload,sideload,xload, + & nload,idist,sti,stx,iexpl,plicon, + & nplicon,plkcon,nplkcon,xstiff,npmat_, + & dtime,matname,mi(1),ncmat_,mass,stiffness,buckling,rhsi, + & intscheme,ttime,time,istep,iinc,coriolis,xloadold, + & reltime,ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold, + & springarea,nstate_,xstateini,xstate,ne0) +! + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdof(k,node1) +! + do ll=jj,3*nope + if (mcs.gt.1)then + if(cs(1,(ielcs(i)+1)).ne.1.d0) then + s(jj,ll)=(cs(1,(ielcs(i)+1))/cs(1,1))*s(jj,ll) + sm(jj,ll)=(cs(1,(ielcs(i)+1))/cs(1,1))*sm(jj,ll) + endif + endif +! + l=(ll-1)/3+1 + m=ll-3*(l-1) +! + node2=kon(indexe+l) + jdof2=nactdof(m,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call add_sm_ei(au,ad,aub,adb,jq,irow,jdof1,jdof2, + & s(jj,ll),sm(jj,ll),jj,ll) + call add_sm_ei(au,ad,aub,adb,jq,irow,jdof1+ner,jdof2+ner, + & s(jj,ll),sm(jj,ll),jj,ll) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8+k + else + idof1=jdof1 + idof2=(node2-1)*8+m + endif +! + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id1=ilmpc(id) + ist=ipompc(id1) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + inode=nodempc(1,index) + icomplex=0 +c write(*,*) id1,labmpc(id1)(1:9) + if(labmpc(id1)(1:6).eq.'CYCLIC') then + read(labmpc(id1)(7:20),'(i14)') icomplex + elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then + do ij=1,mcs + ilength=int(cs(4,ij)) + lprev=int(cs(14,ij)) + call nident(ics(lprev+1),inode,ilength,id) + if(id.gt.0) then + if(ics(lprev+id).eq.inode) then + icomplex=ij + exit + endif + endif + enddo + endif + idof2=nactdof(nodempc(2,index),inode) + if(idof2.ne.0) then + value=-coefmpc(index)*s(jj,ll)/coefmpc(ist) + valu2=-coefmpc(index)*sm(jj,ll)/ + & coefmpc(ist) + if(idof1.eq.idof2) then + value=2.d0*value + valu2=2.d0*valu2 + endif + if(icomplex.eq.0) then + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1,idof2,value,valu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1+ner,idof2+ner,value,valu2,i0,i0) + else + walue=value*cs(15,icomplex) + walu2=valu2*cs(15,icomplex) + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1,idof2,walue,walu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1+ner,idof2+ner,walue,walu2,i0,i0) + if(idof1.ne.idof2) then + walue=value*cs(16,icomplex) + walu2=valu2*cs(16,icomplex) + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1,idof2+ner,walue,walu2,i0,i0) + walue=-walue + walu2=-walu2 + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1+ner,idof2,walue,walu2,i0,i0) + endif + endif + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif +! + else + idof1=(node1-1)*8+k + idof2=(node2-1)*8+m +! + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + inode1=nodempc(1,index1) + icomplex1=0 + if(labmpc(id1)(1:6).eq.'CYCLIC') then + read(labmpc(id1)(7:20),'(i14)') icomplex1 + elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then + do ij=1,mcs + ilength=int(cs(4,ij)) + lprev=int(cs(14,ij)) + call nident(ics(lprev+1),inode1, + & ilength,id) + if(id.gt.0) then + if(ics(lprev+id).eq.inode1) then + icomplex1=ij + exit + endif + endif + enddo + endif + idof1=nactdof(nodempc(2,index1),inode1) + index2=index1 + do + inode2=nodempc(1,index2) + icomplex2=0 + if(labmpc(id1)(1:6).eq.'CYCLIC') then + read(labmpc(id1)(7:20),'(i14)') icomplex2 + elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then + do ij=1,mcs + ilength=int(cs(4,ij)) + lprev=int(cs(14,ij)) + call nident(ics(lprev+1),inode2, + & ilength,id) + if(id.gt.0) then + if(ics(lprev+id).eq.inode2) then + icomplex2=ij + exit + endif + endif + enddo + endif + idof2=nactdof(nodempc(2,index2),inode2) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & s(jj,ll)/coefmpc(ist)/coefmpc(ist) + valu2=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + if((icomplex1.eq.0).and. + & (icomplex2.eq.0)) then + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,value,valu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1+ner,idof2+ner,value, + & valu2,i0,i0) + elseif((icomplex1.ne.0).and. + & (icomplex2.ne.0)) then + if(icomplex1.eq.icomplex2) then + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,value,valu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1+ner,idof2+ner,value, + & valu2,i0,i0) + else + tr=cs(15,icomplex1)*cs(15,icomplex2) + & +cs(16,icomplex1)*cs(16,icomplex2) +c write(*,*) 'tr= ',tr + walue=value*tr + walu2=valu2*tr + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,walue,walu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1+ner,idof2+ner,walue, + & walu2,i0,i0) + ti=cs(15,icomplex1)*cs(16,icomplex2) + & -cs(15,icomplex2)*cs(16,icomplex1) +c write(*,*) icomplex1,icomplex2, +c & cs(15,icomplex1),cs(16,icomplex1), +c & cs(15,icomplex2),cs(16,icomplex2) +c write(*,*) 'ti= ',ti + walue=value*ti + walu2=valu2*ti +c write(*,'(2i8,2(1x,e11.4))') +c & idof1,idof2+ner, +c & walue,walu2 + call add_sm_ei(au,ad,aub,adb,jq,irow + & ,idof1,idof2+ner,walue,walu2,i0,i0) + walue=-walue + walu2=-walu2 + call add_sm_ei(au,ad,aub,adb,jq,irow + & ,idof1+ner,idof2,walue,walu2,i0,i0) + endif + elseif((icomplex1.eq.0).or. + & (icomplex2.eq.0)) then + if(icomplex2.ne.0) then + walue=value*cs(15,icomplex2) + walu2=valu2*cs(15,icomplex2) + else + walue=value*cs(15,icomplex1) + walu2=valu2*cs(15,icomplex1) + endif + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1,idof2,walue,walu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1+ner,idof2+ner,walue,walu2,i0,i0) + if(icomplex2.ne.0) then + walue=value*cs(16,icomplex2) + walu2=valu2*cs(16,icomplex2) + else + walue=-value*cs(16,icomplex1) + walu2=-valu2*cs(16,icomplex1) + endif +c walue=value*st +c walu2=valu2*st + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1,idof2+ner,walue,walu2,i0,i0) + walue=-walue + walu2=-walu2 + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1+ner,idof2,walue,walu2,i0,i0) + endif + endif + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + inode1=nodempc(1,index1) + icomplex1=0 + if(labmpc(id1)(1:6).eq.'CYCLIC') then + read(labmpc(id1)(7:20),'(i14)') icomplex1 + elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then + do ij=1,mcs + ilength=int(cs(4,ij)) + lprev=int(cs(14,ij)) + call nident(ics(lprev+1),inode1, + & ilength,id) + if(id.gt.0) then + if(ics(lprev+id).eq.inode1) then + icomplex1=ij + exit + endif + endif + enddo + endif + idof1=nactdof(nodempc(2,index1),inode1) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + inode2=nodempc(1,index2) + icomplex2=0 + if(labmpc(id2)(1:6).eq.'CYCLIC') then + read(labmpc(id2)(7:20),'(i14)') icomplex2 + elseif(labmpc(id2)(1:9).eq.'SUBCYCLIC') then + do ij=1,mcs + ilength=int(cs(4,ij)) + lprev=int(cs(14,ij)) + call nident(ics(lprev+1),inode2, + & ilength,id) + if(id.gt.0) then + if(ics(lprev+id).eq.inode2) then + icomplex2=ij + exit + endif + endif + enddo + endif + idof2=nactdof(nodempc(2,index2),inode2) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & s(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + valu2=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) then + value=2.d0*value + valu2=2.d0*valu2 + endif + if((icomplex1.eq.0).and. + & (icomplex2.eq.0)) then + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,value,valu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1+ner,idof2+ner,value, + & valu2,i0,i0) + elseif((icomplex1.ne.0).and. + & (icomplex2.ne.0)) then + if(icomplex1.eq.icomplex2) then + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,value,valu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1+ner,idof2+ner,value, + & valu2,i0,i0) + else + tr=cs(15,icomplex1)*cs(15,icomplex2) + & +cs(16,icomplex1)*cs(16,icomplex2) +c write(*,*) 'tr= ',tr + walue=value*tr + walu2=valu2*tr + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,walue,walu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1+ner,idof2+ner,walue, + & walu2,i0,i0) + ti=cs(15,icomplex1)*cs(16,icomplex2) + & -cs(15,icomplex2)*cs(16,icomplex1) +c write(*,*) icomplex1,icomplex2, +c & cs(15,icomplex1),cs(16,icomplex1), +c & cs(15,icomplex2),cs(16,icomplex2) +c write(*,*) 'ti= ',ti + walue=value*ti + walu2=valu2*ti +c write(*,'(2i8,2(1x,e11.4))') +c & idof1,idof2+ner, +c & walue,walu2 + call add_sm_ei(au,ad,aub,adb,jq,irow + & ,idof1,idof2+ner,walue,walu2,i0,i0) + walue=-walue + walu2=-walu2 + call add_sm_ei(au,ad,aub,adb,jq,irow + & ,idof1+ner,idof2,walue,walu2,i0,i0) + endif + elseif((icomplex1.eq.0).or. + & (icomplex2.eq.0)) then + if(icomplex2.ne.0) then + walue=value*cs(15,icomplex2) + walu2=valu2*cs(15,icomplex2) + else + walue=value*cs(15,icomplex1) + walu2=valu2*cs(15,icomplex1) + endif + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1,idof2,walue,walu2,i0,i0) + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1+ner,idof2+ner,walue,walu2,i0,i0) + if(idof1.ne.idof2) then + if(icomplex2.ne.0) then + walue=value*cs(16,icomplex2) + walu2=valu2*cs(16,icomplex2) + else + walue=-value*cs(16,icomplex1) + walu2=-valu2*cs(16,icomplex1) + endif +c walue=value*st +c walu2=valu2*st + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2+ner,walue, + & walu2,i0,i0) + walue=-walue + walu2=-walu2 + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1+ner,idof2,walue, + & walu2,i0,i0) + endif + endif + endif + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo +! + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillsm.f calculix-ccx-2.3/ccx_2.3/src/mafillsm.f --- calculix-ccx-2.1/ccx_2.3/src/mafillsm.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillsm.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,813 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillsm(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun, + & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + & ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, + & ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon, + & nrhcon,alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + & t0,t1,ithermal,prestr, + & iprestr,vold,iperturb,sti,nzs,stx,adb,aub,iexpl,plicon, + & nplicon,plkcon,nplkcon,xstiff,npmat_,dtime, + & matname,mi,ncmat_,mass,stiffness,buckling,rhsi,intscheme, + & physcon,shcon,nshcon,cocon,ncocon,ttime,time,istep,iinc, + & coriolis,ibody,xloadold,reltime,veold,springarea,nstate_, + & xstateini,xstate) +! +! filling the stiffness matrix in spare matrix format (sm) +! + implicit none +! + logical mass(2),stiffness,buckling,rhsi,stiffonly(2),coriolis +! + character*8 lakon(*) + character*20 sideload(*) + character*80 matname(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & nodeforc(2,*),ndirforc(*),nelemload(2,*),icol(*),jq(*),ikmpc(*), + & ilmpc(*),ikboun(*),ilboun(*),mi(2),nstate_,ne0, + & nactdof(0:mi(2),*),konl(20),irow(*),icolumn, + & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), + & ipkon(*),intscheme,ncocon(2,*),nshcon(*),ipobody(2,*),nbody, + & ibody(3,*),nk,ne,nboun,nmpc,nforc,nload,neq(2),nzl,nmethod, + & ithermal(2),iprestr,iperturb(*),nzs(3),i,j,k,l,m,idist,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,jdof,node1,node2,kflag,icalccg, + & ntmat_,indexe,nope,norien,iexpl,i0,ncmat_,istep,iinc, + & nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ +! + real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), + & p2(3),ad(*),au(*),bodyf(3),fext(*),xloadold(2,*),reltime, + & t0(*),t1(*),prestr(6,mi(1),*),vold(0:mi(2),*),s(60,60),ff(60), + & sti(6,mi(1),*),sm(60,60),stx(6,mi(1),*),adb(*),aub(*), + & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*),springarea(2,*), + & alcon(0:6,ntmat_,*),physcon(*),cocon(0:6,ntmat_,*), + & xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*), + & shcon(0:3,ntmat_,*),alzero(*),orab(7,*),xbody(7,*),cgr(4,*), + & plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), + & xstiff(27,mi(1),*),veold(0:mi(2),*),om,valu2,value,dtime,ttime, + & time +! + kflag=2 + i0=0 + icalccg=0 +! + if(stiffness.and.(.not.mass(1)).and.(.not.buckling)) then + stiffonly(1)=.true. + else + stiffonly(1)=.false. + endif + if(stiffness.and.(.not.mass(2)).and.(.not.buckling)) then + stiffonly(2)=.true. + else + stiffonly(2)=.false. + endif +! +! determining nzl +! + nzl=0 + do i=neq(2),1,-1 + if(icol(i).gt.0) then + nzl=i + exit + endif + enddo +! +! initializing the matrices +! + if(.not.buckling) then + do i=1,neq(2) + ad(i)=0.d0 + enddo + do i=1,nzs(3) + au(i)=0.d0 + enddo + endif +! + if(rhsi) then + do i=1,neq(2) + fext(i)=0.d0 + enddo + endif +c elseif(mass.or.buckling) then + if(mass(1).or.buckling) then + do i=1,neq(1) + adb(i)=0.d0 + enddo + do i=1,nzs(1) + aub(i)=0.d0 + enddo + endif + if(mass(2)) then + do i=neq(1)+1,neq(2) + adb(i)=0.d0 + enddo + do i=nzs(1)+1,nzs(2) + aub(i)=0.d0 + enddo + endif +! + if(rhsi) then +! +! distributed forces (body forces or thermal loads or +! residual stresses or distributed face loads) +! + if((nbody.ne.0).or.(ithermal(1).ne.0).or. + & (iprestr.ne.0).or.(nload.ne.0)) then + idist=1 + else + idist=0 + endif +! + endif +! + if((ithermal(1).le.1).or.(ithermal(1).eq.3)) then +! +! mechanical analysis: loop over all elements +! + ne0=0 + do i=1,ne +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) +c Bernhardi start + if(lakon(i)(1:5).eq.'C3D8I') then + nope=11 + elseif(lakon(i)(4:4).eq.'2') then +c Bernhardi end + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + elseif(lakon(i)(1:2).eq.'ES') then + read(lakon(i)(8:8),'(i1)') nope +! +! local contact spring number +! + if(lakon(i)(7:7).eq.'C') konl(nope+1)=kon(indexe+nope+1) + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + om=0.d0 +! +c if((rhsi).and.(nbody.gt.0).and.(lakon(i)(1:1).ne.'E')) then + if((nbody.gt.0).and.(lakon(i)(1:1).ne.'E')) then +! +! assigning centrifugal forces +! + bodyf(1)=0. + bodyf(2)=0. + bodyf(3)=0. +! + index=i + do + j=ipobody(1,index) + if(j.eq.0) exit + if(ibody(1,j).eq.1) then + om=xbody(1,j) + p1(1)=xbody(2,j) + p1(2)=xbody(3,j) + p1(3)=xbody(4,j) + p2(1)=xbody(5,j) + p2(2)=xbody(6,j) + p2(3)=xbody(7,j) +! +! assigning gravity forces +! + elseif(ibody(1,j).eq.2) then + bodyf(1)=bodyf(1)+xbody(1,j)*xbody(2,j) + bodyf(2)=bodyf(2)+xbody(1,j)*xbody(3,j) + bodyf(3)=bodyf(3)+xbody(1,j)*xbody(4,j) +! +! assigning newton gravity forces +! + elseif(ibody(1,j).eq.3) then + call newton(icalccg,ne,ipkon,lakon,kon,t0,co,rhcon, + & nrhcon,ntmat_,physcon,i,cgr,bodyf,ielmat,ithermal, + & vold,mi) + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif +c write(*,*) 'mafillsm ',i,bodyf(1),bodyf(2),bodyf(3) +! + call e_c3d(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody,s,sm,ff,i, + & nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon, + & alzero,ielmat,ielorien,norien,orab,ntmat_, + & t0,t1,ithermal,vold,iperturb,nelemload,sideload,xload, + & nload,idist,sti,stx,iexpl,plicon, + & nplicon,plkcon,nplkcon,xstiff,npmat_, + & dtime,matname,mi(1),ncmat_,mass(1),stiffness,buckling, + & rhsi,intscheme,ttime,time,istep,iinc,coriolis,xloadold, + & reltime,ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold, + & springarea,nstate_,xstateini,xstate,ne0) +! + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdof(k,node1) +! + do ll=jj,3*nope +! + l=(ll-1)/3+1 + m=ll-3*(l-1) +! + node2=kon(indexe+l) + jdof2=nactdof(m,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + if(stiffonly(1)) then + call add_sm_st(au,ad,jq,irow,jdof1,jdof2, + & s(jj,ll),jj,ll) + else + call add_sm_ei(au,ad,aub,adb,jq,irow,jdof1,jdof2, + & s(jj,ll),sm(jj,ll),jj,ll) + endif + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8+k + else + idof1=jdof1 + idof2=(node2-1)*8+m + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdof(nodempc(2,index),nodempc(1,index)) + value=-coefmpc(index)*s(jj,ll)/coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + if(idof2.ne.0) then + if(stiffonly(1)) then + call add_sm_st(au,ad,jq,irow,idof1, + & idof2,value,i0,i0) + else + valu2=-coefmpc(index)*sm(jj,ll)/ + & coefmpc(ist) +c + if(idof1.eq.idof2) valu2=2.d0*valu2 +c + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1,idof2,value,valu2,i0,i0) + endif + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif +! +! regular DOF / SPC +! + if(rhsi) then + elseif(nmethod.eq.2) then + value=s(jj,ll) + call nident(ikboun,idof2,nboun,id) + icolumn=neq(2)+ilboun(id) + call add_bo_st(au,jq,irow,idof1,icolumn,value) + endif + else + idof1=(node1-1)*8+k + idof2=(node2-1)*8+m + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdof(nodempc(2,index1), + & nodempc(1,index1)) + index2=index1 + do + idof2=nactdof(nodempc(2,index2), + & nodempc(1,index2)) + value=coefmpc(index1)*coefmpc(index2)* + & s(jj,ll)/coefmpc(ist)/coefmpc(ist) + if((idof1.ne.0).and.(idof2.ne.0)) then + if(stiffonly(1)) then + call add_sm_st(au,ad,jq,irow, + & idof1,idof2,value,i0,i0) + else + valu2=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,value,valu2,i0,i0) + endif + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdof(nodempc(2,index1), + & nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdof(nodempc(2,index2), + & nodempc(1,index2)) + value=coefmpc(index1)*coefmpc(index2)* + & s(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + if((idof1.ne.0).and.(idof2.ne.0)) then + if(stiffonly(1)) then + call add_sm_st(au,ad,jq,irow, + & idof1,idof2,value,i0,i0) + else + valu2=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) +c + if(idof1.eq.idof2) valu2=2.d0*valu2 +c + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,value,valu2,i0,i0) + endif + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif +c elseif(((mpc1.eq.1).or.(mpc2.eq.1)).and.rhsi) +c & then +c if(mpc1.eq.1) then +c! +c! MPC id1 / SPC +c! +c call nident(ikboun,idof2,nboun,id2) +c idof2=ilboun(id2) +c ist1=ipompc(id1) +c index1=nodempc(3,ist1) +c if(index1.eq.0) cycle +c elseif(mpc2.eq.1) then +c! +c! MPC id2 / SPC +c! +c call nident(ikboun,idof1,nboun,id1) +c idof1=ilboun(id1) +c ist2=ipompc(id2) +c index2=nodempc(3,ist2) +c if(index2.eq.0) cycle +c endif + endif + endif + enddo +! + if(rhsi) then +! +! distributed forces +! + if(idist.ne.0) then + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8+k + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof1=nactdof(nodempc(2,index), + & nodempc(1,index)) + if(jdof1.ne.0) then + fext(jdof1)=fext(jdof1) + & -coefmpc(index)*ff(jj) + & /coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + fext(jdof1)=fext(jdof1)+ff(jj) + endif + endif +! + enddo + enddo +! + endif + if(ithermal(1).gt.1) then +! +! thermal analysis: loop over all elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + elseif(lakon(i)(1:2).eq.'ES') then + read(lakon(i)(8:8),'(i1)') nope +! +! local contact spring number +! + if(lakon(i)(7:7).eq.'C') konl(nope+1)=kon(indexe+nope+1) + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + call e_c3d_th(co,nk,konl,lakon(i),s,sm, + & ff,i,nmethod,rhcon,nrhcon,ielmat,ielorien,norien,orab, + & ntmat_,t0,t1,ithermal,vold,iperturb,nelemload, + & sideload,xload,nload,idist,iexpl,dtime, + & matname,mi(1),mass(2),stiffness,buckling,rhsi,intscheme, + & physcon,shcon,nshcon,cocon,ncocon,ttime,time,istep,iinc, + & xstiff,xloadold,reltime,ipompc,nodempc,coefmpc,nmpc,ikmpc, + & ilmpc,springarea,plicon,nplicon,npmat_,ncmat_,elcon,nelcon) +! + do jj=1,nope +! + j=jj +c k=0 +! + node1=kon(indexe+j) + jdof1=nactdof(0,node1) +! + do ll=jj,nope +! + l=ll +c m=0 +! + node2=kon(indexe+l) + jdof2=nactdof(0,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + if(stiffonly(2)) then + call add_sm_st(au,ad,jq,irow,jdof1,jdof2, + & s(jj,ll),jj,ll) + else + call add_sm_ei(au,ad,aub,adb,jq,irow,jdof1,jdof2, + & s(jj,ll),sm(jj,ll),jj,ll) + endif + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8 + else + idof1=jdof1 + idof2=(node2-1)*8 + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdof(nodempc(2,index),nodempc(1,index)) + value=-coefmpc(index)*s(jj,ll)/coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + if(idof2.ne.0) then + if(stiffonly(2)) then + call add_sm_st(au,ad,jq,irow,idof1, + & idof2,value,i0,i0) + else + valu2=-coefmpc(index)*sm(jj,ll)/ + & coefmpc(ist) +c + if(idof1.eq.idof2) valu2=2.d0*valu2 +c + call add_sm_ei(au,ad,aub,adb,jq,irow, + & idof1,idof2,value,valu2,i0,i0) + endif + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif +! +! regular DOF / SPC +! + if(rhsi) then + elseif(nmethod.eq.2) then + value=s(jj,ll) + call nident(ikboun,idof2,nboun,id) + icolumn=neq(2)+ilboun(id) + call add_bo_st(au,jq,irow,idof1,icolumn,value) + endif + else + idof1=(node1-1)*8 + idof2=(node2-1)*8 + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdof(nodempc(2,index1), + & nodempc(1,index1)) + index2=index1 + do + idof2=nactdof(nodempc(2,index2), + & nodempc(1,index2)) + value=coefmpc(index1)*coefmpc(index2)* + & s(jj,ll)/coefmpc(ist)/coefmpc(ist) + if((idof1.ne.0).and.(idof2.ne.0)) then + if(stiffonly(2)) then + call add_sm_st(au,ad,jq,irow, + & idof1,idof2,value,i0,i0) + else + valu2=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,value,valu2,i0,i0) + endif + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdof(nodempc(2,index1), + & nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdof(nodempc(2,index2), + & nodempc(1,index2)) + value=coefmpc(index1)*coefmpc(index2)* + & s(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + if((idof1.ne.0).and.(idof2.ne.0)) then + if(stiffonly(2)) then + call add_sm_st(au,ad,jq,irow, + & idof1,idof2,value,i0,i0) + else + valu2=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) +c + if(idof1.eq.idof2) valu2=2.d0*valu2 +c + call add_sm_ei(au,ad,aub,adb,jq, + & irow,idof1,idof2,value,valu2,i0,i0) + endif + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif +c elseif(((mpc1.eq.1).or.(mpc2.eq.1)).and.rhsi) +c & then +c if(mpc1.eq.1) then +c! +c! MPC id1 / SPC +c! +c call nident(ikboun,idof2,nboun,id2) +c idof2=ilboun(id2) +c ist1=ipompc(id1) +c index1=nodempc(3,ist1) +c if(index1.eq.0) cycle +c do +c idof1=nactdof(nodempc(2,index1), +c & nodempc(1,index1)) +c index1=nodempc(3,index1) +c if(index1.eq.0) exit +c enddo +c elseif(mpc2.eq.1) then +c! +c! MPC id2 / SPC +c! +c call nident(ikboun,idof1,nboun,id1) +c idof1=ilboun(id1) +c ist2=ipompc(id2) +c index2=nodempc(3,ist2) +c if(index2.eq.0) cycle +c endif + endif + endif + enddo +! + if(rhsi) then +! +! distributed forces +! + if(idist.ne.0) then + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8 + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof1=nactdof(nodempc(2,index), + & nodempc(1,index)) + if(jdof1.ne.0) then + fext(jdof1)=fext(jdof1) + & -coefmpc(index)*ff(jj) + & /coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + fext(jdof1)=fext(jdof1)+ff(jj) + endif + endif +! + enddo + enddo +! + endif +! + if(rhsi) then +! +! point forces +! + do i=1,nforc + if(ndirforc(i).gt.3) cycle + jdof=nactdof(ndirforc(i),nodeforc(1,i)) + if(jdof.ne.0) then + fext(jdof)=fext(jdof)+xforc(i) + else +! +! node is a dependent node of a MPC: distribute +! the forces among the independent nodes +! (proportional to their coefficients) +! + jdof=8*(nodeforc(1,i)-1)+ndirforc(i) + call nident(ikmpc,jdof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.jdof) then + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof=nactdof(nodempc(2,index),nodempc(1,index)) + if(jdof.ne.0) then + fext(jdof)=fext(jdof)- + & coefmpc(index)*xforc(i)/coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + endif + enddo +! + endif +! +c write(*,'(6(1x,e11.4))') (au(i),i=1,nzs(2)) +c write(*,'(6(1x,e11.4))') (ad(i),i=1,neq(2)) +c write(*,'(6(1x,e11.4))') (aub(i),i=1,nzs(2)) +c write(*,'(6(1x,e11.4))') (adb(i),i=1,neq(2)) +c write(*,'(6(1x,e11.4))') (b(i),i=1,neq(2)) +c write(*,*) 'mafillsm ' +c write(*,'(6(1x,e11.4))') (fext(i),i=1,neq(2)) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafilltlhs.f calculix-ccx-2.3/ccx_2.3/src/mafilltlhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafilltlhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafilltlhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,227 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafilltlhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, + & nactdoh,icolt,jqt,irowt,neqt,nzlt, + & ikmpc,ilmpc,ikboun,ilboun,nzst,adbt,aubt,ipvar,var) +! +! filling the stiffness matrix in spare matrix format (sm) +! + implicit none +! + character*8 lakon(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & icolt(*),jqt(*),ikmpc(*),nzst,nmethod,ipvar(*), + & ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20),irowt(*), + & ipkon(*),nk,ne,nboun,nmpc,neqt,nzlt,i,j,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,node1,node2, + & indexe,nope,i0 +! + real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbt(*),aubt(*), + & var(*),value +! + i0=0 +! +! determining nzlt +! + nzlt=0 + do i=neqt,1,-1 + if(icolt(i).gt.0) then + nzlt=i + exit + endif + enddo +! + do i=1,neqt + adbt(i)=0.d0 + enddo + do i=1,nzst + aubt(i)=0.d0 + enddo +! +! loop over all elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + call e_c3d_tlhs(co,nk,konl,lakon(i),sm,i,ipvar,var) +! + do jj=1,nope +! + node1=kon(indexe+jj) + jdof1=nactdoh(0,node1) +! + do ll=jj,nope +! + node2=kon(indexe+ll) + jdof2=nactdoh(0,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call add_sm_fl(aubt,adbt,jqt,irowt,jdof1,jdof2, + & sm(jj,ll),jj,ll) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8 + else + idof1=jdof1 + idof2=(node2-1)*8 + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdoh(nodempc(2,index),nodempc(1,index)) + if(idof2.ne.0) then + value=-coefmpc(index)*sm(jj,ll)/ + & coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubt,adbt,jqt,irowt, + & idof1,idof2,value,i0,i0) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif + else + idof1=(node1-1)*8 + idof2=(node2-1)*8 + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdoh(nodempc(2,index1), + & nodempc(1,index1)) + index2=index1 + do + idof2=nactdoh(nodempc(2,index2), + & nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + call add_sm_fl(aubt,adbt,jqt, + & irowt,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdoh(nodempc(2,index1), + & nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdoh(nodempc(2,index2), + & nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubt,adbt,jqt, + & irowt,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafilltrhs.f calculix-ccx-2.3/ccx_2.3/src/mafilltrhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafilltrhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafilltrhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,193 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafilltrhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody, + & b,nactdoh,neqt,nmethod,ikmpc,ilmpc,ikboun, + & ilboun,rhcon,nrhcon,ielmat,ntmat_,t0,ithermal,vold,voldcon,nzst, + & dtl,matname,mi,ncmat_,physcon,shcon,nshcon,ttime,time, + & istep,iinc,ibody,xloadold,reltimef,cocon,ncocon,nelemface, + & sideface,nface,compressible,v,voldtu,yy,turbulent,nea,neb, + & dtimef,ipvar,var,ipvarf,varf) +! +! filling the rhs b of the velocity equations (step 1) +! + implicit none +! + character*1 sideface(*) + character*8 lakon(*) + character*20 sideload(*) + character*80 matname(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & nodeforc(2,*),ndirforc(*),nelemload(2,*),nelemface(*),nface, + & ikmpc(*),ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20), + & nrhcon(*),ielmat(*),ipkon(*),nshcon(*),ipobody(2,*), + & nbody,ibody(3,*),ncocon(2,*),compressible,nea,neb,ipvar(*), + & ipvarf(*) +! + integer nk,ne,nboun,nmpc,nforc,nload,neqt,nmethod, + & ithermal,nzst,i,j,idist,jj,id,ist,index,jdof1,idof1, + & node1,kflag,ntmat_,indexe,nope,mi(2),i0,ncmat_,istep,iinc, + & turbulent +! + real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), + & p2(3),bodyf(3),b(*),xloadold(2,*),reltimef,cocon(0:6,ntmat_,*), + & t0(*),vold(0:mi(2),*),voldcon(0:4,*),ff(60),v(0:mi(2),*),yy(*), + & rhcon(0:1,ntmat_,*),physcon(*),voldtu(2,*), + & shcon(0:3,ntmat_,*),xbody(7,*),var(*),varf(*) +! + real*8 om,dtimef,ttime,time,dtl(*) +! + kflag=2 + i0=0 +! + do i=1,neqt + b(i)=0.d0 + enddo +! +! distributed forces (body forces or thermal loads or +! residual stresses or distributed face loads) +! + if((nbody.ne.0).or.(ithermal.ne.0).or. + & (nload.ne.0)) then + idist=1 + else + idist=0 + endif +! + do i=nea,neb +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! +c do j=1,nope +c konl(j)=kon(indexe+j) +c enddo +! + om=0.d0 +! + if(nbody.gt.0) then +! +! assigning centrifugal forces +! + bodyf(1)=0. + bodyf(2)=0. + bodyf(3)=0. +! + index=i + do + j=ipobody(1,index) + if(j.eq.0) exit + if(ibody(1,j).eq.1) then + om=xbody(1,j) + p1(1)=xbody(2,j) + p1(2)=xbody(3,j) + p1(3)=xbody(4,j) + p2(1)=xbody(5,j) + p2(2)=xbody(6,j) + p2(3)=xbody(7,j) +! +! assigning gravity forces +! + elseif(ibody(1,j).eq.2) then + bodyf(1)=bodyf(1)+xbody(1,j)*xbody(2,j) + bodyf(2)=bodyf(2)+xbody(1,j)*xbody(3,j) + bodyf(3)=bodyf(3)+xbody(1,j)*xbody(4,j) + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif +! + call e_c3d_trhs(co,nk,kon(indexe+1),lakon(i),p1,p2,om,bodyf, + & nbody,ff,i,nmethod,rhcon,nrhcon, + & ielmat,ntmat_,vold,voldcon,nelemload, + & sideload,xload,nload,idist,dtimef,matname,mi(1), + & ttime,time,istep,iinc,xloadold,reltimef,shcon,nshcon, + & cocon,ncocon,physcon,nelemface,sideface,nface, + & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,compressible,v, + & voldtu,yy,turbulent,ipvar,var,ipvarf,varf) +! + do jj=1,nope +! + node1=kon(indexe+jj) +c ff(jj)=ff(jj)*dtl(node1)/dtimef + jdof1=nactdoh(0,node1) +! +! distributed forces +! + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8 + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof1=nactdoh(nodempc(2,index), + & nodempc(1,index)) + if(jdof1.ne.0) then + b(jdof1)=b(jdof1) + & -coefmpc(index)*ff(jj) + & /coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + b(jdof1)=b(jdof1)+ff(jj) +! + enddo + enddo +! +! nonlocal time stepping for compressible steady state calculations +! +c if((compressible.eq.1).and.(nmethod.eq.1)) then +c do i=1,nk +c if(nactdoh(0,i).gt.0) then +c b(nactdoh(0,i))=b(nactdoh(0,i))*dtl(i)/dtimef +c endif +c enddo +c endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillv1rhs.f calculix-ccx-2.3/ccx_2.3/src/mafillv1rhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafillv1rhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillv1rhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,232 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillv1rhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody, + & b,nactdoh,icolv,jqv,irowv,neqv,nzlv,nmethod,ikmpc,ilmpc,ikboun, + & ilboun,rhcon,nrhcon,ielmat,ntmat_,t0,ithermal,vold,voldcon,nzsv, + & dtl,matname,mi,ncmat_,physcon,shcon,nshcon,ttime,time, + & istep,iinc,ibody,xloadold,turbulent,voldtu,yy, + & nelemface,sideface,nface,compressible,ne1,ne2,dtimef,ipvar,var, + & ipvarf,varf,sti) +! +! filling the rhs b of the velocity equations (step 1) +! + implicit none +! + integer turbulent,compressible +! + character*1 sideface(*) + character*8 lakon(*) + character*20 sideload(*) + character*80 matname(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & nodeforc(2,*),ndirforc(*),nelemload(2,*),icolv(*),jqv(*), + & ikmpc(*),ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20), + & irowv(*),nrhcon(*),ielmat(*),ipkon(*),nshcon(*),ipobody(2,*), + & nbody,ibody(3,*),nelemface(*),nface,ne1,ne2 +! + integer nk,ne,nboun,nmpc,nforc,nload,neqv,nzlv,nmethod, + & ithermal,nzsv,i,j,k,idist,jj,id,ist,index,jdof1,idof1, + & jdof,node1,kflag,ntmat_,indexe,nope,mi(2),i0,ncmat_,istep,iinc, + & ipvar(*),ipvarf(*) +! + real*8 co(3,*),xboun(*),coefmpc(*),xforc(*),xload(2,*),p1(3), + & p2(3),bodyf(3),b(*),xloadold(2,*),voldtu(2,*),yy(*), + & t0(*),vold(0:mi(2),*),voldcon(0:4,*),ff(60),rhcon(0:1,ntmat_,*), + & physcon(*),shcon(0:3,ntmat_,*),xbody(7,*),var(*),varf(*), + & sti(6,mi(1),*) +! + real*8 om,dtimef,ttime,time,dtl(*) +! + kflag=2 + i0=0 +! + do i=1,neqv + b(i)=0.d0 + enddo +! +! distributed forces (body forces or thermal loads or +! residual stresses or distributed face loads) +! + if((nbody.ne.0).or.(ithermal.ne.0).or. + & (nload.ne.0)) then + idist=1 + else + idist=0 + endif +! + do i=ne1,ne2 +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! +c do j=1,nope +c konl(j)=kon(indexe+j) +c enddo +! + om=0.d0 +! + if(nbody.gt.0) then +! +! assigning centrifugal forces +! + bodyf(1)=0. + bodyf(2)=0. + bodyf(3)=0. +! + index=i + do + j=ipobody(1,index) + if(j.eq.0) exit + if(ibody(1,j).eq.1) then + om=xbody(1,j) + p1(1)=xbody(2,j) + p1(2)=xbody(3,j) + p1(3)=xbody(4,j) + p2(1)=xbody(5,j) + p2(2)=xbody(6,j) + p2(3)=xbody(7,j) +! +! assigning gravity forces +! + elseif(ibody(1,j).eq.2) then + bodyf(1)=bodyf(1)+xbody(1,j)*xbody(2,j) + bodyf(2)=bodyf(2)+xbody(1,j)*xbody(3,j) + bodyf(3)=bodyf(3)+xbody(1,j)*xbody(4,j) + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif +! + call e_c3d_v1rhs(co,nk,kon(indexe+1),lakon(i),p1,p2,om, + & bodyf,nbody,ff,i,nmethod,rhcon,nrhcon,ielmat,ntmat_,vold, + & voldcon,idist,dtimef,matname,mi(1), + & ttime,time,istep,iinc,shcon,nshcon, + & turbulent,voldtu,yy,nelemface,sideface,nface,compressible, + & ipvar,var,ipvarf,varf,sti,ithermal) +! + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) +c ff(jj)=ff(jj)*dtl(node1)/dtimef + jdof1=nactdoh(k,node1) +! +! distributed forces +! + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8+k + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof1=nactdoh(nodempc(2,index), + & nodempc(1,index)) + if(jdof1.ne.0) then + b(jdof1)=b(jdof1) + & -coefmpc(index)*ff(jj) + & /coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + b(jdof1)=b(jdof1)+ff(jj) +! + enddo + enddo +! +! point forces +! + if(ne1.eq.1) then + do i=1,nforc + if(ndirforc(i).gt.3) cycle + jdof=nactdoh(ndirforc(i),nodeforc(1,i)) + if(jdof.ne.0) then + b(jdof)=b(jdof)+xforc(i) + else +! +! node is a dependent node of a MPC: distribute +! the forces among the independent nodes +! (proportional to their coefficients) +! + jdof=8*(nodeforc(1,i)-1)+ndirforc(i) + call nident(ikmpc,jdof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.jdof) then + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof=nactdoh(nodempc(2,index),nodempc(1,index)) + if(jdof.ne.0) then + b(jdof)=b(jdof)- + & coefmpc(index)*xforc(i)/coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + endif + enddo + endif +! +! nonlocal time stepping for compressible steady state calculations +! +c if((compressible.eq.1).and.(nmethod.eq.1)) then +c do i=1,nk +c do j=1,3 +c if(nactdoh(j,i).gt.0) then +c b(nactdoh(j,i))=b(nactdoh(j,i))*dtl(i)/dtimef +c endif +c enddo +c enddo +c endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillv2rhs.f calculix-ccx-2.3/ccx_2.3/src/mafillv2rhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafillv2rhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillv2rhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,131 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillv2rhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, + & b,nactdoh,icolv,jqv,irowv,neqv,nzlv,nmethod,ikmpc,ilmpc,ikboun, + & ilboun,vold,nzsv,dtl,v,theta2,iexplicit,nea,neb,mi,dtimef, + & ipvar,var,ipvarf,varf) +! +! filling the rhs b of the velocity equations (step 3) +! + implicit none +! + character*8 lakon(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & icolv(*),jqv(*),ikmpc(*),ilmpc(*),ikboun(*),ilboun(*), + & nactdoh(0:4,*),konl(20),irowv(*),ipkon(*),nea,neb,mi(2), + & ipvar(*),ipvarf(*) +! + integer nk,ne,nboun,nmpc,neqv,nzlv,nmethod,nzsv,i,j,k,jj, + & id,ist,index,jdof1,idof1,iexplicit,node1,kflag,indexe,nope,i0 +! + real*8 co(3,*),xboun(*),coefmpc(*),b(*),v(0:mi(2),*),theta2, + & vold(0:mi(2),*),ff(60),dtimef,dtl(*),var(*),varf(*) +! + kflag=2 + i0=0 +! + do i=1,neqv + b(i)=0.d0 + enddo +! + do i=nea,neb +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! +c do j=1,nope +c konl(j)=kon(indexe+j) +c enddo +! + call e_c3d_v2rhs(co,nk,kon(indexe+1),lakon(i), + & ff,i,nmethod,vold,v,dtimef,theta2,iexplicit,mi, + & ipvar,var,ipvarf,varf) +! + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) +c ff(jj)=ff(jj)*dtl(node1)/dtimef + jdof1=nactdoh(k,node1) +! +! distributed forces +! + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8+k + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof1=nactdoh(nodempc(2,index), + & nodempc(1,index)) + if(jdof1.ne.0) then + b(jdof1)=b(jdof1) + & -coefmpc(index)*ff(jj) + & /coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + b(jdof1)=b(jdof1)+ff(jj) +! + enddo + enddo +! +! nonlocal time stepping for compressible steady state calculations +! +c if((iexplicit.eq.1).and.(nmethod.eq.1)) then +c do i=1,nk +c do j=1,3 +c if(nactdoh(j,i).gt.0) then +c b(nactdoh(j,i))=b(nactdoh(j,i))*dtl(i)/dtimef +c endif +c enddo +c enddo +c endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/mafillvlhs.f calculix-ccx-2.3/ccx_2.3/src/mafillvlhs.f --- calculix-ccx-2.1/ccx_2.3/src/mafillvlhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mafillvlhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,242 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mafillvlhs(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,nmpc, + & nactdoh,icolv,jqv,irowv,neqv,nzlv, + & ikmpc,ilmpc,ikboun,ilboun,nzsv,adbv,aubv,ipvar,var) +! +! filling the stiffness matrix in spare matrix format (sm) +! + implicit none +! + character*8 lakon(*) +! + integer kon(*),nodeboun(*),ndirboun(*),ipompc(*),nodempc(3,*), + & icolv(*),jqv(*),ikmpc(*),nzsv,nmethod, + & ilmpc(*),ikboun(*),ilboun(*),nactdoh(0:4,*),konl(20),irowv(*), + & ipkon(*),ipvar(*) +! + integer nk,ne,nboun,nmpc,neqv,nzlv,i,j,k,l,m,jj, + & ll,id,id1,id2,ist,ist1,ist2,index,jdof1,jdof2,idof1,idof2, + & mpc1,mpc2,index1,index2,node1,node2, + & indexe,nope,i0 +! + real*8 co(3,*),xboun(*),coefmpc(*),sm(60,60),adbv(*),aubv(*), + & var(*) +! + real*8 value +! +c write(*,*) 'print nactdoh' +c do i=1,nk +c write(*,*) i,(nactdoh(j,i),j=0,4) +c enddo +! + i0=0 +! +! determining nzlv +! + nzlv=0 + do i=neqv,1,-1 + if(icolv(i).gt.0) then + nzlv=i + exit + endif + enddo +! + do i=1,neqv + adbv(i)=0.d0 + enddo + do i=1,nzsv + aubv(i)=0.d0 + enddo +! +! loop over all fluid elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + call e_c3d_vlhs(co,nk,konl,lakon(i),sm,i,ipvar,var) +! + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdoh(k,node1) +! + do ll=jj,3*nope +! + l=(ll-1)/3+1 + m=ll-3*(l-1) +! + node2=kon(indexe+l) + jdof2=nactdoh(m,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call add_sm_fl(aubv,adbv,jqv,irowv,jdof1,jdof2, + & sm(jj,ll),jj,ll) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*8+k + else + idof1=jdof1 + idof2=(node2-1)*8+m + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + idof2=nactdoh(nodempc(2,index),nodempc(1,index)) + if(idof2.ne.0) then + value=-coefmpc(index)*sm(jj,ll)/ + & coefmpc(ist) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubv,adbv,jqv,irowv, + & idof1,idof2,value,i0,i0) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif + else + idof1=(node1-1)*8+k + idof2=(node2-1)*8+m + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + idof1=nactdoh(nodempc(2,index1), + & nodempc(1,index1)) + index2=index1 + do + idof2=nactdoh(nodempc(2,index2), + & nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist)/coefmpc(ist) + call add_sm_fl(aubv,adbv,jqv, + & irowv,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + idof1=nactdoh(nodempc(2,index1), + & nodempc(1,index1)) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + idof2=nactdoh(nodempc(2,index2), + & nodempc(1,index2)) + if((idof1.ne.0).and.(idof2.ne.0)) then + value=coefmpc(index1)*coefmpc(index2)* + & sm(jj,ll)/coefmpc(ist1)/coefmpc(ist2) + if(idof1.eq.idof2) value=2.d0*value + call add_sm_fl(aubv,adbv,jqv, + & irowv,idof1,idof2,value,i0,i0) + endif +! + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/Makefile calculix-ccx-2.3/ccx_2.3/src/Makefile --- calculix-ccx-2.1/ccx_2.3/src/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/Makefile 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,33 @@ + +CFLAGS = -Wall -O -I ../../../SPOOLES.2.2 -DARCH="Linux" -DSPOOLES -DARPACK -DMATRIXSTORAGE +FFLAGS = -Wall -O -fopenmp + +CC=cc +FC=gfortran + +.c.o : + $(CC) $(CFLAGS) -c $< +.f.o : + $(FC) $(FFLAGS) -c $< + +include Makefile.inc + +SCCXMAIN = ccx_2.3.c + +OCCXF = $(SCCXF:.f=.o) +OCCXC = $(SCCXC:.c=.o) +OCCXMAIN = $(SCCXMAIN:.c=.o) + +DIR=../../../SPOOLES.2.2 + +LIBS = \ + $(DIR)/spooles.a \ + ../../../ARPACK/libarpack_INTEL.a \ + -lm -lc + +ccx_2.3: $(OCCXMAIN) ccx_2.3.a $(LIBS) + ./date.pl; $(CC) $(CFLAGS) -c ccx_2.3.c; $(FC) -Wall -O -o $@ $(OCCXMAIN) ccx_2.3.a -lpthread $(LIBS) + +ccx_2.3.a: $(OCCXF) $(OCCXC) + ar vr $@ $? + diff -Nru calculix-ccx-2.1/ccx_2.3/src/Makefile.inc calculix-ccx-2.3/ccx_2.3/src/Makefile.inc --- calculix-ccx-2.1/ccx_2.3/src/Makefile.inc 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/Makefile.inc 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,567 @@ +SCCXF = \ +absolute_relative.f \ +addimdnodecload.f \ +addimdnodedload.f \ +addizdofcload.f \ +addizdofdload.f \ +add_bo_st.f \ +add_pr.f \ +add_sm_ei.f \ +add_sm_fl.f \ +add_sm_st.f \ +add_sm_st_as.f \ +addimd.f \ +addimdnodedof.f \ +allocation.f \ +allocont.f \ +amplitudes.f \ +angsum.f \ +anisonl.f \ +anisotropic.f \ +applybounk.f \ +applybounp.f \ +applybounpgas.f \ +applybount.f \ +applybounv.f \ +approxplane.f \ +attach.f \ +attachline.f \ +beamsections.f \ +bodyadd.f \ +bodyforce.f \ +bounadd.f \ +boundaries.f \ +bounrem.f \ +buckles.f \ +calcmach.f \ +calinput.f \ +carbon_seal.f \ +cd_bleedtapping.f \ +cd_bragg.f \ +cd_chamfer.f \ +cd_lab_1spike.f \ +cd_lab_cdrzcdlab.f \ +cd_lab_correction.f \ +cd_lab_honeycomb.f \ +cd_lab_radius.f \ +cd_lab_reynolds.f \ +cd_lab_straight.f \ +cd_lichtarowicz.f \ +cd_Mcgreehan_Schotsch.f \ +cd_ms_ms.f \ +cd_own_albers.f \ +cd_pk_albers.f \ +cd_pk_ms.f \ +cd_preswirlnozzle.f \ +cfdconv.f \ +cflux.f \ +cfluxes.f \ +changedepterm.f \ +changefrictions.f \ +characteristic.f \ +checkarpackcs.f \ +checkslavevertex.f \ +checktime.f \ +checktriaedge.f \ +checktriavertex.f \ +chksurf.f \ +cident.f \ +cident20.f \ +cload.f \ +cloads.f \ +closefile.f \ +compdt.f \ +conductivities.f \ +contactdampings.f \ +contactpairs.f \ +contactprints.f \ +controlss.f \ +couptempdisps.f \ +cp_corrected.f \ +createbdentry.f \ +createddentry.f \ +creategap.f \ +createinum.f \ +createmddof.f \ +creep.f \ +creeps.f \ +cubic.f \ +cubtri.f \ +cychards.f \ +cycsymmods.f \ +dashdamp.f \ +dashforc.f \ +dashpots.f \ +datest.f \ +ddeabm.f \ +ddebdf.f \ +dderkf.f \ +defplasticities.f \ +defplas.f \ +densities.f \ +depvars.f \ +deuldlag.f \ +dflux.f \ +dfluxes.f \ +dgesv.f \ +diamtr.f \ +distattach.f \ +distattachline.f \ +distributedcouplings.f \ +dKdm.f \ +dKdp.f \ +dKdt.f \ +dKdX.f \ +dload.f \ +dloads.f \ +dot.f \ +dqag.f \ +dredu.f \ +drfftf.f \ +dsort.f \ +dsptri.f \ +dualshape4q.f \ +dualshape8q.f \ +dualshape3tri.f \ +dualshape6tri.f \ +dynamics.f \ +dynamic_viscosity.f \ +dynamic_viscosity_oil.f \ +dynresults.f \ +elastics.f \ +elements.f \ +elprints.f \ +enthalpy.f \ +envtemp.f \ +equationcheck.f \ +equations.f \ +estimator.f \ +expansions.f \ +extrapolate.f \ +e_c3d.f \ +e_c3d_1lhs.f \ +e_c3d_3lhs.f \ +e_c3d_krhs.f \ +e_c3d_plhs.f \ +e_c3d_prhs.f \ +e_c3d_rhs.f \ +e_c3d_rhs_th.f \ +e_c3d_th.f \ +e_c3d_tlhs.f \ +e_c3d_trhs.f \ +e_c3d_vlhs.f \ +e_c3d_v1rhs.f \ +e_c3d_v2rhs.f \ +e_damp.f \ +faceprints.f \ +fcrit.f \ +fillknotmpc.f \ +film.f \ +films.f \ +findsurface.f \ +finpro.f \ +flowoutput.f \ +flowresult.f \ +fluidconstants.f \ +fluidsections.f \ +flux.f \ +forcadd.f \ +frd.f \ +frdfluid.f \ +frdheader.f \ +frdscalar.f \ +frdset.f \ +frdtensor.f \ +frdvector.f \ +frdvectorcomp.f \ +frequencies.f \ +friction_coefficient.f \ +frictions.f \ +fridaforc.f \ +fsub.f \ +fsuper.f \ +gapcon.f \ +gapconductances.f \ +gaps.f \ +gasmechbc.f \ +gaspipe.f \ +gaspipe_fanno.f \ +gen3dboun.f \ +gen3dconnect.f \ +gen3delem.f \ +gen3dforc.f \ +gen3dfrom1d.f \ +gen3dfrom2d.f \ +gen3dmpc.f \ +gen3dnor.f \ +gen3dprop.f \ +gen3dsurf.f \ +gen3dtemp.f \ +gencontelem.f \ +gencontrel.f \ +generatecycmpcs.f \ +genfirstactif.f \ +genislavactdof.f \ +genmodes.f \ +gennactdofinv.f \ +genran.f \ +gentiedmpc.f \ +getnewline.f \ +graph.f \ +hcrit.f \ +headings.f \ +heattransfers.f \ +hgforce.f \ +hgstiffness.f \ +hns.f \ +hybsvd.f \ +hyperelastics.f \ +hyperfoams.f \ +ident.f \ +ident2.f \ +identamta.f \ +identifytiedface.f \ +includefilename.f \ +incplas.f \ +initialcfd.f \ +initialconditions.f \ +initialnet.f \ +inputerror.f \ +inputinfo.f \ +inputwarning.f \ +interpol_alfa2.f \ +isorti.f \ +isortic.f \ +isortid.f \ +isortiddc1.f \ +isortiddc2.f \ +isortii.f \ +isort2i.f \ +isortiid.f \ +keystart.f \ +knotmpc.f \ +label.f \ +labyrinth.f \ +lab_straight_ppkrit.f \ +limit_case_calc.f \ +linel.f \ +linkdissimilar.f \ +lintemp.f \ +lintemp_th.f \ +liquidchannel.f \ +liquidpipe.f \ +liquidpump.f \ +loadadd.f \ +loadaddp.f \ +loadaddt.f \ +lump.f \ +mafill1lhs.f \ +mafill3lhs.f \ +mafilldm.f \ +mafillklhs.f \ +mafillkrhs.f \ +mafillnet.f \ +mafillplhs.f \ +mafillprhs.f \ +mafillsm.f \ +mafillsmcs.f \ +mafillsmas.f \ +mafilltlhs.f \ +mafilltrhs.f \ +mafillvlhs.f \ +mafillv1rhs.f \ +mafillv2rhs.f \ +map3dto1d2d.f \ +map3dto1d2d_v.f \ +materialdata_cond.f \ +materialdata_cp.f \ +materialdata_cp_sec.f \ +materialdata_dvi.f \ +materialdata_me.f \ +materialdata_rho.f \ +materialdata_sp.f \ +materialdata_tg.f \ +materialdata_th.f \ +materials.f \ +mechmodel.f \ +modaldampings.f \ +modaldynamics.f \ +modelchanges.f \ +moehring.f \ +mpcrem.f \ +mpcs.f \ +mult.f \ +multistages.f \ +networkextrapolate.f \ +nident.f \ +nident2.f \ +nidentk.f \ +near2d.f \ +near3d.f \ +neartriangle.f \ +neartriangle2.f \ +newton.f \ +noanalysis.f \ +nodalthicknesses.f \ +nodeprints.f \ +nodes.f \ +nodestiedface.f \ +noelfiles.f \ +noelsets.f \ +nonlinmpc.f \ +normals.f \ +norshell6.f \ +norshell8.f \ +number.f \ +onedint.f \ +onf.f \ +op.f \ +opcs.f \ +openfile.f \ +opnonsym.f \ +opnonsymt.f \ +orientations.f \ +orifice.f \ +orthonl.f \ +orthotropic.f \ +out.f \ +parser.f \ +patch.f \ +physicalconstants.f \ +pk_cdc_cl1.f \ +pk_cdc_cl3.f \ +pk_cdc_cl3a.f \ +pk_cdc_cl3b.f \ +pk_cdc_cl3d.f \ +pk_cdi_noz.f \ +pk_cdi_r.f \ +pk_cdi_rl.f \ +pk_cdi_se.f \ +pk_y0_yg.f \ +planempc.f \ +plane3.f \ +plane4.f \ +plastics.f \ +plcopy.f \ +plinterpol.f \ +plmix.f \ +polynom.f \ +precfd.f \ +presgradient.f \ +pretensionsections.f \ +printout.f \ +printoutelem.f \ +printoutface.f \ +printoutint.f \ +printoutnode.f \ +profil.f \ +pt2_lim_calc.f \ +pt2zpt1_crit.f \ +radiate.f \ +radiates.f \ +radmatrix.f \ +radresult.f \ +ranewr.f \ +rcavi.f \ +rcavi2.f \ +rcavi_cp_lt.f \ +rcavi_cp_nt.f \ +rearrange.f \ +rectcyl.f \ +rectcylexp.f \ +rectcylvi.f \ +renumber.f \ +restartread.f \ +restarts.f \ +restartshort.f \ +restartwrite.f \ +restrictor.f \ +resultnet.f \ +results.f \ +resultsk.f \ +resultsp.f \ +resultst.f \ +resultsv1.f \ +resultsv2.f \ +rhs.f \ +rigidbodies.f \ +rigidmpc.f \ +rimseal.f \ +rimseal_calc.f \ +rootls.f \ +rs.f \ +rubber.f \ +saxpb.f \ +scavenge_pump.f \ +sdvini.f \ +selcycsymmods.f \ +shape3l.f \ +shape3tri.f \ +shape4q.f \ +shape4tet.f \ +shape6tri.f \ +shape6w.f \ +shape8h.f \ +shape8hr.f \ +shape8hu.f \ +shape8q.f \ +shape10tet.f \ +shape15w.f \ +shape20h.f \ +shape20h_ax.f \ +shape20h_pl.f \ +shellsections.f \ +sigini.f \ +skip.f \ +slavintmortar.f \ +smooth.f \ +smoothshock.f \ +solidsections.f \ +solveeq.f \ +spcmatch.f \ +specificgasconstants.f \ +specificheats.f \ +splitline.f \ +springs.f \ +springforc.f \ +springforc_th.f \ +springstiff.f \ +springstiff_th.f \ +statics.f \ +steadystatedynamics.f \ +steps.f \ +stiff2mat.f \ +stop.f \ +storeresidual.f \ +str2mat.f \ +straighteq2d.f \ +straighteq3d.f \ +straightmpc.f \ +subspace.f \ +surfacebehaviors.f \ +surfaceinteractions.f \ +surfaces.f \ +temperatures.f \ +tempload.f \ +temploaddiff.f \ +temploadmodal.f \ +thermmodel.f \ +tiefaccont.f \ +ties.f \ +timepointss.f \ +transformatrix.f \ +transforms.f \ +treattriangle.f \ +trianeighbor.f \ +triangucont.f \ +triangulate.f \ +ts_calc.f \ +tt_calc.f \ +twodint.f \ +two_phase_flow.f \ +uamplitude.f \ +uboun.f \ +ucreep.f \ +ufaceload.f \ +uhardening.f \ +umat.f \ +umatht.f \ +umat_abaqus.f \ +umat_abaqusnl.f \ +umat_aniso_creep.f \ +umat_aniso_plas.f \ +umat_elastic_fiber.f \ +umat_gurson.f \ +umat_ideal_gas.f \ +umat_iso_creep.f \ +umat_lin_iso_el.f \ +umat_main.f \ +umat_single_crystal.f \ +umat_user.f \ +umpc_dist.f \ +umpc_gap.f \ +umpc_mean_rot.f \ +umpc_user.f \ +uncouptempdisps.f \ +uout.f \ +updatecfd.f \ +updatecomp.f \ +updatecont.f \ +usermaterials.f \ +usermpc.f \ +utemp.f \ +valuesatinf.f \ +viewfactors.f \ +viscos.f \ +vortex.f \ +wcoef.f \ +writeboun.f \ +writebv.f \ +writeev.f \ +writeevcs.f \ +writehe.f \ +writeim.f \ +writeinput.f \ +writematrix.f \ +writempc.f \ +writepf.f \ +writere.f \ +writeset.f \ +writesummary.f \ +zeta_calc.f + +SCCXC = \ +add_rect.c \ +arpack.c \ +arpackbu.c \ +arpackcs.c \ +bdfill.c \ +calcresidual.c \ +calcshapef.c \ +cascade.c \ +checkconvergence.c \ +checkconvnet.c \ +checkinclength.c \ +compfluid.c \ +contact.c \ +contactmortar.c \ +contactstress.c \ +dfdbj.c \ +dyna.c \ +dynacont.c \ +dynboun.c \ +expand.c \ +frdcyc.c \ +gencontmpc.c \ +inicont.c \ +insert.c \ +insertas.c \ +insertas_ws.c \ +mastruct.c \ +mastructcs.c \ +mastructf.c \ +matrixstorage.c \ +multimortar.c \ +multi_rect.c \ +multi_rectv.c \ +multi_scal.c \ +nonlingeo.c \ +pardiso.c \ +pcgsolver.c \ +prediction.c \ +preiter.c \ +prespooles.c \ +radcyc.c \ +radflowload.c \ +readinput.c \ +remastruct.c \ +remcontmpc.c \ +sgi.c \ +spooles.c \ +steadystate.c \ +storecontactdof.c \ +strcmp1.c \ +strcpy1.c \ +tau.c \ +tiedcontact.c \ +u_calloc.c diff -Nru calculix-ccx-2.1/ccx_2.3/src/Makefile_MT calculix-ccx-2.3/ccx_2.3/src/Makefile_MT --- calculix-ccx-2.1/ccx_2.3/src/Makefile_MT 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/Makefile_MT 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,34 @@ + +CFLAGS = -Wall -O3 -I ../../../SPOOLES.2.2 -DARCH="Linux" -DSPOOLES -DARPACK -DMATRIXSTORAGE -DUSE_MT=1 +FFLAGS = -Wall -O3 + +CC=cc +FC=gfortran + +.c.o : + $(CC) $(CFLAGS) -c $< +.f.o : + $(FC) $(FFLAGS) -c $< + +include Makefile.inc + +SCCXMAIN = ccx_2.3.c + +OCCXF = $(SCCXF:.f=.o) +OCCXC = $(SCCXC:.c=.o) +OCCXMAIN = $(SCCXMAIN:.c=.o) + +DIR=../../../SPOOLES.2.2 + +LIBS = \ + $(DIR)/MT/src/spoolesMT.a \ + $(DIR)/spooles.a \ + ../../../ARPACK/libarpack_INTEL.a \ + -lpthread -lm + +ccx_2.3_MT: $(OCCXMAIN) ccx_2.3_MT.a $(LIBS) + ./date.pl; $(CC) $(CFLAGS) -c ccx_2.3.c; $(FC) -Wall -O3 -o $@ $(OCCXMAIN) ccx_2.3_MT.a $(LIBS) + +ccx_2.3_MT.a: $(OCCXF) $(OCCXC) + ar vr $@ $? + diff -Nru calculix-ccx-2.1/ccx_2.3/src/map3dto1d2d.f calculix-ccx-2.3/ccx_2.3/src/map3dto1d2d.f --- calculix-ccx-2.1/ccx_2.3/src/map3dto1d2d.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/map3dto1d2d.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,461 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine map3dto1d2d(yn,ipkon,inum,kon,lakon,nfield,nk, + & ne,cflag,co,vold,force,mi) +! +! interpolates 3d field nodal values to 1d/2d nodal locations +! +! the number of internal state variables is limited to 999 +! (cfr. array field) +! + implicit none +! + logical force +! + character*1 cflag + character*8 lakon(*),lakonl +! + integer ipkon(*),inum(*),kon(*),ne,indexe,nfield,nk,i,j,k,l,m, + & node3(8,3),node6(3,6),node8(3,8),node2d,node3d,indexe2d,ne1d2d, + & node3m(8,3),node(8),m1,m2,nodea,nodeb,nodec,iflag,mi(2) +! + real*8 yn(nfield,*),cg(3),p(3),pcg(3),t(3),xl(3,8),shp(7,8), + & xsj(3),e1(3),e2(3),e3(3),s(6),dd,xi,et,co(3,*),xs(3,7), + & vold(0:mi(2),*),ratioe(3) +! + include "gauss.f" +! +c data node3 /1,4,8,5,9,11,15,13,2,3,7,6/ + data node3 /1,4,8,5,12,20,16,17,9,11,15,13, + & 0,0,0,0,2,3,7,6,10,19,14,18/ + data node3m /1,5,8,4,17,16,20,12, + & 0,0,0,0,0,0,0,0, + & 3,7,6,2,19,14,18,10/ +c data node6 /1,4,2,5,3,6,7,10,8,11,9,12/ +c data node8 /1,5,2,6,3,7,4,8,9,13,10,14,11,15,12,16/ + data node6 /1,13,4,2,14,5,3,15,6,7,0,10,8,0,11,9,0,12/ + data node8 /1,17,5,2,18,6,3,19,7,4,20,8,9,0,13,10,0,14, + & 11,0,15,12,0,16/ + data ratioe /0.16666666666667d0,0.66666666666666d0, + & 0.16666666666667d0/ + data iflag /2/ +! +! removing any results in 1d/2d nodes +! + ne1d2d=0 +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + lakonl=lakon(i) + if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'I').or. + & (lakonl(1:1).ne.'C')) cycle + ne1d2d=1 + indexe=ipkon(i) +! +! inactivating the 3d expansion nodes of 1d/2d elements +! + do j=1,20 + inum(kon(indexe+j))=0 + enddo +! + if(lakonl(4:5).eq.'15') then + indexe2d=indexe+15 + do j=1,6 + node2d=kon(indexe2d+j) + inum(node2d)=0 + do k=1,nfield + yn(k,node2d)=0.d0 + enddo + enddo + elseif(lakonl(7:7).eq.'B') then + indexe2d=indexe+20 + do j=1,3 + node2d=kon(indexe2d+j) + inum(node2d)=0 + do k=1,nfield + yn(k,node2d)=0.d0 + enddo + enddo + else + indexe2d=indexe+20 + do j=1,8 + node2d=kon(indexe2d+j) + inum(node2d)=0 + do k=1,nfield + yn(k,node2d)=0.d0 + enddo + enddo + endif +! + enddo +! +! if no 1d/2d elements return +! + if(ne1d2d.eq.0) return +! +! interpolation of 3d results on 1d/2d nodes +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + lakonl=lakon(i) + if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'I').or. + & (lakonl(1:1).ne.'C')) cycle + indexe=ipkon(i) +! + if(lakonl(4:5).eq.'15') then + indexe2d=indexe+15 + do j=1,6 + node2d=kon(indexe2d+j) + inum(node2d)=inum(node2d)-1 + if(.not.force) then +! +! taking the mean across the thickness +! + if(j.le.3) then +! +! end nodes: weights 1/6,2/3 and 1/6 +! + do l=1,3 + node3d=kon(indexe+node6(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+ + & yn(k,node3d)*ratioe(l) + enddo + enddo + else +! +! middle nodes: weights 1/2,1/2 +! + do l=1,3,2 + node3d=kon(indexe+node6(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+yn(k,node3d)/2.d0 + enddo + enddo + endif + else +! +! forces must be summed +! + if(j.le.3) then +! +! end nodes +! + do l=1,3 + node3d=kon(indexe+node6(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+yn(k,node3d) + enddo + enddo + else +! +! middle nodes +! + do l=1,3,2 + node3d=kon(indexe+node6(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+yn(k,node3d) + enddo + enddo + endif + endif + enddo + elseif(lakonl(7:7).eq.'B') then + indexe2d=indexe+20 + if(cflag.ne.'M') then +! +! mean values for beam elements +! + do j=1,3 + node2d=kon(indexe2d+j) + if(.not.force) then +! +! mean value of vertex values +! + do l=1,4 + inum(node2d)=inum(node2d)-1 + node3d=kon(indexe+node3(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+yn(k,node3d) + enddo + enddo + else +! +! forces must be summed across the section +! + inum(node2d)=inum(node2d)-1 + if(j.ne.2) then + do l=1,8 + node3d=kon(indexe+node3(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+yn(k,node3d) + enddo + enddo + else + do l=1,4 + node3d=kon(indexe+node3(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+yn(k,node3d) + enddo + enddo + endif + endif + enddo + else +! +! section forces for beam elements +! + do j=1,3,2 + node2d=kon(indexe2d+j) + inum(node2d)=inum(node2d)-1 +! +! coordinates of the nodes belonging to the section +! + do l=1,8 + node(l)=kon(indexe+node3m(l,j)) + do m=1,3 + xl(m,l)=co(m,node(l))+vold(m,node(l)) + enddo + enddo +! +! center of gravity and unit vectors 1 and 2 +! + do m=1,3 + cg(m)=(xl(m,6)+xl(m,8))/2.d0 + if(j.eq.1) then + e1(m)=(xl(m,8)-xl(m,6)) + else + e1(m)=(xl(m,6)-xl(m,8)) + endif + e2(m)=(xl(m,7)-xl(m,5)) + enddo +! +! normalizing e1 +! + dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3)) + do m=1,3 + e1(m)=e1(m)/dd + enddo +! +! making sure that e2 is orthogonal to e1 +! + dd=e1(1)*e2(1)+e1(2)*e2(2)+e1(3)*e2(3) + do m=1,3 + e2(m)=e2(m)-dd*e1(m) + enddo +! +! normalizing e2 +! + dd=dsqrt(e2(1)*e2(1)+e2(2)*e2(2)+e2(3)*e2(3)) + do m=1,3 + e2(m)=e2(m)/dd + enddo +! +! e3 = e1 x e2 for j=3, e3 = e2 x e1 for j=1 +! + if(j.eq.1) then + e3(1)=e2(2)*e1(3)-e1(2)*e2(3) + e3(2)=e2(3)*e1(1)-e1(3)*e2(1) + e3(3)=e2(1)*e1(2)-e1(1)*e2(2) + else + e3(1)=e1(2)*e2(3)-e2(2)*e1(3) + e3(2)=e1(3)*e2(1)-e2(3)*e1(1) + e3(3)=e1(1)*e2(2)-e2(1)*e1(2) + endif +! +! loop over the integration points (2x2) +! + do l=1,4 + xi=gauss2d2(1,l) + et=gauss2d2(2,l) + call shape8q(xi,et,xl,xsj,xs,shp,iflag) +! +! local stress tensor +! + do m1=1,6 + s(m1)=0.d0 + do m2=1,8 + s(m1)=s(m1)+shp(4,m2)*yn(m1,node(m2)) + enddo + enddo +! +! local coordinates +! + do m1=1,3 + p(m1)=0.d0 + do m2=1,8 + p(m1)=p(m1)+shp(4,m2)*xl(m1,m2) + enddo + pcg(m1)=p(m1)-cg(m1) + enddo +! +! local stress vector on section +! + t(1)=s(1)*xsj(1)+s(4)*xsj(2)+s(5)*xsj(3) + t(2)=s(4)*xsj(1)+s(2)*xsj(2)+s(6)*xsj(3) + t(3)=s(5)*xsj(1)+s(6)*xsj(2)+s(3)*xsj(3) +! +! section forces +! + yn(1,node2d)=yn(1,node2d)+ + & (e1(1)*t(1)+e1(2)*t(2)+e1(3)*t(3)) + yn(2,node2d)=yn(2,node2d)+ + & (e2(1)*t(1)+e2(2)*t(2)+e2(3)*t(3)) + yn(3,node2d)=yn(3,node2d)+ + & (e3(1)*t(1)+e3(2)*t(2)+e3(3)*t(3)) +! +! section moments +! +! about beam axis +! + yn(4,node2d)=yn(4,node2d)+ + & (e3(1)*pcg(2)*t(3)+e3(2)*pcg(3)*t(1)+ + & e3(3)*pcg(1)*t(2)-e3(3)*pcg(2)*t(1)- + & e3(1)*pcg(3)*t(2)-e3(2)*pcg(1)*t(3)) +! +! about 2-direction +! + yn(5,node2d)=yn(5,node2d)+ + & (e2(1)*pcg(2)*t(3)+e2(2)*pcg(3)*t(1)+ + & e2(3)*pcg(1)*t(2)-e2(3)*pcg(2)*t(1)- + & e2(1)*pcg(3)*t(2)-e2(2)*pcg(1)*t(3)) +! +! about 1-direction +! + yn(6,node2d)=yn(6,node2d)+ + & (e1(1)*pcg(2)*t(3)+e1(2)*pcg(3)*t(1)+ + & e1(3)*pcg(1)*t(2)-e1(3)*pcg(2)*t(1)- + & e1(1)*pcg(3)*t(2)-e1(2)*pcg(1)*t(3)) +! +! components 5 and 6 are switched in the frd +! format, so the final order is beam axis, +! 1-direction and 2-direction, or s12, s23 and s31 +! + enddo + enddo +! + endif + else + indexe2d=indexe+20 + do j=1,8 + node2d=kon(indexe2d+j) + inum(node2d)=inum(node2d)-1 + if(.not.force) then +! +! taking the mean across the thickness +! + if(j.le.4) then +! +! end nodes: weights 1/6,2/3 and 1/6 +! + do l=1,3 + node3d=kon(indexe+node8(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+ + & yn(k,node3d)*ratioe(l) + enddo + enddo + else +! +! middle nodes: weights 1/2,1/2 +! + do l=1,3,2 + node3d=kon(indexe+node8(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+yn(k,node3d)/2.d0 + enddo + enddo + endif + else +! +! forces must be summed +! + if(j.le.4) then +! +! end nodes +! + do l=1,3 + node3d=kon(indexe+node8(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+yn(k,node3d) + enddo + enddo + else +! +! middle nodes +! + do l=1,3,2 + node3d=kon(indexe+node8(l,j)) + do k=1,nfield + yn(k,node2d)=yn(k,node2d)+yn(k,node3d) + enddo + enddo + endif + endif + enddo + endif +! + enddo +! +! taking the mean of nodal contributions coming from different +! elements having the node in common +! + do i=1,nk + if(inum(i).lt.0) then + inum(i)=-inum(i) + do j=1,nfield + yn(j,i)=yn(j,i)/inum(i) + enddo + endif + enddo +! +! beam section forces in the middle nodes +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + lakonl=lakon(i) + if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'I').or. + & (lakonl(1:1).ne.'C')) cycle + indexe=ipkon(i) +! + if(lakonl(7:7).eq.'B') then + indexe2d=indexe+20 + if(cflag.eq.'M') then +! +! section forces in the middle node are the mean +! of those in the end nodes +! + nodea=kon(indexe2d+1) + nodeb=kon(indexe2d+2) + nodec=kon(indexe2d+3) + inum(nodeb)=1 + do j=1,6 + yn(j,nodeb)=yn(j,nodeb)+(yn(j,nodea)+yn(j,nodec))/2.d0 + enddo +! + endif + endif +! + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/map3dto1d2d_v.f calculix-ccx-2.3/ccx_2.3/src/map3dto1d2d_v.f --- calculix-ccx-2.1/ccx_2.3/src/map3dto1d2d_v.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/map3dto1d2d_v.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,214 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine map3dto1d2d_v(yn,ipkon,inum,kon,lakon,nfield,nk, + & ne,nactdof) +! +! interpolates basic degree of freedom nodal values +! (displacements, temperatures) to 1d/2d nodal locations +! + implicit none +! + character*8 lakon(*),lakonl +! + integer ipkon(*),inum(*),kon(*),ne,indexe,nfield,nk,i,j,k,l, + & node3(8,3),node6(3,6),node8(3,8),node2d,node3d,indexe2d,ne1d2d, + & node3m(8,3),iflag,nactdof(nfield,*) +! + real*8 yn(nfield,*),ratioe(3) +! + include "gauss.f" +! + data node3 /1,4,8,5,12,20,16,17,9,11,15,13, + & 0,0,0,0,2,3,7,6,10,19,14,18/ + data node3m /1,5,8,4,17,16,20,12, + & 0,0,0,0,0,0,0,0, + & 3,7,6,2,19,14,18,10/ + data node6 /1,13,4,2,14,5,3,15,6,7,0,10,8,0,11,9,0,12/ + data node8 /1,17,5,2,18,6,3,19,7,4,20,8,9,0,13,10,0,14, + & 11,0,15,12,0,16/ + data ratioe /0.16666666666667d0,0.66666666666666d0, + & 0.16666666666667d0/ + data iflag /2/ +! +! removing any results in 1d/2d nodes +! + ne1d2d=0 +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + lakonl=lakon(i) + if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'I').or. + & (lakonl(1:1).ne.'C')) cycle + ne1d2d=1 + indexe=ipkon(i) +! +! inactivating the 3d expansion nodes of 1d/2d elements +! + do j=1,20 + inum(kon(indexe+j))=0 + enddo +! + if(lakonl(4:5).eq.'15') then + indexe2d=indexe+15 + do j=1,6 + node2d=kon(indexe2d+j) + inum(node2d)=0 + do k=1,nfield + if(nactdof(k,node2d).eq.0) yn(k,node2d)=0.d0 + enddo + enddo + elseif(lakonl(7:7).eq.'B') then + indexe2d=indexe+20 + do j=1,3 + node2d=kon(indexe2d+j) + inum(node2d)=0 + do k=1,nfield + if(nactdof(k,node2d).eq.0) yn(k,node2d)=0.d0 + enddo + enddo + else + indexe2d=indexe+20 + do j=1,8 + node2d=kon(indexe2d+j) + inum(node2d)=0 + do k=1,nfield + if(nactdof(k,node2d).eq.0) yn(k,node2d)=0.d0 + enddo + enddo + endif +! + enddo +! +! if no 1d/2d elements return +! + if(ne1d2d.eq.0) return +! +! interpolation of 3d results on 1d/2d nodes +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + lakonl=lakon(i) + if((lakonl(7:7).eq.' ').or.(lakonl(7:7).eq.'I').or. + & (lakonl(1:1).ne.'C')) cycle + indexe=ipkon(i) +! + if(lakonl(4:5).eq.'15') then + indexe2d=indexe+15 + do j=1,6 + node2d=kon(indexe2d+j) + inum(node2d)=inum(node2d)-1 +! +! taking the mean across the thickness +! + if(j.le.3) then +! +! end nodes: weights 1/6,2/3 and 1/6 +! + do l=1,3 + node3d=kon(indexe+node6(l,j)) + do k=1,nfield + if(nactdof(k,node2d).eq.0) yn(k,node2d)= + & yn(k,node2d)+yn(k,node3d)*ratioe(l) + enddo + enddo + else +! +! middle nodes: weights 1/2,1/2 +! + do l=1,3,2 + node3d=kon(indexe+node6(l,j)) + do k=1,nfield + if(nactdof(k,node2d).eq.0) yn(k,node2d)= + & yn(k,node2d)+yn(k,node3d)/2.d0 + enddo + enddo + endif + enddo + elseif(lakonl(7:7).eq.'B') then + indexe2d=indexe+20 +! +! mean values for beam elements +! + do j=1,3 + node2d=kon(indexe2d+j) +! +! mean value of vertex values +! + do l=1,4 + inum(node2d)=inum(node2d)-1 + node3d=kon(indexe+node3(l,j)) + do k=1,nfield + if(nactdof(k,node2d).eq.0) yn(k,node2d)= + & yn(k,node2d)+yn(k,node3d) + enddo + enddo + enddo + else + indexe2d=indexe+20 + do j=1,8 + node2d=kon(indexe2d+j) + inum(node2d)=inum(node2d)-1 +! +! taking the mean across the thickness +! + if(j.le.4) then +! +! end nodes: weights 1/6,2/3 and 1/6 +! + do l=1,3 + node3d=kon(indexe+node8(l,j)) + do k=1,nfield + if(nactdof(k,node2d).eq.0) yn(k,node2d)= + & yn(k,node2d)+yn(k,node3d)*ratioe(l) + enddo + enddo + else +! +! middle nodes: weights 1/2,1/2 +! + do l=1,3,2 + node3d=kon(indexe+node8(l,j)) + do k=1,nfield + if(nactdof(k,node2d).eq.0) yn(k,node2d)= + & yn(k,node2d)+yn(k,node3d)/2.d0 + enddo + enddo + endif + enddo + endif +! + enddo +! +! taking the mean of nodal contributions coming from different +! elements having the node in common +! + do i=1,nk + if(inum(i).lt.0) then + inum(i)=-inum(i) + do j=1,nfield + if(nactdof(j,i).eq.0) yn(j,i)=yn(j,i)/inum(i) + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/mastruct.c calculix-ccx-2.3/ccx_2.3/src/mastruct.c --- calculix-ccx-2.1/ccx_2.3/src/mastruct.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mastruct.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1054 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) + +void mastruct(int *nk, int *kon, int *ipkon, char *lakon, int *ne, + int *nodeboun, int *ndirboun, int *nboun, int *ipompc, + int *nodempc, int *nmpc, int *nactdof, int *icol, + int *jq, int **mast1p, int **irowp, int *isolver, int *neq, + int *nnn, int *ikmpc, int *ilmpc,int *ipointer, int *nzs, + int *nmethod,int *ithermal, int *ikboun, int *ilboun, + int *iperturb, int *mi){ + + char lakonl[2]=" \0"; + + int i,j,k,l,jj,ll,id,index,jdof1,jdof2,idof1,idof2,mpc1,mpc2,id1,id2, + ist1,ist2,node1,node2,isubtract,nmast,ifree,istart,istartold, + index1,index2,m,node,nzs_,ist,kflag,indexe,nope,isize,*mast1=NULL, + *irow=NULL,icolumn,nmastboun,fluid=0,mt=mi[1]+1,jmax; + + /* the indices in the comments follow FORTRAN convention, i.e. the + fields start with 1 */ + + mast1=*mast1p; + irow=*irowp; + + kflag=2; + nzs_=nzs[1]; + + /* initialisation of nactmpc */ + + for(i=0;i=3)){ + for(i=0;i<*ne;++i){ + + if(ipkon[i]<0) continue; + if(strcmp1(&lakon[8*i],"F")==0){ + fluid=1; + continue; + } + indexe=ipkon[i]; +/* Bernhardi start */ + if (strcmp1(&lakon[8*i+3],"8I")==0)nope=11; + else if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; +/* Bernhardi end */ + else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; + else if ((strcmp1(&lakon[8*i+3],"4")==0)|| + (strcmp1(&lakon[8*i+2],"4")==0)) nope=4; + else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; + else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; + else if (strcmp1(&lakon[8*i],"E")==0){ + lakonl[0]=lakon[8*i+7]; + nope=atoi(lakonl);} + else continue; + + /* displacement degrees of freedom */ + + for(j=0;j1){ + for(i=0;i<*ne;++i){ + + if(ipkon[i]<0) continue; + if(strcmp1(&lakon[8*i],"F")==0)continue; + indexe=ipkon[i]; + if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; + else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; + else if (strcmp1(&lakon[8*i],"E")==0){ + lakonl[0]=lakon[8*i+7]; + nope=atoi(lakonl);} + else continue; + + for(j=0;jmi[1]){continue;} + nactdof[mt*(nodeboun[i]-1)+ndirboun[i]]=0; + } + + for(i=0;i<*nmpc;++i){ + index=ipompc[i]-1; + if(nodempc[3*index+1]>mi[1]) continue; + nactdof[mt*(nodempc[3*index]-1)+nodempc[3*index+1]]=0; + } + + /* numbering the active degrees of freedom */ + + neq[0]=0; + for(i=0;i<*nk;++i){ + for(j=1;j=3)){ + ++neq[0]; + nactdof[mt*(nnn[i]-1)+j]=neq[0]; + } + else{ + nactdof[mt*(nnn[i]-1)+j]=0; + } + } + } + } + neq[1]=neq[0]; + for(i=0;i<*nk;++i){ + if(nactdof[mt*(nnn[i]-1)]!=0){ + if(*ithermal>1){ + ++neq[1]; + nactdof[mt*(nnn[i]-1)]=neq[1]; + } + else{ + nactdof[mt*(nnn[i]-1)]=0; + } + } + } + if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ + neq[2]=neq[1]+*nboun; + } + else{neq[2]=neq[1];} + + ifree=0; + /* for(i=0;i<4**nk;++i){printf("nactdof=%d,%d,%d\n",i/4+1,i-(i/4)*4,nactdof[i]);}*/ + + /* determining the position of each nonzero matrix element + + mast1(ipointer(i)) = first nonzero row in column i + irow(ipointer(i)) points to further nonzero elements in + column i */ + + for(i=0;i<4**nk;++i){ipointer[i]=0;} + + /* mechanical entries */ + + if((*ithermal<2)||(*ithermal>=3)){ + + for(i=0;i<*ne;++i){ + + if(ipkon[i]<0) continue; + if(strcmp1(&lakon[8*i],"F")==0)continue; + indexe=ipkon[i]; +/* Bernhardi start */ + if (strcmp1(&lakon[8*i+3],"8I")==0)nope=11; + else if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; +/* Bernhardi end */ + else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; + else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; + else if (strcmp1(&lakon[8*i],"E")==0){ + lakonl[0]=lakon[8*i+7]; + nope=atoi(lakonl);} + else continue; + + for(jj=0;jj0){ + + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); + if((id>0)&&(ikmpc[id-1]==idof2)){ + + /* regular DOF / MPC */ + + id=ilmpc[id-1]; + ist=ipompc[id-1]; + index=nodempc[3*ist-1]; + if(index==0) continue; + while(1){ +// idof2=nactdof[mt*nodempc[3*index-3]+nodempc[3*index-2]-4]; + idof2=nactdof[mt*(nodempc[3*index-3]-1)+nodempc[3*index-2]]; + if(idof2!=0){ + insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); + } + index=nodempc[3*index-1]; + if(index==0) break; + } + continue; + } + } + + /* boundary stiffness coefficients (for frequency + and modal dynamic calculations) */ + + if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ + FORTRAN(nident,(ikboun,&idof2,nboun,&id)); + icolumn=neq[1]+ilboun[id-1]; + /* printf("idof1=%d,icolumn=%d\n",idof1,icolumn);*/ + insert(ipointer,&mast1,&irow,&idof1,&icolumn,&ifree,&nzs_); + } + } + + else{ + idof1=8*node1+k-7; + idof2=8*node2+m-7; + mpc1=0; + mpc2=0; + if(*nmpc>0){ + FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); + if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); + if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; + } + if((mpc1==1)&&(mpc2==1)){ + id1=ilmpc[id1-1]; + id2=ilmpc[id2-1]; + if(id1==id2){ + + /* MPC id1 / MPC id1 */ + + ist=ipompc[id1-1]; + index1=nodempc[3*ist-1]; + if(index1==0) continue; + while(1){ +// idof1=nactdof[mt*nodempc[3*index1-3]+nodempc[3*index1-2]-4]; + idof1=nactdof[mt*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; + index2=index1; + while(1){ +// idof2=nactdof[mt*nodempc[3*index2-3]+nodempc[3*index2-2]-4]; + idof2=nactdof[mt*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + + else{ + + /* MPC id1 /MPC id2 */ + + ist1=ipompc[id1-1]; + index1=nodempc[3*ist1-1]; + if(index1==0) continue; + while(1){ +// idof1=nactdof[mt*nodempc[3*index1-3]+nodempc[3*index1-2]-4]; + idof1=nactdof[mt*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; + ist2=ipompc[id2-1]; + index2=nodempc[3*ist2-1]; + if(index2==0){ + index1=nodempc[3*index1-1]; + if(index1==0){break;} + else{continue;} + } + while(1){ +// idof2=nactdof[mt*nodempc[3*index2-3]+nodempc[3*index2-2]-4]; + idof2=nactdof[mt*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + } + } + } + } + } + + } + + /* nzs[0]=ifree-neq[0];*/ + /* printf("\nneq[0]=%d,nzs[0]=%d\n\n",neq[0],nzs[0]);*/ + + /* thermal entries*/ + + if(*ithermal>1){ + + for(i=0;i<*ne;++i){ + + if(ipkon[i]<0) continue; + if(strcmp1(&lakon[8*i],"F")==0)continue; + indexe=ipkon[i]; + if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; + else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; + else if (strcmp1(&lakon[8*i],"E")==0){ + lakonl[0]=lakon[8*i+7]; + nope=atoi(lakonl);} + else continue; + + for(jj=0;jj0){ + + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); + if((id>0)&&(ikmpc[id-1]==idof2)){ + + /* regular DOF / MPC */ + + id=ilmpc[id-1]; + ist=ipompc[id-1]; + index=nodempc[3*ist-1]; + if(index==0) continue; + while(1){ +// idof2=nactdof[mt*nodempc[3*index-3]+nodempc[3*index-2]-4]; + idof2=nactdof[mt*(nodempc[3*index-3]-1)+nodempc[3*index-2]]; + if(idof2!=0){ + insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); + } + index=nodempc[3*index-1]; + if(index==0) break; + } + continue; + } + } + + /* boundary stiffness coefficients (for frequency and + modal dynamic calculations */ + + if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ + FORTRAN(nident,(ikboun,&idof2,nboun,&id)); + icolumn=neq[1]+ilboun[id-1]; + insert(ipointer,&mast1,&irow,&idof1,&icolumn,&ifree,&nzs_); + } + + } + + else{ + idof1=8*node1-8; + idof2=8*node2-8; + mpc1=0; + mpc2=0; + if(*nmpc>0){ + FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); + if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); + if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; + } + if((mpc1==1)&&(mpc2==1)){ + id1=ilmpc[id1-1]; + id2=ilmpc[id2-1]; + if(id1==id2){ + + /* MPC id1 / MPC id1 */ + + ist=ipompc[id1-1]; + index1=nodempc[3*ist-1]; + if(index1==0) continue; + while(1){ +// idof1=nactdof[mt*nodempc[3*index1-3]+nodempc[3*index1-2]-4]; + idof1=nactdof[mt*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; + index2=index1; + while(1){ +// idof2=nactdof[mt*nodempc[3*index2-3]+nodempc[3*index2-2]-4]; + idof2=nactdof[mt*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + + else{ + + /* MPC id1 /MPC id2 */ + + ist1=ipompc[id1-1]; + index1=nodempc[3*ist1-1]; + if(index1==0) continue; + while(1){ +// idof1=nactdof[mt*nodempc[3*index1-3]+nodempc[3*index1-2]-4]; + idof1=nactdof[mt*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; + ist2=ipompc[id2-1]; + index2=nodempc[3*ist2-1]; + if(index2==0){ + index1=nodempc[3*index1-1]; + if(index1==0){break;} + else{continue;} + } + while(1){ +// idof2=nactdof[mt*nodempc[3*index2-3]+nodempc[3*index2-2]-4]; + idof2=nactdof[mt*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + } + } + } + } + } + + } + + for(i=0;i=neq[1]) continue; + node1=0; + for(j=0;j<*nk;j++){ + for(k=0;k<4;++k){ +// if(nactdof[mt*nnn[j]+k-4]==i+1){ + if(nactdof[mt*(nnn[j]-1)+k]==i+1){ + node1=nnn[j]; + idof1=k; + break; + } + } + if(node1!=0) break; + } + printf("*ERROR in mastruct: zero column\n"); + printf(" node=%d,DOF=%d\n",node1,idof1); + FORTRAN(stop,()); + } + istart=ipointer[i]; + while(1){ + istartold=istart; + istart=irow[istart-1]; + irow[istartold-1]=i+1; + if(istart==0) break; + } + } + + /* defining icol and jq */ + + if(neq[1]==0){ + printf("\n*WARNING: no degrees of freedom in the model\n\n"); + } + + nmast=ifree; + + /* for frequency calculations and modal dynamic calculations: + sorting column after column; + determining the end of the classical stiffness matrix + in fields irow and mast1 */ + + if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ + FORTRAN(isortii,(irow,mast1,&nmast,&kflag)); + nmastboun=nmast; + FORTRAN(nident,(irow,&neq[1],&nmast,&id)); + if((id>0)&&(irow[id-1]==neq[1])) nmast=id; + } + + /* summary */ + + printf(" number of equations\n"); + printf(" %d\n",neq[1]); + printf(" number of nonzero matrix elements\n"); + printf(" %d\n",nmast); + printf("\n"); + + /* changing the meaning of icol,j1,mast1,irow: + + - irow is going to contain the row numbers of the SUBdiagonal + nonzero's, column per column + - mast1 contains the column numbers + - icol(i)=# SUBdiagonal nonzero's in column i + - jq(i)= location in field irow of the first SUBdiagonal + nonzero in column i + + */ + + /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ + + FORTRAN(isortii,(mast1,irow,&nmast,&kflag)); + + /* filtering out the diagonal elements and generating icol and jq */ + + isubtract=0; + for(i=0;i0){ + isize=jq[i+1]-jq[i]; + FORTRAN(isortii,(&irow[jq[i]-1],&mast1[jq[i]-1],&isize,&kflag)); + } + } + + if(neq[0]==0){nzs[0]=0;} + else{nzs[0]=jq[neq[0]]-1;} + nzs[1]=jq[neq[1]]-1; + + /* determining jq for the boundary stiffness matrix (only + for frequency and modal dynamic calculations */ + + if((*nmethod==2)||((*nmethod==4)&&(*iperturb<=1))||(*nmethod>=5)){ + for(i=neq[1];i0){ + isize=jq[i+1]-jq[i]; + FORTRAN(isortii,(&irow[jq[i]-1],&mast1[jq[i]-1],&isize,&kflag)); + } + } + nzs[2]=jq[neq[2]]-1; + } + else{nzs[2]=nzs[1];} + +/* for(i=nzs[1];i +#include +#include +#include +#include "CalculiX.h" + +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) + +void mastructcs(int *nk, int *kon, int *ipkon, char *lakon, int *ne, + int *nodeboun, int *ndirboun, int *nboun, int *ipompc, + int *nodempc, int *nmpc, int *nactdof, int *icol, + int *jq, int **mast1p, int **irowp, int *isolver, int *neq, + int *nnn, int *ikmpc, int *ilmpc, + int *ipointer, int *nzs, int *nmethod, + int *ics, double *cs, char *labmpc, int *mcs, int *mi){ + + int i,j,k,l,jj,ll,id,index,jdof1,jdof2,idof1,idof2,mpc1,mpc2,id1,id2, + ist1,ist2,node1,node2,isubtract,nmast,ifree,istart,istartold, + index1,index2,m,node,nzs_,ist,kflag,indexe,nope,isize,*mast1=NULL, + *irow=NULL,inode,icomplex,inode1,icomplex1,inode2, + icomplex2,kdof1,kdof2,ilength,lprev,ij,mt=mi[1]+1; + + /* the indices in the comments follow FORTRAN convention, i.e. the + fields start with 1 */ + + mast1=*mast1p; + irow=*irowp; + + kflag=2; + nzs_=nzs[1]; + + /* initialisation of nactmpc */ + + for(i=0;i0){ + + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); + if((id>0)&&(ikmpc[id-1]==idof2)){ + + /* regular DOF / MPC */ + + id1=ilmpc[id-1]; + ist=ipompc[id1-1]; + index=nodempc[3*ist-1]; + if(index==0) continue; + while(1){ + inode=nodempc[3*index-3]; + icomplex=0; + if(strcmp1(&labmpc[(id1-1)*20],"CYCLIC")==0){ + icomplex=atoi(&labmpc[20*(id1-1)+6]); + } + else if(strcmp1(&labmpc[(id1-1)*20],"SUBCYCLIC")==0){ + for(ij=0;ij<*mcs;ij++){ + ilength=cs[17*ij+3]; + lprev=cs[17*ij+13]; + FORTRAN(nident,(&ics[lprev],&inode,&ilength,&id)); + if(id>0){ + if(ics[lprev+id-1]==inode){ + icomplex=ij+1; + break; + } + } + } + } +// idof2=nactdof[mt*inode+nodempc[3*index-2]-4]; + idof2=nactdof[mt*(inode-1)+nodempc[3*index-2]]; + if(idof2!=0){ + insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); + kdof1=idof1+neq[0];kdof2=idof2+neq[0]; + insert(ipointer,&mast1,&irow,&kdof1,&kdof2,&ifree,&nzs_); + if((icomplex!=0)&&(idof1!=idof2)){ + insert(ipointer,&mast1,&irow,&kdof1,&idof2,&ifree,&nzs_); + insert(ipointer,&mast1,&irow,&idof1,&kdof2,&ifree,&nzs_); + } + } + index=nodempc[3*index-1]; + if(index==0) break; + } + continue; + } + } + } + + else{ + idof1=8*node1+k-7; + idof2=8*node2+m-7; + mpc1=0; + mpc2=0; + if(*nmpc>0){ + FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); + if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); + if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; + } + if((mpc1==1)&&(mpc2==1)){ + id1=ilmpc[id1-1]; + id2=ilmpc[id2-1]; + if(id1==id2){ + + /* MPC id1 / MPC id1 */ + + ist=ipompc[id1-1]; + index1=nodempc[3*ist-1]; + if(index1==0) continue; + while(1){ + inode1=nodempc[3*index1-3]; + icomplex1=0; + if(strcmp1(&labmpc[(id1-1)*20],"CYCLIC")==0){ + icomplex1=atoi(&labmpc[20*(id1-1)+6]); + } + else if(strcmp1(&labmpc[(id1-1)*20],"SUBCYCLIC")==0){ + for(ij=0;ij<*mcs;ij++){ + ilength=cs[17*ij+3]; + lprev=cs[17*ij+13]; + FORTRAN(nident,(&ics[lprev],&inode1,&ilength,&id)); + if(id>0){ + if(ics[lprev+id-1]==inode1){ + icomplex1=ij+1; + break; + } + } + } + } +// idof1=nactdof[mt*inode1+nodempc[3*index1-2]-4]; + idof1=nactdof[mt*(inode1-1)+nodempc[3*index1-2]]; + index2=index1; + while(1){ + inode2=nodempc[3*index2-3]; + icomplex2=0; + if(strcmp1(&labmpc[(id1-1)*20],"CYCLIC")==0){ + icomplex2=atoi(&labmpc[20*(id1-1)+6]); + } + else if(strcmp1(&labmpc[(id1-1)*20],"SUBCYCLIC")==0){ + for(ij=0;ij<*mcs;ij++){ + ilength=cs[17*ij+3]; + lprev=cs[17*ij+13]; + FORTRAN(nident,(&ics[lprev],&inode2,&ilength,&id)); + if(id>0){ + if(ics[lprev+id-1]==inode2){ + icomplex2=ij+1; + break; + } + } + } + } +// idof2=nactdof[mt*inode2+nodempc[3*index2-2]-4]; + idof2=nactdof[mt*(inode2-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); + kdof1=idof1+neq[0];kdof2=idof2+neq[0]; + insert(ipointer,&mast1,&irow,&kdof1,&kdof2,&ifree,&nzs_); + if(((icomplex1!=0)||(icomplex2!=0))&& + (icomplex1!=icomplex2)){ + /* if(((icomplex1!=0)||(icomplex2!=0))&& + ((icomplex1==0)||(icomplex2==0))){*/ + insert(ipointer,&mast1,&irow,&kdof1,&idof2,&ifree,&nzs_); + insert(ipointer,&mast1,&irow,&idof1,&kdof2,&ifree,&nzs_); + } + } + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + + else{ + + /* MPC id1 /MPC id2 */ + + ist1=ipompc[id1-1]; + index1=nodempc[3*ist1-1]; + if(index1==0) continue; + while(1){ + inode1=nodempc[3*index1-3]; + icomplex1=0; + if(strcmp1(&labmpc[(id1-1)*20],"CYCLIC")==0){ + icomplex1=atoi(&labmpc[20*(id1-1)+6]); + } + else if(strcmp1(&labmpc[(id1-1)*20],"SUBCYCLIC")==0){ + for(ij=0;ij<*mcs;ij++){ + ilength=cs[17*ij+3]; + lprev=cs[17*ij+13]; + FORTRAN(nident,(&ics[lprev],&inode1,&ilength,&id)); + if(id>0){ + if(ics[lprev+id-1]==inode1){ + icomplex1=ij+1; + break; + } + } + } + } +// idof1=nactdof[mt*inode1+nodempc[3*index1-2]-4]; + idof1=nactdof[mt*(inode1-1)+nodempc[3*index1-2]]; + ist2=ipompc[id2-1]; + index2=nodempc[3*ist2-1]; + if(index2==0){ + index1=nodempc[3*index1-1]; + if(index1==0){break;} + else{continue;} + } + while(1){ + inode2=nodempc[3*index2-3]; + icomplex2=0; + if(strcmp1(&labmpc[(id2-1)*20],"CYCLIC")==0){ + icomplex2=atoi(&labmpc[20*(id2-1)+6]); + } + else if(strcmp1(&labmpc[(id2-1)*20],"SUBCYCLIC")==0){ + for(ij=0;ij<*mcs;ij++){ + ilength=cs[17*ij+3]; + lprev=cs[17*ij+13]; + FORTRAN(nident,(&ics[lprev],&inode2,&ilength,&id)); + if(id>0){ + if(ics[lprev+id-1]==inode2){ + icomplex2=ij+1; + break; + } + } + } + } +// idof2=nactdof[mt*inode2+nodempc[3*index2-2]-4]; + idof2=nactdof[mt*(inode2-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irow,&idof1,&idof2,&ifree,&nzs_); + kdof1=idof1+neq[0];kdof2=idof2+neq[0]; + insert(ipointer,&mast1,&irow,&kdof1,&kdof2,&ifree,&nzs_); + if(((icomplex1!=0)||(icomplex2!=0))&& + (icomplex1!=icomplex2)){ + /* if(((icomplex1!=0)||(icomplex2!=0))&& + ((icomplex1==0)||(icomplex2==0))){*/ + insert(ipointer,&mast1,&irow,&kdof1,&idof2,&ifree,&nzs_); + insert(ipointer,&mast1,&irow,&idof1,&kdof2,&ifree,&nzs_); + } + } + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + } + } + } + } + } + + neq[0]=2*neq[0]; + neq[1]=neq[0]; + + /* ordering the nonzero nodes in the SUPERdiagonal columns + mast1 contains the row numbers column per column, + irow the column numbers */ + +/* for(i=0;i=neq[1]) continue; + printf("*ERROR in mastructcs: zero column\n"); + FORTRAN(stop,()); + } + istart=ipointer[i]; + while(1){ + istartold=istart; + istart=irow[istart-1]; + irow[istartold-1]=i+1; + if(istart==0) break; + } + } + + if(neq[0]==0){ + printf("\n*WARNING: no degrees of freedom in the model\n"); + FORTRAN(stop,()); + } + + printf(" number of equations\n"); + printf(" %d\n",neq[0]); + printf(" number of nonzero matrix elements\n"); + printf(" %d\n",ifree); + + /* new meaning of icol,j1,mast1,irow: + + - irow is going to contain the row numbers of the SUBdiagonal + nonzero's, column per column + - mast1 contains the column numbers + - icol(i)=# SUBdiagonal nonzero's in column i + - jq(i)= location in field irow of the first SUBdiagonal + nonzero in column i + + */ + + nmast=ifree; + + /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ + + FORTRAN(isortii,(mast1,irow,&nmast,&kflag)); + + /* filtering out the diagonal elements and generating icol and jq */ + + isubtract=0; + for(i=0;i0){ + isize=jq[i+1]-jq[i]; + FORTRAN(isortii,(&irow[jq[i]-1],&mast1[jq[i]-1],&isize,&kflag)); + } + } + + nzs[0]=jq[neq[0]-1]-1; + nzs[1]=nzs[0]; + nzs[2]=nzs[0]; + + *mast1p=mast1; + *irowp=irow; + + return; + +} + +/* + +What follows is the original FORTRAN code. The C Code is a one-to-one +manual translation of the FORTRAN code. However, the FORTRAN code might +be easier to understand. + +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine mastructcs(nk,kon,ipkon,lakon,ne,nodeboun,ndirboun, + & nboun,ipompc, + & nodempc,nmpc,nactdof,icol,jq,mast1,irow,isolver,neq,nnn, + & ikmpc,ilmpc,ikcol,ipointer,nsky,nzs,nmethod,ics,ns,labmpc) +! + implicit none +! + character*6 lakon(*) + character*20 labmpc(*) +! + integer kon(*),nodeboun(*),ndirboun(*),nodempc(3,*),ipompc(*), + & nactdof(3,*),icol(*),jq(*),ipointer(*),nnn(*),ikmpc(*),ilmpc(*), + & ikcol(*),mast1(*),irow(*),ipkon(*),inode,icomplex,inode1, + & icomplex1,inode2,icomplex2,nsky_exp,nsky_inc,ns(5),ics(*) +! + integer nk,ne,nboun,nmpc,isolver,neq,nsky,nzs,i,j,k,l,jj,ll,id, + & index,jdof1,jdof2,idof1,idof2,mpc1,mpc2,id1,id2,ist1,ist2,node1, + & node2,isubtract,nmast,ifree,istart,istartold,itot,index1,index2, + & m,node,nzs_,ist,kflag,nmethod,indexe,nope +! + kflag=2 + nzs_=nzs +! +! initialisation of nactmpc +! + do i=1,nk + do j=1,3 + nactdof(j,i)=0 + enddo + enddo +! +! determining the active degrees of freedom due to elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + if((lakon(i).eq.'C3D20R').or.(lakon(i).eq.'C3D20 ')) then + nope=20 + elseif((lakon(i).eq.'C3D8R ').or.(lakon(i).eq.'C3D8 ')) then + nope=8 + else + nope=10 + endif +! + do j=1,nope + node=kon(indexe+j) + do k=1,3 + nactdof(k,node)=1 + enddo + enddo + enddo +! +! determining the active degrees of freedom due to mpc's +! + do i=1,nmpc + index=ipompc(i) + do + nactdof(nodempc(2,index),nodempc(1,index))=1 + index=nodempc(3,index) + if(index.eq.0) exit + enddo + enddo +! +! subtracting the SPC and MPC nodes +! + do i=1,nboun + nactdof(ndirboun(i),nodeboun(i))=0 + enddo +! + do i=1,nmpc + index=ipompc(i) + nactdof(nodempc(2,index),nodempc(1,index))=0 + enddo +! +! numbering the active degrees of freedom +! + neq=0 + do i=1,nk + do j=1,3 + if(nactdof(j,nnn(i)).ne.0) then + neq=neq+1 + nactdof(j,nnn(i))=neq + endif + enddo + enddo +! + ifree=0 +! +! +! determining the position of each nonzero matrix element +! +! mast1(ipointer(i)) = first nonzero row in column i +! irow(ipointer(i)) points to further nonzero elements in +! column i +! + do i=1,6*nk + ipointer(i)=0 + enddo +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + if((lakon(i).eq.'C3D20R').or.(lakon(i).eq.'C3D20 ')) then + nope=20 + elseif((lakon(i).eq.'C3D8R ').or.(lakon(i).eq.'C3D8 ')) then + nope=8 + else + nope=10 + endif +! + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdof(k,node1) +! + do ll=jj,3*nope +! + l=(ll-1)/3+1 + m=ll-3*(l-1) +! + node2=kon(indexe+l) + jdof2=nactdof(m,node2) +! +! check whether one of the DOF belongs to a SPC or MPC +! + if((jdof1.ne.0).and.(jdof2.ne.0)) then + call inserf(ipointer,mast1,irow, + & jdof1,jdof2,ifree,nzs_) + call inserf(ipointer,mast1,irow, + & jdof1+neq,jdof2+neq,ifree,nzs_) + elseif((jdof1.ne.0).or.(jdof2.ne.0)) then +! +! idof1: genuine DOF +! idof2: nominal DOF of the SPC/MPC +! + if(jdof1.eq.0) then + idof1=jdof2 + idof2=(node1-1)*3+k + else + idof1=jdof1 + idof2=(node2-1)*3+m + endif + if(nmpc.gt.0) then + call nident(ikmpc,idof2,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof2)) then +! +! regular DOF / MPC +! + id1=ilmpc(id) + ist=ipompc(id1) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + inode=nodempc(1,index) + icomplex=0 + if(labmpc(id1)(1:6).eq.'CYCLIC') then + icomplex=1 + elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then + call nident(ics,inode,ns(4),id) + if(id.gt.0) then + if(ics(id).eq.inode) then + icomplex=1 + endif + endif + endif + idof2=nactdof(nodempc(2,index),inode) + if(idof2.ne.0) then + call inserf(ipointer,mast1,irow, + & idof1,idof2,ifree,nzs_) + call inserf(ipointer,mast1,irow, + & idof1+neq,idof2+neq,ifree,nzs_) + if((icomplex.eq.1).and.(idof1.ne.idof2)) then + call inserf(ipointer,mast1,irow, + & idof1+neq,idof2,ifree,nzs_) + call inserf(ipointer,mast1,irow, + & idof1,idof2+neq,ifree,nzs_) + endif + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + cycle + endif + endif +! + else + idof1=(node1-1)*3+k + idof2=(node2-1)*3+m + mpc1=0 + mpc2=0 + if(nmpc.gt.0) then + call nident(ikmpc,idof1,nmpc,id1) + if((id1.gt.0).and.(ikmpc(id1).eq.idof1)) mpc1=1 + call nident(ikmpc,idof2,nmpc,id2) + if((id2.gt.0).and.(ikmpc(id2).eq.idof2)) mpc2=1 + endif + if((mpc1.eq.1).and.(mpc2.eq.1)) then + id1=ilmpc(id1) + id2=ilmpc(id2) + if(id1.eq.id2) then +! +! MPC id1 / MPC id1 +! + ist=ipompc(id1) + index1=nodempc(3,ist) + if(index1.eq.0) cycle + do + inode1=nodempc(1,index1) + icomplex1=0 + if(labmpc(id1)(1:6).eq.'CYCLIC') then + icomplex1=1 + elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then + call nident(ics,inode1,ns(4),id) + if(id.gt.0) then + if(ics(id).eq.inode1) then + icomplex1=1 + endif + endif + endif + idof1=nactdof(nodempc(2,index1),inode1) + index2=index1 + do + inode2=nodempc(1,index2) + call nident(ics,inode2,ns(4),id) + icomplex2=0 + if(labmpc(id1)(1:6).eq.'CYCLIC') then + icomplex2=1 + elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then + call nident(ics,inode2,ns(4),id) + if(id.gt.0) then + if(ics(id).eq.inode2) then + icomplex2=1 + endif + endif + endif + idof2=nactdof(nodempc(2,index2),inode2) + if((idof1.ne.0).and.(idof2.ne.0)) then + call inserf(ipointer,mast1,irow, + & idof1,idof2,ifree,nzs_) + call inserf(ipointer,mast1,irow, + & idof1+neq,idof2+neq,ifree,nzs_) + if(((icomplex1.eq.1).or.(icomplex2.eq.1)). + & and.((icomplex1.eq.0).or.(icomplex2.eq.0))) + & then + call inserf(ipointer,mast1,irow, + & idof1+neq,idof2,ifree,nzs_) + call inserf(ipointer,mast1,irow, + & idof1,idof2+neq,ifree,nzs_) + endif + endif + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + else +! +! MPC id1 / MPC id2 +! + ist1=ipompc(id1) + index1=nodempc(3,ist1) + if(index1.eq.0) cycle + do + inode1=nodempc(1,index1) + icomplex1=0 + if(labmpc(id1)(1:6).eq.'CYCLIC') then + icomplex1=1 + elseif(labmpc(id1)(1:9).eq.'SUBCYCLIC') then + call nident(ics,inode1,ns(4),id) + if(id.gt.0) then + if(ics(id).eq.inode1) then + icomplex1=1 + endif + endif + endif + idof1=nactdof(nodempc(2,index1),inode1) + ist2=ipompc(id2) + index2=nodempc(3,ist2) + if(index2.eq.0) then + index1=nodempc(3,index1) + if(index1.eq.0) then + exit + else + cycle + endif + endif + do + inode2=nodempc(1,index2) + icomplex2=0 + if(labmpc(id2)(1:6).eq.'CYCLIC') then + icomplex2=1 + elseif(labmpc(id2)(1:9).eq.'SUBCYCLIC') then + call nident(ics,inode2,ns(4),id) + if(id.gt.0) then + if(ics(id).eq.inode2) then + icomplex2=1 + endif + endif + endif + idof2=nactdof(nodempc(2,index2),inode2) + if((idof1.ne.0).and.(idof2.ne.0)) then + call inserf(ipointer,mast1,irow, + & idof1,idof2,ifree,nzs_) + call inserf(ipointer,mast1,irow, + & idof1+neq,idof2+neq,ifree,nzs_) + if(((icomplex1.eq.1).or.(icomplex2.eq.1)). + & and.((icomplex1.eq.0).or.(icomplex2.eq.0)). + & and.(idof1.ne.idof2)) + & then + call inserf(ipointer,mast1,irow, + & idof1+neq,idof2,ifree,nzs_) + call inserf(ipointer,mast1,irow, + & idof1,idof2+neq,ifree,nzs_) + endif + endif + index2=nodempc(3,index2) + if(index2.eq.0) exit + enddo + index1=nodempc(3,index1) + if(index1.eq.0) exit + enddo + endif + endif + endif + enddo + enddo + enddo +! +! ordering the nonzero nodes in the SUPERdiagonal columns +! mast1 contains the row numbers column per column, +! irow the column numbers +! + neq=2*neq +! + do i=1,neq + itot=0 + if(ipointer(i).eq.0) then + write(*,*) 'error in mastructcs: zero column' + stop + endif + istart=ipointer(i) + do + itot=itot+1 + ikcol(itot)=mast1(istart) + istart=irow(istart) + if(istart.eq.0) exit + enddo + call isortii(ikcol,icol,itot,kflag) + istart=ipointer(i) + do j=1,itot-1 + mast1(istart)=ikcol(j) + istartold=istart + istart=irow(istart) + irow(istartold)=i + enddo + mast1(istart)=ikcol(itot) + irow(istart)=i + enddo +! +! defining icol and jq +! + nsky=0 + nsky_exp=0 + do i=2,neq + nsky_inc=i-mast1(ipointer(i)) + if(2147483647-nsky.lt.nsky_inc) then + nsky_exp=nsky_exp+1 + nsky_inc=nsky_inc-2147483647 + endif + nsky=nsky+nsky_inc + enddo +! + if(neq.eq.0) then + write(*,*) '*WARNING: no degrees of freedom in the model' + stop + endif +! + write(*,*) 'number of equations' + write(*,*) neq + write(*,*) 'number of nonzero matrix elements' + write(*,*) ifree + write(*,*) 'total length of the skyline' + write(*,*) nsky_exp,'*2147483647+',nsky + write(*,*) 'percentage of nonzero skyline elements' + write(*,*) real(ifree)/ + & (real(nsky+neq)+nsky_exp*real(2147483647))*100. + write(*,*) +! +! new meaning of icol,j1,mast1,irow: +! - irow is going to contain the row numbers of the SUBdiagonal +! nonzero's, column per column +! - mast1 contains the column numbers +! - icol(i)=# SUBdiagonal nonzero's in column i +! - jq(i)= location in field irow of the first SUBdiagonal +! nonzero in column i +! + nmast=ifree +! +! switching from a SUPERdiagonal inventary to a SUBdiagonal one +! + call isortii(mast1,irow,nmast,kflag) +! +! filtering out the diagonal elements and generating icol and jq +! + isubtract=0 + do i=1,neq + icol(i)=0 + enddo + k=0 + do i=1,nmast + if(mast1(i).eq.irow(i)) then + isubtract=isubtract+1 + else + mast1(i-isubtract)=mast1(i) + irow(i-isubtract)=irow(i) + if(k.ne.mast1(i)) then + do l=k+1,mast1(i) + jq(l)=i-isubtract + enddo + k=mast1(i) + endif + icol(k)=icol(k)+1 + endif + enddo + nmast=nmast-isubtract + do l=k+1,neq+1 + jq(l)=nmast+1 + enddo +! + do i=1,neq + if(jq(i+1)-jq(i).gt.0) then + call isortii(irow(jq(i)),mast1(jq(i)),jq(i+1)-jq(i), + & kflag) + endif + enddo +! + nzs=jq(neq)-1 +! + return + end + + */ diff -Nru calculix-ccx-2.1/ccx_2.3/src/mastructf.c calculix-ccx-2.3/ccx_2.3/src/mastructf.c --- calculix-ccx-2.1/ccx_2.3/src/mastructf.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/mastructf.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1151 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +#define min(a,b) ((a) <= (b) ? (a) : (b)) +#define max(a,b) ((a) >= (b) ? (a) : (b)) + +void mastructf(int *nk, int *kon, int *ipkon, char *lakon, int *ne, + int *nodeboun, int *ndirboun, int *nboun, int *ipompc, + int *nodempc, int *nmpc, int *nactdoh, int *icolt, + int *icolv, int *icolp, int *icolk,int *jqt, int *jqv, int *jqp, + int *jqk,int **mast1p, int **irowtp, int **irowvp, int **irowpp, + int **irowkp, int *isolver, int *neqt, int *neqv, int *neqp, + int *neqk,int *ikmpc, int *ilmpc,int *ipointer, + int *nzst, int *nzsv, int *nzsp, int *nzsk, + int *ithermal, int *ikboun, int *ilboun, int *turbulent, + int *nactdok, int *ifreestream, int *nfreestream, + int *isolidface, int *nsolidface, int *nzs, int *iexplicit, + int *ielmat, int *inomat, char *labmpc){ + + int i,j,k,l,jj,ll,id,index,jdof1,jdof2,idof1,idof2,mpc1,mpc2,id1,id2, + ist1,ist2,node1,node2,isubtract,nmast,ifree,istart,istartold,idir, + index1,index2,m,node,nzs_,ist,kflag,indexe,nope,isize,*mast1=NULL, + *irowt=NULL,*irowv=NULL,*irowp=NULL,*irowk=NULL,fluid,imaterial; + + /* the indices in the comments follow FORTRAN convention, i.e. the + fields start with 1 */ + + mast1=*mast1p; + irowt=*irowtp;irowv=*irowvp;irowp=*irowpp;irowk=*irowkp; + + kflag=2; + + /* initialisation of nactdoh */ + + for(i=0;i<5**nk;++i){nactdoh[i]=0;} + + /* determining the active degrees of freedom due to elements */ + + for(i=0;i<*ne;++i){ + + if(ipkon[i]<0) continue; + if(strcmp1(&lakon[8*i],"F")!=0) continue; + indexe=ipkon[i]; + if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; + else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; + else continue; + + for(j=0;j4){continue;} + if(nodempc[3*index+1]==4){ + nactdoh[5*(nodempc[3*index]-1)+4]=0; + } + } + } + + /* numbering the active degrees of freedom */ + + *neqt=0;*neqv=0;*neqp=0; + for(i=0;i<*nk;++i){ + if(*ithermal>1){ + if(nactdoh[5*i]!=0){ + ++(*neqt); + nactdoh[5*i]=*neqt; + } + } + for(j=1;j<4;++j){ + if(nactdoh[5*i+j]!=0){ + ++(*neqv); + nactdoh[5*i+j]=*neqv; + } + } + if(nactdoh[5*i+4]!=0){ + ++(*neqp); + nactdoh[5*i+4]=*neqp; + } + } + if(*ithermal>1) printf("neqttt=%d\n",*neqt); + printf("neqvvv=%d\n",*neqv); + printf("neqppp=%d\n",*neqp); + + /* determining the turbulence degrees of freedom */ + + if(*turbulent!=0){ + + /* initialisation of nactdok */ + + for(i=0;i<*nk;++i){nactdok[i]=0;} + + /* determining the turbulence degrees of freedom due to elements */ + + for(i=0;i<*ne;++i){ + + if(ipkon[i]<0) continue; + if(strcmp1(&lakon[8*i],"F")!=0) continue; + indexe=ipkon[i]; + if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; + else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; + else continue; + + for(j=0;j1){ + + ifree=0; + nzs_=*nzs; + + /* determining the position of each nonzero matrix element + + mast1(ipointer(i)) = first nonzero row in column i + irow(ipointer(i)) points to further nonzero elements in + column i */ + + for(i=0;i<3**nk;++i){ipointer[i]=0;} + + for(i=0;i<*ne;++i){ + + if(ipkon[i]<0) continue; + if(strcmp1(&lakon[8*i],"F")!=0) continue; + indexe=ipkon[i]; + if(strcmp1(&lakon[8*i+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*i+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*i+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*i+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*i+3],"15")==0)nope=15; + else if (strcmp1(&lakon[8*i+3],"6")==0)nope=6; + else continue; + + for(jj=0;jj0){ + + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); + if((id>0)&&(ikmpc[id-1]==idof2)){ + + /* regular DOF / MPC */ + + id=ilmpc[id-1]; + ist=ipompc[id-1]; + index=nodempc[3*ist-1]; + if(index==0) continue; + while(1){ + idof2=nactdoh[5*(nodempc[3*index-3]-1)+nodempc[3*index-2]]; + if(idof2!=0){ + insert(ipointer,&mast1,&irowt,&idof1,&idof2,&ifree,&nzs_); + } + index=nodempc[3*index-1]; + if(index==0) break; + } + continue; + } + } + + } + + else{ + idof1=8*node1-8; + idof2=8*node2-8; + mpc1=0; + mpc2=0; + if(*nmpc>0){ + FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); + if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); + if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; + } + if((mpc1==1)&&(mpc2==1)){ + id1=ilmpc[id1-1]; + id2=ilmpc[id2-1]; + if(id1==id2){ + + /* MPC id1 / MPC id1 */ + + ist=ipompc[id1-1]; + index1=nodempc[3*ist-1]; + if(index1==0) continue; + while(1){ + idof1=nactdoh[5*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; + index2=index1; + while(1){ + idof2=nactdoh[5*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irowt,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + + else{ + + /* MPC id1 /MPC id2 */ + + ist1=ipompc[id1-1]; + index1=nodempc[3*ist1-1]; + if(index1==0) continue; + while(1){ + idof1=nactdoh[5*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; + ist2=ipompc[id2-1]; + index2=nodempc[3*ist2-1]; + if(index2==0){ + index1=nodempc[3*index1-1]; + if(index1==0){break;} + else{continue;} + } + while(1){ + idof2=nactdoh[5*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irowt,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + } + } + } + } + } + + for(i=0;i<*neqt;++i){ + if(ipointer[i]==0){ + if(i>=*neqt) continue; + printf("*ERROR in mastructf: zero column\n"); + FORTRAN(stop,()); + } + istart=ipointer[i]; + while(1){ + istartold=istart; + istart=irowt[istart-1]; + irowt[istartold-1]=i+1; + if(istart==0) break; + } + } + + /* defining icolt and jqt */ + + if(*neqt==0){ + printf("\n*WARNING in mastructf: no degrees of freedom in the temperature matrix\n\n"); + } + + nmast=ifree; + + /* summary */ + + printf(" number of temperature equations\n"); + printf(" %d\n",*neqt); + printf(" number of nonzero temperature matrix elements\n"); + printf(" %d\n",nmast); + printf("\n"); + + /* changing the meaning of icolt,jqt,mast1,irowt: + + - irowt is going to contain the row numbers of the SUBdiagonal + nonzero's, column per column + - mast1 contains the column numbers + - icolt(i)=# SUBdiagonal nonzero's in column i + - jqt(i)= location in field irow of the first SUBdiagonal + nonzero in column i + + */ + + /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ + + FORTRAN(isortii,(mast1,irowt,&nmast,&kflag)); + + /* filtering out the diagonal elements and generating icolt and jqt */ + + isubtract=0; + for(i=0;i<*neqt;++i){icolt[i]=0;} + k=0; + for(i=0;i0){ + isize=jqt[i+1]-jqt[i]; + FORTRAN(isortii,(&irowt[jqt[i]-1],&mast1[jqt[i]-1],&isize,&kflag)); + } + } + + if(*neqt==0){*nzst=0;} + else{*nzst=jqt[*neqt]-1;} + + } + + /* velocity entries */ + + ifree=0; + nzs_=*nzs; + RENEW(mast1,int,nzs_); + for(i=0;i0){ + + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); + if((id>0)&&(ikmpc[id-1]==idof2)){ + + /* regular DOF / MPC */ + + id=ilmpc[id-1]; + ist=ipompc[id-1]; + index=nodempc[3*ist-1]; + if(index==0) continue; + while(1){ + idof2=nactdoh[5*(nodempc[3*index-3]-1)+nodempc[3*index-2]]; + if(idof2!=0){ + insert(ipointer,&mast1,&irowv,&idof1,&idof2,&ifree,&nzs_); + } + index=nodempc[3*index-1]; + if(index==0) break; + } + continue; + } + } + } + + else{ + idof1=8*node1+k-7; + idof2=8*node2+m-7; + mpc1=0; + mpc2=0; + if(*nmpc>0){ + FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); + if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); + if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; + } + if((mpc1==1)&&(mpc2==1)){ + id1=ilmpc[id1-1]; + id2=ilmpc[id2-1]; + if(id1==id2){ + + /* MPC id1 / MPC id1 */ + + ist=ipompc[id1-1]; + index1=nodempc[3*ist-1]; + if(index1==0) continue; + while(1){ + idof1=nactdoh[5*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; + index2=index1; + while(1){ + idof2=nactdoh[5*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irowv,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + + else{ + + /* MPC id1 /MPC id2 */ + + ist1=ipompc[id1-1]; + index1=nodempc[3*ist1-1]; + if(index1==0) continue; + while(1){ + idof1=nactdoh[5*(nodempc[3*index1-3]-1)+nodempc[3*index1-2]]; + ist2=ipompc[id2-1]; + index2=nodempc[3*ist2-1]; + if(index2==0){ + index1=nodempc[3*index1-1]; + if(index1==0){break;} + else{continue;} + } + while(1){ + idof2=nactdoh[5*(nodempc[3*index2-3]-1)+nodempc[3*index2-2]]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irowv,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + } + } + } + } + } + + for(i=0;i<*neqv;++i){ + if(ipointer[i]==0){ + if(i>=*neqv) continue; + printf("*ERROR in mastructf: zero column in the velocity matrix\n"); + printf(" DOF %d\n",i); + FORTRAN(stop,()); + } + istart=ipointer[i]; + while(1){ + istartold=istart; + istart=irowv[istart-1]; + irowv[istartold-1]=i+1; + if(istart==0) break; + } + } + + /* defining icolv and jqv */ + + if(*neqv==0){ + printf("\n*WARNING in mastructf: no degrees of freedom in the velocity matrix\n\n"); + } + + nmast=ifree; + + /* summary */ + + printf(" number of velocity equations\n"); + printf(" %d\n",*neqv); + printf(" number of nonzero velocity matrix elements\n"); + printf(" %d\n",nmast); + printf("\n"); + + /* changing the meaning of icolv,jqv,mast1,irowv: + + - irowv is going to contain the row numbers of the SUBdiagonal + nonzero's, column per column + - mast1 contains the column numbers + - icolv(i)=# SUBdiagonal nonzero's in column i + - jqv(i)= location in field irow of the first SUBdiagonal + nonzero in column i + + */ + + /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ + + FORTRAN(isortii,(mast1,irowv,&nmast,&kflag)); + + /* filtering out the diagonal elements and generating icolv and jqv */ + + isubtract=0; + for(i=0;i<*neqv;++i){icolv[i]=0;} + k=0; + for(i=0;i0){ + isize=jqv[i+1]-jqv[i]; + FORTRAN(isortii,(&irowv[jqv[i]-1],&mast1[jqv[i]-1],&isize,&kflag)); + } + } + + if(*neqv==0){*nzsv=0;} + else{*nzsv=jqv[*neqv]-1;} + + /* pressure entries */ + + ifree=0; + nzs_=*nzs; + RENEW(mast1,int,nzs_); + for(i=0;i0){ + + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); + if((id>0)&&(ikmpc[id-1]==idof2)){ + + /* regular DOF / MPC */ + + id=ilmpc[id-1]; + ist=ipompc[id-1]; + index=nodempc[3*ist-1]; + if(index==0) continue; + while(1){ + idof2=nactdoh[5*(nodempc[3*index-3]-1)+4]; + if(idof2!=0){ + insert(ipointer,&mast1,&irowp,&idof1,&idof2,&ifree,&nzs_); + } + index=nodempc[3*index-1]; + if(index==0) break; + } + continue; + } + } + } + + else{ + idof1=8*node1-4; + idof2=8*node2-4; + mpc1=0; + mpc2=0; + if(*nmpc>0){ + FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); + if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); + if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; + } + if((mpc1==1)&&(mpc2==1)){ + id1=ilmpc[id1-1]; + id2=ilmpc[id2-1]; + if(id1==id2){ + + /* MPC id1 / MPC id1 */ + + ist=ipompc[id1-1]; + index1=nodempc[3*ist-1]; + if(index1==0) continue; + while(1){ + idof1=nactdoh[5*(nodempc[3*index1-3]-1)+4]; + index2=index1; + while(1){ + idof2=nactdoh[5*(nodempc[3*index2-3]-1)+4]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irowp,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + + else{ + + /* MPC id1 /MPC id2 */ + + ist1=ipompc[id1-1]; + index1=nodempc[3*ist1-1]; + if(index1==0) continue; + while(1){ + idof1=nactdoh[5*(nodempc[3*index1-3]-1)+4]; + ist2=ipompc[id2-1]; + index2=nodempc[3*ist2-1]; + if(index2==0){ + index1=nodempc[3*index1-1]; + if(index1==0){break;} + else{continue;} + } + while(1){ + idof2=nactdoh[5*(nodempc[3*index2-3]-1)+4]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irowp,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + } + } + } + } + } + + for(i=0;i<*neqp;++i){ + if(ipointer[i]==0){ + if(i>=*neqp) continue; + printf("*ERROR in mastructf: zero column\n"); + FORTRAN(stop,()); + } + istart=ipointer[i]; + while(1){ + istartold=istart; + istart=irowp[istart-1]; + irowp[istartold-1]=i+1; + if(istart==0) break; + } + } + + /* defining icolp and jqp */ + + if(*neqp==0){ + printf("\n*WARNING in matructf: no degrees of freedom in the pressure matrix\n\n"); + } + + nmast=ifree; + + /* summary */ + + printf(" number of pressure equations\n"); + printf(" %d\n",*neqp); + printf(" number of nonzero pressure matrix elements\n"); + printf(" %d\n",nmast); + printf("\n"); + + /* changing the meaning of icolp,jqp,mast1,irowp: + + - irowp is going to contain the row numbers of the SUBdiagonal + nonzero's, column per column + - mast1 contains the column numbers + - icolp(i)=# SUBdiagonal nonzero's in column i + - jqp(i)= location in field irow of the first SUBdiagonal + nonzero in column i + + */ + + /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ + + FORTRAN(isortii,(mast1,irowp,&nmast,&kflag)); + + /* filtering out the diagonal elements and generating icolp and jqp */ + + isubtract=0; + for(i=0;i<*neqp;++i){icolp[i]=0;} + k=0; + for(i=0;i0){ + isize=jqp[i+1]-jqp[i]; + FORTRAN(isortii,(&irowp[jqp[i]-1],&mast1[jqp[i]-1],&isize,&kflag)); + } + } + + if(*neqp==0){*nzsp=0;} + else{*nzsp=jqp[*neqp]-1;} + + /* turbulence entries */ + + if(*turbulent!=0){ + + ifree=0; + nzs_=*nzs; + RENEW(mast1,int,nzs_); + for(i=0;i0){ + + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id)); + if((id>0)&&(ikmpc[id-1]==idof2)){ + + /* regular DOF / MPC */ + + id=ilmpc[id-1]; + ist=ipompc[id-1]; + index=nodempc[3*ist-1]; + if(index==0) continue; + while(1){ + idof2=nactdok[nodempc[3*index-3]-1]; + if(idof2!=0){ + insert(ipointer,&mast1,&irowk,&idof1,&idof2,&ifree,&nzs_); + } + index=nodempc[3*index-1]; + if(index==0) break; + } + continue; + } + } + } + + else{ + idof1=8*node1-8; + idof2=8*node2-8; + mpc1=0; + mpc2=0; + if(*nmpc>0){ + FORTRAN(nident,(ikmpc,&idof1,nmpc,&id1)); + if((id1>0)&&(ikmpc[id1-1]==idof1)) mpc1=1; + FORTRAN(nident,(ikmpc,&idof2,nmpc,&id2)); + if((id2>0)&&(ikmpc[id2-1]==idof2)) mpc2=1; + } + if((mpc1==1)&&(mpc2==1)){ + id1=ilmpc[id1-1]; + id2=ilmpc[id2-1]; + if(id1==id2){ + + /* MPC id1 / MPC id1 */ + + ist=ipompc[id1-1]; + index1=nodempc[3*ist-1]; + if(index1==0) continue; + while(1){ + idof1=nactdok[nodempc[3*index1-3]-1]; + index2=index1; + while(1){ + idof2=nactdok[nodempc[3*index2-3]-1]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irowk,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + + else{ + + /* MPC id1 /MPC id2 */ + + ist1=ipompc[id1-1]; + index1=nodempc[3*ist1-1]; + if(index1==0) continue; + while(1){ + idof1=nactdok[nodempc[3*index1-3]-1]; + ist2=ipompc[id2-1]; + index2=nodempc[3*ist2-1]; + if(index2==0){ + index1=nodempc[3*index1-1]; + if(index1==0){break;} + else{continue;} + } + while(1){ + idof2=nactdok[nodempc[3*index2-3]-1]; + if((idof1!=0)&&(idof2!=0)){ + insert(ipointer,&mast1,&irowk,&idof1,&idof2,&ifree,&nzs_);} + index2=nodempc[3*index2-1]; + if(index2==0) break; + } + index1=nodempc[3*index1-1]; + if(index1==0) break; + } + } + } + } + } + } + } + + for(i=0;i<*neqk;++i){ + if(ipointer[i]==0){ + if(i>=*neqk) continue; + printf("*ERROR in mastructf: zero column\n"); + FORTRAN(stop,()); + } + istart=ipointer[i]; + while(1){ + istartold=istart; + istart=irowk[istart-1]; + irowk[istartold-1]=i+1; + if(istart==0) break; + } + } + + /* defining icolk and jqk */ + + if(*neqk==0){ + printf("\n*WARNING in matructf: no degrees of freedom in the turbulence matrix\n\n"); + } + + nmast=ifree; + + /* summary */ + + printf(" number of turbulence equations\n"); + printf(" %d\n",*neqk); + printf(" number of nonzero turbulence matrix elements\n"); + printf(" %d\n",nmast); + printf("\n"); + + /* changing the meaning of icolk,jqk,mast1,irowk: + + - irowk is going to contain the row numbers of the SUBdiagonal + nonzero's, column per column + - mast1 contains the column numbers + - icolk(i)=# SUBdiagonal nonzero's in column i + - jqk(i)= location in field irow of the first SUBdiagonal + nonzero in column i + + */ + + /* switching from a SUPERdiagonal inventory to a SUBdiagonal one */ + + FORTRAN(isortii,(mast1,irowk,&nmast,&kflag)); + + /* filtering out the diagonal elements and generating icolk and jqk */ + + isubtract=0; + for(i=0;i<*neqk;++i){icolk[i]=0;} + k=0; + for(i=0;i0){ + isize=jqk[i+1]-jqk[i]; + FORTRAN(isortii,(&irowk[jqk[i]-1],&mast1[jqk[i]-1],&isize,&kflag)); + } + } + + if(*neqk==0){*nzsk=0;} + else{*nzsk=jqk[*neqk]-1;} + + } + + *mast1p=mast1; + *irowtp=irowt;*irowvp=irowv;*irowpp=irowp;*irowkp=irowk; + + return; + +} + diff -Nru calculix-ccx-2.1/ccx_2.3/src/materialdata_cond.f calculix-ccx-2.3/ccx_2.3/src/materialdata_cond.f --- calculix-ccx-2.1/ccx_2.3/src/materialdata_cond.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materialdata_cond.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,68 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materialdata_cond(imat,ntmat_,t1l,cocon,ncocon,cond) +! + implicit none +! +! determines the following gas properties: the density, +! specific heat, the dynamic viscosity, the specific gas constant +! and the thermal conductivity +! + integer imat,ntmat_,id,ncocon(2,*),ncoconst,seven +! + real*8 t1l,cocon(0:6,ntmat_,*),cond +! + seven=7 +! +! calculating the conductivity coefficients +! + ncoconst=ncocon(1,imat) + if(ncoconst.ne.1) then + write(*,*) '*ERROR in materialdata_fl' + write(*,*) + & ' conductivity for fluids must be isotropic' + stop + endif +! + call ident2(cocon(0,1,imat),t1l,ncocon(2,imat),seven,id) + if(ncocon(2,imat).eq.0) then + cond=0.d0 + continue + elseif(ncocon(2,imat).eq.1) then + cond=cocon(1,1,imat) + elseif(id.eq.0) then + cond=cocon(1,1,imat) + elseif(id.eq.ncocon(2,imat)) then + cond=cocon(1,id,imat) + else + cond=(cocon(1,id,imat)+ + & (cocon(1,id+1,imat)-cocon(1,id,imat))* + & (t1l-cocon(0,id,imat))/ + & (cocon(0,id+1,imat)-cocon(0,id,imat))) + & + endif +! + return + end + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/materialdata_cp.f calculix-ccx-2.3/ccx_2.3/src/materialdata_cp.f --- calculix-ccx-2.1/ccx_2.3/src/materialdata_cp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materialdata_cp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,56 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materialdata_cp(imat,ntmat_,t1l,shcon,nshcon,cp) +! + implicit none +! +! determines the specific heat +! + integer imat,ntmat_,id,nshcon(*),four +! + real*8 t1l,shcon(0:3,ntmat_,*),cp +! + four=4 +! +! calculating the specific heat and the dynamic viscosity +! + call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) + if(nshcon(imat).eq.0) then + continue + elseif(nshcon(imat).eq.1) then + cp=shcon(1,1,imat) + elseif(id.eq.0) then + cp=shcon(1,1,imat) + elseif(id.eq.nshcon(imat)) then + cp=shcon(1,id,imat) + else + cp=shcon(1,id,imat)+ + & (shcon(1,id+1,imat)-shcon(1,id,imat))* + & (t1l-shcon(0,id,imat))/ + & (shcon(0,id+1,imat)-shcon(0,id,imat)) + endif +! + return + end + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/materialdata_cp_sec.f calculix-ccx-2.3/ccx_2.3/src/materialdata_cp_sec.f --- calculix-ccx-2.1/ccx_2.3/src/materialdata_cp_sec.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materialdata_cp_sec.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,80 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materialdata_cp_sec(imat,ntmat_,t1l,shcon,nshcon,cp, + & physcon) +! + implicit none +! +! determines the secant specific heat at constant pressure cp +! +! the difference with materialdata_cp is that the specific heat at +! constant pressure cp as returned from the present routine +! is the secant value and not the differential value. +! For the differential value we have: +! dh=cp*dT +! and consequently +! h=int_from_0_to_T cp*dT cp*dT +! For the secant value one has: +! h=cp_secant*T +! + integer imat,ntmat_,id,nshcon(*),four,i +! + real*8 t1l,shcon(0:3,ntmat_,*),cp,physcon(*) +! + four=4 +! +! calculating the tangent specific heat +! + call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) + if(nshcon(imat).eq.0) then + continue + elseif(nshcon(imat).eq.1) then + cp=shcon(1,1,imat) + elseif(id.eq.0) then + cp=shcon(1,1,imat) + elseif(id.eq.nshcon(imat)) then + cp=(shcon(0,1,imat)-physcon(1))*shcon(1,1,imat) + do i=2,nshcon(imat) + cp=cp+(shcon(0,i,imat)-shcon(0,i-1,imat))* + & (shcon(1,i,imat)+shcon(1,i-1,imat))/2.d0 + enddo + cp=cp+(t1l-shcon(0,nshcon(imat),imat))* + & (shcon(1,nshcon(imat),imat))/(t1l-physcon(1)) + else + cp=shcon(1,id,imat)+ + & (shcon(1,id+1,imat)-shcon(1,id,imat))* + & (t1l-shcon(0,id,imat))/ + & (shcon(0,id+1,imat)-shcon(0,id,imat)) + cp=(t1l-shcon(0,id,imat))*(cp+shcon(1,id,imat))/2.d0 + do i=2,id + cp=cp+(shcon(0,i,imat)-shcon(0,i-1,imat))* + & (shcon(1,i,imat)+shcon(1,i-1,imat))/2.d0 + enddo + cp=cp+(shcon(0,1,imat)-physcon(1))*shcon(1,1,imat) + cp=cp/(t1l-physcon(1)) + endif +! + return + end + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/materialdata_dvi.f calculix-ccx-2.3/ccx_2.3/src/materialdata_dvi.f --- calculix-ccx-2.1/ccx_2.3/src/materialdata_dvi.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materialdata_dvi.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,54 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materialdata_dvi(imat,ntmat_,t1l,shcon,nshcon,dvi) +! + implicit none +! +! determines the dynamic viscosity +! + integer imat,ntmat_,id,nshcon(*),four +! + real*8 t1l,shcon(0:3,ntmat_,*),dvi +! + four=4 +! + call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) + if(nshcon(imat).eq.0) then + continue + elseif(nshcon(imat).eq.1) then + dvi=shcon(2,1,imat) + elseif(id.eq.0) then + dvi=shcon(2,1,imat) + elseif(id.eq.nshcon(imat)) then + dvi=shcon(2,id,imat) + else + dvi=shcon(2,id,imat)+ + & (shcon(2,id+1,imat)-shcon(2,id,imat))* + & (t1l-shcon(0,id,imat))/ + & (shcon(0,id+1,imat)-shcon(0,id,imat)) + endif +! + return + end + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/materialdata_me.f calculix-ccx-2.3/ccx_2.3/src/materialdata_me.f --- calculix-ccx-2.1/ccx_2.3/src/materialdata_me.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materialdata_me.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,448 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materialdata_me(elcon,nelcon,rhcon,nrhcon,alcon,nalcon, + & imat,amat,iorien,pgauss,orab,ntmat_,elas,rho,i,ithermal, + & alzero,mattyp,t0l,t1l,ihyper,istiff,elconloc,eth,kode,plicon, + & nplicon,plkcon,nplkcon,npmat_,plconloc,mi,dtime,iel,iint, + & xstiff,ncmat_) +! + implicit none +! +! determines the material data for element i +! +! istiff=0: only interpolation of material data +! istiff=1: copy the consistent tangent matrix from the field +! xstiff and check for zero entries +! + character*80 amat +! + integer nelcon(2,*),nrhcon(*),nalcon(2,*), + & imat,iorien,ithermal,i,j,k,mattyp,kal(2,6),j1,j2,j3,j4, + & jj,ntmat_,istiff,nelconst,ihyper,kode,itemp,kin,nelas, + & iel,iint,mi(2),ncmat_,id,two,seven +! + integer nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ +! + real*8 elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*), + & alcon(0:6,ntmat_,*),eth(6),xstiff(27,mi(1),*), + & orab(7,*),elas(21),alph(6),alzero(*),rho,t0l,t1l, + & skl(3,3),xa(3,3),elconloc(21),emax,pgauss(3) +! + real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), + & plconloc(82),dtime +! + data kal /1,1,2,2,3,3,1,2,1,3,2,3/ +! + two=2 + seven=7 +! +! nelconst: # constants read from file +! nelas: # constants in the local tangent stiffness matrix +! + if(istiff.eq.1) then + + nelas=nelcon(1,imat) + if((nelas.lt.0).or.((nelas.ne.2).and.(iorien.ne.0))) nelas=21 +! +! calculating the density (needed for the mass matrix and +! gravity or centrifugal loading) +! + if(ithermal.eq.0) then + rho=rhcon(1,1,imat) + else + call ident2(rhcon(0,1,imat),t1l,nrhcon(imat),two,id) + if(nrhcon(imat).eq.0) then + continue + elseif(nrhcon(imat).eq.1) then + rho=rhcon(1,1,imat) + elseif(id.eq.0) then + rho=rhcon(1,1,imat) + elseif(id.eq.nrhcon(imat)) then + rho=rhcon(1,id,imat) + else + rho=rhcon(1,id,imat)+ + & (rhcon(1,id+1,imat)-rhcon(1,id,imat))* + & (t1l-rhcon(0,id,imat))/ + & (rhcon(0,id+1,imat)-rhcon(0,id,imat)) + endif + endif +! +! for nonlinear behavior (nonlinear geometric or +! nonlinear material behavior): copy the stiffness matrix +! from the last stress calculation +! + do j=1,21 + elas(j)=xstiff(j,iint,iel) + enddo +! +! check whether the fully anisotropic case can be +! considered as orthotropic +! + if(nelas.eq.21) then + emax=0.d0 + do j=1,9 + emax=max(emax,dabs(elas(j))) + enddo + do j=10,21 + if(dabs(elas(j)).gt.emax*1.d-10) then + emax=-1.d0 + exit + endif + enddo + if(emax.gt.0.d0) nelas=9 + endif +! +! determining the type: isotropic, orthotropic or anisotropic +! + if(nelas.le.2) then + mattyp=1 + elseif(nelas.le.9) then + mattyp=2 + else + mattyp=3 + endif +! + else +! + nelconst=nelcon(1,imat) +! + if(nelconst.lt.0) then +! +! inelastic material or user material +! + if(nelconst.eq.-1) then + nelconst=3 + elseif(nelconst.eq.-2) then + nelconst=3 + elseif(nelconst.eq.-3) then + nelconst=2 + elseif(nelconst.eq.-4) then + nelconst=3 + elseif(nelconst.eq.-5) then + nelconst=6 + elseif(nelconst.eq.-6) then + nelconst=9 + elseif(nelconst.eq.-7) then + nelconst=3 + elseif(nelconst.eq.-8) then + nelconst=7 + elseif(nelconst.eq.-9) then + nelconst=12 + elseif(nelconst.eq.-10) then + nelconst=2 + elseif(nelconst.eq.-11) then + nelconst=4 + elseif(nelconst.eq.-12) then + nelconst=6 + elseif(nelconst.eq.-13) then + nelconst=5 + elseif(nelconst.eq.-14) then + nelconst=6 + elseif(nelconst.eq.-15) then + nelconst=3 + elseif(nelconst.eq.-16) then + nelconst=6 + elseif(nelconst.eq.-17) then + nelconst=9 + elseif(nelconst.eq.-50) then + nelconst=5 + elseif(nelconst.eq.-51) then + nelconst=2 + elseif(nelconst.eq.-52) then + nelconst=5 + elseif(nelconst.le.-100) then + nelconst=-nelconst-100 + endif +! + endif +! +! in case no initial temperatures are defined, the calculation +! is assumed athermal, and the first available set material +! constants are used +! + if(ithermal.eq.0) then + if(ihyper.ne.1) then + do k=1,nelconst + elconloc(k)=elcon(k,1,imat) + enddo + else + do k=1,nelconst + elconloc(k)=elcon(k,1,imat) + enddo +! + itemp=1 +! + if((kode.lt.-50).and.(kode.gt.-100)) then + plconloc(1)=0.d0 + plconloc(2)=0.d0 + plconloc(3)=0.d0 + plconloc(81)=nplicon(1,imat)+0.5d0 + plconloc(82)=nplkcon(1,imat)+0.5d0 +! +! isotropic hardening +! + if(nplicon(1,imat).ne.0) then + kin=0 + call plcopy(plicon,nplicon,plconloc,npmat_,ntmat_, + & imat,itemp,i,kin) + endif +! +! kinematic hardening +! + if(nplkcon(1,imat).ne.0) then + kin=1 + call plcopy(plkcon,nplkcon,plconloc,npmat_,ntmat_, + & imat,itemp,i,kin) + endif +! + endif +! + endif + else +! +! calculating the expansion coefficients +! + call ident2(alcon(0,1,imat),t1l,nalcon(2,imat),seven,id) + if(nalcon(2,imat).eq.0) then + do k=1,6 + alph(k)=0.d0 + enddo + continue + elseif(nalcon(2,imat).eq.1) then + do k=1,nalcon(1,imat) + alph(k)=alcon(k,1,imat)*(t1l-alzero(imat)) + enddo + elseif(id.eq.0) then + do k=1,nalcon(1,imat) + alph(k)=alcon(k,1,imat)*(t1l-alzero(imat)) + enddo + elseif(id.eq.nalcon(2,imat)) then + do k=1,nalcon(1,imat) + alph(k)=alcon(k,id,imat)*(t1l-alzero(imat)) + enddo + else + do k=1,nalcon(1,imat) + alph(k)=(alcon(k,id,imat)+ + & (alcon(k,id+1,imat)-alcon(k,id,imat))* + & (t1l-alcon(0,id,imat))/ + & (alcon(0,id+1,imat)-alcon(0,id,imat))) + & *(t1l-alzero(imat)) + enddo + endif +! +! subtracting the initial temperature influence +! + call ident2(alcon(0,1,imat),t0l,nalcon(2,imat),seven,id) + if(nalcon(2,imat).eq.0) then + continue + elseif(nalcon(2,imat).eq.1) then + do k=1,nalcon(1,imat) + alph(k)=alph(k)-alcon(k,1,imat)*(t0l-alzero(imat)) + enddo + elseif(id.eq.0) then + do k=1,nalcon(1,imat) + alph(k)=alph(k)-alcon(k,1,imat)*(t0l-alzero(imat)) + enddo + elseif(id.eq.nalcon(2,imat)) then + do k=1,nalcon(1,imat) + alph(k)=alph(k)-alcon(k,id,imat)*(t0l-alzero(imat)) + enddo + else + do k=1,nalcon(1,imat) + alph(k)=alph(k)-(alcon(k,id,imat)+ + & (alcon(k,id+1,imat)-alcon(k,id,imat))* + & (t0l-alcon(0,id,imat))/ + & (alcon(0,id+1,imat)-alcon(0,id,imat))) + & *(t0l-alzero(imat)) + enddo + endif +! +! storing the thermal strains +! + if(nalcon(1,imat).eq.1) then + do k=1,3 + eth(k)=alph(1) + enddo + do k=4,6 + eth(k)=0.d0 + enddo + elseif(nalcon(1,imat).eq.3) then + do k=1,3 + eth(k)=alph(k) + enddo + do k=4,6 + eth(k)=0.d0 + enddo + else + do k=1,6 + eth(k)=alph(k) + enddo + endif +! +! calculating the hardening coefficients +! +! for the calculation of the stresses, the whole curve +! has to be stored: +! plconloc(2*k-1), k=1...20: equivalent plastic strain values (iso) +! plconloc(2*k),k=1...20: corresponding stresses (iso) +! plconloc(39+2*k),k=1...20: equivalent plastic strain values (kin) +! plconloc(40+2*k),k=1...20: corresponding stresses (kin) +! +! initialization +! + if((kode.lt.-50).and.(kode.gt.-100)) then + if(npmat_.eq.0) then + plconloc(81)=0.5d0 + plconloc(82)=0.5d0 + else + plconloc(1)=0.d0 + plconloc(2)=0.d0 + plconloc(3)=0.d0 + plconloc(81)=nplicon(1,imat)+0.5d0 + plconloc(82)=nplkcon(1,imat)+0.5d0 +! +! isotropic hardening +! + if(nplicon(1,imat).ne.0) then +! + if(nplicon(0,imat).eq.1) then + id=-1 + else + call ident2(plicon(0,1,imat),t1l, + & nplicon(0,imat),2*npmat_+1,id) + endif +! + if(nplicon(0,imat).eq.0) then + continue + elseif((nplicon(0,imat).eq.1).or.(id.eq.0).or. + & (id.eq.nplicon(0,imat))) then + if(id.le.0) then + itemp=1 + else + itemp=id + endif + kin=0 + call plcopy(plicon,nplicon,plconloc,npmat_, + & ntmat_,imat,itemp,i,kin) + if((id.eq.0).or.(id.eq.nplicon(0,imat))) then + endif + else + kin=0 + call plmix(plicon,nplicon,plconloc,npmat_, + & ntmat_,imat,id+1,t1l,i,kin) + endif + endif +! +! kinematic hardening +! + if(nplkcon(1,imat).ne.0) then +! + if(nplkcon(0,imat).eq.1) then + id=-1 + else + call ident2(plkcon(0,1,imat),t1l, + & nplkcon(0,imat),2*npmat_+1,id) + endif +! + if(nplkcon(0,imat).eq.0) then + continue + elseif((nplkcon(0,imat).eq.1).or.(id.eq.0).or. + & (id.eq.nplkcon(0,imat))) then + if(id.le.0)then + itemp=1 + else + itemp=id + endif + kin=1 + call plcopy(plkcon,nplkcon,plconloc,npmat_, + & ntmat_,imat,itemp,i,kin) + if((id.eq.0).or.(id.eq.nplkcon(0,imat))) then + endif + else + kin=1 + call plmix(plkcon,nplkcon,plconloc,npmat_, + & ntmat_,imat,id+1,t1l,i,kin) + endif + endif + endif + endif +! +! calculating the elastic constants +! + call ident2(elcon(0,1,imat),t1l,nelcon(2,imat),ncmat_+1,id) + if(nelcon(2,imat).eq.0) then + continue + elseif(nelcon(2,imat).eq.1) then + do k=1,nelconst + elconloc(k)=elcon(k,1,imat) + enddo + elseif(id.eq.0) then + do k=1,nelconst + elconloc(k)=elcon(k,1,imat) + enddo + elseif(id.eq.nelcon(2,imat)) then + do k=1,nelconst + elconloc(k)=elcon(k,id,imat) + enddo + else + do k=1,nelconst + elconloc(k)=elcon(k,id,imat)+ + & (elcon(k,id+1,imat)-elcon(k,id,imat))* + & (t1l-elcon(0,id,imat))/ + & (elcon(0,id+1,imat)-elcon(0,id,imat)) + enddo + endif +! +! modifying the thermal constants if anisotropic and +! a transformation was defined +! + if((iorien.ne.0).and.(nalcon(1,imat).gt.1)) then +! +! calculating the transformation matrix +! + call transformatrix(orab(1,iorien),pgauss,skl) +! +! transforming the thermal strain +! + xa(1,1)=eth(1) + xa(1,2)=eth(4) + xa(1,3)=eth(5) + xa(2,1)=eth(4) + xa(2,2)=eth(2) + xa(2,3)=eth(6) + xa(3,1)=eth(5) + xa(3,2)=eth(6) + xa(3,3)=eth(3) +! + do jj=1,6 + eth(jj)=0.d0 + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + eth(jj)=eth(jj)+ + & xa(j3,j4)*skl(j1,j3)*skl(j2,j4) + enddo + enddo + enddo + endif + endif + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/materialdata_rho.f calculix-ccx-2.3/ccx_2.3/src/materialdata_rho.f --- calculix-ccx-2.1/ccx_2.3/src/materialdata_rho.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materialdata_rho.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,52 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materialdata_rho(rhcon,nrhcon,imat,rho, + & t1l,ntmat_,ithermal) +! + implicit none +! +! determines the density of the material +! + integer nrhcon(*),imat,two,ntmat_,id,ithermal +! + real*8 rhcon(0:1,ntmat_,*),rho,t1l +! + two=2 +! + if(ithermal.eq.0) then + rho=rhcon(1,1,imat) + else + call ident2(rhcon(0,1,imat),t1l,nrhcon(imat),two,id) + if(nrhcon(imat).eq.0) then + continue + elseif(nrhcon(imat).eq.1) then + rho=rhcon(1,1,imat) + elseif(id.eq.0) then + rho=rhcon(1,1,imat) + elseif(id.eq.nrhcon(imat)) then + rho=rhcon(1,id,imat) + else + rho=rhcon(1,id,imat)+ + & (rhcon(1,id+1,imat)-rhcon(1,id,imat))* + & (t1l-rhcon(0,id,imat))/ + & (rhcon(0,id+1,imat)-rhcon(0,id,imat)) + endif + endif + return + end +! diff -Nru calculix-ccx-2.1/ccx_2.3/src/materialdata_sp.f calculix-ccx-2.3/ccx_2.3/src/materialdata_sp.f --- calculix-ccx-2.1/ccx_2.3/src/materialdata_sp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materialdata_sp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,115 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materialdata_sp(elcon,nelcon,imat,ntmat_,i,t1l, + & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) +! + implicit none +! +! determines the material data for element i +! + integer nelcon(2,*),imat,i,k,kin,ntmat_,nelconst,kode, + & itemp,ncmat_,id,nplicon(0:ntmat_,*),npmat_ +! + real*8 elcon(0:ncmat_,ntmat_,*),t1l,elconloc(21), + & plicon(0:2*npmat_,ntmat_,*),plconloc(82) +! +! nelconst: # constants read from file +! +! calculating the hardening coefficients +! +! for the calculation of the spring stiffness, the whole curve +! has to be stored: +! plconloc(2*k-1), k=1...20: displacement +! plconloc(2*k),k=1...20: force +! + if(kode.lt.-50) then + if(npmat_.eq.0) then + plconloc(81)=0.5d0 + plconloc(82)=0.5d0 + else + plconloc(1)=0.d0 + plconloc(2)=0.d0 + plconloc(3)=0.d0 + plconloc(81)=nplicon(1,imat)+0.5d0 + plconloc(82)=0.5d0 +! +! nonlinear spring characteristic or gap conductance characteristic +! + if(nplicon(1,imat).ne.0) then +! + if(nplicon(0,imat).eq.1) then + id=-1 + else + call ident2(plicon(0,1,imat),t1l,nplicon(0,imat), + & 2*npmat_+1,id) + endif +! + if(nplicon(0,imat).eq.0) then + continue + elseif((nplicon(0,imat).eq.1).or.(id.eq.0).or. + & (id.eq.nplicon(0,imat))) then + if(id.le.0) then + itemp=1 + else + itemp=id + endif + kin=0 + call plcopy(plicon,nplicon,plconloc,npmat_,ntmat_, + & imat,itemp,i,kin) + if((id.eq.0).or.(id.eq.nplicon(0,imat))) then + endif + else + kin=0 + call plmix(plicon,nplicon,plconloc,npmat_,ntmat_, + & imat,id+1,t1l,i,kin) + endif + endif + endif + else +! +! linear spring characteristic +! + nelconst=nelcon(1,imat) + call ident2(elcon(0,1,imat),t1l,nelcon(2,imat),ncmat_+1,id) + if(nelcon(2,imat).eq.0) then + continue + elseif(nelcon(2,imat).eq.1) then + do k=1,nelconst + elconloc(k)=elcon(k,1,imat) + enddo + elseif(id.eq.0) then + do k=1,nelconst + elconloc(k)=elcon(k,1,imat) + enddo + elseif(id.eq.nelcon(2,imat)) then + do k=1,nelconst + elconloc(k)=elcon(k,id,imat) + enddo + else + do k=1,nelconst + elconloc(k)=elcon(k,id,imat)+ + & (elcon(k,id+1,imat)-elcon(k,id,imat))* + & (t1l-elcon(0,id,imat))/ + & (elcon(0,id+1,imat)-elcon(0,id,imat)) + enddo + endif + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/materialdata_tg.f calculix-ccx-2.3/ccx_2.3/src/materialdata_tg.f --- calculix-ccx-2.1/ccx_2.3/src/materialdata_tg.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materialdata_tg.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,90 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materialdata_tg(imat,ntmat_,t1l,shcon,nshcon,sph,r, + & dvi,rhcon,nrhcon,rho) +! + implicit none +! +! determines the following gas properties: the density, +! the specific heat, the dynamic viscosity and the specific gas constant +! + integer imat,ntmat_,id,nshcon(*),two,four,nrhcon(*) +! + real*8 t1l,shcon(0:3,ntmat_,*),sph,r,dvi,rhcon(0:1,ntmat_,*), + & rho +! + two=2 + four=4 +! +! calculating the density (needed for liquids) +! + call ident2(rhcon(0,1,imat),t1l,nrhcon(imat),two,id) + if(nrhcon(imat).eq.0) then + rho=0.d0 + continue + elseif(nrhcon(imat).eq.1) then + rho=rhcon(1,1,imat) + elseif(id.eq.0) then + rho=rhcon(1,1,imat) + elseif(id.eq.nrhcon(imat)) then + rho=rhcon(1,id,imat) + else + rho=rhcon(1,id,imat)+ + & (rhcon(1,id+1,imat)-rhcon(1,id,imat))* + & (t1l-rhcon(0,id,imat))/ + & (rhcon(0,id+1,imat)-rhcon(0,id,imat)) + endif +! +! calculating the specific heat and the dynamic viscosity +! + call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) + if(nshcon(imat).eq.0) then + continue + elseif(nshcon(imat).eq.1) then + sph=shcon(1,1,imat) + dvi=shcon(2,1,imat) + elseif(id.eq.0) then + sph=shcon(1,1,imat) + dvi=shcon(2,1,imat) + elseif(id.eq.nshcon(imat)) then + sph=shcon(1,id,imat) + dvi=shcon(2,id,imat) + else + sph=shcon(1,id,imat)+ + & (shcon(1,id+1,imat)-shcon(1,id,imat))* + & (t1l-shcon(0,id,imat))/ + & (shcon(0,id+1,imat)-shcon(0,id,imat)) + dvi=shcon(2,id,imat)+ + & (shcon(2,id+1,imat)-shcon(2,id,imat))* + & (t1l-shcon(0,id,imat))/ + & (shcon(0,id+1,imat)-shcon(0,id,imat)) + endif +! +! specific gas constant +! + r=shcon(3,1,imat) +! + return + end + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/materialdata_th.f calculix-ccx-2.3/ccx_2.3/src/materialdata_th.f --- calculix-ccx-2.1/ccx_2.3/src/materialdata_th.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materialdata_th.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,136 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materialdata_th(cocon,ncocon,imat,iorien,pgauss,orab, + & ntmat_,coconloc,mattyp,t1l,rhcon,nrhcon,rho,shcon,nshcon,sph, + & xstiff,iint,iel,istiff,mi) +! + implicit none +! +! determines the density, the specific heat and the conductivity +! in an integration point with coordinates pgauss +! + integer ncocon(2,*),imat,iorien,k,mattyp,mi(2), + & ntmat_,id,two,four,seven,nrhcon(*),nshcon(*), + & iint,iel,ncond,istiff,ncoconst +! + real*8 cocon(0:6,ntmat_,*),orab(7,*),coconloc(6),t1l, + & pgauss(3),rhcon(0:1,ntmat_,*), + & shcon(0:3,ntmat_,*),rho,sph,xstiff(27,mi(1),*) +! + two=2 + four=4 + seven=7 +! + if(istiff.eq.1) then +! + ncond=ncocon(1,imat) + if((ncond.le.-100).or.(iorien.ne.0)) ncond=6 +! +! calculating the density (needed for the capacity matrix) +! + call ident2(rhcon(0,1,imat),t1l,nrhcon(imat),two,id) + if(nrhcon(imat).eq.0) then + continue + elseif(nrhcon(imat).eq.1) then + rho=rhcon(1,1,imat) + elseif(id.eq.0) then + rho=rhcon(1,1,imat) + elseif(id.eq.nrhcon(imat)) then + rho=rhcon(1,id,imat) + else + rho=rhcon(1,id,imat)+ + & (rhcon(1,id+1,imat)-rhcon(1,id,imat))* + & (t1l-rhcon(0,id,imat))/ + & (rhcon(0,id+1,imat)-rhcon(0,id,imat)) + endif +! +! calculating the specific heat (needed for the capacity matrix) +! + call ident2(shcon(0,1,imat),t1l,nshcon(imat),four,id) + if(nshcon(imat).eq.0) then + continue + elseif(nshcon(imat).eq.1) then + sph=shcon(1,1,imat) + elseif(id.eq.0) then + sph=shcon(1,1,imat) + elseif(id.eq.nshcon(imat)) then + sph=shcon(1,id,imat) + else + sph=shcon(1,id,imat)+ + & (shcon(1,id+1,imat)-shcon(1,id,imat))* + & (t1l-shcon(0,id,imat))/ + & (shcon(0,id+1,imat)-shcon(0,id,imat)) + endif +! +! determining the conductivity coefficients +! + do k=1,6 + coconloc(k)=xstiff(21+k,iint,iel) + enddo +! +! determining the type: isotropic, orthotropic or anisotropic +! + if(ncond.le.1) then + mattyp=1 + elseif(ncond.le.3) then + mattyp=2 + else + mattyp=3 + endif +! + else +! + ncoconst=ncocon(1,imat) + if(ncoconst.le.-100) ncoconst=-ncoconst-100 +! +! calculating the conductivity coefficients +! + call ident2(cocon(0,1,imat),t1l,ncocon(2,imat),seven,id) + if(ncocon(2,imat).eq.0) then + do k=1,6 + coconloc(k)=0.d0 + enddo + continue + elseif(ncocon(2,imat).eq.1) then + do k=1,ncoconst + coconloc(k)=cocon(k,1,imat) + enddo + elseif(id.eq.0) then + do k=1,ncoconst + coconloc(k)=cocon(k,1,imat) + enddo + elseif(id.eq.ncocon(2,imat)) then + do k=1,ncoconst + coconloc(k)=cocon(k,id,imat) + enddo + else + do k=1,ncoconst + coconloc(k)=(cocon(k,id,imat)+ + & (cocon(k,id+1,imat)-cocon(k,id,imat))* + & (t1l-cocon(0,id,imat))/ + & (cocon(0,id+1,imat)-cocon(0,id,imat))) + & + enddo + endif + endif +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/materials.f calculix-ccx-2.3/ccx_2.3/src/materials.f --- calculix-ccx-2.1/ccx_2.3/src/materials.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/materials.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,69 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine materials(inpc,textpart,matname,nmat,nmat_, + & irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *MATERIAL +! + implicit none +! + character*1 inpc(*) + character*80 matname(*) + character*132 textpart(16) +! + integer nmat,nmat_,istep,istat,n,key,i,irstrt,iline,ipol,inl, + & ipoinp(2,*),inp(3,*),ipoinpc(0:*) +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in materials: *MATERIAL should be placed' + write(*,*) ' before all step definitions' + stop + endif +! + nmat=nmat+1 + if(nmat.gt.nmat_) then + write(*,*) '*ERROR in materials: increase nmat_' + stop + endif +! + do i=2,n + if(textpart(i)(1:5).eq.'NAME=') then + matname(nmat)=textpart(i)(6:85) + if(textpart(i)(86:86).ne.' ') then + write(*,*) '*ERROR in materials: material name too long' + write(*,*) ' (more than 80 characters)' + write(*,*) ' material name:',textpart(i)(1:132) + stop + endif + exit + else + write(*,*) + & '*WARNING in materials: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/matrixstorage.c calculix-ccx-2.3/ccx_2.3/src/matrixstorage.c --- calculix-ccx-2.1/ccx_2.3/src/matrixstorage.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/matrixstorage.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,503 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" +#include "matrixstorage.h" + +void matrixstorage(double *ad, double **aup, double *adb, double *aub, + double *sigma,int *icol, int **irowp, + int *neq, int *nzs, int *ntrans, int *inotr, + double *trab, double *co, int *nk, int *nactdof, + char *jobnamec, int *mi){ + + char fsti[132]="",fmas[132]=""; + int i,j,k,l,*irow=NULL,*ai=NULL,*aj=NULL,kflag=2,ndim,jref,kstart,klen, + *ipoint=NULL,npoint_,npoint,neq3,index,i3l,i3c,i3lo,i3co,idof,n,il, + ic,id,itrans,ndim2,*ipoindex=NULL,mt=mi[1]+1; + double *au=NULL,*aa=NULL,*trans=NULL,*aa3=NULL,a[9]; + FILE *f2,*f3; + + strcpy(fsti,jobnamec); + strcat(fsti,".sti"); + + printf(" Storing the stiffness matrix in file %s \n\n",fsti); + printf(" *INFO: this routine only works in the absence of SPC's!\n and in the absence of transformations in combination\n with equations\n\n "); + + if((f2=fopen(fsti,"wb"))==NULL){ + printf("*ERROR in matrixstorage: cannot open %s for writing...\n",fsti); + FORTRAN(stop,()); + } + + au=*aup; + irow=*irowp; + + ndim=*neq+*nzs; + + itrans=0; + if(*ntrans!=0){ + for(i=0;i<*nk;i++){ + if(inotr[2*i]!=0){ + itrans=1; + break; + } + } + } + + /* stiffness matrix */ + + if(itrans==0){ + + /* no transformation */ + + aa=NNEW(double,ndim); + ai=NNEW(int,ndim); + aj=NNEW(int,ndim); + + k=0; + for(i=0;i<*neq;i++){ + ai[k]=i+1; + aj[k]=i+1; + aa[k]=ad[i]; + k++; + } + l=0; + for(i=0;i<*neq;i++){ + for(j=0;jnpoint_){ + npoint_=(int)(1.1*npoint_); + RENEW(ipoint,int,npoint_); + RENEW(ipoindex,int,npoint_); + } + index+=9; + ipoint[npoint-1]=k; + ipoindex[npoint-1]=index; + } + else{ + index=ipoindex[id-1]; + } + aa3[index+3*i3co+i3lo]=aa[i]; + } + + /* defining the transformation matrix (diagonal matrix of + 3x3 submatrices */ + + trans=NNEW(double,9*neq3); + for (i=0;i<*nk;i++){ + idof=nactdof[mt*i+1]; + if(idof==0) continue; + itrans=inotr[2*i]; + if(itrans==0){ + for(j=0;j<9;j++){ + trans[3*(idof-1)+j]=0.; + } + trans[3*(idof-1)]=1.; + trans[3*(idof-1)+4]=1.; + trans[3*(idof-1)+8]=1.; + } + else{ + FORTRAN(transformatrix,(&trab[7*itrans-7],&co[3*i],a)); + for(j=0;j<9;j++){ + trans[3*(idof-1)+j]=a[j]; + } + } + } + + /* postmultiplying the matrix with the transpose of the + transformation matrix */ + + for(i=0;iic) continue; + k++; + ai[k]=il; + aj[k]=ic; + aa[k]=aa3[9*i+j]; + } + } + free(aa3);free(ipoint);free(ipoindex);free(trans); + } + + FORTRAN(isortiid,(aj,ai,aa,&ndim,&kflag)); + + k=0; + for(i=0;i<*neq;i++){ + jref=aj[k]; + kstart=k; + do{ + k++; + if(aj[k]!=jref) break; + }while(1); + klen=k-kstart; + FORTRAN(isortiid,(&ai[kstart],&aj[kstart],&aa[kstart],&klen,&kflag)); + } + + for(i=0;inpoint_){ + npoint_=(int)(1.1*npoint_); + RENEW(ipoint,int,npoint_); + RENEW(ipoindex,int,npoint_); + } + index+=9; + ipoint[npoint-1]=k; + ipoindex[npoint-1]=index; + } + else{ + index=ipoindex[id-1]; + } + aa3[index+3*i3co+i3lo]=aa[i]; + } + + /* defining the transformation matrix (diagonal matrix of + 3x3 submatrices */ + + trans=NNEW(double,9*neq3); + for (i=0;i<*nk;i++){ + idof=nactdof[mt*i+1]; + if(idof==0) continue; + itrans=inotr[2*i]; + if(itrans==0){ + for(j=0;j<9;j++){ + trans[3*(idof-1)+j]=0.; + } + trans[3*(idof-1)]=1.; + trans[3*(idof-1)+4]=1.; + trans[3*(idof-1)+8]=1.; + } + else{ + FORTRAN(transformatrix,(&trab[7*itrans-7],&co[3*i],a)); + for(j=0;j<9;j++){ + trans[3*(idof-1)+j]=a[j]; + } + } + } + + /* postmultiplying the matrix with the transpose of the + transformation matrix */ + + for(i=0;iic) continue; + k++; + ai[k]=il; + aj[k]=ic; + aa[k]=aa3[9*i+j]; + } + } + free(aa3);free(ipoint);free(ipoindex);free(trans); + } + + FORTRAN(isortiid,(aj,ai,aa,&ndim,&kflag)); + + k=0; + for(i=0;i<*neq;i++){ + jref=aj[k]; + kstart=k; + do{ + k++; + if(aj[k]!=jref) break; + }while(1); + klen=k-kstart; + FORTRAN(isortiid,(&ai[kstart],&aj[kstart],&aa[kstart],&klen,&kflag)); + } + + for(i=0;i +#include +#include +#include +#include +#include "CalculiX.h" + +/* + Multiplication of (Bd)^T*A*Bd +*/ + +void multimortar(double *au, double *ad, int *irow, int *jq, int *nzs, + double *aubd, double *bdd, int *irowbd, int *jqbd, int *nzsbd, + double **aucp, double *adc, int **irowcp, int *jqc, int *nzsc, + double *auqdt,int *irowqdt,int *jqqdt,int *nzsqdt, + int *neq,double *b, double *bhat,int* islavnode, int*imastnode,int*nactdof, + int nslavs,int nmasts,int * mi){ + + /*compteurs*/ + + int i,j,k,l,m,icol,mt=mi[1]+1,nodes,nodem,row_ln,row_lm,row_ls,kflag,flag_diag=0; + /* Different matrices */ + int *irow_nn=NULL,*jq_nn=NULL,*irow_sn=NULL,*jq_sn=NULL,numb, + *irow_mn=NULL,*jq_mn=NULL,*irow_mm=NULL,*jq_mm=NULL, + *irow_sm=NULL,*jq_sm=NULL,*irow_ss=NULL,*jq_ss=NULL, + *irowc=NULL,*irow_bdtil=NULL,*jq_bdtil=NULL, + *irow_ssd=NULL,*irow_mmd=NULL,*jq_ssd=NULL,*jq_mmd=NULL; + + double *au_nn=NULL,*bd_nn=NULL,*au_sn=NULL, + *au_mn=NULL,*bd_mn=NULL,*au_mm=NULL,*au_ms=NULL, + *au_sm=NULL,*au_ss=NULL,*auc=NULL,*au_bdtil=NULL, + *au_ssd=NULL,*au_mmd=NULL; + + clock_t debut; + clock_t fin; + irowc = *irowcp; auc=*aucp; + + /* Flag to produce the bijection between local and global dof*/ + + /*Au is symmetric compute the non_symmeric whole au_matrix*/ + double *au_w=NULL,*au_t=NULL; + int *irow_w=NULL,*irow_t=NULL,*jq_w=NULL,*jq_t=NULL,nzs_t=*nzs,*mast1=NULL; + /*transpose*/ + au_t=NNEW(double,nzs_t); + irow_t=NNEW(int,nzs_t); + jq_t=NNEW(int,neq[1]+1); + jq_w=NNEW(int,neq[1]+1); + mast1=NNEW(int,nzs_t); + + +for(j=0;j0){ + numb=jq_t[i+1]-jq_t[i]; + FORTRAN(isortid,(&irow_t[jq_t[i]-1],&au_t[jq_t[i]-1],&numb,&kflag)); + } + } + + for (i=0;i0){ + numb=jq[i+1]-jq[i]; + FORTRAN(isortid,(&irow[jq[i]-1],&au[jq[i]-1],&numb,&kflag)); + } + } + + irow_w=NNEW(int,*nzs*2); + au_w=NNEW(double,*nzs*2); + + + add_rect(au,irow,jq,neq[1],neq[1], + au_t,irow_t,jq_t,neq[1],neq[1], + &au_w,&irow_w,jq_w); + + + int *l_flag=NULL,*n_flag=NULL,*m_flag=NULL,*s_flag=NULL,number=1; + /* + l_flag[i]=1 for M Master dof + l_flag[i]=2 for S Slave dof + l_flag[i]=0 for N rest of the dof + + n_flag contains local N_row number + m_flag contains local M_row number + s_flag contains local S_row number + */ + l_flag=NNEW(int,neq[1]); + n_flag=NNEW(int,neq[1]); + m_flag=NNEW(int,neq[1]); + s_flag=NNEW(int,neq[1]); + + /* Fill l_flag*/ + //Master + for (i=0;i0) l_flag[k-1]=1; + } + } + + //Slave + for (i=0;i0) l_flag[k-1]=2; + } + } + + /*** Fill the local row ***/ + row_ln=0; + row_lm=0; + row_ls=0; + + /* Stock of the diagonale */ + bd_nn=NNEW(double,neq[1]); + + + au_mmd=NNEW(double,neq[1]); + irow_mmd=NNEW(int,neq[1]); + jq_mmd=NNEW(int,neq[1]); + + au_ssd=NNEW(double,neq[1]); + irow_ssd=NNEW(int,neq[1]); + jq_ssd=NNEW(int,neq[1]); + + /**** For the construction of Bhat, the new rhs***/ + double *f_s=NULL,*f_m=NULL,*f_fm=NULL; +// bhat=NNEW(double,neq[1]); + f_s=NNEW(double,neq[1]); + f_m=NNEW(double,neq[1]); + + + for (i=0;i0){ + numb=jq_bdtil[i+1]-jq_bdtil[i]; + FORTRAN(isortid,(&irow_bdtil[jq_bdtil[i]-1],&au_bdtil[jq_bdtil[i]-1],&numb,&kflag)); + } + } +/*************************************** ALL THE SUB MATRICES have been yet computed **************************** +***************************************** Calculation of the submuliplication *********************************** +******************************************************************************************************************/ + + + /*************************************************************************** + ************************ TEST - Multiplication ***************************** + **************************************************************************** + + double a_t1[8]={1,3,4,2,4,1,1,1}; + int irow_t1[8]={1,3,4,2,3,1,4,1}; + int jq_at1[5]={1,4,6,8,9}; + double a_t2[8]={1,3,1,2,1,2,1,1},*a_t3=NULL; + int irow_t2[8]={1,3,2,3,2,3,1,4},*irow_t3=NULL; + int jq_at2[5]={1,3,5,7,9},*jq_at3=NULL; + double *dum2=NULL,*dum1=NULL,*dum3=NULL; + a_t3=NNEW(double,16); + irow_t3=NNEW(int,16); + jq_at3=NNEW(int,5); + dum3=NNEW(double,3); + flag_diag=1; + multi_rect(a_t1,irow_t1,jq_at1,4,4, + a_t2,irow_t2,jq_at2,4,4, + &a_t3,&irow_t3,jq_at3); + + add_rect(a_t1,irow_t1,jq_at1,4,4, + a_t2,irow_t2,jq_at2,4,4, + &a_t3,&irow_t3,jq_at3); + + flag_diag=0; +// delete(a_t1);delete(irow_t1);delete(jq_at1); +// delete(a_t2);delete(irow_t2);delete(jq_at2); + free(a_t3);free(irow_t3);free(jq_at3); + /*************************************************************************** + ****************************************************************************/ + + + /************* Calculation of A_MN *****************/ + + /* Bt_T * A_SN*/ + int *irow_intmn=NULL,*jq_intmn=NULL; + double *au_intmn=NULL,*bdummy1=NULL,*bdummy2=NULL,*bdummy3=NULL; + + jq_intmn=NNEW(int,row_ln+1); + au_intmn=NNEW(double,row_lm*row_ln); + irow_intmn=NNEW(int,row_lm*row_ln); + + multi_rect(au_bdtil,irow_bdtil,jq_bdtil,row_ls,row_lm, + au_sn,irow_sn,jq_sn,row_ls,row_ln, + &au_intmn,&irow_intmn,jq_intmn); + + + /************** Calculation of new A_MN=A_mn+BdT*A_SN **********************/ + + int *irow_fmn=NULL,*jq_fmn=NULL; + double *au_fmn=NULL; + jq_fmn=NNEW(int,row_ln+1); + au_fmn=NNEW(double,row_lm*row_ln); + irow_fmn=NNEW(int,row_lm*row_ln); + + add_rect(au_intmn,irow_intmn,jq_intmn,row_lm,row_ln, + au_mn,irow_mn,jq_mn,row_lm,row_ln, + &au_fmn,&irow_fmn,jq_fmn); + + // FORTRAN(writematrix,(au_fmn,ad,irow_fmn,jq_fmn,&row_ln,&number)); + /************************************************** + **************************************************/ + + /**************** Calculation of A_SM *******************/ + + int *irow_intsm1=NULL,*jq_intsm1=NULL; + double *au_intsm1=NULL; + int *irow_ssf=NULL,*jq_ssf=NULL; + double *au_ssf=NULL; + + jq_intsm1=NNEW(int,row_lm+1); + au_intsm1=NNEW(double,row_ls*row_lm); + irow_intsm1=NNEW(int,row_ls*row_lm); + + jq_ssf=NNEW(int,row_ls+1); + au_ssf=NNEW(double,row_ls*row_ls); + irow_ssf=NNEW(int,row_ls*row_ls); + + add_rect(au_ssd,irow_ssd,jq_ssd,row_ls,row_ls, + au_ss,irow_ss,jq_ss,row_ls,row_ls, + &au_ssf,&irow_ssf,jq_ssf); + + + multi_rect(au_ssf,irow_ssf,jq_ssf,row_ls,row_ls, + au_bdtil,irow_bdtil,jq_bdtil,row_ls,row_lm, + &au_intsm1,&irow_intsm1,jq_intsm1); + +// FORTRAN(writematrix,(au_intsm1,ad,irow_intsm1,jq_intsm1,&row_lm,&number)); +// FORTRAN(writematrix,(au_ss,ad,irow_ss,jq_ss,&row_ls,&number)); + /********************* the matrix intsm1 needed for new_AMM ****************/ + + + /*************** Calculation of new A_SM *********************************/ + + + + int *irow_fsm=NULL,*jq_fsm=NULL; + double *au_fsm=NULL; + + jq_fsm=NNEW(int,row_lm+1); + au_fsm=NNEW(double,row_ls*row_lm); + irow_fsm=NNEW(int,row_ls*row_lm); + + + add_rect(au_sm,irow_sm,jq_sm,row_ls,row_lm, + au_intsm1,irow_intsm1,jq_intsm1,row_ls,row_lm, + &au_fsm,&irow_fsm,jq_fsm); + +// FORTRAN(writematrix,(au_fsm,ad,irow_fsm,jq_fsm,&row_lm,&number)); + + /******************************************************** + *********************************************************/ + + /******************** Calculation of A_MM ****************/ + + /* Calculation of Bd_T*A_SM */ + + int *irow_intmm1=NULL,*jq_intmm1=NULL; + double *au_intmm1=NULL,*bd_intmm1=NULL; + + jq_intmm1=NNEW(int,row_lm+1); + bd_intmm1=NNEW(double,row_lm); + au_intmm1=NNEW(double,row_lm*row_lm); + irow_intmm1=NNEW(int,row_lm*row_lm); + + + multi_rect(au_bdtil,irow_bdtil,jq_bdtil,row_ls,row_lm, + au_sm,irow_sm,jq_sm,row_ls,row_lm, + &au_intmm1,&irow_intmm1,jq_intmm1); + +// FORTRAN(writematrix,(au_intmm1,ad,irow_intmm1,jq_intmm1,&row_lm,&number)); + + /* Calcul of A_MS*Bd = (Bd_T*A_SM)_T *************/ + + int *irow_tmm=NULL,*jq_tmm=NULL; + double *au_tmm=NULL; + + int nzs_tmm=jq_intmm1[row_lm]-1; + if (nzs_tmm!=0){ + au_tmm=NNEW(double,nzs_tmm); + }else{ + au_tmm=NNEW(double,1); + } + if (nzs_tmm!=0){ + irow_tmm=NNEW(int,nzs_tmm); + }else{ + irow_tmm=NNEW(int,1); + } + if (nzs_tmm!=0){ + mast1=NNEW(int,nzs_tmm); + }else{ + mast1=NNEW(int,1); + } + jq_tmm=NNEW(int,row_lm+1); + + for(j=0;j0){ + numb=jq_tmm[i+1]-jq_tmm[i]; + FORTRAN(isortid,(&irow_tmm[jq_tmm[i]-1],&au_tmm[jq_tmm[i]-1],&numb,&kflag)); + } + } + +// FORTRAN(writematrix,(au_tmm,ad,irow_tmm,jq_tmm,&row_lm,&number)); + + /*Calculation of Bd_T * Ass_Bd ***/ + /******** Remark Ass_Bd : intsm1 ****/ + + int *irow_intmm3=NULL,*jq_intmm3=NULL; + double *au_intmm3=NULL; + + + jq_intmm3=NNEW(int,row_lm+1); + au_intmm3=NNEW(double,row_lm*row_lm); + irow_intmm3=NNEW(int,row_lm*row_lm); + + + multi_rect(au_bdtil,irow_bdtil,jq_bdtil,row_ls,row_lm, + au_intsm1,irow_intsm1,jq_intsm1,row_ls,row_lm, + &au_intmm3,&irow_intmm3,jq_intmm3); + + /*** Calculation of the new A_MM ***/ + + int *irow_fmmi=NULL,*jq_fmmi=NULL; + double *au_fmmi=NULL; + + + jq_fmmi=NNEW(int,row_lm+1); + au_fmmi=NNEW(double,row_lm*row_lm); + irow_fmmi=NNEW(int,row_lm*row_lm); + + add_rect(au_intmm1,irow_intmm1,jq_intmm1,row_lm,row_lm, + au_tmm,irow_tmm,jq_tmm,row_lm,row_lm, + &au_fmmi,&irow_fmmi,jq_fmmi); + + int *irow_fmmi2=NULL,*jq_fmmi2=NULL; + double *au_fmmi2=NULL; + + + jq_fmmi2=NNEW(int,row_lm+1); + au_fmmi2=NNEW(double,row_lm*row_lm); + irow_fmmi2=NNEW(int,row_lm*row_lm); + + add_rect(au_fmmi,irow_fmmi,jq_fmmi,row_lm,row_lm, + au_intmm3,irow_intmm3,jq_intmm3,row_lm,row_lm, + &au_fmmi2,&irow_fmmi2,jq_fmmi2); + + + int *irow_fmm=NULL,*jq_fmm=NULL; + double *au_fmm=NULL; + int *irow_mmf=NULL,*jq_mmf=NULL; + double *au_mmf=NULL; + + jq_fmm=NNEW(int,row_lm+1); + au_fmm=NNEW(double,row_lm*row_lm); + irow_fmm=NNEW(int,row_lm*row_lm); + + jq_mmf=NNEW(int,row_lm+1); + au_mmf=NNEW(double,row_lm*row_lm); + irow_mmf=NNEW(int,row_lm*row_lm); + + + add_rect(au_mmd,irow_mmd,jq_mmd,row_lm,row_lm, + au_mm,irow_mm,jq_mm,row_lm,row_lm, + &au_mmf,&irow_mmf,jq_mmf); + + add_rect(au_fmmi2,irow_fmmi2,jq_fmmi2,row_lm,row_lm, + au_mmf,irow_mmf,jq_mmf,row_lm,row_lm, + &au_fmm,&irow_fmm,jq_fmm); + + +// FORTRAN(writematrix,(au_fmm,ad,irow_fmm,jq_fmm,&row_lm,&number)); + + /******************************************************* + *************** Free intermediate fields ************** + ********************************************************/ + free(au_fmmi2);free(irow_fmmi2);free(jq_fmmi2); + free(au_fmmi);free(irow_fmmi);free(jq_fmmi); + free(au_intmm3);free(irow_intmm3);free(jq_intmm3); + free(au_tmm);free(irow_tmm);free(jq_tmm); + free(au_intmm1);free(irow_intmm1);free(jq_intmm1); + free(au_intsm1);free(irow_intsm1);free(jq_intsm1); + free(au_intmn);free(irow_intmn);free(jq_intmn); + /********************************************************** + ***********************************************************/ + + +/******************************************** Submultiplications done ********************************************** +************************************************ ASSEMBLEE *********************************************************/ + + + /************** Construction of the Bhat = Qd*b 0 <=> f_mh = f_m + Bd_T*fs ************/ + + /*** Local => Global topology ***/ + int *n_flagr=NULL,*m_flagr=NULL,*s_flagr=NULL; + n_flagr=NNEW(int,row_ln); + m_flagr=NNEW(int,row_lm); + s_flagr=NNEW(int,row_ls); + + for(j=0;j0){ + numb=jqc[i+1]-jqc[i]; + FORTRAN(isortid,(&irowc[jqc[i]-1],&auc[jqc[i]-1],&numb,&kflag)); + } + } + fin=clock(); + printf("multimortar tri fin : %f s\n",((double)(fin-debut))/CLOCKS_PER_SEC); + + +/******************************************************/ + + + free(mast1); + + + number=6; + +// FORTRAN(writematrix,(auc,adc,irowc,jqc,&neq[1],&number)); + + + /*********** Free the intermediate matrices ********/ + free(au_nn);free(irow_nn);free(jq_nn); + free(au_mn);free(irow_mn);free(jq_mn); + free(au_sn);free(irow_sn);free(jq_sn); + free(au_mm);free(irow_mm);free(jq_mm); + free(au_sm);free(irow_sm);free(jq_sm); + free(au_ss);free(irow_ss);free(jq_ss); + free(au_fmm);free(irow_fmm);free(jq_fmm); + free(au_fmn);free(irow_fmn);free(jq_fmn); + free(au_fsm);free(irow_fsm);free(jq_fsm); + free(au_bdtil);free(irow_bdtil);free(jq_bdtil); + free(au_ssd);free(irow_ssd);free(jq_ssd); + free(au_mmd);free(irow_mmd);free(jq_mmd); + free(au_ssf);free(irow_ssf);free(jq_ssf); + free(au_mmf);free(irow_mmf);free(jq_mmf); + free(f_s); + free(f_m); + free(bd_nn); + /*************************/ + + /*END transmit the new stiffness matrix*/ + RENEW(auc,double,*nzsc); + RENEW(irowc,int,*nzsc); + + *irowcp = irowc; *aucp=auc; + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/multi_rect.c calculix-ccx-2.3/ccx_2.3/src/multi_rect.c --- calculix-ccx-2.1/ccx_2.3/src/multi_rect.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/multi_rect.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,68 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include +#include "CalculiX.h" + +void multi_rect(double *au_1,int * irow_1,int * jq_1,int n_1, int m_1, + double *au_2,int * irow_2,int * jq_2,int n_2, int m_2, + double **au_rp,int **irow_rp,int * jq_r){ + + /*Result fields*/ + int *irow=NULL,ifree=1,nzs,numb,icol,i,j,k,l,m,carre=0,kflag=2,istart,icounter; + int flag=0; + double *au=NULL,value; + clock_t debut; + clock_t fin; + /*Perform a_1T*a_2*/ + + debut=clock(); + if (n_1!=n_2) { + printf("Error in mutli_rec : Matrix sizes are not compatible\n"); + return; + } + + nzs=n_1*m_2; + irow=*irow_rp; + au=*au_rp; + + if (n_1==m_2) carre=1; + + jq_r[0]=1; + for(j=0;j +#include +#include +#include +#include "CalculiX.h" + +void multi_rectv(double *au_1,int * irow_1,int * jq_1,int n_1, int m_1, + double * b, double ** v_rp){ + + /*Result fields*/ + int irow,i,j; + double *v_r=NULL,value; + + + v_r=NNEW(double,m_1); + + for(j=0;j +#include +#include +#include +#include "CalculiX.h" + +void multi_scal(double *au_1,int * irow_1,int * jq_1, + double *au_2,int * irow_2,int * jq_2, + int m,int n,double*value,int *flag){ + + /*Performs the scalar product of the mth column of au_1 and the + the nth column of au_2*/ + int pt1,pt2; + double val=0.0; + + pt1=jq_1[m]-1; + pt2=jq_2[n]-1; + while((pt1 nk' + stop + elseif(ialset(nalset+2).gt.nk) then + write(*,*) '*WARNING in noelsets: end value in' + write(*,*) ' set ',set(iset),' > nk;' + write(*,*) ' replaced by nk' + ialset(nalset+2)=nk + elseif(ialset(nalset+3).le.0) then + write(*,*) '*ERROR in noelsets: increment in' + write(*,*) ' set ',set(iset),' <=0' + stop + endif + else + if(ialset(nalset+1).gt.ne) then + write(*,*) '*ERROR in noelsets: starting value in' + write(*,*) ' set ',set(iset),' > ne' + stop + elseif(ialset(nalset+2).gt.ne) then + write(*,*) '*WARNING in noelsets: end value in' + write(*,*) ' set ',set(iset),' > ne;' + write(*,*) ' replaced by ne' + ialset(nalset+2)=nk + elseif(ialset(nalset+3).le.0) then + write(*,*) '*ERROR in noelsets: increment in' + write(*,*) ' set ',set(iset),' <=0' + stop + endif + endif + if(ialset(nalset+1).eq.ialset(nalset+2)) then + ialset(nalset+2)=0 + ialset(nalset+3)=0 + nalset=nalset+1 + else + ialset(nalset+3)=-ialset(nalset+3) + nalset=nalset+3 + endif + iendset(iset)=nalset + else + do i=1,n + read(textpart(i)(1:10),'(i10)',iostat=istat) + & ialset(nalset+1) + if(istat.gt.0) then +! +! set name +! + noelset=textpart(i)(1:80) + noelset(81:81)=' ' + ipos=index(noelset,' ') + if(kode.eq.0) then + noelset(ipos:ipos)='N' + else + noelset(ipos:ipos)='E' + endif + do j=1,nset + if(j.eq.iset)cycle + if(noelset.eq.set(j)) then + m=iendset(j)-istartset(j)+1 + do k=1,m + ialset(nalset+k)=ialset(istartset(j)+k-1) + enddo + nalset=nalset+m + exit + endif + enddo + if(noelset.ne.set(j)) then + noelset(ipos:ipos)=' ' + if(kode.eq.0) then + write(*,*) '*ERROR in noelsets: node set ', + & noelset + else + write(*,*) '*ERROR in noelsets: element set ', + & noelset + endif + write(*,*) ' has not been defined yet' + stop + endif + else +! +! node or element number +! + if(kode.eq.0) then + if(ialset(nalset+1).gt.nk) then + write(*,*) '*WARNING in noelsets: value ', + & ialset(nalset+1) + write(*,*) ' in set ',set(iset),' > nk' + else + nalset=nalset+1 + endif + else + if(ialset(nalset+1).gt.ne) then + write(*,*) '*WARNING in noelsets: value ', + & ialset(nalset+1) + write(*,*) ' in set ',set(iset),' > ne' + else + nalset=nalset+1 + endif + endif + endif + enddo + iendset(iset)=nalset + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/nonlingeo.c calculix-ccx-2.3/ccx_2.3/src/nonlingeo.c --- calculix-ccx-2.1/ccx_2.3/src/nonlingeo.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/nonlingeo.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1990 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif +#ifdef PARDISO + #include "pardiso.h" +#endif + + +void nonlingeo(double **cop, int *nk, int **konp, int **ipkonp, char **lakonp, + int *ne, + int *nodeboun, int *ndirboun, double *xboun, int *nboun, + int **ipompcp, int **nodempcp, double **coefmpcp, char **labmpcp, + int *nmpc, + int *nodeforc, int *ndirforc,double *xforc, int *nforc, + int *nelemload, char *sideload, double *xload,int *nload, + double *ad, double *au, double *b, int *nactdof, + int **icolp, int *jq, int **irowp, int *neq, int *nzl, + int *nmethod, int **ikmpcp, int **ilmpcp, int *ikboun, + int *ilboun, + double *elcon, int *nelcon, double *rhcon, int *nrhcon, + double *alcon, int *nalcon, double *alzero, int **ielmatp, + int **ielorienp, int *norien, double *orab, int *ntmat_, + double *t0, double *t1, double *t1old, + int *ithermal,double *prestr, int *iprestr, + double **voldp,int *iperturb, double *sti, int *nzs, + int *kode, double *adb, double *aub,char *filab, + int *idrct, int *jmax, int *jout, double *tinc, + double *tper, double *tmin, double *tmax, double *eme, + double *xbounold, double *xforcold, double *xloadold, + double *veold, double *accold, + char *amname, double *amta, int *namta, int *nam, + int *iamforc, int *iamload, + int *iamt1, double *alpha, int *iexpl, + int *iamboun, double *plicon, int *nplicon, double *plkcon, + int *nplkcon, + double **xstatep, int *npmat_, int *istep, double *ttime, + char *matname, double *qaold, int *mi, + int *isolver, int *ncmat_, int *nstate_, int *iumat, + double *cs, int *mcs, int *nkon, double **enerp, int *mpcinfo, + int *nnn, char *output, + double *shcon, int *nshcon, double *cocon, int *ncocon, + double *physcon, int *nflow, double *ctrl, + char *set, int *nset, int *istartset, + int *iendset, int *ialset, int *nprint, char *prlab, + char *prset, int *nener,int *ikforc,int *ilforc, double *trab, + int *inotr, int *ntrans, double **fmpcp, char *cbody, + int *ibody, double *xbody, int *nbody, double *xbodyold, + int *ielprop, double *prop, int *ntie, char *tieset, + int *itpamp, int *iviewfile, char *jobnamec, double *tietol, + int *inlgeom){ + + char description[13]=" ",*lakon=NULL,jobnamef[396]="", + *sideface=NULL,*labmpc=NULL; + + int *inum=NULL,k,l,iout=0,icntrl,iinc=0,jprint=0,iit=-1,jnz=0, + icutb=0,istab=0,ifreebody,uncoupled,n1,n2,nzlc,im, + iperturb_sav[2],ilin,*icol=NULL,*irow=NULL,ielas=0,icmd=0, + memmpc_,mpcfree,icascade,maxlenmpc,*nodempc=NULL,*iaux=NULL, + *nodempcref=NULL,memmpcref_,mpcfreeref,*itg=NULL,*ineighe=NULL, + *ieg=NULL,ntg=0,ntr,*iptri=NULL,*kontri=NULL,*nloadtr=NULL, + *ipiv=NULL,*idist=NULL,ntri,newstep,mode=-1,noddiam=-1, + ntrit,*inocs=NULL,inewton=0,*ipobody=NULL,*nacteq=NULL, + *nactdog=NULL,nteq,network,*itietri=NULL,*koncont=NULL, + ncont,ne0,nkon0,*ipkon=NULL,*kon=NULL,*ielorien=NULL, + *ielmat=NULL,nslavs=0,inext,itp=0,symmetryflag=0,inputformat=0, + *iruc=NULL,iitterm=0,turbulent,ngraph=1,ismallsliding=0, + *ipompc=NULL,*ikmpc=NULL,*ilmpc=NULL,i0ref,irref,icref, + *itiefac=NULL,*islavsurf=NULL,*islavnode=NULL,*imastnode=NULL, + *nslavnode=NULL,*nmastnode=NULL,mortar=0,*imastop=NULL, + *iponoels=NULL,*inoels=NULL,nzsc,*irowc=NULL,*jqc=NULL, + *islavact=NULL,*irowqdt=NULL,*jqqdt=NULL,nzsqdt,*icolc=NULL, + *irowbd=NULL,*jqbd=NULL,mt=mi[1]+1,*nactdofinv=NULL,*ipe=NULL, + *ime=NULL,*ikactmech=NULL,nactmech,ifacecount,inode,idir,neold, + iemchange=0; + + int mass[2]={0,0}, stiffness=1, buckling=0, rhsi=1, intscheme=0,idiscon=0, + coriolis=0,*ipneigh=NULL,*neigh=NULL, + *nelemface=NULL,*ipoface=NULL,*nodface=NULL,*ifreestream=NULL, + *isolidsurf=NULL,*neighsolidsurf=NULL,*iponoel=NULL,*inoel=NULL, + nef=0,nface,nfreestream,nsolidsurf,inoelfree,i,indexe,cfd=0,id, + node,networknode,*jqtemp=NULL,*icoltemp=NULL,*irowtemp=NULL, + nzstemp[3],iflagact=0,*nodorig=NULL,*ipivr=NULL; + + double *stn=NULL,*v=NULL,*een=NULL,cam[5],*epn=NULL,*cg=NULL, + *f=NULL,*fn=NULL,qa[3]={0.,0.,-1.},qam[2]={0.,0.},dtheta,theta, + err,ram[4]={0.,0.,0.,0.},*areaslav=NULL,*springarea=NULL, + ram1[2]={0.,0.},ram2[2]={0.,0.},deltmx,*auc=NULL,*adc=NULL, + uam[2]={0.,0.},*vini=NULL,*ac=NULL,qa0,qau,ea,*straight=NULL, + *t1act=NULL,qamold[2],*xbounact=NULL,*bc=NULL,*bdd=NULL, + *xforcact=NULL,*xloadact=NULL,*fext=NULL,*gap=NULL, + reltime,time,bet=0.,gam=0.,*aux1=NULL,*aux2=NULL,dtime,*fini=NULL, + *fextini=NULL,*veini=NULL,*accini=NULL,*xstateini=NULL, + *ampli=NULL,scal1,*eei=NULL,*t1ini=NULL,*auqdt=NULL, + *xbounini=NULL,dev,*xstiff=NULL,*stx=NULL,*stiini=NULL, + *enern=NULL,*coefmpc=NULL,*aux=NULL,*xstaten=NULL, + *coefmpcref=NULL,*enerini=NULL,*area=NULL,*slavnor=NULL, + *tarea=NULL,*tenv=NULL,*dist=NULL,*erad=NULL,*pmid=NULL, + *fij=NULL,*e1=NULL,*e2=NULL,*e3=NULL, *qfx=NULL,*bhat=NULL, + *qfn=NULL,*co=NULL,*vold=NULL,*fenv=NULL,sigma=0., + *xbodyact=NULL,*cgr=NULL,dthetaref, *voldtu=NULL,*vr=NULL,*vi=NULL, + *stnr=NULL,*stni=NULL,*vmax=NULL,*stnmax=NULL,*fmpc=NULL,*ener=NULL, + *cstress=NULL,*cdisp=NULL,*aubd=NULL, *f_cm=NULL, *f_cs=NULL, aux3, + *vectornull=NULL, *alambda=NULL,*alambdad=NULL,*xstate=NULL, + *eenmax=NULL,*acr=NULL,*bcr=NULL; + +#ifdef SGI + int token; +#endif + + (*inlgeom)++; + + if(*ithermal==4){ + uncoupled=1; + *ithermal=3; + }else{ + uncoupled=0; + } + + /* turbulence model + turbulent==0: laminar + turbulent==1: k-epsilon + turbulent==2: q-omega + turbulent==3: SST */ + + turbulent=(int)physcon[8]; + + for(k=0;k<3;k++){ + strcpy1(&jobnamef[k*132],&jobnamec[k*132],132); + } + + qa0=ctrl[20];qau=ctrl[21];ea=ctrl[23];deltmx=ctrl[26]; + i0ref=ctrl[0];irref=ctrl[1];icref=ctrl[3]; + + memmpc_=mpcinfo[0];mpcfree=mpcinfo[1];icascade=mpcinfo[2]; + maxlenmpc=mpcinfo[3]; + + icol=*icolp;irow=*irowp;co=*cop;vold=*voldp; + ipkon=*ipkonp;lakon=*lakonp;kon=*konp;ielorien=*ielorienp; + ielmat=*ielmatp;ener=*enerp;xstate=*xstatep; + + ipompc=*ipompcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; + fmpc=*fmpcp;nodempc=*nodempcp;coefmpc=*coefmpcp; + + /* invert nactdof */ + + nactdofinv=NNEW(int,mt**nk);nodorig=NNEW(int,*nk); + FORTRAN(gennactdofinv,(nactdof,nactdofinv,nk,mi,nodorig, + ipkon,lakon,kon,ne)); + free(nodorig); + + /* allocating a field for the stiffness matrix */ + + xstiff=NNEW(double,27*mi[0]**ne); + + /* allocating force fields */ + + f=NNEW(double,neq[1]); + fext=NNEW(double,neq[1]); + + b=NNEW(double,neq[1]); + vini=NNEW(double,mt**nk); + + aux=NNEW(double,7*maxlenmpc); + iaux=NNEW(int,maxlenmpc); + + /* allocating fields for the actual external loading */ + + xbounact=NNEW(double,*nboun); + xbounini=NNEW(double,*nboun); + for(k=0;k<*nboun;++k){xbounact[k]=xbounold[k];} + xforcact=NNEW(double,*nforc); + xloadact=NNEW(double,2**nload); + xbodyact=NNEW(double,7**nbody); + /* copying the rotation axis and/or acceleration vector */ + for(k=0;k<7**nbody;k++){xbodyact[k]=xbody[k];} + + /* assigning the body forces to the elements */ + + if(*nbody>0){ + ifreebody=*ne+1; + ipobody=NNEW(int,2*ifreebody**nbody); + for(k=1;k<=*nbody;k++){ + FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, + iendset,ialset,&inewton,nset,&ifreebody,&k)); + RENEW(ipobody,int,2*(*ne+ifreebody)); + } + RENEW(ipobody,int,2*(ifreebody-1)); + if(inewton==1){cgr=NNEW(double,4**ne);} + } + + /* for mechanical calculations: updating boundary conditions + calculated in a previous thermal step */ + + if(*ithermal<2) FORTRAN(gasmechbc,(vold,nload,sideload, + nelemload,xload,mi)); + + /* for thermal calculations: forced convection and cavity + radiation*/ + + if(*ithermal>1){ + itg=NNEW(int,*nload+3**nflow); + ieg=NNEW(int,*nflow); + iptri=NNEW(int,*nload); + kontri=NNEW(int,18**nload); + nloadtr=NNEW(int,*nload); + nacteq=NNEW(int,4**nk); + nactdog=NNEW(int,4**nk); + v=NNEW(double,mt**nk); + FORTRAN(envtemp,(itg,ieg,&ntg,&ntr,sideload,nelemload, + ipkon,kon,lakon,ielmat,ne,nload,iptri, + kontri,&ntri,nloadtr,nflow,ndirboun,nactdog, + nodeboun,nacteq,nboun,ielprop,prop,&nteq, + v,&network,physcon,shcon,ntmat_,co, + vold,set,nshcon,rhcon,nrhcon,mi,nmpc,nodempc, + ipompc,labmpc,ikboun)); + free(v); + + if((*mcs>0)&&(ntr>0)){ + inocs=NNEW(int,*nk); + radcyc(nk,kon,ipkon,lakon,ne,cs,mcs,nkon,ialset,istartset, + iendset,&kontri,&ntri,&co,&vold,&ntrit,inocs,mi); + } + else{ntrit=ntri;} + + RENEW(itg,int,ntg); + ineighe=NNEW(int,ntg); + RENEW(iptri,int,ntr); + RENEW(kontri,int,3*ntrit); + RENEW(nloadtr,int,ntr); + + area=NNEW(double,ntrit); + pmid=NNEW(double,3*ntrit); + e1=NNEW(double,3*ntrit); + e2=NNEW(double,3*ntrit); + e3=NNEW(double,4*ntrit); + dist=NNEW(double,ntrit); + idist=NNEW(int,ntrit); + + fij=NNEW(double,ntr*ntr); + tarea=NNEW(double,ntr); + tenv=NNEW(double,ntr); + fenv=NNEW(double,ntr); + erad=NNEW(double,ntr); + + ac=NNEW(double,nteq*nteq); + bc=NNEW(double,nteq); + ipiv=NNEW(int,nteq); + acr=NNEW(double,ntr*ntr); + bcr=NNEW(double,ntr); + ipivr=NNEW(int,ntr); + } + + /* check for fluid elements */ + + for(i=0;i<*ne;++i){ + if(ipkon[i]<0) continue; + indexe=ipkon[i]; + if(strcmp1(&lakon[8*i],"F")==0){cfd=1;nef++;} + } + if(cfd==1){ + sideface=NNEW(char,6*nef); + nelemface=NNEW(int,6*nef); + ipoface=NNEW(int,*nk); + nodface=NNEW(int,5*6*nef); + ifreestream=NNEW(int,*nk); + isolidsurf=NNEW(int,*nk); + neighsolidsurf=NNEW(int,*nk); + iponoel=NNEW(int,*nk); + inoel=NNEW(int,3*20*nef); + FORTRAN(precfd,(nelemface,sideface,&nface,ipoface,nodface, + ne,ipkon,kon,lakon,ikboun,ilboun,xboun,nboun,nk,isolidsurf, + &nsolidsurf,ifreestream,&nfreestream,neighsolidsurf, + iponoel,inoel,&inoelfree,&nef,co,ipompc,nodempc,ikmpc,ilmpc,nmpc)); + RENEW(sideface,char,nface); + RENEW(nelemface,int,nface); + free(ipoface);free(nodface); + RENEW(ifreestream,int,nfreestream); + RENEW(isolidsurf,int,nsolidsurf); + RENEW(neighsolidsurf,int,nsolidsurf); + RENEW(inoel,int,3*inoelfree); + voldtu=NNEW(double,2**nk); + } + + /* contact conditions */ + + inicont(nk,&ncont,ntie,tieset,nset,set,istartset,iendset,ialset,&itietri, + lakon,ipkon,kon,&koncont,&nslavs,tietol,&ismallsliding,&itiefac, + &islavsurf,&islavnode,&imastnode,&nslavnode,&nmastnode, + &mortar,&imastop,nkon,&iponoels,&inoels,&ipe,&ime,ne,&ifacecount, + nmpc,&mpcfree,&memmpc_, + &ipompc,&labmpc,&ikmpc,&ilmpc,&fmpc,&nodempc,&coefmpc, + iperturb,ikboun,nboun); + + if(ncont!=0){ + + if(*nener==1){ + RENEW(ener,double,mi[0]*(*ne+nslavs)*2); + } + RENEW(ipkon,int,*ne+nslavs); + RENEW(lakon,char,8*(*ne+nslavs)); + + if(*norien>0){ + RENEW(ielorien,int,*ne+nslavs); + for(k=*ne;k<*ne+nslavs;k++) ielorien[k]=0; + } + RENEW(ielmat,int,*ne+nslavs); + for(k=*ne;k<*ne+nslavs;k++) ielmat[k]=1; + cg=NNEW(double,3*ncont); + straight=NNEW(double,16*ncont); + + if(mortar==1){ + + /* adding one element per slave node, similar to + spring elements; + needed for output in frd-format of CDISP and CSTRES */ + + RENEW(kon,int,*nkon+nslavs); + for(k=0;k=3)){ + t1ini=NNEW(double,*nk); + t1act=NNEW(double,*nk); + for(k=0;k<*nk;++k){t1act[k]=t1old[k];} + } + + /* allocating a field for the instantaneous amplitude */ + + ampli=NNEW(double,*nam); + + /* allocating fields for nonlinear dynamics */ + + fini=NNEW(double,neq[1]); + if(*nmethod==4){ + mass[0]=1; + mass[1]=1; + aux2=NNEW(double,neq[1]); + fextini=NNEW(double,neq[1]); + veini=NNEW(double,mt**nk); + accini=NNEW(double,mt**nk); + adb=NNEW(double,neq[1]); + aub=NNEW(double,nzs[1]); + } + + if(*nstate_!=0){ + xstateini=NNEW(double,*nstate_*mi[0]*(*ne+nslavs)); + for(k=0;k<*nstate_*mi[0]*(*ne+nslavs);++k){ + xstateini[k]=xstate[k]; + } + } + eei=NNEW(double,6*mi[0]**ne); + stiini=NNEW(double,6*mi[0]**ne); + if(*nener==1) + enerini=NNEW(double,mi[0]**ne); + + qa[0]=qaold[0]; + qa[1]=qaold[1]; + + /* normalizing the time */ + + FORTRAN(checktime,(itpamp,namta,tinc,ttime,amta,tmin,&inext,&itp)); + dtheta=(*tinc)/(*tper); + dthetaref=dtheta; + if((dtheta<=1.e-6)&&(*iexpl<=1)){ + printf("\n *ERROR in nonlingeo\n"); + printf(" increment size smaller than one millionth of step size\n"); + printf(" increase increment size\n\n"); + } + *tmin=*tmin/(*tper); + *tmax=*tmax/(*tper); + theta=0.; + + /* calculating an initial flux norm */ + + if(*ithermal!=2){ + if(qau>1.e-10){qam[0]=qau;} + else if(qa0>1.e-10){qam[0]=qa0;} + else if(qa[0]>1.e-10){qam[0]=qa[0];} + else {qam[0]=1.e-2;} + } + if(*ithermal>1){ + if(qau>1.e-10){qam[1]=qau;} + else if(qa0>1.e-10){qam[1]=qa0;} + else if(qa[1]>1.e-10){qam[1]=qa[1];} + else {qam[1]=1.e-2;} + } + + /* storing the element and topology information before introducing + contact elements */ + + ne0=*ne;nkon0=*nkon; + + /*********************************************************************/ + + /* calculating the initial acceleration at the start of the step + for dynamic calculations */ + + /*********************************************************************/ + + if((*nmethod==4)&&(*ithermal!=2)){ + bet=(1.-*alpha)*(1.-*alpha)/4.; + gam=0.5-*alpha; + + /* calculating the stiffness and mass matrix + the stress must be determined to calculate the + stiffness matrix*/ + + reltime=0.; + time=0.; + dtime=0.; + + FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc,xloadold,xload, + xloadact,iamload,nload,ibody,xbody,nbody,xbodyold,xbodyact, + t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal,nmethod, + xbounold,xboun,xbounact,iamboun,nboun, + nodeboun,ndirboun,nodeforc,ndirforc,istep,&iinc, + co,vold,itg,&ntg,amname,ikboun,ilboun,nelemload,sideload,mi, + ntrans,trab,inotr,veold)); + + time=0.; + dtime=1.; + + /* updating the nonlinear mpc's (also affects the boundary + conditions through the nonhomogeneous part of the mpc's) + if contact arises the number of MPC's can also change */ + + cam[0]=0.;cam[1]=0.; + if(*ithermal>1){radflowload(itg,ieg,&ntg,&ntr,acr,bcr,ipivr, + ac,bc,nload,sideload,nelemload,xloadact,lakon,ipiv,ntmat_,vold, + shcon,nshcon,ipkon,kon,co,pmid,e1,e2,e3,iptri, + kontri,&ntri,nloadtr,tarea,tenv,physcon,erad,fij, + dist,idist,area,nflow,ikboun,xboun,nboun,ithermal,&iinc,&iit, + cs,mcs,inocs,&ntrit,nk,fenv,istep,&dtime,ttime,&time,ilboun, + ikforc,ilforc,xforcact,nforc,cam,ielmat,&nteq,prop,ielprop, + nactdog,nacteq,nodeboun,ndirboun,&network,rhcon, + nrhcon,ipobody,ibody,xbodyact,nbody,iviewfile,jobnamef,ctrl, + xloadold,&reltime,nmethod,set,mi,istartset,iendset,ialset,nset, + ineighe,nmpc,nodempc,ipompc,coefmpc,labmpc,&iemchange,nam,iamload);} + + if((icascade==2)||(ncont!=0)){ + memmpc_=memmpcref_;mpcfree=mpcfreeref; + RENEW(nodempc,int,3*memmpcref_); + for(k=0;k<3*memmpcref_;k++){nodempc[k]=nodempcref[k];} + RENEW(coefmpc,double,memmpcref_); + for(k=0;k0) remastruct(ipompc,&coefmpc,&nodempc,nmpc, + &mpcfree,nodeboun,ndirboun,nboun,ikmpc,ilmpc,ikboun,ilboun, + labmpc,nk,&memmpc_,&icascade,&maxlenmpc, + kon,ipkon,lakon,ne,nnn,nactdof,icol,jq,&irow,isolver, + neq,nzs,nmethod,&f,&fext,&b,&aux2,&fini,&fextini, + &adb,&aub,ithermal,iperturb,mass,mi); + + /* invert nactdof */ + + free(nactdofinv);nactdofinv=NNEW(int,mt**nk);nodorig=NNEW(int,*nk); + FORTRAN(gennactdofinv,(nactdof,nactdofinv,nk,mi,nodorig, + ipkon,lakon,kon,ne)); + free(nodorig); + + iout=-1; + ielas=1; + + fn=NNEW(double,mt**nk); + stx=NNEW(double,6*mi[0]**ne); + if(*ithermal>1) qfx=NNEW(double,3*mi[0]**ne); + + inum=NNEW(int,*nk); + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,vold,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1old,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xbounold,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold,&bet, + &gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,sti,vini,ikboun,ilboun,ener,enern,sti,xstaten, + eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,istep,&iinc,springarea,&reltime)); + + free(fn);free(stx);if(*ithermal>1)free(qfx);free(inum); + + iout=0; + ielas=0; + + reltime=0.; + time=0.; + dtime=0.; + + if(*iexpl<=1){intscheme=1;} + + /* in mafillsm the stiffness and mass matrix are computed; + The primary aim is to calculate the mass matrix (not + lumped for an implicit dynamic calculation, lumped for an + explicit dynamic calculation). However: + - for an implicit calculation the mass matrix is "doped" with + a small amount of stiffness matrix, therefore the calculation + of the stiffness matrix is needed. + - for an explicit calculation the stiffness matrix is not + needed at all. Since the calculation of the mass matrix alone + is not possible in mafillsm, the determination of the stiffness + matrix is taken as unavoidable "ballast". */ + + ad=NNEW(double,neq[1]); + au=NNEW(double,nzs[1]); + + FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xbounold,nboun, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, + nforc,nelemload,sideload,xloadact,nload,xbodyact,ipobody, + nbody,cgr,ad,au,fext,nactdof,icol,jq,irow,neq,nzl, + nmethod,ikmpc,ilmpc,ikboun,ilboun, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero, + ielmat,ielorien,norien,orab,ntmat_, + t0,t1act,ithermal,prestr,iprestr,vold,iperturb,sti, + nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, + xstiff,npmat_,&dtime,matname,mi, + ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme, + physcon,shcon,nshcon,cocon,ncocon,ttime,&time,istep,&iinc, + &coriolis,ibody,xloadold,&reltime,veold,springarea,nstate_, + xstateini,xstate)); + + if(nmethod==0){ + + /* error occurred in mafill: storing the geometry in frd format */ + + ++*kode; + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); + } + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab, + een,t1,fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_,istep, + &iinc,iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, + set,nset,istartset,iendset,ialset,eenmax)); + if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} + + FORTRAN(stop,()); + + } + + /* mass x acceleration = f(external)-f(internal) + only for the mechanical loading*/ + + for(k=0;k1) icmd=3; + + /**************************************************************/ + /* starting the loop over the increments */ + /**************************************************************/ + + newstep=1; + + while(1.-theta>1.e-6){ + + if(icutb==0){ + + /* previous increment converged: update the initial values */ + + iinc++; + jprint++; + + /* vold is copied into vini */ + + memcpy(&vini[0],&vold[0],sizeof(double)*mt**nk); + + for(k=0;k<*nboun;++k){xbounini[k]=xbounact[k];} + if((*ithermal==1)||(*ithermal>=3)){ + for(k=0;k<*nk;++k){t1ini[k]=t1act[k];} + } + for(k=0;k*jmax){ + printf(" *ERROR: max. # of increments reached\n\n"); + FORTRAN(stop,()); + } + printf(" increment %d attempt %d \n",iinc,icutb+1); + printf(" increment size= %e\n",dtheta**tper); + printf(" sum of previous increments=%e\n",theta**tper); + printf(" actual step time=%e\n",(theta+dtheta)**tper); + printf(" actual total time=%e\n\n",*ttime+dtheta**tper); + + printf(" iteration 1\n\n"); + + qamold[0]=qam[0]; + qamold[1]=qam[1]; + + /* determining the actual loads at the end of the new increment*/ + + reltime=theta+dtheta; + time=reltime**tper; + dtime=dtheta**tper; + + FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc,xloadold,xload, + xloadact,iamload,nload,ibody,xbody,nbody,xbodyold,xbodyact, + t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal,nmethod, + xbounold,xboun,xbounact,iamboun,nboun, + nodeboun,ndirboun,nodeforc,ndirforc,istep,&iinc, + co,vold,itg,&ntg,amname,ikboun,ilboun,nelemload,sideload,mi, + ntrans,trab,inotr,veold)); + + for(i=0;i<3;i++){cam[i]=0.;}for(i=3;i<5;i++){cam[i]=0.5;} + if(*ithermal>1){radflowload(itg,ieg,&ntg,&ntr,acr,bcr,ipivr, + ac,bc,nload,sideload,nelemload,xloadact,lakon,ipiv,ntmat_,vold, + shcon,nshcon,ipkon,kon,co,pmid,e1,e2,e3,iptri, + kontri,&ntri,nloadtr,tarea,tenv,physcon,erad,fij, + dist,idist,area,nflow,ikboun,xbounact,nboun,ithermal,&iinc,&iit, + cs,mcs,inocs,&ntrit,nk,fenv,istep,&dtime,ttime,&time,ilboun, + ikforc,ilforc,xforcact,nforc,cam,ielmat,&nteq,prop,ielprop, + nactdog,nacteq,nodeboun,ndirboun,&network, + rhcon,nrhcon,ipobody,ibody,xbodyact,nbody,iviewfile,jobnamef, + ctrl,xloadold,&reltime,nmethod,set,mi,istartset,iendset,ialset,nset, + ineighe,nmpc,nodempc,ipompc,coefmpc,labmpc,&iemchange,nam,iamload); + } + + if(cfd==1){ + compfluid(co,nk,ipkon,kon,lakon,ne,ipoface,sideface, + ifreestream,&nfreestream,isolidsurf,neighsolidsurf,&nsolidsurf, + iponoel,inoel,nshcon,shcon,nrhcon,rhcon,vold,ntmat_,nodeboun, + ndirboun,nboun,ipompc,nodempc,nmpc,ikmpc,ilmpc,ithermal, + ikboun,ilboun,&turbulent,isolver,iexpl,voldtu,ttime, + &time,&dtime,nodeforc,ndirforc,xforc,nforc,nelemload,sideload, + xload,nload,xbody,ipobody,nbody,ielmat,matname,mi,ncmat_, + physcon,istep,&iinc,ibody,xloadold,xboun,coefmpc, + nmethod,xforcold,xforcact,iamforc,iamload,xbodyold,xbodyact, + t1old,t1,t1act,iamt1,amta,namta,nam,ampli,xbounold,xbounact, + iamboun,itg,&ntg,amname,t0,nelemface,&nface,cocon,ncocon,xloadact, + tper,jmax,jout,set,nset,istartset,iendset,ialset,prset,prlab, + nprint,trab,inotr,ntrans,filab,labmpc,sti,norien,orab); + } + + if((icascade==2)|| + ((ncont!=0)&&((iinc==1)||(ismallsliding<2)))){ + memmpc_=memmpcref_;mpcfree=mpcfreeref; + RENEW(nodempc,int,3*memmpcref_); + for(k=0;k<3*memmpcref_;k++){nodempc[k]=nodempcref[k];} + RENEW(coefmpc,double,memmpcref_); + for(k=0;k0) remastruct(ipompc,&coefmpc,&nodempc,nmpc, + &mpcfree,nodeboun,ndirboun,nboun,ikmpc,ilmpc,ikboun,ilboun, + labmpc,nk,&memmpc_,&icascade,&maxlenmpc, + kon,ipkon,lakon,ne,nnn,nactdof,icol,jq,&irow,isolver, + neq,nzs,nmethod,&f,&fext,&b,&aux2,&fini,&fextini, + &adb,&aub,ithermal,iperturb,mass,mi); + + /* invert nactdof */ + + free(nactdofinv);nactdofinv=NNEW(int,mt**nk);nodorig=NNEW(int,*nk); + FORTRAN(gennactdofinv,(nactdof,nactdofinv,nk,mi,nodorig, + ipkon,lakon,kon,ne)); + free(nodorig); + + /* check whether the forced displacements changed; if so, and + if the procedure is static, the first iteration has to be + purely linear elastic, in order to get an equilibrium + displacement field; otherwise huge (maybe nonelastic) + stresses may occur, jeopardizing convergence */ + + ilin=0; + + /* only for iinc=1 a linearized calculation is performed, since + for iinc>1 a reasonable displacement field is predicted by using the + initial velocity field at the end of the last increment */ + + if((iinc==1)&&(*ithermal<2)){ + dev=0.; + for(k=0;k<*nboun;++k){ + err=fabs(xbounact[k]-xbounini[k]); + if(err>dev){dev=err;} + } + if(dev>1.e-5) ilin=1; + } + + /* prediction of the kinematic vectors */ + + v=NNEW(double,mt**nk); + + prediction(uam,nmethod,&bet,&gam,&dtime,ithermal,nk,veold,accold,v, + &iinc,&idiscon,vold,nactdof,mi); + + fn=NNEW(double,mt**nk); + stx=NNEW(double,6*mi[0]**ne); + if(*ithermal>1) qfx=NNEW(double,3*mi[0]*ne0); + + /* determining the internal forces at the start of the increment + + for a static calculation with increased forced displacements + the linear strains are calculated corresponding to + + the displacements at the end of the previous increment, extrapolated + if appropriate (for nondispersive media) + + the forced displacements at the end of the present increment + + the temperatures at the end of the present increment (this sum is + v) - + the displacements at the end of the previous increment (this is vold) + + these linear strains are converted in stresses by multiplication + with the tangent element stiffness matrix and converted into nodal + forces. + + this boils down to the fact that the effect of forced displacements + should be handled in a purely linear way at the + start of a new increment, in order to speed up the convergence and + (for dissipative media) guarantee smooth loading within the increment. + + for all other cases the nodal force calculation is based on + the true stresses derived from the appropriate strain tensor taking + into account the extrapolated displacements at the end of the + previous increment + the forced displacements and the temperatures + at the end of the present increment */ + + iout=-1; + iperturb_sav[0]=iperturb[0]; + iperturb_sav[1]=iperturb[1]; + + /* first iteration in first increment: elastic tangent */ + + if((*nmethod!=4)&&(ilin==1)){ + + ielas=1; + + iperturb[0]=-1; + iperturb[1]=0; + + for(k=0;k1)free(qfx);free(v); + + /***************************************************************/ + /* iteration counter and start of the loop over the iterations */ + /***************************************************************/ + + iit=1; + icntrl=0; + ctrl[0]=i0ref;ctrl[1]=irref;ctrl[3]=icref; + if(uncoupled){ + *ithermal=2; + iruc=NNEW(int,nzs[1]-nzs[0]); + for(k=0;k1){radflowload(itg,ieg,&ntg,&ntr,acr,bcr,ipivr, + ac,bc,nload,sideload,nelemload,xloadact,lakon,ipiv, + ntmat_,vold,shcon,nshcon,ipkon,kon,co,pmid,e1,e2,e3, + iptri,kontri,&ntri,nloadtr,tarea,tenv,physcon,erad,fij, + dist,idist,area,nflow,ikboun,xbounact,nboun,ithermal,&iinc,&iit, + cs,mcs,inocs,&ntrit,nk,fenv,istep,&dtime,ttime,&time,ilboun, + ikforc,ilforc,xforcact,nforc,cam,ielmat,&nteq,prop,ielprop, + nactdog,nacteq,nodeboun,ndirboun,&network, + rhcon,nrhcon,ipobody,ibody,xbodyact,nbody,iviewfile,jobnamef, + ctrl,xloadold,&reltime,nmethod,set,mi,istartset,iendset,ialset, + nset,ineighe,nmpc,nodempc,ipompc,coefmpc,labmpc,&iemchange,nam, + iamload); + } + + if((icascade==2)|| + ((ncont!=0)&&(ismallsliding==0))){ + memmpc_=memmpcref_;mpcfree=mpcfreeref; + RENEW(nodempc,int,3*memmpcref_); + for(k=0;k<3*memmpcref_;k++){nodempc[k]=nodempcref[k];} + RENEW(coefmpc,double,memmpcref_); + for(k=0;k0){ + remastruct(ipompc,&coefmpc,&nodempc,nmpc, + &mpcfree,nodeboun,ndirboun,nboun,ikmpc,ilmpc,ikboun,ilboun, + labmpc,nk,&memmpc_,&icascade,&maxlenmpc, + kon,ipkon,lakon,ne,nnn,nactdof,icol,jq,&irow,isolver, + neq,nzs,nmethod,&f,&fext,&b,&aux2,&fini,&fextini, + &adb,&aub,ithermal,iperturb,mass,mi); + + /* invert nactdof */ + + free(nactdofinv);nactdofinv=NNEW(int,mt**nk);nodorig=NNEW(int,*nk); + FORTRAN(gennactdofinv,(nactdof,nactdofinv,nk,mi,nodorig, + ipkon,lakon,kon,ne)); + free(nodorig); + + v=NNEW(double,mt**nk); + stx=NNEW(double,6*mi[0]**ne); + if(*ithermal>1) qfx=NNEW(double,3*mi[0]*ne0); + fn=NNEW(double,mt**nk); + + memcpy(&v[0],&vold[0],sizeof(double)*mt**nk); + iout=-1; + + inum=NNEW(int,*nk); + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1act,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xbounact,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, + xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,istep,&iinc,springarea, + &reltime)); + + /*for(k=0;k1)free(qfx);free(inum); + iout=0; + + }else{ + + /*for(k=0;k1){ + for(k=neq[0];k1){ + for(k=neq[0];k1) qfx=NNEW(double,3*mi[0]*ne0); + fn=NNEW(double,mt**nk); + + if ((mortar==0)||(iflagact==0)){ + inum=NNEW(int,*nk); + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1act,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xbounact,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, + &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, + sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, + fmpc,nelemload,nload,ikmpc,ilmpc,istep,&iinc,springarea, + &reltime)); + free(inum); + } + + if(*ithermal!=2){ + if(cam[0]>uam[0]){uam[0]=cam[0];} + if(qau<1.e-10){ + if(qa[0]>ea*qam[0]){qam[0]=(qamold[0]*jnz+qa[0])/(jnz+1);} + else {qam[0]=qamold[0];} + } + } + if(*ithermal>1){ + if(cam[1]>uam[1]){uam[1]=cam[1];} + if(qau<1.e-10){ + if(qa[1]>ea*qam[1]){qam[1]=(qamold[1]*jnz+qa[1])/(jnz+1);} + else {qam[1]=qamold[1];} + } + } + + memcpy(&vold[0],&v[0],sizeof(double)*mt**nk); + + if(*ithermal!=2){ + for(k=0;k<6*mi[0]*ne0;++k){ + sti[k]=stx[k]; + } + } + + free(v);free(stx);free(fn);if(*ithermal>1)free(qfx); + + /* calculating the residual */ + + calcresidual(nmethod,neq,b,fext,f,iexpl,nactdof,aux1,aux2,vold, + vini,&dtime,accold,nk,adb,aub,icol,irow,nzl,alpha,fextini,fini, + islavnode,nslavnode,imastnode,nmastnode,&mortar,ntie,f_cm,f_cs,mi); + + /* calculating the maximum residual */ + + for(k=0;k<2;++k){ + ram2[k]=ram1[k]; + ram1[k]=ram[k]; + ram[k]=0.; + } + if(*ithermal!=2){ + for(k=0;kram[0]){ram[0]=err;ram[2]=k+0.5;} + } + } + if(*ithermal>1){ + for(k=neq[0];kram[1]){ram[1]=err;ram[3]=k+0.5;} + } + } + + /* next line is inserted to cope with stress-less + temperature calculations */ + + if(*ithermal!=2){ + if(ram[0]<1.e-6) ram[0]=0.; + printf(" average force= %f\n",qa[0]); + printf(" time avg. forc= %f\n",qam[0]); + if((int)((double)nactdofinv[(int)ram[2]]/mt)+1==0){ + printf(" largest residual force= %f\n", + ram[0]); + }else{ + inode=(int)((double)nactdofinv[(int)ram[2]]/mt)+1; + idir=nactdofinv[(int)ram[2]]-mt*(inode-1); + printf(" largest residual force= %f in node %d and dof %d\n", + ram[0],inode,idir); + } + printf(" largest increment of disp= %e\n",uam[0]); + if((int)cam[3]==0){ + printf(" largest correction to disp= %e\n\n", + cam[0]); + }else{ + inode=(int)((double)nactdofinv[(int)cam[3]]/mt)+1; + idir=nactdofinv[(int)cam[3]]-mt*(inode-1); + printf(" largest correction to disp= %e in node %d and dof %d\n\n",cam[0],inode,idir); + } + } + if(*ithermal>1){ + if(ram[1]<1.e-6) ram[1]=0.; + printf(" average flux= %f\n",qa[1]); + printf(" time avg. flux= %f\n",qam[1]); + if((int)((double)nactdofinv[(int)ram[3]]/mt)+1==0){ + printf(" largest residual flux= %f\n", + ram[1]); + }else{ + inode=(int)((double)nactdofinv[(int)ram[3]]/mt)+1; + idir=nactdofinv[(int)ram[3]]-mt*(inode-1); + printf(" largest residual flux= %f in node %d and dof %d\n",ram[1],inode,idir); + } + printf(" largest increment of temp= %e\n",uam[1]); + if((int)cam[4]==0){ + printf(" largest correction to temp= %e\n\n", + cam[1]); + }else{ + inode=(int)((double)nactdofinv[(int)cam[4]]/mt)+1; + idir=nactdofinv[(int)cam[4]]-mt*(inode-1); + printf(" largest correction to temp= %e in node %d and dof %d\n\n",cam[1],inode,idir); + } + } + + checkconvergence(co,nk,kon,ipkon,lakon,ne,stn,nmethod, + kode,filab,een,t1act,&time,epn,ielmat,matname,enern, + xstaten,nstate_,istep,&iinc,iperturb,ener,mi,output, + ithermal,qfn,&mode,&noddiam,trab,inotr,ntrans,orab, + ielorien,norien,description,sti,&icutb,&iit,&dtime,qa, + vold,qam,ram1,ram2,ram,cam,uam,&ntg,ttime,&icntrl, + &theta,&dtheta,veold,vini,idrct,tper,&istab,tmax, + nactdof,b,tmin,ctrl,amta,namta,itpamp,&inext,&dthetaref, + &itp,&jprint,jout,&uncoupled,t1,&iitterm,nelemload, + nload,nodeboun,nboun,itg,ndirboun,&deltmx,&iflagact, + set,nset,istartset,iendset,ialset); + } + + /*********************************************************/ + /* end of the iteration loop */ + /*********************************************************/ + + /* icutb=0 means that the iterations in the increment converged, + icutb!=0 indicates that the increment has to be reiterated with + another increment size (dtheta) */ + + if(uncoupled){ + free(iruc); + } + + if(((qa[0]>ea*qam[0])||(qa[1]>ea*qam[1]))&&(icutb==0)){jnz++;} + iit=0; + + if(icutb!=0){ + + memcpy(&vold[0],&vini[0],sizeof(double)*mt**nk); + + for(k=0;k<*nboun;++k){xbounact[k]=xbounini[k];} + if((*ithermal==1)||(*ithermal>=3)){ + for(k=0;k<*nk;++k){t1act[k]=t1ini[k];} + } + for(k=0;k1) qfn=NNEW(double,3**nk); + inum=NNEW(int,*nk); + stx=NNEW(double,6*mi[0]**ne); + if(*ithermal>1) qfx=NNEW(double,3*mi[0]*ne0); + + if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); + if(strcmp1(&filab[435],"PEEQ")==0) epn=NNEW(double,*nk); + if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); + if(strcmp1(&filab[609],"SDV ")==0) xstaten=NNEW(double,*nstate_**nk); + + memcpy(&v[0],&vold[0],sizeof(double)*mt**nk); + + iout=2; + icmd=3; + + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1act,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xbounact,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, + xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,istep,&iinc,springarea, + &reltime)); + + memcpy(&vold[0],&v[0],sizeof(double)*mt**nk); + + iout=0; + if(*iexpl<=1) icmd=0; + for(k=0;k0){inum[itg[k]-1]*=-1;} + + ++*kode; + if(*mcs!=0){ + frdcyc(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een, + t1act,fn,ttime,epn,ielmat,matname,cs,mcs,nkon,enern,xstaten, + nstate_,istep,&iinc,iperturb,ener,mi,output,ithermal,qfn, + ialset,istartset,iendset,trab,inotr,ntrans,orab,ielorien, + norien,stx,veold,&noddiam,set,nset); + } + else{ + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); + } + if(mortar==1){ + RENEW(stx,double,6*mi[0]*(*ne+nslavs)); + for(k=0;k1){free(qfx);free(qfn);} + + if(strcmp1(&filab[261],"E ")==0) free(een); + if(strcmp1(&filab[435],"PEEQ")==0) free(epn); + if(strcmp1(&filab[522],"ENER")==0) free(enern); + if(strcmp1(&filab[609],"SDV ")==0) free(xstaten); + } + + } + + /*********************************************************/ + /* end of the increment loop */ + /*********************************************************/ + + if(jprint!=0){ + + /* calculating the displacements and the stresses and storing + the results in frd format */ + + v=NNEW(double,mt**nk); + fn=NNEW(double,mt**nk); + stn=NNEW(double,6**nk); + if(*ithermal>1) qfn=NNEW(double,3**nk); + inum=NNEW(int,*nk); + stx=NNEW(double,6*mi[0]**ne); + if(*ithermal>1) qfx=NNEW(double,3*mi[0]*ne0); + + if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); + if(strcmp1(&filab[435],"PEEQ")==0) epn=NNEW(double,*nk); + if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); + if(strcmp1(&filab[609],"SDV ")==0) xstaten=NNEW(double,*nstate_**nk); + + memcpy(&v[0],&vold[0],sizeof(double)*mt**nk); + iout=2; + icmd=3; + + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xbounact,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,&neq[1],veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, + xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,istep,&iinc,springarea, + &reltime)); + + memcpy(&vold[0],&v[0],sizeof(double)*mt**nk); + + iout=0; + if(*iexpl<=1) icmd=0; + for(k=0;k0){inum[itg[k]-1]*=-1;} + + ++*kode; + if(*mcs>0){ + frdcyc(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een, + t1act,fn,ttime,epn,ielmat,matname,cs,mcs,nkon,enern,xstaten, + nstate_,istep,&iinc,iperturb,ener,mi,output,ithermal,qfn, + ialset,istartset,iendset,trab,inotr,ntrans,orab,ielorien, + norien,stx,veold,&noddiam,set,nset); + } + else{ + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); + } + if(mortar==1){ + RENEW(stx,double,6*mi[0]*(*ne+nslavs)); + for(k=0;k1){free(qfx);free(qfn);} + + if(strcmp1(&filab[261],"E ")==0) free(een); + if(strcmp1(&filab[435],"PEEQ")==0) free(epn); + if(strcmp1(&filab[522],"ENER")==0) free(enern); + if(strcmp1(&filab[609],"SDV ")==0) free(xstaten); + + } + + /* setting the velocity to zero at the end of a quasistatic or stationary + step */ + + if(*nmethod==1){ + for(k=0;k0)&&(ndirboun[k]<4)){ + node=nodeboun[k]; + FORTRAN(nident,(itg,&node,&ntg,&id)); + networknode=0; + if(id>0){ + if(itg[id-1]==node) networknode=1; + } + if((*ithermal==2)&&(networknode==0)) continue; + } + xbounold[k]=xbounact[k]; + } + for(k=0;k<*nforc;++k){xforcold[k]=xforcact[k];} + for(k=0;k<2**nload;++k){xloadold[k]=xloadact[k];} + for(k=0;k<7**nbody;k=k+7){xbodyold[k]=xbodyact[k];} + if(*ithermal==1){ + for(k=0;k<*nk;++k){t1old[k]=t1act[k];} + for(k=0;k<*nk;++k){vold[mt*k]=t1act[k];} + } + else if(*ithermal>1){ + for(k=0;k<*nk;++k){t1[k]=vold[mt*k];} + if(*ithermal>=3){ + for(k=0;k<*nk;++k){t1old[k]=t1act[k];} + } + } + + qaold[0]=qa[0]; + qaold[1]=qa[1]; + + free(f); + free(b); + free(xbounact);free(xforcact);free(xloadact);free(xbodyact); + if(*nbody>0) free(ipobody);if(inewton==1){free(cgr);} + free(fext);free(ampli);free(xbounini);free(xstiff); + if((*ithermal==1)||(*ithermal>=3)){free(t1act);free(t1ini);} + + if(*ithermal>1){ + free(itg);free(ieg);free(iptri);free(kontri);free(nloadtr); + free(area);free(pmid);free(nactdog);free(nacteq);free(ineighe); + free(dist);free(idist);free(fij);free(tarea);free(tenv);free(fenv); + free(erad);free(ac);free(bc);free(ipiv);free(e1);free(e2);free(e3); + free(acr);free(bcr);free(ipivr); + if((*mcs>0)&&(ntr>0)){free(inocs);} + } + + if(cfd==1){ + free(sideface);free(nelemface);free(ifreestream); + free(isolidsurf);free(neighsolidsurf);free(iponoel);free(inoel); + free(voldtu); + } + + free(fini); + if(*nmethod==4){ + free(aux2);free(fextini);free(veini);free(accini); + free(adb);free(aub); + } + free(eei);free(stiini); + if(*nener==1) + free(enerini); + if(*nstate_!=0){free(xstateini);} + + free(aux);free(iaux);free(vini); + + if((icascade==2)||(ncont!=0)){ + memmpc_=memmpcref_;mpcfree=mpcfreeref; + RENEW(nodempc,int,3*memmpcref_); + for(k=0;k<3*memmpcref_;k++){nodempc[k]=nodempcref[k];} + RENEW(coefmpc,double,memmpcref_); + for(k=0;k0){ + RENEW(ielorien,int,*ne); + } + RENEW(ielmat,int,*ne); + free(cg);free(straight); + free(imastop);free(itiefac);free(islavsurf);free(islavnode); + free(nslavnode);free(iponoels);free(inoels); + + /* deleting contact MPC's (not for modal dynamics calculations) */ + + remcontmpc(nmpc,labmpc,&mpcfree,nodempc,ikmpc,ilmpc,coefmpc,ipompc); + + if(mortar==1){ + free(islavact);free(gap);free(slavnor);free(bdd); + free(auqdt);free(irowqdt);free(jqqdt);free(bhat); + free(jqtemp);free(irowtemp);free(icoltemp);free(imastnode); + free(nmastnode);free(cstress);free(f_cm);free(f_cs);free(ipe); + free(ime);free(cdisp);free(alambda);free(alambdad); + }else{ + free(areaslav);free(springarea); + } + } + + /* reset icascade */ + + if(icascade==1){icascade=0;} + + mpcinfo[0]=memmpc_;mpcinfo[1]=mpcfree;mpcinfo[2]=icascade; + mpcinfo[3]=maxlenmpc; + + *icolp=icol;*irowp=irow;*cop=co;*voldp=vold; + + *ipompcp=ipompc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; + *fmpcp=fmpc;*nodempcp=nodempc;*coefmpcp=coefmpc; + + *ipkonp=ipkon;*lakonp=lakon;*konp=kon;*ielorienp=ielorien; + *ielmatp=ielmat;*enerp=ener;*xstatep=xstate; + + (*tmin)*=(*tper); + (*tmax)*=(*tper); + + free(nactdofinv); + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/nonlinmpc.f calculix-ccx-2.3/ccx_2.3/src/nonlinmpc.f --- calculix-ccx-2.1/ccx_2.3/src/nonlinmpc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/nonlinmpc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1013 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine nonlinmpc(co,vold,ipompc,nodempc,coefmpc,labmpc, + & nmpc,ikboun,ilboun,nboun,xbounact,aux,iaux,maxlenmpc,ikmpc, + & ilmpc,icascade,kon,ipkon,lakon,ne,reltime,newstep,xboun,fmpc, + & iit,idiscon,ncont,trab,ntrans,ithermal,mi) +! +! updates the coefficients in nonlinear MPC's +! + implicit none +! + logical isochoric +! + character*8 lakon(*) + character*20 labmpc(*),label +! + integer ipompc(*),nodempc(3,*),irefnode,irotnode,idir, + & nmpc,index,ii,inode,node,id,ikboun(*),ilboun(*),nboun, + & i,j,k,idof,na,nb,nc,np,i1,i2,i3,iaux(*),maxlenmpc,n, + & l,m,lmax,mmax,ikmpc(*),ilmpc(*),icascade,neigh(7,8), + & mpc,kon(*),ipkon(*),indexe,ne,idofrem,idofins,nmpc0,nmpc01, + & newstep,iit,idiscon,ncont,iexpnode,indexexp,nmpcdif,ntrans, + & nodei,noded,lathyp(3,6),inum,ndir,number,ithermal,mi(2) +! + real*8 co(3,*),coefmpc(*),vold(0:mi(2),*),c(3,3),dc(3,3,3),ww, + & e(3,3,3),d(3,3),w(3),f(3,3),c1,c2,c3,c4,c5,c6,xbounact(*), + & xboun(*),fmpc(*),expan + real*8 dd,a11,a12,a13,a21,a22,a23,a31,a32,a33, + & b11,b12,b13,b21,b22,b23,b31,b32,b33,aux(*),const, + & ddmax,a(3,3),b(3,3),xj,xi,et,ze,xlag(3,20),xeul(3,20), + & coloc(3,8),reltime,csab(7),trab(7,*),pd(3),pi(3), + & ad(3,3),ai(3,3) +! + data d /1.,0.,0.,0.,1.,0.,0.,0.,1./ + data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., + & 0.,0.,1.,0.,0.,0.,-1.,0.,0., + & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ + data neigh /1,9,2,12,4,17,5,2,9,1,10,3,18,6, + & 3,11,4,10,2,19,7,4,11,3,12,1,20,8, + & 5,13,6,16,8,17,1,6,13,5,14,7,18,2, + & 7,15,8,14,6,19,3,8,15,7,16,5,20,4/ + data coloc /-1.,-1.,-1.,1.,-1.,-1.,1.,1.,-1.,-1.,1.,-1., + & -1.,-1.,1.,1.,-1.,1.,1.,1.,1.,-1.,1.,1./ +! +! latin hypercube positions in a 3 x 3 matrix +! + data lathyp /1,2,3,1,3,2,2,1,3,2,3,1,3,1,2,3,2,1/ +! + irotnode=0 + if((icascade.eq.1).and.(newstep.ne.1).and.(ncont.eq.0)) icascade=0 + isochoric=.false. +! + ii=0 + loop: do + ii=ii+1 + if(ii.gt.nmpc) exit + if(labmpc(ii)(1:5).eq.'RIGID') then +! + index=ipompc(ii) + inode=nodempc(1,index) + idir=nodempc(2,index) + coefmpc(index)=1.d0 +! + index=nodempc(3,index) + irefnode=nodempc(1,index) + coefmpc(index)=-1.d0 +! + index=nodempc(3,index) + node=nodempc(1,index) +! +! check whether the rotational node is the same as in +! the last rigid body MPC +! + if(node.ne.irotnode) then + irotnode=node + w(1)=vold(1,node) + w(2)=vold(2,node) + w(3)=vold(3,node) +c write(*,*) 'w ',w(1),w(2),w(3) + ww=dsqrt(w(1)*w(1)+w(2)*w(2)+w(3)*w(3)) +! + c1=dcos(ww) + if(ww.gt.1.d-10) then + c2=dsin(ww)/ww + else + c2=1.d0 + endif + if(ww.gt.1.d-5) then + c3=(1.d0-c1)/ww**2 + else + c3=0.5d0 + endif +! +! rotation matrix c +! + do i=1,3 + do j=1,3 + c(i,j)=c1*d(i,j)+ + & c2*(e(i,1,j)*w(1)+e(i,2,j)*w(2)+e(i,3,j)*w(3))+ + & c3*w(i)*w(j) + enddo + enddo +! + c4=-c2 + if(ww.gt.0.00464159) then + c5=(ww*dcos(ww)-dsin(ww))/ww**3 + else + c5=-1.d0/3.d0 + endif + if(ww.gt.0.0031623) then + c6=(ww*dsin(ww)-2.d0+2.d0*dcos(ww))/ww**4 + else + c6=-1.d0/12.d0 + endif +! +! derivative of the rotation matrix c with respect to +! the rotation vector w +! + do i=1,3 + do j=1,3 + do k=1,3 + dc(i,j,k)=c4*w(k)*d(i,j)+ + & c5*w(k)*(e(i,1,j)*w(1)+ + & e(i,2,j)*w(2)+e(i,3,j)*w(3))+ + & c2*e(i,k,j)+ + & c6*w(k)*w(i)*w(j)+ + & c3*(d(i,k)*w(j)+d(j,k)*w(i)) + enddo + enddo + enddo +! +! dummy variable +! + do i=1,3 + do j=1,3 +c f(i,j)=c(i,j)-d(i,j)-dc(i,j,1)*w(1)-dc(i,j,2)*w(2)- +c & dc(i,j,3)*w(3) + f(i,j)=c(i,j)-d(i,j) + enddo + enddo + endif +! +! determining the coefficients of the rotational degrees +! of freedom +! + coefmpc(index)=dc(idir,1,1)*(co(1,irefnode)-co(1,inode))+ + & dc(idir,2,1)*(co(2,irefnode)-co(2,inode))+ + & dc(idir,3,1)*(co(3,irefnode)-co(3,inode)) +! + index=nodempc(3,index) + coefmpc(index)=dc(idir,1,2)*(co(1,irefnode)-co(1,inode))+ + & dc(idir,2,2)*(co(2,irefnode)-co(2,inode))+ + & dc(idir,3,2)*(co(3,irefnode)-co(3,inode)) +! + index=nodempc(3,index) + coefmpc(index)=dc(idir,1,3)*(co(1,irefnode)-co(1,inode))+ + & dc(idir,2,3)*(co(2,irefnode)-co(2,inode))+ + & dc(idir,3,3)*(co(3,irefnode)-co(3,inode)) +! +! determining the nonhomogeneous part +! + index=nodempc(3,index) + coefmpc(index)=1.d0 +! +! old value of the nonhomogeneous term must be zero +! + vold(nodempc(2,index),nodempc(1,index))=0.d0 + idof=8*(nodempc(1,index)-1)+nodempc(2,index) + call nident(ikboun,idof,nboun,id) + xbounact(ilboun(id))=f(idir,1)*(co(1,irefnode)-co(1,inode))+ + & f(idir,2)*(co(2,irefnode)-co(2,inode))+ + & f(idir,3)*(co(3,irefnode)-co(3,inode))- + & vold(idir,irefnode)+vold(idir,inode) +! + elseif(labmpc(ii)(1:4).eq.'KNOT') then +! +! dependent node +! + index=ipompc(ii) + inode=nodempc(1,index) + idir=nodempc(2,index) + coefmpc(index)=1.d0 +! +! translation node +! + index=nodempc(3,index) + irefnode=nodempc(1,index) + coefmpc(index)=-1.d0 +! +! expansion node +! + index=nodempc(3,index) + iexpnode=nodempc(1,index) + expan=1.d0+vold(1,iexpnode) + indexexp=index +! +! rotation node +! + index=nodempc(3,index) + node=nodempc(1,index) +! +! check whether the rotational node is the same as in +! the last rigid body MPC +! + if(node.ne.irotnode) then + irotnode=node + w(1)=vold(1,node) + w(2)=vold(2,node) + w(3)=vold(3,node) + ww=dsqrt(w(1)*w(1)+w(2)*w(2)+w(3)*w(3)) +! + c1=dcos(ww) + if(ww.gt.1.d-10) then + c2=dsin(ww)/ww + else + c2=1.d0 + endif + if(ww.gt.1.d-5) then + c3=(1.d0-c1)/ww**2 + else + c3=0.5d0 + endif +! +! rotation matrix c +! + do i=1,3 + do j=1,3 + c(i,j)=c1*d(i,j)+ + & c2*(e(i,1,j)*w(1)+e(i,2,j)*w(2)+e(i,3,j)*w(3))+ + & c3*w(i)*w(j) + enddo + enddo +! + c4=-c2 + if(ww.gt.0.00464159) then + c5=(ww*dcos(ww)-dsin(ww))/ww**3 + else + c5=-1.d0/3.d0 + endif + if(ww.gt.0.0031623) then + c6=(ww*dsin(ww)-2.d0+2.d0*dcos(ww))/ww**4 + else + c6=-1.d0/12.d0 + endif +! +! derivative of the rotation matrix c with respect to +! the rotation vector w +! + do i=1,3 + do j=1,3 + do k=1,3 + dc(i,j,k)=c4*w(k)*d(i,j)+ + & c5*w(k)*(e(i,1,j)*w(1)+ + & e(i,2,j)*w(2)+e(i,3,j)*w(3))+ + & c2*e(i,k,j)+ + & c6*w(k)*w(i)*w(j)+ + & c3*(d(i,k)*w(j)+d(j,k)*w(i)) + enddo + enddo + enddo +! +! dummy variable +! + do i=1,3 + do j=1,3 +c f(i,j)=c(i,j)-d(i,j)-dc(i,j,1)*w(1)-dc(i,j,2)*w(2)- +c & dc(i,j,3)*w(3) + f(i,j)=expan*c(i,j)-d(i,j) + enddo + enddo + endif +! + coefmpc(indexexp)=c(idir,1)*(co(1,irefnode)-co(1,inode))+ + & c(idir,2)*(co(2,irefnode)-co(2,inode))+ + & c(idir,3)*(co(3,irefnode)-co(3,inode)) +! +! determining the coefficients of the rotational degrees +! of freedom +! + coefmpc(index)=(dc(idir,1,1)*(co(1,irefnode)-co(1,inode))+ + & dc(idir,2,1)*(co(2,irefnode)-co(2,inode))+ + & dc(idir,3,1)*(co(3,irefnode)-co(3,inode)))*expan +! + index=nodempc(3,index) + coefmpc(index)=(dc(idir,1,2)*(co(1,irefnode)-co(1,inode))+ + & dc(idir,2,2)*(co(2,irefnode)-co(2,inode))+ + & dc(idir,3,2)*(co(3,irefnode)-co(3,inode)))*expan +! + index=nodempc(3,index) + coefmpc(index)=(dc(idir,1,3)*(co(1,irefnode)-co(1,inode))+ + & dc(idir,2,3)*(co(2,irefnode)-co(2,inode))+ + & dc(idir,3,3)*(co(3,irefnode)-co(3,inode)))*expan +! +! determining the nonhomogeneous part +! + index=nodempc(3,index) + coefmpc(index)=1.d0 +! +! old value of the nonhomogeneous term must be zero +! + vold(nodempc(2,index),nodempc(1,index))=0.d0 + idof=8*(nodempc(1,index)-1)+nodempc(2,index) + call nident(ikboun,idof,nboun,id) + xbounact(ilboun(id))=f(idir,1)*(co(1,irefnode)-co(1,inode))+ + & f(idir,2)*(co(2,irefnode)-co(2,inode))+ + & f(idir,3)*(co(3,irefnode)-co(3,inode))- + & vold(idir,irefnode)+vold(idir,inode) +! + elseif(labmpc(ii)(1:8).eq.'STRAIGHT') then +! +! determining nodes and directions involved in MPC +! + index=ipompc(ii) + np=nodempc(1,index) + j=nodempc(2,index) + index=nodempc(3,index) + i=nodempc(2,index) + index=nodempc(3,index) + na=nodempc(1,index) + index=nodempc(3,nodempc(3,index)) + nb=nodempc(1,index) +! +! determining the coefficients +! + index=ipompc(ii) + c2=co(i,na)+vold(i,na)-co(i,nb)-vold(i,nb) + if(dabs(c2).lt.1.d-5) then + write(*,*) '*WARNING in nonlinmpc: coefficient of' + write(*,*) + & ' dependent node in STRAIGHT MPC is zero' + idofrem=8*(np-1)+j +! +! determining a new dependent term +! + ddmax=abs(c2) + l=i + m=j + do k=1,2 + l=l+1 + m=m+1 + if(l.gt.3) l=l-3 + if(m.gt.3) m=m-3 + dd=dabs(co(l,na)+vold(l,na)-co(l,nb)-vold(l,nb)) + if(dd.gt.ddmax) then + ddmax=dd + lmax=l + mmax=m + endif + enddo + i=lmax + j=mmax + idofins=8*(np-1)+j +! + call changedepterm(ikmpc,ilmpc,nmpc,ii,idofrem,idofins) +! + index=ipompc(ii) + nodempc(2,index)=j + index=nodempc(3,index) + nodempc(2,index)=i + index=nodempc(3,index) + nodempc(2,index)=j + index=nodempc(3,index) + nodempc(2,index)=i + index=nodempc(3,index) + nodempc(2,index)=j + index=nodempc(3,index) + nodempc(2,index)=i + index=nodempc(3,index) + nodempc(2,index)=j + if(icascade.eq.0) icascade=1 + c2=co(i,na)+vold(i,na)-co(i,nb)-vold(i,nb) + endif + coefmpc(index)=c2 + index=nodempc(3,index) + c3=co(j,nb)+vold(j,nb)-co(j,na)-vold(j,na) + coefmpc(index)=c3 + index=nodempc(3,index) + c5=co(i,nb)+vold(i,nb)-co(i,np)-vold(i,np) + coefmpc(index)=c5 + index=nodempc(3,index) + c6=co(j,np)+vold(j,np)-co(j,nb)-vold(j,nb) + coefmpc(index)=c6 + index=nodempc(3,index) + c4=co(i,np)+vold(i,np)-co(i,na)-vold(i,na) + coefmpc(index)=c4 + index=nodempc(3,index) + c1=co(j,na)+vold(j,na)-co(j,np)-vold(j,np) + coefmpc(index)=c1 + index=nodempc(3,index) +! +! nonhomogeneous term +! + coefmpc(index)=1.d0 +! +! old value of the nonhomogeneous term must be zero +! + idof=8*(nodempc(1,index)-1)+nodempc(2,index) + call nident(ikboun,idof,nboun,id) + xbounact(ilboun(id))=-c1*c2+c3*c4 + if(newstep.eq.1) xboun(ilboun(id))=xbounact(ilboun(id)) + vold(nodempc(2,index),nodempc(1,index))= + & (1.d0-reltime)*xboun(ilboun(id)) + elseif(labmpc(ii)(1:5).eq.'PLANE') then +! +! determining nodes and directions involved in MPC +! + index=ipompc(ii) + np=nodempc(1,index) + i1=nodempc(2,index) + index=nodempc(3,index) + i2=nodempc(2,index) + index=nodempc(3,index) + i3=nodempc(2,index) + index=nodempc(3,index) + na=nodempc(1,index) + index=nodempc(3,nodempc(3,nodempc(3,index))) + nb=nodempc(1,index) + index=nodempc(3,nodempc(3,nodempc(3,index))) + nc=nodempc(1,index) +! +! determining the coefficients +! + a11=co(i1,np)+vold(i1,np)-co(i1,nc)-vold(i1,nc) + a12=co(i2,np)+vold(i2,np)-co(i2,nc)-vold(i2,nc) + a13=co(i3,np)+vold(i3,np)-co(i3,nc)-vold(i3,nc) + a21=co(i1,na)+vold(i1,na)-co(i1,nc)-vold(i1,nc) + a22=co(i2,na)+vold(i2,na)-co(i2,nc)-vold(i2,nc) + a23=co(i3,na)+vold(i3,na)-co(i3,nc)-vold(i3,nc) + a31=co(i1,nb)+vold(i1,nb)-co(i1,nc)-vold(i1,nc) + a32=co(i2,nb)+vold(i2,nb)-co(i2,nc)-vold(i2,nc) + a33=co(i3,nb)+vold(i3,nb)-co(i3,nc)-vold(i3,nc) +! + b11=a22*a33-a23*a32 + b12=a31*a23-a21*a33 + b13=a21*a32-a31*a22 + b21=a32*a13-a12*a33 + b22=a11*a33-a31*a13 + b23=a31*a12-a11*a32 + b31=a12*a23-a22*a13 + b32=a21*a13-a11*a23 + b33=a11*a22-a12*a21 +! + index=ipompc(ii) + if(dabs(b11).lt.1.d-5) then + write(*,*) '*WARNING in nonlinmpc: coefficient of' + write(*,*) ' dependent node in PLANE MPC is zero' +! + idofrem=8*(nodempc(1,index)-1)+i1 +! + if(dabs(b12).gt.dabs(b13)) then + idofins=8*(nodempc(1,index)-1)+i2 + call changedepterm + & (ikmpc,ilmpc,nmpc,ii,idofrem,idofins) + coefmpc(index)=b12 + nodempc(2,index)=i2 + index=nodempc(3,index) + coefmpc(index)=b11 + nodempc(2,index)=i1 + index=nodempc(3,index) + coefmpc(index)=b13 + index=nodempc(3,index) + coefmpc(index)=b22 + nodempc(2,index)=i2 + index=nodempc(3,index) + coefmpc(index)=b21 + nodempc(2,index)=i1 + index=nodempc(3,index) + coefmpc(index)=b23 + index=nodempc(3,index) + coefmpc(index)=b32 + nodempc(2,index)=i2 + index=nodempc(3,index) + coefmpc(index)=b31 + nodempc(2,index)=i1 + index=nodempc(3,index) + coefmpc(index)=b33 + index=nodempc(3,index) + coefmpc(index)=-b12-b22-b32 + nodempc(2,index)=i2 + index=nodempc(3,index) + coefmpc(index)=-b11-b21-b31 + nodempc(2,index)=i1 + index=nodempc(3,index) + coefmpc(index)=-b13-b23-b33 + if(icascade.eq.0) icascade=1 + else + idofins=8*(nodempc(1,index)-1)+i3 + call changedepterm + & (ikmpc,ilmpc,nmpc,ii,idofrem,idofins) + coefmpc(index)=b13 + nodempc(2,index)=i3 + index=nodempc(3,index) + coefmpc(index)=b12 + index=nodempc(3,index) + coefmpc(index)=b11 + nodempc(2,index)=i1 + index=nodempc(3,index) + coefmpc(index)=b23 + nodempc(2,index)=i3 + index=nodempc(3,index) + coefmpc(index)=b22 + index=nodempc(3,index) + coefmpc(index)=b21 + nodempc(2,index)=i1 + index=nodempc(3,index) + coefmpc(index)=b33 + nodempc(2,index)=i3 + index=nodempc(3,index) + coefmpc(index)=b32 + index=nodempc(3,index) + coefmpc(index)=b31 + nodempc(2,index)=i1 + index=nodempc(3,index) + coefmpc(index)=-b13-b23-b33 + nodempc(2,index)=i3 + index=nodempc(3,index) + coefmpc(index)=-b12-b22-b32 + index=nodempc(3,index) + coefmpc(index)=-b11-b21-b31 + nodempc(2,index)=i1 + if(icascade.eq.0) icascade=1 + endif + else + coefmpc(index)=b11 + index=nodempc(3,index) + coefmpc(index)=b12 + index=nodempc(3,index) + coefmpc(index)=b13 + index=nodempc(3,index) + coefmpc(index)=b21 + index=nodempc(3,index) + coefmpc(index)=b22 + index=nodempc(3,index) + coefmpc(index)=b23 + index=nodempc(3,index) + coefmpc(index)=b31 + index=nodempc(3,index) + coefmpc(index)=b32 + index=nodempc(3,index) + coefmpc(index)=b33 + index=nodempc(3,index) + coefmpc(index)=-b11-b21-b31 + index=nodempc(3,index) + coefmpc(index)=-b12-b22-b32 + index=nodempc(3,index) + coefmpc(index)=-b13-b23-b33 + endif + index=nodempc(3,index) + coefmpc(index)=1.d0 + idof=8*(nodempc(1,index)-1)+nodempc(2,index) +! +! old value of the nonhomogeneous term must be zero +! + call nident(ikboun,idof,nboun,id) + xbounact(ilboun(id))=a11*b11+a12*b12+a13*b13 + if(newstep.eq.1) xboun(ilboun(id))=xbounact(ilboun(id)) + vold(nodempc(2,index),nodempc(1,index))=0.d0 + elseif(labmpc(ii)(1:9).eq.'ISOCHORIC') then + isochoric=.true. +! +! next segment is deactivated (CYCLID instead of CYCLIC): +! cylic MPC's are considered to be linear +! + elseif((labmpc(ii)(1:6).eq.'CYCLID').and.(ithermal.ne.2)) then + index=ipompc(ii) + noded=nodempc(1,index) +! +! check for thermal MPC +! + if(nodempc(2,index).eq.0) cycle loop +! +! check whether the next two MPC's are cyclic MPC's +! applied to the same dependent node +! + if((nodempc(1,ipompc(ii+1)).ne.noded).or. + & (labmpc(ii+1)(1:6).ne.'CYCLIC').or. + & (nodempc(1,ipompc(ii+2)).ne.noded).or. + & (labmpc(ii+2)(1:6).ne.'CYCLIC')) then + write(*,*) '*WARNING in nonlinmpc: no three' + write(*,*) ' cyclic MPCs pertaining' + write(*,*) ' to the same dependent node;' + write(*,*) ' no update' + cycle loop + endif +! +! finding the cyclic symmetry axis +! + do i=1,ntrans + if(trab(7,i).eq.2) exit + enddo + if(i.gt.ntrans) then + write(*,*) '*ERROR in nonlinmpc: cyclic symmetry' + write(*,*) ' axis not found' + stop + endif + do j=1,6 + csab(j)=trab(j,i) + enddo + csab(7)=-1 +! +! determining the independent node +! + nodei=0 + do + if(nodempc(1,index).ne.noded) then + if(nodei.eq.0) then + nodei=nodempc(1,index) + elseif(nodei.ne.nodempc(1,index)) then + write(*,*) '*WARNING in nonlinmpc:' + write(*,*) ' cyclic symmetry conditions' + write(*,*) ' between unequal meshes' + write(*,*) ' no update' + cycle loop + endif + endif + index=nodempc(3,index) + if(index.eq.0) then + if(nodei.eq.0) then + write(*,*) '*ERROR in nonlinmpc:' + write(*,*) ' no independent node found' + stop + else + exit + endif + endif + enddo +! +! actual location of dependent and independent node +! + do i=1,3 + pd(i)=co(i,noded)+vold(i,noded) + pi(i)=co(i,nodei)+vold(i,nodei) + enddo +! +! update transformation matrix +! + call transformatrix(csab,pd,ad) + call transformatrix(csab,pi,ai) +! +! checking for latin hypercube positions in matrix al none of +! which are zero +! + do inum=1,6 + if((dabs(ad(lathyp(1,inum),1)).gt.1.d-3).and. + & (dabs(ad(lathyp(2,inum),2)).gt.1.d-3).and. + & (dabs(ad(lathyp(3,inum),3)).gt.1.d-3)) exit + enddo +! +! remove old DOFs +! + do j=1,3 + idof=8*(noded-1)+j + call nident(ikmpc,idof,nmpc,id) + if(id.lt.0) then + write(*,*) '*ERROR in nonlinmpc: error in' + write(*,*) ' MPC database' + stop + elseif(ikmpc(id).ne.idof) then + write(*,*) '*ERROR in nonlinmpc: error in' + write(*,*) ' MPC database' + stop + endif +! + do k=id,nmpc-1 + ikmpc(k)=ikmpc(k+1) + ilmpc(k)=ilmpc(k+1) + enddo + enddo +! +! add new MPCs +! + ii=ii-1 + do ndir=1,3 + ii=ii+1 + number=lathyp(ndir,inum) + idof=8*(noded-1)+number + call nident(ikmpc,idof,nmpc-1,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*WARNING in nonlinmpc: cyclic MPC + & in node' + write(*,*) ' ',noded,' and direction ',ndir + write(*,*) ' cannot be created: the' + write(*,*) ' DOF in this node is already us + &ed' + cycle + endif + endif + number=number-1 +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! +! update the MPC coefficients +! + index=ipompc(ii) + do j=1,3 + number=number+1 + if(number.gt.3) number=1 + if(dabs(ad(number,ndir)).lt.1.d-5) cycle + if(index.eq.0) then + write(*,*)'*ERROR in nonlinmpc: index=0' + stop + endif + nodempc(1,index)=noded + nodempc(2,index)=number + coefmpc(index)=ad(number,ndir) + index=nodempc(3,index) + enddo + do j=1,3 + number=number+1 + if(number.gt.3) number=1 + if(dabs(ai(number,ndir)).lt.1.d-5) cycle + if(index.eq.0) then + write(*,*)'*ERROR in nonlinmpc: index=0' + stop + endif + nodempc(1,index)=nodei + nodempc(2,index)=number + coefmpc(index)=-ai(number,ndir) + index=nodempc(3,index) + enddo + enddo + elseif((labmpc(ii)(1:20).ne.' ').and. + & (labmpc(ii)(1:10).ne.'PRETENSION').and. + & (labmpc(ii)(1:7).ne.'CONTACT').and. + & (labmpc(ii)(1:7).ne.'NETWORK').and. + & (labmpc(ii)(1:6).ne.'CYCLIC').and. + & (labmpc(ii)(1:9).ne.'SUBCYCLIC')) then + index=ipompc(ii) + i=0 + do + if(index.eq.0) exit + node=nodempc(1,index) + i=i+1 + iaux(i)=nodempc(2,index) + aux(6*maxlenmpc+i)=coefmpc(index) + do j=1,3 + aux(3*(i-1)+j)=co(j,node) + aux(3*(maxlenmpc+i-1)+j)=vold(j,node) + enddo + index=nodempc(3,index) + enddo + n=i-1 + if((labmpc(ii)(1:7).eq.'MEANROT').or. + & (labmpc(ii)(1:1).eq.'1')) then + call umpc_mean_rot(aux,aux(3*maxlenmpc+1),const, + & aux(6*maxlenmpc+1),iaux,n,fmpc(ii),iit,idiscon) + elseif(labmpc(ii)(1:4).eq.'DIST') then + call umpc_dist(aux,aux(3*maxlenmpc+1),const, + & aux(6*maxlenmpc+1),iaux,n,fmpc(ii),iit,idiscon) + elseif(labmpc(ii)(1:3).eq.'GAP') then + call umpc_gap(aux,aux(3*maxlenmpc+1),const, + & aux(6*maxlenmpc+1),iaux,n,fmpc(ii),iit,idiscon) + elseif(labmpc(ii)(1:4).eq.'USER') then + call umpc_user(aux,aux(3*maxlenmpc+1),const, + & aux(6*maxlenmpc+1),iaux,n,fmpc(ii),iit,idiscon) + else + write(*,*) '*ERROR in nonlinmpc: mpc of type ',labmpc(ii) + write(*,*) ' is unknown' + stop + endif + index=ipompc(ii) +! + if(iaux(1).ne.nodempc(2,index)) then +! +! dependent MPC has changed +! + idofrem=8*(nodempc(1,index)-1)+nodempc(2,index) + idofins=8*(nodempc(1,index)-1)+iaux(1) + call changedepterm(ikmpc,ilmpc,nmpc,ii,idofrem,idofins) + if(icascade.eq.0) icascade=1 + endif +! + i=0 + do + if(index.eq.0) exit + i=i+1 + if(i.le.n) then +! +! check whether any directions have changed: +! necessitates calling of remastruct +! + if(iaux(i).ne.nodempc(2,index)) then + if(icascade.eq.0) icascade=1 + endif + nodempc(2,index)=iaux(i) + coefmpc(index)=aux(6*maxlenmpc+i) + else + coefmpc(index)=1.d0 +! +! old value of the nonhomogeneous term must be zero +! + vold(nodempc(2,index),nodempc(1,index))=0.d0 + idof=8*(nodempc(1,index)-1)+nodempc(2,index) + call nident(ikboun,idof,nboun,id) + xbounact(ilboun(id))=const + endif + index=nodempc(3,index) + enddo + endif + enddo loop +! +! incompressible material +! + if(.not.isochoric) return +! +! initialization of the mpc's +! + nmpc01=0 + nmpcdif=0 + do i=1,nmpc + if(labmpc(i)(1:9).eq.'ISOCHORIC') then + if(nmpc01.eq.0) nmpc01=i + nmpcdif=i + index=ipompc(i) + do + if(nodempc(3,index).eq.0) then + idof=8*(nodempc(1,index)-1)+nodempc(2,index) + call nident(ikboun,idof,nboun,id) + xbounact(ilboun(id))=0.d0 + exit + endif + coefmpc(index)=0.d0 + index=nodempc(3,index) + enddo + endif + enddo + nmpc0=nmpc01-1 + nmpcdif=nmpcdif-nmpc0 +! + do i=1,ne + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:7).eq.'C3D20RI') then + indexe=ipkon(i) +! + do j=1,20 + node=kon(indexe+j) + do k=1,3 + xlag(k,j)=co(k,node) + xeul(k,j)=xlag(k,j)+vold(k,node) + enddo + enddo +! + do j=1,8 + mpc=0 + node=kon(indexe+j) + label(1:9)='ISOCHORIC' + write(label(10:20),'(i11)') node +c write(*,*) 'nonlinmpclab ',label + call cident20(labmpc(nmpc01),label,nmpcdif,id) + id=id+nmpc0 +c write(*,*) 'nonlinmpclab ',id,label,labmpc(id) + if(id.gt.0) then + if(labmpc(id).eq.label) then + mpc=id + endif + endif + if(mpc.eq.0) cycle +! + xi=coloc(1,j) + et=coloc(2,j) + ze=coloc(3,j) +! + call deuldlag(xi,et,ze,xlag,xeul,xj,a) +! + b(1,1)=a(2,2)*a(3,3)-a(2,3)*a(3,2) + b(1,2)=a(3,1)*a(2,3)-a(2,1)*a(3,3) + b(1,3)=a(2,1)*a(3,2)-a(3,1)*a(2,2) + b(2,1)=a(3,2)*a(1,3)-a(1,2)*a(3,3) + b(2,2)=a(1,1)*a(3,3)-a(3,1)*a(1,3) + b(2,3)=a(3,1)*a(1,2)-a(1,1)*a(3,2) + b(3,1)=a(1,2)*a(2,3)-a(2,2)*a(1,3) + b(3,2)=a(2,1)*a(1,3)-a(1,1)*a(2,3) + b(3,3)=a(1,1)*a(2,2)-a(1,2)*a(2,1) +! + index=ipompc(mpc) + do + if(nodempc(3,index).eq.0) then + coefmpc(index)=1.d0 + idof=8*(nodempc(1,index)-1)+nodempc(2,index) + call nident(ikboun,idof,nboun,id) + xbounact(ilboun(id))=xbounact(ilboun(id))+ + & a(1,1)*b(1,1)+a(1,2)*b(1,2)+a(1,3)*b(1,3) + & -1.d0/xj +c write(*,*) 'nonlinmpcboun ',nodempc(1,index), +c & nodempc(2,index),ilboun(id), +c & xbounact(ilboun(id)) + exit + else + node=nodempc(1,index) + idir=nodempc(2,index) + do k=1,7 + if(kon(indexe+neigh(k,j)).eq.node) then + if(k.eq.1) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index)+ + & 1.5d0*(xi*b(1,1)+et*b(1,2)+ze*b(1,3)) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index)+ + & 1.5d0*(xi*b(2,1)+et*b(2,2)+ze*b(2,3)) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index)+ + & 1.5d0*(xi*b(3,1)+et*b(3,2)+ze*b(3,3)) + endif + elseif(k.eq.2) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index)- + & 2.d0*xi*b(1,1) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index)- + & 2.d0*xi*b(2,1) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index)- + & 2.d0*xi*b(3,1) + endif + elseif(k.eq.3) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index)+ + & 0.5d0*xi*b(1,1) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index)+ + & 0.5d0*xi*b(2,1) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index)+ + & 0.5d0*xi*b(3,1) + endif + elseif(k.eq.4) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index)- + & 2.d0*et*b(1,2) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index)- + & 2.d0*et*b(2,2) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index)- + & 2.d0*et*b(3,2) + endif + elseif(k.eq.5) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index)+ + & 0.5d0*et*b(1,2) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index)+ + & 0.5d0*et*b(2,2) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index)+ + & 0.5d0*et*b(3,2) + endif + elseif(k.eq.6) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index)- + & 2.d0*ze*b(1,3) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index)- + & 2.d0*ze*b(2,3) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index)- + & 2.d0*ze*b(3,3) + endif + elseif(k.eq.7) then + if(idir.eq.1) then + coefmpc(index)=coefmpc(index)+ + & 0.5d0*ze*b(1,3) + elseif(idir.eq.2) then + coefmpc(index)=coefmpc(index)+ + & 0.5d0*ze*b(2,3) + elseif(idir.eq.3) then + coefmpc(index)=coefmpc(index)+ + & 0.5d0*ze*b(3,3) + endif + endif + exit + endif + enddo + endif + index=nodempc(3,index) + enddo +! + enddo + endif + enddo +! + return + end + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/normals.f calculix-ccx-2.3/ccx_2.3/src/normals.f --- calculix-ccx-2.1/ccx_2.3/src/normals.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/normals.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,126 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine normals(inpc,textpart,iponor,xnor,ixfree, + & ipkon,kon,nk,nk_,ne,lakon,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! +! reading the input deck: *NORMAL +! + implicit none +! + character*1 inpc(*) + character*8 lakon(*) + character*132 textpart(16) +! + integer iponor(2,*),ixfree,ipkon(*),kon(*),nk,ipoinpc(0:*), + & nk_,ne,istep,istat,n,ielement,node,j,indexe,i, + & key,iline,ipol,inl,ipoinp(2,*),inp(3,*) +! + real*8 xnor(*),x,y,z,dd +! + if(istep.gt.0) then + write(*,*) '*ERROR in normals: *NORMAL should be placed' + write(*,*) ' before all step definitions' + stop + endif +! + do i=2,n + write(*,*) + & '*WARNING in normals: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + enddo +! + loop:do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit +! + read(textpart(1)(1:10),'(i10)',iostat=istat) ielement + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:10),'(i10)',iostat=istat) node + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) x + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(n.le.3) then + y=0.d0 + else + read(textpart(4)(1:20),'(f20.0)',iostat=istat) y + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + endif + if(n.le.4) then + z=0.d0 + else + read(textpart(5)(1:20),'(f20.0)',iostat=istat) z + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + endif +! +! normalizing the normal +! + dd=dsqrt(x*x+y*y+z*z) + x=x/dd + y=y/dd + z=z/dd +! + if(ielement.gt.ne) then + write(*,*) '*ERROR in normals: element number',ielement + write(*,*) ' exceeds ne' + stop + endif +! + indexe=ipkon(ielement) + do j=1,8 + if(kon(indexe+j).eq.node) then + iponor(1,indexe+j)=ixfree + if(lakon(ielement)(1:1).eq.'B') then + xnor(ixfree+4)=x + xnor(ixfree+5)=y + xnor(ixfree+6)=z + ixfree=ixfree+6 + elseif(lakon(ielement)(1:2).ne.'C3') then + xnor(ixfree+1)=x + xnor(ixfree+2)=y + xnor(ixfree+3)=z + ixfree=ixfree+3 + else + write(*,*) '*WARNING in normals: specifying a normal' + write(*,*) ' 3-D element does not make sense' + endif + cycle loop + endif + enddo + write(*,*) '*WARNING: node ',node,' does not belong to' + write(*,*) ' element ',ielement + write(*,*) ' normal definition discarded' +! + enddo loop +! + return + end + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/norshell6.f calculix-ccx-2.3/ccx_2.3/src/norshell6.f --- calculix-ccx-2.1/ccx_2.3/src/norshell6.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/norshell6.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,82 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine norshell6(xi,et,xl,xnor) +! +! calculates the normal on a triangular shell element in a point +! with local coordinates xi and et. The coordinates of the nodes +! belonging to the element are stored in xl +! + implicit none +! + integer i,j,k +! + real*8 shp(4,6),xs(3,2),xl(3,6),xnor(3) +! + real*8 xi,et +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=4.d0*(xi+et)-3.d0 + shp(1,2)=4.d0*xi-1.d0 + shp(1,3)=0.d0 + shp(1,4)=4.d0*(1.d0-2.d0*xi-et) + shp(1,5)=4.d0*et + shp(1,6)=-4.d0*et +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=4.d0*(xi+et)-3.d0 + shp(2,2)=0.d0 + shp(2,3)=4.d0*et-1.d0 + shp(2,4)=-4.d0*xi + shp(2,5)=4.d0*xi + shp(2,6)=4.d0*(1.d0-xi-2.d0*et) +! +! shape functions +! + shp(4,1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et) + shp(4,2)=xi*(2.d0*xi-1.d0) + shp(4,3)=et*(2.d0*et-1.d0) + shp(4,4)=4.d0*xi*(1.d0-xi-et) + shp(4,5)=4.d0*xi*et + shp(4,6)=4.d0*et*(1.d0-xi-et) +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,6 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant +! + xnor(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xnor(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xnor(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/norshell8.f calculix-ccx-2.3/ccx_2.3/src/norshell8.f --- calculix-ccx-2.1/ccx_2.3/src/norshell8.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/norshell8.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,88 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine norshell8(xi,et,xl,xnor) +! +! calculates the normal on a quadratic shell element in a point +! with local coordinates xi and et. The coordinates of the nodes +! belonging to the element are stored in xl +! + implicit none +! + integer i,j,k +! + real*8 shp(4,8),xs(3,2),xl(3,8),xnor(3) +! + real*8 xi,et +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=(1.d0-et)*(2.d0*xi+et)/4.d0 + shp(1,2)=(1.d0-et)*(2.d0*xi-et)/4.d0 + shp(1,3)=(1.d0+et)*(2.d0*xi+et)/4.d0 + shp(1,4)=(1.d0+et)*(2.d0*xi-et)/4.d0 + shp(1,5)=-xi*(1.d0-et) + shp(1,6)=(1.d0-et*et)/2.d0 + shp(1,7)=-xi*(1.d0+et) + shp(1,8)=-(1.d0-et*et)/2.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=(1.d0-xi)*(2.d0*et+xi)/4.d0 + shp(2,2)=(1.d0+xi)*(2.d0*et-xi)/4.d0 + shp(2,3)=(1.d0+xi)*(2.d0*et+xi)/4.d0 + shp(2,4)=(1.d0-xi)*(2.d0*et-xi)/4.d0 + shp(2,5)=-(1.d0-xi*xi)/2.d0 + shp(2,6)=-et*(1.d0+xi) + shp(2,7)=(1.d0-xi*xi)/2.d0 + shp(2,8)=-et*(1.d0-xi) +! +! shape functions +! + shp(4,1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0 + shp(4,2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0 + shp(4,3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0 + shp(4,4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0 + shp(4,5)=(1.d0-xi*xi)*(1.d0-et)/2.d0 + shp(4,6)=(1.d0+xi)*(1.d0-et*et)/2.d0 + shp(4,7)=(1.d0-xi*xi)*(1.d0+et)/2.d0 + shp(4,8)=(1.d0-xi)*(1.d0-et*et)/2.d0 +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,8 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant +! + xnor(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xnor(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xnor(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/number.f calculix-ccx-2.3/ccx_2.3/src/number.f --- calculix-ccx-2.1/ccx_2.3/src/number.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/number.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,99 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine number(n,nc,snode,lstnum,e2,adj,xadj,s,q,p) +! +! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) +! + integer nc,lstnum,jstrt,jstop,istop,nbr,nabor,i,j,next,addres,nn, + & node,snode,istrt,maxprt,prty,n,w1,w2,e2,q(nc),xadj(n+1),adj(e2), + & p(n),s(n) +! + parameter(w1=1,w2=2) +! + do 10 i=1,nc + node=q(i) + p(node)=w1*s(node)-w2*(xadj(node+1)-xadj(node)+1) + s(node)=-2 + 10 continue +! + nn=1 + q(nn)=snode + s(snode)=-1 +! + 30 if(nn.gt.0) then +! + addres=1 + maxprt=p(q(1)) + do 35 i=2,nn + prty=p(q(i)) + if(prty.gt.maxprt) then + addres=i + maxprt=prty + endif + 35 continue +! + next=q(addres) +! + q(addres)=q(nn) + nn=nn-1 + istrt=xadj(next) + istop=xadj(next+1)-1 + if(s(next).eq.-1) then +! + do 50 i=istrt,istop +! + nbr=adj(i) + p(nbr)=p(nbr)+w2 +! + if(s(nbr).eq.-2) then + nn=nn+1 + q(nn)=nbr + s(nbr)=-1 + endif + 50 continue + endif +! + lstnum=lstnum+1 + s(next)=lstnum +! + do 80 i=istrt,istop + nbr=adj(i) + if(s(nbr).eq.-1) then +! + p(nbr)=p(nbr)+w2 + s(nbr)=0 +! + jstrt=xadj(nbr) + jstop=xadj(nbr+1)-1 + do 60 j=jstrt,jstop + nabor=adj(j) +! + p(nabor)=p(nabor)+w2 + if(s(nabor).eq.-2) then +! + nn=nn+1 + q(nn)=nabor + s(nabor)=-1 + endif + 60 continue + endif + 80 continue + go to 30 + endif + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/onedint.f calculix-ccx-2.3/ccx_2.3/src/onedint.f --- calculix-ccx-2.1/ccx_2.3/src/onedint.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/onedint.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,214 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +C +C 1. TASK INTERPOLATION OF A FUNCTION DEFINED POINT BY POINT +C ********* THE X COORDINATES ARE USER SPECIFIED. +C THE INTERPOLATION PROCESS CAN BE EITHER CONSTANT,LINEAR +c OR EVEN dOUBLE QUADRATIC WITH EXTRAPOLATION USING THE +c POLYNOM HIGHEST ORDER +C thE DOUBLE QUADRATIC INTERPOLATION IS A 3RD ORDER METHOD +c BY WHICH 2 PARABOLS ENCOMPASSING EACH 3 AND 4 sAMPLING POINTS +c ARE DEFINED. +c THE SOLUTION IS A LINEAR COMBINATION OF THE CONCERNED +c PARABOLS VALUES DEPENDING ON THE DEFINITION OF THE ACTUAL +c SAMPLING POINT INTERVAL +C +C +C 2.INPUT CALL A06931(XE,YE,NE,XA,YA,NA,IART,IEXP,IER) +C *********** XE = ABSCISSE VECTOR OF THE SAMPLING POINTS +C YE = ORDINATE VECTOR OF THE SAMPLING POINTS +C NE = LENGHT OF THE SAMPLING POINT VECTOR +C XA = ASCISSE VECTOR OF THE INTERPOLATION POINT(INPUT) +C YA = ORDINATE VECTOR OF THE INTERPOLATION POINT(OUTPUT) +C NA = LENGTH OF THE INTERPOLATION VECTOR c IART = tYPE OF INTERPOLATION +C =0: CONSTANT +C =1: LINEAR +C =2: DOUBLE QUADRATIC +C IEXP = TYPE OF EXTRAPOLATION +C IEXP = 10*IEX1 + IEXN +C IEX1 EXTRAPOLATIONS BEYOND THE +C 1. SAMPLING POINT IN THE VECTOR +C IEXN EXTRAPOLATION BEYOND THE +C LAST SAMPLING POINT IN THE VECTOR +C SELECTION OF THE EXTRAPOLATION TYPE AS +C FOR IART. +C IER = ERROR CODE +C = 0: NORMAL PROCEEDING +C =-1:PROBLEM IN TH EGIVEN VALUES +C PROGRAMM STOPS. +C +C 3.RESTRICTION ABSCISSE VECTOR XE MUST BE STRICTLY MONOTONIC INCREASING SORTED +C *************** AUTOMATIC CONTROL INSIDE TEH SUBROUTINE: +C NE = 0: ERROR INTERRUPTION +C NE = 1: ONLY CONSTANT INTER- EXTRAPOLATION +C NE = 2: MAXIMAL LINEAR INTER- EXTRAPOLATION +C NE = 3: MAXIMAL QUADRATIC INTER- EXTRAPOLATIO +C THE PARAMETER FOR THE TYPE OF EXTRAPOLATION +c MUST NOT BE GREATER THAN THE ONE FOR TH EINTERPOLATION TYPE +C OTHERWISE THE VALUE IS AUTOMATICALLY ADAPTATED +C + SUBROUTINE ONEDINT(XE,YE,NE,XA,YA,NA,IART,IEXP,IER) + implicit none + INTEGER NE,NA,NA1,NE1,IG,IER,IA,IART,IE2,I,IEXP,IE1,L + REAL*8 XE(NE),YE(NE),XA(NA),YA(NA),ZW1,ZW2,XO,YO,RAB,XD,YD, + & XZ,YZ,XU,YU,EQ,EQD,X +C +C INTERPOLATION FUNCTION +C ------------------------ + EQ(X) = YU + YU * (X-XU) / XU + + 1 ((YZ-YU)/(XZ-XU) - YU/XU) * (X-XU) * X / XZ + EQD(X) = YZ * X / XZ + + 1 (YD / XD - YZ / XZ) * X * (X - XZ) / (XD - XZ) +C +C INPUT/DATA TEST,INTERPOLATION DIVERGENCE,EXTRAPOLATION LIMIT +C---------------------------------------------------------------- + NA1 = NA - 1 + IF (NA .LE. 0) GO TO 900 + NE1 = NE - 1 + IF (NE1.lt.0) then + go to 900 + elseif(ne1.eq.0) then + go to 22 + else + go to 18 + endif + 18 DO 20 L = 1,NE1 + 20 IF ((XE(L+1)-XE(L)) .LE. 0) GO TO 900 + 22 IE1 = IEXP / 10 + IE2 = IEXP - 10*IE1 + IA = IART + IF (NE1 .LT. IA) IA = NE1 + IF (IA .LT. IE1) IE1 = IA + IF (IA .LT. IE2) IE2 = IA +C +C SUCCESSIVE PROCESSING THE INTERPOLATION EXIGENCES +C------------------------------------------------------- +C +C ZUR ERHOEHUNG DER NUMERISCHEN GENAUIGKEIT WIRD EINE +C TRANSLATION VON (XO,YO) IN (0,0) DURCHGEFUEHRT. DIES +C BEWIRKT AUSSERDEM EINE BESCHLEUNIGUNG DES VERFAHRENS. +C + DO 100 I = 1,NA + DO 24 L = 1,NE + IF (XA(I) .LT. XE(L)) GO TO 30 + 24 CONTINUE + L = NE + IF ((IE2 - 1).lt.0) then + go to 50 + elseif((ie2-1).eq.0) then + go to 35 + else + go to 70 + endif + 30 IF (L .GT. 1) GO TO 40 + IF ((IE1 - 1).lt.0) then + go to 50 + elseif((ie1-1).eq.0) then + go to 25 + else + go to 70 + endif + 40 IF ((IA-1).lt.0) then + go to 45 + elseif((ia-1).eq.0) then + go to 60 + else + go to 70 + endif +C +C CONSTANT INTERPOLATION +C ----------------------- + 45 L = L - 1 + 50 YA(I) = YE(L) + GO TO 100 +C +C LINEAR EXTRAPOLATION +C ------------------------------ + 25 IF (IA .EQ. 1) GO TO 60 + XO = XE(2) + XU = XE(1) - XO + YO = YE(2) + YU = YE(1) - YO + XZ = XE(3) - XO + YZ = YE(3) - YO + GO TO 38 + 35 IF (IA .EQ. 1) GO TO 60 + XO = XE(NE1) + XZ = XE(NE1-1) - XO + XU = XE(NE) - XO + YO = YE(NE1) + YZ = YE(NE1-1) - YO + YU = YE(NE) - YO +C +C LINEAR EXTRAPOLATION WITH QUADRATIC INTERPOLATION +C ----------------------------------------------------- + 38 RAB = YU / XU + XU * ((YZ-YU) / (XZ-XU) - YU/XU) / XZ + YA(I) = YU + YO + (XA(I) -XU-XO)*RAB + GO TO 100 +C +C LINEAR INTERPOLATION +C --------------------- + 60 IG = L - 1 + IF (IG .LT. 1) IG = 1 + YA(I) = YE(IG) + (XA(I)-XE(IG))*(YE(IG+1)-YE(IG)) + 1 / (XE(IG+1)-XE(IG)) + GO TO 100 + 70 IF (L .GT. 2) GO TO 80 + XO = XE(2) + XU = XE(1) - XO + YO = YE(2) + YU = YE(1) - YO + XZ = XE(3) - XO + YZ = YE(3) - YO + GO TO 85 + 80 IF (L .LT. NE) GO TO 90 + XO = XE(NE1) + XU = XE(NE1-1) - XO + XZ = XE(NE) - XO + YO = YE(NE1) + YU = YE(NE1-1) - YO + YZ = YE(NE) - YO + 85 YA(I) = EQ(XA(I)-XO) + YO + GO TO 100 +C +C DOUBLE QUADRATIC INTERPOLATION +C ---------------------------------- + 90 XO = XE(L-1) + XU = XE(L-2) - XO + XZ = XE(L) - XO + XD = XE(L+1) - XO + YO = YE(L-1) + YU = YE(L-2) - YO + YZ = YE(L) - YO + YD = YE(L+1) - YO + ZW1 = EQ(XA(I)-XO) + ZW2 = EQD(XA(I)-XO) + YA(I) = ZW1 + (ZW2 - ZW1) * (XA(I) - XO)/XZ + YO + 100 CONTINUE +C +C RETURN BY NORMAL PROCEEDING +C ------------------------------- + IER = 0 + RETURN +C +C ERROR RETURN +C ------------ + 900 IER = -1 + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/onf.f calculix-ccx-2.3/ccx_2.3/src/onf.f --- calculix-ccx-2.1/ccx_2.3/src/onf.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/onf.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,490 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine onf(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod, + & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern,xstaten, + & nstate_,istep,iinc,iperturb,ener,mi) +! +! stores the results in frd format +! + implicit none +! + character*5 m1 + character*8 lakon(*) + character*80 matname(*) + character*87 filab(*) +! + integer kon(*),inum(*),nk,ne,nmethod,kode,i,j,ipkon(*),indexe, + & one,ielmat(*),nstate_,istep,iinc,ianatyp,iperturb, + & konl(20),jj,mint3d,k,nope,mi(2),n,kflag,iy(3),iflag, + & nktrue,netrue +! + real*8 co(3,*),v(3,*),stn(6,*),een(6,*),t1(*),fn(3,*),time, + & epn(*),enern(*),xstaten(nstate_,*),zero,stnprin(3),str(6), + & str2(6),v1,v2,v3,ener(mi(1),*),xi,et,ze,weight,volume, + & energy,totenergy,xsj,xl(3,20),shp(4,20),tt,cm,cn, + & bb,cc,pi +! + include "gauss.f" +! + data iflag /2/ +! + one=1 + zero=0.d0 + m1=' -1' + pi=4.d0*datan(1.d0) + n=3 + kflag=-1 +! +c open(12,file='beam_520.onf',status='unknown') +c open(13,file='beam.onf',status='unknown') + if(nmethod.eq.1) then + if(iperturb.gt.1) then + ianatyp=5 + else + ianatyp=1 + endif + elseif(nmethod.eq.2) then + ianatyp=2 + elseif(nmethod.eq.3) then + ianatyp=6 + elseif(nmethod.eq.4) then + if(iperturb.gt.1) then + ianatyp=2 + else + ianatyp=4 + endif + endif +! +! calculating the true number of nodes and elements +! + nktrue=0 + do i=1,nk + if(inum(i).ne.0) nktrue=nktrue+1 + enddo + netrue=0 + do i=1,ne + if(ipkon(i).ge.0) netrue=netrue+1 + enddo +! +! storing the frequency and/or the buckling eigenvalue +! + if((nmethod.eq.2).or.(nmethod.eq.3)) then + write(11,'(a5)') m1 + write(11,'(a3)') '500' + write(11,'(i1)') one + write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc + write(11,'(i10)') one + write(11,99) time,zero,zero,zero + endif +! +! storing the displacements of the nodes +! + if(filab(1)(1:4).eq.'U ') then +! + write(11,'(a5)') m1 + write(11,'(a3)') '510' + write(11,'(i1)') one + write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc + write(11,'(i10)') nktrue +! + do i=1,nk + if(inum(i).eq.0) cycle + write(11,100) i,(v(j,i),j=1,3),zero,zero,zero + enddo +! + write(11,'(a5)') m1 + endif +! +! storing the stresses in the nodes +! + if(filab(3)(1:4).eq.'S ') then +! +! calculating the nodal principal stress +! + write(11,'(a5)') m1 + write(11,'(a3)') '520' + write(11,'(i1)') one + write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc + write(11,'(i10)') nktrue +! + do i=1,nk + if(inum(i).eq.0) cycle + do j=1,6 + str(j)=stn(j,i) + enddo + str2(1)=str(1)*str(1)+str(4)*str(4)+str(5)*str(5) + str2(2)=str(4)*str(4)+str(2)*str(2)+str(6)*str(6) + str2(3)=str(5)*str(5)+str(6)*str(6)+str(3)*str(3) +c str2(4)=str(1)*str(4)+str(4)*str(2)+str(5)*str(6) +c str2(5)=str(1)*str(5)+str(4)*str(6)+str(5)*str(3) +c str2(6)=str(4)*str(5)+str(2)*str(6)+str(6)*str(3) + v1=str(1)+str(2)+str(3) + v2=(v1*v1-str2(1)-str2(2)-str2(3))/2.d0 + v3=str(1)*(str(2)*str(3)-str(6)*str(6)) + & -str(4)*(str(4)*str(3)-str(5)*str(6)) + & +str(5)*(str(4)*str(6)-str(5)*str(2)) + bb=v2-v1*v1/3.d0 + cc=-2.d0*v1**3/27.d0+v1*v2/3.d0-v3 + if(dabs(bb).le.1.d-10) then + stnprin(1)=0.d0 + stnprin(2)=0.d0 + stnprin(3)=0.d0 + else + cm=2.d0*dsqrt(-bb/3.d0) + cn=3.d0*cc/(cm*bb) + if(dabs(cn).gt.1.d0) then + if(cn.gt.1.d0) then + cn=1.d0 + else + cn=-1.d0 + endif + endif + tt=datan2(dsqrt(1.d0-cn*cn),cn)/3.d0 + stnprin(1)=cm*dcos(tt) + stnprin(2)=cm*dcos(tt+2.d0*pi/3.d0) + stnprin(3)=cm*dcos(tt+4.d0*pi/3.d0) + endif + do j=1,3 + stnprin(j)=stnprin(j)+v1/3.d0 + enddo + call dsort(stnprin,iy,n,kflag) + write(11,101) i,one,(stnprin(j),j=1,3) + enddo + write(11,'(a5)') m1 +! +! calculating the elemental principal stress +! + write(11,'(a5)') m1 + write(11,'(a3)') '530' + write(11,'(i1)') one + write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc + write(11,'(i10)') netrue +! + do i=1,ne + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + else + nope=6 + endif +! +! calculating the eigenvalues of the mean stress +! tensor. The mean tensor is taken over the nodes +! belonging to the element +! + do j=1,6 + str(j)=0.d0 + do k=1,nope + str(j)=str(j)+stn(j,kon(indexe+k)) + enddo + str(j)=str(j)/nope + enddo + str2(1)=str(1)*str(1)+str(4)*str(4)+str(5)*str(5) + str2(2)=str(4)*str(4)+str(2)*str(2)+str(6)*str(6) + str2(3)=str(5)*str(5)+str(6)*str(6)+str(3)*str(3) +c str2(4)=str(1)*str(4)+str(4)*str(2)+str(5)*str(6) +c str2(5)=str(1)*str(5)+str(4)*str(6)+str(5)*str(3) +c str2(6)=str(4)*str(5)+str(2)*str(6)+str(6)*str(3) + v1=str(1)+str(2)+str(3) + v2=(v1*v1-str2(1)-str2(2)-str2(3))/2.d0 + v3=str(1)*(str(2)*str(3)-str(6)*str(6)) + & -str(4)*(str(4)*str(3)-str(5)*str(6)) + & +str(5)*(str(4)*str(6)-str(5)*str(2)) + bb=v2-v1*v1/3.d0 + cc=-2.d0*v1**3/27.d0+v1*v2/3.d0-v3 + if(dabs(bb).le.1.d-10) then + stnprin(1)=0.d0 + stnprin(2)=0.d0 + stnprin(3)=0.d0 + else + cm=2.d0*dsqrt(-bb/3.d0) + cn=3.d0*cc/(cm*bb) + if(dabs(cn).gt.1.d0) then + if(cn.gt.1.d0) then + cn=1.d0 + else + cn=-1.d0 + endif + endif + tt=datan2(dsqrt(1.d0-cn*cn),cn)/3.d0 + stnprin(1)=cm*dcos(tt) + stnprin(2)=cm*dcos(tt+2.d0*pi/3.d0) + stnprin(3)=cm*dcos(tt+4.d0*pi/3.d0) + endif + call dsort(stnprin,iy,n,kflag) + do j=1,3 + stnprin(j)=stnprin(j)+v1/3.d0 + enddo + write(11,101) i,one,(stnprin(j),j=1,3) + enddo +! + write(11,'(a5)') m1 + endif +! + if(filab(7)(1:4).eq.'ENER') then +! +! calculating the energy +! + write(11,'(a5)') m1 + write(11,'(a3)') '540' + write(11,'(i1)') one + write(11,'(i5,",",i5,",",i5)') ianatyp,istep,iinc + write(11,'(i10)') netrue +! +! calculating the total energy +! + totenergy=0.d0 + do i=1,ne + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) +! + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + else + nope=6 + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + do k=1,3 + xl(k,j)=co(k,konl(j)) + enddo + enddo +! + if(lakon(i)(4:5).eq.'8R') then + mint3d=1 + elseif((lakon(i)(4:4).eq.'8').or. + & (lakon(i)(4:6).eq.'20R')) then + mint3d=8 + elseif(lakon(i)(4:4).eq.'2') then + mint3d=27 + elseif(lakon(i)(4:5).eq.'10') then + mint3d=4 + elseif(lakon(i)(4:4).eq.'4') then + mint3d=1 + elseif(lakon(i)(4:5).eq.'15') then + mint3d=9 + else + mint3d=2 + endif +! + do jj=1,mint3d + if(lakon(i)(4:5).eq.'8R') then + xi=gauss3d1(1,jj) + et=gauss3d1(2,jj) + ze=gauss3d1(3,jj) + weight=weight3d1(jj) + elseif((lakon(i)(4:4).eq.'8').or. + & (lakon(i)(4:6).eq.'20R')) + & then + xi=gauss3d2(1,jj) + et=gauss3d2(2,jj) + ze=gauss3d2(3,jj) + weight=weight3d2(jj) + elseif(lakon(i)(4:4).eq.'2') then + xi=gauss3d3(1,jj) + et=gauss3d3(2,jj) + ze=gauss3d3(3,jj) + weight=weight3d3(jj) + elseif(lakon(i)(4:5).eq.'10') then + xi=gauss3d5(1,jj) + et=gauss3d5(2,jj) + ze=gauss3d5(3,jj) + weight=weight3d5(jj) + elseif(lakon(i)(4:4).eq.'4') then + xi=gauss3d4(1,jj) + et=gauss3d4(2,jj) + ze=gauss3d4(3,jj) + weight=weight3d4(jj) + elseif(lakon(i)(4:5).eq.'15') then + xi=gauss3d8(1,jj) + et=gauss3d8(2,jj) + ze=gauss3d8(3,jj) + weight=weight3d8(jj) + else + xi=gauss3d7(1,jj) + et=gauss3d7(2,jj) + ze=gauss3d7(3,jj) + weight=weight3d7(jj) + endif +! + if(nope.eq.20) then + if(lakon(i)(7:7).eq.'A') then + call shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) + elseif((lakon(i)(7:7).eq.'E').or. + & (lakon(i)(7:7).eq.'S')) then + call shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) + else + call shape20h(xi,et,ze,xl,xsj,shp,iflag) + endif + elseif(nope.eq.8) then + call shape8h(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.10) then + call shape10tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.4) then + call shape4tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.15) then + call shape15w(xi,et,ze,xl,xsj,shp,iflag) + else + call shape6w(xi,et,ze,xl,xsj,shp,iflag) + endif +! + totenergy=totenergy+weight*ener(jj,i)*xsj + enddo + enddo +! +! calculating the element energy... +! + do i=1,ne + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) +! + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + else + nope=6 + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + do k=1,3 + xl(k,j)=co(k,konl(j)) + enddo + enddo +! + energy=0.d0 + volume=0.d0 +! + if(lakon(i)(4:5).eq.'8R') then + mint3d=1 + elseif((lakon(i)(4:4).eq.'8').or. + & (lakon(i)(4:6).eq.'20R')) then + mint3d=8 + elseif(lakon(i)(4:4).eq.'2') then + mint3d=27 + elseif(lakon(i)(4:5).eq.'10') then + mint3d=4 + elseif(lakon(i)(4:4).eq.'4') then + mint3d=1 + elseif(lakon(i)(4:5).eq.'15') then + mint3d=9 + else + mint3d=2 + endif +! + do jj=1,mint3d + if(lakon(i)(4:5).eq.'8R') then + xi=gauss3d1(1,jj) + et=gauss3d1(2,jj) + ze=gauss3d1(3,jj) + weight=weight3d1(jj) + elseif((lakon(i)(4:4).eq.'8').or. + & (lakon(i)(4:6).eq.'20R')) + & then + xi=gauss3d2(1,jj) + et=gauss3d2(2,jj) + ze=gauss3d2(3,jj) + weight=weight3d2(jj) + elseif(lakon(i)(4:4).eq.'2') then + xi=gauss3d3(1,jj) + et=gauss3d3(2,jj) + ze=gauss3d3(3,jj) + weight=weight3d3(jj) + elseif(lakon(i)(4:5).eq.'10') then + xi=gauss3d5(1,jj) + et=gauss3d5(2,jj) + ze=gauss3d5(3,jj) + weight=weight3d5(jj) + elseif(lakon(i)(4:4).eq.'4') then + xi=gauss3d4(1,jj) + et=gauss3d4(2,jj) + ze=gauss3d4(3,jj) + weight=weight3d4(jj) + elseif(lakon(i)(4:5).eq.'15') then + xi=gauss3d8(1,jj) + et=gauss3d8(2,jj) + ze=gauss3d8(3,jj) + weight=weight3d8(jj) + else + xi=gauss3d7(1,jj) + et=gauss3d7(2,jj) + ze=gauss3d7(3,jj) + weight=weight3d7(jj) + endif +! + if(nope.eq.20) then + if(lakon(i)(7:7).eq.'A') then + call shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) + elseif((lakon(i)(7:7).eq.'E').or. + & (lakon(i)(7:7).eq.'S')) then + call shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) + else + call shape20h(xi,et,ze,xl,xsj,shp,iflag) + endif + elseif(nope.eq.8) then + call shape8h(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.10) then + call shape10tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.4) then + call shape4tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.15) then + call shape15w(xi,et,ze,xl,xsj,shp,iflag) + else + call shape6w(xi,et,ze,xl,xsj,shp,iflag) + endif +! + energy=energy+weight*xsj*ener(jj,i) + volume=volume+weight*xsj + enddo + write(11,102) i,energy,energy/totenergy,energy/volume + enddo + write(11,'(a5)') m1 + endif + 99 format(e12.5,3(",",e12.5)) + 100 format(i10,6(",",e12.5)) + 101 format(i10,",",i5,3(",",e12.5)) + 102 format(i10,3(",",e12.5)) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/opcs.f calculix-ccx-2.3/ccx_2.3/src/opcs.f --- calculix-ccx-2.1/ccx_2.3/src/opcs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/opcs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,65 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +C +C-----MATRIX-VECTOR MULTIPLY FOR REAL SPARSE SYMMETRIC MATRICES--------- +C + SUBROUTINE OPcs(n,p,W,U,ad,asd,icol,irow,nzl) + implicit real*8(a-h,o-z) +! +C----------------------------------------------------------------------- + DOUBLE PRECISION U(*),W(*),Asd(*),AD(*),p(*) + INTEGER IROW(*),ICOL(*),n,nzl +C----------------------------------------------------------------------- +C SPARSE MATRIX-VECTOR MULTIPLY FOR LANCZS U = A*W +C SEE USPEC SUBROUTINE FOR DESCRIPTION OF THE ARRAYS THAT DEFINE +C THE MATRIX +c the vector p is not needed but is kept for compatibility reasons +c with the calling program +C----------------------------------------------------------------------- +C +C COMPUTE THE DIAGONAL TERMS + DO 10 I = 1,N + U(I) = AD(I)*W(I) + 10 CONTINUE +C +C COMPUTE BY COLUMN + LLAST = 0 + DO 30 J = 1,NZL +C + IF (ICOL(J).EQ.0) GO TO 30 + LFIRST = LLAST + 1 + LLAST = LLAST + ICOL(J) +C + DO 20 L = LFIRST,LLAST + I = IROW(L) + if(i>n) cycle +C + U(I) = U(I) + Asd(L)*W(J) + U(J) = U(J) + Asd(L)*W(I) +C + 20 CONTINUE +C + 30 CONTINUE +C + RETURN + END + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/openfile.f calculix-ccx-2.3/ccx_2.3/src/openfile.f --- calculix-ccx-2.1/ccx_2.3/src/openfile.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/openfile.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,107 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine openfile(jobname,output) +! + implicit none +! + logical exi + character*3 output + character*132 jobname,fnin,fndat,fnfrd,fnsta,fnonf + integer i +! +! opening the input and output file +! + do i=1,132 + if(jobname(i:i).eq.' ') exit + enddo + i=i-1 + if(i.gt.128) then + write(*,*) '*ERROR in openfile: input file name is too long:' + write(*,'(a132)') jobname(1:132) + write(*,*) ' exceeds 128 characters' + stop + endif +! + fnin=jobname(1:i)//'.inp' + inquire(file=fnin(1:i+4),exist=exi) + if(exi) then + open(1,file=fnin(1:i+4),status='old',err=1) + else + write(*,*) '*ERROR in openfile: input file ',fnin + write(*,*) 'does not exist' + stop + endif +! + fndat=jobname(1:i)//'.dat' + open(5,file=fndat(1:i+4),status='unknown',err=51) + close(5,status='delete',err=52) + open(5,file=fndat(1:i+4),status='unknown',err=51) +c rewind(5) +! + if(output.ne.'onf') then + fnfrd=jobname(1:i)//'.frd' + open(7,file=fnfrd(1:i+4),status='unknown',err=71) + close(7,status='delete',err=72) + open(7,file=fnfrd(1:i+4),status='unknown',err=71) +c rewind(7) + endif +! + fnsta=jobname(1:i)//'.sta' + open(8,file=fnsta(1:i+4),status='unknown',err=81) + close(8,status='delete',err=82) + open(8,file=fnsta(1:i+4),status='unknown',err=81) +c rewind(8) + write(8,100) + write(8,101) + 100 format('SUMMARY OF JOB INFORMATION') + 101 format(' STEP INC ATT ITRS TOT TIME STEP TIME + & INC TIME') +! + if(output.eq.'onf') then + fnonf=jobname(1:i)//'.onf' + open(11,file=fnonf(1:i+4),status='unknown',err=111) + close(11,status='delete',err=112) + open(11,file=fnonf(1:i+4),status='new',err=111) + endif +! + return +! + 1 write(*,*) '*ERROR in openfile: could not open file ',fnin(1:i+4) + stop + 51 write(*,*) '*ERROR in openfile: could not open file ',fndat(1:i+4) + stop + 52 write(*,*) '*ERROR in openfile: could not delete file ', + & fndat(1:i+4) + stop + 71 write(*,*) '*ERROR in openfile: could not open file ',fnfrd(1:i+4) + stop + 72 write(*,*) '*ERROR in openfile: could not delete file ', + & fnfrd(1:i+4) + stop + 81 write(*,*) '*ERROR in openfile: could not open file ',fnsta(1:i+4) + stop + 82 write(*,*) '*ERROR in openfile: could not delete file ', + & fnsta(1:i+4) + stop + 111 write(*,*) '*ERROR in openfile: could not open file ',fnonf(1:i+4) + stop + 112 write(*,*) '*ERROR in openfile: could not delete file ', + & fnonf(1:i+4) + stop + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/op.f calculix-ccx-2.3/ccx_2.3/src/op.f --- calculix-ccx-2.1/ccx_2.3/src/op.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/op.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,64 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +C +C-----MATRIX-VECTOR MULTIPLY FOR REAL SPARSE SYMMETRIC MATRICES--------- +C + SUBROUTINE OP(n,p,W,U,ad,asd,icol,irow,nzl) + implicit real*8(a-h,o-z) +! +C----------------------------------------------------------------------- + DOUBLE PRECISION U(*),W(*),Asd(*),AD(*),p(*) + INTEGER IROW(*),ICOL(*),n,nzl +C----------------------------------------------------------------------- +C SPARSE MATRIX-VECTOR MULTIPLY FOR LANCZS U = A*W +C SEE USPEC SUBROUTINE FOR DESCRIPTION OF THE ARRAYS THAT DEFINE +C THE MATRIX +c the vector p is not needed but is kept for compatibility reasons +c with the calling program +C----------------------------------------------------------------------- +C +C COMPUTE THE DIAGONAL TERMS + DO 10 I = 1,N + U(I) = AD(I)*W(I) + 10 CONTINUE +C +C COMPUTE BY COLUMN + LLAST = 0 + DO 30 J = 1,NZL +C + IF (ICOL(J).EQ.0) GO TO 30 + LFIRST = LLAST + 1 + LLAST = LLAST + ICOL(J) +C + DO 20 L = LFIRST,LLAST + I = IROW(L) +C + U(I) = U(I) + Asd(L)*W(J) + U(J) = U(J) + Asd(L)*W(I) +C + 20 CONTINUE +C + 30 CONTINUE +C + RETURN + END + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/opnonsym.f calculix-ccx-2.3/ccx_2.3/src/opnonsym.f --- calculix-ccx-2.1/ccx_2.3/src/opnonsym.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/opnonsym.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,59 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +C +C-----MATRIX-VECTOR MULTIPLY FOR REAL SPARSE NONSYMMETRIC MATRICES--------- +C + SUBROUTINE OPNONSYM(n,p,W,U,ad,asd,jq,irow) + implicit real*8(a-h,o-z) +! +C----------------------------------------------------------------------- + DOUBLE PRECISION U(*),W(*),Asd(*),AD(*),p(*) + INTEGER IROW(*),JQ(*),n +C----------------------------------------------------------------------- +C SPARSE MATRIX-VECTOR MULTIPLY FOR LANCZS U = A*W +C SEE USPEC SUBROUTINE FOR DESCRIPTION OF THE ARRAYS THAT DEFINE +C THE MATRIX +c the vector p is not needed but is kept for compatibility reasons +c with the calling program +C----------------------------------------------------------------------- +C +C COMPUTE THE DIAGONAL TERMS + DO 10 I = 1,N + U(I) = AD(I)*W(I) + 10 CONTINUE +C +C COMPUTE BY COLUMN + LLAST = 0 + DO 30 J = 1,N +C + DO 20 L = JQ(J),JQ(J+1)-1 + I = IROW(L) +C + U(I) = U(I) + Asd(L)*W(J) +C + 20 CONTINUE +C + 30 CONTINUE +C + RETURN + END + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/opnonsymt.f calculix-ccx-2.3/ccx_2.3/src/opnonsymt.f --- calculix-ccx-2.1/ccx_2.3/src/opnonsymt.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/opnonsymt.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,59 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +C +C-----MATRIX-VECTOR MULTIPLY FOR REAL SPARSE NONSYMMETRIC MATRICES--------- +C + SUBROUTINE OPNONSYMt(n,p,W,U,ad,asd,jq,irow) + implicit real*8(a-h,o-z) +! +C----------------------------------------------------------------------- + DOUBLE PRECISION U(*),W(*),Asd(*),AD(*),p(*) + INTEGER IROW(*),JQ(*),n +C----------------------------------------------------------------------- +C SPARSE MATRIX-VECTOR MULTIPLY FOR LANCZS U = A*W +C SEE USPEC SUBROUTINE FOR DESCRIPTION OF THE ARRAYS THAT DEFINE +C THE MATRIX +c the vector p is not needed but is kept for compatibility reasons +c with the calling program +C----------------------------------------------------------------------- +C +C COMPUTE THE DIAGONAL TERMS + DO 10 I = 1,N + U(I) = AD(I)*W(I)+U(I) + 10 CONTINUE +C +C COMPUTE BY COLUMN + LLAST = 0 + DO 30 J = 1,N +C + DO 20 L = JQ(J),JQ(J+1)-1 + I = IROW(L) +C + U(j) = U(j) + Asd(L)*W(i) +C + 20 CONTINUE +C + 30 CONTINUE +C + RETURN + END + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/orientations.f calculix-ccx-2.3/ccx_2.3/src/orientations.f --- calculix-ccx-2.1/ccx_2.3/src/orientations.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/orientations.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,93 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine orientations(inpc,textpart,orname,orab,norien, + & norien_,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *ORIENTATION +! + implicit none +! + character*1 inpc(*) + character*80 orname(*) + character*132 textpart(16) +! + integer norien,norien_,istep,istat,n,key,i,iline,ipol,inl, + & ipoinp(2,*),inp(3,*),ipoinpc(0:*) +! + real*8 orab(7,*) +! + if(istep.gt.0) then + write(*,*) '*ERROR in orientations: *ORIENTATION should be' + write(*,*) ' placed before all step definitions' + stop + endif +! + norien=norien+1 + if(norien.gt.norien_) then + write(*,*) '*ERROR in orientations: increase norien_' + stop + endif +! +! rectangular coordinate system: orab(7,norien)=1 +! cylindrical coordinate system: orab(7,norien)=-1 +! default is rectangular +! + orab(7,norien)=1.d0 +! + do i=2,n + if(textpart(i)(1:5).eq.'NAME=') then + orname(norien)=textpart(i)(6:85) + if(textpart(i)(86:86).ne.' ') then + write(*,*) '*ERROR in orientations: name too long' + write(*,*) ' (more than 80 characters)' + write(*,*) ' orientation name:',textpart(i)(1:132) + stop + endif + elseif(textpart(i)(1:7).eq.'SYSTEM=') then + if(textpart(i)(8:8).eq.'C') then + orab(7,norien)=-1.d0 + endif + else + write(*,*) + & '*WARNING in orientations: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*)'*ERROR in orientations: definition of the following' + write(*,*) ' orientation is not complete: ',orname(norien) + stop + endif +! + do i=1,6 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) orab(i,norien) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/orifice.f calculix-ccx-2.3/ccx_2.3/src/orifice.f --- calculix-ccx-2.1/ccx_2.3/src/orifice.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/orifice.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,727 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine orifice(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,R,physcon,dvi,numf,set,co,vold,mi) +! +! orifice element +! + implicit none +! + logical identity + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(4),idirf(4),index,iflag, + & inv,ipkon(*),kon(*),number,kgas,nelemref, + & nodea,nodeb,iaxial,mi(2),i,itype +! + real*4 ofvidg +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R,a,d,xl, + & p1,p2,T1,Aeff,C1,C2,C3,cd,cp,physcon(3),p2p1,km1,dvi, + & kp1,kdkm1,tdkp1,km1dk,x,y,ca1,cb1,ca2,cb2,dT1,alambda, + & rad,beta,reynolds,theta,k_phi,c2u_new,u,pi,xflow_oil, + & ps1pt1,uref,cd_chamf,angle,vid,cdcrit,T2,radius, + & initial_radius,co(3,*),vold(0:mi(2),*),offset, + & x_tab(15), y_tab(15),x_tab2(15),y_tab2(15),curve +! +! + external ofvidg +! + pi=4.d0*datan(1.d0) + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1)then +! + index=ielprop(nelem) + kappa=(cp/(cp-R)) + a=prop(index+1) + d=prop(index+2) + xl=prop(index+3) +! + if(lakon(nelem)(2:5).eq.'ORFL') then + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + iaxial=int(prop(index+3)) + offset=prop(index+4) + radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2)-offset + initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2)-offset + if(iaxial.ne.0) then + A=pi*radius**2/iaxial + else + A=pi*radius**2 + endif + d=2*radius + endif +! + p1=v(2,node1) + p2=v(2,node2) + if(p1.ge.p2) then + inv=1 + T1=v(0,node1)+physcon(1) + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + T1=v(0,node2)+physcon(1) + endif +! + cd=1.d0 +! + p2p1=p2/p1 + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + tdkp1=2.d0/kp1 + C2=tdkp1**kdkm1 + Aeff=A*cd + if(p2p1.gt.C2) then + xflow=inv*p1*Aeff*dsqrt(2.d0*kdkm1*p2p1**(2.d0/kappa) + & *(1.d0-p2p1**(1.d0/kdkm1))/r)/dsqrt(T1) + else + xflow=inv*p1*Aeff*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ + & dsqrt(T1) + endif +! + elseif (iflag.eq.2)then +! + numf=4 + alambda=10000.d0 + index=ielprop(nelem) + kappa=(cp/(cp-R)) + a=prop(index+1) +! + p1=v(2,node1) + p2=v(2,node2) + if(p1.ge.p2) then + inv=1 + xflow=v(1,nodem) + T1=v(0,node1)+physcon(1) + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + xflow=-v(1,nodem) + T1=v(0,node2)+physcon(1) + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 +! +! calculation of the dynamic viscosity +! +! + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif +! + if ((lakon(nelem)(4:5).ne.'BT').and. + & (lakon(nelem)(4:5).ne.'PN').and. + & (lakon(nelem)(4:5).ne.'C1').and. + & (lakon(nelem)(4:5).ne.'FL') ) then + d=prop(index+2) + xl=prop(index+3) + u=prop(index+7) + nelemref=int(prop(index+8)) + if (nelemref.eq.0) then + uref=0.d0 + else +! swirl generating element +! +! preswirl nozzle + if(lakon(nelemref)(2:5).eq.'ORPN') then + uref=prop(ielprop(nelemref)+5) +! +! forced vortex + elseif(lakon(nelemref)(2:5).eq.'VOFO') then + uref=prop(ielprop(nelemref)+7) +! +! free vortex + elseif(lakon(nelemref)(2:5).eq.'VOFR') then + uref=prop(ielprop(nelemref)+9) +! + else + write(*,*) '*ERROR in orifice:' + write(*,*) ' element',nelemref + write(*,*) 'refered by element',nelem + write(*,*) 'is not a preswirl nozzle' + endif + endif + u=u-uref + angle=prop(index+5) +! + endif +! +! calculate the discharge coefficient using Bragg's Method +! "Effect of Compressibility on the discharge coefficient +! of orifices and convergent nozzles" +! journal of mechanical Engineering +! vol2 No 1 1960 +! + if((lakon(nelem)(2:5).eq.'ORBG')) then +! + p2p1=p2/p1 + cdcrit=prop(index+2) +! + itype=2 + call cd_bragg(cdcrit,p2p1,cd,itype) +! + elseif (lakon(nelem)(2:5).eq.'ORMA') then +! +! calculate the discharge coefficient using own table data and +! using Dr.Albers method for rotating cavities +! + call cd_own_albers(p1,p2,xl,d,cd,u,T1,R,kappa) +! +! chamfer correction +! + if(angle.gt.0.d0)then + call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) + cd=cd*cd_chamf + endif +! + elseif (lakon(nelem)(2:5).eq.'ORMM') then +! +! calculate the discharge coefficient using McGreehan and Schotsch method +! + rad=prop(index+4) +! + reynolds=dabs(xflow)*d/(dvi*a) +! + call cd_ms_ms(p1,p2,T1,rad,d,xl,kappa,r,reynolds,u,vid,cd) +! + if (cd.ge.1) then + write(*,*) '' + write(*,*) '**WARNING**' + write(*,*) 'in RESTRICTOR ',nelem + write(*,*) 'Calculation using' + write(*,*) ' McGreehan and Schotsch method:' + write(*,*) ' Cd=',Cd,'>1 !' + write(*,*) 'Calcultion will proceed will Cd=1' + write(*,*) 'l/d=',xl/d,'r/d=',rad/d,'u/vid=',u/vid + cd=1.d0 + endif +! +! chamfer correction +! + if(angle.gt.0.d0) then + call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) + cd=cd*cd_chamf + endif +! + elseif (lakon(nelem)(2:5).eq.'ORPA') then +! +! calculate the discharge coefficient using Parker and Kercher method +! and using Dr. Albers method for rotating cavities +! + rad=prop(index+4) +! + beta=prop(index+6) +! + reynolds=dabs(xflow)*d/(dvi*a) +! + call cd_pk_albers(rad,d,xl,reynolds,p2,p1,beta,kappa, + & cd,u,T1,R) +! +! chamfer correction +! + if(angle.gt.0.d0) then + call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) + cd=cd*cd_chamf + endif +! + elseif (lakon(nelem)(2:5).eq.'ORPM') then +! +! calculate the discharge coefficient using Parker and Kercher method +! and using Mac Grehan and Schotsch method for rotating cavities +! + rad=prop(index+4) +! + beta=prop(index+6) + reynolds=dabs(xflow)*d/(dvi*a) +! + call cd_pk_ms(rad,d,xl,reynolds,p2,p1,beta,kappa,cd, + & u,T1,R) +! +! chamfer correction +! + if(angle.gt.0.d0) then + call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) + cd=cd*cd_chamf + endif +! + elseif (lakon(nelem)(2:5).eq.'ORC1') then +! + d=dsqrt(a*4/Pi) + reynolds=dabs(xflow)*d/(dvi*a) + cd=1.d0 +! + elseif (lakon(nelem)(2:5).eq.'ORBT') then +! +! calculate the discharge coefficient of bleed tappings (OWN tables) +! + ps1pt1=prop(index+2) + curve=int(prop(index+3)) + number=int(prop(index+4)) +! + if(number.ne.0.d0)then + do i=1,number + x_tab(i)=prop(index+2*i+3) + y_tab(i)=prop(index+2*i+4) + enddo + endif +! + call cd_bleedtapping(p2,p1,ps1pt1,number,curve,x_tab,y_tab, + & cd) +! + elseif (lakon(nelem)(2:5).eq.'ORPN') then +! +! calculate the discharge coefficient of preswirl nozzle (OWN tables) +! + d=dsqrt(4*A/pi) + reynolds=dabs(xflow)*d/(dvi*a) + curve=int(prop(index+4)) + number=int(prop(index+6)) + if(number.ne.0.d0)then + do i=1,number + x_tab2(i)=prop(index+2*i+5) + y_tab2(i)=prop(index+2*i+6) + enddo + endif + call cd_preswirlnozzle(p2,p1,number,curve,x_tab2,y_tab2 + & ,cd) +! + theta=prop(index+2) + k_phi=prop(index+3) +! + if(p2/p1.gt.(2/(kappa+1.d0))**(kappa/(kappa-1.d0))) then + c2u_new=k_phi*cd*sin(theta*Pi/180.d0)*r* + & dsqrt(2.d0*kappa/(r*(kappa-1)))* + & dsqrt(T1*(1.d0-(p2/p1)**((kappa-1)/kappa))) +! + else + c2u_new=k_phi*cd*sin(theta*Pi/180.d0)*r* + & dsqrt(2.d0*kappa/(r*(kappa-1)))* + & dsqrt(T1*(1.d0-2/(kappa+1))) + endif + prop(index+5)=c2u_new +! + elseif(lakon(nelem)(2:5).eq.'ORFL') then + nodea=int(prop(index+1)) + nodeb=int(prop(index+2)) + iaxial=int(prop(index+3)) + offset=prop(index+4) + radius=dsqrt((co(1,nodeb)+vold(1,nodeb)- + & co(1,nodea)-vold(1,nodea))**2)-offset +! + initial_radius=dsqrt((co(1,nodeb)-co(1,nodea))**2)-offset +! + if(iaxial.ne.0) then + A=pi*radius**2/iaxial + else + A=pi*radius**2 + endif + d=2*radius + reynolds=dabs(xflow)*d/(dvi*a) + cd=1.d0 +! + endif +! + if (cd.gt.1.d0) then + Write(*,*) '*WARNING:' + Write(*,*) 'In RESTRICTOR',nelem + write(*,*) 'Cd greater than 1' + write (*,*) 'Calculation will proceed using Cd=1' + cd=1.d0 + endif +! + p2p1=p2/p1 + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + tdkp1=2.d0/kp1 + C2=tdkp1**kdkm1 + Aeff=A*cd + dT1=dsqrt(T1) +! + if(p2p1.gt.C2) then + C1=dsqrt(2.d0*kdkm1/r)*Aeff + km1dk=1.d0/kdkm1 + y=p2p1**km1dk + x=dsqrt(1.d0-y) + ca1=-C1*x/(kappa*p1*y) + cb1=C1*km1dk/(2.d0*p1) + ca2=-ca1*p2p1-xflow*dT1/(p1*p1) + cb2=-cb1*p2p1 + f=xflow*dT1/p1-C1*p2p1**(1.d0/kappa)*x + if(cb2.le.-(alambda+ca2)*x) then + df(1)=-alambda + elseif(cb2.ge.(alambda-ca2)*x) then + df(1)=alambda + else + df(1)=ca2+cb2/x + endif + df(2)=xflow/(2.d0*p1*dT1) + df(3)=inv*dT1/p1 + if(cb1.le.-(alambda+ca1)*x) then + df(4)=-alambda + elseif(cb1.ge.(alambda-ca1)*x) then + df(4)=alambda + else + df(4)=ca1+cb1/x + endif + else + C3=dsqrt(kappa/r)*(tdkp1)**(kp1/(2.d0*km1))*Aeff + f=xflow*dT1/p1-C3 + df(1)=-xflow*dT1/(p1)**2 + df(2)=xflow/(2*p1*dT1) + df(3)=inv*dT1/p1 + df(4)=0.d0 + endif +! +! output +! + elseif (iflag.eq.3) then +! + pi=4.d0*datan(1.d0) + p1=v(2,node1) + p2=v(2,node2) + if(p1.ge.p2) then + inv=1 + xflow=v(1,nodem) + T1=v(0,node1)+physcon(1) + T2=v(0,node2)+physcon(1) + else + inv=-1 + p1=v(2,node2) + p2=v(2,node1) + xflow=-v(1,nodem) + T1=v(0,node2)+physcon(1) + T2=v(0,node1)+physcon(1) + endif +! +! calculation of the dynamic viscosity +! + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif +! + index=ielprop(nelem) + kappa=(cp/(cp-R)) + a=prop(index+1) +! + if ((lakon(nelem)(4:5).ne.'BT').and. + & (lakon(nelem)(4:5).ne.'PN').and. + & (lakon(nelem)(4:5).ne.'C1')) then + d=prop(index+2) + xl=prop(index+3) + u=prop(index+7) + nelemref=int(prop(index+8)) + if (nelemref.eq.0) then + uref=0.d0 + else +! swirl generating element +! +! preswirl nozzle + if(lakon(nelemref)(2:5).eq.'ORPN') then + uref=prop(ielprop(nelemref)+5) +! +! forced vortex + elseif(lakon(nelemref)(2:5).eq.'VOFO') then + uref=prop(ielprop(nelemref)+7) +! +! free vortex + elseif(lakon(nelemref)(2:5).eq.'VOFR') then + uref=prop(ielprop(nelemref)+9) + else + write(*,*) '*ERROR in orifice:' + write(*,*) ' element',nelemref + write(*,*) 'refered by element',nelem + write(*,*) 'is not a preswirl nozzle' + endif + endif + u=u-uref + angle=prop(index+5) +! + endif +! +! calculate the discharge coefficient using Bragg's Method +! "Effect of Compressibility on the discharge coefficient +! of orifices and convergent nozzles" +! journal of mechanical Engineering +! vol2 No 1 1960 +! + if((lakon(nelem)(2:5).eq.'ORBG')) then +! + p2p1=p2/p1 + d=dsqrt(a*4/Pi) + reynolds=dabs(xflow)*d/(dvi*a) + cdcrit=prop(index+2) +! + itype=2 + call cd_bragg(cdcrit,p2p1,cd,itype) +! + elseif (lakon(nelem)(2:5).eq.'ORMA') then +! +! calculate the discharge coefficient using own table data and +! using Dr.Albers method for rotating cavities +! + reynolds=dabs(xflow)*d/(dvi*a) +! + call cd_own_albers(p1,p2,xl,d,cd,u,T1,R,kappa) +! +! chamfer correction +! + if(angle.gt.0.d0)then + call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) + cd=cd*cd_chamf + endif +! + elseif (lakon(nelem)(2:5).eq.'ORMM') then +! +! calculate the discharge coefficient using McGreehan and Schotsch method +! + rad=prop(index+4) +! + reynolds=dabs(xflow)*d/(dvi*a) +! + call cd_ms_ms(p1,p2,T1,rad,d,xl,kappa,r,reynolds,u,vid,cd) +! + if (cd.ge.1) then + write(*,*) '' + write(*,*) '**WARNING**' + write(*,*) 'in RESTRICTOR ',nelem + write(*,*) 'Calculation using' + write(*,*) ' McGreehan and Schotsch method:' + write(*,*) ' Cd=',Cd,'>1 !' + write(*,*) 'Calcultion will proceed will Cd=1' + write(*,*) 'l/d=',xl/d,'r/d=',rad/d,'u/vid=',u/vid + cd=1.d0 + endif +! +! chamfer correction +! + if(angle.gt.0.d0) then + call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) + cd=cd*cd_chamf + endif +! + elseif (lakon(nelem)(2:5).eq.'ORPA') then +! +! calculate the discharge coefficient using Parker and Kercher method +! and using Dr. Albers method for rotating cavities +! + rad=prop(index+4) +! + beta=prop(index+6) +! + reynolds=dabs(xflow)*d/(dvi*a) +! + call cd_pk_albers(rad,d,xl,reynolds,p2,p1,beta,kappa, + & cd,u,T1,R) +! +! chamfer correction +! + if(angle.gt.0.d0) then + call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) + cd=cd*cd_chamf + endif +! + elseif (lakon(nelem)(2:5).eq.'ORPM') then +! +! calculate the discharge coefficient using Parker and Kercher method +! and using Mac Grehan and Schotsch method for rotating cavities +! + rad=prop(index+4) +! + beta=prop(index+6) + reynolds=dabs(xflow)*d/(dvi*a) +! + call cd_pk_ms(rad,d,xl,reynolds,p2,p1,beta,kappa,cd, + & u,T1,R) +! +! chamfer correction +! + if(angle.gt.0.d0) then + call cd_chamfer(xl,d,p1,p2,angle,cd_chamf) + cd=cd*cd_chamf + endif +! + elseif (lakon(nelem)(2:5).eq.'ORC1') then +! + d=dsqrt(a*4/Pi) + reynolds=dabs(xflow)*d/(dvi*a) + cd=1.d0 +! + elseif (lakon(nelem)(2:5).eq.'ORBT') then +! +! calculate the discharge coefficient of bleed tappings (OWN tables) +! + d=dsqrt(A*Pi/4) + reynolds=dabs(xflow)*d/(dvi*a) + ps1pt1=prop(index+2) + curve=int(prop(index+3)) + number=int(prop(index+4)) + reynolds=dabs(xflow)*d/(dvi*a) + if(number.ne.0.d0)then + do i=1,number + x_tab(i)=prop(index+2*i+3) + y_tab(i)=prop(index+2*i+4) + enddo + endif +! + call cd_bleedtapping(p2,p1,ps1pt1,number,curve,x_tab,y_tab, + & cd) +! + elseif (lakon(nelem)(2:5).eq.'ORPN') then +! +! calculate the discharge coefficient of preswirl nozzle (OWN tables) +! + d=dsqrt(4*A/pi) + reynolds=dabs(xflow)*d/(dvi*a) + curve=int(prop(index+4)) + number=int(prop(index+6)) +! + if(number.ne.0.d0)then + do i=1,number + x_tab2(i)=prop(index+2*i+5) + y_tab2(i)=prop(index+2*i+6) + enddo + endif +! + call cd_preswirlnozzle(p2,p1,number,curve,x_tab2,y_tab2,cd) +! + theta=prop(index+2) + k_phi=prop(index+3) +! + if(p2/p1.gt.(2/(kappa+1.d0))**(kappa/(kappa-1.d0))) then + c2u_new=k_phi*cd*sin(theta*Pi/180.d0)*r* + & dsqrt(2.d0*kappa/(r*(kappa-1)))* + & dsqrt(T1*(1.d0-(p2/p1)**((kappa-1)/kappa))) +! + else + c2u_new=k_phi*cd*sin(theta*Pi/180.d0)*r* + & dsqrt(2.d0*kappa/(r*(kappa-1)))* + & dsqrt(T1*(1.d0-2/(kappa+1))) + endif + prop(index+5)=c2u_new + endif +! + if (cd.gt.1.d0) then + Write(*,*) '*WARNING:' + Write(*,*) 'In RESTRICTOR',nelem + write(*,*) 'Cd greater than 1' + write(*,*) 'Calculation will proceed using Cd=1' + cd=1.d0 + endif + xflow_oil=0 +! + write(1,*) '' + write(1,55) 'In line',int(nodem/1000),' from node',node1, + & ' to node', node2,': air massflow rate=',inv*xflow,'kg/s', + & ', oil massflow rate=',xflow_oil,'kg/s' + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) + + if(inv.eq.1) then + write(1,56)' Inlet node ',node1,': Tt1=',T1, + & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' + + write(1,*)' element R ',set(numf)(1:20) + write(1,57)' Eta= ',dvi,' kg/(m*s), Re=' + & ,reynolds + if(lakon(nelem)(2:5).ne.'ORMA') then + write(1,58)' CD= ',cd + elseif(lakon(nelem)(2:5).eq.'ORMA') then + write(1,59)' CD= ',cd,' C1u= ',uref,'m/s' + endif + + +! special for bleed tappings + if(lakon(nelem)(2:5).eq.'ORBT') then + write(1,60) ' DAB=',(1-P2/P1)/(1-ps1pt1), + & ' ,curve N°',curve +! special for preswirlnozzles + elseif(lakon(nelem)(2:5).eq.'ORPN') then + write(1,61)' C2u= ',c2u_new,'m/s' +! special for recievers + + endif + + write(1,56)' Outlet node ',node2,': Tt2=',T2, + & 'K, Ts2=',T2,'K, Pt2=',P2/1e5,'Bar' +! + else if(inv.eq.-1) then + write(1,56)' Inlet node ',node2,': Tt1=',T1, + & 'K, Ts1=',T1,'K, Pt1=',P1/1E5, 'Bar' + & + write(1,*)' element R ',set(numf)(1:20) + write(1,57)' eta= ',dvi,'kg/(m*s), Re=' + & ,reynolds,', CD=',cd + +! special for bleed tappings + if(lakon(nelem)(2:5).eq.'ORBT') then + write(1,60) ' DAB ',(1-P2/P1)/(1-ps1pt1),' + & , curve N°', curve +! special for preswirlnozzles + elseif(lakon(nelem)(2:5).eq.'ORPN') then + write(1,*) 'u= ',u,'m/s, C2u= ',c2u_new,'m/s' + endif + + write(1,56)' Outlet node ',node1,': Tt2=',T2, + & 'K, Ts2=',T2,'K, Pt2=',P2/1e5, 'Bar' + + endif +! + 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A) + 57 FORMAT(1X,A,G9.4,A,G11.4) + 58 FORMAT(1X,A,f12.5) + 59 FORMAT(1X,A,f12.5,A,f12.5,A) + 60 FORMAT(1X,A,f12.5,A,I2,A) + 61 FORMAT(1X,A,f12.3,A) + + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/orthonl.f calculix-ccx-2.3/ccx_2.3/src/orthonl.f --- calculix-ccx-2.1/ccx_2.3/src/orthonl.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/orthonl.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,361 @@ + subroutine orthonl(w,vo,elas,s,ii1,jj1,weight) +! +! This routine replaces the following lines in e_c3d.f for +! an orthotropic material +! +! do i1=1,3 +! iii1=ii1+i1-1 +! do j1=1,3 +! jjj1=jj1+j1-1 +! do k1=1,3 +! do l1=1,3 +! s(iii1,jjj1)=s(iii1,jjj1) +! & +anisox(i1,k1,j1,l1)*w(k1,l1) +! do m1=1,3 +! s(iii1,jjj1)=s(iii1,jjj1) +! & +anisox(i1,k1,m1,l1)*w(k1,l1) +! & *vo(j1,m1) +! & +anisox(m1,k1,j1,l1)*w(k1,l1) +! & *vo(i1,m1) +! do n1=1,3 +! s(iii1,jjj1)=s(iii1,jjj1) +! & +anisox(m1,k1,n1,l1) +! & *w(k1,l1)*vo(i1,m1)*vo(j1,n1) +! enddo +! enddo +! enddo +! enddo +! enddo +! enddo +! + integer ii1,jj1 + real*8 w(3,3),vo(3,3),elas(21),s(60,60),weight +! + s(ii1,jj1)=s(ii1,jj1)+((elas( 1)+elas( 1)*vo(1,1) + &+(elas( 1)+elas( 1)*vo(1,1) + &)*vo(1,1)+(elas( 7)*vo(1,2))*vo(1,2) + &+(elas( 8)*vo(1,3)) + &*vo(1,3))*w(1,1) + &+(elas( 2)*vo(1,2)+(elas( 2)*vo(1,2))*vo(1,1)+(elas( 7) + &+elas( 7)*vo(1,1))*vo(1,2) + &)*w(1,2) + &+(elas( 4)*vo(1,3)+(elas( 4)*vo(1,3))*vo(1,1) + &+(elas( 8)+elas( 8)*vo(1,1)) + &*vo(1,3))*w(1,3) + &+(elas( 7)*vo(1,2)+(elas( 7)*vo(1,2))*vo(1,1)+(elas( 2) + &+elas( 2)*vo(1,1))*vo(1,2) + &)*w(2,1) + &+(elas( 7)+elas( 7)*vo(1,1) + &+(elas( 7)+elas( 7)*vo(1,1) + &)*vo(1,1)+(elas( 3)*vo(1,2))*vo(1,2) + &+(elas( 9)*vo(1,3)) + &*vo(1,3))*w(2,2) + &+((elas( 5)*vo(1,3))*vo(1,2) + &+(elas( 9)*vo(1,2)) + &*vo(1,3))*w(2,3) + &+(elas( 8)*vo(1,3)+(elas( 8)*vo(1,3))*vo(1,1) + &+(elas( 4)+elas( 4)*vo(1,1)) + &*vo(1,3))*w(3,1) + &+((elas( 9)*vo(1,3))*vo(1,2) + &+(elas( 5)*vo(1,2)) + &*vo(1,3))*w(3,2) + &+(elas( 8)+elas( 8)*vo(1,1) + &+(elas( 8)+elas( 8)*vo(1,1) + &)*vo(1,1)+(elas( 9)*vo(1,2))*vo(1,2) + &+(elas( 6)*vo(1,3)) + &*vo(1,3))*w(3,3))*weight + s(ii1,jj1+1)=s(ii1,jj1+1)+((elas( 1)*vo(2,1) + &+(elas( 1)*vo(2,1) + &)*vo(1,1)+(elas( 7) + &+elas( 7)*vo(2,2))*vo(1,2) + &+(elas( 8)*vo(2,3)) + &*vo(1,3))*w(1,1) + &+(elas( 2) + &+elas( 2)*vo(2,2)+(elas( 2) + &+elas( 2)*vo(2,2))*vo(1,1)+(elas( 7)*vo(2,1))*vo(1,2) + &)*w(1,2) + &+(elas( 4)*vo(2,3)+(elas( 4)*vo(2,3))*vo(1,1) + &+(elas( 8)*vo(2,1)) + &*vo(1,3))*w(1,3) + &+(elas( 7) + &+elas( 7)*vo(2,2)+(elas( 7) + &+elas( 7)*vo(2,2))*vo(1,1)+(elas( 2)*vo(2,1))*vo(1,2) + &)*w(2,1) + &+(elas( 7)*vo(2,1) + &+(elas( 7)*vo(2,1) + &)*vo(1,1)+(elas( 3) + &+elas( 3)*vo(2,2))*vo(1,2) + &+(elas( 9)*vo(2,3)) + &*vo(1,3))*w(2,2) + &+((elas( 5)*vo(2,3))*vo(1,2) + &+(elas( 9)+elas( 9)*vo(2,2)) + &*vo(1,3))*w(2,3) + &+(elas( 8)*vo(2,3)+(elas( 8)*vo(2,3))*vo(1,1) + &+(elas( 4)*vo(2,1)) + &*vo(1,3))*w(3,1) + &+((elas( 9)*vo(2,3))*vo(1,2) + &+(elas( 5)+elas( 5)*vo(2,2)) + &*vo(1,3))*w(3,2) + &+(elas( 8)*vo(2,1) + &+(elas( 8)*vo(2,1) + &)*vo(1,1)+(elas( 9) + &+elas( 9)*vo(2,2))*vo(1,2) + &+(elas( 6)*vo(2,3)) + &*vo(1,3))*w(3,3))*weight + s(ii1,jj1+2)=s(ii1,jj1+2)+((elas( 1)*vo(3,1) + &+(elas( 1)*vo(3,1) + &)*vo(1,1)+(elas( 7)*vo(3,2))*vo(1,2) + &+(elas( 8)+elas( 8)*vo(3,3)) + &*vo(1,3))*w(1,1) + &+(elas( 2)*vo(3,2) + &+(elas( 2)*vo(3,2))*vo(1,1)+(elas( 7)*vo(3,1))*vo(1,2) + &)*w(1,2) + &+(elas( 4) + &+elas( 4)*vo(3,3)+(elas( 4) + &+elas( 4)*vo(3,3))*vo(1,1) + &+(elas( 8)*vo(3,1)) + &*vo(1,3))*w(1,3) + &+(elas( 7)*vo(3,2)+(elas( 7)*vo(3,2))*vo(1,1) + &+(elas( 2)*vo(3,1))*vo(1,2) + &)*w(2,1) + &+(elas( 7)*vo(3,1) + &+(elas( 7)*vo(3,1) + &)*vo(1,1)+(elas( 3)*vo(3,2))*vo(1,2) + &+(elas( 9)+elas( 9)*vo(3,3)) + &*vo(1,3))*w(2,2) + &+((elas( 5) + &+elas( 5)*vo(3,3))*vo(1,2) + &+(elas( 9)*vo(3,2)) + &*vo(1,3))*w(2,3) + &+(elas( 8) + &+elas( 8)*vo(3,3)+(elas( 8) + &+elas( 8)*vo(3,3))*vo(1,1) + &+(elas( 4)*vo(3,1)) + &*vo(1,3))*w(3,1) + &+((elas( 9) + &+elas( 9)*vo(3,3))*vo(1,2) + &+(elas( 5)*vo(3,2)) + &*vo(1,3))*w(3,2) + &+(elas( 8)*vo(3,1) + &+(elas( 8)*vo(3,1) + &)*vo(1,1)+(elas( 9)*vo(3,2))*vo(1,2) + &+(elas( 6)+elas( 6)*vo(3,3)) + &*vo(1,3))*w(3,3))*weight + s(ii1+1,jj1)=s(ii1+1,jj1)+((elas( 7)*vo(1,2) + &+(elas( 1)+elas( 1)*vo(1,1) + &)*vo(2,1)+(elas( 7)*vo(1,2))*vo(2,2) + &+(elas( 8)*vo(1,3)) + &*vo(2,3))*w(1,1) + &+(elas( 7)+elas( 7)*vo(1,1) + &+(elas( 2)*vo(1,2))*vo(2,1)+(elas( 7) + &+elas( 7)*vo(1,1))*vo(2,2) + &)*w(1,2) + &+((elas( 4)*vo(1,3))*vo(2,1) + &+(elas( 8)+elas( 8)*vo(1,1)) + &*vo(2,3))*w(1,3) + &+(elas( 2)+elas( 2)*vo(1,1) + &+(elas( 7)*vo(1,2))*vo(2,1)+(elas( 2) + &+elas( 2)*vo(1,1))*vo(2,2) + &)*w(2,1) + &+(elas( 3)*vo(1,2)+(elas( 7)+elas( 7)*vo(1,1) + &)*vo(2,1)+(elas( 3)*vo(1,2))*vo(2,2) + &+(elas( 9)*vo(1,3)) + &*vo(2,3))*w(2,2) + &+(elas( 5)*vo(1,3)+(elas( 5)*vo(1,3))*vo(2,2) + &+(elas( 9)*vo(1,2)) + &*vo(2,3))*w(2,3) + &+((elas( 8)*vo(1,3))*vo(2,1) + &+(elas( 4)+elas( 4)*vo(1,1)) + &*vo(2,3))*w(3,1) + &+(elas( 9)*vo(1,3)+(elas( 9)*vo(1,3))*vo(2,2) + &+(elas( 5)*vo(1,2)) + &*vo(2,3))*w(3,2) + &+(elas( 9)*vo(1,2)+(elas( 8)+elas( 8)*vo(1,1) + &)*vo(2,1)+(elas( 9)*vo(1,2))*vo(2,2) + &+(elas( 6)*vo(1,3)) + &*vo(2,3))*w(3,3))*weight + s(ii1+1,jj1+1)=s(ii1+1,jj1+1)+((elas( 7) + &+elas( 7)*vo(2,2)+(elas( 1)*vo(2,1) + &)*vo(2,1)+(elas( 7) + &+elas( 7)*vo(2,2))*vo(2,2) + &+(elas( 8)*vo(2,3)) + &*vo(2,3))*w(1,1) + &+(elas( 7)*vo(2,1) + &+(elas( 2) + &+elas( 2)*vo(2,2))*vo(2,1)+(elas( 7)*vo(2,1))*vo(2,2) + &)*w(1,2) + &+((elas( 4)*vo(2,3))*vo(2,1) + &+(elas( 8)*vo(2,1)) + &*vo(2,3))*w(1,3) + &+(elas( 2)*vo(2,1) + &+(elas( 7) + &+elas( 7)*vo(2,2))*vo(2,1)+(elas( 2)*vo(2,1))*vo(2,2) + &)*w(2,1) + &+(elas( 3) + &+elas( 3)*vo(2,2)+(elas( 7)*vo(2,1) + &)*vo(2,1)+(elas( 3) + &+elas( 3)*vo(2,2))*vo(2,2) + &+(elas( 9)*vo(2,3)) + &*vo(2,3))*w(2,2) + &+(elas( 5)*vo(2,3)+(elas( 5)*vo(2,3))*vo(2,2) + &+(elas( 9)+elas( 9)*vo(2,2)) + &*vo(2,3))*w(2,3) + &+((elas( 8)*vo(2,3))*vo(2,1) + &+(elas( 4)*vo(2,1)) + &*vo(2,3))*w(3,1) + &+(elas( 9)*vo(2,3)+(elas( 9)*vo(2,3))*vo(2,2) + &+(elas( 5)+elas( 5)*vo(2,2)) + &*vo(2,3))*w(3,2) + &+(elas( 9) + &+elas( 9)*vo(2,2)+(elas( 8)*vo(2,1) + &)*vo(2,1)+(elas( 9) + &+elas( 9)*vo(2,2))*vo(2,2) + &+(elas( 6)*vo(2,3)) + &*vo(2,3))*w(3,3))*weight + s(ii1+1,jj1+2)=s(ii1+1,jj1+2)+((elas( 7)*vo(3,2)+(elas( 1)*vo(3,1) + &)*vo(2,1)+(elas( 7)*vo(3,2))*vo(2,2) + &+(elas( 8)+elas( 8)*vo(3,3)) + &*vo(2,3))*w(1,1) + &+(elas( 7)*vo(3,1) + &+(elas( 2)*vo(3,2))*vo(2,1)+(elas( 7)*vo(3,1))*vo(2,2) + &)*w(1,2) + &+((elas( 4) + &+elas( 4)*vo(3,3))*vo(2,1) + &+(elas( 8)*vo(3,1)) + &*vo(2,3))*w(1,3) + &+(elas( 2)*vo(3,1) + &+(elas( 7)*vo(3,2))*vo(2,1)+(elas( 2)*vo(3,1))*vo(2,2) + &)*w(2,1) + &+(elas( 3)*vo(3,2)+(elas( 7)*vo(3,1) + &)*vo(2,1)+(elas( 3)*vo(3,2))*vo(2,2) + &+(elas( 9)+elas( 9)*vo(3,3)) + &*vo(2,3))*w(2,2) + &+(elas( 5) + &+elas( 5)*vo(3,3)+(elas( 5) + &+elas( 5)*vo(3,3))*vo(2,2) + &+(elas( 9)*vo(3,2)) + &*vo(2,3))*w(2,3) + &+((elas( 8) + &+elas( 8)*vo(3,3))*vo(2,1) + &+(elas( 4)*vo(3,1)) + &*vo(2,3))*w(3,1) + &+(elas( 9) + &+elas( 9)*vo(3,3)+(elas( 9) + &+elas( 9)*vo(3,3))*vo(2,2) + &+(elas( 5)*vo(3,2)) + &*vo(2,3))*w(3,2) + &+(elas( 9)*vo(3,2)+(elas( 8)*vo(3,1) + &)*vo(2,1)+(elas( 9)*vo(3,2))*vo(2,2) + &+(elas( 6)+elas( 6)*vo(3,3)) + &*vo(2,3))*w(3,3))*weight + s(ii1+2,jj1)=s(ii1+2,jj1)+((elas( 8)*vo(1,3) + &+(elas( 1)+elas( 1)*vo(1,1) + &)*vo(3,1)+(elas( 7)*vo(1,2))*vo(3,2) + &+(elas( 8)*vo(1,3)) + &*vo(3,3))*w(1,1) + &+((elas( 2)*vo(1,2))*vo(3,1)+(elas( 7) + &+elas( 7)*vo(1,1))*vo(3,2) + &)*w(1,2) + &+(elas( 8)+elas( 8)*vo(1,1) + &+(elas( 4)*vo(1,3))*vo(3,1) + &+(elas( 8)+elas( 8)*vo(1,1)) + &*vo(3,3))*w(1,3) + &+((elas( 7)*vo(1,2))*vo(3,1)+(elas( 2) + &+elas( 2)*vo(1,1))*vo(3,2) + &)*w(2,1) + &+(elas( 9)*vo(1,3)+(elas( 7)+elas( 7)*vo(1,1) + &)*vo(3,1)+(elas( 3)*vo(1,2))*vo(3,2) + &+(elas( 9)*vo(1,3)) + &*vo(3,3))*w(2,2) + &+(elas( 9)*vo(1,2)+(elas( 5)*vo(1,3))*vo(3,2) + &+(elas( 9)*vo(1,2)) + &*vo(3,3))*w(2,3) + &+(elas( 4)+elas( 4)*vo(1,1) + &+(elas( 8)*vo(1,3))*vo(3,1) + &+(elas( 4)+elas( 4)*vo(1,1)) + &*vo(3,3))*w(3,1) + &+(elas( 5)*vo(1,2)+(elas( 9)*vo(1,3))*vo(3,2) + &+(elas( 5)*vo(1,2)) + &*vo(3,3))*w(3,2) + &+(elas( 6)*vo(1,3)+(elas( 8)+elas( 8)*vo(1,1) + &)*vo(3,1)+(elas( 9)*vo(1,2))*vo(3,2) + &+(elas( 6)*vo(1,3)) + &*vo(3,3))*w(3,3))*weight + s(ii1+2,jj1+1)=s(ii1+2,jj1+1)+((elas( 8)*vo(2,3) + &+(elas( 1)*vo(2,1) + &)*vo(3,1)+(elas( 7) + &+elas( 7)*vo(2,2))*vo(3,2) + &+(elas( 8)*vo(2,3)) + &*vo(3,3))*w(1,1) + &+((elas( 2) + &+elas( 2)*vo(2,2))*vo(3,1)+(elas( 7)*vo(2,1))*vo(3,2) + &)*w(1,2) + &+(elas( 8)*vo(2,1) + &+(elas( 4)*vo(2,3))*vo(3,1) + &+(elas( 8)*vo(2,1)) + &*vo(3,3))*w(1,3) + &+((elas( 7) + &+elas( 7)*vo(2,2))*vo(3,1)+(elas( 2)*vo(2,1))*vo(3,2) + &)*w(2,1) + &+(elas( 9)*vo(2,3)+(elas( 7)*vo(2,1) + &)*vo(3,1)+(elas( 3) + &+elas( 3)*vo(2,2))*vo(3,2) + &+(elas( 9)*vo(2,3)) + &*vo(3,3))*w(2,2) + &+(elas( 9) + &+elas( 9)*vo(2,2)+(elas( 5)*vo(2,3))*vo(3,2) + &+(elas( 9)+elas( 9)*vo(2,2)) + &*vo(3,3))*w(2,3) + &+(elas( 4)*vo(2,1) + &+(elas( 8)*vo(2,3))*vo(3,1) + &+(elas( 4)*vo(2,1)) + &*vo(3,3))*w(3,1) + &+(elas( 5) + &+elas( 5)*vo(2,2)+(elas( 9)*vo(2,3))*vo(3,2) + &+(elas( 5)+elas( 5)*vo(2,2)) + &*vo(3,3))*w(3,2) + &+(elas( 6)*vo(2,3)+(elas( 8)*vo(2,1) + &)*vo(3,1)+(elas( 9) + &+elas( 9)*vo(2,2))*vo(3,2) + &+(elas( 6)*vo(2,3)) + &*vo(3,3))*w(3,3))*weight + s(ii1+2,jj1+2)=s(ii1+2,jj1+2)+((elas( 8) + &+elas( 8)*vo(3,3)+(elas( 1)*vo(3,1) + &)*vo(3,1)+(elas( 7)*vo(3,2))*vo(3,2) + &+(elas( 8)+elas( 8)*vo(3,3)) + &*vo(3,3))*w(1,1) + &+((elas( 2)*vo(3,2))*vo(3,1)+(elas( 7)*vo(3,1))*vo(3,2) + &)*w(1,2) + &+(elas( 8)*vo(3,1) + &+(elas( 4) + &+elas( 4)*vo(3,3))*vo(3,1) + &+(elas( 8)*vo(3,1)) + &*vo(3,3))*w(1,3) + &+((elas( 7)*vo(3,2))*vo(3,1)+(elas( 2)*vo(3,1))*vo(3,2) + &)*w(2,1) + &+(elas( 9) + &+elas( 9)*vo(3,3)+(elas( 7)*vo(3,1) + &)*vo(3,1)+(elas( 3)*vo(3,2))*vo(3,2) + &+(elas( 9)+elas( 9)*vo(3,3)) + &*vo(3,3))*w(2,2) + &+(elas( 9)*vo(3,2)+(elas( 5) + &+elas( 5)*vo(3,3))*vo(3,2) + &+(elas( 9)*vo(3,2)) + &*vo(3,3))*w(2,3) + &+(elas( 4)*vo(3,1) + &+(elas( 8) + &+elas( 8)*vo(3,3))*vo(3,1) + &+(elas( 4)*vo(3,1)) + &*vo(3,3))*w(3,1) + &+(elas( 5)*vo(3,2)+(elas( 9) + &+elas( 9)*vo(3,3))*vo(3,2) + &+(elas( 5)*vo(3,2)) + &*vo(3,3))*w(3,2) + &+(elas( 6) + &+elas( 6)*vo(3,3)+(elas( 8)*vo(3,1) + &)*vo(3,1)+(elas( 9)*vo(3,2))*vo(3,2) + &+(elas( 6)+elas( 6)*vo(3,3)) + &*vo(3,3))*w(3,3))*weight +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/orthotropic.f calculix-ccx-2.3/ccx_2.3/src/orthotropic.f --- calculix-ccx-2.1/ccx_2.3/src/orthotropic.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/orthotropic.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,112 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine orthotropic(orthol,anisox) +! +! expands the 9 orthotropic elastic constants into a +! 3x3x3x3 matrix +! + implicit none +! + real*8 orthol(9),anisox(3,3,3,3) +! + anisox(1,1,1,1)=orthol(1) + anisox(1,1,1,2)=0.d0 + anisox(1,1,1,3)=0.d0 + anisox(1,1,2,1)=0.d0 + anisox(1,1,2,2)=orthol(2) + anisox(1,1,2,3)=0.d0 + anisox(1,1,3,1)=0.d0 + anisox(1,1,3,2)=0.d0 + anisox(1,1,3,3)=orthol(4) + anisox(1,2,1,1)=0.d0 + anisox(1,2,1,2)=orthol(7) + anisox(1,2,1,3)=0.d0 + anisox(1,2,2,1)=orthol(7) + anisox(1,2,2,2)=0.d0 + anisox(1,2,2,3)=0.d0 + anisox(1,2,3,1)=0.d0 + anisox(1,2,3,2)=0.d0 + anisox(1,2,3,3)=0.d0 + anisox(1,3,1,1)=0.d0 + anisox(1,3,1,2)=0.d0 + anisox(1,3,1,3)=orthol(8) + anisox(1,3,2,1)=0.d0 + anisox(1,3,2,2)=0.d0 + anisox(1,3,2,3)=0.d0 + anisox(1,3,3,1)=orthol(8) + anisox(1,3,3,2)=0.d0 + anisox(1,3,3,3)=0.d0 + anisox(2,1,1,1)=0.d0 + anisox(2,1,1,2)=orthol(7) + anisox(2,1,1,3)=0.d0 + anisox(2,1,2,1)=orthol(7) + anisox(2,1,2,2)=0.d0 + anisox(2,1,2,3)=0.d0 + anisox(2,1,3,1)=0.d0 + anisox(2,1,3,2)=0.d0 + anisox(2,1,3,3)=0.d0 + anisox(2,2,1,1)=orthol(2) + anisox(2,2,1,2)=0.d0 + anisox(2,2,1,3)=0.d0 + anisox(2,2,2,1)=0.d0 + anisox(2,2,2,2)=orthol(3) + anisox(2,2,2,3)=0.d0 + anisox(2,2,3,1)=0.d0 + anisox(2,2,3,2)=0.d0 + anisox(2,2,3,3)=orthol(5) + anisox(2,3,1,1)=0.d0 + anisox(2,3,1,2)=0.d0 + anisox(2,3,1,3)=0.d0 + anisox(2,3,2,1)=0.d0 + anisox(2,3,2,2)=0.d0 + anisox(2,3,2,3)=orthol(9) + anisox(2,3,3,1)=0.d0 + anisox(2,3,3,2)=orthol(9) + anisox(2,3,3,3)=0.d0 + anisox(3,1,1,1)=0.d0 + anisox(3,1,1,2)=0.d0 + anisox(3,1,1,3)=orthol(8) + anisox(3,1,2,1)=0.d0 + anisox(3,1,2,2)=0.d0 + anisox(3,1,2,3)=0.d0 + anisox(3,1,3,1)=orthol(8) + anisox(3,1,3,2)=0.d0 + anisox(3,1,3,3)=0.d0 + anisox(3,2,1,1)=0.d0 + anisox(3,2,1,2)=0.d0 + anisox(3,2,1,3)=0.d0 + anisox(3,2,2,1)=0.d0 + anisox(3,2,2,2)=0.d0 + anisox(3,2,2,3)=orthol(9) + anisox(3,2,3,1)=0.d0 + anisox(3,2,3,2)=orthol(9) + anisox(3,2,3,3)=0.d0 + anisox(3,3,1,1)=orthol(4) + anisox(3,3,1,2)=0.d0 + anisox(3,3,1,3)=0.d0 + anisox(3,3,2,1)=0.d0 + anisox(3,3,2,2)=orthol(5) + anisox(3,3,2,3)=0.d0 + anisox(3,3,3,1)=0.d0 + anisox(3,3,3,2)=0.d0 + anisox(3,3,3,3)=orthol(6) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/out.f calculix-ccx-2.3/ccx_2.3/src/out.f --- calculix-ccx-2.1/ccx_2.3/src/out.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/out.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,67 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine out(co,nk,kon,ipkon,lakon,ne0,v,stn,inum,nmethod, + & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern,xstaten, + & nstate_,istep,iinc,iperturb,ener,mi,output,ithermal,qfn, + & mode,noddiam,trab,inotr,ntrans,orab,ielorien,norien,description, + & ipneigh,neigh,stx,vr,vi,stnr,stni,vmax,stnmax,ngraph,veold,ne, + & cs,set,nset,istartset,iendset,ialset,eenmax) +! +! stores the results in frd format +! + implicit none +! + character*3 output + character*8 lakon(*) + character*12 description + character*80 matname(*) + character*81 set(*) + character*87 filab(*) +! + integer kon(*),inum(*),nk,ne0,nmethod,kode,ipkon(*),mode,noddiam, + & ielmat(*),nstate_,istep,iinc,iperturb,mi(2),ithermal,inotr(2,*), + & ntrans,ielorien(*),norien,ngraph,ne,nset,istartset(*), + & iendset(*),ialset(*),ipneigh(*),neigh(2,*) +! + real*8 co(3,*),v(0:mi(2),*),stn(6,*),een(6,*),t1(*),fn(0:mi(2),*), + & time,epn(*),enern(*),xstaten(nstate_,*),ener(mi(1),*),qfn(3,*), + & trab(7,*),orab(7,*),vr(0:mi(2),*),vi(0:mi(2),*),stnr(6,*), + & cs(17,*),stni(6,*),pi,vmax(0:3,*),stnmax(0:6,*),eenmax(0:6,*), + & veold(0:mi(2),*),stx(6,mi(1),*) +! + if((output.eq.'frd').or.(output.eq.'FRD')) then + call frd(co,nk,kon,ipkon,lakon,ne0,v,stn,inum,nmethod, + & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern, + & xstaten,nstate_,istep,iinc,ithermal,qfn,mode,noddiam, + & trab,inotr,ntrans,orab,ielorien,norien,description, + & ipneigh,neigh,mi(1),stx,vr,vi,stnr,stni,vmax, + & stnmax,ngraph,veold,ener,ne,cs,set,nset,istartset, + & iendset,ialset,eenmax) + else + if(nmethod.ne.0) then + call onf(co,nk,kon,ipkon,lakon,ne0,v,stn,inum,nmethod, + & kode,filab,een,t1,fn,time,epn,ielmat,matname,enern, + & xstaten,nstate_,istep,iinc,iperturb,ener,mi(1)) + endif + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/pardiso.c calculix-ccx-2.3/ccx_2.3/src/pardiso.c --- calculix-ccx-2.1/ccx_2.3/src/pardiso.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pardiso.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,174 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2005 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifdef PARDISO + +#include +#include +#include +#include "CalculiX.h" +#include "pardiso.h" + +int *irowpardiso=NULL,*pointers=NULL,iparm[64]; +long int pt[64]; +double *aupardiso=NULL; + +void pardiso_factor(double *ad, double *au, double *adb, double *aub, + double *sigma,int *icol, int *irow, + int *neq, int *nzs){ + + char *env; + int i,j,k,l,maxfct=1,mnum=1,mtype=-2,phase=12,nrhs=1,*perm=NULL, + msglvl=0,error=0; + long long ndim; + double *b=NULL,*x=NULL; + + printf(" Factoring the system of equations using the pardiso solver\n\n"); + + iparm[0]=0; + env=getenv("OMP_NUM_THREADS"); + if(env) { + iparm[2]=atoi(env);} + else{ + iparm[2]=1; + } + + printf(" number of threads =% d\n\n",iparm[2]); + + for(i=0;i<64;i++){pt[i]=0;} + + ndim=*neq+*nzs; + + pointers=NNEW(int,*neq+1); + irowpardiso=NNEW(int,ndim); + aupardiso=NNEW(double,ndim); + + k=ndim; + l=*nzs; + + if(*sigma==0.){ + pointers[*neq]=ndim+1; + for(i=*neq-1;i>=0;--i){ + for(j=0;j=0;--i){ + for(j=0;j +#include +#include +#include "CalculiX.h" + +#define GOOD 0 +#define BAD 1 +#define FALSE 0 +#define TRUE 1 + +/* Prototyping */ + +int cgsolver (double *A, double *x, double *b, int neq, int len, int *ia, + int *iz,double *eps, int *niter, int precFlg); +void PCG (double *A, double *x, double *b, int neq, int len, int *ia, + int *iz,double *eps, int *niter, int precFlg, + double *rho, double *r, double *g, double *C, double *z); +void CG (double *A, double *x, double *b, int neq, int len, int *ia, + int *iz,double *eps, int *niter,double *r, double *p, double *z); +void Scaling (double *A, double *b, int neq, int *ia, int *iz, double *d); +void MatVecProduct (double *A, double *p, int neq, int *ia, int *iz, + double *z); +void PreConditioning (double *A, int neq, int len, int *ia, int *iz, + double alpha, int precFlg,double *C, int *ier); +void Mrhor (double *C, int neq, int *ia, int *iz, double *r, double *rho); +void InnerProduct (double *a, double *b, int n, double *Sum); + +/* ********************************************************************** + +The (preconditioned) conjugate gradient solver + + parameter: + A compact row oriented storage of lower left of matrix A + neq order of A, number of equations + len number of non zero entries in Matrix A + ia column indices of corresponding elements in Matrix A + iz row indices (diagonal elements indices) + x solution vector + b right hand side + eps required accuracy -> residual + niter maximum number of iterations -> number of iterations + precFlg preconditioning flag + +The compact row oriented storage of sparse quadratic matrices is decsribed in +H.R. Schwarz: FORTRAN-Programme zur Methode der finiten Elemente, pp.66-67, +Teubner, 1981 + +********************************************************************** +*/ + +int cgsolver (double *A, double *x, double *b, int neq, int len, + int *ia, int *iz, + double *eps, int *niter, int precFlg) +{ + int i=0; + double *Factor=NULL,*r=NULL,*p=NULL,*z=NULL,*C=NULL,*g=NULL,*rho=NULL; + + /* reduce row and column indices by 1 (FORTRAN->C) */ + + for (i=0; i residual + niter maximum number of iterations -> number of iterations + precFlg preconditioning flag + + The function corresponds to function PACHCG() in H.R. Schwarz: FORTRAN-Pro- + gramme zur Methode der finiten Elemente, p.115, Teubner, 1981 + +********************************************************************** +*/ + +void PCG (double *A, double *x, double *b, int neq, int len, int *ia, + int *iz,double *eps, int *niter, int precFlg, + double *rho, double *r, double *g, double *C, double *z) +{ + int i=0, k=0, ncg=0,iam,ier=0; + double alpha=0.0, ekm1=0.0, rrho=0.0; + double rrho1=0.0, gz=0.0, qk=0.0; + double c1=0.005,qam,err,ram=0; + + + /* initialize result and residual vectors */ + + qam=0.;iam=0; + for (i=0; i1.e-20){qam+=err;iam++;} + } + if(iam>0) qam=qam/iam; + else {*niter=0;return;} + + /* preconditioning */ + + printf("Cholesky preconditioning\n\n"); + + printf("alpha=%f\n",alpha); + PreConditioning(A,neq,len,ia,iz,alpha,precFlg,C,&ier); + while (ier==0) + { + if (alpha<=0.0) alpha=0.005; + alpha += alpha; + printf("alpha=%f\n",alpha); + PreConditioning(A,neq,len,ia,iz,alpha,precFlg,C,&ier); + } + + /* solving the system of equations using the iterative solver */ + + printf("Solving the system of equations using the iterative solver\n\n"); + + /* main iteration loop */ + + for (k=1; k<=*niter; k++, ncg++) + { + + /* solve M rho = r, M=C CT */ + + Mrhor(C,neq,ia,iz,r,rho); + + /* inner product (r,rho) */ + + InnerProduct(r,rho,neq,&rrho); + + /* If working with Penalty-terms for boundary conditions you can get + numerical troubles because RRHO becomes a very large value. + With at least two iterations the result may be better !!! */ + + /* convergency check */ + + printf("iteration= %d, error= %e, limit=%e\n",ncg,ram,c1*qam); + if (k!=1 && (ram<=c1*qam)) break; + if (k!=1) + { + ekm1 = rrho/rrho1; + for (i=0; iram) ram=err; + } + rrho1 = rrho; + } + if(k==*niter){ + printf("*ERROR in PCG: no convergence;"); + FORTRAN(stop,()); + } + *eps = rrho; + *niter = ncg; + + return; +} + + +/* ********************************************************************** + + Scaling the equation system A x + b = 0 + + The equation system is scaled in consideration of keeping the symmetry in + such a way that the diagonal elements of matrix A are 1. This is performed + by the diagonal matrix Ds with the diagonal elements d_i = 1/sqrt(a_ii). + The given equation system Ax+b=0 is transformed into + -1 - - - + Ds A Ds Ds x + Ds b = 0 or A x + b = 0 + _ _ + with the scaled Matrix A= Ds A Ds and the scaled right hand side b= Ds b. + The scaling factor Ds is needed later for backscaling of the solution + vector + _ -1 _ + x = Ds x resp. x = Ds x + + parameter: + A compact row oriented storage of lower left of matrix A + b right hand side + neq order of A, number of equations + ia column indices + iz row indices (diagonal elements indices) + + The function corresponds to function SCALKO() in H.R. Schwarz: FORTRAN-Pro- + gramme zur Methode der finiten Elemente, p.105, Teubner, 1981 + +********************************************************************** +*/ + +void Scaling (double *A, double *b, int neq, int *ia, int *iz, double *d) +{ + int i=0, j=0, jlo=0, jup=0; + + /* extract diagonal vector from matrix A */ + + for (i=0; i Ax+b=0: negative sign) */ + + for (i=0; iia[j]) break; + if (ia[l]0; i--) + { + rho[i] /= C[iz[i]]; + jlo = iz[i-1]+1; /*..first non-zero element in current row...... */ + jup = iz[i]-1; /*..diagonal element in current row............ */ + for (j=jlo; j<=jup; j++) /*..all non-zero off-diagonal element.......... */ + rho[ia[j]] -= C[j]*rho[i]; + } + return; +} +/*--------------------------------------------------------------------------------- */ + + + + +/*--Calculation of the inner product of two (distributed) vectors------------------ */ +/*--------------------------------------------------------------------------------- */ +void InnerProduct (double *a, double *b, int n, double *Sum) +{ + int i=0; +/*..local vectors.................................................................. */ + *Sum=0.; + for (i=0; i residual -- */ +/*-- niter maximum number of iterations -> number of iterations -- */ +/*--------------------------------------------------------------------------------- */ +void CG (double *A, double *x, double *b, int neq, int len, int *ia, int *iz, + double *eps, int *niter, double *r, double *p, double *z) +{ + int i=0, k=0, ncg=0,iam; + double ekm1=0.0,c1=0.005,qam,ram=0.,err; + double rr=0.0, pz=0.0, qk=0.0, rro=0.0; + + + /* solving the system of equations using the iterative solver */ + + printf("Solving the system of equations using the iterative solver\n\n"); + +/*..initialize result, search and residual vectors................................. */ + qam=0.;iam=0; + for (i=0; i1.e-20){qam+=err;iam++;} + } + if(iam>0) qam=qam/neq; + else {*niter=0;return;} + /*else qam=0.01;*/ +/*..main iteration loop............................................................ */ + for (k=1; k<=(*niter); k++, ncg++) + { +/*......inner product rT r......................................................... */ + InnerProduct(r,r,neq,&rr); + printf("iteration= %d, error= %e, limit=%e\n",ncg,ram,c1*qam); +/*......If working with Penalty-terms for boundary conditions you can get nume-.... */ +/*......rical troubles because RR becomes a very large value. With at least two.... */ +/*......iterations the result may be better !!!.................................... */ +/*......convergency check.......................................................... */ + if (k!=1 && (ram<=c1*qam)) break; +/*......new search vector.......................................................... */ + if (k!=1) + { + ekm1 = rr/rro; + for (i=0; iram) ram=err; + } +/*......store previous residual.................................................... */ + rro = rr; + + } + if(k==*niter){ + printf("*ERROR in PCG: no convergence;"); + FORTRAN(stop,()); + } + *eps = rr; /*..return residual............................ */ + *niter = ncg; /*..return number of iterations................ */ +/*..That's it...................................................................... */ + return; +} +/*--------------------------------------------------------------------------------- */ diff -Nru calculix-ccx-2.1/ccx_2.3/src/physicalconstants.f calculix-ccx-2.3/ccx_2.3/src/physicalconstants.f --- calculix-ccx-2.1/ccx_2.3/src/physicalconstants.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/physicalconstants.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,70 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine physicalconstants(inpc,textpart,physcon, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *PHYSICAL CONSTANTS +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer i,istep,istat,n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*), + & ipoinpc(0:*) +! + real*8 physcon(*) +! + if(istep.gt.0) then + write(*,*) '*ERROR in physicalconstants: *PHYSICAL CONSTANTS' + write(*,*) ' should only be used before the first STEP' + stop + endif +! + do i=2,n + if(textpart(i)(1:13).eq.'ABSOLUTEZERO=') then + read(textpart(i)(14:33),'(f20.0)',iostat=istat) physcon(1) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:16).eq.'STEFANBOLTZMANN=') then + read(textpart(i)(17:36),'(f20.0)',iostat=istat) physcon(2) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:14).eq.'NEWTONGRAVITY=') then + read(textpart(i)(15:24),'(f20.0)',iostat=istat) physcon(3) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + write(*,*) + & '*WARNING in physicalconstants: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/pk_cdc_cl1.f calculix-ccx-2.3/ccx_2.3/src/pk_cdc_cl1.f --- calculix-ccx-2.1/ccx_2.3/src/pk_cdc_cl1.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pk_cdc_cl1.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,47 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! cd_compressible for class 1 orifices where r/d=l/d +! + subroutine pk_cdc_cl1(lqd,reynolds,p2p1,beta,kappa,cdc_cl1) +! + implicit none +! + real*8 lqd,reynolds,p2p1,beta,kappa,cdi_noz,cdi_r,cdi_se, + & y0,yg,cdc_cl1,rqd,cdqcv_noz,cdqcv_r +! + rqd=lqd +! cd incompresssible nozzle eq. 4a 4b + call pk_cdi_noz(reynolds,cdi_noz) +! cdr eq.5 + call pk_cdi_r(rqd,reynolds,beta,cdi_r) +! cd incompressible sharp edge eq.3 + call pk_cdi_se(reynolds,beta,cdi_se) +! y0 and yg , eq.15-17 , eq.18 + call pk_y0_yg(p2p1,beta,kappa,y0,yg) +! + cdqcv_noz=cdi_noz/(0.0718d0*cdi_noz+0.9282d0) + cdqcv_r=cdi_r/(0.0718d0*cdi_r+0.9282d0) +! eq.25 + cdc_cl1=cdi_r*((cdqcv_noz-cdqcv_r) + & /(cdqcv_noz-cdi_se/0.971d0) + & *(y0/yg-1d0)+1d0) +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pk_cdc_cl3a.f calculix-ccx-2.3/ccx_2.3/src/pk_cdc_cl3a.f --- calculix-ccx-2.1/ccx_2.3/src/pk_cdc_cl3a.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pk_cdc_cl3a.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,48 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! cd compressible for class 3 orifice where, l/d>0 and r/d>0 +!typ a) with 0 <= l/d<=0.28 (eq. 25 modified) +! + subroutine pk_cdc_cl3a(lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3a) +! + implicit none +! + real*8 lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3a,cdi_noz, + & cdi_rl,cdi_se,y0,yg,cdqcv_noz,cdqcv_rl +! +! cd incompressible nozlle eq 4a 4b + call pk_cdi_noz(reynolds,cdi_noz) +! cd incompresible eq.6 + call pk_cdi_rl(lqd,rqd,reynolds,beta,cdi_rl) +! cd incompressible sharp edge eq.3 + call pk_cdi_se(reynolds,beta,cdi_se) +! y0,yg ,eq. 15-17, eq.18 + call pk_y0_yg(p2p1,beta,kappa,y0,yg) +! + cdqcv_noz=cdi_noz/(0.0718d0*cdi_noz+0.9282d0) + cdqcv_rl=cdi_rl/(0.0718d0*cdi_rl+0.9282d0) +! +! eq.26 modified for class 3a +! + cdc_cl3a=cdi_rl*((cdqcv_noz-cdqcv_rl)/(cdqcv_noz-cdi_se/0.971d0) + & *(y0/yg-1.d0)+1.d0) +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pk_cdc_cl3b.f calculix-ccx-2.3/ccx_2.3/src/pk_cdc_cl3b.f --- calculix-ccx-2.1/ccx_2.3/src/pk_cdc_cl3b.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pk_cdc_cl3b.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,48 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +!cd compresssible for class3 orifices where l/d>0 and r/d>0 +! typ b) with 0.280 and r/d>0 +! type d) with 0.5<=l/d<=2 (eq. 27) +! + subroutine pk_cdc_cl3d(lqd,rqd,reynolds,p2p1,beta,cdc_cl3d) +! + implicit none +! + real*8 lqd,rqd,reynolds,p2p1,beta,cdc_cl3d,cdi_rl,cdc_cl3_choked, + & jpsqpt,zeta +! + cdc_cl3_choked=1.d0-(0.008d0+0.992d0*exp(-5.5d0*rqd + & -3.5d0*rqd**2.d0))*(1.d0-0.838d0) +! + call pk_cdi_rl(lqd,rqd,reynolds,beta,cdi_rl) +! +! help function for eq 26 + if (p2p1.ge.1d0) then + jpsqpt=1.d0 + elseif(p2p1.ge.0.1d0) then + zeta=(1.d0-p2p1)/0.6d0 + jpsqpt=exp(-4.6d0*zeta**7d0-2.2d0*zeta**1.5d0) + else + jpsqpt=0.d0 + endif +! + cdc_cl3d=cdc_cl3_choked-jpsqpt*(cdc_cl3_choked-cdi_rl) +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pk_cdc_cl3.f calculix-ccx-2.3/ccx_2.3/src/pk_cdc_cl3.f --- calculix-ccx-2.1/ccx_2.3/src/pk_cdc_cl3.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pk_cdc_cl3.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,46 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! cd compresibble for class 3 orifices where l/d>0 and r/d>0 +! + subroutine pk_cdc_cl3(lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3) +! + implicit none +! + real*8 lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3a,cdc_cl3b, + & cdc_cl3d,cdc_cl3 +! + cdc_cl3a=0.d0 + cdc_cl3b=0.d0 + cdc_cl3d=0.d0 +! + if(lqd.le.0.28d0) then + call pk_cdc_cl3a(lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3a) + cdc_cl3=cdc_cl3a + elseif(lqd.le.0.5d0) then + call pk_cdc_cl3b(lqd,rqd,reynolds,p2p1,beta,kappa,cdc_cl3b) + cdc_cl3=cdc_cl3b + else + call pk_cdc_cl3d(lqd,rqd,reynolds,p2p1,beta,cdc_cl3d) + cdc_cl3=cdc_cl3d +! + endif +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pk_cdi_noz.f calculix-ccx-2.3/ccx_2.3/src/pk_cdi_noz.f --- calculix-ccx-2.1/ccx_2.3/src/pk_cdi_noz.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pk_cdi_noz.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,75 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +!cd incompressible for ASME nozzles eq 4a 4b + + subroutine pk_cdi_noz(reynolds,cdi_noz) +! + implicit none +! + real*8 reynolds,cdi_noz,ln_reynolds,cdi_noz_lr, + & cdi_noz_hr,e,reynolds_cor +! + if (reynolds.lt.40000d0) then +! +! formerly pk_cdi_noz_lr : for low Reynolds nsumber +! + if (reynolds.eq.0d0) then + reynolds_cor=1.d0 + else + reynolds_cor=reynolds + endif + e=2.718281828459045d0 + ln_reynolds=log(reynolds_cor)/log(e) +! + cdi_noz_lr=0.19436d0+0.152884d0*ln_reynolds + & -0.0097785d0*ln_reynolds**2d0+0.00020903d0 + & *ln_reynolds**3d0 +! + cdi_noz=cdi_noz_lr +! + elseif (reynolds.lt.50000d0) then +! + if (reynolds.eq.0) then + reynolds_cor=1 + else + reynolds_cor=reynolds + endif +! + e=2.718281828459045d0 + ln_reynolds=log(reynolds_cor)/log(e) +! + cdi_noz_lr=0.19436d0+0.152884d0*ln_reynolds + & -0.0097785d0*ln_reynolds**2+0.00020903d0 + & *ln_reynolds**3d0 +! + cdi_noz_hr=0.9975d0-0.00653d0*dsqrt(1000000d0/50000d0) + +! linear interpolation in order to achieve continuity +! + cdi_noz=cdi_noz_lr+(cdi_noz_hr-cdi_noz_lr) + & *(reynolds-40000d0)/(50000d0-40000d0) + else +! +! formerly pk_cdi_noz_hr for high Reynolds numbers +! + cdi_noz=0.9975d0-0.00653d0*dsqrt(1000000d0/reynolds) + endif + + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pk_cdi_r.f calculix-ccx-2.3/ccx_2.3/src/pk_cdi_r.f --- calculix-ccx-2.1/ccx_2.3/src/pk_cdi_r.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pk_cdi_r.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,35 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! cd inncompressible fro thin orifices with corner radiusing (eq 5) + + subroutine pk_cdi_r (rqd,reynolds,beta,cdi_r) +! + implicit none +! + real*8 rqd,reynolds,beta,cdi_r,frqd,cdi_se,cdi_noz +! + call pk_cdi_noz(reynolds,cdi_noz) + call pk_cdi_se(reynolds,beta,cdi_se) + + frqd=0.008d0+0.992d0*exp(-5.5d0*rqd-3.5d0*rqd**2.d0) +! + cdi_r=cdi_noz-frqd*(cdi_noz-cdi_se) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pk_cdi_rl.f calculix-ccx-2.3/ccx_2.3/src/pk_cdi_rl.f --- calculix-ccx-2.1/ccx_2.3/src/pk_cdi_rl.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pk_cdi_rl.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,44 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +!cd incompressible for long orifices (eq.6) +! + subroutine pk_cdi_rl(lqd,rqd,reynolds,beta,cdi_rl) +! + implicit none +! + real*8 lqd,rqd,reynolds,beta,cdi_rl,rqd_cor,lrqd,cdi_r,glrqd +! + rqd_cor=rqd +! + if (rqd_cor.gt.lqd) then + rqd_cor=lqd + endif +! + lrqd=lqd-rqd_cor +! + call pk_cdi_r(rqd_cor,reynolds,beta,cdi_r) +! + glrqd=(1d0+1.298d0*exp(-1.593d0*lrqd**2.33d0)) + & *(0.435d0+0.021d0*lrqd)/(2.298d0*0.435d0) +! + cdi_rl=1.d0-glrqd*(1.d0-cdi_r) +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pk_cdi_se.f calculix-ccx-2.3/ccx_2.3/src/pk_cdi_se.f --- calculix-ccx-2.1/ccx_2.3/src/pk_cdi_se.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pk_cdi_se.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,40 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! cd incompressible for sharp edged orifices( eq.3) +! + subroutine pk_cdi_se(reynolds,beta,cdi_se) +! + implicit none +! + real*8 reynolds,beta,cdi_se,reynolds_cor +! + if(reynolds.eq.0d0) then + reynolds_cor=1.d0 + else + reynolds_cor=reynolds + endif +! + cdi_se=0.5959d0+0.0312d0*beta**2.1d0-0.184d0*beta**8.d0 + & +0.09d0*0.4333d0*beta**4.d0 + & /(1.d0-beta**4.d0)-0.0337d0*0.47d0*beta**3.d0+91.71d0 + & *(beta**1.75d0)/(reynolds_cor**0.75d0) +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pk_y0_yg.f calculix-ccx-2.3/ccx_2.3/src/pk_y0_yg.f --- calculix-ccx-2.1/ccx_2.3/src/pk_y0_yg.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pk_y0_yg.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,55 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine pk_y0_yg(p2p1,beta,kappa,y0,yg) +! + implicit none +! + real*8 p2p1,beta,kappa,y0,yg,pcrit +! +! adiabatic expansion factor y0 measured (eq.15-17) +! + pcrit=(2.d0/(kappa+1.d0))**(kappa/(kappa-1.d0)) + + if(p2p1.ge.0.63d0) then + y0=1d0-(0.41d0+0.35d0*beta**4.d0)/kappa*(1.d0-p2p1) + else + y0=1d0-(0.41d0+0.35d0*beta**4.d0)/kappa*(1.d0-0.63d0) + & -(0.3475d0+0.1207d0*beta**2.d0-0.3177d0*beta**4.d0) + & *(0.63d0-p2p1) +! + endif +! +! adiabatic expension factor yg isentropic eq 18 +! + if(p2p1.ge.1d0) then + yg=1.d0 +! + elseif (p2p1.ge.pcrit) then + yg=p2p1**(1.d0/kappa)*dsqrt(kappa/(kappa-1.d0) + & *(1.d0-p2p1**((kappa-1.d0)/kappa)))/dsqrt(1.d0-p2p1) +! + else +! critical pressure ratio + yg=(2.d0/(kappa+1.d0))**(1.d0/(kappa-1.d0)) + & *dsqrt(kappa/(kappa+1.d0))/dsqrt(1.d0-p2p1) + endif +! + return +! + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/plane3.f calculix-ccx-2.3/ccx_2.3/src/plane3.f --- calculix-ccx-2.1/ccx_2.3/src/plane3.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/plane3.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,57 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine plane3(co,nodep,a,b,c,d) +! +! calculate the equation of the plane through the +! nodes nodep(1),nodep(2) and nodep(3) in the form +! a*x+b*y+c*z+d=0 such that the triangle through the +! nodes nodep(1),nodep(2),nopep(3) is numbered clockwise +! when looking in the direction of vector (a,b,c) +! + implicit none +! + integer nodep(3),i +! + real*8 co(3,*),a,b,c,d,dd,p12(3),p23(3),p31(3) +! +! sides of the triangle +! + do i=1,3 + p12(i)=co(i,nodep(2))-co(i,nodep(1)) + p23(i)=co(i,nodep(3))-co(i,nodep(2)) + p31(i)=co(i,nodep(1))-co(i,nodep(3)) + enddo +! +! normalized vector normal to the triangle: xn = p12 x p23 +! + a=p12(2)*p23(3)-p12(3)*p23(2) + b=p12(3)*p23(1)-p12(1)*p23(3) + c=p12(1)*p23(2)-p12(2)*p23(1) + dd=dsqrt(a*a+b*b+c*c) + a=a/dd + b=b/dd + c=c/dd +! +! determining the inhomogeneous term +! + d=-a*co(1,nodep(1))-b*co(2,nodep(1))-c*co(3,nodep(1)) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/plane4.f calculix-ccx-2.3/ccx_2.3/src/plane4.f --- calculix-ccx-2.1/ccx_2.3/src/plane4.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/plane4.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,90 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine plane4(co,node,nodep,a,b,c,d) +! +! given are 5 nodes: node and nodep(1) up to nodep(4) +! +! first, the node among the nodep's with the largest +! distance from node is eliminated. The remaining nodes +! are stored into noden(1) up to noden(3). +! +! Then, the equation of the plane through the +! nodes noden(1),noden(2) and noden(3) in the form +! a*x+b*y+c*z+d=0 such that the triangle through the +! nodes noden(1),noden(2),nopen(3) is numbered clockwise +! when looking in the direction of vector (a,b,c) +! + implicit none +! + integer nodep(4),i,j,noden(3),node,kflag,idist(4),n +! + real*8 co(3,*),a,b,c,d,dd,p12(3),p23(3),p31(3),dist(4) +! + kflag=2 + n=4 +! +! determining the distance of the nodep's to node +! + do i=1,4 + dist(i)=((co(1,nodep(i))-co(1,node))**2+ + & (co(2,nodep(i))-co(2,node))**2+ + & (co(3,nodep(i))-co(3,node))**2) + idist(i)=nodep(i) +c write(*,*) nodep(i),dist(i) + enddo +! +! sorting the distances +! + call dsort(dist,idist,n,kflag) +! +! storing the 3 closest nodes in noden +! + j=0 + do i=1,4 + if(nodep(i).eq.idist(4)) cycle + j=j+1 + noden(j)=nodep(i) + enddo +c write(*,*) 'noden ',(noden(i),i=1,3) +! +! sides of the triangle +! + do i=1,3 + p12(i)=co(i,noden(2))-co(i,noden(1)) + p23(i)=co(i,noden(3))-co(i,noden(2)) + p31(i)=co(i,noden(1))-co(i,noden(3)) + enddo +! +! normalized vector normal to the triangle: xn = p12 x p23 +! + a=p12(2)*p23(3)-p12(3)*p23(2) + b=p12(3)*p23(1)-p12(1)*p23(3) + c=p12(1)*p23(2)-p12(2)*p23(1) + dd=dsqrt(a*a+b*b+c*c) + a=a/dd + b=b/dd + c=c/dd +! +! determining the inhomogeneous term +! + d=-a*co(1,noden(1))-b*co(2,noden(1))-c*co(3,noden(1)) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/planempc.f calculix-ccx-2.3/ccx_2.3/src/planempc.f --- calculix-ccx-2.1/ccx_2.3/src/planempc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/planempc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,168 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine planempc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, + & ikboun,ilboun,nboun,nboun_,xboun,inode,node,co,typeboun) +! +! generates MPC's for nodes staying on a straight line defined +! by two nodes a and b. The parameter inode indicates how many +! times the present routine was called within the same *MPC +! definition. For inode=1 "node" is node a, for inode=2 "node" +! is node b. Starting with inode=3 MPC's are defined. +! + implicit none +! + character*1 typeboun(*) + character*20 labmpc(*) +! + integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), + & ilmpc(*),node,id,mpcfreeold,j,idof,l,nodeboun(*),nodea,nodeb, + & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,inode,jmax,k,nodec, + & m +! + real*8 coefmpc(3,*),co(3,*),dd,dmax,pac(3),pbc(3),xboun(*) +! + save nodea,nodeb,nodec,jmax +! + if(inode.eq.1) then + nodea=node + return + elseif(inode.eq.2) then + nodeb=node + return + elseif(inode.eq.3) then + nodec=node + do j=1,3 + pac(j)=co(j,nodea)-co(j,nodec) + pbc(j)=co(j,nodeb)-co(j,nodec) + enddo + dmax=abs(pac(2)*pbc(3)-pac(3)*pbc(2)) + jmax=1 + dd=abs(pac(1)*pbc(3)-pac(3)*pbc(1)) + if(dd.gt.dmax) then + dmax=dd + jmax=2 + endif + dd=abs(pac(1)*pbc(2)-pac(2)*pbc(1)) + if(dd.gt.dmax) then + dmax=dd + jmax=3 + endif + return + endif +! + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in planempc: increase nk_' + stop + endif +! + j=jmax + k=j+1 + if(k.gt.3) k=1 + l=k+1 + if(l.gt.3) l=1 +! + idof=8*(node-1)+j + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*WARNING in planempc: DOF for node ',node + write(*,*) ' in direction ',j,' has been used' + write(*,*) ' on the dependent side of another MPC' + write(*,*) ' PLANE constraint cannot be applied' + return + endif + endif + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in planempc: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)='PLANE ' +! + do m=nmpc,id+2,-1 + ikmpc(m)=ikmpc(m-1) + ilmpc(m)=ilmpc(m-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=j + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=k + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=l + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodea + nodempc(2,mpcfree)=j + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodea + nodempc(2,mpcfree)=k + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodea + nodempc(2,mpcfree)=l + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodeb + nodempc(2,mpcfree)=j + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodeb + nodempc(2,mpcfree)=k + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodeb + nodempc(2,mpcfree)=l + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodec + nodempc(2,mpcfree)=j + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodec + nodempc(2,mpcfree)=k + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodec + nodempc(2,mpcfree)=l + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=j + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + idof=8*(nk-1)+j + call nident(ikboun,idof,nboun,id) + nboun=nboun+1 + if(nboun.gt.nboun_) then + write(*,*) '*ERROR in planempc: increase nboun_' + stop + endif + nodeboun(nboun)=nk + ndirboun(nboun)=j + typeboun(nboun)='P' + do m=nboun,id+2,-1 + ikboun(m)=ikboun(m-1) + ilboun(m)=ilboun(m-1) + enddo + ikboun(id+1)=idof + ilboun(id+1)=nboun +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/plastics.f calculix-ccx-2.3/ccx_2.3/src/plastics.f --- calculix-ccx-2.1/ccx_2.3/src/plastics.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/plastics.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,368 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine plastics(inpc,textpart,nelcon,nmat,ntmat_,npmat_, + & plicon,nplicon,plkcon,nplkcon,iplas,iperturb,nstate_, + & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,ipoinpc,ianisoplas) +! +! reading the input deck: *PLASTIC +! + implicit none +! + logical iso +! + character*1 inpc(*) + character*80 matname(*) + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat_,ntmat,npmat_,npmat,istep, + & n,key,i,nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),ncmat_, + & iplas,iperturb(*),istat,nstate_,kin,itemp,ndata,ndatamax,id, + & irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),ipoinpc(0:*), + & ianisoplas +! + real*8 plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), + & temperature,plconloc(82),t1l,elcon(0:ncmat_,ntmat_,*) +! + iso=.true. +! + ntmat=0 + npmat=0 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in plastics: *PLASTIC should be placed' + write(*,*) ' before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in plastics: *PLASTIC should be preceded' + write(*,*) ' by a *MATERIAL card' + stop + endif +! + if((nelcon(1,nmat).ne.2).and.(nelcon(1,nmat).ne.9)) then + write(*,*) '*ERROR in plastics: *PLASTIC should be preceded' + write(*,*) ' by an *ELASTIC,TYPE=ISO card or' + write(*,*) ' by an *ELASTIC,TYPE=ORTHO card' + stop + endif +! + iperturb(1)=3 + iperturb(2)=1 +! + if(nelcon(1,nmat).eq.2) then + iplas=1 + nelcon(1,nmat)=-51 + nstate_=max(nstate_,13) + else + ianisoplas=1 + nelcon(1,nmat)=-114 + nstate_=max(nstate_,14) + endif +! + do i=2,n + if(textpart(i)(1:10).eq.'HARDENING=') then + if(textpart(i)(11:19).eq.'KINEMATIC') then + iso=.false. + elseif(textpart(i)(11:18).eq.'COMBINED') then + iso=.false. + elseif(textpart(i)(11:14).eq.'USER') then + if(nelcon(1,nmat).eq.-114) then + write(*,*) '*ERROR in plastics: user defined ' + write(*,*) ' hardening is not allowed for ' + write(*,*) ' elastically anisotropic materials' + stop + endif + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + return + endif + exit + else + write(*,*) + & '*WARNING in plastics: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(iso) then +! +! isotropic hardening coefficients +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + read(textpart(3)(1:20),'(f20.0)',iostat=istat) temperature + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! +! first temperature +! + if(ntmat.eq.0) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in plastics: increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature +! +! new temperature +! + elseif(plicon(0,ntmat,nmat).ne.temperature) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in plastics: increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature + endif + do i=1,2 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & plicon(2*npmat+i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + npmat=npmat+1 + if(npmat.gt.npmat_) then + write(*,*) '*ERROR in plastics: increase npmat_' + stop + endif + nplicon(ntmat,nmat)=npmat + enddo + else +! +! kinematic hardening coefficients +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + read(textpart(3)(1:20),'(f20.0)',iostat=istat) temperature + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! +! first temperature +! + if(ntmat.eq.0) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in plastics: increase ntmat_' + stop + endif + nplkcon(0,nmat)=ntmat + plkcon(0,ntmat,nmat)=temperature +! +! new temperature +! + elseif(plkcon(0,ntmat,nmat).ne.temperature) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in plastics: increase ntmat_' + stop + endif + nplkcon(0,nmat)=ntmat + plkcon(0,ntmat,nmat)=temperature + endif + do i=1,2 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & plkcon(2*npmat+i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + npmat=npmat+1 + if(npmat.gt.npmat_) then + write(*,*) '*ERROR in plastics: increase npmat_' + stop + endif + nplkcon(ntmat,nmat)=npmat + enddo + endif +! + if(ntmat.eq.0) then + write(*,*) '*ERROR in plastics: *PLASTIC card without data' + stop + endif +! +! elastically anisotropic materials: recasting the input data +! in a format conform to the user routine umat_aniso_plas.f +! + if(nelcon(1,nmat).eq.-114) then + if(matname(nmat)(71:80).ne.' ') then + write(*,*) '*ERROR in plastics: the material name for an' + write(*,*) ' elastically anisotropic material with' + write(*,*) ' isotropic plasticity must not exceed 70' + write(*,*) ' characters' + stop + else + do i=80,11,-1 + matname(nmat)(i:i)=matname(nmat)(i-10:i-10) + enddo +c matname(nmat)(11:80)=matname(nmat)(1:70) + matname(nmat)(1:10)='ANISO_PLAS' + endif +! + if(iso) then +! +! isotropic hardening +! +! interpolating the plastic data at the elastic temperature +! data points +! + ndatamax=0 + do i=1,nelcon(2,nmat) + t1l=elcon(0,i,nmat) +c plconloc(1)=0.d0 +c plconloc(2)=0.d0 +c plconloc(3)=0.d0 +c plconloc(81)=nplicon(1,nmat)+0.5d0 +! + if(nplicon(0,nmat).eq.1) then + id=-1 + else + call ident2(plicon(0,1,nmat),t1l,nplicon(0,nmat), + & 2*npmat_+1,id) + endif +! + if(nplicon(0,nmat).eq.0) then + continue + elseif((nplicon(0,nmat).eq.1).or.(id.eq.0).or. + & (id.eq.nplicon(0,nmat))) then + if(id.le.0) then + itemp=1 + else + itemp=id + endif + kin=0 + call plcopy(plicon,nplicon,plconloc,npmat_,ntmat_, + & nmat,itemp,i,kin) + if((id.eq.0).or.(id.eq.nplicon(0,nmat))) then + endif + else + kin=0 + call plmix(plicon,nplicon,plconloc,npmat_,ntmat_, + & nmat,id+1,t1l,i,kin) + endif +! + ndata=int(plconloc(81)) + if(ndata.eq.1) then + elcon(10,i,nmat)=plconloc(2) + elcon(11,i,nmat)=0.d0 + elcon(12,i,nmat)=0.d0 + elcon(13,i,nmat)=-1.d0 + elcon(14,i,nmat)=1.d0 + else + elcon(10,i,nmat)=plconloc(2) + elcon(11,i,nmat)=(plconloc(4)-plconloc(2))/ + & (plconloc(3)-plconloc(1)) + elcon(12,i,nmat)=0.d0 + elcon(13,i,nmat)=-1.d0 + elcon(14,i,nmat)=1.d0 + endif + ndatamax=max(ndata,ndatamax) + enddo + if(ndatamax.gt.2) then + write(*,*) '*WARNING in plastics: isotropic hardening' + write(*,*) ' curve is possibly nonlinear for' + write(*,*) ' the elastically anisotropic' + write(*,*) ' material ',matname(nmat)(11:80) + endif + else +! +! kinematic hardening +! +! interpolating the plastic data at the elastic temperature +! data points +! + ndatamax=0 + do i=1,nelcon(2,nmat) + t1l=elcon(0,i,nmat) +c plconloc(1)=0.d0 +c plconloc(2)=0.d0 +c plconloc(3)=0.d0 +c plconloc(82)=nplkcon(1,nmat)+0.5d0 +! + if(nplkcon(0,nmat).eq.1) then + id=-1 + else + call ident2(plkcon(0,1,nmat),t1l,nplkcon(0,nmat), + & 2*npmat_+1,id) + endif +! + if(nplkcon(0,nmat).eq.0) then + continue + elseif((nplkcon(0,nmat).eq.1).or.(id.eq.0).or. + & (id.eq.nplkcon(0,nmat))) then + if(id.le.0) then + itemp=1 + else + itemp=id + endif + kin=1 + call plcopy(plkcon,nplkcon,plconloc,npmat_,ntmat_, + & nmat,itemp,i,kin) + if((id.eq.0).or.(id.eq.nplkcon(0,nmat))) then + endif + else + kin=1 + call plmix(plkcon,nplkcon,plconloc,npmat_,ntmat_, + & nmat,id+1,t1l,i,kin) + endif +! + ndata=int(plconloc(82)) + if(ndata.eq.1) then + elcon(10,i,nmat)=plconloc(42) + elcon(11,i,nmat)=0.d0 + elcon(12,i,nmat)=0.d0 + elcon(13,i,nmat)=-1.d0 + elcon(14,i,nmat)=1.d0 + else + elcon(10,i,nmat)=plconloc(42) + elcon(11,i,nmat)=0.d0 + elcon(12,i,nmat)=(plconloc(44)-plconloc(42))/ + & (plconloc(43)-plconloc(41)) + elcon(13,i,nmat)=-1.d0 + elcon(14,i,nmat)=1.d0 + endif + ndatamax=max(ndata,ndatamax) + enddo + if(ndatamax.gt.2) then + write(*,*) '*WARNING in plastics: kinematic hardening' + write(*,*) ' curve is possibly nonlinear for' + write(*,*) ' the elastically anisotropic' + write(*,*) ' material ',matname(nmat)(11:80) + endif + endif + endif +! +c if(nelcon(1,nmat).eq.-114) then +c write(*,*) 'anisotropic elasticity+viscoplasticity' +c do i=1,nelcon(2,nmat) +c write(*,*) (elcon(j,i,nmat),j=0,14) +c enddo +c endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/plcopy.f calculix-ccx-2.3/ccx_2.3/src/plcopy.f --- calculix-ccx-2.1/ccx_2.3/src/plcopy.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/plcopy.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,81 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine plcopy(plcon,nplcon,plconloc,npmat_,ntmat_, + & imat,itemp,nelem,kin) +! +! copies the hardening data for material imat and temperature +! itemp from plcon into plconloc if the number of data points does +! not exceed 20. Else, the equivalent plastic strain range is +! divided into 19 intervals and the values are interpolated. +! Attention: in plcon the odd storage spaces contain the Von +! Mises stress, the even ones the equivalent plastic +! strain. For plconloc, this order is reversed. +! + implicit none +! + integer imat,ndata,ntmat_,npmat_,nplcon(0:ntmat_,*),nelem, + & kin,k,itemp +! + real*8 eplmin,eplmax,depl,epla,plcon(0:2*npmat_,ntmat_,*), + & plconloc(82),dummy +! + ndata=nplcon(itemp,imat) +! + if(ndata.le.20) then + if(kin.eq.0) then + do k=1,ndata + plconloc(2*k-1)=plcon(2*k,itemp,imat) + plconloc(2*k)=plcon(2*k-1,itemp,imat) + enddo + plconloc(81)=real(ndata)+0.5d0 + else + do k=1,ndata + plconloc(39+2*k)=plcon(2*k,itemp,imat) + plconloc(40+2*k)=plcon(2*k-1,itemp,imat) + enddo + plconloc(82)=real(ndata)+0.5d0 + endif + else + if(kin.eq.0) then + eplmin=plcon(2,itemp,imat) + eplmax=plcon(2*nplcon(itemp,imat),itemp,imat)-1.d-10 + depl=(eplmax-eplmin)/19.d0 + do k=1,20 + epla=eplmin+(k-1)*depl + call plinterpol(plcon,nplcon,itemp, + & plconloc(2*k),dummy,npmat_,ntmat_,imat,nelem,epla) + plconloc(2*k-1)=epla + enddo + plconloc(81)=20.5d0 + else + eplmin=plcon(2,itemp,imat) + eplmax=plcon(2*nplcon(itemp,imat),itemp,imat)-1.d-10 + depl=(eplmax-eplmin)/19.d0 + do k=1,20 + epla=eplmin+(k-1)*depl + call plinterpol(plcon,nplcon,itemp, + & plconloc(40+2*k),dummy,npmat_,ntmat_,imat,nelem,epla) + plconloc(39+2*k)=epla + enddo + endif + plconloc(82)=20.5d0 + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/plinterpol.f calculix-ccx-2.3/ccx_2.3/src/plinterpol.f --- calculix-ccx-2.1/ccx_2.3/src/plinterpol.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/plinterpol.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,61 @@ +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine plinterpol(plcon,nplcon,itemp,f,df,npmat_,ntmat_, + & imat,nelem,epl) +! + implicit none +! +! interpolation of isotropic or kinematic hardening data +! input: hardening data plcon and nplcon, temperature itemp, +! size parameters npmat_ and ntmat_, material number imat +! and equivalent plastic strain at which the coefficients +! are to be determined +! output: hardening coefficient and its local derivative f and df +! + integer npmat_,ntmat_,nplcon(0:ntmat_,*),itemp,ndata,imat,j, + & nelem +! + real*8 plcon(0:2*npmat_,ntmat_,*),f,df,epl +! + ndata=nplcon(itemp,imat) +! + do j=1,ndata + if(epl.lt.plcon(2*j,itemp,imat)) exit + enddo +! + if((j.eq.1).or.(j.gt.ndata)) then + if(j.eq.1) then + f=plcon(1,itemp,imat) + df=0.d0 + else + f=plcon(2*ndata-1,itemp,imat) + df=0.d0 + endif + write(*,*) '*WARNING in plinterpol: plastic strain ',epl + write(*,*) ' outside material plastic strain range' + write(*,*) ' in element ',nelem,' and material ',imat + write(*,*) ' for temperature ',plcon(0,itemp,imat) + else + df=(plcon(2*j-1,itemp,imat)-plcon(2*j-3,itemp,imat))/ + & (plcon(2*j,itemp,imat)-plcon(2*j-2,itemp,imat)) + f=plcon(2*j-3,itemp,imat)+ + & df*(epl-plcon(2*j-2,itemp,imat)) + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/plmix.f calculix-ccx-2.3/ccx_2.3/src/plmix.f --- calculix-ccx-2.1/ccx_2.3/src/plmix.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/plmix.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,205 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine plmix(plcon,nplcon,plconloc,npmat_,ntmat_, + & imat,j,temp,nelem,kin) +! +! interpolates the hardening data for material imat and temperature +! j and j-1 to obtain data for temperature temp. The data is taken +! from plcon and stored in plconloc. +! The Von Mises stress is interpolated for a given equivalent +! plastic strain. If the equivalent strain data points for +! temperature j and j-1 do not coincide, the union of both is +! taken. If this union exceeds 20 (ierror=1), the equivalent plastic +! strain range is divided into 19 intervals yielding 20 new +! equivalent strain data points, for which the Von Mises stress +! is interpolated. +! Attention: in plcon the odd storage spaces contain the Von +! Mises stress, the even ones the equivalent plastic +! strain. For plconloc, this order is reversed. +! + implicit none +! + integer imat,ndata,ntmat_,npmat_,nplcon(0:ntmat_,*),nelem, + & kin,k,j,k1,k2,ierror,ndata1,ndata2,itemp +! + real*8 eplmin,eplmax,depl,epla,plcon(0:2*npmat_,ntmat_,*), + & plconloc(82),dummy,temp,ep1,ep2,t1,t2,s1,s2,ratio +! + ndata=0 + ierror=0 +! + ndata1=nplcon(j-1,imat) + ndata2=nplcon(j,imat) + t1=plcon(0,j-1,imat) + t2=plcon(0,j,imat) + ratio=(temp-t1)/(t2-t1) +! +! the interval on which the stress interpolation is performed +! is the intersection of the domain of the two curves +! + k1=1 + k2=1 + ep1=plcon(2,j-1,imat) + ep2=plcon(2,j,imat) + if(ep1.gt.ep2) then + do k2=1,ndata2 + ep2=plcon(2*k2,j,imat) + if(ep2.gt.ep1) exit + enddo + if(k2.gt.ndata2) then + write(*,*) '*ERROR in plmix: there exist two temperatures' + write(*,*) ' for which the hardening curves are' + write(*,*) ' disjunct' + stop + endif + elseif(ep2.gt.ep1) then + do k1=1,ndata1 + ep1=plcon(2*k1,j-1,imat) + if(ep1.gt.ep2) exit + enddo + if(k1.gt.ndata1) then + write(*,*) '*ERROR in plmix: there exist two temperatures' + write(*,*) ' for which the hardening curves are' + write(*,*) ' disjunct' + stop + endif + endif +! + do + s1=plcon(2*k1-1,j-1,imat) + s2=plcon(2*k2-1,j,imat) + ep1=plcon(2*k1,j-1,imat) + ep2=plcon(2*k2,j,imat) +! + if(dabs(ep1-ep2).lt.1.d-10) then + if(k2.lt.ndata2) then + k2=k2+1 + elseif(k1.lt.ndata1) then + k1=k1+1 + else + ndata=ndata+1 + if(ndata.gt.20) then + ierror=1 + exit + endif + if(kin.eq.0) then + plconloc(2*ndata-1)=ep1+ratio*(ep2-ep1) + plconloc(2*ndata)=s1+ratio*(s2-s1) + else + plconloc(39+2*ndata)=ep1+ratio*(ep2-ep1) + plconloc(40+2*ndata)=s1+ratio*(s2-s1) + endif + exit + endif + cycle + endif + if(ep1.lt.ep2) then + ndata=ndata+1 + if(ndata.gt.20) then + ierror=1 + exit + endif + call plinterpol(plcon,nplcon,j,s2,dummy,npmat_,ntmat_, + & imat,nelem,ep1) + if(kin.eq.0) then + plconloc(2*ndata-1)=ep1 + plconloc(2*ndata)=s1+ratio*(s2-s1) + else + plconloc(39+2*ndata)=ep1 + plconloc(40+2*ndata)=s1+ratio*(s2-s1) + endif + if(k1.lt.ndata1) then + k1=k1+1 + cycle + else + exit + endif + else + ndata=ndata+1 + if(ndata.gt.20) then + ierror=1 + exit + endif + call plinterpol(plcon,nplcon,j-1,s1,dummy,npmat_,ntmat_, + & imat,nelem,ep2) + if(kin.eq.0) then + plconloc(2*ndata-1)=ep2 + plconloc(2*ndata)=s1+ratio*(s2-s1) + else + plconloc(39+2*ndata)=ep2 + plconloc(40+2*ndata)=s1+ratio*(s2-s1) + endif + if(k2.lt.ndata2) then + k2=k2+1 + cycle + else + exit + endif + endif + enddo +! +! if more than 20 data points result, the interval is divided into +! 19 equidistant intervals +! + if(ierror.eq.0) then + if(kin.eq.0) then + plconloc(81)=real(ndata)+0.5d0 + else + plconloc(82)=real(ndata)+0.5d0 + endif + else + if(kin.eq.0) then + eplmin=max(plcon(2,j-1,imat),plcon(2,j,imat)) + eplmax=min(plcon(2*ndata1,j-1,imat),plcon(2*ndata2,j,imat)) + & -1.d-10 + depl=(eplmax-eplmin)/19.d0 + do k=1,20 + epla=eplmin+(k-1)*depl + itemp=j-1 + call plinterpol(plcon,nplcon,itemp,s1, + & dummy,npmat_,ntmat_,imat,nelem,epla) + itemp=j + call plinterpol(plcon,nplcon,itemp,s2, + & dummy,npmat_,ntmat_,imat,nelem,epla) + plconloc(2*k-1)=epla + plconloc(2*k)=s1+ratio*(s2-s1) + enddo + plconloc(81)=20.5d0 + else + eplmin=max(plcon(2,j-1,imat),plcon(2,j,imat)) + eplmax=min(plcon(2*ndata1,j-1,imat),plcon(2*ndata2,j,imat)) + & -1.d-10 + depl=(eplmax-eplmin)/19.d0 + do k=1,20 + epla=eplmin+(k-1)*depl + itemp=j-1 + call plinterpol(plcon,nplcon,itemp,s1, + & dummy,npmat_,ntmat_,imat,nelem,epla) + itemp=j + call plinterpol(plcon,nplcon,itemp,s2, + & dummy,npmat_,ntmat_,imat,nelem,epla) + plconloc(19+2*k)=epla + plconloc(20+2*k)=s1+ratio*(s2-s1) + enddo + plconloc(82)=20.5d0 + endif + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/polynom.f calculix-ccx-2.3/ccx_2.3/src/polynom.f --- calculix-ccx-2.1/ccx_2.3/src/polynom.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/polynom.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,50 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine polynom(x,y,z,p) +! +! calculates the polynomial terms for the Zienkiewicz-Zhu +! stress recovery procedure +! + implicit none +! + real*8 p(20),x,y,z +! + p(1)=1.d0 + p(2)=x + p(3)=y + p(4)=z + p(5)=x*x + p(6)=y*y + p(7)=z*z + p(8)=x*y + p(9)=x*z + p(10)=y*z + p(11)=x*x*y + p(12)=x*y*y + p(13)=x*x*z + p(14)=x*z*z + p(15)=y*y*z + p(16)=y*z*z + p(17)=x*y*z + p(18)=x*x*y*z + p(19)=x*y*y*z + p(20)=x*y*z*z +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/precfd.f calculix-ccx-2.3/ccx_2.3/src/precfd.f --- calculix-ccx-2.1/ccx_2.3/src/precfd.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/precfd.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,650 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine precfd(nelemface,sideface,nface,ipoface,nodface, + & ne,ipkon,kon,lakon,ikboun,ilboun,xboun,nboun,nk,isolidsurf, + & nsolidsurf,ifreestream,nfreestream,neighsolidsurf,iponoel,inoel, + & inoelfree,nef,co,ipompc,nodempc,ikmpc,ilmpc,nmpc) +! +! preliminary calculations for cfd applicatons: +! - determining the external faces of the mesh and storing +! them in fields nelemface and sideface +! - determining the nodes belonging to solid surfaces and +! storing them in isolidsurf (in ascending order) +! - determining the nodes belonging to freestream surfaces +! and storing them in ifreestream (in ascending order) +! - determining the fluid elements belonging to a given node +! and storing them in fields iponoel and inoel +! + implicit none +! + logical solidboun,mpcnode +! + character*1 sideface(*) + character*8 lakon(*) +! + integer nelemface(*),nface,ipoface(*),nodface(5,*),nodes(4), + & ne,ipkon(*),kon(*),indexe,ifaceq(8,6),ifacet(6,4),index, + & ifacew(8,5),ithree,ifour,iaux,kflag,nnodes,ikboun(*), + & ilboun(*),nboun,isolidsurf(*),nsolidsurf,ifreestream(*), + & nfreestream,id,nk,node,idof,i,j,k,l,m,neighsolidsurf(*), + & iponoel(*),noden,idn,nope,nodemin,ifree,nef,indexold, + & inoel(3,*),ifreenew,inoelfree,mpc,ikmpc(*),nmpc, + & nodempc(3,*),ipompc(*),ilmpc(*) +! + real*8 xboun(*),dist,distmin,co(3,*) +! +! nodes belonging to the element faces +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! + kflag=1 + ithree=3 + ifour=4 +! +! determining the external element faces of the fluid mesh +! the faces are catalogued by the three lowes nodes numbers +! in ascending order. ipoface(i) points to a face for which +! node i is the lowest node and nodface(1,ipoface(i)) and +! nodface(2,ipoface(i)) are the next lower ones. +! nodface(3,ipoface(i)) contains the element number, +! nodface(4,ipoface(i)) the face number and nodface(5,ipoface(i)) +! is a pointer to the next surface for which node i is the +! lowest node; if there are no more such surfaces the pointer +! has the value zero +! An external element face is one which belongs to one element +! only +! + ifree=1 + do i=1,6*nef-1 + nodface(5,i)=i+1 + enddo + do i=1,ne + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + indexe=ipkon(i) + if((lakon(i)(4:4).eq.'2').or.(lakon(i)(4:4).eq.'8')) then + do j=1,6 + do k=1,4 + nodes(k)=kon(indexe+ifaceq(k,j)) + enddo + call isortii(nodes,iaux,ifour,kflag) + indexold=0 + index=ipoface(nodes(1)) + do +! +! adding a surface which has not been +! catalogued so far +! + if(index.eq.0) then + ifreenew=nodface(5,ifree) + nodface(1,ifree)=nodes(2) + nodface(2,ifree)=nodes(3) + nodface(3,ifree)=i + nodface(4,ifree)=j +c write(*,*) 'new ',i,j + nodface(5,ifree)=ipoface(nodes(1)) + ipoface(nodes(1))=ifree + ifree=ifreenew + exit + endif +! +! removing a surface which has already +! been catalogued +! + if((nodface(1,index).eq.nodes(2)).and. + & (nodface(2,index).eq.nodes(3))) then + if(indexold.eq.0) then + ipoface(nodes(1))=nodface(5,index) + else + nodface(5,indexold)=nodface(5,index) + endif + nodface(5,index)=ifree +c write(*,*) 'freed ', +c & nodface(3,index),nodface(4,index) + ifree=index + exit + endif + indexold=index + index=nodface(5,index) + enddo + enddo + elseif((lakon(i)(4:4).eq.'4').or.(lakon(i)(4:5).eq.'10')) then + do j=1,4 + do k=1,3 + nodes(k)=kon(indexe+ifacet(k,j)) + enddo + call isortii(nodes,iaux,ithree,kflag) + indexold=0 + index=ipoface(nodes(1)) + do +! +! adding a surface which has not been +! catalogues so far +! + if(index.eq.0) then + ifreenew=nodface(5,ifree) + nodface(1,ifree)=nodes(2) + nodface(2,ifree)=nodes(3) + nodface(3,ifree)=i + nodface(4,ifree)=j + nodface(5,ifree)=ipoface(nodes(1)) + ipoface(nodes(1))=ifree + ifree=ifreenew + exit + endif +! +! removing a surface which has already +! been catalogued +! + if((nodface(1,index).eq.nodes(2)).and. + & (nodface(2,index).eq.nodes(3))) then + if(indexold.eq.0) then + ipoface(nodes(1))=nodface(5,index) + else + nodface(5,indexold)=nodface(5,index) + endif + nodface(5,index)=ifree + ifree=index + exit + endif + indexold=index + index=nodface(5,index) + enddo + enddo + else + do j=1,5 + if(j.le.2) then + do k=1,3 + nodes(k)=kon(indexe+ifacew(k,j)) + enddo + call isortii(nodes,iaux,ithree,kflag) + else + do k=1,4 + nodes(k)=kon(indexe+ifacew(k,j)) + enddo + call isortii(nodes,iaux,ifour,kflag) + endif + indexold=0 + index=ipoface(nodes(1)) + do +! +! adding a surface which has not been +! catalogues so far +! + if(index.eq.0) then + ifreenew=nodface(5,ifree) + nodface(1,ifree)=nodes(2) + nodface(2,ifree)=nodes(3) + nodface(3,ifree)=i + nodface(4,ifree)=j + nodface(5,ifree)=ipoface(nodes(1)) + ipoface(nodes(1))=ifree + ifree=ifreenew + exit + endif +! +! removing a surface which has already +! been catalogued +! + if((nodface(1,index).eq.nodes(2)).and. + & (nodface(2,index).eq.nodes(3))) then + if(indexold.eq.0) then + ipoface(nodes(1))=nodface(5,index) + else + nodface(5,indexold)=nodface(5,index) + endif + nodface(5,index)=ifree + ifree=index + exit + endif + indexold=index + index=nodface(5,index) + enddo + enddo + endif + enddo +! +! storing the external faces in nelemface and sideface +! catalogueing the external nodes in isolidsurf and ifreestream +! +! only the nodes which +! - belong to external faces AND +! - in which all velocity components are set to zero +! by SPC boundary conditions +! are considered as solid surface nodes +! +! all other external face nodes are freestream nodes +! + nface=0 + nsolidsurf=0 + nfreestream=0 +! + do m=1,nk + index=ipoface(m) + do + if(index.eq.0) exit + nface=nface+1 + i=nodface(3,index) + j=nodface(4,index) +c write(*,*) 'zu behandeln ',m,i,j +! + nelemface(nface)=i + write(sideface(nface)(1:1),'(i1)') j +! + indexe=ipkon(i) + if((lakon(i)(4:4).eq.'2').or.(lakon(i)(4:4).eq.'8')) then + if(lakon(i)(4:4).eq.'2') then + nnodes=8 + else + nnodes=4 + endif + do k=1,nnodes +c write(*,*) j,k,ifaceq(k,j),indexe + node=kon(indexe+ifaceq(k,j)) + solidboun=.true. + do l=1,3 + idof=8*(node-1)+l + call nident(ikboun,idof,nboun,id) + if(id.le.0) then + solidboun=.false. + exit + elseif(ikboun(id).ne.idof) then + solidboun=.false. + exit + elseif(dabs(xboun(ilboun(id))).gt.1.d-20) then + solidboun=.false. + exit + endif + enddo + if(solidboun) then + call nident(isolidsurf,node,nsolidsurf,id) + if(id.gt.0) then + if(isolidsurf(id).eq.node) cycle + endif + nsolidsurf=nsolidsurf+1 + do l=nsolidsurf,id+2,-1 + isolidsurf(l)=isolidsurf(l-1) + enddo + isolidsurf(id+1)=node + else + call nident(ifreestream,node,nfreestream,id) + if(id.gt.0) then + if(ifreestream(id).eq.node) cycle + endif + nfreestream=nfreestream+1 + do l=nfreestream,id+2,-1 + ifreestream(l)=ifreestream(l-1) + enddo + ifreestream(id+1)=node + endif + enddo + elseif((lakon(i)(4:4).eq.'4').or.(lakon(i)(4:5).eq.'10')) + & then + if(lakon(i)(4:4).eq.'4') then + nnodes=3 + else + nnodes=6 + endif + do k=1,nnodes + node=kon(indexe+ifacet(k,j)) + solidboun=.true. + do l=1,3 + idof=8*(node-1)+l + call nident(ikboun,idof,nboun,id) + if(id.le.0) then + solidboun=.false. + exit + elseif(ikboun(id).ne.idof) then + solidboun=.false. + exit + elseif(dabs(xboun(ilboun(id))).gt.1.d-20) then + solidboun=.false. + exit + endif + enddo + if(solidboun) then + call nident(isolidsurf,node,nsolidsurf,id) + if(id.gt.0) then + if(isolidsurf(id).eq.node) cycle + endif + nsolidsurf=nsolidsurf+1 + do l=nsolidsurf,id+2,-1 + isolidsurf(l)=isolidsurf(l-1) + enddo + isolidsurf(id+1)=node + else + call nident(ifreestream,node,nfreestream,id) + if(id.gt.0) then + if(ifreestream(id).eq.node) cycle + endif + nfreestream=nfreestream+1 + do l=nfreestream,id+2,-1 + ifreestream(l)=ifreestream(l-1) + enddo + ifreestream(id+1)=node + endif + enddo + else + if(lakon(i)(4:4).eq.'6') then + if(j.le.2) then + nnodes=3 + else + nnodes=4 + endif + else + if(j.le.2) then + nnodes=6 + else + nnodes=8 + endif + endif + do k=1,nnodes + node=kon(indexe+ifacew(k,j)) + solidboun=.true. + do l=1,3 + idof=8*(node-1)+l + call nident(ikboun,idof,nboun,id) + if(id.le.0) then + solidboun=.false. + exit + elseif(ikboun(id).ne.idof) then + solidboun=.false. + exit + elseif(dabs(xboun(ilboun(id))).gt.1.d-20) then + solidboun=.false. + exit + endif + enddo + if(solidboun) then + call nident(isolidsurf,node,nsolidsurf,id) + if(id.gt.0) then + if(isolidsurf(id).eq.node) cycle + endif + nsolidsurf=nsolidsurf+1 + do l=nsolidsurf,id+2,-1 + isolidsurf(l)=isolidsurf(l-1) + enddo + isolidsurf(id+1)=node + else + call nident(ifreestream,node,nfreestream,id) + if(id.gt.0) then + if(ifreestream(id).eq.node) cycle + endif + nfreestream=nfreestream+1 + do l=nfreestream,id+2,-1 + ifreestream(l)=ifreestream(l-1) + enddo + ifreestream(id+1)=node + endif + enddo + endif + index=nodface(5,index) + enddo + enddo +! +! all nodes belonging to MPC's are removed from the +! ifreestream stack +! + do i=1,nmpc + index=ipompc(i) + do + if(index.eq.0) exit + node=nodempc(1,index) + call nident(ifreestream,node,nfreestream,id) + if(id.gt.0) then + if(ifreestream(id).eq.node) then + nfreestream=nfreestream-1 + do j=id,nfreestream + ifreestream(j)=ifreestream(j+1) + enddo + endif + endif + index=nodempc(3,index) + enddo + enddo +! +! storing the in-stream neighbors of the solid surface external +! nodes in neighsolidsurf +! + do m=1,nface + i=nelemface(m) + read(sideface(m)(1:1),'(i1)') j + indexe=ipkon(i) +! + if((lakon(i)(4:4).eq.'2').or.(lakon(i)(4:4).eq.'8')) then + if(lakon(i)(4:4).eq.'2') then + nnodes=8 + nope=20 + else + nnodes=4 + nope=8 + endif + do k=1,nnodes + node=kon(indexe+ifaceq(k,j)) +! +! node must belong to solid surface +! + call nident(isolidsurf,node,nsolidsurf,id) + if(id.le.0) then + cycle + elseif(isolidsurf(id).ne.node) then + cycle + endif +! +! check whether neighbor was already found +! + if(neighsolidsurf(id).ne.0) cycle +! + distmin=1.d30 + nodemin=0 +! + do l=1,nope + noden=kon(indexe+l) +! +! node must not belong to solid surface +! + call nident(isolidsurf,noden,nsolidsurf,idn) + if(idn.gt.0) then + if(isolidsurf(idn).eq.noden) cycle + endif + dist=dsqrt((co(1,node)-co(1,noden))**2+ + & (co(2,node)-co(2,noden))**2+ + & (co(3,node)-co(3,noden))**2) + if(dist.lt.distmin) then + distmin=dist + nodemin=noden + endif + enddo + if(nodemin.ne.0) then + neighsolidsurf(id)=nodemin + endif + enddo + elseif((lakon(i)(4:4).eq.'4').or.(lakon(i)(4:5).eq.'10')) + & then + if(lakon(i)(4:4).eq.'4') then + nnodes=3 + nope=4 + else + nnodes=6 + nope=10 + endif + do k=1,nnodes + node=kon(indexe+ifacet(k,j)) +! +! node must belong to solid surface +! + call nident(isolidsurf,node,nsolidsurf,id) + if(id.le.0) then + cycle + elseif(isolidsurf(id).ne.node) then + cycle + endif +! +! check whether neighbor was already found +! + if(neighsolidsurf(id).ne.0) cycle +! + distmin=1.d30 + nodemin=0 +! + do l=1,nope + noden=kon(indexe+l) +! +! node must not belong to solid surface +! + call nident(isolidsurf,noden,nsolidsurf,idn) + if(idn.gt.0) then + if(isolidsurf(idn).eq.noden) cycle + endif + dist=dsqrt((co(1,node)-co(1,noden))**2+ + & (co(2,node)-co(2,noden))**2+ + & (co(3,node)-co(3,noden))**2) + if(dist.lt.distmin) then + distmin=dist + nodemin=noden + endif + enddo + if(nodemin.ne.0) then + neighsolidsurf(id)=nodemin + endif + enddo + else + if(lakon(i)(4:4).eq.'6') then + nope=6 + if(j.le.2) then + nnodes=3 + else + nnodes=4 + endif + else + nope=15 + if(j.le.2) then + nnodes=6 + else + nnodes=8 + endif + endif + do k=1,nnodes + node=kon(indexe+ifacew(k,j)) + ! +! node must belong to solid surface +! + call nident(isolidsurf,node,nsolidsurf,id) + if(id.le.0) then + cycle + elseif(isolidsurf(id).ne.node) then + cycle + endif +! +! check whether neighbor was already found +! + if(neighsolidsurf(id).ne.0) cycle +! + distmin=1.d30 + nodemin=0 +! + do l=1,nope + noden=kon(indexe+l) +! +! node must not belong to solid surface +! + call nident(isolidsurf,noden,nsolidsurf,idn) + if(idn.gt.0) then + if(isolidsurf(idn).eq.noden) cycle + endif + dist=dsqrt((co(1,node)-co(1,noden))**2+ + & (co(2,node)-co(2,noden))**2+ + & (co(3,node)-co(3,noden))**2) + if(dist.lt.distmin) then + distmin=dist + nodemin=noden + endif + enddo + if(nodemin.ne.0) then + neighsolidsurf(id)=nodemin + endif + enddo + endif + enddo +! +! determining the fluid elements belonging to edge nodes of +! the elements +! + inoelfree=1 + do i=1,ne + if(ipkon(i).lt.0) cycle + if(lakon(i)(1:1).ne.'F') cycle + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + nope=15 + endif + indexe=ipkon(i) + do j=1,nope + node=kon(indexe+j) + inoel(1,inoelfree)=i + inoel(2,inoelfree)=j + inoel(3,inoelfree)=iponoel(node) + iponoel(node)=inoelfree + inoelfree=inoelfree+1 + enddo + enddo +! +! sorting nelemface +! + kflag=2 + call isortic(nelemface,sideface,nface,kflag) +! +c write(*,*) 'nfreestream ',nfreestream +c do i=1,nfreestream +c write(*,*) 'nfreestream ',i,ifreestream(i) +c enddo +c write(*,*) 'nsolidsurf ',nsolidsurf +c do i=1,nsolidsurf +c write(*,*) 'nsolidsurf ',i,isolidsurf(i),neighsolidsurf(i) +c enddo +c write(*,*) 'external faces' +c do i=1,nface +c write(*,*) nelemface(i),sideface(i) +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/prediction.c calculix-ccx-2.3/ccx_2.3/src/prediction.c --- calculix-ccx-2.1/ccx_2.3/src/prediction.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/prediction.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,149 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif + + +void prediction(double *uam, int *nmethod, double *bet, double *gam, + double *dtime, + int *ithermal, int *nk, double *veold, double *accold, double *v, + int *iinc, int *idiscon, double *vold, int *nactdof, int *mi){ + + int j,k,mt=mi[1]+1; + double dextrapol,scal1,scal2; + + uam[0]=0.; + uam[1]=0.; + if(*nmethod==4){ + + scal1=0.5*(1.-2.**bet)**dtime**dtime; + scal2=(1.-*gam)**dtime; + + if(*ithermal<2){ + for(k=0;k<*nk;++k){ + for(j=0;juam[0])&&(nactdof[mt*k+j]>0)) {uam[0]=fabs(dextrapol);} + v[mt*k+j]=vold[mt*k+j]+dextrapol; + veold[mt*k+j]=veold[mt*k+j]+scal2*accold[mt*k+j]; + accold[mt*k+j]=0.; + } + } + }else if(*ithermal==2){ + for(k=0;k<*nk;++k){ + for(j=0;j100.) dextrapol=100.*dextrapol/fabs(dextrapol); + if((fabs(dextrapol)>uam[1])&&(nactdof[mt*k]>0)) {uam[1]=fabs(dextrapol);} + v[mt*k]+=dextrapol; + } + }else{ + for(k=0;k<*nk;++k){ + for(j=0;j100.) dextrapol=100.*dextrapol/fabs(dextrapol); + if(j==0){ + if((fabs(dextrapol)>uam[1])&&(nactdof[mt*k]>0)) {uam[1]=fabs(dextrapol);} + }else{ + if((fabs(dextrapol)>uam[0])&&(nactdof[mt*k+j]>0)) {uam[0]=fabs(dextrapol);} + } + v[mt*k+j]=vold[mt*k+j]+dextrapol; + veold[mt*k+j]=veold[mt*k+j]+scal2*accold[mt*k+j]; + accold[mt*k+j]=0.; + } + } + } + } + + /* for the static case: extrapolation of the previous increment + (if any within the same step) */ + + else{ + if(*iinc>1){ + if(*ithermal<2){ + for(k=0;k<*nk;++k){ + for(j=0;juam[0])&&(nactdof[mt*k+j]>0)) {uam[0]=fabs(dextrapol);} + v[mt*k+j]=vold[mt*k+j]+dextrapol; + }else{ + v[mt*k+j]=vold[mt*k+j]; + } + } + } + }else if(*ithermal==2){ + for(k=0;k<*nk;++k){ + for(j=0;j100.) dextrapol=100.*dextrapol/fabs(dextrapol); + if((fabs(dextrapol)>uam[1])&&(nactdof[mt*k]>0)) {uam[1]=fabs(dextrapol);} + v[mt*k]+=dextrapol; + } + } + }else{ + for(k=0;k<*nk;++k){ + for(j=0;j100.) dextrapol=100.*dextrapol/fabs(dextrapol); + if(j==0){ + if((fabs(dextrapol)>uam[1])&&(nactdof[mt*k+j]>0)) {uam[1]=fabs(dextrapol);} + }else{ + if((fabs(dextrapol)>uam[0])&&(nactdof[mt*k+j]>0)) {uam[0]=fabs(dextrapol);} + } + v[mt*k+j]=vold[mt*k+j]+dextrapol; + }else{ + v[mt*k+j]=vold[mt*k+j]; + } + } + } + } + } + else{ + for(k=0;k<*nk;++k){ + for(j=0;j +#include +#include +#include "CalculiX.h" + +void preiter(double *ad, double **aup, double *b, int **icolp, int **irowp, + int *neq, int *nzs, int *isolver, int *iperturb){ + + int precFlg,niter=5000000,ndim,i,j,k,ier,*icol=NULL,*irow=NULL, + *irow_save=NULL,*icol_save=NULL; + double eps=1.e-4,*u=NULL,*au=NULL; + + if(*neq==0) return; + + /* icol(i) = # subdiagonal nonzeros in column i (i=1,neq) + irow(i) = row number of entry i in au (i=1,nzs) + ad(i) = diagonal term in column i of the matrix + au(i) = subdiagonal nonzero term i; the terms are entered + column per column */ + + au=*aup; + irow=*irowp; + icol=*icolp; + + if(*iperturb>1){ + irow_save=NNEW(int,*nzs); + icol_save=NNEW(int,*neq); + for(i=0;i<*nzs;++i){ + irow_save[i]=irow[i]; + } + for(i=0;i<*neq;++i){ + icol_save[i]=icol[i]; + } + } + + if(*isolver==2) {precFlg=0;} + else {precFlg=3;} + + ndim=*neq+*nzs; + + RENEW(au,double,ndim); + RENEW(irow,int,ndim); + RENEW(icol,int,ndim); + + k=*nzs; + for(i=*neq-1;i>=0;--i){ + for(j=0;j1){ + RENEW(irow,int,*nzs); + RENEW(icol,int,*neq); + for(i=0;i<*nzs;++i){ + irow[i]=irow_save[i]; + } + for(i=0;i<*neq;++i){ + icol[i]=icol_save[i]; + } + free(irow_save);free(icol_save); + } + + *aup=au; + *irowp=irow; + *icolp=icol; + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/presgradient.f calculix-ccx-2.3/ccx_2.3/src/presgradient.f --- calculix-ccx-2.1/ccx_2.3/src/presgradient.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/presgradient.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,204 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine presgradient(iponoel,inoel,sa,sav,nk,dt,shockcoef, + & dtimef,ipkon,kon,lakon,vold,mi,compressible,nmethod,dtl, + & isolidsurf,nsolidsurf,co,euler) +! +! determining measure for the pressure gradient +! +! Ref: The Finite Element Method for Fluid Dynamics, +! O.C. Zienkiewicz, R.L. Taylor & P. Nithiarasu +! 6th edition (2006) ISBN 0 7506 6322 7 +! p. 61 +! + implicit none +! + character*8 lakon(*) +! + integer iponoel(*),inoel(3,*),nk,i,j,index,indexe,nope, + & ipkon(*),kon(*),node,ielem,mi(2),compressible,nmethod, + & isolidsurf(*),nsolidsurf,id,isum,euler +! + real*8 sa(*),sav(*),dt(*),shockcoef,dtimef,ca,sum,xmaxsum,pa, + & vold(0:mi(2),*),dtl(*),co(3,*),dd,v(3),p(3),cosang, + & xmaxshear,sumabs +! +c if(euler.eq.1) then +c! +c! nonviscous (euler): pressure switch is 1 if local +c! maximum or minimum occurs, independent +c! of its size +c! +c do i=1,nk +c if(iponoel(i).le.0) cycle +c sum=0.d0 +c sumabs=0.d0 +c pa=vold(4,i) +c index=iponoel(i) +c do +c ielem=inoel(1,index) +c if(ipkon(ielem).lt.0) cycle +c if(lakon(ielem)(1:1).ne.'F') cycle +c if(lakon(ielem)(4:4).eq.'2') then +c nope=20 +c elseif(lakon(ielem)(4:4).eq.'8') then +c nope=8 +c elseif(lakon(ielem)(4:4).eq.'4') then +c nope=4 +c elseif(lakon(ielem)(4:5).eq.'10') then +c nope=10 +c elseif(lakon(ielem)(4:4).eq.'6') then +c nope=6 +c elseif(lakon(ielem)(4:5).eq.'15') then +c nope=15 +c endif +c indexe=ipkon(ielem) +c do j=1,nope +c node=kon(indexe+j) +c sum=sum+pa-vold(4,node) +c sumabs=sumabs+dabs(pa-vold(4,node)) +c enddo +c index=inoel(3,index) +c if(index.eq.0) exit +c enddo +c if(sumabs.lt.1.d-10) then +c sum=0.d0 +c sumabs=1.d0 +c endif +c sa(i)=dabs(sum)/(sumabs*dt(i)) +c stn(3,i)=dtl(i) +c stn(6,i)=dt(i) +c enddo +c else +c! +c! viscous: pressure switch is calculated based on +c! actual second derivative +c! + xmaxsum=0.d0 + do i=1,nk + if(iponoel(i).le.0) cycle + sum=0.d0 + pa=vold(4,i) + index=iponoel(i) + dd=dsqrt(vold(1,i)**2+vold(2,i)**2+vold(3,i)**2) + if(dd.lt.1.d-10) then + v(1)=1.d0 + v(2)=0.d0 + v(3)=0.d0 + else + v(1)=vold(1,i)/dd + v(2)=vold(2,i)/dd + v(3)=vold(3,i)/dd + endif + do + ielem=inoel(1,index) + if(ipkon(ielem).lt.0) cycle + if(lakon(ielem)(1:1).ne.'F') cycle + if(lakon(ielem)(4:4).eq.'2') then + nope=20 + elseif(lakon(ielem)(4:4).eq.'8') then + nope=8 + elseif(lakon(ielem)(4:4).eq.'4') then + nope=4 + elseif(lakon(ielem)(4:5).eq.'10') then + nope=10 + elseif(lakon(ielem)(4:4).eq.'6') then + nope=6 + elseif(lakon(ielem)(4:5).eq.'15') then + nope=15 + endif + indexe=ipkon(ielem) + do j=1,nope + node=kon(indexe+j) + if(node.eq.i) cycle + p(1)=co(1,node)-co(1,i) + p(2)=co(2,node)-co(2,i) + p(3)=co(3,node)-co(3,i) + dd=dsqrt(p(1)**2+ + & p(2)**2+ + & p(3)**2) + cosang=dabs((p(1)*v(1)+p(2)*v(2)+p(3)*v(3)))/dd + call nident(isolidsurf,node,nsolidsurf,id) + if(id.gt.0) then + if(isolidsurf(id).eq.node) then + sum=sum+2.d0*cosang*(pa-vold(4,node))/dd**2 + cycle + endif + endif + sum=sum+cosang*(pa-vold(4,node))/dd**2 + enddo + index=inoel(3,index) + if(index.eq.0) exit + enddo + sa(i)=dabs(sum) + if(xmaxsum.lt.sa(i)) xmaxsum=sa(i) + enddo +! + if(xmaxsum.lt.1.e-30) xmaxsum=1. +! +! a lower exponent in the next line (but >0) creates +! more smoothing +! + if(euler.eq.1) then +! +! nonviscous: basic smoothing of 0.1 augmented by +! a term dependent on the second pressure derivative +! + do i=1,nk + sa(i)=(0.1d0+0.9d0*(sa(i)/xmaxsum)**(1.d0/2.d0))/dt(i) + enddo + else +! +! viscous: only the second order derivative of the pressure +! is taken +! + do i=1,nk + sa(i)=(sa(i)/xmaxsum)**(1.d0/2.d0)/dt(i) + enddo + endif +c endif +! + if(nmethod.eq.4) then +! +! transient compressible +! + ca=shockcoef*dtimef + do i=1,nk + sa(i)=ca*sa(i) + sav(3*i-2)=sa(i) + sav(3*i-1)=sa(i) + sav(3*i)=sa(i) + enddo + else +! +! steady state compressible +! + do i=1,nk +c ca=shockcoef*dtl(i)*10.d0 +c ca=shockcoef*dtl(i) + ca=shockcoef*dtimef + sa(i)=ca*sa(i) + sav(3*i-2)=sa(i) + sav(3*i-1)=sa(i) + sav(3*i)=sa(i) + enddo + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/prespooles.c calculix-ccx-2.3/ccx_2.3/src/prespooles.c --- calculix-ccx-2.1/ccx_2.3/src/prespooles.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/prespooles.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,356 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif +#ifdef PARDISO + #include "pardiso.h" +#endif + +void prespooles(double *co, int *nk, int *kon, int *ipkon, char *lakon, + int *ne, + int *nodeboun, int *ndirboun, double *xboun, int *nboun, + int *ipompc, int *nodempc, double *coefmpc, char *labmpc, + int *nmpc, + int *nodeforc, int *ndirforc,double *xforc, int *nforc, + int *nelemload, char *sideload, double *xload, + int *nload, + double *ad, double *au, double *b, int *nactdof, + int **icolp, int *jq, int **irowp, int *neq, int *nzl, + int *nmethod, int *ikmpc, int *ilmpc, int *ikboun, + int *ilboun, + double *elcon, int *nelcon, double *rhcon, int *nrhcon, + double *alcon, int *nalcon, double *alzero, int *ielmat, + int *ielorien, int *norien, double *orab, int *ntmat_, + double *t0, double *t1, double *t1old, + int *ithermal,double *prestr, int *iprestr, + double *vold,int *iperturb, double *sti, int *nzs, + int *kode, double *adb, double *aub, + char *filab, double *eme, + int *iexpl, double *plicon, int *nplicon, double *plkcon, + int *nplkcon, + double *xstate, int *npmat_, char *matname, int *isolver, + int *mi, int *ncmat_, int *nstate_, double *cs, int *mcs, + int *nkon, double *ener, double *xbounold, + double *xforcold, double *xloadold, + char *amname, double *amta, int *namta, + int *nam, int *iamforc, int *iamload, + int *iamt1, int *iamboun, double *ttime, char *output, + char *set, int *nset, int *istartset, + int *iendset, int *ialset, int *nprint, char *prlab, + char *prset, int *nener, double *trab, + int *inotr, int *ntrans, double *fmpc, char *cbody, int *ibody, + double *xbody, int *nbody, double *xbodyold, double *tper){ + + char description[13]=" "; + + int *inum=NULL,k,*icol=NULL,*irow=NULL,ielas,icmd=0,istep=1,iinc=1, + mass[2]={0,0}, stiffness=1, buckling=0, rhsi=1, intscheme=0,*ncocon=NULL, + *nshcon=NULL,mode=-1,noddiam=-1,*ipobody=NULL,inewton=0,coriolis=0,iout, + ifreebody,*itg=NULL,ntg=0,symmetryflag=0,inputformat=0,ngraph=1, + mt=mi[1]+1; + + double *stn=NULL,*v=NULL,*een=NULL,cam[5],*xstiff=NULL,*stiini=NULL, + *f=NULL,*fn=NULL,qa[3],*fext=NULL,*epn=NULL,*xstateini=NULL, + *vini=NULL,*stx=NULL,*enern=NULL,*xbounact=NULL,*xforcact=NULL, + *xloadact=NULL,*t1act=NULL,*ampli=NULL,*xstaten=NULL,*eei=NULL, + *enerini=NULL,*cocon=NULL,*shcon=NULL,*physcon=NULL,*qfx=NULL, + *qfn=NULL,sigma=0.,*cgr=NULL,*xbodyact=NULL,*vr=NULL,*vi=NULL, + *stnr=NULL,*stni=NULL,*vmax=NULL,*stnmax=NULL,*springarea=NULL, + *eenmax=NULL; + + int *ipneigh=NULL,*neigh=NULL; + +#ifdef SGI + int token; +#endif + + /* dummy arguments for the results call */ + + double *veold=NULL,*accold=NULL,bet,gam,dtime=1.,time=1.,reltime=1.; + + icol=*icolp; + irow=*irowp; + + /* allocating fields for the actual external loading */ + + xbounact=NNEW(double,*nboun); + for(k=0;k<*nboun;++k){xbounact[k]=xbounold[k];} + xforcact=NNEW(double,*nforc); + xloadact=NNEW(double,2**nload); + xbodyact=NNEW(double,7**nbody); + /* copying the rotation axis and/or acceleration vector */ + for(k=0;k<7**nbody;k++){xbodyact[k]=xbody[k];} + if(*ithermal==1){ + t1act=NNEW(double,*nk); + for(k=0;k<*nk;++k){t1act[k]=t1old[k];} + } + + /* assigning the body forces to the elements */ + + if(*nbody>0){ + ifreebody=*ne+1; + ipobody=NNEW(int,2*ifreebody**nbody); + for(k=1;k<=*nbody;k++){ + FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, + iendset,ialset,&inewton,nset,&ifreebody,&k)); + RENEW(ipobody,int,2*(*ne+ifreebody)); + } + RENEW(ipobody,int,2*(ifreebody-1)); + } + + /* allocating a field for the instantaneous amplitude */ + + ampli=NNEW(double,*nam); + + FORTRAN(tempload,(xforcold,xforc,xforcact,iamforc,nforc,xloadold,xload, + xloadact,iamload,nload,ibody,xbody,nbody,xbodyold,xbodyact, + t1old,t1,t1act,iamt1,nk,amta, + namta,nam,ampli,&time,&reltime,ttime,&dtime,ithermal,nmethod, + xbounold,xboun,xbounact,iamboun,nboun, + nodeboun,ndirboun,nodeforc,ndirforc,&istep,&iinc, + co,vold,itg,&ntg,amname,ikboun,ilboun,nelemload,sideload,mi, + ntrans,trab,inotr,veold)); + *ttime=*ttime+*tper; + + /* determining the internal forces and the stiffness coefficients */ + + f=NNEW(double,*neq); + + /* allocating a field for the stiffness matrix */ + + xstiff=NNEW(double,27*mi[0]**ne); + + iout=-1; + v=NNEW(double,mt**nk); + fn=NNEW(double,mt**nk); + stx=NNEW(double,6*mi[0]**ne); + inum=NNEW(int,*nk); + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1act,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun, + ndirboun,xbounact,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq,veold,accold, + &bet,&gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas, + &icmd,ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern, + sti,xstaten,eei,enerini,cocon,ncocon,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans, + fmpc,nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea, + &reltime)); + free(v);free(fn);free(stx);free(inum); + iout=1; + + /* determining the system matrix and the external forces */ + + ad=NNEW(double,*neq); + au=NNEW(double,*nzs); + fext=NNEW(double,*neq); + + FORTRAN(mafillsm,(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xbounact,nboun, + ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforcact, + nforc,nelemload,sideload,xloadact,nload,xbodyact,ipobody, + nbody,cgr,ad,au,fext,nactdof,icol,jq,irow,neq,nzl,nmethod, + ikmpc,ilmpc,ikboun,ilboun, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_, + t0,t1act,ithermal,prestr,iprestr,vold,iperturb,sti, + nzs,stx,adb,aub,iexpl,plicon,nplicon,plkcon,nplkcon, + xstiff,npmat_,&dtime,matname,mi, + ncmat_,mass,&stiffness,&buckling,&rhsi,&intscheme,physcon, + shcon,nshcon,cocon,ncocon,ttime,&time,&istep,&iinc,&coriolis, + ibody,xloadold,&reltime,veold,springarea,nstate_, + xstateini,xstate)); + + /* determining the right hand side */ + + b=NNEW(double,*neq); + for(k=0;k<*neq;++k){ + b[k]=fext[k]-f[k]; + } + free(fext);free(f); + + if(*nmethod!=0){ + + if(*isolver==0){ +#ifdef SPOOLES + spooles(ad,au,adb,aub,&sigma,b,icol,irow,neq,nzs,&symmetryflag, + &inputformat); +#else + printf("*ERROR in prespooles: the SPOOLES library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if((*isolver==2)||(*isolver==3)){ + preiter(ad,&au,b,&icol,&irow,neq,nzs,isolver,iperturb); + } + else if(*isolver==4){ +#ifdef SGI + token=1; + sgi_main(ad,au,adb,aub,&sigma,b,icol,irow,neq,nzs,token); +#else + printf("*ERROR in prespooles: the SGI library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau(ad,&au,adb,aub,&sigma,b,icol,&irow,neq,nzs); +#else + printf("*ERROR in prespooles: the TAUCS library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_main(ad,au,adb,aub,&sigma,b,icol,irow,neq,nzs); +#else + printf("*ERROR in prespooles: the PARDISO library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + + free(ad);free(au); + + /* calculating the displacements and the stresses and storing */ + /* the results in frd format for each valid eigenmode */ + + v=NNEW(double,mt**nk); + fn=NNEW(double,mt**nk); + stn=NNEW(double,6**nk); + inum=NNEW(int,*nk); + stx=NNEW(double,6*mi[0]**ne); + + if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); + if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); + + eei=NNEW(double,6*mi[0]**ne); + if(*nener==1){ + stiini=NNEW(double,6*mi[0]**ne); + enerini=NNEW(double,mi[0]**ne);} + + FORTRAN(results,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,stx, + elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero,ielmat, + ielorien,norien,orab,ntmat_,t0,t1act,ithermal, + prestr,iprestr,filab,eme,een,iperturb, + f,fn,nactdof,&iout,qa,vold,b,nodeboun,ndirboun,xbounact,nboun,ipompc, + nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq,veold,accold,&bet, + &gam,&dtime,&time,ttime,plicon,nplicon,plkcon,nplkcon, + xstateini,xstiff,xstate,npmat_,epn,matname,mi,&ielas,&icmd, + ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, + xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + nelemload,nload,ikmpc,ilmpc,&istep,&iinc,springarea,&reltime)); + + free(eei); + if(*nener==1){ + free(stiini);free(enerini);} + + memcpy(&vold[0],&v[0],sizeof(double)*mt**nk); + memcpy(&sti[0],&stx[0],sizeof(double)*6*mi[0]**ne); +/* for(k=0;k0){ + frdcyc(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, + fn,ttime,epn,ielmat,matname,cs,mcs,nkon,enern,xstaten, + nstate_,&istep,&iinc,iperturb,ener,mi,output,ithermal, + qfn,ialset,istartset,iendset,trab,inotr,ntrans,orab, + ielorien,norien,sti,veold,&noddiam,set,nset); + } + else{ + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); + } + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, + fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_,&istep,&iinc, + iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, + set,nset,istartset,iendset,ialset,eenmax)); + if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} + } + + free(v);free(stn);free(inum); + free(b);free(stx);free(fn); + + if(strcmp1(&filab[261],"E ")==0) free(een); + if(strcmp1(&filab[522],"ENER")==0) free(enern); + + } + else { + + /* error occurred in mafill: storing the geometry in frd format */ + + ++*kode; + inum=NNEW(int,*nk);for(k=0;k<*nk;k++) inum[k]=1; + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); + } + FORTRAN(out,(co,nk,kon,ipkon,lakon,ne,v,stn,inum,nmethod,kode,filab,een,t1, + fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_,&istep,&iinc, + iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,sti,vr,vi,stnr,stni,vmax,stnmax,&ngraph,veold,ne,cs, + set,nset,istartset,iendset,ialset,eenmax)); + if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} + free(inum);FORTRAN(stop,()); + + } + + /* updating the loading at the end of the step; + important in case the amplitude at the end of the step + is not equal to one */ + + for(k=0;k<*nboun;++k){xbounold[k]=xbounact[k];} + for(k=0;k<*nforc;++k){xforcold[k]=xforcact[k];} + for(k=0;k<2**nload;++k){xloadold[k]=xloadact[k];} + for(k=0;k<7**nbody;k=k+7){xbodyold[k]=xbodyact[k];} + if(*ithermal==1){ + for(k=0;k<*nk;++k){t1old[k]=t1act[k];} + for(k=0;k<*nk;++k){vold[mt*k]=t1act[k];} + } + + free(xbounact);free(xforcact);free(xloadact);free(t1act);free(ampli); + free(xbodyact);if(*nbody>0) free(ipobody);free(xstiff); + + *icolp=icol; + *irowp=irow; + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/pretensionsections.f calculix-ccx-2.3/ccx_2.3/src/pretensionsections.f --- calculix-ccx-2.1/ccx_2.3/src/pretensionsections.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pretensionsections.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,758 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine pretensionsections(inpc,textpart,ipompc,nodempc, + & coefmpc,nmpc,nmpc_,mpcfree,nk,ikmpc,ilmpc, + & labmpc,istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc,lakon, + & kon,ipkon,set,nset,istartset,iendset,ialset,co,ics,dcs) +! +! reading the input deck: *PRE-TENSION SECTION +! + implicit none +! + logical twod +! + character*1 inpc(*) + character*8 lakon(*) + character*20 labmpc(*) + character*81 surface,set(*) + character*132 textpart(16) +! + integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,istep,istat, + & n,i,j,key,nk,node,ifacequad(3,4),ifacetria(3,3),npt, + & mpcfreeold,ikmpc(*),ilmpc(*),id,idof,iline,ipol,inl, + & ipoinp(2,*),inp(3,*),ipoinpc(0:*),irefnode,lathyp(3,6),inum, + & jn,jt,jd,iside,nelem,jface,nopes,nface,nodef(8),nodel(8), + & ifaceq(8,6),ifacet(6,4),ifacew1(4,5),ifacew2(8,5),indexpret, + & k,ipos,nkold,nope,m,kon(*),ipkon(*),indexe,iset,nset,idir, + & istartset(*),iendset(*),ialset(*),index1,ics(2,*),mpcpret, + & mint,iflag +! + real*8 coefmpc(*),xn(3),xt(3),xd(3),dd,co(3,*),dcs(*),area, + & areanodal(8),xl2(3,8),xi,et,weight,shp2(7,8), + & xs2(3,2),xsj2(3),xsj +! + include "gauss.f" +! +! latin hypercube positions in a 3 x 3 matrix +! + data lathyp /1,2,3,1,3,2,2,1,3,2,3,1,3,1,2,3,2,1/ +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! +! nodes per face for quad elements +! + data ifacequad /1,5,2, + & 2,6,3, + & 3,7,4, + & 4,8,1/ +! +! nodes per face for tria elements +! + data ifacetria /1,4,2, + & 2,5,3, + & 3,6,1/ +! +! flag for shape functions +! + data iflag /2/ +! + if(istep.gt.0) then + write(*,*) '*ERROR in pretensionsections.f: *EQUATION should' + write(*,*) ' be placed before all step definitions' + stop + endif +! + do i=2,n + if(textpart(i)(1:8).eq.'SURFACE=') then + surface=textpart(i)(9:88) + ipos=index(surface,' ') + surface(ipos:ipos)='T' + elseif(textpart(i)(1:5).eq.'NODE=') then + read(textpart(i)(6:15),'(i10)',iostat=istat) irefnode + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if((irefnode.gt.nk).or.(irefnode.le.0)) then + write(*,*) '*ERROR in pretensionsections.f:' + write(*,*) ' node ',irefnode,' is not defined' + stop + endif + else + write(*,*) + & '*WARNING in pretensionsections: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! checking whether the surface exists and is an element face +! surface +! + iset=0 + do i=1,nset + if(set(i).eq.surface) then + iset=i + exit + endif + enddo + if(iset.eq.0) then + write(*,*) '*ERROR in pretensionsections: nonexistent surface' + write(*,*) ' or surface consists of nodes' + call inputerror(inpc,ipoinpc,iline) + endif +! +! reading the normal vector and normalizing +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + do i=1,3 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) xn(i) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + dd=dsqrt(xn(1)*xn(1)+xn(2)*xn(2)+xn(3)*xn(3)) + do i=1,3 + xn(i)=xn(i)/dd + enddo +! +! finding a unit vector xt perpendicular to the normal vector +! using a unit vector in x or in y +! + if(dabs(xn(1)).lt.0.95d0) then + xt(1)=1.d0-xn(1)*xn(1) + xt(2)=-xn(1)*xn(2) + xt(3)=-xn(1)*xn(3) + else + xt(1)=-xn(2)*xn(1) + xt(2)=1.d0-xn(2)*xn(2) + xt(3)=-xn(2)*xn(3) + endif + dd=dsqrt(xt(1)*xt(1)+xt(2)*xt(2)+xt(3)*xt(3)) + do i=1,3 + xt(i)=xt(i)/dd + enddo +! +! xd=xn x xt +! + xd(1)=xn(2)*xt(3)-xn(3)*xt(2) + xd(2)=xn(3)*xt(1)-xn(1)*xt(3) + xd(3)=xn(1)*xt(2)-xn(2)*xt(1) +! +! generating a Latin hypercube +! checking which DOF's of xn, xt and xd are nonzero +! + do inum=1,6 + if((dabs(xn(lathyp(1,inum))).gt.1.d-3).and. + & (dabs(xt(lathyp(2,inum))).gt.1.d-3).and. + & (dabs(xd(lathyp(3,inum))).gt.1.d-3)) exit + enddo + jn=lathyp(1,inum) + jt=lathyp(2,inum) + jd=lathyp(3,inum) +! +! generating the MPCs +! + indexpret=0 + nkold=nk + m=iendset(iset)-istartset(iset)+1 +! +! number of distinct pre-strain nodes for the present keyword +! + npt=0 + area=0.d0 +! +! loop over all element faces belonging to the surface +! + do k=1,m + twod=.false. + iside=ialset(istartset(iset)+k-1) + nelem=int(iside/10.d0) + indexe=ipkon(nelem) + jface=iside-10*nelem +! +! nodes: #nodes in the face +! the nodes are stored in nodef(*) +! + if(lakon(nelem)(4:4).eq.'2') then + nopes=8 + nface=6 + elseif(lakon(nelem)(3:4).eq.'D8') then + nopes=4 + nface=6 + elseif(lakon(nelem)(4:5).eq.'10') then + nopes=6 + nface=4 + nope=10 + elseif(lakon(nelem)(4:4).eq.'4') then + nopes=3 + nface=4 + nope=4 + elseif(lakon(nelem)(4:5).eq.'15') then + if(jface.le.2) then + nopes=6 + else + nopes=8 + endif + nface=5 + nope=15 + elseif(lakon(nelem)(3:4).eq.'D6') then + if(jface.le.2) then + nopes=3 + else + nopes=4 + endif + nface=5 + nope=6 + elseif((lakon(nelem)(2:2).eq.'8').or. + & (lakon(nelem)(4:4).eq.'8')) then +! +! 8-node 2-D elements +! + nopes=3 + nface=4 + nope=8 + if(lakon(nelem)(4:4).eq.'8') then + twod=.true. + jface=jface-2 + endif + elseif((lakon(nelem)(2:2).eq.'6').or. + & (lakon(nelem)(4:4).eq.'6')) then +! +! 6-node 2-D elements +! + nopes=3 + nface=3 + if(lakon(nelem)(4:4).eq.'6') then + twod=.true. + jface=jface-2 + endif + else + cycle + endif +! +! determining the nodes of the face +! + if(nface.eq.3) then + do i=1,nopes + nodef(i)=kon(indexe+ifacetria(i,jface)) + nodel(i)=ifacetria(i,jface) + enddo + elseif(nface.eq.4) then + if(nope.eq.8) then + do i=1,nopes + nodef(i)=kon(indexe+ifacequad(i,jface)) + nodel(i)=ifacequad(i,jface) + enddo + else + do i=1,nopes + nodef(i)=kon(indexe+ifacet(i,jface)) + nodel(i)=ifacet(i,jface) + enddo + endif + elseif(nface.eq.5) then + if(nope.eq.6) then + do i=1,nopes + nodef(i)=kon(indexe+ifacew1(i,jface)) + nodel(i)=ifacew1(i,jface) + enddo + elseif(nope.eq.15) then + do i=1,nopes + nodef(i)=kon(indexe+ifacew2(i,jface)) + nodel(i)=ifacew2(i,jface) + enddo + endif + elseif(nface.eq.6) then + do i=1,nopes + nodef(i)=kon(indexe+ifaceq(i,jface)) + nodel(i)=ifaceq(i,jface) + enddo + endif +! +! loop over the nodes belonging to the face +! ics(1,*): pretension node +! ics(2,*): corresponding partner node +! dcs(*): area corresponding to pretension node +! + do i=1,nopes + node=nodef(i) + call nident2(ics,node,npt,id) + if(id.gt.0) then + if(ics(1,id).eq.node) then +! +! node was already treated: replacing the node +! by the partner node +! + kon(indexe+nodel(i))=ics(2,id) + cycle + endif + endif +! +! generating a partner node +! + nk=nk+1 +! +! coordinates for the new node +! + do j=1,3 + co(j,nk)=co(j,node) + enddo +! +! updating the topology +! + kon(indexe+nodel(i))=nk +! +! updating ics +! + npt=npt+1 + do j=npt,id+2,-1 + ics(1,j)=ics(1,j-1) + ics(2,j)=ics(2,j-1) + dcs(j)=dcs(j-1) + enddo + ics(1,id+1)=node + ics(2,id+1)=nk + dcs(id+1)=0.d0 +! +! first MPC perpendicular to the normal direction +! + idof=8*(nk-1)+jt + call nident(ikmpc,idof,nmpc,id) +! + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in equations: increase nmpc_' + stop + endif + ipompc(nmpc)=mpcfree + labmpc(nmpc)=' ' +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + idir=jt + if(dabs(xt(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-xt(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xt(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-xt(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xt(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-xt(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=jt + if(dabs(xt(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=jt + coefmpc(mpcfree)=xt(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xt(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xt(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xt(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xt(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif + nodempc(3,mpcfreeold)=0 +! +! second MPC perpendicular to the normal direction +! + if(.not.twod) then + idof=8*(nk-1)+jd + call nident(ikmpc,idof,nmpc,id) +! + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in equations: increase nmpc_' + stop + endif + labmpc(nmpc)=' ' + ipompc(nmpc)=mpcfree +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + idir=jd + if(dabs(xd(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-xd(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xd(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-xd(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xd(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-xd(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=jd + if(dabs(xd(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xd(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xd(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xd(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xd(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xd(idir) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + endif + nodempc(3,mpcfreeold)=0 + endif +! +! MPC in normal direction +! +! check whether initialized +! + if(indexpret.eq.0) then + idof=8*(nk-1)+jn + call nident(ikmpc,idof,nmpc,id) +! + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in equations: increase nmpc_' + stop + endif + labmpc(nmpc)='PRETENSION ' + ipompc(nmpc)=mpcfree + mpcpret=nmpc +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + else + nodempc(3,indexpret)=mpcfree + endif +! + idir=jn + if(dabs(xn(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-xn(idir) + indexpret=mpcfree + mpcfree=nodempc(3,mpcfree) +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xn(idir) + indexpret=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xn(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-xn(idir) + indexpret=mpcfree + mpcfree=nodempc(3,mpcfree) +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xn(idir) + indexpret=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + idir=idir+1 + if(idir.eq.4) idir=1 + if(dabs(xn(idir)).gt.1.d-10) then + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=-xn(idir) + indexpret=mpcfree + mpcfree=nodempc(3,mpcfree) +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=idir + coefmpc(mpcfree)=xn(idir) + indexpret=mpcfree + mpcfree=nodempc(3,mpcfree) + endif +! + enddo +! +! calculating the area of the face and its contributions +! to the facial nodes +! +! number of integration points +! + if(lakon(nelem)(3:5).eq.'D8R') then + mint=1 + elseif(lakon(nelem)(3:4).eq.'D8') then + mint=4 + elseif(lakon(nelem)(4:6).eq.'20R') then + mint=4 + elseif(lakon(nelem)(4:4).eq.'2') then + mint=9 + elseif(lakon(nelem)(4:5).eq.'10') then + mint=3 + elseif(lakon(nelem)(4:4).eq.'4') then + mint=1 + elseif(lakon(nelem)(3:4).eq.'D6') then + mint=1 + elseif(lakon(nelem)(4:5).eq.'15') then + if(jface.le.2) then + mint=3 + else + mint=4 + endif +! +! faces of 2-D elements +! + elseif((lakon(nelem)(3:3).eq.'R').or. + & (lakon(nelem)(5:5).eq.'R')) then + mint=2 + else + mint=3 + endif +! + do i=1,nopes + areanodal(i)=0.d0 + do j=1,3 + xl2(j,i)=co(j,nodef(i)) + enddo + enddo +! + do m=1,mint + if((lakon(nelem)(3:5).eq.'D8R').or. + & ((lakon(nelem)(3:4).eq.'D6').and.(nopes.eq.4))) then + xi=gauss2d1(1,m) + et=gauss2d1(2,m) + weight=weight2d1(m) + elseif((lakon(nelem)(3:4).eq.'D8').or. + & (lakon(nelem)(4:6).eq.'20R').or. + & ((lakon(nelem)(4:5).eq.'15').and. + & (nopes.eq.8))) then + xi=gauss2d2(1,m) + et=gauss2d2(2,m) + weight=weight2d2(m) + elseif(lakon(nelem)(4:4).eq.'2') then + xi=gauss2d3(1,m) + et=gauss2d3(2,m) + weight=weight2d3(m) + elseif((lakon(nelem)(4:5).eq.'10').or. + & ((lakon(nelem)(4:5).eq.'15').and. + & (nopes.eq.6))) then + xi=gauss2d5(1,m) + et=gauss2d5(2,m) + weight=weight2d5(m) + elseif((lakon(nelem)(4:4).eq.'4').or. + & ((lakon(nelem)(3:4).eq.'D6').and. + & (nopes.eq.3))) then + xi=gauss2d4(1,m) + et=gauss2d4(2,m) + weight=weight2d4(m) +! +! faces of 2-D elements +! + elseif((lakon(nelem)(3:3).eq.'R').or. + & (lakon(nelem)(5:5).eq.'R')) then + xi=gauss1d2(1,m) + weight=weight1d2(m) + else + xi=gauss1d3(1,m) + weight=weight1d3(m) + endif +! + if(nopes.eq.8) then + call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif((nopes.eq.3).and.(.not.twod)) then + call shape3tri(xi,xl2,xsj,xs2,shp2,iflag) + else +! +! 3-node line +! + call shape3l(xi,xl2,xsj2,xs2,shp2,iflag) + endif +! +! calculating the total area and nodal area +! + if(.not.twod) then + xsj=weight*dsqrt(xsj2(1)**2+xsj2(2)**2+xsj2(3)**2) + else + xsj=weight*xsj2(1) + endif + area=area+xsj + do i=1,nopes + areanodal(i)=areanodal(i)+xsj*shp2(4,i) + enddo +! + enddo +! +! inserting the nodal area into field dcs +! + do i=1,nopes + node=nodef(i) + call nident2(ics,node,npt,id) + dcs(id)=dcs(id)+areanodal(i) + enddo +! + enddo +! + nodempc(3,indexpret)=mpcfree + nodempc(1,mpcfree)=irefnode + nodempc(2,mpcfree)=1 + coefmpc(mpcfree)=area + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 +! +! changing the coefficients of the pretension MPC +! + index1=ipompc(mpcpret) + do + node=nodempc(1,nodempc(3,index1)) + call nident2(ics,node,npt,id) + do j=1,2 + coefmpc(index1)=coefmpc(index1)*dcs(id) + index1=nodempc(3,index1) + enddo + if(nodempc(1,index1).eq.irefnode) exit + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! +c do i=1,nmpc +c call writempc(ipompc,nodempc,coefmpc,labmpc,i) +c enddo +c do i=1,nmpc +c write(*,*) i,ikmpc(i),ilmpc(i) +c enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/printoutelem.f calculix-ccx-2.3/ccx_2.3/src/printoutelem.f --- calculix-ccx-2.1/ccx_2.3/src/printoutelem.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/printoutelem.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,189 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine printoutelem(prlab,ipkon,lakon,kon,co, + & ener,mi,ii,nelem,energytot,volumetot,enerkintot,nkin,ne, + & stx,nodes) +! +! stores whole element results for element "nelem" in the .dat file +! + implicit none +! + character*6 prlab(*) + character*8 lakon(*) +! + integer ipkon(*),nelem,ii,kon(*),mi(2),nope,indexe,j,k,konl(20), + & mint3d,jj,nener,iflag,nkin,ne,nodes +! + real*8 ener(mi(1),*),energytot,volumetot,energy,volume,co(3,*), + & xl(3,20),xi,et,ze,xsj,shp(4,20),weight,enerkintot,enerkin, + & stx(6,mi(1),*) +! + include "gauss.f" +! + data iflag /2/ +! + if(ipkon(nelem).lt.0) return +! + if((prlab(ii)(1:4).eq.'ELSE').or.(prlab(ii)(1:4).eq.'CELS')) then + nener=1 + else + nener=0 + endif +! + indexe=ipkon(nelem) +! + if(lakon(nelem)(4:4).eq.'2') then + nope=20 + elseif(lakon(nelem)(4:4).eq.'8') then + nope=8 + elseif(lakon(nelem)(4:5).eq.'10') then + nope=10 + elseif(lakon(nelem)(4:4).eq.'4') then + nope=4 + elseif(lakon(nelem)(4:5).eq.'15') then + nope=15 + elseif(lakon(nelem)(4:5).eq.'6') then + nope=6 + else + nope=0 + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + do k=1,3 + xl(k,j)=co(k,konl(j)) + enddo + enddo +! + energy=0.d0 + volume=0.d0 + enerkin=0.d0 +! + if(lakon(nelem)(4:5).eq.'8R') then + mint3d=1 + elseif((lakon(nelem)(4:4).eq.'8').or. + & (lakon(nelem)(4:6).eq.'20R')) then + mint3d=8 + elseif(lakon(nelem)(4:4).eq.'2') then + mint3d=27 + elseif(lakon(nelem)(4:5).eq.'10') then + mint3d=4 + elseif(lakon(nelem)(4:4).eq.'4') then + mint3d=1 + elseif(lakon(nelem)(4:5).eq.'15') then + mint3d=9 + elseif(lakon(nelem)(4:5).eq.'6') then + mint3d=2 + else + if(nener.eq.1)then + energy=ener(1,nelem) + endif + mint3d=0 + endif +! + do jj=1,mint3d + if(lakon(nelem)(4:5).eq.'8R') then + xi=gauss3d1(1,jj) + et=gauss3d1(2,jj) + ze=gauss3d1(3,jj) + weight=weight3d1(jj) + elseif((lakon(nelem)(4:4).eq.'8').or. + & (lakon(nelem)(4:6).eq.'20R')) + & then + xi=gauss3d2(1,jj) + et=gauss3d2(2,jj) + ze=gauss3d2(3,jj) + weight=weight3d2(jj) + elseif(lakon(nelem)(4:4).eq.'2') then + xi=gauss3d3(1,jj) + et=gauss3d3(2,jj) + ze=gauss3d3(3,jj) + weight=weight3d3(jj) + elseif(lakon(nelem)(4:5).eq.'10') then + xi=gauss3d5(1,jj) + et=gauss3d5(2,jj) + ze=gauss3d5(3,jj) + weight=weight3d5(jj) + elseif(lakon(nelem)(4:4).eq.'4') then + xi=gauss3d4(1,jj) + et=gauss3d4(2,jj) + ze=gauss3d4(3,jj) + weight=weight3d4(jj) + elseif(lakon(nelem)(4:5).eq.'15') then + xi=gauss3d8(1,jj) + et=gauss3d8(2,jj) + ze=gauss3d8(3,jj) + weight=weight3d8(jj) + else + xi=gauss3d7(1,jj) + et=gauss3d7(2,jj) + ze=gauss3d7(3,jj) + weight=weight3d7(jj) + endif +! + if(nope.eq.20) then + call shape20h(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.8) then + call shape8h(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.10) then + call shape10tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.4) then + call shape4tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.15) then + call shape15w(xi,et,ze,xl,xsj,shp,iflag) + else + call shape6w(xi,et,ze,xl,xsj,shp,iflag) + endif +! + if(nener.eq.1) energy=energy+weight*xsj*ener(jj,nelem) + if(nkin.eq.1) enerkin=enerkin+weight*xsj*ener(jj,nelem+ne) + volume=volume+weight*xsj + enddo +! + volumetot=volumetot+volume + if(nener.eq.1) energytot=energytot+energy + if(nkin.eq.1) enerkintot=enerkintot+enerkin +! +! writing to file +! + if((prlab(ii)(1:5).eq.'ELSE ').or. + & (prlab(ii)(1:5).eq.'ELSET')) then + write(5,'(i6,1p,1x,e11.4)') nelem,energy + elseif((prlab(ii)(1:5).eq.'CELS ').or. + & (prlab(ii)(1:5).eq.'CELST')) then + write(5,'(i6,1p,1x,e11.4)') nodes,energy + elseif((prlab(ii)(1:5).eq.'CDIS ').or. + & (prlab(ii)(1:5).eq.'CDIST')) then + write(5,'(i6,1p,1x,e11.4,1p,1x,e11.4,1p,1x,e11.4)') nodes, + & stx(1,1,nelem),stx(2,1,nelem),stx(3,1,nelem) + elseif((prlab(ii)(1:5).eq.'CSTR ').or. + & (prlab(ii)(1:5).eq.'CSTRT')) then + write(5,'(i6,1p,1x,e11.4,1p,1x,e11.4,1p,1x,e11.4)') nodes, + & stx(4,1,nelem),stx(5,1,nelem),stx(6,1,nelem) + elseif((prlab(ii)(1:5).eq.'EVOL ').or. + & (prlab(ii)(1:5).eq.'EVOLT')) then + write(5,'(i6,1p,1x,e11.4)') nelem,volume + elseif((prlab(ii)(1:5).eq.'ELKE ').or. + & (prlab(ii)(1:5).eq.'ELKET')) then + write(5,'(i6,1p,1x,e11.4)') nelem,enerkin + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/printout.f calculix-ccx-2.3/ccx_2.3/src/printout.f --- calculix-ccx-2.1/ccx_2.3/src/printout.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/printout.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,439 @@ + +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine printout(set,nset,istartset,iendset,ialset,nprint, + & prlab,prset,v,t1,fn,ipkon,lakon,stx,eme,xstate,ener, + & mi,nstate_,ithermal,co,kon,qfx,ttime,trab,inotr,ntrans, + & orab,ielorien,norien,nk,ne,inum,filab,vold,ikin) +! +! stores results in the .dat file +! + implicit none +! + logical force +! + character*1 cflag + character*6 prlab(*) + character*8 lakon(*) + character*80 noset,elset + character*81 set(*),prset(*) + character*87 filab(*) +! + integer nset,istartset(*),iendset(*),ialset(*),nprint,ipkon(*), + & mi(2),nstate_,ii,jj,iset,l,lb,limit,node,ipos,ithermal, + & nelem,kon(*),inotr(2,*),ntrans,ielorien(*),norien,nk,ne, + & inum(*),nfield,ikin,nodes,ne0,nope,mt +! + real*8 v(0:mi(2),*),t1(*),fn(0:mi(2),*),stx(6,mi(1),*), + & eme(6,mi(1),*),xstate(nstate_,mi(1),*),ener(mi(1),*),energytot, + & volumetot,co(3,*),qfx(3,mi(1),*),rftot(0:3),ttime, + & trab(7,*),orab(7,*),vold(0:mi(2),*),enerkintot +! + mt=mi(2)+1 +! +! interpolation in the original nodes of 1d and 2d elements +! + do ii=1,nprint + if((prlab(ii)(1:4).eq.'U ').or. + & ((prlab(ii)(1:4).eq.'NT ').and.(ithermal.gt.1))) then + if(filab(1)(5:5).ne.' ') then + nfield=mt + cflag=' ' + force=.false. + call map3dto1d2d(v,ipkon,inum,kon,lakon,nfield,nk, + & ne,cflag,co,vold,force,mi) + endif + exit + endif + enddo + do ii=1,nprint + if((prlab(ii)(1:4).eq.'NT ').and.(ithermal.le.1)) then + if(filab(2)(5:5).ne.' ') then + nfield=1 + cflag=' ' + force=.false. + call map3dto1d2d(t1,ipkon,inum,kon,lakon,nfield,nk, + & ne,cflag,co,vold,force,mi) + endif + exit + endif + enddo + do ii=1,nprint + if(prlab(ii)(1:2).eq.'RF') then + if(filab(1)(5:5).ne.' ') then + nfield=mt + cflag=' ' + force=.true. + call map3dto1d2d(fn,ipkon,inum,kon,lakon,nfield,nk, + & ne,cflag,co,vold,force,mi) + endif + exit + endif + enddo +! + do ii=1,nprint +! +! nodal values +! + if((prlab(ii)(1:4).eq.'U ').or.(prlab(ii)(1:4).eq.'NT ').or. + & (prlab(ii)(1:4).eq.'RF ').or.(prlab(ii)(1:4).eq.'RFL ').or. + & (prlab(ii)(1:4).eq.'PS ').or.(prlab(ii)(1:4).eq.'PN ').or. + & (prlab(ii)(1:4).eq.'MF ').or.(prlab(ii)(1:4).eq.'V ')) + & then +! + ipos=index(prset(ii),' ') + noset=' ' + noset(1:ipos-1)=prset(ii)(1:ipos-1) +! +! printing the header +! + if(prlab(ii)(1:4).eq.'U ') then + write(5,*) + write(5,100) noset(1:ipos-2),ttime + 100 format(' displacements (vx,vy,vz) for set ',A, + & ' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'NT ') then + write(5,*) + write(5,101) noset(1:ipos-2),ttime + 101 format(' temperatures for set ',A,' and time ',e14.7) + write(5,*) + elseif((prlab(ii)(1:5).eq.'RF ').or. + & (prlab(ii)(1:5).eq.'RF T')) then + write(5,*) + write(5,102) noset(1:ipos-2),ttime + 102 format(' forces (fx,fy,fz) for set ',A, + & ' and time ',e14.7) + write(5,*) + elseif((prlab(ii)(1:5).eq.'RFL ').or. + & (prlab(ii)(1:5).eq.'RFL T')) then + write(5,*) + write(5,103) noset(1:ipos-2),ttime + 103 format(' heat generation for set ',A,' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'PS ') then + write(5,*) + write(5,115) noset(1:ipos-2),ttime + 115 format(' static pressures for set ',A,' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'PN ') then + write(5,*) + write(5,117) noset(1:ipos-2),ttime + 117 format(' network pressures (total pressure for gases, sta + &tic pressure for liquids and fluid depth for channels) for set ', + &A,' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'MF ') then + write(5,*) + write(5,118) noset(1:ipos-2),ttime + 118 format(' mass flows for set ',A,' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'V ') then + write(5,*) + write(5,119) noset(1:ipos-2),ttime + 119 format(' velocities (vx,vy,vz) for set ',A, + & ' and time ',e14.7) + write(5,*) + endif +! +! printing the data +! + do iset=1,nset + if(set(iset).eq.prset(ii)) exit + enddo + do jj=0,3 + rftot(jj)=0.d0 + enddo + do jj=istartset(iset),iendset(iset) + if(ialset(jj).lt.0) cycle + if(jj.eq.iendset(iset)) then + node=ialset(jj) + call printoutnode(prlab,v,t1,fn,ithermal,ii,node, + & rftot,trab,inotr,ntrans,co,mi) + elseif(ialset(jj+1).gt.0) then + node=ialset(jj) + call printoutnode(prlab,v,t1,fn,ithermal,ii,node, + & rftot,trab,inotr,ntrans,co,mi) + else + do node=ialset(jj-1)-ialset(jj+1),ialset(jj), + & -ialset(jj+1) + call printoutnode(prlab,v,t1,fn,ithermal,ii,node, + & rftot,trab,inotr,ntrans,co,mi) + enddo + endif + enddo +! +! writing total values to file +! + if((prlab(ii)(1:5).eq.'RF O').or. + & (prlab(ii)(1:5).eq.'RF T')) then + write(5,*) + write(5,104) noset(1:ipos-2),ttime + 104 format(' total force (fx,fy,fz) for set ',A, + & ' and time ',e14.7) + write(5,*) + write(5,'(6x,1p,3(1x,e11.4))') rftot(1),rftot(2),rftot(3) + elseif((prlab(ii)(1:5).eq.'RFL O').or. + & (prlab(ii)(1:5).eq.'RFL T')) then + write(5,*) + write(5,105)noset(1:ipos-2),ttime + 105 format(' total heat generation for set ',A, + & ' and time ',e14.7) + write(5,*) + write(5,'(6x,1p,1x,e11.4)') rftot(0) + endif +! +! integration point values +! + elseif((prlab(ii)(1:4).eq.'S ').or. + & (prlab(ii)(1:4).eq.'E ').or. + & (prlab(ii)(1:4).eq.'PEEQ').or. + & (prlab(ii)(1:4).eq.'ENER').or. + & (prlab(ii)(1:4).eq.'SDV ').or. + & (prlab(ii)(1:4).eq.'HFL ')) then +! + ipos=index(prset(ii),' ') + elset=' ' + elset(1:ipos-1)=prset(ii)(1:ipos-1) +! + limit=1 +! + do l=1,limit +! +! printing the header +! + if(prlab(ii)(1:4).eq.'S ') then + write(5,*) + write(5,106) elset(1:ipos-2),ttime + 106 format(' stresses (elem, integ.pnt.,sxx,syy,szz,sxy,sx + &z,syz) for set ',A,' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'E ') then + write(5,*) + write(5,107) elset(1:ipos-2),ttime + 107 format(' strains (elem, integ.pnt.,exx,eyy,ezz,exy,exz + &,eyz) forset ',A,' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'PEEQ') then + write(5,*) + write(5,108) elset(1:ipos-2),ttime + 108 format(' equivalent plastic strain (elem, integ.pnt.,p + &e)for set ',A,' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'ENER') then + write(5,*) + write(5,109) elset(1:ipos-2),ttime + 109 format(' internal energy density (elem, integ.pnt.,energy) for + &set ',A,' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'SDV ') then + write(5,*) + write(5,111) elset(1:ipos-2),ttime + 111 format + & (' internal state variables (elem, integ.pnt.,values) f + &or set ',A,' and time ',e14.7) + write(5,*) + elseif(prlab(ii)(1:4).eq.'HFL ') then + write(5,*) + write(5,112) elset(1:ipos-2),ttime + 112 format(' heat flux (elem, integ.pnt.,qx,qy,qz) for set + & ',A,' and time ',e14.7) + write(5,*) + endif +! +! printing the data +! + do iset=1,nset + if(set(iset).eq.prset(ii)) exit + enddo + do jj=istartset(iset),iendset(iset) + if(ialset(jj).lt.0) cycle + if(jj.eq.iendset(iset)) then + nelem=ialset(jj) + call printoutint(prlab,ipkon,lakon,stx,eme,xstate, + & ener,mi(1),nstate_,l,lb,ii,nelem,qfx, + & orab,ielorien,norien,co,kon) + elseif(ialset(jj+1).gt.0) then + nelem=ialset(jj) + call printoutint(prlab,ipkon,lakon,stx,eme,xstate, + & ener,mi(1),nstate_,l,lb,ii,nelem,qfx,orab, + & ielorien,norien,co,kon) + else + do nelem=ialset(jj-1)-ialset(jj+1),ialset(jj), + & -ialset(jj+1) + call printoutint(prlab,ipkon,lakon,stx,eme, + & xstate,ener,mi(1),nstate_,l,lb,ii,nelem, + & qfx,orab,ielorien,norien,co,kon) + enddo + endif + enddo +! + enddo +! +! whole element values +! + elseif((prlab(ii)(1:4).eq.'ELSE').or. + & (prlab(ii)(1:4).eq.'ELKE').or. + & (prlab(ii)(1:4).eq.'EVOL').or. + & (prlab(ii)(1:4).eq.'CSTR').or. + & (prlab(ii)(1:4).eq.'CDIS').or. + & (prlab(ii)(1:4).eq.'CELS')) then +! + ipos=index(prset(ii),' ') + elset=' ' + elset(1:ipos-1)=prset(ii)(1:ipos-1) +! +! printing the header +! + if((prlab(ii)(1:5).eq.'ELSE ').or. + & (prlab(ii)(1:5).eq.'ELSET')) then + write(5,*) + write(5,113) elset(1:ipos-2),ttime + 113 format(' internal energy (element, energy) for set ',A, + & ' and time ',e14.7) + write(5,*) + elseif((prlab(ii)(1:5).eq.'ELKE ').or. + & (prlab(ii)(1:5).eq.'ELKET')) then + write(5,*) + write(5,110) elset(1:ipos-2),ttime + 110 format(' kinetic energy (elem, energy) for set ' + & ,A,' and time ',e14.7) + write(5,*) + elseif((prlab(ii)(1:5).eq.'EVOL ').or. + & (prlab(ii)(1:5).eq.'EVOLT')) then + write(5,*) + write(5,114) elset(1:ipos-2),ttime + 114 format(' volume (element, volume) for set ',A, + & ' and time ',e14.7) + write(5,*) + elseif((prlab(ii)(1:5).eq.'CSTR ').or. + & (prlab(ii)(1:5).eq.'CSTRT')) then + write(5,*) + write(5,122) ttime + 122 format(' contact stress (slave node,press,' + & 'tang1,tang2) for all contact elements and time', + & e14.7) + write(5,*) + elseif((prlab(ii)(1:5).eq.'CDIS ').or. + & (prlab(ii)(1:5).eq.'CDIST')) then + write(5,*) + write(5,123) ttime + 123 format(' relative contact displacement (slave node,' + & 'normal,tang1,tang2) for all contact elements and ' + & 'time',e14.7) + write(5,*) + elseif((prlab(ii)(1:5).eq.'CELS ').or. + & (prlab(ii)(1:5).eq.'CELST')) then + write(5,*) + write(5,124) ttime + 124 format(' contact print energy (slave node,energy) for' + & 'all contact elements and time',e14.7) + write(5,*) + endif +! +! printing the data +! + + volumetot=0.d0 + energytot=0.d0 + enerkintot=0.d0 + + if ((prlab(ii)(1:4).eq.'CSTR').or. + & (prlab(ii)(1:4).eq.'CDIS').or. + & (prlab(ii)(1:4).eq.'CELS')) then +! + do jj=ne,1,-1 + if((lakon(jj)(2:2).ne.'S').or. + & (lakon(jj)(7:7).ne.'C')) then + ne0=jj+1 + exit + endif + enddo + do nelem=ne0,ne + read(lakon(nelem)(8:8),'(i1)') nope + nodes=kon(ipkon(nelem)+nope) + call printoutelem(prlab,ipkon,lakon,kon,co, + & ener,mi(1),ii,nelem,energytot,volumetot, + & enerkintot,ikin,ne,stx,nodes) + enddo + else + do iset=1,nset + if(set(iset).eq.prset(ii)) exit + enddo + do jj=istartset(iset),iendset(iset) + if(ialset(jj).lt.0) cycle + if(jj.eq.iendset(iset)) then + nelem=ialset(jj) + call printoutelem(prlab,ipkon,lakon,kon,co, + & ener,mi(1),ii,nelem,energytot,volumetot, + & enerkintot,ikin,ne,stx,nodes) + elseif(ialset(jj+1).gt.0) then + nelem=ialset(jj) + call printoutelem(prlab,ipkon,lakon,kon,co, + & ener,mi(1),ii,nelem,energytot,volumetot, + & enerkintot,ikin,ne,stx,nodes) + else + do nelem=ialset(jj-1)-ialset(jj+1),ialset(jj), + & -ialset(jj+1) + call printoutelem(prlab,ipkon,lakon,kon,co, + & ener,mi(1),ii,nelem,energytot,volumetot, + & enerkintot,ikin,ne,stx,nodes) + enddo + endif + enddo + endif +! +! writing total values to file +! + if((prlab(ii)(1:5).eq.'ELSEO').or. + & (prlab(ii)(1:5).eq.'ELSET')) then + write(5,*) + write(5,116) elset(1:ipos-2),ttime + 116 format(' total internal energy for set ',A,' and time ', + & e14.7) + write(5,*) + write(5,'(6x,1p,1x,e11.4)') energytot + elseif((prlab(ii)(1:5).eq.'ELKEO').or. + & (prlab(ii)(1:5).eq.'ELKET')) then + write(5,*) + write(5,120) elset(1:ipos-2),ttime + 120 format(' total kinetic energy for set ',A,' and time ', + & e14.7) + write(5,*) + write(5,'(6x,1p,1x,e11.4)') enerkintot + elseif((prlab(ii)(1:5).eq.'EVOLO').or. + & (prlab(ii)(1:5).eq.'EVOLT')) then + write(5,*) + write(5,121) elset(1:ipos-2),ttime + 121 format(' total volume for set ',A,' and time ',e14.7) + write(5,*) + write(5,'(6x,1p,1x,e11.4)') volumetot + elseif((prlab(ii)(1:5).eq.'CELSO').or. + & (prlab(ii)(1:5).eq.'CELST')) then + write(5,*) + write(5,125) ttime + 125 format(' total contact spring energy for time ',e14.7) + write(5,*) + write(5,'(6x,1p,1x,e11.4)') energytot +! + endif + endif + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/printoutface.f calculix-ccx-2.3/ccx_2.3/src/printoutface.f --- calculix-ccx-2.1/ccx_2.3/src/printoutface.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/printoutface.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,379 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine printoutface(co,rhcon,nrhcon,ntmat_,vold,shcon,nshcon, + & cocon,ncocon,compressible,istartset,iendset,ipkon,lakon,kon, + & ialset,prset,ttime,nset,set,nprint,prlab,ielmat,mi) +! +! calculation and printout of the lift and drag forces +! + implicit none +! + integer compressible +! + character*8 lakonl,lakon(*) + character*6 prlab(*) + character*80 faset + character*81 set(*),prset(*) +! + integer konl(20),ifaceq(8,6),nelem,ii,nprint,i,j,i1,i2,j1, + & ncocon(2,*),k1,jj,ig,nrhcon(*),nshcon(*),ntmat_,nope,nopes,imat, + & mint2d,ifacet(6,4),ifacew(8,5),iflag,indexe,jface,istartset(*), + & iendset(*),ipkon(*),kon(*),iset,ialset(*),nset,ipos,ielmat(*), + & mi(2) +! + real*8 co(3,*),xl(3,20),shp(4,20),xs2(3,7),dvi,f(3), + & vkl(3,3),rhcon(0:1,ntmat_,*),t(3,3),div,shcon(0:3,ntmat_,*), + & voldl(0:mi(2),20),cocon(0:6,ntmat_,*),xl2(3,8),xsj2(3), + & shp2(7,8), + & vold(0:mi(2),*),xi,et,xsj,temp,xi3d,et3d,ze3d,weight, + & xlocal20(3,9,6),xlocal4(3,1,4),xlocal10(3,3,4),xlocal6(3,1,5), + & xlocal15(3,4,5),xlocal8(3,4,6),xlocal8r(3,1,6),ttime,pres, + & tf(3),tn,tt,dd,coords(3) +! + include "gauss.f" + include "xlocal.f" +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ + data iflag /3/ +! +! initialisierung forces +! + do i=1,3 + f(i)=0.d0 + enddo +! + do ii=1,nprint +! +! total drag +! + if(prlab(ii)(1:4).eq.'DRAG') then +! + ipos=index(prset(ii),' ') + faset=' ' + faset(1:ipos-1)=prset(ii)(1:ipos-1) +! +! printing the header +! + write(5,*) + write(5,120) faset(1:ipos-2),ttime + 120 format(' surface stress vector (tx,ty,tz), normal stress, sh + &ear stress and coordinates for set ',A,' and time ',e14.7) + write(5,*) +! +! printing the data +! + do iset=1,nset + if(set(iset).eq.prset(ii)) exit + enddo +! + do jj=istartset(iset),iendset(iset) +! + jface=ialset(jj) +! + nelem=int(jface/10.d0) + ig=jface-10*nelem + lakonl=lakon(nelem) + indexe=ipkon(nelem) + imat=ielmat(nelem) +! + if(lakonl(4:4).eq.'2') then + nope=20 + nopes=8 + elseif(lakonl(4:4).eq.'8') then + nope=8 + nopes=4 + elseif(lakonl(4:5).eq.'10') then + nope=10 + nopes=6 + elseif(lakonl(4:4).eq.'4') then + nope=4 + nopes=3 + elseif(lakonl(4:5).eq.'15') then + nope=15 + elseif(lakonl(4:4).eq.'6') then + nope=6 + endif +! + if(lakonl(4:5).eq.'8R') then + mint2d=1 + elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R')) + & then + if((lakonl(7:7).eq.'A').or.(lakonl(7:7).eq.'S').or. + & (lakonl(7:7).eq.'E')) then + mint2d=2 + else + mint2d=4 + endif + elseif(lakonl(4:4).eq.'2') then + mint2d=9 + elseif(lakonl(4:5).eq.'10') then + mint2d=3 + elseif(lakonl(4:4).eq.'4') then + mint2d=1 + endif +! +! local topology +! + do i=1,nope + konl(i)=kon(indexe+i) + enddo +! +! computation of the coordinates of the local nodes +! + do i=1,nope + do j=1,3 + xl(j,i)=co(j,konl(i)) + enddo + enddo +! +! temperature, velocity and auxiliary variables +! (rho*energy density, rho*velocity and rho) +! + do i1=1,nope + do i2=0,4 + voldl(i2,i1)=vold(i2,konl(i1)) + enddo + enddo +! +! treatment of wedge faces +! + if(lakonl(4:4).eq.'6') then + mint2d=1 + if(ig.le.2) then + nopes=3 + else + nopes=4 + endif + endif + if(lakonl(4:5).eq.'15') then + if(ig.le.2) then + mint2d=3 + nopes=6 + else + mint2d=4 + nopes=8 + endif + endif +! + if((nope.eq.20).or.(nope.eq.8)) then + do i=1,nopes + do j=1,3 + xl2(j,i)=co(j,konl(ifaceq(i,ig))) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + do i=1,nopes + do j=1,3 + xl2(j,i)=co(j,konl(ifacet(i,ig))) + enddo + enddo + else + do i=1,nopes + do j=1,3 + xl2(j,i)=co(j,konl(ifacew(i,ig))) + enddo + enddo + endif +! + do i=1,mint2d +! +! local coordinates of the surface integration +! point within the surface local coordinate system +! + if((lakonl(4:5).eq.'8R').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then + xi=gauss2d1(1,i) + et=gauss2d1(2,i) + weight=weight2d1(i) + elseif((lakonl(4:4).eq.'8').or. + & (lakonl(4:6).eq.'20R').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then + xi=gauss2d2(1,i) + et=gauss2d2(2,i) + weight=weight2d2(i) + elseif(lakonl(4:4).eq.'2') then + xi=gauss2d3(1,i) + et=gauss2d3(2,i) + weight=weight2d3(i) + elseif((lakonl(4:5).eq.'10').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then + xi=gauss2d5(1,i) + et=gauss2d5(2,i) + weight=weight2d5(i) + elseif((lakonl(4:4).eq.'4').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then + xi=gauss2d4(1,i) + et=gauss2d4(2,i) + weight=weight2d4(i) + endif +! +! local surface normal +! + if(nopes.eq.8) then + call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + endif +! +! global coordinates of the integration point +! + do j1=1,3 + coords(j1)=0.d0 + do i1=1,nopes + coords(j1)=coords(j1)+shp2(4,i1)*xl2(j1,i1) + enddo + enddo +! +! local coordinates of the surface integration +! point within the element local coordinate system +! + if(lakonl(4:5).eq.'8R') then + xi3d=xlocal8r(1,i,ig) + et3d=xlocal8r(2,i,ig) + ze3d=xlocal8r(3,i,ig) + call shape8h(xi3d,et3d,ze3d,xl,xsj,shp,iflag) + elseif(lakonl(4:4).eq.'8') then + xi3d=xlocal8(1,i,ig) + et3d=xlocal8(2,i,ig) + ze3d=xlocal8(3,i,ig) + call shape8h(xi3d,et3d,ze3d,xl,xsj,shp,iflag) + elseif(lakonl(4:6).eq.'20R') then + xi3d=xlocal8(1,i,ig) + et3d=xlocal8(2,i,ig) + ze3d=xlocal8(3,i,ig) + call shape20h(xi3d,et3d,ze3d,xl,xsj,shp,iflag) + elseif(lakonl(4:4).eq.'2') then + xi3d=xlocal20(1,i,ig) + et3d=xlocal20(2,i,ig) + ze3d=xlocal20(3,i,ig) + call shape20h(xi3d,et3d,ze3d,xl,xsj,shp,iflag) + elseif(lakonl(4:5).eq.'10') then + xi3d=xlocal10(1,i,ig) + et3d=xlocal10(2,i,ig) + ze3d=xlocal10(3,i,ig) + call shape10tet(xi3d,et3d,ze3d,xl,xsj,shp,iflag) + elseif(lakonl(4:4).eq.'4') then + xi3d=xlocal4(1,i,ig) + et3d=xlocal4(2,i,ig) + ze3d=xlocal4(3,i,ig) + call shape4tet(xi3d,et3d,ze3d,xl,xsj,shp,iflag) + elseif(lakonl(4:5).eq.'15') then + xi3d=xlocal15(1,i,ig) + et3d=xlocal15(2,i,ig) + ze3d=xlocal15(3,i,ig) + call shape15w(xi3d,et3d,ze3d,xl,xsj,shp,iflag) + elseif(lakonl(4:4).eq.'6') then + xi3d=xlocal6(1,i,ig) + et3d=xlocal6(2,i,ig) + ze3d=xlocal6(3,i,ig) + call shape6w(xi3d,et3d,ze3d,xl,xsj,shp,iflag) + endif +! +! calculating of +! the temperature temp +! the static pressure pres +! the velocity gradient vkl +! in the integration point +! + temp=0.d0 + pres=0.d0 + do i1=1,3 + do j1=1,3 + vkl(i1,j1)=0.d0 + enddo + enddo + do i1=1,nope + temp=temp+shp(4,i1)*voldl(0,i1) + pres=pres+shp(4,i1)*voldl(4,i1) + do j1=1,3 + do k1=1,3 + vkl(j1,k1)=vkl(j1,k1)+shp(k1,i1)*voldl(j1,i1) + enddo + enddo + enddo + if(compressible.eq.1) div=vkl(1,1)+vkl(2,2)+vkl(3,3) +! +! material data (density, dynamic viscosity, heat capacity and +! conductivity) +! +c call materialdata_fl(imat,ntmat_,temp,shcon,nshcon,cp, +c & r,dvi,rhcon,nrhcon,rho,cocon,ncocon,cond) + call materialdata_dvi(imat,ntmat_,temp,shcon,nshcon, + & dvi) +! +! determining the stress +! + do i1=1,3 + do j1=1,3 + t(i1,j1)=vkl(i1,j1)+vkl(j1,i1) + enddo + if(compressible.eq.1) + & t(i1,i1)=t(i1,i1)-2.d0*div/3.d0 + enddo +! + dd=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+ + & xsj2(3)*xsj2(3)) + do i1=1,3 + tf(i1)=dvi*(t(i1,1)*xsj2(1)+t(i1,2)*xsj2(2)+ + & t(i1,3)*xsj2(3))-pres*xsj2(i1) + f(i1)=f(i1)+tf(i1)*weight + tf(i1)=tf(i1)/dd + enddo + tn=(tf(1)*xsj2(1)+tf(2)*xsj2(2)+tf(3)*xsj2(3))/dd + tt=dsqrt((tf(1)-tn*xsj2(1)/dd)**2+ + & (tf(2)-tn*xsj2(2)/dd)**2+ + & (tf(3)-tn*xsj2(3)/dd)**2) + write(5,'(i6,1x,i3,1x,i3,1p,8(1x,e11.4))') nelem,ig,i, + & (tf(i1),i1=1,3),tn,tt,(coords(i1),i1=1,3) +! + enddo + enddo +! + write(5,*) + write(5,121) faset(1:ipos-2),ttime + 121 format(' total surface force (fx,fy,fz) for set ',A, + & ' and time ',e14.7) + write(5,*) + write(5,'(1p,3(1x,e11.4))') (f(j),j=1,3) +! + endif + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/printoutint.f calculix-ccx-2.3/ccx_2.3/src/printoutint.f --- calculix-ccx-2.1/ccx_2.3/src/printoutint.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/printoutint.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,275 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine printoutint(prlab,ipkon,lakon,stx,eme,xstate,ener, + & mi,nstate_,l1,lb,ii,nelem,qfx,orab,ielorien,norien,co,kon) +! +! stores integration point results for element "nelem" in the .dat file +! + implicit none +! + character*6 prlab(*) + character*8 lakon(*) +! + integer ipkon(*),mi(2),nstate_,nelem,l,lb,ii,mint3d,j,k,nope, + & ielorien(*),norien,kon(*),konl,indexe,m,iorien,iflag,l1 +! + real*8 stx(6,mi(1),*),eme(6,mi(1),*),xstate(nstate_,mi(1),*), + & ener(mi(1),*),qfx(3,mi(1),*),xi,et,ze,xl(3,20),xsj,shp(4,20), + & coords(3,27),weight,orab(7,*),co(3,*),a(3,3),b(3,3),c(3,3), + & qfxl(3) +! + include "gauss.f" +! + data iflag /1/ +! + if(ipkon(nelem).lt.0) return +! +! check whether transformation is necessary (if orientation +! is applied and output in local system is requested) +! + if((norien.eq.0).or.(prlab(ii)(6:6).eq.'G')) then + iorien=0 + else + iorien=ielorien(nelem) + endif +! + if(lakon(nelem)(4:5).eq.'8R') then + mint3d=1 + elseif((lakon(nelem)(4:4).eq.'8').or. + & (lakon(nelem)(4:6).eq.'20R')) then + mint3d=8 + elseif(lakon(nelem)(4:4).eq.'2') then + mint3d=27 + elseif(lakon(nelem)(4:5).eq.'10') then + mint3d=4 + elseif(lakon(nelem)(4:4).eq.'4') then + mint3d=1 + elseif(lakon(nelem)(4:5).eq.'15') then + mint3d=9 + elseif(lakon(nelem)(4:4).eq.'6') then + mint3d=2 + else + return + endif +! +! calculation of the integration point coordinates for +! output in the local system +! + if(iorien.ne.0) then + if(lakon(nelem)(4:4).eq.'2') then + nope=20 + elseif(lakon(nelem)(4:4).eq.'8') then + nope=8 + elseif(lakon(nelem)(4:5).eq.'10') then + nope=10 + elseif(lakon(nelem)(4:4).eq.'4') then + nope=4 + elseif(lakon(nelem)(4:5).eq.'15') then + nope=15 + elseif(lakon(nelem)(4:4).eq.'6') then + nope=6 + endif +! + indexe=ipkon(nelem) + do j=1,nope + konl=kon(indexe+j) + do k=1,3 + xl(k,j)=co(k,konl) + enddo + enddo +! + do j=1,mint3d + if(lakon(nelem)(4:5).eq.'8R') then + xi=gauss3d1(1,j) + et=gauss3d1(2,j) + ze=gauss3d1(3,j) + weight=weight3d1(j) + elseif((lakon(nelem)(4:4).eq.'8').or. + & (lakon(nelem)(4:6).eq.'20R')) + & then + xi=gauss3d2(1,j) + et=gauss3d2(2,j) + ze=gauss3d2(3,j) + weight=weight3d2(j) + elseif(lakon(nelem)(4:4).eq.'2') then + xi=gauss3d3(1,j) + et=gauss3d3(2,j) + ze=gauss3d3(3,j) + weight=weight3d3(j) + elseif(lakon(nelem)(4:5).eq.'10') then + xi=gauss3d5(1,j) + et=gauss3d5(2,j) + ze=gauss3d5(3,j) + weight=weight3d5(j) + elseif(lakon(nelem)(4:4).eq.'4') then + xi=gauss3d4(1,j) + et=gauss3d4(2,j) + ze=gauss3d4(3,j) + weight=weight3d4(j) + elseif(lakon(nelem)(4:5).eq.'15') then + xi=gauss3d8(1,j) + et=gauss3d8(2,j) + ze=gauss3d8(3,j) + weight=weight3d8(j) + elseif(lakon(nelem)(4:4).eq.'6') then + xi=gauss3d7(1,j) + et=gauss3d7(2,j) + ze=gauss3d7(3,j) + weight=weight3d7(j) + endif +! + if(nope.eq.20) then + call shape20h(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.8) then + call shape8h(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.10) then + call shape10tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.4) then + call shape4tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.15) then + call shape15w(xi,et,ze,xl,xsj,shp,iflag) + else + call shape6w(xi,et,ze,xl,xsj,shp,iflag) + endif +! + do k=1,3 + coords(k,j)=0.d0 + do l=1,nope + coords(k,j)=coords(k,j)+xl(k,l)*shp(4,l) + enddo + enddo + enddo + endif +! + if(prlab(ii)(1:4).eq.'S ') then + if(iorien.eq.0) then + do j=1,mint3d + write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, + & (stx(k,j,nelem),k=1,6) + enddo + else + do j=1,mint3d + call transformatrix(orab(1,iorien),coords(1,j),a) + b(1,1)=stx(1,j,nelem) + b(2,2)=stx(2,j,nelem) + b(3,3)=stx(3,j,nelem) + b(1,2)=stx(4,j,nelem) + b(1,3)=stx(5,j,nelem) + b(2,3)=stx(6,j,nelem) + b(2,1)=b(1,2) + b(3,1)=b(1,3) + b(3,2)=b(2,3) + do k=1,3 + do l=1,3 + c(k,l)=0.d0 + do m=1,3 + c(k,l)=c(k,l)+b(k,m)*a(m,l) + enddo + enddo + enddo + do k=1,3 + do l=k,3 + b(k,l)=0.d0 + do m=1,3 + b(k,l)=b(k,l)+a(m,k)*c(m,l) + enddo + enddo + enddo + write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, + & b(1,1),b(2,2),b(3,3),b(1,2),b(1,3),b(2,3) + enddo + endif + elseif(prlab(ii)(1:4).eq.'E ') then + if(iorien.eq.0) then + do j=1,mint3d + write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, + & (eme(k,j,nelem),k=1,6) + enddo + else + do j=1,mint3d + call transformatrix(orab(1,iorien),coords(1,j),a) + b(1,1)=eme(1,j,nelem) + b(2,2)=eme(2,j,nelem) + b(3,3)=eme(3,j,nelem) + b(1,2)=eme(4,j,nelem) + b(1,3)=eme(5,j,nelem) + b(2,3)=eme(6,j,nelem) + b(2,1)=b(1,2) + b(3,1)=b(1,3) + b(3,2)=b(2,3) + do k=1,3 + do l=1,3 + do m=1,3 + c(k,l)=b(k,m)*a(m,l) + enddo + enddo + enddo + do k=1,3 + do l=k,3 + do m=1,3 + b(k,l)=a(m,k)*c(m,l) + enddo + enddo + enddo + write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, + & b(1,1),b(2,2),b(3,3),b(1,2),b(1,3),b(2,3) + enddo + endif + elseif(prlab(ii)(1:4).eq.'PEEQ') then + do j=1,mint3d + write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, + & xstate(1,j,nelem) + enddo + elseif(prlab(ii)(1:4).eq.'ENER') then + do j=1,mint3d + write(5,'(i6,1x,i3,1p,6(1x,e11.4))') nelem,j, + & ener(j,nelem) + enddo + elseif(prlab(ii)(1:4).eq.'SDV ') then + if(iorien.ne.0) then + write(*,*) '*WARNING in printoutint: SDV cannot be' + write(*,*) ' printed in the local system' + write(*,*) ' results are in the global system' + endif + do j=1,mint3d + write(5,'(i6,1x,i3,1p,99(1x,e11.4))') nelem,j, + & (xstate(k,j,nelem),k=1,nstate_) + enddo + elseif(prlab(ii)(1:4).eq.'HFL ') then + if(iorien.eq.0) then + do j=1,mint3d + write(5,'(i6,1x,i3,1p,3(1x,e11.4))') nelem,j, + & (qfx(k,j,nelem),k=1,3) + enddo + else + do j=1,mint3d + do k=1,3 + qfxl(k)=qfx(k,j,nelem) + enddo + call transformatrix(orab(1,iorien),coords(1,j),a) + write(5,'(i6,1x,i3,1p,3(1x,e11.4))') nelem,j, + & qfxl(1)*a(1,1)+qfxl(2)*a(2,1)+qfxl(3)*a(3,1), + & qfxl(1)*a(1,2)+qfxl(2)*a(2,2)+qfxl(3)*a(3,2), + & qfxl(1)*a(1,3)+qfxl(2)*a(2,3)+qfxl(3)*a(3,3) + enddo + endif + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/printoutnode.f calculix-ccx-2.3/ccx_2.3/src/printoutnode.f --- calculix-ccx-2.1/ccx_2.3/src/printoutnode.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/printoutnode.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,100 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine printoutnode(prlab,v,t1,fn,ithermal,ii,node, + & rftot,trab,inotr,ntrans,co,mi) +! +! stores results in the .dat file +! + implicit none +! + character*6 prlab(*) +! + integer ithermal,node,ii,j,inotr(2,*),ntrans,mi(2) +! + real*8 v(0:mi(2),*),t1(*),fn(0:mi(2),*),rftot(0:3),trab(7,*), + & co(3,*),a(3,3) +! + if((prlab(ii)(1:4).eq.'U ').or.(prlab(ii)(1:4).eq.'V ')) then + if((ntrans.eq.0).or.(prlab(ii)(6:6).eq.'G')) then + write(5,'(i6,1p,3(1x,e11.4))') node, + & (v(j,node),j=1,3) + elseif(inotr(1,node).eq.0) then + write(5,'(i6,1p,3(1x,e11.4))') node, + & (v(j,node),j=1,3) + else + call transformatrix(trab(1,inotr(1,node)),co(1,node),a) + write(5,'(i6,1p,3(1x,e11.4))') node, + & v(1,node)*a(1,1)+v(2,node)*a(2,1)+v(3,node)*a(3,1), + & v(1,node)*a(1,2)+v(2,node)*a(2,2)+v(3,node)*a(3,2), + & v(1,node)*a(1,3)+v(2,node)*a(2,3)+v(3,node)*a(3,3) + endif + elseif(prlab(ii)(1:4).eq.'NT ') then + if(ithermal.le.1) then + write(5,'(i6,1x,1p,e11.4)') node, + & t1(node) + else + write(5,'(i6,1x,1p,e11.4)') node, + & v(0,node) + endif + elseif(prlab(ii)(1:4).eq.'PS ') then + write(5,'(i6,1x,1p,e11.4)') node, + & v(4,node) + elseif(prlab(ii)(1:4).eq.'PN ') then + write(5,'(i6,1x,1p,e11.4)') node, + & v(2,node) + elseif(prlab(ii)(1:4).eq.'MF ') then + write(5,'(i6,1x,1p,e11.4)') node, + & v(1,node) + elseif(prlab(ii)(1:4).eq.'RF ') then + do j=1,3 + rftot(j)=rftot(j)+fn(j,node) + enddo + if(prlab(ii)(5:5).ne.'O') then + if((ntrans.eq.0).or.(prlab(ii)(6:6).eq.'G')) then + write(5,'(i6,1p,3(1x,e11.4))') node, + & (fn(j,node),j=1,3) + elseif(inotr(1,node).eq.0) then + write(5,'(i6,1p,3(1x,e11.4))') node, + & (fn(j,node),j=1,3) + else + call transformatrix(trab(1,inotr(1,node)),co(1,node),a) + write(5,'(i6,1p,3(1x,e11.4))') node, + & fn(1,node)*a(1,1)+fn(2,node)*a(2,1)+fn(3,node)*a(3,1), + & fn(1,node)*a(1,2)+fn(2,node)*a(2,2)+fn(3,node)*a(3,2), + & fn(1,node)*a(1,3)+fn(2,node)*a(2,3)+fn(3,node)*a(3,3) + endif + endif + elseif(prlab(ii)(1:4).eq.'RFL ') then + rftot(0)=rftot(0)+fn(0,node) + if(prlab(ii)(5:5).ne.'O') then + write(5,'(i6,1p,3(1x,e11.4))') node, + & fn(0,node) + endif + endif +! + flush(5) +! + return + end + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/profil.f calculix-ccx-2.3/ccx_2.3/src/profil.f --- calculix-ccx-2.1/ccx_2.3/src/profil.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/profil.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,73 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine profil(n,nnn,e2,adj,xadj,oldpro,newpro, + & oldpro_exp,newpro_exp) +! +! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) +! + integer newpro,i,j,n,jstrt,jstop,oldpro,newmin,oldmin,e2,nnn(n), + & xadj(n+1),adj(e2),inc_oldpro,inc_newpro,oldpro_exp,newpro_exp +! + oldpro=0 + newpro=0 + oldpro_exp=0 + newpro_exp=0 + do 20 i=1,n + jstrt=xadj(i) + jstop=xadj(i+1)-1 + if(jstrt.gt.jstop) cycle + oldmin=adj(jstrt) + newmin=nnn(adj(jstrt)) +! + do 10 j=jstrt+1,jstop + oldmin=min(oldmin,adj(j)) + newmin=min(newmin,nnn(adj(j))) + 10 continue +! + inc_oldpro=dim(i,oldmin) + if(2147483647-oldpro.lt.inc_oldpro) then + oldpro_exp=oldpro_exp+1 + inc_oldpro=inc_oldpro-2147483647 + endif + oldpro=oldpro+inc_oldpro +! + inc_newpro=dim(nnn(i),newmin) + if(2147483647-newpro.lt.inc_newpro) then + newpro_exp=newpro_exp+1 + inc_newpro=inc_newpro-2147483647 + endif + newpro=newpro+inc_newpro + 20 continue +! + inc_oldpro=n + if(2147483647-oldpro.lt.inc_oldpro) then + oldpro_exp=oldpro_exp+1 + inc_oldpro=inc_oldpro-2147483647 + endif + oldpro=oldpro+inc_oldpro +! + inc_newpro=n + if(2147483647-newpro.lt.inc_newpro) then + newpro_exp=newpro_exp+1 + inc_newpro=inc_newpro-2147483647 + endif + newpro=newpro+inc_newpro +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pt2_lim_calc.f calculix-ccx-2.3/ccx_2.3/src/pt2_lim_calc.f --- calculix-ccx-2.1/ccx_2.3/src/pt2_lim_calc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pt2_lim_calc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,115 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! this subroutine solves iteratively the following equation +! to determine the pressure for which section A2 is critical +! + subroutine pt2_lim_calc (pt1,a2,a1,kappa,zeta,pt2_lim) +! + implicit none +! + integer i +! + real*8 pt1,a2,a1,kappa,pt2_lim,x,zeta,f,df,expon1, + & expon2,expon3,cte,a2a1,kp1,km1,delta_x,fact1,fact2,term +! + x=0.999 +! +! x belongs to interval [0;1] +! +! modified 25.11.2007 +! since Pt1/Pt2=(1+0.5(kappa)-M)**(zeta*kappa)/(kappa-1) +! and for zeta1 elements type M_crit=M1=1 +! and for zeta2 elements type M_crit=M2 =1 +! it is not necessary to iteratively solve the flow equation. +! Instead the previous equation is solved to find pt2_crit + if(zeta.ge.0d0) then + kp1=kappa+1d0 + km1=kappa-1d0 + a2a1=a2/a1 + expon1=-0.5d0*kp1/(zeta*kappa) + expon2=-0.5d0*kp1/km1 + cte=a2a1*(0.5*kp1)**expon2 + expon3=-km1/(zeta*kappa) + i=0 +! +! + do + i=i+1 +! + f=x**(-1d0)-cte*x**(expon1) + & *(2d0/km1*(x**expon3-1.d0))**-0.5d0 +! + df=-1.d0/X**2-cte*(x**expon1 + & *(2d0/km1*(x**expon3-1.d0))**-0.5d0) + & *(expon1/X-1d0/km1*expon3*x**(expon3-1d0) + & *(2d0/km1*(x**expon3-1.d0))**(-1.d0)) + + delta_x=-f/df +! + if(( dabs(delta_x/x).le.1.E-8) + & .or.(dabs(delta_x/1d0).le.1.E-10)) then +! + pt2_lim=pt1*X +! + exit + endif + if(i.gt.25)then + pt2_lim=Pt1/(1+0.5*km1)**(zeta*kappa/km1) + exit + endif +! + x=delta_x+x +! + enddo +! + else +! + do + kp1=kappa+1d0 + km1=kappa-1d0 + a2a1=a2/a1 + expon1=kp1/(zeta*kappa) + expon2=km1/(zeta*kappa) + expon3=kp1/km1 + cte=a2a1**2*(0.5*kp1)**-expon3*(2/km1)**-1 + fact1=x**-expon1 + fact2=x**-expon2 + term=fact2-1 +! + f=x**-2-cte*fact1*term**-1 +! + df=-2*x**-3-cte*(x**(-expon1-1)*term**-1) + & *(-expon1+expon2*(X**-expon2)*fact2*term**-1) +! + delta_x=-f/df +! + if(( dabs(delta_x/x).le.1.E-8) + & .or.(dabs(delta_x/1d0).le.1.E-10)) then + pt2_lim=pt1*X + exit + endif +! + x=delta_x+x +! + enddo +! + endif + + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/pt2zpt1_crit.f calculix-ccx-2.3/ccx_2.3/src/pt2zpt1_crit.f --- calculix-ccx-2.1/ccx_2.3/src/pt2zpt1_crit.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/pt2zpt1_crit.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,173 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! calculate the maximal admissible pressure ratio pt2/pt1 +! +! 1) assuming M2=1 for adiabatic respectively M2=1/dsqrt(kappa) for isotherm pipe choking +! M1 is calculated iteratively using a dichotomy scheme +! +! 2)the ratio of the critical pressure ratio Qred_1/Qred_2crit=Pt2/Pt1 +! =D(M1)/D(M2_crit)is computed [D(M)=M*(1+0.5*(kappa-1)*M)**(-0.5*(kappa+1)/(kappa-1))] +! + subroutine pt2zpt1_crit(pt2,pt1,Tt1,Tt2,lambda,kappa,r,l,d,A, + & iflag,inv,pt2zpt1_c,qred_crit,crit,qred_max1,icase) +! + implicit none +! + logical crit +! + integer iflag,inv,icase,i +! + real*8 pt2,pt1,lambda,kappa,l,d,M1,pt2zpt1,pt2zpt1_c, + & km1,kp1,km1zk,kp1zk,Tt1,Tt2,r,A, + & xflow_crit,qred_crit,f1,f2,f3,m1_ac,m1_min,m1_max, + & expon1,qred_max1,lld +! +! useful variables and constants +! + km1=kappa-1.d0 + kp1=kappa+1.d0 + km1zk=km1/kappa + kp1zk=kp1/kappa + lld=lambda*l/d + expon1=-0.5d0*kp1/km1 +! +! adiabatic case +! + if(icase.eq.0) then +! +! computing M1 using dichotomy method +! + i=1 + m1_max=1 + m1_min=0.001d0 + do + i=i+1 + m1_ac=(m1_min+m1_max)*0.5d0 +! + f1=(1.d0-M1_min**2)*(kappa*M1_min**2)**(-1) + & +0.5d0*kp1zk*log((0.5d0*kp1)*M1_min**2 + & *(1+0.5d0*km1*M1_min**2)**(-1))-lld +! + f2=(1.d0-M1_ac**2)*(kappa*M1_ac**2)**(-1) + & +0.5d0*kp1zk*log((0.5d0*kp1)*M1_ac**2 + & *(1+0.5d0*km1*M1_ac**2)**(-1))-lld +! + f3=(1.d0-M1_max**2)*(kappa*M1_max**2)**(-1) + & +0.5d0*kp1zk*log((0.5d0*kp1)*M1_max**2 + & *(1+0.5d0*km1*M1_max**2)**(-1))-lld +! + if(abs(f2).le.1E-6) then + M1=m1_ac + exit + endif + if(i.gt.50) then + M1=M1_ac + exit + endif +! + if((f3.gt.f2).and.(f2.ge.f1)) then + if((f1.lt.0d0).and.(f2.lt.0d0)) then + m1_min=m1_ac + else + m1_max=m1_ac + endif + elseif((f3.lt.f2).and.(f2.le.f1)) then + if((f3.lt.0d0).and.(f2.lt.0d0) )then + m1_max=m1_ac + else + m1_min=m1_ac + endif + endif + enddo +! + Pt2zpt1_c=M1*(0.5d0*kp1)**(0.5*kp1/km1) + & *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1) +! +! isotherm case +! + elseif (icase.eq.1) then +! +! computing M1 using dichotomy method for choked conditions M2=1/dsqrt(kappa) +! (1.d0-kappa*M1**2)/(kappa*M1**2)+log(kappa*M1**2)-lambda*l/d=0 +! + m1_max=1/dsqrt(kappa) + m1_min=0.1d0 + i=1 + do + i=i+1 + m1_ac=(m1_min+m1_max)*0.5d0 +! + f1=(1.d0-kappa*M1_min**2)/(kappa*M1_min**2) + & +log(kappa*M1_min**2)-lambda*l/d +! + f2=(1.d0-kappa*M1_ac**2)/(kappa*M1_ac**2) + & +log(kappa*M1_ac**2)-lambda*l/d +! + f3=(1.d0-kappa*M1_max**2)/(kappa*M1_max**2) + & +log(kappa*M1_max**2)-lambda*l/d +! + if((abs(f2).le.1E-5).or.(i.ge.50)) then + M1=m1_ac + exit + endif +! + if((f3.gt.f2).and.(f2.ge.f1)) then + if((f1.lt.0d0).and.(f2.lt.0d0)) then + m1_min=m1_ac + else + m1_max=m1_ac + endif + elseif((f3.lt.f2).and.(f2.le.f1)) then + if((f3.lt.0d0).and.(f2.lt.0d0) )then + m1_max=m1_ac + else + m1_min=m1_ac + endif + endif + enddo +! +! computing the critical pressure ratio in the isothermal case +! pt=A*dsqrt(kappa)/(xflow*dsqrt(kappa Tt))*M*(1+0.5d0*(kappa-1)M**2)**(-0.5d0*(kappa+1)/(kappa-1)) +! and forming the pressure ratio between inlet and outlet(choked) +! + Pt2zPt1_c=dsqrt(Tt2/Tt1)*M1*dsqrt(kappa)*((1+0.5d0*km1/kappa) + & /(1+0.5d0*km1*M1**2))**(0.5d0*(kappa+1)/km1) +! + endif +! + pt2zpt1=pt2/pt1 + if(Pt2zPt1.le.Pt2zPt1_c) then + crit=.true. + endif +! + if (iflag.eq.1) then + xflow_crit=inv*M1*Pt1*A/dsqrt(Tt1)*dsqrt(kappa/r) + & *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1) + elseif(iflag.eq.2) then + qred_max1=M1*dsqrt(kappa/r) + & *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1) + endif +! + Qred_crit=M1*dsqrt(kappa/r) + & *(1+0.5d0*km1*M1**2)**(-0.5d0*kp1/km1) +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/radcyc.c calculix-ccx-2.3/ccx_2.3/src/radcyc.c --- calculix-ccx-2.1/ccx_2.3/src/radcyc.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/radcyc.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,163 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +void radcyc(int *nk,int *kon,int *ipkon,char *lakon,int *ne, + double *cs, int *mcs, int *nkon,int *ialset, int *istartset, + int *iendset,int **kontrip,int *ntri, + double **cop, double **voldp,int *ntrit, int *inocs, + int *mi){ + + /* duplicates triangular faces for cyclic radiation conditions */ + + char *filab=NULL; + + int i,is,nsegments,idtie,nkt,icntrl,imag=0,*kontri=NULL,mt=mi[1]+1, + node,i1,i2,nope,iel,indexe,j,k,ielset,node1,node2,node3,l,jj; + + double *vt=NULL,*fnt=NULL,*stnt=NULL,*eent=NULL,*qfnt=NULL,t[3],theta, + pi,*v=NULL,*fn=NULL,*stn=NULL,*een=NULL,*qfn=NULL,*co=NULL, + *vold=NULL; + + pi=4.*atan(1.); + + kontri=*kontrip;co=*cop;vold=*voldp; + + /* determining the maximum number of sectors */ + + nsegments=1; + for(j=0;j<*mcs;j++){ + if(cs[17*j]>nsegments) nsegments=(int)(cs[17*j]); + } + + /* assigning nodes and elements to sectors */ + + ielset=cs[12]; + if((*mcs!=1)||(ielset!=0)){ + for(i=0;i<*nk;i++) inocs[i]=-1; + } + + for(i=0;i<*mcs;i++){ + is=cs[17*i+4]; + if(is==1) continue; + ielset=cs[17*i+12]; + if(ielset==0) continue; + for(i1=istartset[ielset-1]-1;i10){ + iel=ialset[i1]-1; + if(ipkon[iel]<0) continue; + indexe=ipkon[iel]; + if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; + else {nope=6;} + for(i2=0;i2=ialset[i1-1]-1) break; + if(ipkon[iel]<0) continue; + indexe=ipkon[iel]; + if(strcmp1(&lakon[8*iel+3],"2")==0)nope=20; + else if (strcmp1(&lakon[8*iel+3],"8")==0)nope=8; + else if (strcmp1(&lakon[8*iel+3],"10")==0)nope=10; + else if (strcmp1(&lakon[8*iel+3],"4")==0)nope=4; + else if (strcmp1(&lakon[8*iel+3],"15")==0)nope=15; + else {nope=6;} + for(i2=0;i2 +#include +#include +#include "CalculiX.h" +#ifdef SPOOLES +#include "spooles.h" +#endif +#ifdef SGI +#include "sgi.h" +#endif +#ifdef TAUCS +#include "tau.h" +#endif +#ifdef PARDISO +#include "pardiso.h" +#endif + +void radflowload(int *itg,int *ieg,int *ntg,int *ntr,double *acr, + double *bcr,int *ipivr, + double *ac,double *bc,int *nload,char *sideload, + int *nelemload,double *xloadact,char *lakon,int *ipiv, + int *ntmat_,double *vold,double *shcon, + int *nshcon,int *ipkon,int *kon,double *co,double *pmid, + double *e1,double *e2,double *e3,int *iptri,int *kontri, + int *ntri,int *nloadtr,double *tarea,double *tenv, + double *physcon,double *erad,double *f,double *dist, + int *idist,double *area,int *nflow,int *ikboun, + double *xbounact,int *nboun,int *ithermal, + int *iinc,int *iit,double *cs, int *mcs, int *inocs, + int *ntrit,int *nk, double *fenv,int *istep,double *dtime, + double *ttime,double *time,int *ilboun,int *ikforc, + int *ilforc,double *xforcact,int *nforc,double *cam, + int *ielmat,int *nteq,double *prop,int *ielprop,int *nactdog, + int *nacteq,int *nodeboun,int *ndirboun, + int *network, double *rhcon, int *nrhcon, int *ipobody, + int *ibody, double *xbodyact, int *nbody,int *iviewfile, + char *jobnamef, double *ctrl, double *xloadold, + double *reltime, int *nmethod, char *set, int *mi, + int * istartset,int* iendset,int *ialset,int *nset, + int *ineighe, int *nmpc, int *nodempc,int *ipompc, + double *coefmpc,char *labmpc, int *iemchange,int *nam, + int *iamload){ + + /* network=0: purely thermal + network=1: general case (temperatures, fluxes and pressures unknown) + network=2: purely aerodynamic, i.e. only fluxes and pressures unknown */ + + char kind[2]="N"; + + int nhrs=1,info=0,i,iin=0,icntrl,icutb=0,iin_abs=0,mt=mi[1]+1; + + double uamt=0,uamf=0,uamp=0,camt[2],camf[2],camp[2], + cam1t=0.,cam1f=0.,cam1p=0., + cam2t=0.,cam2f=0.,cam2p=0.,dtheta=1.,*v=NULL,cama[2],cam1a=0., + cam2a=0.,uama=0.,vamt=0.,vamf=0.,vamp=0.,vama=0.,cam0t=0.,cam0f=0., + cam0p=0.,cam0a=0.; + + /* check whether there are any gas temperature nodes; this check should + NOT be done on nteq, since also for zero equations the temperature + of the gas nodes with boundary conditions must be stored in v + (in initialgas) */ + + v=NNEW(double,mt**nk); + + if(*ntg!=0) { + icntrl=0; + while(icntrl==0) { + + if(iin==0){ + + for(i=0;i0){ + FORTRAN(dgesv,(nteq,&nhrs,ac,nteq,ipiv,bc,nteq,&info)); + } + + /*spooles(ac,au,adb,aub,&sigma,bc,icol,irow,nteq,nteq, + &symmetryflag,&inputformat);*/ + + if (info!=0) { + printf(" *WARNING in radflowload: singular matrix\n"); + + FORTRAN(mafillnet,(itg,ieg,ntg,ac,nload,sideload, + nelemload,xloadact,lakon,ntmat_,v, + shcon,nshcon,ipkon,kon,co,nflow,iinc, + istep,dtime,ttime,time, + ielmat,nteq,prop,ielprop,nactdog,nacteq, + physcon,rhcon,nrhcon,ipobody,ibody,xbodyact, + nbody,vold,xloadold,reltime,nmethod,set,mi, + nmpc,nodempc,ipompc,coefmpc,labmpc)); + + FORTRAN(equationcheck,(ac,nteq,nactdog,itg,ntg,nacteq,network)); + + iin=0; + + } + else { + FORTRAN(resultnet,(itg,ieg,ntg,bc,nload,sideload,nelemload, + xloadact,lakon,ntmat_,v,shcon,nshcon,ipkon,kon,co, + nflow,iinc,istep,dtime,ttime,time,ikforc,ilforc,xforcact, + nforc,ielmat,nteq,prop,ielprop,nactdog,nacteq, + &iin,physcon,camt,camf,camp,rhcon,nrhcon,ipobody, + ibody,xbodyact,nbody,&dtheta,vold,xloadold, + reltime,nmethod,set,mi,ineighe,cama,&vamt, + &vamf,&vamp,&vama,nmpc,nodempc,ipompc,coefmpc,labmpc)); + + if(*network!=2){ + cam2t=cam1t; + cam1t=cam0t; + cam0t=camt[0]; + if (camt[0]>uamt) {uamt=camt[0];} + printf + (" largest increment of gas temperature= %e\n",uamt); + if((int)camt[1]==0){ + printf + (" largest correction to gas temperature= %e\n", + camt[0]); + }else{ + printf + (" largest correction to gas temperature= %e in node %d\n", + camt[0],(int)camt[1]); + } + } + + if(*network!=0){ + cam2f=cam1f; + cam1f=cam0f; + cam0f=camf[0]; + if (camf[0]>uamf) {uamf=camf[0];} + printf(" largest increment of gas massflow= %e\n",uamf); + if((int)camf[1]==0){ + printf(" largest correction to gas massflow= %e\n", + camf[0]); + }else{ + printf(" largest correction to gas massflow= %e in node %d\n", + camf[0],(int)camf[1]); + } + + cam2p=cam1p; + cam1p=cam0p; + cam0p=camp[0]; + if (camp[0]>uamp) {uamp=camp[0];} + printf(" largest increment of gas pressure= %e\n",uamp); + if((int)camp[1]==0){ + printf(" largest correction to gas pressure= %e\n", + camp[0]); + }else{ + printf(" largest correction to gas pressure= %e in node %d\n", + camp[0],(int)camp[1]); + } + + cam2a=cam1a; + cam1a=cam0a; + cam0a=cama[0]; + if (cama[0]>uama) {uama=cama[0];} + printf(" largest increment of geometry= %e\n",uama); + if((int)cama[1]==0){ + printf(" largest correction to geometry= %e\n", + cama[0]); + }else{ + printf(" largest correction to geometry= %e in node %d\n", + cama[0],(int)cama[1]); + } + } + } + + printf("\n"); + + /* for purely thermal calculations no iterations are + deemed necessary */ + + if(*network==0) {icntrl=1;} + else { + checkconvnet(&icutb,&iin,&uamt,&uamf,&uamp, + &cam1t,&cam1f,&cam1p,&cam2t,&cam2f,&cam2p,&cam0t,&cam0f, + &cam0p,&icntrl,&dtheta,ctrl,&uama,&cam1a,&cam2a,&cam0a, + &vamt,&vamf,&vamp,&vama); + } + } + + FORTRAN(flowresult,(ntg,itg,cam,vold,v,nload,sideload, + nelemload,xloadact,nactdog,network,mi)); + + /* extra output for hydraulic jump (fluid channels) */ + + if(*network!=0){ + FORTRAN(flowoutput,(itg,ieg,ntg,nteq,bc,lakon,ntmat_, + v,shcon,nshcon,ipkon,kon,co,nflow, dtime,ttime,time, + ielmat,prop,ielprop,nactdog,nacteq,&iin,physcon, + camt,camf,camp,&uamt,&uamf,&uamp,rhcon,nrhcon, + vold,jobnamef,set,istartset,iendset,ialset,nset,mi)); + } + } + + if(*ntr>0){ + + FORTRAN(radmatrix, (ntr,acr,bcr,sideload,nelemload,xloadact,lakon, + vold,ipkon,kon,co,pmid,e1,e2,e3,iptri,kontri,ntri, + nloadtr,tarea,tenv,physcon,erad,f,dist,idist,area, + ithermal,iinc,iit,cs,mcs,inocs,ntrit,nk,fenv,istep, + dtime,ttime,time,iviewfile,jobnamef,xloadold, + reltime,nmethod,mi,iemchange,nam,iamload)); + + /* equation system is asymmetric and not sparse: + a non-sparse matrix solver is in this case + faster than a sparse matrix solver */ + +//#ifdef SPOOLES +// spooles(ac,au,adb,aub,&sigma,bc,icol,irow,ntr,ntr, +// &symmetryflag,&inputformat); +//#else + + + /* the left hand side of the radiation matrix has probably + changed if + - the viewfactors were updated + - a new step was started + - the emissivity coefficients were changed + - a new increment was started in a stationary calculation + (since the emissivity coefficients are ramped) + in that case the LU decomposition has to be repeated + (i.e. call of dgesv) */ + + if(((*ithermal==3)&&(*iviewfile>=0))|| + (*iit==-1)||(*iemchange==1)||((*iit==0)&&(*nmethod==1))){ + FORTRAN(dgesv,(ntr,&nhrs,acr,ntr,ipivr,bcr,ntr,&info)); + }else{ + FORTRAN(dgetrs,(kind,ntr,&nhrs,acr,ntr,ipivr,bcr,ntr,&info)); + } +//#endif + + if (info!=0){ + printf("*ERROR IN RADFLOWLOAD: SINGULAR MATRIX*\n");} + + else{ FORTRAN(radresult, (ntr,xloadact,bcr,nloadtr,tarea, + tenv,physcon,erad,f,fenv));} + } + + free(v); + + return; + +} + diff -Nru calculix-ccx-2.1/ccx_2.3/src/radiate.f calculix-ccx-2.3/ccx_2.3/src/radiate.f --- calculix-ccx-2.1/ccx_2.3/src/radiate.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/radiate.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,80 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine radiate(e,sink,temp,kstep,kinc,time,noel,npt, + & coords,jltyp,field,nfield,loadtype,node,area,vold,mi, + & iemchange) +! +! user subroutine radiate +! +! +! INPUT: +! +! sink present sink temperature +! temp current temperature value +! kstep step number +! kinc increment number +! time(1) current step time +! time(2) current total time +! noel element number +! npt integration point number +! coords(1..3) global coordinates of the integration point +! jltyp loading face kode: +! 11 = face 1 +! 12 = face 2 +! 13 = face 3 +! 14 = face 4 +! 15 = face 5 +! 16 = face 6 +! field currently not used +! nfield currently not used (value = 1) +! loadtype load type label +! node currently not used +! area area covered by the integration point +! vold(0..4,1..nk) solution field in all nodes +! 0: temperature +! 1: displacement in global x-direction +! 2: displacement in global y-direction +! 3: displacement in global z-direction +! 4: static pressure +! mi(1) max # of integration points per element (max +! over all elements) +! mi(2) max degree of freedomm per node (max over all +! nodes) in fields like v(0:mi(2))... +! +! OUTPUT: +! +! e(1) magnitude of the emissivity +! e(2) not used; please do NOT assign any value +! sink sink temperature (need not be defined +! for cavity radiation) +! iemchange = 1 if the emissivity is changed during a step, +! else zero. +! + implicit none +! + character*20 loadtype + integer kstep,kinc,noel,npt,jltyp,nfield,node,mi(2),iemchange + real*8 e(2),sink,time(2),coords(3),temp,field(nfield),area, + & vold(0:mi(2),*) +! + e(1)=0.72d0 +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/radiates.f calculix-ccx-2.3/ccx_2.3/src/radiates.f --- calculix-ccx-2.1/ccx_2.3/src/radiates.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/radiates.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,330 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine radiates(inpc,textpart,set,istartset,iendset, + & ialset,nset,nelemload,sideload,xload,nload,nload_, + & ielmat,ntmat_,iamload,amname,nam,lakon,ne,radiate_flag, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,physcon,nam_,namtot_, + & namta,amta,ipoinpc) +! +! reading the input deck: *RADIATE +! + implicit none +! + logical radiate_flag,environmentnode +! + character*1 inpc(*) + character*3 cavlabel + character*8 lakon(*) + character*20 sideload(*),label + character*80 amname(*),amplitude + character*81 set(*),elset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),nelemload(2,*), + & ielmat(*),nset,nload,nload_,ntmat_,istep,istat,n,i,j,l,key, + & iamload(2,*),nam,iamptemp,ipos,ne,node,iampradi,iline,ipol, + & inl,ipoinp(2,*),inp(3,*),nam_,namtot,namtot_,namta(3,*), + & idelay1,idelay2,ipoinpc(0:*) +! + real*8 xload(2,*),xmagradi,xmagtemp,physcon(*),amta(2,*) +! + iamptemp=0 + iampradi=0 + idelay1=0 + idelay2=0 + cavlabel=' ' +! + environmentnode=.false. +! + if(istep.lt.1) then + write(*,*) '*ERROR in radiates: *RADIATE should only be used' + write(*,*) ' within a STEP' + stop + endif +! + if(physcon(2).le.0.d0) then + write(*,*) '*ERROR in radiates: *RADIATE card was selected' + write(*,*) ' but no *PHYSICAL CONSTANTS card encountered' + stop + endif +! + do i=2,n + if((textpart(i)(1:6).eq.'OP=NEW').and.(.not.radiate_flag)) then + do j=1,nload + if(sideload(j)(1:1).eq.'R') then + xload(1,j)=0.d0 + endif + enddo + elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then + read(textpart(i)(11:90),'(a80)') amplitude + do j=nam,1,-1 + if(amname(j).eq.amplitude) then + iamptemp=j + exit + endif + enddo + if(j.eq.0) then + write(*,*)'*ERROR in radiates: nonexistent amplitude' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iamptemp=j + elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN + if(idelay1.ne.0) then + write(*,*) '*ERROR in radiates: the parameter TIME DELAY' + write(*,*) ' is used twice in the same keyword' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + else + idelay1=1 + endif + nam=nam+1 + if(nam.gt.nam_) then + write(*,*) '*ERROR in radiates: increase nam_' + stop + endif + amname(nam)=' + & ' + if(iamptemp.eq.0) then + write(*,*) '*ERROR in radiates: time delay must be' + write(*,*) ' preceded by the amplitude parameter' + stop + endif + namta(3,nam)=isign(iamptemp,namta(3,iamptemp)) + iamptemp=nam + if(nam.eq.1) then + namtot=0 + else + namtot=namta(2,nam-1) + endif + namtot=namtot+1 + if(namtot.gt.namtot_) then + write(*,*) '*ERROR radiates: increase namtot_' + stop + endif + namta(1,nam)=namtot + namta(2,nam)=namtot + read(textpart(i)(11:30),'(f20.0)',iostat=istat) + & amta(1,namtot) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:19).eq.'RADIATIONAMPLITUDE=') then + read(textpart(i)(20:99),'(a80)') amplitude + do j=nam,1,-1 + if(amname(j).eq.amplitude) then + iampradi=j + exit + endif + enddo + if(j.eq.0) then + write(*,*)'*ERROR in radiates: nonexistent amplitude' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iampradi=j + elseif(textpart(i)(1:19).eq.'RADIATIONTIMEDELAY=') THEN + if(idelay2.ne.0) then + write(*,*) '*ERROR in radiates: the parameter RADIATION' + write(*,*) ' TIME DELAY is used twice in the' + write(*,*) ' same keyword; ' + call inputerror(inpc,ipoinpc,iline) + stop + else + idelay2=1 + endif + nam=nam+1 + if(nam.gt.nam_) then + write(*,*) '*ERROR in radiates: increase nam_' + stop + endif + amname(nam)=' + & ' + if(iampradi.eq.0) then + write(*,*) '*ERROR in radiates: radiation time delay' + write(*,*) ' must be preceded by the radiation' + write(*,*) ' amplitude parameter' + stop + endif + namta(3,nam)=isign(iampradi,namta(3,iampradi)) + iampradi=nam + if(nam.eq.1) then + namtot=0 + else + namtot=namta(2,nam-1) + endif + namtot=namtot+1 + if(namtot.gt.namtot_) then + write(*,*) '*ERROR radiates: increase namtot_' + stop + endif + namta(1,nam)=namtot + namta(2,nam)=namtot + read(textpart(i)(20:39),'(f20.0)',iostat=istat) + & amta(1,namtot) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:7).eq.'ENVNODE') THEN + environmentnode=.true. + elseif(textpart(i)(1:7).eq.'CAVITY=') THEN + read(textpart(i)(8:10),'(a3)',iostat=istat) cavlabel + else + write(*,*) + & '*WARNING in radiates: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return +! + read(textpart(2)(1:20),'(a20)',iostat=istat) label +! + label(18:20)=cavlabel +! +! compatibility with ABAQUS for shells +! + if(label(2:4).eq.'NEG') label(2:4)='1 ' + if(label(2:4).eq.'POS') label(2:4)='2 ' + if(label(2:2).eq.'N') label(2:2)='5' + if(label(2:2).eq.'P') label(2:2)='6' +! +! reference temperature and radiation coefficient +! (for non uniform loading: use user routine radiation.f) +! + if((label(3:4).ne.'NU').and.(label(5:5).ne.'N')) then + if(environmentnode) then + read(textpart(3)(1:10),'(i10)',iostat=istat) node + else + read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagtemp + node=0 + endif + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(4)(1:20),'(f20.0)',iostat=istat) xmagradi + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + if(environmentnode) then + read(textpart(3)(1:10),'(i10)',iostat=istat) node + else + read(textpart(3)(1:20),'(f20.0)',iostat=istat) xmagtemp + node=0 + endif + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + endif + if(((label(1:2).ne.'R1').and.(label(1:2).ne.'R2').and. + & (label(1:2).ne.'R3').and.(label(1:2).ne.'R4').and. + & (label(1:2).ne.'R5').and.(label(1:2).ne.'R6')).or. + & ((label(3:5).ne.' ').and.(label(3:5).ne.'NU ').and. + & (label(3:5).ne.'CR ').and.(label(3:5).ne.'CRN'))) then + call inputerror(inpc,ipoinpc,iline) + endif +! + read(textpart(1)(1:10),'(i10)',iostat=istat) l + if(istat.eq.0) then + if(l.gt.ne) then + write(*,*) '*ERROR in radiates: element ',l + write(*,*) ' is not defined' + stop + endif +! + if((lakon(l)(1:2).eq.'CP').or. + & (lakon(l)(2:2).eq.'A').or. + & (lakon(l)(7:7).eq.'E').or. + & (lakon(l)(7:7).eq.'S').or. + & (lakon(l)(7:7).eq.'A')) then + if(label(1:2).eq.'R1') then + label(1:2)='R3' + elseif(label(1:2).eq.'R2') then + label(1:2)='R4' + elseif(label(1:2).eq.'R3') then + label(1:2)='R5' + elseif(label(1:2).eq.'R4') then + label(1:2)='R6' + elseif(label(1:2).eq.'R5') then + label(1:2)='R1' + elseif(label(1:2).eq.'R6') then + label(1:2)='R2' + endif + endif + call loadaddt(l,label,xmagradi,xmagtemp,nelemload,sideload, + & xload,nload,nload_,iamload,iamptemp,iampradi,nam,node) + else + read(textpart(1)(1:80),'(a80)',iostat=istat) elset + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + do i=1,nset + if(set(i).eq.elset) exit + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR in radiates: element set ',elset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! + l=ialset(istartset(i)) + if((lakon(l)(1:2).eq.'CP').or. + & (lakon(l)(2:2).eq.'A').or. + & (lakon(l)(7:7).eq.'E').or. + & (lakon(l)(7:7).eq.'S').or. + & (lakon(l)(7:7).eq.'A')) then + if(label(1:2).eq.'R1') then + label(1:2)='R3' + elseif(label(1:2).eq.'R2') then + label(1:2)='R4' + elseif(label(1:2).eq.'R3') then + label(1:2)='R5' + elseif(label(1:2).eq.'R4') then + label(1:2)='R6' + elseif(label(1:2).eq.'R5') then + label(1:2)='R1' + elseif(label(1:2).eq.'R6') then + label(1:2)='R2' + endif + endif +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + l=ialset(j) + call loadaddt(l,label,xmagradi,xmagtemp,nelemload, + & sideload,xload,nload,nload_,iamload, + & iamptemp,iampradi,nam,node) + else + l=ialset(j-2) + do + l=l-ialset(j) + if(l.ge.ialset(j-1)) exit + call loadaddt(l,label,xmagradi,xmagtemp,nelemload, + & sideload,xload,nload,nload_,iamload, + & iamptemp,iampradi,nam,node) + enddo + endif + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/radmatrix.f calculix-ccx-2.3/ccx_2.3/src/radmatrix.f --- calculix-ccx-2.1/ccx_2.3/src/radmatrix.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/radmatrix.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1049 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! +! center of gravity of the projection of the vertices for +! visibility purposes +! exact integration for one triangle: routine cubtri +! if the surfaces are far enough away, one-point integration +! is used +! + subroutine radmatrix(ntr, + & acr,bcr,sideload,nelemload,xloadact,lakon,vold, + & ipkon,kon,co,pmid,e1,e2,e3,iptri, + & kontri,ntri,nloadtr,tarea,tenv,physcon,erad,f, + & dist,idist,area,ithermal,iinc,iit, + & cs,mcs,inocs,ntrit,nk,fenv,istep,dtime,ttime, + & time,iviewfile,jobnamef,xloadold,reltime,nmethod,mi, + & iemchange,nam,iamload) +! + implicit none +! + logical covered(160,160),exi +! +! change following line if nlabel is increased +! + character*87 label(30) + character*8 lakonl,lakon(*) + character*20 sideload(*) + character*132 jobnamef(*),fnvw +! + integer ntr,nelemload(2,*),nope,nopes,mint2d,i,j,k,l, + & node,ifaceq(8,6),ifacet(6,4),iviewfile,mi(2), + & ifacew(8,5),nelem,ig,index,konl(20),iflag, + & ipkon(*),kon(*),ncovered,kontri(3,*),iptri(*),nloadtr(*), + & i1,j1,istart,iend,jstart,jend,imin,imid,imax,mcs,inocs(*), + & k1,kflag,idist(*),ndist,i2,i3,ng,idi,idj,ntri, + & ithermal,iinc,iit,ix,iy,ntrit,jj,is,m,jmod,nkt, + & icntrl,imag,nk,istep,jltyp,nfield,nonzero,nmethod, + & limev,ier,nw,idata(1),ncalls,nlabel,iemchange,nam, + & iamload(2,*) +! + real*8 acr(ntr,*),bcr(ntr,1),xloadact(2,*),h(2),w(239), + & xl2(3,8),coords(3),dxsj2,temp,xi,et,weight,xsj2(3), + & vold(0:mi(2),*),co(3,*),shp2(7,8),xs2(3,7),xn(3),xxn, + & pmid(3,*),e3(4,*),e1(3,*),e2(3,*),p1(3),p2(3),p3(3), + & areamean,tarea(*),tenv(*),x,y,cs(17,*),porigin(3), + & erad(*),fenv(*),e,ec,physcon(*),yymin,yymax,xxmin, + & xxmid,xxmax,dummy,a(3,3),b(3,3),c(3,3),ddd(3),p31(3), + & xx(3),yy(3),ftij,f(ntr,*),dint,dir(3),tl2(8), + & dirloc(3),dist(*),area(*),dd,p21(3),p32(3),pi, + & totarea,fn,stn,qfn,een,t(3),sidemean,tvar(2),field, + & dtime,ttime,time,areaj,xloadold(2,*),reltime,p(3,3), + & fform,ver(2,3),epsabs,epsrel,abserr,vj(3,3),unitvec(3,3), + & rdata(1),vertex(3,3),vertexl(2,3),factor,argument +! + include "gauss.f" +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ + data iflag /2/ +! + common /formfactor/ vj,unitvec,porigin +! + external fform +! +! change following line if nlabel is increased and the dimension +! of field label above! +! + nlabel=30 +! +! factor determines when the numerical integration using cubtri +! is replaced by a simplified formula using only the center +! of gravity of one of the triangles. The integration over the +! other triangle is exact (analytical formula, see +! "Radiosity: a Programmer's Perspective", by Ian Ashdown, Wiley, 1994) +! If the distance between the center of gravity of the triangles +! is larger then factor*the projected sqrt(area) of the triangle on the +! hemisphere, the simplified formula is taken +! + factor=0.d0 +! + pi=4.d0*datan(1.d0) +! + tvar(1)=time + tvar(2)=ttime+dtime +! +! cavity radiation! +! +! the default sink temperature is updated at the start of each +! increment +! + do i=1,ntr + node=nelemload(2,nloadtr(i)) + if(node.ne.0) then + tenv(i)=vold(0,node)-physcon(1) + elseif(iit.le.0) then + tenv(i)=xloadact(2,nloadtr(i))-physcon(1) + endif + enddo +! +! for pure thermal steps the viewfactors have to be +! calculated only once, for thermo-mechanical steps +! (ithermal=3) they are recalculated in each iteration +! unless they are read from file +! + if(((ithermal.eq.3).and.(iviewfile.ge.0)).or.(iit.eq.-1)) then + if(iviewfile.lt.0) then + if(ithermal.eq.3) then + write(*,*) '*WARNING in radmatrix: viewfactors are being' + write(*,*) ' read from file for a thermomechani-' + write(*,*) ' cal calculation: they will not be ' + write(*,*) ' recalculated in every iteration.' + endif +! + write(*,*) 'Reading the viewfactors from file' + write(*,*) +! + if(jobnamef(2)(1:1).eq.' ') then + do i=1,132 + if(jobnamef(1)(i:i).eq.' ') exit + enddo + i=i-1 + fnvw=jobnamef(1)(1:i)//'.vwf' + else + fnvw=jobnamef(2) + endif + inquire(file=fnvw,exist=exi) + if(exi) then + open(10,file=fnvw,status='old',form='unformatted', + & access='sequential',err=10) + else + write(*,*) '*ERROR in radmatrix: viewfactor file ',fnvw + write(*,*) 'does not exist' + stop + endif +! + read(10) nonzero + do k=1,nonzero + read(10) i,j,f(i,j) + enddo + read(10)(fenv(i),i=1,ntr) +! + close(10) + else +! + write(*,*) 'Calculating the viewfactors' + write(*,*) +! + ng=160 + dint=2.d0/ng +! +! updating the displacements for cyclic symmetric structures +! + if(mcs.gt.0) then + nkt=0 + do i=1,mcs + if(int(cs(1,i)).gt.nkt) nkt=int(cs(1,i)) + enddo + nkt=nk*nkt + do i=1,nlabel + do l=1,87 + label(i)(l:l)=' ' + enddo + enddo + label(1)(1:1)='U' + imag=0 + icntrl=2 + call rectcyl(co,vold,fn,stn,qfn,een,cs,nk,icntrl,t, + & label,imag,mi) + + do jj=0,mcs-1 + is=cs(1,jj+1) +! + do i=1,is-1 + do l=1,nk + if(inocs(l).ne.jj) cycle + do m=1,mi(2) + vold(m,l+nk*i)=vold(m,l) + enddo + enddo + enddo + enddo + icntrl=-2 + call rectcyl(co,vold,fn,stn,qfn,een,cs,nkt,icntrl,t, + & label,imag,mi) + endif +! +! calculating the momentaneous center of the triangles, +! area of the triangles and normal to the triangles +! + sidemean=0.d0 + do i=1,ntrit + i1=kontri(1,i) + if(i1.eq.0) cycle + i2=kontri(2,i) + i3=kontri(3,i) + do j=1,3 + p1(j)=co(j,i1)+vold(j,i1) + p2(j)=co(j,i2)+vold(j,i2) + p3(j)=co(j,i3)+vold(j,i3) + pmid(j,i)=(p1(j)+p2(j)+p3(j))/3.d0 + p21(j)=p2(j)-p1(j) + p32(j)=p3(j)-p2(j) + enddo +! +! normal to the triangle +! + e3(1,i)=p21(2)*p32(3)-p32(2)*p21(3) + e3(2,i)=p21(3)*p32(1)-p32(3)*p21(1) + e3(3,i)=p21(1)*p32(2)-p32(1)*p21(2) +! + dd=dsqrt(e3(1,i)*e3(1,i)+e3(2,i)*e3(2,i)+ + & e3(3,i)*e3(3,i)) +! +! check for degenerated triangles +! + if(dd.lt.1.d-20) then + area(i)=0.d0 + cycle + endif +! + do j=1,3 + e3(j,i)=e3(j,i)/dd + enddo +! +! area of the triangle +! + area(i)=dd/2.d0 +! +! unit vector parallel to side 1-2 +! + dd=dsqrt(p21(1)*p21(1)+p21(2)*p21(2)+p21(3)*p21(3)) + sidemean=sidemean+dd + do j=1,3 + e1(j,i)=p21(j)/dd + enddo +! +! unit vector orthogonal to e1 and e3 +! + e2(1,i)=e3(2,i)*e1(3,i)-e3(3,i)*e1(2,i) + e2(2,i)=e3(3,i)*e1(1,i)-e3(1,i)*e1(3,i) + e2(3,i)=e3(1,i)*e1(2,i)-e3(2,i)*e1(1,i) +! +! the fourth component in e3 is the constant term in the +! equation of the triangle plane in the form +! e3(1)*x+e3(2)*y+e3(3)*z+e3(4)=0 +! + e3(4,i)=-(e3(1,i)*p1(1)+e3(2,i)*p1(2) + & +e3(3,i)*p1(3)) + enddo + sidemean=sidemean/ntrit +! +! determine the geometrical factors +! +! initialization of the fields +! + do i=1,ntr + do j=1,ntr + f(i,j)=0.d0 + enddo + enddo +! + do i=1,ntri + if(area(i).lt.1.d-20) cycle +! +! vertices of triangle i in local coordinates +! + i1=kontri(1,i) + if(i1.eq.0) cycle + i2=kontri(2,i) + i3=kontri(3,i) + do j=1,3 + porigin(j)=co(j,i1)+vold(j,i1) + p2(j)=co(j,i2)+vold(j,i2) + p3(j)=co(j,i3)+vold(j,i3) + p21(j)=p2(j)-porigin(j) + p31(j)=p3(j)-porigin(j) + enddo + ver(1,1)=0.d0 + ver(2,1)=0.d0 + ver(1,2)=dsqrt(p21(1)**2+p21(2)**2+p21(3)**2) + ver(2,2)=0.d0 + ver(1,3)=p31(1)*e1(1,i)+p31(2)*e1(2,i)+p31(3)*e1(3,i) + ver(2,3)=p31(1)*e2(1,i)+p31(2)*e2(2,i)+p31(3)*e2(3,i) +! + do k=1,3 + unitvec(k,1)=e1(k,i) + unitvec(k,2)=e2(k,i) + unitvec(k,3)=e3(k,i) + enddo +! +! checking which triangles face triangle i +! + ndist=0 + call nident(iptri,i,ntr,idi) + do j=1,ntrit + if((kontri(1,j).eq.0).or.(area(j).lt.1.d-20)) cycle + if(pmid(1,j)*e3(1,i)+pmid(2,j)*e3(2,i)+ + & pmid(3,j)*e3(3,i)+e3(4,i).le.sidemean/800.d0) cycle + if(pmid(1,i)*e3(1,j)+pmid(2,i)*e3(2,j)+ + & pmid(3,i)*e3(3,j)+e3(4,j).le.sidemean/800.d0) cycle +! + if(j.gt.ntri) then + jmod=mod(j,ntri) + if(jmod.eq.0) jmod=ntri + else + jmod=j + endif +! +c call nident(iptri,i,ntr,idi) + call nident(iptri,jmod,ntr,idj) + if(sideload(nloadtr(idi))(18:20).ne. + & sideload(nloadtr(idj))(18:20)) cycle +! + ndist=ndist+1 + dist(ndist)=dsqrt((pmid(1,j)-pmid(1,i))**2+ + & (pmid(2,j)-pmid(2,i))**2+ + & (pmid(3,j)-pmid(3,i))**2) + idist(ndist)=j + enddo + if(ndist.eq.0) cycle +! +! ordering the triangles +! + kflag=2 + call dsort(dist,idist,ndist,kflag) +! +! initializing the coverage matrix +! +c write(*,*) i,(idist(i1),i1=1,ndist) + ncovered=0 + do i1=1,ng + x=((i1-0.5d0)*dint-1.d0)**2 + do j1=1,ng + y=((j1-0.5d0)*dint-1.d0)**2 + if(x+y.gt.1.d0) then + covered(i1,j1)=.true. + ncovered=ncovered+1 + else + covered(i1,j1)=.false. + endif + enddo + enddo +! + do k1=1,ndist + j=idist(k1) +! +! determining the 2-D projection of the vertices +! of triangle j +! + do l=1,3 + do k=1,3 + vertex(k,l)=co(k,kontri(l,j))-pmid(k,i) + enddo + dd=dsqrt(vertex(1,l)**2+vertex(2,l)**2+ + & vertex(3,l)**2) + do k=1,3 + vertex(k,l)=vertex(k,l)/dd + enddo + vertexl(1,l)=vertex(1,l)*e1(1,i)+ + & vertex(2,l)*e1(2,i)+ + & vertex(3,l)*e1(3,i) + vertexl(2,l)=vertex(1,l)*e2(1,i)+ + & vertex(2,l)*e2(2,i)+ + & vertex(3,l)*e2(3,i) + enddo +! +! determining the center of gravity of the projected +! triangle +! + do k=1,2 + dirloc(k)=(vertexl(k,1)+vertexl(k,2)+ + & vertexl(k,3))/3.d0 + enddo +! +! determine the direction vector in global coordinates +! + do k=1,3 + dir(k)=(pmid(k,j)-pmid(k,i))/dist(k1) + enddo +! +! direction vector in local coordinates of triangle i +! + dirloc(3)=dir(1)*e3(1,i)+dir(2)*e3(2,i)+dir(3)*e3(3,i) +! +! check whether this direction was already covered +! + ix=int((dirloc(1)+1.d0)/dint)+1 + iy=int((dirloc(2)+1.d0)/dint)+1 + if(covered(ix,iy)) then +c write(*,*) 'triangle ',j,' was already covered' + cycle + endif +! +! if surfaces are close, numerical integration with +! cubtri is performed +! + if(dist(k1).le.factor*dsqrt(area(i))*dirloc(3)) then +! +! vertices of triangle j +! + do k=1,3 + do l=1,3 + vj(l,k)=co(l,kontri(k,j))+vold(l,kontri(k,j)) + enddo + enddo +! +! formfactor contribution +! + epsrel=0.01d0 + epsabs=0.d0 + limev=100 + nw=239 + ncalls=0 +! +! max 1000 evaluations for nw=239 +! + call cubtri(fform,ver,epsrel,limev,ftij,abserr,ncalls, + & w,nw,idata,rdata,ier) + ftij=ftij/2.d0 +c write(*,*) 'formfactor contri ',i,j,ftij/area(i),ier, +c & abserr,ncalls + endif +! +! updating the coverage matrix +! + do k=1,3 + p(k,1)=co(k,kontri(1,j))+vold(k,kontri(1,j))-pmid(k,i) + enddo + ddd(1)=dsqrt(p(1,1)*p(1,1)+p(2,1)*p(2,1)+p(3,1)*p(3,1)) + do k=1,3 + p1(k)=p(k,1)/ddd(1) + enddo + xx(1)=p1(1)*e1(1,i)+p1(2)*e1(2,i)+p1(3)*e1(3,i) + yy(1)=p1(1)*e2(1,i)+p1(2)*e2(2,i)+p1(3)*e2(3,i) +! + do k=1,3 + p(k,2)=co(k,kontri(2,j))+vold(k,kontri(2,j))-pmid(k,i) + enddo + ddd(2)=dsqrt(p(1,2)*p(1,2)+p(2,2)*p(2,2)+p(3,2)*p(3,2)) + do k=1,3 + p2(k)=p(k,2)/ddd(2) + enddo + xx(2)=p2(1)*e1(1,i)+p2(2)*e1(2,i)+p2(3)*e1(3,i) + yy(2)=p2(1)*e2(1,i)+p2(2)*e2(2,i)+p2(3)*e2(3,i) +! + do k=1,3 + p(k,3)=co(k,kontri(3,j))+vold(k,kontri(3,j))-pmid(k,i) + enddo + ddd(3)=dsqrt(p(1,3)*p(1,3)+p(2,3)*p(2,3)+p(3,3)*p(3,3)) + do k=1,3 + p3(k)=p(k,3)/ddd(3) + enddo + xx(3)=p3(1)*e1(1,i)+p3(2)*e1(2,i)+p3(3)*e1(3,i) + yy(3)=p3(1)*e2(1,i)+p3(2)*e2(2,i)+p3(3)*e2(3,i) +! + if(dabs(xx(2)-xx(1)).lt.1.d-5) xx(2)=xx(1)+1.d-5 + if(dabs(xx(2)-xx(1)).lt.1.d-5) xx(2)=xx(1)+1.d-5 +! +! if the surfaces are far enough away, one-point +! integration is used +! + if(dist(k1).gt.factor*dsqrt(area(i))*dirloc(3)) then + ftij=0.d0 + do k=1,3 + l=k-1 + if(l.lt.1) l=3 + xn(1)=p(2,k)*p(3,l)-p(2,l)*p(3,k) + xn(2)=p(3,k)*p(1,l)-p(3,l)*p(1,k) + xn(3)=p(1,k)*p(2,l)-p(1,l)*p(2,k) + xxn=dsqrt(xn(1)**2+xn(2)**2+xn(3)**2) +! +! argument of dacos must have an absolute value +! smaller than or equal to 1.d0; due to +! round-off the value can slightly exceed one +! and has to be cut-off. +! + argument= + & (p(1,k)*p(1,l)+p(2,k)*p(2,l)+p(3,k)*p(3,l))/ + & (ddd(k)*ddd(l)) + if(dabs(argument).gt.1.d0) then + if(argument.gt.0.d0) then + argument=1.d0 + else + argument=-1.d0 + endif + endif + ftij=ftij+ + & (e3(1,i)*xn(1) + & +e3(2,i)*xn(2) + & +e3(3,i)*xn(3))/xxn + & *dacos(argument) +c & (p(1,k)*p(1,l)+p(2,k)*p(2,l)+p(3,k)*p(3,l))/ +c & (ddd(k)*ddd(l))) + enddo + ftij=ftij*area(i)/2.d0 +c write(*,*) 'formfactor contri: one-point ', +c & i,j,ftij/area(i) + endif +! +! localizing which surface interaction the +! triangle interaction is part of (the modulus is +! necessary for cyclic structures) +! + if(j.gt.ntri) then + jmod=mod(j,ntri) + if(jmod.eq.0) jmod=ntri + else + jmod=j + endif +! +c call nident(iptri,i,ntr,idi) + call nident(iptri,jmod,ntr,idj) + f(idi,idj)=f(idi,idj)+ftij +! +! determining maxima and minima +! + xxmin=2.d0 + xxmax=-2.d0 + do k=1,3 + if(xx(k).lt.xxmin) then + xxmin=xx(k) + imin=k + endif + if(xx(k).gt.xxmax) then + xxmax=xx(k) + imax=k + endif + enddo +! + if(((imin.eq.1).and.(imax.eq.2)).or. + & ((imin.eq.2).and.(imax.eq.1))) then + imid=3 + xxmid=xx(3) + elseif(((imin.eq.2).and.(imax.eq.3)).or. + & ((imin.eq.3).and.(imax.eq.2))) then + imid=1 + xxmid=xx(1) + else + imid=2 + xxmid=xx(2) + endif +! +! check for equal x-values +! + if(xxmid-xxmin.lt.1.d-5) then + xxmin=xxmin-1.d-5 + xx(imin)=xxmin + endif + if(xxmax-xxmid.lt.1.d-5) then + xxmax=xxmax+1.d-5 + xx(imax)=xxmax + endif +! +! equation of the straight lines connecting the +! triangle vertices in the local x-y plane +! + a(1,2)=yy(2)-yy(1) + b(1,2)=xx(1)-xx(2) + c(1,2)=yy(1)*xx(2)-xx(1)*yy(2) +! + a(2,3)=yy(3)-yy(2) + b(2,3)=xx(2)-xx(3) + c(2,3)=yy(2)*xx(3)-xx(2)*yy(3) +! + a(3,1)=yy(1)-yy(3) + b(3,1)=xx(3)-xx(1) + c(3,1)=yy(3)*xx(1)-xx(3)*yy(1) +! + a(2,1)=a(1,2) + b(2,1)=b(1,2) + c(2,1)=c(1,2) + a(3,2)=a(2,3) + b(3,2)=b(2,3) + c(3,2)=c(2,3) + a(1,3)=a(3,1) + b(1,3)=b(3,1) + c(1,3)=c(3,1) +! + istart=int((xxmin+1.d0+dint/2.d0)/dint)+1 + iend=int((xxmid+1.d0+dint/2.d0)/dint) + do i1=istart,iend + x=dint*(i1-0.5d0)-1.d0 + yymin=-(a(imin,imid)*x+c(imin,imid))/b(imin,imid) + yymax=-(a(imin,imax)*x+c(imin,imax))/b(imin,imax) + if(yymin.gt.yymax) then + dummy=yymin + yymin=yymax + yymax=dummy + endif + jstart=int((yymin+1.d0+dint/2.d0)/dint)+1 + jend=int((yymax+1.d0+dint/2.d0)/dint) + do j1=jstart,jend + covered(i1,j1)=.true. + enddo + ncovered=ncovered+jend-jstart+1 + enddo +! + istart=int((xxmid+1.d0+dint/2.d0)/dint)+1 + iend=int((xxmax+1.d0+dint/2.d0)/dint) + do i1=istart,iend + x=dint*(i1-0.5d0)-1.d0 + yymin=-(a(imid,imax)*x+c(imid,imax))/b(imid,imax) + yymax=-(a(imin,imax)*x+c(imin,imax))/b(imin,imax) + if(yymin.gt.yymax) then + dummy=yymin + yymin=yymax + yymax=dummy + endif + jstart=int((yymin+1.d0+dint/2.d0)/dint)+1 + jend=int((yymax+1.d0+dint/2.d0)/dint) + do j1=jstart,jend + covered(i1,j1)=.true. + enddo + ncovered=ncovered+jend-jstart+1 + enddo + if(ncovered.eq.ng*ng)exit +! + enddo + enddo +! +! division through total area and through pi +! + do i=1,ntr + totarea=0.d0 + if(i.lt.ntr) then + do j=iptri(i),iptri(i+1)-1 + totarea=totarea+area(j) + enddo + else + do j=iptri(i),ntri + totarea=totarea+area(j) + enddo + endif + totarea=totarea*4.d0*datan(1.d0) + do j=1,ntr + f(i,j)=f(i,j)/totarea + enddo + enddo +! +! checking whether the sum of the viewfactors does not +! exceed 1 +! + do i=1,ntr + fenv(i)=0.d0 + do j=1,ntr + fenv(i)=fenv(i)+f(i,j) + enddo +c write(*,*) nelemload(1,i),',',sideload(i),',',fenv(i), +c & ',',1.d0-fenv(i) + if((fenv(i).gt.1.d0).or.(tenv(i).lt.0)) then + if(fenv(i).gt.0.d0) then + do j=1,ntr + f(i,j)=f(i,j)/fenv(i) + enddo + fenv(i)=1.d0 + else + write(*,*) '*WARNING in radmatrix: viewfactors' + write(*,*) ' for 3D-face''', + & sideload(nloadtr(i)),'''' + write(*,*) ' of element', + & nelemload(1,nloadtr(i)) + write(*,*) ' cannot be scaled since they are' + write(*,*) ' all zero' + write(*,*) + endif + endif + fenv(i)=1.d0-fenv(i) + enddo +! + endif +! + nonzero=0 + do i=1,ntr + do j=1,ntr + if(dabs(f(i,j)).gt.1.d-20) nonzero=nonzero+1 + enddo + enddo +! + if(abs(iviewfile).eq.2) then +! + write(*,*) 'Writing the viewfactors to file' + write(*,*) +! + if(jobnamef(3)(1:1).eq.' ') then + do i=1,132 + if(jobnamef(1)(i:i).eq.' ') exit + enddo + i=i-1 + fnvw=jobnamef(1)(1:i)//'.vwf' + else + fnvw=jobnamef(3) + endif + open(10,file=fnvw,status='unknown',form='unformatted', + & access='sequential',err=10) +! + write(10) nonzero + do i=1,ntr + do j=1,ntr + if(dabs(f(i,j)).gt.1.d-20) write(10) i,j,f(i,j) + enddo + enddo + write(10)(fenv(i),i=1,ntr) + close(10) + endif +! + endif +! +! initialization of acr and bcr +! +c do i=1,ntr +c! +c! acr is (re)initialized only if the viewfactors changed +c! or the emissivity +c! +c if(((ithermal.eq.3).and.(iviewfile.ge.0)).or. +c & (iit.eq.-1).or.(iemchange.eq.1).or. +c & ((iit.eq.0).and.(nmethod.eq.1))) then +c do j=1,ntr +c acr(i,j)=0.d0 +c enddo +c endif +c bcr(i,1)=0.d0 +c enddo +! +! filling acr and bcr +! + do i1=1,ntr +c if(((ithermal.eq.3).and.(iviewfile.ge.0)).or. +c & (iit.eq.-1).or.(iemchange.eq.1).or. +c & ((iit.eq.0).and.(nmethod.eq.1))) then +c acr(i1,i1)=1.d0 +c endif + i=nloadtr(i1) + nelem=nelemload(1,i) + lakonl=lakon(nelem) +! +! calculate the mean temperature of the face +! + read(sideload(i)(2:2),'(i1)') ig +! +! number of nodes and integration points in the face +! + if(lakonl(4:4).eq.'2') then + nope=20 + nopes=8 + elseif(lakonl(4:4).eq.'8') then + nope=8 + nopes=4 + elseif(lakonl(4:5).eq.'10') then + nope=10 + nopes=6 + elseif(lakonl(4:4).eq.'4') then + nope=4 + nopes=3 + elseif(lakonl(4:5).eq.'15') then + nope=15 + else + nope=6 + endif +! + if(lakonl(4:5).eq.'8R') then + mint2d=1 + elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R')) + & then + if(lakonl(7:7).eq.'A') then + mint2d=2 + else + mint2d=4 + endif + elseif(lakonl(4:4).eq.'2') then + mint2d=9 + elseif(lakonl(4:5).eq.'10') then + mint2d=3 + elseif(lakonl(4:4).eq.'4') then + mint2d=1 + endif +! + if(lakonl(4:4).eq.'6') then + mint2d=1 + if(ig.le.2) then + nopes=3 + else + nopes=4 + endif + endif + if(lakonl(4:5).eq.'15') then + if(ig.le.2) then + mint2d=3 + nopes=6 + else + mint2d=4 + nopes=8 + endif + endif +! +! connectivity of the element +! + index=ipkon(nelem) + if(index.lt.0) then + write(*,*) '*ERROR in radmatrix: element ',nelem + write(*,*) ' is not defined' + stop + endif + do k=1,nope + konl(k)=kon(index+k) + enddo +! +! coordinates of the nodes belonging to the face +! + if((nope.eq.20).or.(nope.eq.8)) then + do k=1,nopes + tl2(k)=vold(0,konl(ifaceq(k,ig))) +! + do j=1,3 + xl2(j,k)=co(j,konl(ifaceq(k,ig)))+ + & vold(j,konl(ifaceq(k,ig))) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + do k=1,nopes + tl2(k)=vold(0,konl(ifacet(k,ig))) + do j=1,3 + xl2(j,k)=co(j,konl(ifacet(k,ig)))+ + & vold(j,konl(ifacet(k,ig))) + enddo + enddo + else + do k=1,nopes + tl2(k)=vold(0,konl(ifacew(k,ig))) + do j=1,3 + xl2(j,k)=co(j,konl(ifacew(k,ig)))+ + & vold(j,konl(ifacew(k,ig))) + enddo + enddo + endif +! +! integration to obtain the center of gravity and the mean +! temperature; radiation coefficient +! + areamean=0.d0 + tarea(i1)=0.d0 +! + read(sideload(i)(2:2),'(i1)') jltyp + jltyp=jltyp+10 + if(sideload(i)(5:6).ne.'NU') then + erad(i1)=xloadact(1,i) +! +! if an amplitude was defined for the emissivity it is +! assumed that the emissivity changes with the step, so +! acr has to be calculated anew in every iteration +! + if(nam.gt.0) then + if(iamload(1,i).ne.0) then + iemchange=1 + endif + endif + else + erad(i1)=0.d0 + endif +! + do l=1,mint2d + if((lakonl(4:5).eq.'8R').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then + xi=gauss2d1(1,l) + et=gauss2d1(2,l) + weight=weight2d1(l) + elseif((lakonl(4:4).eq.'8').or. + & (lakonl(4:6).eq.'20R').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then + xi=gauss2d2(1,l) + et=gauss2d2(2,l) + weight=weight2d2(l) + elseif(lakonl(4:4).eq.'2') then + xi=gauss2d3(1,l) + et=gauss2d3(2,l) + weight=weight2d3(l) + elseif((lakonl(4:5).eq.'10').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then + xi=gauss2d5(1,l) + et=gauss2d5(2,l) + weight=weight2d5(l) + elseif((lakonl(4:4).eq.'4').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then + xi=gauss2d4(1,l) + et=gauss2d4(2,l) + weight=weight2d4(l) + endif +! + if(nopes.eq.8) then + call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + endif +! + dxsj2=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+ + & xsj2(3)*xsj2(3)) +! + temp=0.d0 + do j=1,nopes + temp=temp+tl2(j)*shp2(4,j) + enddo +! + tarea(i1)=tarea(i1)+temp*dxsj2*weight + areamean=areamean+dxsj2*weight +! + if(sideload(i)(5:6).eq.'NU') then + areaj=dxsj2*weight + do k=1,3 + coords(k)=0.d0 + enddo + do j=1,nopes + do k=1,3 + coords(k)=coords(k)+xl2(k,j)*shp2(4,j) + enddo + enddo + call radiate(h(1),tenv(i1),temp,istep, + & iinc,tvar,nelem,l,coords,jltyp,field,nfield, + & sideload(i),node,areaj,vold,mi,iemchange) + if(nmethod.eq.1) h(1)=xloadold(1,i)+ + & (h(1)-xloadold(1,i))*reltime + erad(i1)=erad(i1)+h(1) + endif +! + enddo + tarea(i1)=tarea(i1)/areamean-physcon(1) + if(sideload(i)(5:6).eq.'NU') then + erad(i1)=erad(i1)/mint2d + endif +! +! radiation coefficient +! +! + e=erad(i1) + ec=1.d0-e +! +! acr is recalculated only if the viewfactors changed +! or the emissivity +! + if(((ithermal.eq.3).and.(iviewfile.ge.0)).or. + & (iit.eq.-1).or.(iemchange.eq.1).or. + & ((iit.eq.0).and.(nmethod.eq.1))) then + do j1=1,ntr +c acr(i1,j1)=acr(i1,j1)-ec*f(i1,j1) + acr(i1,j1)=-ec*f(i1,j1) + enddo + acr(i1,i1)=1.d0+acr(i1,i1) + endif + bcr(i1,1)=physcon(2)*(e*tarea(i1)**4+ + & ec*fenv(i1)*tenv(i1)**4) +! + enddo +! + return +! + 10 write(*,*) '*ERROR in radmatrix: could not open file ',fnvw + stop + end +! +! function to be integrated +! + real*8 function fform(x,y,idata,rdata) +! + implicit none +! + integer k,l,number,idata(1) +! + real*8 pint(3),ddd(3),xn(3),vj(3,3), + & unitvec(3,3),p(3,3),xxn,x,y,porigin(3),rdata(1) +! + common /formfactor/ vj,unitvec,porigin +! + data number /0/ + save number +! + number=number+1 + do k=1,3 + pint(k)=porigin(k)+x*unitvec(k,1)+y*unitvec(k,2) + enddo +! + do k=1,3 + p(k,1)=vj(k,1)-pint(k) + enddo + ddd(1)=dsqrt(p(1,1)*p(1,1)+p(2,1)*p(2,1)+p(3,1)*p(3,1)) +! + do k=1,3 + p(k,2)=vj(k,2)-pint(k) + enddo + ddd(2)=dsqrt(p(1,2)*p(1,2)+p(2,2)*p(2,2)+p(3,2)*p(3,2)) +! + do k=1,3 + p(k,3)=vj(k,3)-pint(k) + enddo + ddd(3)=dsqrt(p(1,3)*p(1,3)+p(2,3)*p(2,3)+p(3,3)*p(3,3)) +! +! calculating the contribution +! + fform=0.d0 + do k=1,3 + l=k-1 + if(l.lt.1) l=3 + xn(1)=p(2,k)*p(3,l)-p(2,l)*p(3,k) + xn(2)=p(3,k)*p(1,l)-p(3,l)*p(1,k) + xn(3)=p(1,k)*p(2,l)-p(1,l)*p(2,k) + xxn=dsqrt(xn(1)**2+xn(2)**2+xn(3)**2) + fform=fform+ + & (unitvec(1,3)*xn(1) + & +unitvec(2,3)*xn(2) + & +unitvec(3,3)*xn(3))/xxn + & *dacos( + & (p(1,k)*p(1,l)+p(2,k)*p(2,l)+p(3,k)*p(3,l))/ + & (ddd(k)*ddd(l))) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/radresult.f calculix-ccx-2.3/ccx_2.3/src/radresult.f --- calculix-ccx-2.1/ccx_2.3/src/radresult.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/radresult.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,51 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine radresult(ntr,xloadact,bcr,nloadtr,tarea, + & tenv,physcon,erad,f,fenv) +! + implicit none +! + integer i,j,ntr,nloadtr(*) +! + real*8 xloadact(2,*), tarea(*),tenv(*), + & erad(*),q,fenv(*),physcon(*),f(ntr,*),bcr(ntr,1) +! +! calculating the flux and transforming the flux into an +! equivalent temperature +! + write(*,*) '' + + do i=1,ntr + q=bcr(i,1) + do j=1,ntr + if(i.eq.j)cycle + q=q-f(i,j)*bcr(j,1) + enddo + q=q-fenv(i)*physcon(2)*tenv(i)**4 + xloadact(2,nloadtr(i))= + & max(tarea(i)**4-q/(erad(i)*physcon(2)),0.d0) +c write(*,*) xloadact(2,nloadtr(i)) + xloadact(2,nloadtr(i))= + & (xloadact(2,nloadtr(i)))**0.25+physcon(1) +c write(*,*) xloadact(2,nloadtr(i)) +c write(*,*) i,bcr(i,1),q,xloadact(2,nloadtr(i) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/ranewr.f calculix-ccx-2.3/ccx_2.3/src/ranewr.f --- calculix-ccx-2.1/ccx_2.3/src/ranewr.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ranewr.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,96 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + REAL FUNCTION RANEWR () +C +C ERZEUGUNG GLEICHVERTEILTER ZUFALLSZAHLEN ZWISCHEN 0 UND 1. +C PORTABLER ZUFALLSZAHLENGENERATOR IN STANDARD F77 +C +C AUTOR: H. PFOERTNER +C +C AENDERUNGSSTAND : +C 26.08.95 EXTERNAL RAEWIN ENGEFUEGT, UM UEBER BLOCKDATA-LINK +C STARTBELEGUNG AUCH OHNE INIRAN-AUFRUF ZU ERZWINGEN +C 07.12.92 BASISVERSION +C +C LITERATUR: WICHMANN AND HILL: APPL. STATIST. (JRSSC), +C (31) 188-190, (1982) +C +C GEDAECHTNIS: +C MUSS VOR DEM ERSTEN AUFRUF VON RANEWR DURCH EINEN AUFRUF VON +C INIRAN VORBELEGT WERDEN. + INTEGER IX, IY, IZ + COMMON /XXXRAN/ IX, IY, IZ +C + EXTERNAL RAEWIN +C +C MODULO-OPERATIONEN + IX = 171 * MOD ( IX, 177) - 2 * ( IX / 177 ) + IY = 172 * MOD ( IY, 176) - 35 * ( IY / 176 ) + IZ = 170 * MOD ( IZ, 178) - 63 * ( IZ / 178 ) +C +C AUF POSITIVEN BEREICH BRINGEN + IF ( IX .LT. 0 ) IX = IX + 30269 + IF ( IY .LT. 0 ) IY = IY + 30307 + IF ( IZ .LT. 0 ) IZ = IZ + 30323 +C +C ZAHL ZWISCHEN 0 UND 1 ERZEUGEN + RANEWR = MOD ( REAL(IX) / 30269.0 + & + REAL(IY) / 30307.0 + & + REAL(IZ) / 30323.0, 1.0 ) +C + RETURN +C ENDE DER FUNCTION RANEWR + END +C ******************************************************************* + SUBROUTINE INIRAN(i1,i2,i3) +C +C STARTBELEGUNG FUER DEN ZUFALLSZAHLENGENERATOR RANEWR +C +C AUTOR: H. PFOERTNER +C +C AENDERUNGSSTAND : +C 07.12.92 BASISVERSION +C +C LITERATUR: WICHMANN AND HILL: APPL. STATIST. (JRSSC), +C (31) 188-190, (1982) +C +C GEDAECHTNIS: + INTEGER IX, IY, IZ + COMMON /XXXRAN/ IX, IY, IZ +C +C VORBELEGUNG + IX = i1 + IY = i2 + IZ = i3 +C + RETURN +C ENDE DES UP. INIRAN + END +C ******************************************************************* + BLOCKDATA RAEWIN +C +C ERZWINGUNG EINER STARTBELEGUNG (Z.B. BEI VERGESSENEM INIRAN-AUFRUF) +C +C HUGO PFOERTNER / OBERHACHING +C 26.08.95 BASISVERSION +C + INTEGER IX, IY, IZ + COMMON /XXXRAN/ IX, IY, IZ + DATA IX, IY, IZ / 1974, 235, 337 / + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/rcavi2.f calculix-ccx-2.3/ccx_2.3/src/rcavi2.f --- calculix-ccx-2.1/ccx_2.3/src/rcavi2.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rcavi2.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,70 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rcavi2(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,R,physcon,dvi,numf,set,mi) +! +! rotating cavity element +! + implicit none +! + logical identity + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(4),idirf(4),index,iflag,mi(2), + & inv,ipkon(*),kon(*),kgas,nelem_in,nelem_out, + & element0,node10,node20,node11,node21,node12,node22,node_cav, + & node_main,node_main2,node_in1,node_out1,node_in2,node_out2 +! + + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R,a,d, + & p1,p2,T1,T2,Aeff,C1,C2,C3,cd,cp,physcon(3),p2p1,km1,dvi, + & kp1,kdkm1,tdkp1,km1dk,x,y,ca1,cb1,ca2,cb2,dT1,alambda, + & reynolds,pi,xflow_oil,s,Tcav,pcav,pmin,pmax, + & Tref,Alpha1, Alpha2, Alpha3, GF,kf,MRTAP_ref_ein, + & MRTAP_ref_aus, m_ref_ein, m_ref_aus,maus_zu_mref, + & mein_zu_mref, A_aus, A_ein, A_ges,m_aus, m_ein, m_sperr +! + pi=4.d0*datan(1.d0) + + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1) then +! + p1=v(2,node1) + call rcavi_cp_lt(xflow) + + call rcavi_cp_nt(xflow) + elseif (iflag.eq.2) then +! + elseif (iflag.eq.3) then +! + endif + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/rcavi_cp_lt.f calculix-ccx-2.3/ccx_2.3/src/rcavi_cp_lt.f --- calculix-ccx-2.1/ccx_2.3/src/rcavi_cp_lt.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rcavi_cp_lt.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,27 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rcavi_cp_lt(xflow) +! +! rcavi element +! + real*8 xflow +! + write(*,*)'xflow',xflow +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/rcavi_cp_nt.f calculix-ccx-2.3/ccx_2.3/src/rcavi_cp_nt.f --- calculix-ccx-2.1/ccx_2.3/src/rcavi_cp_nt.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rcavi_cp_nt.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,27 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rcavi_cp_nt(xflow) +! +! rcavi element +! + real*8 xflow +! + write(*,*)'xflow',xflow +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/rcavi.f calculix-ccx-2.3/ccx_2.3/src/rcavi.f --- calculix-ccx-2.1/ccx_2.3/src/rcavi.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rcavi.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,70 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rcavi(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,R,physcon,dvi,numf,set,mi) +! +! rotating cavity element +! + implicit none +! + logical identity + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(4),idirf(4),index,iflag,mi(2), + & inv,ipkon(*),kon(*),kgas,nelem_in,nelem_out, + & element0,node10,node20,node11,node21,node12,node22,node_cav, + & node_main,node_main2,node_in1,node_out1,node_in2,node_out2 +! + + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R,a,d, + & p1,p2,T1,T2,Aeff,C1,C2,C3,cd,cp,physcon(3),p2p1,km1,dvi, + & kp1,kdkm1,tdkp1,km1dk,x,y,ca1,cb1,ca2,cb2,dT1,alambda, + & reynolds,pi,xflow_oil,s,Tcav,pcav,pmin,pmax, + & Tref,Alpha1, Alpha2, Alpha3, GF,kf,MRTAP_ref_ein, + & MRTAP_ref_aus, m_ref_ein, m_ref_aus,maus_zu_mref, + & mein_zu_mref, A_aus, A_ein, A_ges,m_aus, m_ein, m_sperr +! + pi=4.d0*datan(1.d0) + + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1) then +! + p1=v(2,node1) + call rcavi_cp_lt(xflow) + + call rcavi_cp_nt(xflow) + elseif (iflag.eq.2) then +! + elseif (iflag.eq.3) then +! + endif + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/readinput.c calculix-ccx-2.3/ccx_2.3/src/readinput.c --- calculix-ccx-2.1/ccx_2.3/src/readinput.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/readinput.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,382 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include +#include "CalculiX.h" + +void readinput(char *jobnamec, char **inpcp, int *nline, int *nset, + int *ipoinp, int **inpp, int **ipoinpcp, int *ithermal){ + + /* reads and stores the input deck in inpcp; determines the + number of sets */ + + FILE *f1[10]; + + char buff[1320], fninp[132]="", includefn[132]="", *inpc=NULL, + textpart[2112],*set=NULL; + + int i,j,k,n,in=0,nlinemax=100000,irestartread,irestartstep, + icntrl,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat,ntmat,npmat, + norien,nam,nprint,mint,ntrans,ncs,namtot,ncmat,memmpc,ne1d, + ne2d,nflow,*meminset=NULL,*rmeminset=NULL, *inp=NULL,ntie, + nener,nstate,nentries=14,ifreeinp,ikey,lincludefn, + nbody,ncharmax=1000000,*ipoinpc=NULL,ichangefriction=0; + + /* initialization */ + + /* nentries is the number of different keyword cards for which + the input deck order is important, cf keystart.f */ + + inpc=NNEW(char,ncharmax); + ipoinpc=NNEW(int,nlinemax+1); + inp=NNEW(int,3*nlinemax); + *nline=0; + for(i=0;i<2*nentries;i++){ipoinp[i]=0;} + ifreeinp=1; + ikey=0; + + /* opening the input file */ + + strcpy(fninp,jobnamec); + strcat(fninp,".inp"); + if((f1[in]=fopen(fninp,"r"))==NULL){ + printf("*ERROR in read: cannot open file %s\n",fninp); + exit(0); + } + + /* starting to read the input file */ + + do{ + if(fgets(buff,1320,f1[in])==NULL){ + fclose(f1[in]); + if(in!=0){ + in--; + continue; + } + else{break;} + } + + /* storing the significant characters */ + /* get rid of blanks */ + + k=0; + i=-1; + do{ + i++; + if((buff[i]=='\0')||(buff[i]=='\n')||(buff[i]=='\r')||(k==1320)) break; + if((buff[i]==' ')||(buff[i]=='\t')) continue; + buff[k]=buff[i]; + k++; + }while(1); + + /* check for blank lines and comments */ + + if(k==0) continue; + if(strcmp1(&buff[0],"**")==0) continue; + + /* changing to uppercase except include filenames */ + + if(k<15){ + for(j=0;j9){ + printf("*ERROR in read: include statements can \n not be cascaded over more than 9 levels\n"); + } + if((f1[in]=fopen(includefn,"r"))==NULL){ + printf("*ERROR in read: cannot open file %s\n",includefn); + exit(0); + } + continue; + } + + /* adding a line */ + + (*nline)++; + if(*nline>nlinemax){ + nlinemax=(int)(1.1*nlinemax); + RENEW(ipoinpc,int,nlinemax+1); + RENEW(inp,int,3*nlinemax); + } + + /* checking the total number of characters */ + + if(ipoinpc[*nline-1]+k>ncharmax){ + ncharmax=(int)(1.1*ncharmax); + RENEW(inpc,char,ncharmax); + } + + /* copying into inpc */ + + for(j=0;j +#include +#include +#include +#include "CalculiX.h" + +void remastruct(int *ipompc, double **coefmpcp, int **nodempcp, int *nmpc, + int *mpcfree, int *nodeboun, int *ndirboun, int *nboun, + int *ikmpc, int *ilmpc, int *ikboun, int *ilboun, + char *labmpc, int *nk, + int *memmpc_, int *icascade, int *maxlenmpc, + int *kon, int *ipkon, char *lakon, int *ne, int *nnn, + int *nactdof, int *icol, int *jq, int **irowp, int *isolver, + int *neq, int *nzs,int *nmethod, double **fp, + double **fextp, double **bp, double **aux2p, double **finip, + double **fextinip,double **adbp, double **aubp, int *ithermal, + int *iperturb, int *mass, int *mi){ + + /* reconstructs the nonzero locations in the stiffness and mass + matrix after a change in MPC's */ + + int *nodempc=NULL,*npn=NULL,*adj=NULL,*xadj=NULL,*iw=NULL,*mmm=NULL, + *xnpn=NULL,*mast1=NULL,*ipointer=NULL,mpcend,mpcmult, + callfrommain,i,*irow=NULL; + + double *coefmpc=NULL,*f=NULL,*fext=NULL,*b=NULL,*aux2=NULL, + *fini=NULL,*fextini=NULL,*adb=NULL,*aub=NULL; + + nodempc=*nodempcp;coefmpc=*coefmpcp;irow=*irowp; + f=*fp;fext=*fextp;b=*bp;aux2=*aux2p;fini=*finip; + fextini=*fextinip;adb=*adbp;aub=*aubp; + + /* decascading the MPC's */ + + printf(" Decascading the MPC's\n\n"); + + callfrommain=0; + cascade(ipompc,&coefmpc,&nodempc,nmpc, + mpcfree,nodeboun,ndirboun,nboun,ikmpc, + ilmpc,ikboun,ilboun,&mpcend,&mpcmult, + labmpc,nk,memmpc_,icascade,maxlenmpc, + &callfrommain,iperturb,ithermal); + + /* reallocating nodempc and coefmpc */ + + /* RENEW(nodempc,int,3*mpcend); + RENEW(coefmpc,double,mpcend);*/ + + for(i=1;i<=*nk;++i) nnn[i-1]=i; + + /* renumbering the nodes */ + + /*printf(" Renumbering the nodes to decrease the profile:\n"); + + npn=NNEW(int,20**ne+mpcend); + adj=NNEW(int,380**ne+mpcmult); + xadj=NNEW(int,*nk+1); + iw=NNEW(int,4**nk+1); + mmm=NNEW(int,*nk); + xnpn=NNEW(int,*ne+*nmpc+1); + + FORTRAN(renumber,(nk,kon,ipkon,lakon,ne,ipompc,nodempc,nmpc,nnn, + npn,adj,xadj,iw,mmm,xnpn)); + + free(npn);free(adj);free(xadj);free(iw);free(mmm);free(xnpn);*/ + + /* determining the matrix structure */ + + printf(" Determining the structure of the matrix:\n"); + + if(nzs[1]<10) nzs[1]=10; + mast1=NNEW(int,nzs[1]); + ipointer=NNEW(int,4**nk); + RENEW(irow,int,nzs[1]);for(i=0;i +#include +#include +#include +#include "CalculiX.h" + +void remcontmpc(int *nmpc, char *labmpc, int *mpcfree, int *nodempc, + int *ikmpc, int *ilmpc, double *coefmpc, int *ipompc){ + + /* removes the contact MPC's */ + + int i; + + for(i=*nmpc;i>0;i--){ + if(strcmp1(&labmpc[20*(i-1)],"CONTACT")==0){ + FORTRAN(mpcrem,(&i,mpcfree,nodempc,nmpc,ikmpc,ilmpc, + labmpc,coefmpc,ipompc)); + } + } + + return; + +} + diff -Nru calculix-ccx-2.1/ccx_2.3/src/renumber.f calculix-ccx-2.3/ccx_2.3/src/renumber.f --- calculix-ccx-2.1/ccx_2.3/src/renumber.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/renumber.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,140 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine renumber(nk,kon,ipkon,lakon,ne,ipompc,nodempc,nmpc,nnn, + & npn,adj,xadj,iw,mmm,xnpn,inum1,inum2) +! +! renumbers the nodes to reduce the profile length +! + implicit none +! + character*8 lakon(*) +! + integer kon(*),ipompc(*),nodempc(3,*),npn(*),inum1(*),inum2(*), + & nnn(*),iw(*),mmm(*),xnpn(*),adj(*),xadj(*),ipkon(*),node +! + integer nne,inpn,iadj,nk,ne,nmpc,i,j,nterm,e2,oldpro,newpro, + & index,kflag,nope,indexe,oldpro_exp,newpro_exp,nknew +! + kflag=2 + nne=0 + inpn=0 + iadj=0 +! +! taking the elements into account +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + elseif(lakon(i)(1:1).eq.'E') then + read(lakon(i)(8:8),'(i1)') nope + elseif(lakon(i)(1:1).eq.'D') then + cycle + endif +! + nne=nne+1 + xnpn(nne)=inpn+1 + do j=1,nope + node=kon(indexe+j) + npn(inpn+j)=node + inum1(node)=1 + enddo + inpn=inpn+nope + iadj=iadj+nope*(nope-1) + enddo +! +! taking the equations into account +! + do i=1,nmpc + nne=nne+1 + xnpn(nne)=inpn+1 + index=ipompc(i) + nterm=0 + do + nterm=nterm+1 + node=nodempc(1,index) + npn(inpn+nterm)=node + inum1(node)=1 + index=nodempc(3,index) + if(index.eq.0) exit + enddo + inpn=inpn+nterm + iadj=iadj+nterm*(nterm-1) + enddo +! + xnpn(nne+1)=inpn+1 +! +! numbering the node which are really used and changing the +! numbers in npn +! + nknew=0 + do i=1,nk + if(inum1(i).gt.0) then + nknew=nknew+1 + inum1(i)=nknew + endif + enddo + do i=1,inpn + npn(i)=inum1(npn(i)) + enddo +! + call graph(nknew,nne,inpn,npn,xnpn,iadj,adj,xadj) +! + e2=xadj(nknew+1)-1 +! + call label(nknew,e2,adj,xadj,mmm,iw,oldpro,newpro,oldpro_exp, + & newpro_exp) +! + write(*,*) 'old profile = ',oldpro_exp,'*2147483647+',oldpro + write(*,*) 'new profile = ',newpro_exp,'*2147483647+',newpro + write(*,*) +! +! restoring the original numbering +! + do i=1,nk + if(inum1(i).ne.0) then + inum2(inum1(i))=i + endif + enddo + index=0 + do i=1,nk + if(inum1(i).eq.0) then + inum1(i)=i + else + index=index+1 + inum1(i)=inum2(mmm(index)) + endif + enddo +! + call isortii(inum1,nnn,nk,kflag) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/residual.f calculix-ccx-2.3/ccx_2.3/src/residual.f --- calculix-ccx-2.1/ccx_2.3/src/residual.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/residual.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,77 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine storeresidual(nactdof,b,fn,filab,ithermal,nk) +! +! This routine is called in case of divergence: +! stores the residual forces in fn and changes the +! file storage labels so that the independent +! variables (displacements and/or temperatures) and +! the corresponding residual forces are stored in the +! frd file +! + implicit none +! + character*87 filab(*) +! + integer nactdof(0:mi(2),*),ithermal,i,j,nk +! + real*8 b(*),fn(0:mi(2),*) +! +! storing the residual forces in field fn +! + do i=1,nk + do j=0,3 + if(nactdof(j,i).gt.0) then + fn(j,i)=b(nactdof(j,i)) + else + fn(j,i)=0.d0 + endif + enddo + enddo +! +! adapting the storage labels +! + if(ithermal.ne.2) then + filab(1)='U ' + else + filab(1)=' ' + endif + if(ithermal.gt.1) then + filab(2)='NT ' + else + filab(2)=' ' + endif + do i=3,10 + filab(i)=' ' + enddo + if(ithermal.ne.2) then + filab(13)='RFRES ' + else + filab(13)=' ' + endif + if(ithermal.gt.1) then + filab(14)='RFLRES' + else + filab(14)=' ' + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/restartread.f calculix-ccx-2.3/ccx_2.3/src/restartread.f --- calculix-ccx-2.1/ccx_2.3/src/restartread.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/restartread.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,416 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine restartread(istep,nset,nload,nforc, nboun,nk,ne, + & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi, + & ntrans,ncs_,namtot_,ncmat_,mpcfree,maxlenmpc, + & ne1d,ne2d,nflow,nlabel,iplas, + & nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset, + & iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun, + & xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, + & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload, + & sideload,xload,elcon,nelcon,rhcon,nrhcon, + & alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab, + & ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold, + & ielmat,matname,prlab,prset,filab,vold,nodebounold, + & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, + & iponor,xnor,knor,thickn,thicke,offset,iponoel,inoel,rig, + & shcon,nshcon,cocon,ncocon,ics,sti, + & ener,xstate,jobnamec,infree,nnn,irestartstep,prestr,iprestr, + & cbody,ibody,xbody,nbody,xbodyold,ttime,qaold,cs,mcs, + & output,physcon,ctrl,typeboun,fmpc,tieset,ntie,tietol) +! + implicit none +! + character*1 typeboun(*) + character*3 output + character*6 prlab(*) + character*8 lakon(*) + character*20 labmpc(*),sideload(*) + character*80 orname(*),amname(*),matname(*) + character*81 set(*),prset(*),tieset(3,*),cbody(*) + character*87 filab(*) + character*132 fnrstrt,jobnamec(*) +! + integer istep,nset,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat, + & ntmat_,npmat_,norien,nam,nprint,mi(2),ntrans,ncs_, + & namtot_,ncmat_,mpcfree,ne1d,ne2d,nflow,nlabel,iplas,nkon, + & ithermal,nmethod,iperturb(*),nstate_,istartset(*),iendset(*), + & ialset(*),kon(*),ipkon(*),nodeboun(*),ndirboun(*),iamboun(*), + & ikboun(*),ilboun(*),ipompc(*),nodempc(*),ikmpc(*),ilmpc(*), + & nodeforc(*),ndirforc(*),iamforc(*),ikforc(*),ilforc(*), + & nelemload(*),iamload(*),nelcon(*),mt, + & nrhcon(*),nalcon(*),nplicon(*),nplkcon(*),ielorien(*),inotr(*), + & namta(*),iamt1(*),ielmat(*),nodebounold(*),ndirbounold(*), + & iponor(*),knor(*),iponoel(*),inoel(*),rig(*), + & nshcon(*),ncocon(*),ics(*),infree(*),nnn(*),i,ipos, + & nener,irestartstep,istat,iprestr, + & maxlenmpc,j,mcs,mpcend,ntie,ibody(*),nbody +! + real*8 co(*),xboun(*),coefmpc(*),xforc(*),xload(*),elcon(*), + & rhcon(*),alcon(*),alzero(*),plicon(*),plkcon(*),orab(*), + & trab(*),amta(*),t0(*),t1(*),veold(*),tietol(2,*), + & vold(*),xbounold(*),xforcold(*),xloadold(*),t1old(*),eme(*), + & xnor(*),thickn(*),thicke(*),offset(*), + & shcon(*),cocon(*),sti(*),ener(*),xstate(*),prestr(*),ttime, + & qaold(2),physcon(*),ctrl(*),cs(17,*),fmpc(*),xbody(*), + & xbodyold(*) +! + ipos=index(jobnamec(1),char(0)) + fnrstrt(1:ipos-1)=jobnamec(1)(1:ipos-1) + fnrstrt(ipos:ipos+3)=".rin" + do i=ipos+4,132 + fnrstrt(i:i)=' ' + enddo +! + open(15,file=fnrstrt,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', + & err=15) +! + do +! + read(15,iostat=istat)istep + if(istat.lt.0) then + write(*,*) '*ERROR reading *RESTART,READ: requested step' + write(*,*) ' is not in the restart file' + stop + endif +! +! set size +! + read(15)nset + read(15)nalset +! +! load size +! + read(15)nload + read(15)nbody + read(15)nforc + read(15)nboun + read(15)nflow +! +! mesh size +! + read(15)nk + read(15)ne + read(15)nkon + read(15)(mi(i),i=1,2) + mt=mi(2)+1 +! +! constraint size +! + read(15)nmpc + read(15)mpcend + read(15)maxlenmpc +! +! material size +! + read(15)nmat + read(15)ntmat_ + read(15)npmat_ + read(15)ncmat_ +! +! transformation size +! + read(15)norien + read(15)ntrans +! +! amplitude size +! + read(15)nam + read(15)namtot_ +! +! print size +! + read(15)nprint + read(15)nlabel +! +! tie size +! + read(15)ntie +! +! cyclic symmetry size +! + read(15)ncs_ + read(15)mcs +! +! 1d and 2d element size +! + read(15)ne1d + read(15)ne2d + read(15)(infree(i),i=1,4) +! +! procedure info +! + read(15)nmethod + read(15)(iperturb(i),i=1,2) + read(15)nener + read(15)iplas + read(15)ithermal + read(15)nstate_ + read(15)iprestr +! + if(istep.eq.irestartstep) exit +! +! skipping the next entries until the requested step is found +! + call skip(nset,nalset,nload,nbody,nforc,nboun,nflow,nk,ne,nkon, + & mi(1),nmpc,mpcend,nmat,ntmat_,npmat_,ncmat_,norien,ntrans, + & nam,nprint,nlabel,ncs_,ne1d,ne2d,infree,nmethod, + & iperturb,nener,iplas,ithermal,nstate_,iprestr,mcs,ntie) +! + enddo +! +! sets +! + read(15)(set(i),i=1,nset) + read(15)(istartset(i),i=1,nset) + read(15)(iendset(i),i=1,nset) + do i=1,nalset + read(15)ialset(i) + enddo +! +! mesh +! + read(15)(co(i),i=1,3*nk) + read(15)(kon(i),i=1,nkon) + read(15)(ipkon(i),i=1,ne) + read(15)(lakon(i),i=1,ne) +! +! single point constraints +! + read(15)(nodeboun(i),i=1,nboun) + read(15)(ndirboun(i),i=1,nboun) + read(15)(typeboun(i),i=1,nboun) + read(15)(xboun(i),i=1,nboun) + read(15)(ikboun(i),i=1,nboun) + read(15)(ilboun(i),i=1,nboun) + if(nam.gt.0) read(15)(iamboun(i),i=1,nboun) + read(15)(nodebounold(i),i=1,nboun) + read(15)(ndirbounold(i),i=1,nboun) + read(15)(xbounold(i),i=1,nboun) +! +! multiple point constraints +! + read(15)(ipompc(i),i=1,nmpc) + read(15)(labmpc(i),i=1,nmpc) + read(15)(ikmpc(i),i=1,nmpc) + read(15)(ilmpc(i),i=1,nmpc) + read(15)(fmpc(i),i=1,nmpc) + read(15)(nodempc(i),i=1,3*mpcend) + read(15)(coefmpc(i),i=1,mpcend) + mpcfree=mpcend+1 +! +! point forces +! + read(15)(nodeforc(i),i=1,2*nforc) + read(15)(ndirforc(i),i=1,nforc) + read(15)(xforc(i),i=1,nforc) + read(15)(ikforc(i),i=1,nforc) + read(15)(ilforc(i),i=1,nforc) + if(nam.gt.0) read(15)(iamforc(i),i=1,nforc) + read(15)(xforcold(i),i=1,nforc) +! +! distributed loads +! + read(15)(nelemload(i),i=1,2*nload) + read(15)(sideload(i),i=1,nload) + read(15)(xload(i),i=1,2*nload) + if(nam.gt.0) read(15)(iamload(i),i=1,2*nload) + read(15)(xloadold(i),i=1,2*nload) + read(15)(cbody(i),i=1,nbody) + read(15)(ibody(i),i=1,3*nbody) + read(15)(xbody(i),i=1,7*nbody) + read(15)(xbodyold(i),i=1,7*nbody) +! +! prestress +! + if(iprestr.gt.0) read(15) (prestr(i),i=1,6*mi(1)*ne) +! +! labels +! + read(15)(prlab(i),i=1,nprint) + read(15)(prset(i),i=1,nprint) + read(15)(filab(i),i=1,nlabel) +! +! elastic constants +! + read(15)(elcon(i),i=1,(ncmat_+1)*ntmat_*nmat) + read(15)(nelcon(i),i=1,2*nmat) +! +! density +! + read(15)(rhcon(i),i=1,2*ntmat_*nmat) + read(15)(nrhcon(i),i=1,nmat) +! +! specific heat +! + read(15)(shcon(i),i=1,4*ntmat_*nmat) + read(15)(nshcon(i),i=1,nmat) +! +! conductivity +! + read(15)(cocon(i),i=1,7*ntmat_*nmat) + read(15)(ncocon(i),i=1,2*nmat) +! +! expansion coefficients +! + read(15)(alcon(i),i=1,7*ntmat_*nmat) + read(15)(nalcon(i),i=1,2*nmat) + read(15)(alzero(i),i=1,nmat) +! +! physical constants +! + read(15)(physcon(i),i=1,3) +! +! plastic data +! + if(iplas.ne.0)then + read(15)(plicon(i),i=1,(2*npmat_+1)*ntmat_*nmat) + read(15)(nplicon(i),i=1,(ntmat_+1)*nmat) + read(15)(plkcon(i),i=1,(2*npmat_+1)*ntmat_*nmat) + read(15)(nplkcon(i),i=1,(ntmat_+1)*nmat) + endif +! +! material orientation +! + if(norien.ne.0)then + read(15)(orname(i),i=1,norien) + read(15)(orab(i),i=1,7*norien) + read(15)(ielorien(i),i=1,ne) + endif +! +! transformations +! + if(ntrans.ne.0)then + read(15)(trab(i),i=1,7*ntrans) + read(15)(inotr(i),i=1,2*nk) + endif +! +! amplitudes +! + if(nam.gt.0)then + read(15)(amname(i),i=1,nam) + read(15)(namta(i),i=1,3*nam-1) + read(15) namta(3*nam) + read(15)(amta(i),i=1,2*namta(3*nam-1)) + endif +! +! temperatures +! + if(ithermal.gt.0)then + if((ne1d.gt.0).or.(ne2d.gt.0))then + read(15)(t0(i),i=1,3*nk) + read(15)(t1(i),i=1,3*nk) + else + read(15)(t0(i),i=1,nk) + read(15)(t1(i),i=1,nk) + endif + if(nam.gt.0) read(15)(iamt1(i),i=1,nk) + read(15)(t1old(i),i=1,nk) + endif +! +! materials +! + read(15)(matname(i),i=1,nmat) + read(15)(ielmat(i),i=1,ne) +! +! temperature, displacement, static pressure, velocity and acceleration +! + read(15)(vold(i),i=1,mt*nk) + if((nmethod.eq.4).or.((nmethod.eq.1).and.(iperturb(1).ge.2))) then + read(15)(veold(i),i=1,mt*nk) + endif +! +! reordering +! + read(15)(nnn(i),i=1,nk) +! +! 1d and 2d elements +! + if((ne1d.gt.0).or.(ne2d.gt.0))then + read(15)(iponor(i),i=1,2*nkon) + read(15)(xnor(i),i=1,infree(1)-1) + read(15)(knor(i),i=1,infree(2)-1) + read(15)(thicke(i),i=1,2*nkon) + read(15)(offset(i),i=1,2*ne) + read(15)(iponoel(i),i=1,infree(4)) + read(15)(inoel(i),i=1,3*(infree(3)-1)) + read(15)(rig(i),i=1,infree(4)) + endif +! +! tie constraints +! + if(ntie.gt.0) then + read(15)((tieset(i,j),i=1,3),j=1,ntie) + read(15)((tietol(i,j),i=1,2),j=1,ntie) + endif +! +! cyclic symmetry +! + if(ncs_.gt.0)then + read(15)(ics(i),i=1,ncs_) + endif + if(mcs.gt.0) then + read(15)((cs(i,j),i=1,17),j=1,mcs) + endif +! +! integration point variables +! + read(15)(sti(i),i=1,6*mi(1)*ne) + read(15)(eme(i),i=1,6*mi(1)*ne) + if(nener.eq.1) then + read(15)(ener(i),i=1,mi(1)*ne) + endif + if(nstate_.gt.0)then + read(15)(xstate(i),i=1,nstate_*mi(1)*ne) + endif +! +! control parameters +! + read(15) (ctrl(i),i=1,27) + read(15) (qaold(i),i=1,2) + read(15) output + read(15) ttime +! + close(15) +! + return +! + 15 write(*,*) '*ERROR reading *RESTART,READ: could not open file ', + & fnrstrt + stop + end + + + + + + + + + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/restarts.f calculix-ccx-2.3/ccx_2.3/src/restarts.f --- calculix-ccx-2.1/ccx_2.3/src/restarts.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/restarts.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,127 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine restarts(istep,nset,nload,nforc, nboun,nk,ne, + & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi, + & ntrans,ncs_,namtot_,ncmat_,mpcfree,maxlenmpc, + & ne1d,ne2d,nflow,nlabel,iplas, + & nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset, + & iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun, + & xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, + & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload, + & sideload,xload,elcon,nelcon,rhcon,nrhcon, + & alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab, + & ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold, + & ielmat,matname,prlab,prset,filab,vold,nodebounold, + & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, + & iponor,xnor,knor,thickn,thicke,offset,iponoel,inoel,rig, + & shcon,nshcon,cocon,ncocon,ics,sti, + & ener,xstate,jobnamec,infree,nnn,irstrt,inpc,textpart,istat,n, + & key,prestr,iprestr,cbody,ibody,xbody,nbody,xbodyold, + & ttime,qaold,cs,mcs,output,physcon,ctrl,typeboun,iline,ipol,inl, + & ipoinp,inp,fmpc,tieset,ntie,tietol,ipoinpc) +! + implicit none +! + character*1 typeboun(*),inpc(*) + character*3 output + character*6 prlab(*) + character*8 lakon(*) + character*20 labmpc(*),sideload(*) + character*80 orname(*),amname(*),matname(*) + character*81 set(*),prset(*),tieset(3,*),cbody(*) + character*87 filab(*) + character*132 jobnamec(*),textpart(16) +! + integer istep,nset,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat, + & ntmat_,npmat_,norien,nam,nprint,mi(2),ntrans,ncs_, + & namtot_,ncmat_,mpcfree,ne1d,ne2d,nflow,nlabel,iplas,nkon, + & ithermal,nmethod,iperturb(*),nstate_,istartset(*),iendset(*), + & ialset(*),kon(*),ipkon(*),nodeboun(*),ndirboun(*),iamboun(*), + & ikboun(*),ilboun(*),ipompc(*),nodempc(*),ikmpc(*),ilmpc(*), + & nodeforc(*),ndirforc(*),iamforc(*),ikforc(*),ilforc(*), + & nelemload(*),iamload(*),nelcon(*),ipoinpc(0:*), + & nrhcon(*),nalcon(*),nplicon(*),nplkcon(*),ielorien(*),inotr(*), + & namta(*),iamt1(*),ielmat(*),nodebounold(*),ndirbounold(*), + & iponor(*),knor(*),iponoel(*),inoel(*),rig(*), + & nshcon(*),ncocon(*),ics(*),infree(*),nnn(*), + & nener,irestartstep,irestartread,irstrt,istat,n,i,key, + & iprestr,mcs,maxlenmpc,iline,ipol,inl, + & ipoinp(2,*),inp(3,*),ntie,ibody(*),nbody +! + real*8 co(*),xboun(*),coefmpc(*),xforc(*),xload(*),elcon(*), + & rhcon(*),alcon(*),alzero(*),plicon(*),plkcon(*),orab(*), + & trab(*),amta(*),t0(*),t1(*),prestr(*),veold(*),tietol(2,*), + & vold(*),xbounold(*),xforcold(*),xloadold(*),t1old(*),eme(*), + & xnor(*),thickn(*),thicke(*),offset(*), + & shcon(*),cocon(*),sti(*),ener(*),xstate(*), + & ttime,qaold(2),cs(17,*),physcon(*), + & ctrl(*),fmpc(*),xbody(*),xbodyold(*) +! + irestartread=0 + irestartstep=0 +! + do i=2,n + if(textpart(i)(1:4).eq.'READ') then + irestartread=1 + if(irestartstep.eq.0) irestartstep=1 + elseif(textpart(i)(1:5).eq.'STEP=') then + read(textpart(i)(6:15),'(i10)',iostat=istat) irestartstep + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:5).eq.'WRITE') then + irstrt=1 + elseif(textpart(i)(1:10).eq.'FREQUENCY=') then + read(textpart(i)(11:20),'(i10)',iostat=istat) irstrt + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + write(*,*) + & '*WARNING in restarts: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(irestartread.eq.1) then + call restartread(istep,nset,nload,nforc, nboun,nk,ne, + & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi, + & ntrans,ncs_,namtot_,ncmat_,mpcfree,maxlenmpc, + & ne1d,ne2d,nflow,nlabel,iplas, + & nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset, + & iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun, + & xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, + & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload, + & sideload,xload,elcon,nelcon,rhcon,nrhcon, + & alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab, + & ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold, + & ielmat,matname,prlab,prset,filab,vold,nodebounold, + & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, + & iponor,xnor,knor,thickn,thicke,offset,iponoel,inoel,rig, + & shcon,nshcon,cocon,ncocon,ics,sti, + & ener,xstate,jobnamec,infree,nnn,irestartstep,prestr,iprestr, + & cbody,ibody,xbody,nbody,xbodyold,ttime,qaold,cs,mcs, + & output,physcon,ctrl,typeboun,fmpc,tieset,ntie,tietol) + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/restartshort.f calculix-ccx-2.3/ccx_2.3/src/restartshort.f --- calculix-ccx-2.1/ccx_2.3/src/restartshort.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/restartshort.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,327 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine restartshort(nset,nload,nbody,nforc,nboun,nk,ne, + & nmpc,nalset,nmat,ntmat,npmat,norien,nam,nprint,mi, + & ntrans,ncs,namtot,ncmat,memmpc,ne1d,ne2d,nflow, + & set,meminset,rmeminset,jobnamec,irestartstep,icntrl,ithermal, + & nener,nstate_,ntie) +! +! istartset := meminset +! iendset := rmeminset +! + implicit none +! + character*81 set(*) + character*132 fnrstrt,jobnamec(*) +! + integer istep,nset,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat, + & ntmat,npmat,norien,nam,nprint,mi(2),ntrans,ncs, + & namtot,ncmat,memmpc,ne1d,ne2d,nflow,infree(4), + & nmethod,iperturb,meminset(*),rmeminset(*), + & i,j,k,ipos,icntrl,nener,irestartstep,im0,im1,im2,mem,iact, + & istat,nkon,nlabel,iplas,ithermal,nstate_,iprestr,maxlenmpc, + & mcs,ntie,nbody +! + if(icntrl.eq.0) then +! +! determining the name of the restart file +! + ipos=index(jobnamec(1),char(0)) + fnrstrt(1:ipos-1)=jobnamec(1)(1:ipos-1) + fnrstrt(ipos:ipos+3)=".rin" + do i=ipos+4,132 + fnrstrt(i:i)=' ' + enddo +! +! opening the restart file +! + open(15,file=fnrstrt,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', + & err=15) +! + do +! + read(15,iostat=istat)istep + if(istat.lt.0) then + write(*,*) '*ERROR in restartshort: requested step' + write(*,*) ' is not in the restart file' + stop + endif +! +! reading the number of sets +! + read(15)nset +! + if(istep.eq.irestartstep) exit +! + read(15)nalset +! +! load size +! + read(15)nload + read(15)nbody + read(15)nforc + read(15)nboun + read(15)nflow +! +! mesh size +! + read(15)nk + read(15)ne + read(15)nkon + read(15)(mi(i),i=1,2) +! +! constraint size +! + read(15)nmpc + read(15)memmpc + read(15)maxlenmpc +! +! material size +! + read(15)nmat + read(15)ntmat + read(15)npmat + read(15)ncmat +! +! transformation size +! + read(15)norien + read(15)ntrans +! +! amplitude size +! + read(15)nam + read(15)namtot +! +! print size +! + read(15)nprint + read(15)nlabel +! +! tie size +! + read(15)ntie +! +! cyclic symmetry size +! + read(15)ncs + read(15)mcs +! +! 1d and 2d element size +! + read(15)ne1d + read(15)ne2d + read(15)(infree(i),i=1,4) +! +! procedure info +! + read(15)nmethod + read(15)iperturb + read(15)nener + read(15)iplas + read(15)ithermal + read(15)nstate_ + read(15)iprestr +! +! skipping the next entries +! + call skip(nset,nalset,nload,nbody, + & nforc,nboun,nflow,nk,ne,nkon, + & mi,nmpc,memmpc,nmat,ntmat,npmat,ncmat,norien, + & ntrans,nam,nprint,nlabel,ncs,ne1d,ne2d,infree, + & nmethod,iperturb,nener,iplas,ithermal,nstate_,iprestr, + & mcs,ntie) +! + enddo +! + close(15) +! + return + endif +! +! determining the name of the restart file +! + ipos=index(jobnamec(1),char(0)) + fnrstrt(1:ipos-1)=jobnamec(1)(1:ipos-1) + fnrstrt(ipos:ipos+3)=".rin" + do i=ipos+4,132 + fnrstrt(i:i)=' ' + enddo +! +! opening the restart file +! + open(15,file=fnrstrt,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', + & err=15) +! + do +! + read(15,iostat=istat)istep + if(istat.lt.0) then + write(*,*) '*ERROR in restartshort: requested step' + write(*,*) ' is not in the restart file' + stop + endif +! +! set size +! + read(15)nset + read(15)nalset +! +! load size +! + read(15)nload + read(15)nbody + read(15)nforc + read(15)nboun + read(15)nflow +! +! mesh size +! + read(15)nk + read(15)ne + read(15)nkon + read(15)(mi(i),i=1,2) +! +! constraint size +! + read(15)nmpc + read(15)memmpc + read(15)maxlenmpc +! +! material size +! + read(15)nmat + read(15)ntmat + read(15)npmat + read(15)ncmat +! +! transformation size +! + read(15)norien + read(15)ntrans +! +! amplitude size +! + read(15)nam + read(15)namtot +! +! print size +! + read(15)nprint + read(15)nlabel +! +! tie size +! + read(15)ntie +! +! cyclic symmetry size +! + read(15)ncs + read(15)mcs +! +! 1d and 2d element size +! + read(15)ne1d + read(15)ne2d + read(15)(infree(i),i=1,4) +! +! procedure info +! + read(15)nmethod + read(15)iperturb + read(15)nener + read(15)iplas + read(15)ithermal + read(15)nstate_ + read(15)iprestr +! + if(istep.eq.irestartstep) exit +! +! skipping the next entries +! + call skip(nset,nalset,nload,nbody,nforc,nboun,nflow,nk,ne,nkon, + & mi,nmpc,memmpc,nmat,ntmat,npmat,ncmat,norien,ntrans, + & nam,nprint,nlabel,ncs,ne1d,ne2d,infree,nmethod, + & iperturb,nener,iplas,ithermal,nstate_,iprestr,mcs,ntie) +! + enddo +! +! sets +! + read(15)(set(i),i=1,nset) +! +! the contents of istartset is temporarily stored in meminset +! + read(15)(meminset(i),i=1,nset) +! +! the contents of iendset is temporarily stored in rmeminset +! + read(15)(rmeminset(i),i=1,nset) +! +! reordering the information of istartset, iendset and ialset +! into meminset and rmeminset +! + iact=0 + do j=1,nalset + if(iact.eq.0) then + do k=1,nset + if(meminset(k).eq.j) then + meminset(k)=0 + mem=0 + iact=1 + exit + endif + enddo + if(k.gt.nset) cycle + endif + mem=mem+1 + im2=im1 + im1=im0 + read(15) im0 + if(im0.gt.0) then + meminset(k)=meminset(k)+1 + else +! +! im0<0 and two elements are already stored +! + meminset(k)=meminset(k)+(im2-im1)/im0-1 + endif + if(rmeminset(k).eq.j) then + iact=0 + rmeminset(k)=mem +! +! make set k ineligible in further iterations +! + meminset(k)=-meminset(k) + endif + enddo +! +! restore the sign of meminset +! + do k=1,nset + meminset(k)=-meminset(k) + enddo +! + close(15) +! + return +! + 15 write(*,*) '*ERROR in restartshort: could not open file ',fnrstrt + stop + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/restartwrite.f calculix-ccx-2.3/ccx_2.3/src/restartwrite.f --- calculix-ccx-2.1/ccx_2.3/src/restartwrite.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/restartwrite.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,421 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine restartwrite(istepnew,nset,nload,nforc, nboun,nk,ne, + & nmpc,nalset,nmat,ntmat_,npmat_,norien,nam,nprint,mi, + & ntrans,ncs_,namtot_,ncmat_,mpcend,maxlenmpc, + & ne1d,ne2d,nflow,nlabel,iplas, + & nkon,ithermal,nmethod,iperturb,nstate_,nener,set,istartset, + & iendset,ialset,co,kon,ipkon,lakon,nodeboun,ndirboun,iamboun, + & xboun,ikboun,ilboun,ipompc,nodempc,coefmpc,labmpc,ikmpc,ilmpc, + & nodeforc,ndirforc,iamforc,xforc,ikforc,ilforc,nelemload,iamload, + & sideload,xload,elcon,nelcon,rhcon,nrhcon, + & alcon,nalcon,alzero,plicon,nplicon,plkcon,nplkcon,orname,orab, + & ielorien,trab,inotr,amname,amta,namta,t0,t1,iamt1,veold, + & ielmat,matname,prlab,prset,filab,vold,nodebounold, + & ndirbounold,xbounold,xforcold,xloadold,t1old,eme, + & iponor,xnor,knor,thickn,thicke,offset,iponoel,inoel,rig, + & shcon,nshcon,cocon,ncocon,ics,sti, + & ener,xstate,jobnamec,infree,nnn,prestr,iprestr,cbody, + & ibody,xbody,nbody,xbodyold,ttime,qaold,cs,mcs,output, + & physcon,ctrl,typeboun,fmpc,tieset,ntie,tietol) +! + implicit none +! + logical op +! + character*1 typeboun(*) + character*3 output + character*6 prlab(*) + character*8 lakon(*) + character*20 labmpc(*),sideload(*) + character*80 orname(*),amname(*),matname(*) + character*81 set(*),prset(*),tieset(3,*),cbody(*) + character*87 filab(*) + character*132 fnrstrt,jobnamec(*) +! + integer nset,nload,nforc,nboun,nk,ne,nmpc,nalset,nmat, + & ntmat_,npmat_,norien,nam,nprint,mi(2),ntrans,ncs_, + & namtot_,ncmat_,mpcend,ne1d,ne2d,nflow,nlabel,iplas,nkon, + & ithermal,nmethod,iperturb(*),nstate_,istartset(*),iendset(*), + & ialset(*),kon(*),ipkon(*),nodeboun(*),ndirboun(*),iamboun(*), + & ikboun(*),ilboun(*),ipompc(*),nodempc(*),ikmpc(*),ilmpc(*), + & nodeforc(*),ndirforc(*),iamforc(*),ikforc(*),ilforc(*), + & nelemload(*),iamload(*),nelcon(*), + & nrhcon(*),nalcon(*),nplicon(*),nplkcon(*),ielorien(*),inotr(*), + & namta(*),iamt1(*),ielmat(*),nodebounold(*),ndirbounold(*), + & iponor(*),knor(*),iponoel(*),inoel(*),rig(*), + & nshcon(*),ncocon(*),ics(*),infree(*),nnn(*),i,ipos, + & nener,iprestr,istepnew,maxlenmpc,mcs,j,ntie, + & ibody(*),nbody,mt +! + real*8 co(*),xboun(*),coefmpc(*),xforc(*),xload(*),elcon(*), + & rhcon(*),alcon(*),alzero(*),plicon(*),plkcon(*),orab(*), + & trab(*),amta(*),t0(*),t1(*),prestr(*),veold(*),tietol(2,*), + & vold(*),xbounold(*),xforcold(*),xloadold(*),t1old(*),eme(*), + & xnor(*),thickn(*),thicke(*),offset(*), + & shcon(*),cocon(*),sti(*),ener(*),xstate(*), + & qaold(2),cs(17,*),physcon(*),ctrl(*), + & ttime,fmpc(*),xbody(*),xbodyold(*) +! + mt=mi(2)+1 +! + ipos=index(jobnamec(1),char(0)) + fnrstrt(1:ipos-1)=jobnamec(1)(1:ipos-1) + fnrstrt(ipos:ipos+4)=".rout" + do i=ipos+5,132 + fnrstrt(i:i)=' ' + enddo +! +! check whether the restart file exists and is opened +! + inquire(FILE=fnrstrt,OPENED=op,err=152) +! + if(.not.op) then + open(15,file=fnrstrt,ACCESS='SEQUENTIAL',FORM='UNFORMATTED', + & err=151) + endif +! + write(15)istepnew +! +! set size +! + write(15)nset + write(15)nalset +! +! load size +! + write(15)nload + write(15)nbody + write(15)nforc + write(15)nboun + write(15)nflow +! +! mesh size +! + write(15)nk + write(15)ne + write(15)nkon + write(15)(mi(i),i=1,2) +! +! constraint size +! + write(15)nmpc + write(15)mpcend + write(15)maxlenmpc +! +! material size +! + write(15)nmat + write(15)ntmat_ + write(15)npmat_ + write(15)ncmat_ +! +! transformation size +! + write(15)norien + write(15)ntrans +! +! amplitude size +! + write(15)nam + write(15)namtot_ +! +! print size +! + write(15)nprint + write(15)nlabel +! +! tie size +! + write(15)ntie +! +! cyclic symmetry size +! + write(15)ncs_ + write(15)mcs +! +! 1d and 2d element size +! + write(15)ne1d + write(15)ne2d + write(15)(infree(i),i=1,4) +! +! procedure info +! + write(15)nmethod + write(15)(iperturb(i),i=1,2) + write(15)nener + write(15)iplas + write(15)ithermal + write(15)nstate_ + write(15)iprestr +! +! sets +! + write(15)(set(i),i=1,nset) + write(15)(istartset(i),i=1,nset) + write(15)(iendset(i),i=1,nset) +! +! watch out: the statement +! write(15)(ialset(i),i=nalset) (short form) +! needs less space to store than +! do i=1,nalset +! write(15) ialset(i) (long form) +! enddo +! but cannot be accessed by read statements of the form +! do i=1,nalset +! read(15) im0 +! enddo +! as needed in routine restartshort. Therefore the long form +! is used for ialset. +! + do i=1,nalset + write(15) ialset(i) + enddo +! +! mesh +! + write(15)(co(i),i=1,3*nk) + write(15)(kon(i),i=1,nkon) + write(15)(ipkon(i),i=1,ne) + write(15)(lakon(i),i=1,ne) +! +! single point constraints +! + write(15)(nodeboun(i),i=1,nboun) + write(15)(ndirboun(i),i=1,nboun) + write(15)(typeboun(i),i=1,nboun) + write(15)(xboun(i),i=1,nboun) + write(15)(ikboun(i),i=1,nboun) + write(15)(ilboun(i),i=1,nboun) + if(nam.gt.0) write(15)(iamboun(i),i=1,nboun) + write(15)(nodebounold(i),i=1,nboun) + write(15)(ndirbounold(i),i=1,nboun) + write(15)(xbounold(i),i=1,nboun) +! +! multiple point constraints +! + write(15)(ipompc(i),i=1,nmpc) + write(15)(labmpc(i),i=1,nmpc) + write(15)(ikmpc(i),i=1,nmpc) + write(15)(ilmpc(i),i=1,nmpc) + write(15)(fmpc(i),i=1,nmpc) + write(15)(nodempc(i),i=1,3*mpcend) + write(15)(coefmpc(i),i=1,mpcend) +! +! point forces +! + write(15)(nodeforc(i),i=1,2*nforc) + write(15)(ndirforc(i),i=1,nforc) + write(15)(xforc(i),i=1,nforc) + write(15)(ikforc(i),i=1,nforc) + write(15)(ilforc(i),i=1,nforc) + if(nam.gt.0) write(15)(iamforc(i),i=1,nforc) + write(15)(xforcold(i),i=1,nforc) +! +! distributed loads +! + write(15)(nelemload(i),i=1,2*nload) + write(15)(sideload(i),i=1,nload) + write(15)(xload(i),i=1,2*nload) + if(nam.gt.0) write(15)(iamload(i),i=1,2*nload) + write(15)(xloadold(i),i=1,2*nload) + write(15)(cbody(i),i=1,nbody) + write(15)(ibody(i),i=1,3*nbody) + write(15)(xbody(i),i=1,7*nbody) + write(15)(xbodyold(i),i=1,7*nbody) +! +! prestress +! + if(iprestr.gt.0) write(15) (prestr(i),i=1,6*mi(1)*ne) +! +! labels +! + write(15) (prlab(i),i=1,nprint) + write(15) (prset(i),i=1,nprint) + write(15)(filab(i),i=1,nlabel) +! +! elastic constants +! + write(15)(elcon(i),i=1,(ncmat_+1)*ntmat_*nmat) + write(15)(nelcon(i),i=1,2*nmat) +! +! density +! + write(15)(rhcon(i),i=1,2*ntmat_*nmat) + write(15)(nrhcon(i),i=1,nmat) +! +! specific heat +! + write(15)(shcon(i),i=1,4*ntmat_*nmat) + write(15)(nshcon(i),i=1,nmat) +! +! conductivity +! + write(15)(cocon(i),i=1,7*ntmat_*nmat) + write(15)(ncocon(i),i=1,2*nmat) +! +! expansion coefficients +! + write(15)(alcon(i),i=1,7*ntmat_*nmat) + write(15)(nalcon(i),i=1,2*nmat) + write(15)(alzero(i),i=1,nmat) +! +! physical constants +! + write(15)(physcon(i),i=1,3) +! +! plastic data +! + if(iplas.ne.0)then + write(15)(plicon(i),i=1,(2*npmat_+1)*ntmat_*nmat) + write(15)(nplicon(i),i=1,(ntmat_+1)*nmat) + write(15)(plkcon(i),i=1,(2*npmat_+1)*ntmat_*nmat) + write(15)(nplkcon(i),i=1,(ntmat_+1)*nmat) + endif +! +! material orientation +! + if(norien.ne.0)then + write(15)(orname(i),i=1,norien) + write(15)(orab(i),i=1,7*norien) + write(15)(ielorien(i),i=1,ne) + endif +! +! transformations +! + if(ntrans.ne.0)then + write(15)(trab(i),i=1,7*ntrans) + write(15)(inotr(i),i=1,2*nk) + endif +! +! amplitudes +! + if(nam.gt.0)then + write(15)(amname(i),i=1,nam) + write(15)(namta(i),i=1,3*nam-1) + write(15) namta(3*nam) + write(15)(amta(i),i=1,2*namta(3*nam-1)) + endif +! +! temperatures +! + if(ithermal.gt.0)then + if((ne1d.gt.0).or.(ne2d.gt.0))then + write(15)(t0(i),i=1,3*nk) + write(15)(t1(i),i=1,3*nk) + else + write(15)(t0(i),i=1,nk) + write(15)(t1(i),i=1,nk) + endif + if(nam.gt.0) write(15)(iamt1(i),i=1,nk) + write(15)(t1old(i),i=1,nk) + endif +! +! materials +! + write(15)(matname(i),i=1,nmat) + write(15)(ielmat(i),i=1,ne) +! +! temperature, displacement, static pressure, velocity and acceleration +! + write(15)(vold(i),i=1,mt*nk) + if((nmethod.eq.4).or.((nmethod.eq.1).and.(iperturb(1).ge.2))) then + write(15)(veold(i),i=1,mt*nk) + endif +! +! reordering +! + write(15)(nnn(i),i=1,nk) +! +! 1d and 2d elements +! + if((ne1d.gt.0).or.(ne2d.gt.0))then + write(15)(iponor(i),i=1,2*nkon) + write(15)(xnor(i),i=1,infree(1)-1) + write(15)(knor(i),i=1,infree(2)-1) + write(15)(thicke(i),i=1,2*nkon) + write(15)(offset(i),i=1,2*ne) + write(15)(iponoel(i),i=1,infree(4)) + write(15)(inoel(i),i=1,3*(infree(3)-1)) + write(15)(rig(i),i=1,infree(4)) + endif +! +! tie constraints +! + if(ntie.gt.0) then + write(15)((tieset(i,j),i=1,3),j=1,ntie) + write(15)((tietol(i,j),i=1,2),j=1,ntie) + endif +! +! cyclic symmetry +! + if(ncs_.gt.0)then + write(15)(ics(i),i=1,ncs_) + endif + if(mcs.gt.0) then + write(15)((cs(i,j),i=1,17),j=1,mcs) + endif +! +! integration point variables +! + write(15)(sti(i),i=1,6*mi(1)*ne) + write(15)(eme(i),i=1,6*mi(1)*ne) + if(nener.eq.1) then + write(15)(ener(i),i=1,mi(1)*ne) + endif + if(nstate_.gt.0)then + write(15)(xstate(i),i=1,nstate_*mi(1)*ne) + endif +! +! control parameters +! + write(15) (ctrl(i),i=1,27) + write(15) (qaold(i),i=1,2) + write(15) output + write(15) ttime +! + return +! + 151 write(*,*) '*ERROR in restartwrite: could not open file ',fnrstrt + stop +! + 152 write(*,*) '*ERROR in restartwrite: could not inquire file ', + & fnrstrt + stop + end + + + + + + + + + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/restrictor.f calculix-ccx-2.3/ccx_2.3/src/restrictor.f --- calculix-ccx-2.1/ccx_2.3/src/restrictor.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/restrictor.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1104 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine restrictor(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,r,physcon,dvi,numf,set + & ,shcon,nshcon,rhcon,nrhcon,ntmat_,mi) +! +! pressure loss element with partial total head loss +! + implicit none +! + logical identity,crit,isothermal + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(5),idirf(5),index,iflag, + & inv,ipkon(*),kon(*),kgas,icase,k_oil,nshcon(*), + & nrhcon(*),ntmat_,mi(2) +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,R,d, + & Tt1,Tt2,pt1,pt2,cp,physcon(3),km1,dvi, + & kp1,kdkm1,reynolds,kdkp1, + & pt2pt1,pt1pt2,pt1pt2_crit,qred_crit,qred1,qred2,zeta, + & A1,A2,root, expon1,expon2,expon3,fact1,fact2,sqrt,pi, + & pt2_lim,M2,M1,xflow_oil,T1,T2,phi, + & shcon(0:3,ntmat_,*),rhcon(0:1,ntmat_,*),zeta_phi,Aeff, + & C2,tdkp1 +! + phi=0.d0 + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1)then +! + isothermal=.false. + index=ielprop(nelem) + kappa=(cp/(cp-R)) + kp1=kappa+1d0 + km1=kappa-1d0 +! +! defining surfaces for branches elements +! + if(lakon(nelem)(2:6).eq.'REBRJ') then + if(nelem.eq.int(prop(index+2))) then + A1=prop(index+5) + A2=A1 + elseif(nelem.eq.int(prop(index+3)))then + A1=prop(index+6) + A2=A1 + endif + zeta=1.d0 + elseif(lakon(nelem)(2:6).eq.'REBRS') then + if(nelem.eq.int(prop(index+2))) then + A1=prop(index+5) + A2=A1 + elseif(nelem.eq.int(prop(index+3)))then + A1=prop(index+6) + A2=A1 + endif + zeta=1.d0 +! +! for other Restrictor elements +! + else if (lakon(nelem)(2:5).eq.'REUS' ) then + A1=prop(index+1) + A2=prop(index+2) + zeta=prop(index+4) + if(A1.gt.A2) then + A1=A2 + endif + else + A1=prop(index+1) + A2=prop(index+2) + zeta=1.d0 + endif +! + pt1=v(2,node1) + pt2=v(2,node2) +! + if(pt1.ge.pt2) then + inv=1 + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) + else + inv=-1 + pt1=v(2,node2) + pt2=v(2,node1) + Tt1=v(0,node2)+physcon(1) + Tt2=v(0,node1)+physcon(1) + endif +! + pt1pt2=pt1/pt2 + pt2pt1=1/pt1pt2 + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 +! + if(.not.isothermal) then + pt1pt2_crit=(0.5d0*kp1)**(zeta*kdkm1) + else + pt1pt2_crit=0.5d0*(3*kappa-1)**(zeta*kdkm1) + endif +! + if(pt1pt2.gt.pt1pt2_crit) then + crit=.true. + pt1pt2=pt1pt2_crit + endif +! + if(A1.le.A2) then +! + + Qred1=dsqrt(kappa/R)*pt1pt2**(-0.5d0*kp1/(kappa*zeta)) + & *dsqrt(2.d0/km1*(pt1pt2**(km1/(kappa*zeta))-1d0)) +! + Qred2=pt1pt2*A1/A2*Qred1 +! + if(.not.isothermal) then + Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1) + & **(-0.5d0*kp1/km1) + else + Qred_crit=dsqrt(1/R)*(1+0.5*km1/kappa) + & **(-0.5d0*kp1/km1) + endif +! + if (Qred2.lt.Qred_crit) then + if((Qred1.gt.Qred_crit).or.(pt1pt2.gt.pt1pt2_crit)) then + xflow=inv*A1*pt1*Qred_crit/dsqrt(Tt1) + else + xflow=inv*A1*pt1*Qred1/dsqrt(Tt1) + endif + else + call pt2_lim_calc(pt1,a2,a1,kappa,zeta,pt2_lim) +! + xflow=inv*A2*pt2_lim*Qred_crit/dsqrt(Tt2) +! + endif +! + else + Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1) + & **(-0.5d0*kp1/km1) + call pt2_lim_calc(pt1,a2,a1,kappa,zeta,pt2_lim) +! + xflow=inv*A2*pt2_lim*Qred_crit/dsqrt(Tt2) + endif + + pt2pt1=pt2/pt1 + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + tdkp1=2.d0/kp1 + C2=tdkp1**kdkm1 + if(A1.gt.A2) then + Aeff=A2 + else + Aeff=A1 + endif + if(pt2pt1.gt.C2) then + xflow=inv*pt1*Aeff*dsqrt(2.d0*kdkm1*pt2pt1**(2.d0/kappa) + & *(1.d0-pt2pt1**(1.d0/kdkm1))/r)/dsqrt(Tt1) + else + xflow=inv*pt1*Aeff*dsqrt(kappa/r)*tdkp1**(kp1/(2.d0*km1))/ + & dsqrt(Tt1) + endif + if(lakon(nelem)(2:5).ne.'RECO') then + xflow=0.75*xflow + else + xflow=xflow + endif +! + elseif (iflag.eq.2)then +! + numf=4 + isothermal=.false. + pi=4.d0*datan(1.d0) + kappa=(cp/(cp-R)) + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + kdkp1=kappa/kp1 + index=ielprop(nelem) +! + pt1=v(2,node1) + pt2=v(2,node2) +! + if(pt1.ge.pt2) then + inv=1 + else + inv=-1 + endif +! +! defining surfaces and oil properties for branches elements +! + if(lakon(nelem)(2:6).eq.'REBRJ') then + if(nelem.eq.int(prop(index+2))) then + A1=prop(index+5) + A2=A1 + xflow_oil=prop(index+9) + k_oil=int(prop(index+11)) + elseif(nelem.eq.int(prop(index+3)))then + A1=prop(index+6) + A2=A1 + xflow_oil=prop(index+10) + k_oil=int(prop(index+11)) + endif + elseif(lakon(nelem)(2:6).eq.'REBRS') then + if(nelem.eq.int(prop(index+2))) then + A1=prop(index+5) + A2=A1 + if(lakon(nelem)(2:8).eq.'REBRSI1') then + xflow_oil=prop(index+11) + k_oil=int(prop(index+13)) + else + xflow_oil=prop(index+9) + k_oil=int(prop(index+11)) + endif + elseif(nelem.eq.int(prop(index+3)))then + A1=prop(index+6) + A2=A1 + if(lakon(nelem)(2:8).eq.'REBRSI1') then + xflow_oil=prop(index+12) + k_oil=int(prop(index+13)) + else + xflow_oil=prop(index+10) + k_oil=int(prop(index+11)) + endif + endif +! +! for other Restrictor elements +! + + else + if(inv.gt.0.d0) then + A1=prop(index+1) + A2=prop(index+2) + else + A1=prop(index+2) + A2=prop(index+1) + endif +! + if(lakon(nelem)(2:5).eq.'REEL') then + xflow_oil=prop(index+4) + k_oil=int(prop(index+5)) + elseif((lakon(nelem)(2:7).eq.'RELOID').or. + & (lakon(nelem)(2:5).eq.'REUS').or. + & (lakon(nelem)(2:5).eq.'REEN').or. + & (lakon(nelem)(2:5).eq.'REEX').or. + & (lakon(nelem)(2:7).eq.'REWAOR').or. + & (lakon(nelem)(2:7).eq.'RELOLI')) then + xflow_oil=prop(index+5) + k_oil=int(prop(index+6)) + elseif((lakon(nelem)(2:5).eq.'RECO').or. + & (lakon(nelem)(2:7).eq.'REBEMA').or. + & (lakon(nelem)(2:7).eq.'REBEMI').or. + & (lakon(nelem)(2:8).eq.'REBEIDC')) then + xflow_oil=prop(index+6) + k_oil=int(prop(index+7)) + elseif(lakon(nelem)(2:8).eq.'REBEIDR') then + xflow_oil=prop(index+8) + k_oil=int(prop(index+9)) + endif + endif +! + if(pt1.gt.pt2) then + inv=1 + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + icase=0 + call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) + call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 + + elseif(pt1.eq.pt2) then + inv=1 + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) +! + pt2=pt2-0.01*pt2 + icase=0 + call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) + call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! + else + inv=-1 + pt1=v(2,node2) + pt2=v(2,node1) + xflow=-v(1,nodem) + Tt1=v(0,node2)+physcon(1) + Tt2=v(0,node1)+physcon(1) + icase=0 + call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) + call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 + endif + +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 +! +! calculation of the dynamic viscosity +! + if( lakon(nelem)(2:3).eq.'RE') then + icase=0 + endif +! + if (A1.le.A2) then + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif + else + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T2,dvi) + endif + endif +! +! Reynolds number calculation +! + if (lakon(nelem)(2:5).eq.'REBR') then + d=dsqrt(4d0*A1/Pi) + reynolds=dabs(xflow)*d/(dvi*A1) + else + d=prop(index+3) + if(A1.le.A2) then + reynolds=dabs(xflow)*d/(dvi*A1) + else + reynolds=dabs(xflow)*d/(dvi*A2) + endif + endif + + if(xflow_oil.lt.1E-10) then + xflow_oil=0d0 + endif +! +! BEND MILLER with oil +! + if(lakon(nelem)(2:7).eq.'REBEMI') then + if(xflow_oil.ne.0d0) then +! + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) +! + zeta=phi*zeta + else + + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + phi=1.d0 + endif +! +! long orifice idelchick with oil +! + elseif(lakon(nelem)(2:7).eq.'RELOID') then + if(xflow_oil.ne.0d0) then +! + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) + zeta=phi*zeta + + else + + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + phi=1.d0 + endif +! +! every other zeta elements with/without oil +! + else +! + if(xflow_oil.ne.0d0) then + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + zeta=phi*zeta + else + phi=1.d0 + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + zeta=phi*zeta + endif + endif +! + if(zeta.lt.0) then + pt1=v(2,node1) + pt2=v(2,node2) + xflow=v(1,nodem) + Tt2=v(0,node2) + Tt1=v(0,node1) + call ts_calc(xflow,Tt1,Pt1,kappa,r,A1,T1,icase) + call ts_calc(xflow,Tt2,Pt2,kappa,r,A2,T2,icase) +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! + endif +! + if(.not.isothermal) then + pt1pt2_crit=(0.5d0*kp1)**(zeta*kdkm1) + else + pt1pt2_crit=0.5d0*(3*kappa-1)**(zeta*kdkm1) + endif + pt1pt2=pt1/pt2 +! +! Mach number caclulation +! + M1=dsqrt(2d0/km1*(Tt1/T1-1d0)) + if((1.d0-M1).le.1E-6) then + if(zeta.gt.0d0) then + call limit_case_calc(a2,pt1,Tt2,xflow,zeta,r,kappa, + & pt2_lim,M2) +! + endif + else + M2=dsqrt(2d0/km1*(Tt2/T2-1d0)) + endif +! +! Section A1 smaller than or equal to section A2 +! or for all BRANCHES ELEMENTS +! + if (A1.le.A2) then +! +! definition of the reduced mass flows +! + if(zeta.gt.0) then +! + Qred1=dsqrt(kappa/R)*pt1pt2**(-0.5d0*kp1/(kappa*zeta)) + & *dsqrt(2.d0/km1*(pt1pt2**(km1/(kappa*zeta))-1d0)) +! + elseif(zeta.lt.0d0) then +! + Qred1=dabs(xflow)*dsqrt(Tt1)/(pt1*A1) +! + endif +! + Qred2=pt1pt2*A1/A2*Qred1 +! + if(.not.isothermal) then + Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1) + & **(-0.5d0*kp1/km1) + else + Qred_crit=dsqrt(1/R)*(1+0.5*km1/kappa) + & **(-0.5d0*kp1/km1) + endif +! +! icase zeta greater than zero +! + if(zeta.gt.0) then +! +! definition of the coefficients +! + sqrt=dsqrt(R*Tt1/kappa) + expon1=-0.5d0*kp1/(zeta*kappa) + fact1=pt1pt2**expon1 + expon2=km1/(zeta*kappa) + fact2=pt1pt2**expon2 + expon3=1d0/(zeta*kappa) + root=2d0/km1*(fact2-1d0) +! + if(Qred2.lt.Qred_crit) then +! + if((Qred1.lt.Qred_crit) + & .and.(pt1pt2.lt.pt1pt2_crit))then +! +! section 1 is not critical +! +! residual +! + f=xflow*sqrt/(A1*Pt1)-fact1*dsqrt(root) +! +! pressure node1 +! + df(1)=-xflow*sqrt/(A1*Pt1**2)+ + & fact1/pt1*dsqrt(root) + & *(-expon1-expon3*fact2/root) +! +! temperature node1 +! + df(2)=0.5d0*xflow*dsqrt(R/(kappa*Tt1))/(A1*Pt1) +! +! mass flow +! + df(3)=inv*sqrt/(A1*Pt1) +! +! pressure node2 +! + df(4)=fact1/pt2*dsqrt(root)* + & (expon1+expon3*fact2/root) +! + else +! +! section1 is critical +! + f=xflow*sqrt/(pt1*A1)-dsqrt(R/kappa)*qred_crit +! +! pressure node1 +! + df(1)=-xflow*sqrt/(A1*pt1**2) +! +! temperature node1 +! + df(2)=0.5d0*xflow*dsqrt(R/kappa) + & /(pt1*A1*dsqrt(Tt1)) +! +! mass flow +! + df(3)=inv*sqrt/(A1*pt1) +! +! pressure node2 +! + df(4)=0.d0 +! + endif +! + else +! +! section A2 critical +! + call pt2_lim_calc(pt1,a2,a1,kappa,zeta,pt2_lim) + pt1pt2=pt1/pt2_lim +! + fact1=pt1pt2**expon1 +! + fact2=pt1pt2**expon2 +! + root=2d0/km1*(fact2-1d0) +! + f=xflow*sqrt/(A1*Pt1)-fact1*dsqrt(root) +! +! pressure node1 +! + df(1)=-xflow*sqrt/(A1*Pt1**2)+ + & fact1/pt1*dsqrt(root) + & *(-expon1-expon3*fact2/root) +! +! temperature node1 +! + df(2)=0.5d0*xflow*dsqrt(R/(kappa*Tt1))/(A1*Pt1) +! +! mass flow +! + df(3)=inv*sqrt/(A1*Pt1) +! +! pressure node2 +! + df(4)=0 +! + endif +! +! icase zeta less than zero +! + elseif(zeta.lt.0) then +! + expon1=-kp1/(zeta*kappa) + fact1=pt1pt2**expon1 + expon2=km1/(zeta*kappa) + fact2=pt1pt2**expon2 + expon3=1d0/(zeta*kappa) + root=2d0/km1*(fact2-1d0) +! + if(Qred1.lt.Qred_crit) then +! +! section 1 is not critical +! +! residual +! + f=xflow**2*R*Tt1/(A1**2*Pt1**2*Kappa) + & -fact1*root +! +! pressure node1 +! + df(1)=-2*xflow**2*R*Tt1/(A1**2*Pt1**3*Kappa) + & -1/pt1*fact1*(expon1*root + & +2/(zeta*kappa)*fact2) +! +! temperature node1 +! + df(2)=xflow**2*R/(A1**2*Pt1**2*Kappa) +! +! mass flow +! + df(3)=2*xflow*R*Tt1/(A1**2*Pt1**2*Kappa) +! +! pressure node2 +! + df(4)=-(1/Pt2*fact1) + & *(-expon1*root-2/(zeta*kappa)*fact2) +! +! section1 is critical +! + else +! + f=xflow**2*R*Tt1/(A1**2*Pt1**2*Kappa) + & -R/kappa*qred_crit**2 +! +! pressure node1 +! + df(1)=-2*xflow**2*R*Tt1/(A1**2*pt1**3*kappa) +! +! temperature node1 +! + df(2)=xflow**2*R/(A1**2*Pt1**2*Kappa) +! +! mass flow +! + df(3)=2*xflow*R*Tt1/(A1**2*Pt1**2*Kappa) +! +! pressure node2 +! + df(4)=0.d0 +! + endif +! +! zeta = 0 +! + elseif(zeta.eq.0d0) then +! + f=pt1-pt2 +! + df(1)=1 +! + df(2)=0 +! + df(3)=0 +! + df(4)=-1 +! + endif +! + else +! +! A1 greater than A2 +! + Qred2=dabs(xflow)*dsqrt(Tt2)/(A2*Pt2) +! + Qred1=1/pt1pt2*A2/A1*Qred2 +! + Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1) + & **(-0.5d0*kp1/km1) + +! definition of the coefficients +! + if(zeta.gt.0d0) then +! + sqrt=dsqrt(R*Tt1/kappa) +! + expon1=-0.5d0*kp1/(zeta*kappa) + fact1=pt1pt2**expon1 + expon2=km1/(zeta*kappa) + fact2=pt1pt2**expon2 + expon3=1d0/(zeta*kappa) + root=2d0/km1*(fact2-1d0) +! + if(pt1pt2.ge.pt1pt2_crit) then + pt1pt2=pt1pt2_crit + pt2=pt1/pt1pt2_crit + endif +! + if((Qred2.lt.Qred_crit) + & .and.(pt1/pt2.lt.pt1pt2_crit)) then +! +! section 2 is not critical +! +! residual +! + f=xflow*sqrt/(A2*Pt2)-fact1*dsqrt(root) +! +! pressure node1 +! + df(1)=-fact1/pt1*dsqrt(root) + & *(expon1+0.5*dsqrt(2/km1)*expon2*fact2/root) +! +! temperature node1 +! + df(2)=0.5d0*xflow*sqrt/(A2*Pt2*Tt1) +! +! mass flow +! + df(3)=inv*sqrt/(A2*Pt2) +! +! pressure node2 +! + df(4)=-xflow*sqrt/(A2*Pt2**2) + & -fact1/pt2*dsqrt(root)* + & (-expon1-0.5*dsqrt(2/km1)*expon2*fact2/root) +! + else + write(*,*) + & '*WARNING in restrictor: A1 greater A2 critical' +! +! section2 is critical +! + pt2=pt1/pt1pt2_crit +! + f=xflow*dsqrt(Tt1)/(pt2*A2)-qred_crit +! +! pressure node1 +! + df(1)=0 +! +! temperature node1 +! + df(2)=0.5d0*xflow/(A2*pt2*dsqrt(Tt2)) +! +! mass flow +! + df(3)=inv*dsqrt(Tt1)/(A2*pt2) +! +! pressure node2 +! + df(4)=-xflow*dsqrt(Tt1)/(A2*pt2**2) +! + endif +! + elseif(zeta.eq.0d0) then +! + Qred1=dabs(xflow)*dsqrt(Tt1*kappa/R)/(A1*Pt1) + Qred2=dabs(xflow)*dsqrt(Tt2*kappa/R)/(A2*Pt2) + Qred_crit=dsqrt(kappa/R)*(1.d0+0.5d0*km1) + & **(-0.5d0*kp1/km1) +! + f=pt1/pt2-1.d0 +! + df(1)=1/pt2 +! + df(2)=0 +! + df(3)=0 +! + df(4)=-pt1/pt2**2 +! + endif + endif +! + elseif(iflag.eq.3) then +! + isothermal=.false. + pi=4.d0*datan(1.d0) + kappa=(cp/(cp-R)) + km1=kappa-1.d0 + kp1=kappa+1.d0 + kdkm1=kappa/km1 + kdkp1=kappa/kp1 + index=ielprop(nelem) +! + pt1=v(2,node1) + pt2=v(2,node2) + if(pt1.ge.pt2) then + inv=1 + else + inv=-1 + endif +! +! defining surfaces for branches elements +! + if(lakon(nelem)(2:6).eq.'REBRJ') then + if(nelem.eq.int(prop(index+2))) then + A1=prop(index+5) + A2=A1 + xflow_oil=prop(index+9) + k_oil=int(prop(index+11)) + elseif(nelem.eq.int(prop(index+3)))then + A1=prop(index+6) + A2=A1 + xflow_oil=prop(index+10) + k_oil=int(prop(index+11)) + endif + elseif(lakon(nelem)(2:6).eq.'REBRS') then + if(nelem.eq.int(prop(index+2))) then + A1=prop(index+5) + A2=A1 + if(lakon(nelem)(2:8).eq.'REBRSI1') then + xflow_oil=prop(index+11) + k_oil=int(prop(index+13)) + else + xflow_oil=prop(index+9) + k_oil=int(prop(index+11)) + endif + elseif(nelem.eq.int(prop(index+3)))then + A1=prop(index+6) + A2=A1 + if(lakon(nelem)(2:8).eq.'REBRSI1') then + xflow_oil=prop(index+12) + k_oil=int(prop(index+13)) + else + xflow_oil=prop(index+10) + k_oil=int(prop(index+11)) + endif + endif +! +! for other Restrictor elements +! + else + A1=prop(index+1) + A2=prop(index+2) + if(lakon(nelem)(2:5).eq.'REEL') then + xflow_oil=prop(index+4) + k_oil=int(prop(index+5)) + elseif((lakon(nelem)(2:7).eq.'RELOID').or. + & (lakon(nelem)(2:5).eq.'REUS').or. + & (lakon(nelem)(2:5).eq.'REEN').or. + & (lakon(nelem)(2:5).eq.'REEX').or. + & (lakon(nelem)(2:7).eq.'REWAOR').or. + & (lakon(nelem)(2:7).eq.'RELOLI')) then + xflow_oil=prop(index+5) + k_oil=int(prop(index+6)) + elseif((lakon(nelem)(2:5).eq.'RECO').or. + & (lakon(nelem)(2:7).eq.'REBEMA').or. + & (lakon(nelem)(2:7).eq.'REBEMI').or. + & (lakon(nelem)(2:8).eq.'REBEIDC')) then + xflow_oil=prop(index+6) + k_oil=int(prop(index+7)) + elseif(lakon(nelem)(2:7).eq.'REBEIDR') then + xflow_oil=prop(index+8) + k_oil=int(prop(index+9)) + endif + endif +! + if(pt1.ge.pt2) then + inv=1 + xflow=v(1,nodem) + Tt1=v(0,node1)+physcon(1) + Tt2=v(0,node2)+physcon(1) + icase=0 + call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) + call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) +! + else + inv=-1 + pt1=v(2,node2) + pt2=v(2,node1) + xflow=-v(1,nodem) + Tt1=v(0,node2)+physcon(1) + Tt2=v(0,node1)+physcon(1) + icase=0 + call ts_calc(xflow,Tt1,Pt1,kappa,r,a1,T1,icase) + call ts_calc(xflow,Tt2,Pt2,kappa,r,a2,T2,icase) +! + endif +! +! calculation of the dynamic viscosity +! + if( lakon(nelem)(2:3).eq.'RE') then + icase=0 + elseif(lakon(nelem)(2:5).eq.'REEX') then + if(lakon(int(prop(index+4)))(2:6).eq.'GAPFA') then + icase=0 + elseif(lakon(int(prop(index+4)))(2:6).eq.'GAPFI') then + icase=1 + endif + endif +! + if (A1.le.A2) then + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T1,dvi) + endif + else + if(dabs(dvi).lt.1E-30) then + kgas=0 + call dynamic_viscosity(kgas,T2,dvi) + endif + endif +! +! Reynolds number calculation +! + if (lakon(nelem)(2:5).eq.'REBR') then + d=dsqrt(4d0*A1/Pi) + reynolds=dabs(xflow)*d/(dvi*A1) + else + d=prop(index+3) + if(A1.le.A2) then + reynolds=dabs(xflow)*d/(dvi*A1) + else + reynolds=dabs(xflow)*d/(dvi*A2) + endif + endif + + if(xflow_oil.lt.1E-10) then + xflow_oil=0d0 + endif +! +! BEND MILLER with oil +! + if(lakon(nelem)(2:7).eq.'REBEMI') then + if(xflow_oil.ne.0d0) then + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) + + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) +! + zeta_phi=phi*zeta + else +! + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + phi=1.d0 + zeta_phi=phi*zeta +! + endif +! +! long orifice in a wall with oil after Idelchik +! + elseif(lakon(nelem)(2:7).eq.'RELOID') then + if(xflow_oil.ne.0d0) then + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) +! + zeta_phi=phi*zeta + else +! + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + phi=1.d0 + zeta_phi=phi*zeta + endif +! +! every other zeta elements with/without oil +! + else +! + if(xflow_oil.ne.0) then + call two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop, + & v,dvi,cp,r,k_oil,phi,zeta,nshcon,nrhcon, + & shcon,rhcon,ntmat_,mi) +! + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) +! + zeta_phi=phi*zeta + else + phi=1.d0 + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + zeta_phi=phi*zeta + endif + endif +! + if(zeta.le.0) then + pt1=v(2,node1) + pt2=v(2,node2) + xflow=v(1,nodem) + Tt1=v(0,node1) + Tt2=v(0,node2) +! + endif +! + if(.not.isothermal) then + pt1pt2_crit=(0.5d0*kp1)**(zeta*kdkm1) + else + pt1pt2_crit=0.5d0*(3*kappa-1)**(zeta*kdkm1) + endif + pt1pt2=pt1/pt2 +! +! Mach number calculation +! + M1=dsqrt(2d0/km1*(Tt1/T1-1d0)) + if((1.d0-M1).le.1E-3) then + + if(zeta.gt.0d0)then + if(xflow_oil.eq.0) then + call limit_case_calc(a2,pt1,Tt2,xflow,zeta,r,kappa, + & pt2_lim,M2) + else + call limit_case_calc(a2,pt1,Tt2,xflow,zeta_phi,r,kappa + & ,pt2_lim,M2) + endif + endif + else + M2=dsqrt(2d0/km1*(Tt2/T2-1d0)) + endif +! + write(1,*) '' + write(1,55) 'In line',int(nodem/1000),' from node',node1, + & ' to node', node2,': air massflow rate=',xflow,'kg/s' + & , ', oil massflow rate=',xflow_oil,'kg/s' + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.6,A,A,F9.6,A) +! + if(lakon(nelem)(4:5).ne.'BR') then +! +! for restrictors +! + if(inv.eq.1) then + write(1,56)' Inlet node ',node1,': Tt1= ',Tt1, + & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, + & 'Bar, M1= ',M1 + write(1,*)' element F ',set(numf) + & (1:20) + write(1,57)' eta= ',dvi,'kg/(m*s), Re= ' + & ,reynolds,', PHI=',phi,', ZETA= ',zeta, + &', ZETA_PHI= ',zeta_phi + write(1,56)' Outlet node ',node2,': Tt2= ',Tt2, + & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1e5, + & 'Bar, M2= ',M2 +! + else if(inv.eq.-1) then + write(1,56)' Inlet node ',node2,': Tt1= ',Tt1, + & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, + & 'Bar, M1= ',M1 + write(1,*)' element F ',set(numf) + & (1:20) + write(1,57)' eta= ',dvi,'kg/(m*s), Re= ' + & ,reynolds,', PHI= ',phi,', ZETA= ',zeta, + &', ZETA_PHI= ',zeta_phi + write(1,56)' Outlet node ',node1,': Tt2= ',Tt2, + & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1e5, + & 'Bar, M2= ',M2 + endif + else +! +! for branches +! + if(inv.eq.1) then + write(1,56)' Inlet node ',node1,': Tt1= ',Tt1, + & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, + & 'Bar, M1= ',M1 + write(1,*)' element B ',set(numf) + & (1:20) + write(1,57)' Eta= ',dvi,' kg/(m*s), Re= ' + &,reynolds,', PHI= ',phi,', ZETA= ',zeta + write(1,56)' Outlet node ',node2,': Tt2= ',Tt2, + & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1E5, + & 'Bar, M2= ',M2 +! + else if(inv.eq.-1) then + write(1,56)' Inlet node ',node2,': Tt1= ',Tt1, + & 'K, Ts1= ',T1,'K, Pt1= ',Pt1/1E5, + & 'Bar, M1= ',M1 + write(1,*)' element B ',set(numf) + & (1:20) + write(1,57)' Eta=',dvi,' kg/(m*s), Re= ' + & ,reynolds,', PHI= ',phi,', ZETA= ',zeta + write(1,56)' Outlet node ',node1,': Tt2= ',Tt2, + & 'K, Ts2= ',T2,'K, Pt2= ',Pt2/1E5, + & 'Bar, M2= ',M2 + endif + endif + endif + 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f8.5,A,f8.6) + 57 FORMAT(1X,A,G9.4,A,G11.5,A,f8.4,A,f8.4,A,f8.4) +! + + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/resultnet.f calculix-ccx-2.3/ccx_2.3/src/resultnet.f --- calculix-ccx-2.1/ccx_2.3/src/resultnet.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/resultnet.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1203 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! construction of the B matrix +! + subroutine resultnet(itg,ieg,ntg, + & bc,nload,sideload,nelemload,xloadact,lakon,ntmat_, + & v,shcon,nshcon,ipkon,kon,co,nflow, + & iinc,istep,dtime,ttime,time, + & ikforc,ilforc,xforcact,nforc,ielmat,nteq,prop,ielprop, + & nactdog,nacteq,iin,physcon,camt,camf,camp,rhcon,nrhcon, + & ipobody,ibody,xbodyact,nbody,dtheta,vold,xloadold, + & reltime,nmethod,set,mi,ineighe,cama,vamt,vamf,vamp,vama, + & nmpc,nodempc,ipompc,coefmpc,labmpc) +! + implicit none +! + logical identity + character*8 lakonl,lakon(*) + character*20 sideload(*),labmpc(*) + character*81 set(*) +! + integer itg(*),ieg(*),ntg,nteq,nflow,nload,ielmat(*),iflag, + & nelemload(2,*),nope,nopes,mint2d,i,j,k,l,nrhcon(*), + & node,imat,ntmat_,id,ifaceq(8,6),ifacet(6,4),numf, + & ifacew(8,5),node1,node2,nshcon(*),nelem,ig,index,konl(20), + & ipkon(*),kon(*),idof,mi(2),ineighe(*),idir, + & iinc,istep,jltyp,nfield,ikforc(*),ipobody(2,*), + & ilforc(*),nforc,nodem,idirf(5),ieq,nactdog(0:3,*),nbody, + & nacteq(0:3,*),ielprop(*),nodef(5),iin,kflag,ibody(3,*),icase, + & inv, index2,nmethod,nelem0,nodem0,nelem1,nodem1,nelem2, + & nodem2,nelemswirl,nmpc,nodempc(3,*),ipompc(*) +! + real*8 bc(nteq),xloadact(2,*),cp,h(2),physcon(*),r,dvi,rho, + & xl2(3,8),coords(3),dxsj2,temp,xi,et,weight,xsj2(3), + & gastemp,v(0:mi(2),*),shcon(0:3,ntmat_,*),co(3,*),shp2(7,8), + & field,prop(*),tg1,tg2,dtime,ttime,time,g(3),eta, + & xforcact(*),areaj,xflow,tvar(2),f,df(5),camt(*),camf(*), + & camp(*),tl2(8),cama(*),vamt,vamf,vamp,vama, + & rhcon(0:1,ntmat_,*),xbodyact(7,*),sinktemp,kappa,a,T,Tt,Pt, + & dtheta,ts1,ts2,xs2(3,7),xk1,xk2,xdenom1,xdenom2,expon,pt1, + & pt2,dt1,dt2,xcst,xnum1,xnum2,Qred_crit,xflow_crit, + & xflow0,xflow1,reltime,coefmpc(*), + & xflow2,R1,R2,Rout,Rin,Uout,Uin,heat,pi, + & Cp_cor,U,Ct,vold(0:mi(2),*),xloadold(2,*),omega +! + include "gauss.f" +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ + data iflag /2/ +! + kflag=2 +! + tvar(1)=time + tvar(2)=ttime+dtime +! + pi=4.d0*datan(1.d0) +! +! calculating the maximum change in the solution +! + camt(1)=0.d0 + camf(1)=0.d0 + camp(1)=0.d0 + cama(1)=0.d0 +! + camt(2)=0.5d0 + camf(2)=0.5d0 + camp(2)=0.5d0 + cama(2)=0.5d0 +! + vamt=0.d0 + vamf=0.d0 + vamp=0.d0 + vama=0.d0 +! +! +c write(30,*) 'loesung resultgas' +c do i=1,9 +c write(30,'(1x,e11.4)') bc(i) +c enddo +! + do i=1,ntg + node=itg(i) + do j=0,3 + if(nactdog(j,node).eq.0) cycle + idof=nactdog(j,node) + if(j.eq.0) then + if(dabs(bc(idof)).gt.camt(1)) then + camt(1)=dabs(bc(idof)) + camt(2)=node+0.5d0 + endif + elseif(j.eq.1) then + if(dabs(bc(idof)).gt.camf(1)) then + camf(1)=dabs(bc(idof)) + camf(2)=node+0.5d0 + endif + elseif(j.eq.2) then + if(dabs(bc(idof)).gt.camp(1)) then + camp(1)=dabs(bc(idof)) + camp(2)=node+0.5d0 + endif + else + if(dabs(bc(idof)).gt.cama(1)) then + cama(1)=dabs(bc(idof)) + cama(2)=node+0.5d0 + endif + endif + enddo + enddo +! +! updating v +! + do i=1,ntg + node=itg(i) + do j=0,2 + if(nactdog(j,node).eq.0) cycle + v(j,node)=v(j,node)+bc(nactdog(j,node))*dtheta + if((j.eq.0).and.(dabs(v(j,node)).gt.vamt)) then + vamt=dabs(v(j,node)) + elseif((j.eq.1).and.(dabs(v(j,node)).gt.vamf)) then + vamf=dabs(v(j,node)) + elseif((j.eq.2).and.(dabs(v(j,node)).gt.vamp)) then + vamp=dabs(v(j,node)) + endif + enddo +c write(30,*) 'resultgas',node,(v(j,node),j=0,2) + enddo +! +! update geometry changes +! + do i=1,nflow + if(lakon(ieg(i))(6:7).eq.'GV') then + index=ipkon(ieg(i)) + node=kon(index+2) + if(nactdog(3,node).eq.0) cycle + index=ielprop(ieg(i)) + v(3,node)=v(3,node)+bc(nactdog(3,node))*dtheta + if(v(3,node).gt.0.99999d0) then + v(3,node)=0.99999d0 + elseif(v(3,node).lt.0.12501) then + v(3,node)=0.12501d0 + endif +c write(30,*) 'resultgas ',node,prop(index+2) +c v(3,node)=prop(index+2) + if(dabs(v(3,node)).gt.vama) vama=dabs(v(3,node)) +! +! update location of hydraulic jump +! + elseif(lakon(ieg(i))(2:5).eq.'LICH') then + if((lakon(ieg(i))(6:7).eq.'SG').or. + & (lakon(ieg(i))(6:7).eq.'WE').or. + & (lakon(ieg(i))(6:7).eq.'DS')) then + index=ipkon(ieg(i)) + node=kon(index+2) + if(nactdog(3,node).eq.0) cycle + index=ielprop(ieg(i)) + if(lakon(ieg(i))(6:7).eq.'SG') then + eta=prop(index+4)+bc(nactdog(3,node))*dtheta + prop(index+4)=eta + nelem=int(prop(index+7)) + elseif(lakon(ieg(i))(6:7).eq.'WE') then + eta=prop(index+4)+bc(nactdog(3,node))*dtheta + prop(index+4)=eta + nelem=int(prop(index+7)) + elseif(lakon(ieg(i))(6:7).eq.'DS') then + eta=prop(index+7)+bc(nactdog(3,node))*dtheta + prop(index+7)=eta + nelem=int(prop(index+9)) + endif + v(3,node)=eta + vama=eta +! +! check whether 0<=eta<=1. If not, the hydraulic jump +! does not take place in the element itself and has to +! be forced out of the element by adjusting the +! water depth of one of the end nodes +! +c write(30,*) 'resultgas eta ',eta + if((eta.lt.0.d0).or.(eta.gt.1.d0)) then +c if(eta.ne.0.5d0) then + index=ipkon(nelem) + node1=kon(index+1) + nodem=kon(index+2) + node2=kon(index+3) + xflow=v(1,nodem) +! +! determining the temperature for the +! material properties +! + if(xflow.gt.0) then + if(node1.eq.0) then + gastemp=v(0,node2) + else + gastemp=v(0,node1) + endif + else + if(node2.eq.0) then + gastemp=v(0,node1) + else + gastemp=v(0,node2) + endif + endif +c if(node1.eq.0) then +c tg1=v(0,node2) +c tg2=tg1 +c ts1=v(3,node2) +c ts2=Ts1 +c elseif(node2.eq.0) then +c tg1=v(0,node1) +c tg2=tg1 +c ts1=v(3,node1) +c ts2=ts1 +c else +c tg1=v(0,node1) +c tg2=v(0,node2) +c ts1=v(3,node1) +c ts2=v(3,node2) +c endif +c gastemp=(ts1+ts2)/2.d0 +! + imat=ielmat(nelem) +! + call materialdata_tg(imat,ntmat_,gastemp,shcon,nshcon, + & cp,r,dvi,rhcon,nrhcon,rho) +! + do j=1,3 + g(j)=0.d0 + enddo + if(nbody.gt.0) then + index=nelem + do + j=ipobody(1,index) + if(j.eq.0) exit + if(ibody(1,j).eq.2) then + g(1)=g(1)+xbodyact(1,j)*xbodyact(2,j) + g(2)=g(2)+xbodyact(1,j)*xbodyact(3,j) + g(3)=g(3)+xbodyact(1,j)*xbodyact(4,j) + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif +! + kflag=3 + call flux(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity, + & ielprop,prop,kflag,v,xflow,f,nodef,idirf,df, + & cp,r,rho,physcon,g,co,dvi,numf,vold,set,shcon, + & nshcon,rhcon,nrhcon,ntmat_,mi) + kflag=2 +! + endif + endif + endif + enddo +! +c do i=1,ntg +c node=itg(i) +c write(30,*) 'resultgas',(v(j,node),j=0,3) +c enddo +! +! testing the validity of the pressures +! + do i=1,ntg + node=itg(i) + if(v(2,node).lt.0) then + write(*,*) 'wrong pressure node ',node + iin=0 + return + endif + enddo +! +! testing validity of temperatures +! + do i=1,ntg + node=itg(i) + if(v(0,node).lt.0) then + iin=0 + return + endif + enddo +! +! testing the validity of the solution for branches elements +! and restrictor. Since the element properties are dependent on +! a predefined flow direcction a change of this will lead to +! wrong head losses +! + do i=1, nflow + nelem=ieg(i) + if ((lakon(nelem)(4:5).eq.'ATR').or. + & (lakon(nelem)(4:5).eq.'RTA')) then + xflow=v(1,kon(ipkon(nelem)+2)) + if(xflow.lt.0d0)then + Write(*,*)'*WARNING in resultgas.f' + write(*,*)'Element',nelem,'of TYPE ABSOLUTE TO RELATIVE' + write(*,*)'The flow direction is no more conform ' + write(*,*)'to element definition' + write(*,*)'Check the pertinence of the results' + endif + elseif(lakon(nelem)(2:3).eq.'RE') then +! + if(lakon(nelem)(4:5).ne.'BR') then + nodem=kon(ipkon(nelem)+2) + xflow=v(1,nodem) + if (xflow.lt.0) then + Write(*,*)'*WARNING in resultgas.f' + write(*,*)'Element',nelem,'of TYPE RESTRICTOR' + write(*,*)'The flow direction is no more conform ' + write(*,*)'to element definition' + write(*,*)'Check the pertinence of the results' + endif +! + elseif(lakon(nelem)(4:5).eq.'BR') then + index=ielprop(nelem) +! + nelem0=int(prop(index+1)) + nodem0=kon(ipkon(nelem0)+2) + xflow0=v(1,nodem0) +! + nelem1=int(prop(index+2)) + nodem1=kon(ipkon(nelem1)+2) + xflow1=v(1,nodem1) +! + nelem2=int(prop(index+3)) + nodem2=kon(ipkon(nelem2)+2) + xflow2=v(1,nodem2) +! + if((xflow0.lt.0).or.(xflow1.lt.0).or.(xflow2.lt.0)) then + Write(*,*)'*WARNING in resultgas.f' + write(*,*)'Element',nelem,'of TYPE BRANCH' + write(*,*)'The flow direction is no more conform ' + write(*,*)'to element definition' + write(*,*)'Check the pertinence of the results' + endif + endif + endif + enddo +! +! determining the static temperature +! case 1: chamber; static=total temperature +! + do i=1,ntg + node=itg(i) + nelem=ineighe(i) + if(nelem.eq.-1) then + v(3,node)=v(0,node) +c endif +c enddo +c! +c! case 2: gas pipe/restrictor +c! iteratively solving Tt=T+0.5*v**2/(2*Cp) to obtain T static +c! +c do i=1,ntg +c node=itg(i) +c nelem=ineighe(i) +c! +c if (nelem.gt.0) then +c + elseif(nelem.gt.0) then +! + nodem=kon(ipkon(nelem)+2) + T=v(3,node) + Tt=v(0,node) + Pt=v(2,node) + xflow=v(1,nodem) +! + icase=0 + inv=1 + imat=ielmat(nelem) + call materialdata_tg(imat,ntmat_,v(3,node), + & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho) +! + index=ielprop(nelem) + kappa=(cp/(cp-R)) +! + if((lakon(nelem)(2:5).eq.'GAPF') + & .or.(lakon(nelem)(2:5).eq.'GAPI'))then + A=prop(index+1) + if((lakon(nelem)(2:6).eq.'GAPFA') + & .or.(lakon(nelem)(2:5).eq.'GAPIA'))then + icase=0 + elseif((lakon(nelem)(2:6).eq.'GAPFI') + & .or.(lakon(nelem)(2:5).eq.'GAPII'))then + icase=1 + endif + elseif(lakon(nelem)(2:3).eq.'OR') then + A=prop(index+1) + icase=0 +! + elseif(lakon(nelem)(2:3).eq.'RE') then + index2=ipkon(nelem) + node1=kon(index2+1) + node2=kon(index2+3) +! + if(lakon(nelem)(4:5).eq.'EX') then + if(lakon(int(prop(index+4)))(2:6).eq.'GAPFA') then + icase=0 + elseif(lakon(int(prop(index+4)))(2:6).eq.'GAPFI')then + icase=1 + endif + else + icase=0 + endif +! +! defining the sections +! + if(lakon(nelem)(4:5).eq.'BE') then + a=prop(index+1) +! + elseif(lakon(nelem)(4:5).eq.'BR') then + if(lakon(nelem)(4:6).eq.'BRJ') then + if(nelem.eq.int(prop(index+2)))then + A=prop(index+5) + elseif(nelem.eq.int(prop(index+3))) then + A=prop(index+6) + endif + elseif(lakon(nelem)(4:6).eq.'BRS') then + if(nelem.eq.int(prop(index+2)))then + A=prop(index+5) + elseif(nelem.eq.int(prop(index+3))) then + A=prop(index+6) + endif + endif +! + else +! + if(node.eq.node1) then + a=prop(index+1) + elseif(node.eq.node2) then + a=prop(index+2) + endif + endif + endif +! + if(xflow.lt.0d0) then + inv=-1 + else + inv=1 + endif +! + if(icase.eq.0) then + Qred_crit=dsqrt(kappa/R)*(1.+0.5*(kappa-1.)) + & **(-0.5d0*(kappa+1.)/(kappa-1.)) + else + Qred_crit=dsqrt(1/R)*(1.+0.5*(kappa-1.)/kappa) + & **(-0.5d0*(kappa+1.)/(kappa-1.)) + endif + xflow_crit=inv*Qred_crit*Pt*A/dsqrt(Tt) +! + call ts_calc(xflow,Tt,Pt,kappa,r,a,T,icase) +! + v(3,node)=T +! + if(dabs(v(1,nodem)).ge.dabs(xflow_crit)) then + v(1,nodem)=xflow_crit + if(icase.eq.1) then +! + if(nactdog(0,node2).ne.0) then + index2=ipkon(nelem) + node1=kon(index2+1) + node2=kon(index2+3) + v(3,node2)=v(3,node1) + v(0,node2)=v(3,node2) + & *(1+0.5d0*(kappa-1)/kappa) + + endif + endif + endif +! + endif +! + enddo +! +! reinitialisation of the Bc matrix +! + do i=1,nteq + bc(i)=0.d0 + enddo +! +! determining the residual +! + do i=1,nflow + nelem=ieg(i) + index=ipkon(nelem) + node1=kon(index+1) + nodem=kon(index+2) + node2=kon(index+3) + xflow=v(1,nodem) +! +! gas: the property temperature is the static temperature +! + if((lakon(nelem)(2:3).ne.'LP').and. + & (lakon(nelem)(2:3).ne.'LI')) then + if(node1.eq.0) then + tg1=v(0,node2) + tg2=tg1 + ts1=v(3,node2) + ts2=ts1 + elseif(node2.eq.0) then + tg1=v(0,node1) + tg2=tg1 + ts1=v(3,node1) + ts2=ts1 + else + tg1=v(0,node1) + tg2=v(0,node2) + ts1=v(3,node1) + ts2=v(3,node2) + endif + gastemp=(ts1+ts2)/2.d0 + else +! +! liquid: only one temperature +! + if(xflow.gt.0) then + if(node1.eq.0) then + gastemp=v(0,node2) + else + gastemp=v(0,node1) + endif + else + if(node2.eq.0) then + gastemp=v(0,node1) + else + gastemp=v(0,node2) + endif + endif +! + if(node1.eq.0) then + tg2=v(0,node2) + tg1=tg2 + elseif(node2.eq.0) then + tg1=v(0,node1) + tg2=tg1 + else + tg1=v(0,node1) + tg2=v(0,node2) + endif + endif +! + imat=ielmat(nelem) +! + call materialdata_tg(imat,ntmat_,gastemp,shcon,nshcon,cp,r,dvi, + & rhcon,nrhcon,rho) + kappa=Cp/(Cp-R) +! +! Definitions of the constant for isothermal flow elements +! + if((lakon(nelem)(2:6).eq.'GAPFI') + & .or.(lakon(nelem)(2:6).eq.'GAPII')) then + if((node1.ne.0).and.(node2.ne.0)) then + A=prop(ielprop(nelem)+1) + pt1=v(2,node1) + pt2=v(2,node2) +! + if(pt1.ge.pt2)then + if(dabs(tg2/ts2-(1+0.5*(kappa-1)/kappa)).lt.1E-5) then + pt2=dabs(xflow)*dsqrt(Tg2*R)/A + & *(1+0.5*(kappa-1)/kappa) + & **(0.5*(kappa+1)/(kappa-1)) +! + endif + tg1=v(0,node1) + ts1=v(3,node1) + call ts_calc(xflow,Tg1,Pt1,kappa,r,a,Ts1,icase) + call ts_calc(xflow,Tg2,Pt2,kappa,r,a,Ts2,icase) + v(3,node1)=ts1 + v(3,node2)=ts2 + else + pt1=v(2,node2) + pt2=v(2,node1) +c next line has consequences in gaspipe.f +c if(v(3,nodem).ge.(pt2/pt1))then +c pt2=v(3,nodem)*pt1 + if(v(2,nodem).ge.(pt2/pt1))then + pt2=v(2,nodem)*pt1 + endif +! + tg1=v(0,node2) + call ts_calc(xflow,Tg1,Pt1,kappa,r,a,Ts1,icase) + tg2=v(0,node1) + call ts_calc(xflow,Tg2,Pt2,kappa,r,a,Ts2,icase) + endif +! +c dt1=tg1/ts1-1d0 +c dt2=tg2/ts2-1d0 +c xcst=2.d0*Cp*A**2/(R**2) +c expon=2.d0*kappa/(kappa-1.d0) +c xk1=pt1**2*(ts1/tg1)**expon +c xk2=pt2**2*(ts2/tg2)**expon +c! +c xnum1=xcst*dt1*xk1-xflow**2*ts1 +c xdenom1=xcst*xk1*(1.d0-expon*dt1)/ts1+2.d0*xflow**2 +c xnum2=xcst*dt2*xk2-xflow**2*ts2 +c xdenom2=xcst*xk2*(1.d0-expon*dt2)/ts2+2.d0*xflow**2 +! + endif + endif +! + if(node1.ne.0) then +! +! energy equation contribution node1 +! + if (nacteq(0,node1).ne.0) then + ieq=nacteq(0,node1) +! + if(nacteq(3,node1).eq.0) then + if (xflow.lt.0d0)then + bc(ieq)=bc(ieq)+cp*(tg1-tg2)*xflow + endif +! + elseif((lakon(nelem)(2:6).eq.'GAPFI') + & .or.(lakon(nelem)(2:6).eq.'GAPII')) then + if((nacteq(3,node1).eq.node2)) then +! +c bc(ieq)=(ts2+xnum2/xdenom2-ts1-xnum1/xdenom1) + bc(ieq)=(ts2-ts1) +! + endif + endif + endif +! +! mass equation contribution node1 +! + if (nacteq(1,node1).ne.0) then + ieq=nacteq(1,node1) + bc(ieq)=bc(ieq)-xflow + endif + endif +! + if(node2.ne.0) then +! +! energy equation contribution node2 +! + if (nacteq(0,node2).ne.0) then + ieq=nacteq(0,node2) +! + if(nacteq(3,node2).eq.0) then + if (xflow.gt.0d0)then + bc(ieq)=bc(ieq)-cp*(tg2-tg1)*xflow + endif +! + elseif((lakon(nelem)(2:6).eq.'GAPFI') + & .or. (lakon(nelem)(2:6).eq.'GAPII')) then + if(nacteq(3,node2).eq.node1) then +! +c bc(ieq)=(ts2+xnum2/xdenom2-ts1-xnum1/xdenom1) + bc(ieq)=(ts2-ts1) +! + endif + endif + endif +! +! mass equation contribution node2 +! + if (nacteq(1,node2).ne.0) then + ieq=nacteq(1,node2) + bc(ieq)=bc(ieq)+xflow + endif + endif +! +! element equation +! + if (nacteq(2,nodem).ne.0) then + ieq=nacteq (2,nodem) +! +! for liquids: determine the gravity vector +! + if(lakon(nelem)(2:3).eq.'LI') then + do j=1,3 + g(j)=0.d0 + enddo + if(nbody.gt.0) then + index=nelem + do + j=ipobody(1,index) + if(j.eq.0) exit + if(ibody(1,j).eq.2) then + g(1)=g(1)+xbodyact(1,j)*xbodyact(2,j) + g(2)=g(2)+xbodyact(1,j)*xbodyact(3,j) + g(3)=g(3)+xbodyact(1,j)*xbodyact(4,j) + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif + endif +! + call flux(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity, + & ielprop,prop,kflag,v,xflow,f,nodef,idirf,df, + & cp,r,rho,physcon,g,co,dvi,numf,vold,set,shcon, + & nshcon,rhcon,nrhcon,ntmat_,mi) + bc(ieq)=-f + endif + enddo +! +! convection with the walls: contribution to the energy equations +! + do i=1,nload + if(sideload(i)(3:4).eq.'FC') then + nelem=nelemload(1,i) + lakonl=lakon(nelem) + node=nelemload(2,i) + ieq=nacteq(0,node) + if(ieq.eq.0) then + cycle + endif +! + call nident(itg,node,ntg,id) +! +! calculate the area +! + read(sideload(i)(2:2),'(i1)') ig +! +! number of nodes and integration points in the face +! + if(lakonl(4:4).eq.'2') then + nope=20 + nopes=8 + elseif(lakonl(4:4).eq.'8') then + nope=8 + nopes=4 + elseif(lakonl(4:5).eq.'10') then + nope=10 + nopes=6 + elseif(lakonl(4:4).eq.'4') then + nope=4 + nopes=3 + elseif(lakonl(4:5).eq.'15') then + nope=15 + else + nope=6 + endif +! + if(lakonl(4:5).eq.'8R') then + mint2d=1 + elseif((lakonl(4:4).eq.'8').or.(lakonl(4:6).eq.'20R')) + & then + if(lakonl(7:7).eq.'A') then + mint2d=2 + else + mint2d=4 + endif + elseif(lakonl(4:4).eq.'2') then + mint2d=9 + elseif(lakonl(4:5).eq.'10') then + mint2d=3 + elseif(lakonl(4:4).eq.'4') then + mint2d=1 + endif +! + if(lakonl(4:4).eq.'6') then + mint2d=1 + if(ig.le.2) then + nopes=3 + else + nopes=4 + endif + endif + if(lakonl(4:5).eq.'15') then + if(ig.le.2) then + mint2d=3 + nopes=6 + else + mint2d=4 + nopes=8 + endif + endif +! +! connectivity of the element +! + index=ipkon(nelem) + if(index.lt.0) then + write(*,*) '*ERROR in resultnet: element ',nelem + write(*,*) ' is not defined' + stop + endif + do k=1,nope + konl(k)=kon(index+k) + enddo +! +! coordinates of the nodes belonging to the face +! + if((nope.eq.20).or.(nope.eq.8)) then + do k=1,nopes + tl2(k)=v(0,konl(ifaceq(k,ig))) + do j=1,3 + xl2(j,k)=co(j,konl(ifaceq(k,ig)))+ + & v(j,konl(ifaceq(k,ig))) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + do k=1,nopes + tl2(k)=v(0,konl(ifacet(k,ig))) + do j=1,3 + xl2(j,k)=co(j,konl(ifacet(k,ig)))+ + & v(j,konl(ifacet(k,ig))) + enddo + enddo + else + do k=1,nopes + tl2(k)=v(0,konl(ifacew(k,ig))) + do j=1,3 + xl2(j,k)=co(j,konl(ifacew(k,ig)))+ + & v(j,konl(ifacew(k,ig))) + enddo + enddo + endif +! +! integration to obtain the area and the mean +! temperature +! + do l=1,mint2d + if((lakonl(4:5).eq.'8R').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.4))) then + xi=gauss2d1(1,l) + et=gauss2d1(2,l) + weight=weight2d1(l) + elseif((lakonl(4:4).eq.'8').or. + & (lakonl(4:6).eq.'20R').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.8))) then + xi=gauss2d2(1,l) + et=gauss2d2(2,l) + weight=weight2d2(l) + elseif(lakonl(4:4).eq.'2') then + xi=gauss2d3(1,l) + et=gauss2d3(2,l) + weight=weight2d3(l) + elseif((lakonl(4:5).eq.'10').or. + & ((lakonl(4:5).eq.'15').and.(nopes.eq.6))) then + xi=gauss2d5(1,l) + et=gauss2d5(2,l) + weight=weight2d5(l) + elseif((lakonl(4:4).eq.'4').or. + & ((lakonl(4:4).eq.'6').and.(nopes.eq.3))) then + xi=gauss2d4(1,l) + et=gauss2d4(2,l) + weight=weight2d4(l) + endif +! + if(nopes.eq.8) then + call shape8q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.4) then + call shape4q(xi,et,xl2,xsj2,xs2,shp2,iflag) + elseif(nopes.eq.6) then + call shape6tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,xl2,xsj2,xs2,shp2,iflag) + endif +! + dxsj2=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+ + & xsj2(3)*xsj2(3)) + areaj=dxsj2*weight +! + temp=0.d0 + do k=1,3 + coords(k)=0.d0 + enddo + do j=1,nopes + temp=temp+tl2(j)*shp2(4,j) + do k=1,3 + coords(k)=coords(k)+xl2(k,j)*shp2(4,j) + enddo + enddo +! + sinktemp=v(0,node) + if(sideload(i)(5:6).ne.'NU') then + h(1)=xloadact(1,i) + else + read(sideload(i)(2:2),'(i1)') jltyp + jltyp=jltyp+10 + call film(h,sinktemp,temp,istep, + & iinc,tvar,nelem,l,coords,jltyp,field,nfield, + & sideload(i),node,areaj,v,mi) + if(nmethod.eq.1) h(1)=xloadold(1,i)+ + & (h(1)-xloadold(1,i))*reltime + endif + if(lakonl(5:7).eq.'0RA') then + bc(ieq)=bc(ieq)+ + & 2.d0*(temp-sinktemp)*h(1)*dxsj2*weight + else + bc(ieq)=bc(ieq)+ + & (temp-sinktemp)*h(1)*dxsj2*weight + endif + enddo + endif + enddo +! +! prescribed heat generation: contribution the energy equations +! + do i=1,ntg + node=itg(i) + idof=8*(node-1) + call nident(ikforc,idof,nforc,id) + if(id.gt.0) then + if(ikforc(id).eq.idof) then + ieq=nacteq(0,node) + if(ieq.ne.0) bc(ieq)=bc(ieq)+xforcact(ilforc(id)) + cycle + endif + endif + enddo +! +! in the case of forced vortices, when temperature change +! is required, additional heat input is added in the energy +! equation for the downstream node +! + do i=1,nflow + nelem=ieg(i) + if(lakon(nelem)(2:3).ne.'VO') cycle +! +! free vortex and no temperature change +! + if((lakon(nelem)(2:5).eq.'VOFR').and. + & (prop(ielprop(nelem)+8).eq.0)) cycle +! +! free vortex and temperature change in the absolute system +! + if((lakon(nelem)(2:5).eq.'VOFR').and. + & (prop(ielprop(nelem)+8).eq.1)) cycle +! +! forced vortex and no temperature change +! + if((lakon(nelem)(2:5).eq.'VOFO').and. + & (prop(ielprop(nelem)+6).eq.0)) cycle +! + nodem=kon(ipkon(nelem)+2) + xflow=v(1,nodem) + if(xflow.gt.0d0) then + node1=kon(ipkon(nelem)+1) + node2=kon(ipkon(nelem)+3) + else + node1=kon(ipkon(nelem)+1) + node2=kon(ipkon(nelem)+3) + endif +! + if(xflow.gt.0d0) then + R1=prop(ielprop(nelem)+2) + R2=prop(ielprop(nelem)+1) + if(R1.gt.R2) then + Rout=R2 + Rin=R1 + else + Rout=R2 + Rin=R1 + endif + else + R1=prop(ielprop(nelem)+2) + R2=prop(ielprop(nelem)+1) + if(R1.gt.R2) then + Rout=R1 + Rin=R2 + else + Rout=R1 + Rin=R2 + endif + endif +! +! computing temperature corrected Cp=Cp(T) coefficient +! + Tg1=v(0,node1) + Tg2=v(0,node2) + if((lakon(nelem)(2:3).ne.'LP').and. + & (lakon(nelem)(2:3).ne.'LI')) then + gastemp=(tg1+tg2)/2.d0 + else + if(xflow.gt.0) then + gastemp=tg1 + else + gastemp=tg2 + endif + endif +! + imat=ielmat(nelem) + call materialdata_tg(imat,ntmat_,gastemp, + & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho) +! + call cp_corrected(cp,Tg1,Tg2,cp_cor) +! + Uout=Pi/30*prop(ielprop(nelem)+5)*Rout + Uin=Pi/30*prop(ielprop(nelem)+5)*Rin +! +! free and forced vortices with temperature +! change in the relative system of coordinates +! + if((lakon(nelem)(2:5).eq.'VOFR') .and. + & (prop(ielprop(nelem)+8).eq.(-1))) then +! + Uout=Pi/30*prop(ielprop(nelem)+7)*Rout + Uin=Pi/30*prop(ielprop(nelem)+7)*Rin +! + heat=0.5d0*Cp/Cp_cor*(Uout**2-Uin**2)*xflow +! + elseif (((lakon(nelem)(2:5).eq.'VOFO') + & .and.(prop(ielprop(nelem)+6).eq.(-1)))) then +! + Uout=Pi/30*prop(ielprop(nelem)+5)*Rout + Uin=Pi/30*prop(ielprop(nelem)+5)*Rin +! + heat=0.5d0*Cp/Cp_cor*(Uout**2-Uin**2)*xflow +! +! forced vortices with temperature change in the absolute system +! + elseif((lakon(nelem)(2:5).eq.'VOFO') + & .and.((prop(ielprop(nelem)+6).eq.1))) then +! + heat=Cp/Cp_cor*(Uout**2-Uin**2)*xflow +! + endif +! +! including the resulting additional heat flux in the energy equation +! + if(xflow.gt.0d0)then + ieq=nacteq(0,node2) + if(ieq.ne.0) bc(ieq)=bc(ieq)+heat + else + ieq=nacteq(0,node1) + if(ieq.ne.0) bc(ieq)=bc(ieq)+heat + endif + enddo +! +! transfer element ABSOLUTE TO RELATIVE / RELATIVE TO ABSOLUTE +! + do i= 1, nflow + nelem=ieg(i) +! + if((lakon(nelem)(2:4).eq.'ATR').or. + & (lakon(nelem)(2:4).eq.'RTA')) then +! + nodem=kon(ipkon(nelem)+2) + xflow=v(1,nodem) + if(xflow.gt.0d0) then + node1=kon(ipkon(nelem)+1) + node2=kon(ipkon(nelem)+3) + else + node1=kon(ipkon(nelem)+1) + node2=kon(ipkon(nelem)+3) + endif +! +! computing temperature corrected Cp=Cp(T) coefficient +! + Tg1=v(0,node1) + Tg2=v(0,node2) +c gastemp=(Tg1+Tg2)/2.d0 + if((lakon(nelem)(2:3).ne.'LP').and. + & (lakon(nelem)(2:3).ne.'LI')) then + gastemp=(tg1+tg2)/2.d0 + else + if(xflow.gt.0) then + gastemp=tg1 + else + gastemp=tg2 + endif + endif +! + imat=ielmat(nelem) + call materialdata_tg(imat,ntmat_,gastemp, + & shcon,nshcon,cp,r,dvi,rhcon,nrhcon,rho) +! + call cp_corrected(cp,Tg1,Tg2,cp_cor) +! + index=ielprop(nelem) + U=prop(index+1) + ct=prop(index+2) +! + if(ct.eq.0) then + nelemswirl=prop(index+3) + index2=ielprop(nelemswirl) +! +! previous element is a preswirl nozzle +! + if(lakon(nelemswirl)(2:5).eq.'ORPN') then + ct=prop(index2+4) +! +! previous element is a forced vortex +! + elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then + ct=prop(index2+7) +! +! previous element is a free vortex +! + elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then + ct=prop(index2+9) + endif + endif +! + if(lakon(nelem)(2:4).eq.'ATR') then + heat=Cp/Cp_cor*(0.5d0*(U**2-2d0*U*Ct)*xflow) +! + elseif(lakon(nelem)(2:4).eq.'RTA') then + heat=Cp/Cp_cor*(-0.5d0*(U**2-2d0*U*Ct)*xflow) + endif +! +! including the resulting additional heat flux in the energy equation +! + if(xflow.gt.0d0)then +c ieq=nacteq(0,node2) + ieq=nacteq(0,node2) + if(ieq.ne.0) bc(ieq)=bc(ieq)+heat + else + ieq=nacteq(0,node1) +c if(nacteq(0,node1).ne.0)then + if(ieq.ne.0) bc(ieq)=bc(ieq)+heat + endif + endif + enddo +! +! in the case of generalized pipes if rotation occurs +! the outlet node temperature will change +! + do i=1,nflow + nelem=ieg(i) +! + if(lakon(nelem)(2:5).eq.'GAPI') then + index=ielprop(nelem) + if((prop(index+8).ne.0).and. + & (prop(index+9).ne.0).and. + & (prop(index+8).ne.0)) then +! + nodem=kon(ipkon(nelem)+2) + xflow=v(1,nodem) + if(xflow.gt.0d0) then + node1=kon(ipkon(nelem)+1) + node2=kon(ipkon(nelem)+3) + else + node1=kon(ipkon(nelem)+1) + node2=kon(ipkon(nelem)+3) + endif + omega=pi/30d0*prop(index+10) + write(*,*) 'icase',icase + rin=prop(index+8) + rout=prop(index+9) + heat=0.5*omega**2*(rout**2-rin**2)*xflow +! +! influence on the temperature of node 2 +! + if(xflow.gt.0d0)then + ieq=nacteq(0,node2) +c if(nacteq(0,node2).ne.0)then + if(ieq.ne.0) bc(ieq)=bc(ieq)+heat + else + ieq=nacteq(0,node1) +c if(nacteq(0,node1).ne.0)then + if(ieq.ne.0) bc(ieq)=bc(ieq)+heat + endif + endif + endif + enddo +! +! additional multiple point constraints +! + j=nteq+1 + do i=nmpc,1,-1 + if(labmpc(i)(1:7).ne.'NETWORK') cycle + j=j-1 + index=ipompc(i) +! + do + node=nodempc(1,index) + idir=nodempc(2,index) + bc(j)=bc(j)-v(idir,node)*coefmpc(index) + index=nodempc(3,index) + if(index.eq.0) exit + enddo + enddo +! +c write(30,*) 'bc in resultgas' +c do i=1,9 +c write(30,'(1x,e11.4)') bc(i) +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/results.f calculix-ccx-2.3/ccx_2.3/src/results.f --- calculix-ccx-2.1/ccx_2.3/src/results.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/results.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1827 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine results(co,nk,kon,ipkon,lakon,ne,v,stn,inum, + & stx,elcon,nelcon,rhcon,nrhcon,alcon,nalcon,alzero, + & ielmat,ielorien,norien,orab,ntmat_,t0,t1,ithermal,prestr, + & iprestr,filab,eme,een,iperturb,f,fn, + & nactdof,iout,qa,vold,b,nodeboun,ndirboun, + & xboun,nboun,ipompc,nodempc,coefmpc,labmpc,nmpc,nmethod,cam,neq, + & veold,accold,bet,gam,dtime,time,ttime,plicon,nplicon,plkcon, + & nplkcon, + & xstateini,xstiff,xstate,npmat_,epn,matname,mi,ielas,icmd, + & ncmat_,nstate_,stiini,vini,ikboun,ilboun,ener,enern,sti, + & xstaten,eei,enerini,cocon,ncocon,set,nset,istartset,iendset, + & ialset,nprint,prlab,prset,qfx,qfn,trab,inotr,ntrans,fmpc, + & nelemload,nload,ikmpc,ilmpc,istep,iinc,springarea,reltime) +! +! calculates and prints the displacements, temperatures and forces +! at the nodes and the stress and strain at the reduced integration +! points and at the nodes +! +! iout=-2: v is assumed to be known and is used to +! calculate strains, stresses..., no result output +! corresponds to iout=-1 with in addition the +! calculation of the internal energy density +! iout=-1: v is assumed to be known and is used to +! calculate strains, stresses..., no result output; +! is used to take changes in SPC's and MPC's at the +! start of a new increment or iteration into account +! iout=0: v is calculated from the system solution +! and strains, stresses.. are calculated, no result output +! iout=1: v is calculated from the system solution and strains, +! stresses.. are calculated, requested results output +! iout=2: v is assumed to be known and is used to +! calculate strains, stresses..., requested results output +! + implicit none +! + logical calcul_fn,calcul_f,calcul_cauchy,calcul_qa,cauchy, + & force,intpointvar +! + character*1 cflag + character*6 prlab(*) + character*8 lakon(*),lakonl + character*20 labmpc(*) + character*80 amat,matname(*) + character*81 set(*),prset(*) + character*87 filab(*) +! + integer kon(*),konl(20),inum(*),iperm(20),ikmpc(*),ilmpc(*), + & nelcon(2,*),nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*), + & ntmat_,ipkon(*),mi(2),ne0,cfd, + & nactdof(0:mi(2),*),nodeboun(*),nelemload(2,*), + & ndirboun(*),ipompc(*),nodempc(3,*),ikboun(*),ilboun(*), + & ncocon(2,*),inotr(2,*),iorienglob,iflag,nload,nshcon, + & istep,iinc,mt,nk,ne,mattyp,ithermal(2),iprestr,i,j,k,m1,m2,jj, + & i1,m3,m4,kk,iener,indexe,nope,norien,iperturb(*),iout, + & nal,icmd,ihyper,nboun,nmpc,nmethod,ist,ndir,node,index, + & neq,kode,imat,mint3d,nfield,ndim,iorien,ielas, + & istiff,ncmat_,nstate_,incrementalmpc,jmin,jmax, + & nset,istartset(*),iendset(*),ialset(*),nprint,ntrans,ikin, + & nplicon(0:ntmat_,*),nplkcon(0:ntmat_,*),npmat_ +! + real*8 co(3,*),v(0:mi(2),*),shp(4,20),stiini(6,mi(1),*), + & stx(6,mi(1),*),stn(6,*),xl(3,20),vl(0:mi(2),20),stre(6), + & elcon(0:ncmat_,ntmat_,*),rhcon(0:1,ntmat_,*), + & alcon(0:6,ntmat_,*),vini(0:mi(2),*),qfx(3,mi(1),*),qfn(3,*), + & alzero(*),orab(7,*),elas(21),rho,f(*),fn(0:mi(2),*), + & fnl(3,9),tnl(9),timeend(2),skl(3,3),beta(6),q(0:mi(2),20), + & vkl(0:3,3),cam(5),t0(*),t1(*),prestr(6,mi(1),*),eme(6,mi(1),*), + & een(6,*),ckl(3,3),vold(0:mi(2),*),b(*),xboun(*),coefmpc(*), + & eloc(9),veold(0:mi(2),*),springarea(2,*),accold(0:mi(2),*), + & elconloc(21),eth(6),xkl(3,3),voldl(0:mi(2),20),epn(*), + & xikl(3,3),ener(mi(1),*),enern(*),sti(6,mi(1),*),emec(6), + & eei(6,mi(1),*),enerini(mi(1),*),cocon(0:6,ntmat_,*),emec0(6), + & fmpc(*),shcon,sph,c1,vel(1:3,20),veoldl(0:mi(2),20), + & e,un,al,um,am1,xi,et,ze,tt,exx,eyy,ezz,exy,exz,eyz, + & xsj,qa(3),vj,t0l,t1l,bet,gam,dtime,forcempc,scal1,scal2,bnac, + & fixed_disp,weight,pgauss(3),vij,coconloc(6),qflux(3),time,ttime, + & t1lold,plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), + & xstiff(27,mi(1),*),xstate(nstate_,mi(1),*),plconloc(82), + & vokl(3,3),xstateini(nstate_,mi(1),*),vikl(3,3),trab(7,*), + & xstaten(nstate_,*),gs(8,4),a,reltime +! + include "gauss.f" +! + data iflag /3/ + data iperm /5,6,7,8,1,2,3,4,13,14,15,16,9,10,11,12,17,18,19,20/ +! + mt=mi(2)+1 + intpointvar=.true. +! + if(ithermal(1).le.1) then + jmin=1 + jmax=3 + elseif(ithermal(1).eq.2) then + jmin=0 + jmax=min(mi(2),2) + else + jmin=0 + jmax=3 + endif +! + if((iout.ne.2).and.(iout.gt.-1)) then +! + if((nmethod.ne.4).or.(iperturb(1).le.1)) then + if(ithermal(1).ne.2) then + do i=1,nk + do j=1,3 + if(nactdof(j,i).ne.0) then + bnac=b(nactdof(j,i)) + else + bnac=0.d0 + endif + v(j,i)=v(j,i)+bnac + if((iperturb(1).ne.0).and.(nmethod.eq.1)) then + if(dabs(bnac).gt.cam(1)) then + cam(1)=dabs(bnac) + cam(4)=nactdof(j,i)-0.5d0 + endif + endif + enddo + enddo + endif + if(ithermal(1).gt.1) then + do i=1,nk + if(nactdof(0,i).ne.0) then + bnac=b(nactdof(0,i)) + else + bnac=0.d0 + endif + v(0,i)=v(0,i)+bnac + if((iperturb(1).ne.0).and.(nmethod.eq.1)) then + if(dabs(bnac).gt.cam(2)) then + cam(2)=dabs(bnac) + cam(5)=nactdof(0,i)-0.5d0 + endif + endif + enddo + endif +! + else +! +! direct integration dynamic step +! b contains the acceleration increment +! + if(ithermal(1).ne.2) then + scal1=bet*dtime*dtime + scal2=gam*dtime + do i=1,nk + do j=1,3 + if(nactdof(j,i).ne.0) then + bnac=b(nactdof(j,i)) + else + bnac=0.d0 + endif + v(j,i)=v(j,i)+scal1*bnac + if(dabs(scal1*bnac).gt.cam(1)) then + cam(1)=dabs(scal1*bnac) + cam(4)=nactdof(j,i)-0.5d0 + endif + veold(j,i)=veold(j,i)+scal2*bnac + accold(j,i)=accold(j,i)+bnac + enddo + enddo + endif + if(ithermal(1).gt.1) then + do i=1,nk + if(nactdof(0,i).ne.0) then + bnac=b(nactdof(0,i)) + else + bnac=0.d0 + endif + v(0,i)=v(0,i)+bnac + if(dabs(bnac).gt.cam(2)) then + cam(2)=dabs(bnac) + cam(5)=nactdof(0,i)-0.5d0 + endif + if(nactdof(0,i).ne.0) then + cam(3)=max(cam(3),dabs(v(0,i)-vini(0,i))) + endif + veold(0,i)=0.d0 + enddo + endif + endif +! + endif +! +! initialization +! + calcul_fn=.false. + calcul_f=.false. + calcul_qa=.false. + calcul_cauchy=.false. +! +! determining which quantities have to be calculated +! + if((iperturb(1).ge.2).or.((iperturb(1).le.0).and.(iout.lt.0))) + & then + if((iout.lt.1).and.(iout.gt.-2)) then + calcul_fn=.true. + calcul_f=.true. + calcul_qa=.true. + elseif((iout.ne.-2).and.(iperturb(2).eq.1)) then + calcul_cauchy=.true. + endif + endif +! + if(iout.gt.0) then + if((filab(5)(1:4).eq.'RF ').or. + & (filab(10)(1:4).eq.'RFL ')) then + calcul_fn=.true. + else + do i=1,nprint + if((prlab(i)(1:4).eq.'RF ').or. + & (prlab(i)(1:4).eq.'RFL ')) then + calcul_fn=.true. + exit + endif + enddo + endif + endif +! +! initializing fn +! + if(calcul_fn) then + do i=1,nk + do j=0,mi(2) + fn(j,i)=0.d0 + enddo + enddo + endif +! +! initializing f +! + if(calcul_f) then + do i=1,neq + f(i)=0.d0 + enddo + endif +! +! SPC's and MPC's have to be taken into account for +! iout=0,1 and -1 +! + if(abs(iout).lt.2) then +! +! inserting the boundary conditions +! + do i=1,nboun + if(ndirboun(i).gt.3) cycle + fixed_disp=xboun(i) + if((nmethod.eq.4).and.(iperturb(1).gt.1)) then + ndir=ndirboun(i) + node=nodeboun(i) + if(ndir.gt.0) then + accold(ndir,node)=(xboun(i)-v(ndir,node))/ + & (bet*dtime*dtime) + veold(ndir,node)=veold(ndir,node)+ + & gam*dtime*accold(ndir,node) + else + veold(ndir,node)=(xboun(i)-v(ndir,node))/dtime + endif + endif + v(ndirboun(i),nodeboun(i))=fixed_disp + enddo +! +! inserting the mpc information +! the parameter incrementalmpc indicates whether the +! incremental displacements enter the mpc or the total +! displacements (incrementalmpc=0) +! +c +c to be checked: should replace the lines underneath do i=1,nmpc +c +c incrementalmpc=iperturb(2) + do i=1,nmpc + if((labmpc(i)(1:20).eq.' ').or. + & (labmpc(i)(1:7).eq.'CONTACT').or. + & (labmpc(i)(1:6).eq.'CYCLIC').or. + & (labmpc(i)(1:9).eq.'SUBCYCLIC')) then + incrementalmpc=0 + else + if((nmethod.eq.2).or.(nmethod.eq.3).or. + & ((iperturb(1).eq.0).and.(nmethod.eq.1))) + & then + incrementalmpc=0 + else + incrementalmpc=1 + endif + endif + ist=ipompc(i) + node=nodempc(1,ist) + ndir=nodempc(2,ist) + if(ndir.eq.0) then + if(ithermal(1).lt.2) cycle + elseif(ndir.gt.3) then + cycle + else + if(ithermal(1).eq.2) cycle + endif + index=nodempc(3,ist) + fixed_disp=0.d0 + if(index.ne.0) then + do + if(incrementalmpc.eq.0) then + fixed_disp=fixed_disp-coefmpc(index)* + & v(nodempc(2,index),nodempc(1,index)) + else + fixed_disp=fixed_disp-coefmpc(index)* + & (v(nodempc(2,index),nodempc(1,index))- + & vold(nodempc(2,index),nodempc(1,index))) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + fixed_disp=fixed_disp/coefmpc(ist) + if(incrementalmpc.eq.1) then + fixed_disp=fixed_disp+vold(ndir,node) + endif + if((nmethod.eq.4).and.(iperturb(1).gt.1)) then + if(ndir.gt.0) then + accold(ndir,node)=(fixed_disp-v(ndir,node))/ + & (bet*dtime*dtime) + veold(ndir,node)=veold(ndir,node)+ + & gam*dtime*accold(ndir,node) + else + veold(ndir,node)=(fixed_disp-v(ndir,node))/dtime + endif + endif + v(ndir,node)=fixed_disp + enddo + endif +! +! check whether there are any strain output requests +! + iener=0 + ikin=0 + if((filab(7)(1:4).eq.'ENER').or.(filab(27)(1:4).eq.'CELS')) then + iener=1 + endif + + do i=1,nprint + if((prlab(i)(1:4).eq.'ENER').or.(prlab(i)(1:4).eq.'ELSE').or. + & (prlab(i)(1:4).eq.'CELS')) then + iener=1 + elseif(prlab(i)(1:4).eq.'ELKE') then + ikin=1 + endif + enddo +! + qa(1)=0.d0 + nal=0 +! +! check whether integration point variables are needed in +! modal dynamics and steady state dynamics calculations +! + if((nmethod.ge.4).and.(iperturb(1).lt.2)) then + intpointvar=.false. + if((filab(3)(1:4).eq.'S ').or. + & (filab(4)(1:4).eq.'E ').or. + & (filab(5)(1:4).eq.'RF ').or. + & (filab(6)(1:4).eq.'PEEQ').or. + & (filab(7)(1:4).eq.'ENER').or. + & (filab(8)(1:4).eq.'SDV ').or. + & (filab(13)(1:4).eq.'ZZS ').or. + & (filab(18)(1:4).eq.'PHS ').or. + & (filab(20)(1:4).eq.'MAXS').or. + & (filab(26)(1:4).eq.'CONT').or. + & (filab(27)(1:4).eq.'CELS')) intpointvar=.true. + do i=1,nprint + if((prlab(i)(1:4).eq.'S ').or. + & (prlab(i)(1:4).eq.'E ').or. + & (prlab(i)(1:4).eq.'PEEQ').or. + & (prlab(i)(1:4).eq.'ENER').or. + & (prlab(i)(1:4).eq.'ELKE').or. + & (prlab(i)(1:4).eq.'CELS').or. + & (prlab(i)(1:4).eq.'SDV ').or. + & (prlab(i)(1:4).eq.'RF ')) then + intpointvar=.true. + exit + endif + enddo + endif +! +! calculation of the stresses in the integration points +! + if(((ithermal(1).le.1).or.(ithermal(1).ge.3)).and. + & (intpointvar)) then +! +c do i=1,nk +c write(*,*) 'results v ',i,(v(j,i),j=1,3) +c enddo +! + ne0=0 + do i=1,ne +! + if(ipkon(i).lt.0) cycle + imat=ielmat(i) + amat=matname(imat) + if(norien.gt.0) then + iorien=ielorien(i) + else + iorien=0 + endif +! + indexe=ipkon(i) +c Bernhardi start + if(lakon(i)(1:5).eq.'C3D8I') then + nope=11 + elseif(lakon(i)(4:4).eq.'2') then +c Bernhardi end + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + elseif(lakon(i)(1:1).eq.'E') then + read(lakon(i)(8:8),'(i1)') nope +! +! local contact spring number +! + if(lakon(i)(7:7).eq.'C') konl(nope+1)=kon(indexe+nope+1) + else + cycle + endif +! + if(lakon(i)(4:5).eq.'8R') then + mint3d=1 + elseif((lakon(i)(4:4).eq.'8').or. + & (lakon(i)(4:6).eq.'20R')) then + mint3d=8 + elseif(lakon(i)(4:4).eq.'2') then + mint3d=27 + elseif(lakon(i)(4:5).eq.'10') then + mint3d=4 + elseif(lakon(i)(4:4).eq.'4') then + mint3d=1 + elseif(lakon(i)(4:5).eq.'15') then + mint3d=9 + elseif(lakon(i)(4:4).eq.'6') then + mint3d=2 + elseif(lakon(i)(1:1).eq.'E') then + mint3d=0 + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + do k=1,3 + xl(k,j)=co(k,konl(j)) + vl(k,j)=v(k,konl(j)) + voldl(k,j)=vold(k,konl(j)) + enddo + enddo +! +! check for hyperelastic material +! + if(nelcon(1,imat).lt.0) then + ihyper=1 + else + ihyper=0 + endif +! +! q contains the nodal forces per element; initialisation of q +! + if((iperturb(1).ge.2).or.((iperturb(1).le.0).and.(iout.lt.1))) + & then + do m1=1,nope + do m2=0,mi(2) + q(m2,m1)=fn(m2,konl(m1)) + enddo + enddo + endif +! +! calculating the forces for the contact elements +! + if(mint3d.eq.0) then +! + lakonl=lakon(i) +! +! "normal" spring and dashpot elements +! + if(lakonl(7:7).eq.'A') then + kode=nelcon(1,imat) + t0l=0.d0 + t1l=0.d0 + if(ithermal(1).eq.1) then + t0l=(t0(konl(1))+t0(konl(2)))/2.d0 + t1l=(t1(konl(1))+t1(konl(2)))/2.d0 + elseif(ithermal(1).ge.2) then + t0l=(t0(konl(1))+t0(konl(2)))/2.d0 + t1l=(vold(0,konl(1))+vold(0,konl(2)))/2.d0 + endif + endif +! +! spring elements (including contact springs) +! + if(lakonl(2:2).eq.'S') then +! +! velocity may be needed for contact springs +! + if(lakonl(7:7).eq.'C') then + do j=1,nope + do k=1,3 + veoldl(k,j)=veold(k,konl(j)) + enddo + enddo +! +! as soon as the first contact element is discovered ne0 is +! determined and saved +! + if(ne0.eq.0) ne0=i-1 + endif + call springforc(xl,konl,vl,imat,elcon,nelcon,elas, + & fnl,ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc, + & plicon,nplicon,npmat_,veoldl,ener(1,i),iener, + & stx(1,1,i),mi,springarea(1,konl(nope+1)),nmethod, + & ne0,iperturb,nstate_,xstateini,xstate,reltime) + do j=1,nope + do k=1,3 + fn(k,konl(j))=fn(k,konl(j))+fnl(k,j) + enddo + enddo +! +! dashpot elements (including contact dashpots) +! + elseif((nmethod.eq.4).or. + & ((nmethod.eq.1).and.(iperturb(1).ge.2))) then + do j=1,nope + konl(j)=kon(indexe+j) + do k=1,3 + vel(k,j)=veold(k,konl(j)) + enddo + enddo + call dashforc(xl,konl,vl,imat,elcon,nelcon, + & elas,fn,ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode, + & elconloc,plicon,nplicon,npmat_,vel,time,nmethod,mi) + endif + elseif(ikin.eq.1) then + do j=1,nope + do k=1,3 + veoldl(k,j)=veold(k,konl(j)) + enddo + enddo + endif +! + do jj=1,mint3d + if(lakon(i)(4:5).eq.'8R') then + xi=gauss3d1(1,jj) + et=gauss3d1(2,jj) + ze=gauss3d1(3,jj) + weight=weight3d1(jj) + elseif((lakon(i)(4:4).eq.'8').or. + & (lakon(i)(4:6).eq.'20R')) + & then + xi=gauss3d2(1,jj) +c if(nope.eq.20) xi=xi+1.d0 + et=gauss3d2(2,jj) + ze=gauss3d2(3,jj) + weight=weight3d2(jj) + elseif(lakon(i)(4:4).eq.'2') then +c xi=gauss3d3(1,jj)+1.d0 + xi=gauss3d3(1,jj) + et=gauss3d3(2,jj) + ze=gauss3d3(3,jj) + weight=weight3d3(jj) + elseif(lakon(i)(4:5).eq.'10') then + xi=gauss3d5(1,jj) + et=gauss3d5(2,jj) + ze=gauss3d5(3,jj) + weight=weight3d5(jj) + elseif(lakon(i)(4:4).eq.'4') then + xi=gauss3d4(1,jj) + et=gauss3d4(2,jj) + ze=gauss3d4(3,jj) + weight=weight3d4(jj) + elseif(lakon(i)(4:5).eq.'15') then + xi=gauss3d8(1,jj) + et=gauss3d8(2,jj) + ze=gauss3d8(3,jj) + weight=weight3d8(jj) + elseif(lakon(i)(4:4).eq.'6') then + xi=gauss3d7(1,jj) + et=gauss3d7(2,jj) + ze=gauss3d7(3,jj) + weight=weight3d7(jj) + endif +! +c Bernhardi start + if(lakon(i)(1:5).eq.'C3D8R') then + call shape8hr(xl,xsj,shp,gs,a) + elseif(lakon(i)(1:5).eq.'C3D8I') then + call shape8hu(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.20) then +c Bernhardi end + if(lakon(i)(7:7).eq.'A') then + call shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) + elseif((lakon(i)(7:7).eq.'E').or. + & (lakon(i)(7:7).eq.'S')) then + call shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) + else + call shape20h(xi,et,ze,xl,xsj,shp,iflag) + endif + elseif(nope.eq.8) then + call shape8h(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.10) then + call shape10tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.4) then + call shape4tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.15) then + call shape15w(xi,et,ze,xl,xsj,shp,iflag) + else + call shape6w(xi,et,ze,xl,xsj,shp,iflag) + endif +! +! vkl(m2,m3) contains the derivative of the m2- +! component of the displacement with respect to +! direction m3 +! + do m2=1,3 + do m3=1,3 + vkl(m2,m3)=0.d0 + enddo + enddo +! + do m1=1,nope + do m2=1,3 + do m3=1,3 + vkl(m2,m3)=vkl(m2,m3)+shp(m3,m1)*vl(m2,m1) + enddo +c write(*,*) 'vnoeie',i,konl(m1),(vkl(m2,k),k=1,3) + enddo + enddo +! +! for frequency analysis or buckling with preload the +! strains are calculated with respect to the deformed +! configuration +! for a linear iteration within a nonlinear increment: +! the tangent matrix is calculated at strain at the end +! of the previous increment +! + if((iperturb(1).eq.1).or.(iperturb(1).eq.-1))then + do m2=1,3 + do m3=1,3 + vokl(m2,m3)=0.d0 + enddo + enddo +! + do m1=1,nope + do m2=1,3 + do m3=1,3 + vokl(m2,m3)=vokl(m2,m3)+ + & shp(m3,m1)*voldl(m2,m1) + enddo + enddo + enddo + endif +! + kode=nelcon(1,imat) +! +! calculating the strain +! +! attention! exy,exz and eyz are engineering strains! +! + exx=vkl(1,1) + eyy=vkl(2,2) + ezz=vkl(3,3) + exy=vkl(1,2)+vkl(2,1) + exz=vkl(1,3)+vkl(3,1) + eyz=vkl(2,3)+vkl(3,2) +! +! for frequency analysis or buckling with preload the +! strains are calculated with respect to the deformed +! configuration +! + if(iperturb(1).eq.1) then + exx=exx+vokl(1,1)*vkl(1,1)+vokl(2,1)*vkl(2,1)+ + & vokl(3,1)*vkl(3,1) + eyy=eyy+vokl(1,2)*vkl(1,2)+vokl(2,2)*vkl(2,2)+ + & vokl(3,2)*vkl(3,2) + ezz=ezz+vokl(1,3)*vkl(1,3)+vokl(2,3)*vkl(2,3)+ + & vokl(3,3)*vkl(3,3) + exy=exy+vokl(1,1)*vkl(1,2)+vokl(1,2)*vkl(1,1)+ + & vokl(2,1)*vkl(2,2)+vokl(2,2)*vkl(2,1)+ + & vokl(3,1)*vkl(3,2)+vokl(3,2)*vkl(3,1) + exz=exz+vokl(1,1)*vkl(1,3)+vokl(1,3)*vkl(1,1)+ + & vokl(2,1)*vkl(2,3)+vokl(2,3)*vkl(2,1)+ + & vokl(3,1)*vkl(3,3)+vokl(3,3)*vkl(3,1) + eyz=eyz+vokl(1,2)*vkl(1,3)+vokl(1,3)*vkl(1,2)+ + & vokl(2,2)*vkl(2,3)+vokl(2,3)*vkl(2,2)+ + & vokl(3,2)*vkl(3,3)+vokl(3,3)*vkl(3,2) + endif +! +c if(iperturb(1).ge.2) then + if(iperturb(2).eq.1) then +! +! Lagrangian strain +! + exx=exx+(vkl(1,1)**2+vkl(2,1)**2+vkl(3,1)**2)/2.d0 + eyy=eyy+(vkl(1,2)**2+vkl(2,2)**2+vkl(3,2)**2)/2.d0 + ezz=ezz+(vkl(1,3)**2+vkl(2,3)**2+vkl(3,3)**2)/2.d0 + exy=exy+vkl(1,1)*vkl(1,2)+vkl(2,1)*vkl(2,2)+ + & vkl(3,1)*vkl(3,2) + exz=exz+vkl(1,1)*vkl(1,3)+vkl(2,1)*vkl(2,3)+ + & vkl(3,1)*vkl(3,3) + eyz=eyz+vkl(1,2)*vkl(1,3)+vkl(2,2)*vkl(2,3)+ + & vkl(3,2)*vkl(3,3) +! + endif +! +! storing the local strains +! + if(iperturb(1).ne.-1) then + eloc(1)=exx + eloc(2)=eyy + eloc(3)=ezz + eloc(4)=exy/2.d0 + eloc(5)=exz/2.d0 + eloc(6)=eyz/2.d0 + else +! +! linear iteration within a nonlinear increment: +! + eloc(1)=vokl(1,1)+ + & (vokl(1,1)**2+vokl(2,1)**2+vokl(3,1)**2)/2.d0 + eloc(2)=vokl(2,2)+ + & (vokl(1,2)**2+vokl(2,2)**2+vokl(3,2)**2)/2.d0 + eloc(3)=vokl(3,3)+ + & (vokl(1,3)**2+vokl(2,3)**2+vokl(3,3)**2)/2.d0 + eloc(4)=(vokl(1,2)+vokl(2,1)+vokl(1,1)*vokl(1,2)+ + & vokl(2,1)*vokl(2,2)+vokl(3,1)*vokl(3,2))/2.d0 + eloc(5)=(vokl(1,3)+vokl(3,1)+vokl(1,1)*vokl(1,3)+ + & vokl(2,1)*vokl(2,3)+vokl(3,1)*vokl(3,3))/2.d0 + eloc(6)=(vokl(2,3)+vokl(3,2)+vokl(1,2)*vokl(1,3)+ + & vokl(2,2)*vokl(2,3)+vokl(3,2)*vokl(3,3))/2.d0 + endif +! +! calculating the deformation gradient (needed to +! convert the element stiffness matrix from spatial +! coordinates to material coordinates +! deformation plasticity) +! + if((kode.eq.-50).or.(kode.le.-100)) then +! +! calculating the deformation gradient +! +c Bernhardi start + xkl(1,1)=vkl(1,1)+1.0d0 + xkl(2,2)=vkl(2,2)+1.0d0 + xkl(3,3)=vkl(3,3)+1.0d0 +c Bernhardi end + xkl(1,2)=vkl(1,2) + xkl(1,3)=vkl(1,3) + xkl(2,3)=vkl(2,3) + xkl(2,1)=vkl(2,1) + xkl(3,1)=vkl(3,1) + xkl(3,2)=vkl(3,2) +! +! calculating the Jacobian +! + vj=xkl(1,1)*(xkl(2,2)*xkl(3,3)-xkl(2,3)*xkl(3,2)) + & -xkl(1,2)*(xkl(2,1)*xkl(3,3)-xkl(2,3)*xkl(3,1)) + & +xkl(1,3)*(xkl(2,1)*xkl(3,2)-xkl(2,2)*xkl(3,1)) +! +! inversion of the deformation gradient (only for +! deformation plasticity) +! + if(kode.eq.-50) then +! + ckl(1,1)=(xkl(2,2)*xkl(3,3)-xkl(2,3)*xkl(3,2))/vj + ckl(2,2)=(xkl(1,1)*xkl(3,3)-xkl(1,3)*xkl(3,1))/vj + ckl(3,3)=(xkl(1,1)*xkl(2,2)-xkl(1,2)*xkl(2,1))/vj + ckl(1,2)=(xkl(1,3)*xkl(3,2)-xkl(1,2)*xkl(3,3))/vj + ckl(1,3)=(xkl(1,2)*xkl(2,3)-xkl(2,2)*xkl(1,3))/vj + ckl(2,3)=(xkl(2,1)*xkl(1,3)-xkl(1,1)*xkl(2,3))/vj + ckl(2,1)=(xkl(3,1)*xkl(2,3)-xkl(2,1)*xkl(3,3))/vj + ckl(3,1)=(xkl(2,1)*xkl(3,2)-xkl(2,2)*xkl(3,1))/vj + ckl(3,2)=(xkl(3,1)*xkl(1,2)-xkl(1,1)*xkl(3,2))/vj +! +! converting the Lagrangian strain into Eulerian +! strain (only for deformation plasticity) +! + cauchy=.false. + call str2mat(eloc,ckl,vj,cauchy) + endif +! + endif +! +! calculating fields for incremental plasticity +! + if(kode.le.-100) then +! +! calculating the deformation gradient at the +! start of the increment +! +! calculating the displacement gradient at the +! start of the increment +! + do m2=1,3 + do m3=1,3 + vikl(m2,m3)=0.d0 + enddo + enddo +! + do m1=1,nope + do m2=1,3 + do m3=1,3 + vikl(m2,m3)=vikl(m2,m3) + & +shp(m3,m1)*vini(m2,konl(m1)) + enddo + enddo + enddo +! +! calculating the deformation gradient of the old +! fields +! + xikl(1,1)=vikl(1,1)+1 + xikl(2,2)=vikl(2,2)+1. + xikl(3,3)=vikl(3,3)+1. + xikl(1,2)=vikl(1,2) + xikl(1,3)=vikl(1,3) + xikl(2,3)=vikl(2,3) + xikl(2,1)=vikl(2,1) + xikl(3,1)=vikl(3,1) + xikl(3,2)=vikl(3,2) +! +! calculating the Jacobian +! + vij=xikl(1,1)*(xikl(2,2)*xikl(3,3) + & -xikl(2,3)*xikl(3,2)) + & -xikl(1,2)*(xikl(2,1)*xikl(3,3) + & -xikl(2,3)*xikl(3,1)) + & +xikl(1,3)*(xikl(2,1)*xikl(3,2) + & -xikl(2,2)*xikl(3,1)) +! +! stresses at the start of the increment +! + do m1=1,6 + stre(m1)=stiini(m1,jj,i) + enddo +! + endif +! +! prestress values +! + if(iprestr.ne.1) then + do kk=1,6 + beta(kk)=0.d0 + enddo + else + do kk=1,6 + beta(kk)=-prestr(kk,jj,i) + enddo + endif +! + if(ithermal(1).ge.1) then +! +! calculating the temperature difference in +! the integration point +! + t0l=0.d0 + t1l=0.d0 + if(ithermal(1).eq.1) then + if(lakon(i)(4:5).eq.'8 ') then + do i1=1,nope + t0l=t0l+t0(konl(i1))/8.d0 + t1l=t1l+t1(konl(i1))/8.d0 + enddo + elseif(lakon(i)(4:6).eq.'20 ') then + call lintemp(t0,t1,konl,nope,jj,t0l,t1l) + else + do i1=1,nope + t0l=t0l+shp(4,i1)*t0(konl(i1)) + t1l=t1l+shp(4,i1)*t1(konl(i1)) + enddo + endif + elseif(ithermal(1).ge.2) then + if(lakon(i)(4:5).eq.'8 ') then + do i1=1,nope + t0l=t0l+t0(konl(i1))/8.d0 + t1l=t1l+vold(0,konl(i1))/8.d0 + enddo + elseif(lakon(i)(4:6).eq.'20 ') then + call lintemp_th(t0,vold,konl,nope,jj,t0l,t1l,mi) + else + do i1=1,nope + t0l=t0l+shp(4,i1)*t0(konl(i1)) + t1l=t1l+shp(4,i1)*vold(0,konl(i1)) + enddo + endif + endif + tt=t1l-t0l + endif +! +! calculating the coordinates of the integration point +! for material orientation purposes (for cylindrical +! coordinate systems) +! + if((iorien.gt.0).or.(kode.le.-100)) then + do j=1,3 + pgauss(j)=0.d0 + do i1=1,nope + pgauss(j)=pgauss(j)+shp(4,i1)*co(j,konl(i1)) + enddo + enddo + endif +! +! material data; for linear elastic materials +! this includes the calculation of the stiffness +! matrix +! + istiff=0 +! + call materialdata_me(elcon,nelcon,rhcon,nrhcon,alcon, + & nalcon,imat,amat,iorien,pgauss,orab,ntmat_, + & elas,rho,i,ithermal,alzero,mattyp,t0l,t1l,ihyper, + & istiff,elconloc,eth,kode,plicon,nplicon, + & plkcon,nplkcon,npmat_,plconloc,mi(1),dtime,i,jj, + & xstiff,ncmat_) +! +! determining the mechanical strain +! + if(ithermal(1).ne.0) then + do m1=1,6 + emec(m1)=eloc(m1)-eth(m1) + emec0(m1)=eme(m1,jj,i) + enddo + else + do m1=1,6 + emec(m1)=eloc(m1) + emec0(m1)=eme(m1,jj,i) + enddo + endif +! +! subtracting the plastic initial strains +! + if(iprestr.eq.2) then + do m1=1,6 + emec(m1)=emec(m1)-prestr(m1,jj,i) + enddo + endif +! +! calculating the local stiffness and stress +! + call mechmodel(elconloc,elas,emec,kode,emec0,ithermal, + & icmd,beta,stre,xkl,ckl,vj,xikl,vij, + & plconloc,xstate,xstateini,ielas, + & amat,t1l,dtime,time,ttime,i,jj,nstate_,mi(1), + & iorien,pgauss,orab,eloc,mattyp,qa(3),istep,iinc, + & ipkon) +! + do m1=1,21 + xstiff(m1,jj,i)=elas(m1) + enddo +! + if(iperturb(1).eq.-1) then +! +! if the forced displacements were changed at +! the start of a nonlinear step, the nodal +! forces due do this displacements are +! calculated in a purely linear way, and +! the first iteration is purely linear in order +! to allow the displacements to redistribute +! in a quasi-static way (only applies to +! quasi-static analyses (*STATIC)) +! + eloc(1)=exx-vokl(1,1) + eloc(2)=eyy-vokl(2,2) + eloc(3)=ezz-vokl(3,3) + eloc(4)=exy-(vokl(1,2)+vokl(2,1)) + eloc(5)=exz-(vokl(1,3)+vokl(3,1)) + eloc(6)=eyz-(vokl(2,3)+vokl(3,2)) +! + if(mattyp.eq.1) then + e=elas(1) + un=elas(2) + um=e/(1.d0+un) + al=un*um/(1.d0-2.d0*un) + um=um/2.d0 + am1=al*(eloc(1)+eloc(2)+eloc(3)) + stre(1)=am1+2.d0*um*eloc(1) + stre(2)=am1+2.d0*um*eloc(2) + stre(3)=am1+2.d0*um*eloc(3) + stre(4)=um*eloc(4) + stre(5)=um*eloc(5) + stre(6)=um*eloc(6) + elseif(mattyp.eq.2) then + stre(1)=eloc(1)*elas(1)+eloc(2)*elas(2) + & +eloc(3)*elas(4) + stre(2)=eloc(1)*elas(2)+eloc(2)*elas(3) + & +eloc(3)*elas(5) + stre(3)=eloc(1)*elas(4)+eloc(2)*elas(5) + & +eloc(3)*elas(6) + stre(4)=eloc(4)*elas(7) + stre(5)=eloc(5)*elas(8) + stre(6)=eloc(6)*elas(9) + elseif(mattyp.eq.3) then + stre(1)=eloc(1)*elas(1)+eloc(2)*elas(2)+ + & eloc(3)*elas(4)+eloc(4)*elas(7)+ + & eloc(5)*elas(11)+eloc(6)*elas(16) + stre(2)=eloc(1)*elas(2)+eloc(2)*elas(3)+ + & eloc(3)*elas(5)+eloc(4)*elas(8)+ + & eloc(5)*elas(12)+eloc(6)*elas(17) + stre(3)=eloc(1)*elas(4)+eloc(2)*elas(5)+ + & eloc(3)*elas(6)+eloc(4)*elas(9)+ + & eloc(5)*elas(13)+eloc(6)*elas(18) + stre(4)=eloc(1)*elas(7)+eloc(2)*elas(8)+ + & eloc(3)*elas(9)+eloc(4)*elas(10)+ + & eloc(5)*elas(14)+eloc(6)*elas(19) + stre(5)=eloc(1)*elas(11)+eloc(2)*elas(12)+ + & eloc(3)*elas(13)+eloc(4)*elas(14)+ + & eloc(5)*elas(15)+eloc(6)*elas(20) + stre(6)=eloc(1)*elas(16)+eloc(2)*elas(17)+ + & eloc(3)*elas(18)+eloc(4)*elas(19)+ + & eloc(5)*elas(20)+eloc(6)*elas(21) + endif + endif +! +! updating the internal energy +! + if((iout.gt.0).or.(iout.eq.-2)) then + if(ithermal(1).eq.0) then + do m1=1,6 + eth(m1)=0.d0 + enddo + endif + if(iener.eq.1) then + ener(jj,i)=enerini(jj,i)+ + & ((eloc(1)-eth(1)-eme(1,jj,i))* + & (stre(1)+stiini(1,jj,i))+ + & (eloc(2)-eth(2)-eme(2,jj,i))* + & (stre(2)+stiini(2,jj,i))+ + & (eloc(3)-eth(3)-eme(3,jj,i))* + & (stre(3)+stiini(3,jj,i)))/2.d0+ + & (eloc(4)-eth(4)-eme(4,jj,i))*(stre(4)+stiini(4,jj,i))+ + & (eloc(5)-eth(5)-eme(5,jj,i))*(stre(5)+stiini(5,jj,i))+ + & (eloc(6)-eth(6)-eme(6,jj,i))*(stre(6)+stiini(6,jj,i)) + + endif +! + eme(1,jj,i)=eloc(1)-eth(1) + eme(2,jj,i)=eloc(2)-eth(2) + eme(3,jj,i)=eloc(3)-eth(3) + eme(4,jj,i)=eloc(4)-eth(4) + eme(5,jj,i)=eloc(5)-eth(5) + eme(6,jj,i)=eloc(6)-eth(6) +! + eei(1,jj,i)=eloc(1) + eei(2,jj,i)=eloc(2) + eei(3,jj,i)=eloc(3) + eei(4,jj,i)=eloc(4) + eei(5,jj,i)=eloc(5) + eei(6,jj,i)=eloc(6) + endif +! +! updating the kinetic energy +! + if(ikin.eq.1) then + + call materialdata_rho(rhcon,nrhcon,imat,rho,t1l, + & ntmat_,ithermal) + do m1=1,3 + vel(m1,1)=0.d0 + do i1= 1,nope + vel(m1,1)=vel(m1,1)+shp(4,i1)*veoldl(m1,i1) + enddo + enddo + ener(jj,i+ne)=rho*(vel(1,1)*vel(1,1)+ + & vel(2,1)*vel(2,1)+ vel(3,1)*vel(3,1))/2.d0 + endif +! + skl(1,1)=stre(1) + skl(2,2)=stre(2) + skl(3,3)=stre(3) + skl(2,1)=stre(4) + skl(3,1)=stre(5) + skl(3,2)=stre(6) +! + stx(1,jj,i)=skl(1,1) + stx(2,jj,i)=skl(2,2) + stx(3,jj,i)=skl(3,3) + stx(4,jj,i)=skl(2,1) + stx(5,jj,i)=skl(3,1) + stx(6,jj,i)=skl(3,2) +! + skl(1,2)=skl(2,1) + skl(1,3)=skl(3,1) + skl(2,3)=skl(3,2) +! +! calculation of the nodal forces +! +c if(iperturb(2).eq.0) then +c do m1=1,3 +c do m2=1,3 +c vkl(m1,m2)=0.d0 +c enddo +c enddo +c endif +! + if(calcul_fn)then +! +! calculating fn using skl +! + do m1=1,nope + do m2=1,3 +! +! linear elastic part +! + do m3=1,3 + fn(m2,konl(m1))=fn(m2,konl(m1))+ + & xsj*skl(m2,m3)*shp(m3,m1)*weight + enddo +! +! nonlinear geometric part +! +c if(iperturb(1).ge.2) then + if(iperturb(2).eq.1) then + do m3=1,3 + do m4=1,3 + fn(m2,konl(m1))=fn(m2,konl(m1))+ + & xsj*skl(m4,m3)*weight* + & (vkl(m2,m4)*shp(m3,m1)+ + & vkl(m2,m3)*shp(m4,m1))/2.d0 + enddo + enddo + endif +! + enddo + enddo +c Bernhardi start + if(lakon(i)(1:5).eq.'C3D8R') then + call hgforce (fn,elas,a,gs,vl,mi,konl) + endif +c Bernhardi end + endif +! +! calculation of the Cauchy stresses +! + if(calcul_cauchy) then +! +! changing the displacement gradients into +! deformation gradients +! +c if(kode.ne.-50) then + if((kode.ne.-50).and.(kode.gt.-100)) then +c Bernhardi start + xkl(1,1)=vkl(1,1)+1.0d0 + xkl(2,2)=vkl(2,2)+1.0d0 + xkl(3,3)=vkl(3,3)+1.0d0 +c Bernhardi end + xkl(1,2)=vkl(1,2) + xkl(1,3)=vkl(1,3) + xkl(2,3)=vkl(2,3) + xkl(2,1)=vkl(2,1) + xkl(3,1)=vkl(3,1) + xkl(3,2)=vkl(3,2) +! + vj=xkl(1,1)*(xkl(2,2)*xkl(3,3)-xkl(2,3)*xkl(3,2)) + & -xkl(1,2)*(xkl(2,1)*xkl(3,3)-xkl(2,3)*xkl(3,1)) + & +xkl(1,3)*(xkl(2,1)*xkl(3,2)-xkl(2,2)*xkl(3,1)) + endif +! + do m1=1,3 + do m2=1,m1 + ckl(m1,m2)=0.d0 + do m3=1,3 + do m4=1,3 + ckl(m1,m2)=ckl(m1,m2)+ + & skl(m3,m4)*xkl(m1,m3)*xkl(m2,m4) + enddo + enddo + ckl(m1,m2)=ckl(m1,m2)/vj + enddo + enddo +! + stx(1,jj,i)=ckl(1,1) + stx(2,jj,i)=ckl(2,2) + stx(3,jj,i)=ckl(3,3) + stx(4,jj,i)=ckl(2,1) + stx(5,jj,i)=ckl(3,1) + stx(6,jj,i)=ckl(3,2) + endif +! + enddo +! +! q contains the contributions to the nodal force in the nodes +! belonging to the element at stake from other elements (elements +! already treated). These contributions have to be +! subtracted to get the contributions attributable to the element +! at stake only +! + if(calcul_qa) then + do m1=1,nope + do m2=1,3 + qa(1)=qa(1)+dabs(fn(m2,konl(m1))-q(m2,m1)) + enddo + enddo + nal=nal+3*nope + endif + enddo +! + if(calcul_qa) then + if(nal.gt.0) then + qa(1)=qa(1)/nal + endif + endif +! + endif +! +! calculation of temperatures and thermal flux +! + qa(2)=0.d0 + nal=0 +! +! check whether integration point variables are needed in +! modal dynamics and steady state dynamics calculations +! + if((nmethod.ge.4).and.(iperturb(1).lt.2)) then + intpointvar=.false. + if((filab(9)(1:4).eq.'HFL ').or. + & (filab(10)(1:4).eq.'RFL ')) intpointvar=.true. + do i=1,nprint + if((prlab(i)(1:4).eq.'HFL ').or. + & (prlab(i)(1:4).eq.'RFL ')) intpointvar=.true. + enddo + endif +! + if((ithermal(1).ge.2).and.(intpointvar)) then +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + imat=ielmat(i) + amat=matname(imat) + if(norien.gt.0) then + iorien=ielorien(i) + else + iorien=0 + endif +! + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + elseif(lakon(i)(1:1).eq.'E') then + read(lakon(i)(8:8),'(i1)') nope +! +! local contact spring number +! + if(lakon(i)(7:7).eq.'C') konl(nope+1)=kon(indexe+nope+1) + else + cycle + endif +! + if(lakon(i)(4:5).eq.'8R') then + mint3d=1 + elseif((lakon(i)(4:4).eq.'8').or. + & (lakon(i)(4:6).eq.'20R')) then + if(lakon(i)(6:7).eq.'RA') then + mint3d=4 + else + mint3d=8 + endif + elseif(lakon(i)(4:4).eq.'2') then + mint3d=27 + elseif(lakon(i)(4:5).eq.'10') then + mint3d=4 + elseif(lakon(i)(4:4).eq.'4') then + mint3d=1 + elseif(lakon(i)(4:5).eq.'15') then + mint3d=9 + elseif(lakon(i)(4:4).eq.'6') then + mint3d=2 + elseif(lakon(i)(1:1).eq.'E') then + mint3d=0 + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + do k=1,3 + xl(k,j)=co(k,konl(j)) + enddo + vl(0,j)=v(0,konl(j)) + voldl(0,j)=vold(0,konl(j)) + enddo +! +! q contains the nodal forces per element; initialisation of q +! + if((iperturb(1).ge.2).or.((iperturb(1).le.0).and.(iout.lt.1))) + & then + do m1=1,nope + q(0,m1)=fn(0,konl(m1)) + enddo + endif +! +! calculating the concentrated flux for the contact elements +! + if(mint3d.eq.0) then +! + lakonl=lakon(i) +! +! spring elements (including contact springs) +! + if(lakonl(2:2).eq.'S') then +! +! velocity may be needed for contact springs +! + kode=nelcon(1,imat) + if(kode.eq.-51) then + timeend(1)=time + timeend(2)=ttime+dtime + call springforc_th(xl,vl,imat,elcon,nelcon, + & tnl,ncmat_,ntmat_,nope,kode,elconloc, + & plicon,nplicon,npmat_,mi,springarea(1,konl(nope+1)), + & timeend,matname,konl(nope),i,istep,iinc) + endif +! + do j=1,nope + fn(0,konl(j))=fn(0,konl(j))+tnl(j) + enddo + endif + endif +! + do jj=1,mint3d + if(lakon(i)(4:5).eq.'8R') then + xi=gauss3d1(1,jj) + et=gauss3d1(2,jj) + ze=gauss3d1(3,jj) + weight=weight3d1(jj) + elseif((lakon(i)(4:4).eq.'8').or. + & (lakon(i)(4:6).eq.'20R')) + & then + xi=gauss3d2(1,jj) + et=gauss3d2(2,jj) + ze=gauss3d2(3,jj) + weight=weight3d2(jj) + elseif(lakon(i)(4:4).eq.'2') then + xi=gauss3d3(1,jj) + et=gauss3d3(2,jj) + ze=gauss3d3(3,jj) + weight=weight3d3(jj) + elseif(lakon(i)(4:5).eq.'10') then + xi=gauss3d5(1,jj) + et=gauss3d5(2,jj) + ze=gauss3d5(3,jj) + weight=weight3d5(jj) + elseif(lakon(i)(4:4).eq.'4') then + xi=gauss3d4(1,jj) + et=gauss3d4(2,jj) + ze=gauss3d4(3,jj) + weight=weight3d4(jj) + elseif(lakon(i)(4:5).eq.'15') then + xi=gauss3d8(1,jj) + et=gauss3d8(2,jj) + ze=gauss3d8(3,jj) + weight=weight3d8(jj) + elseif(lakon(i)(4:4).eq.'6') then + xi=gauss3d7(1,jj) + et=gauss3d7(2,jj) + ze=gauss3d7(3,jj) + weight=weight3d7(jj) + endif +! + if(nope.eq.20) then + if(lakon(i)(7:7).eq.'A') then + call shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) + elseif((lakon(i)(7:7).eq.'E').or. + & (lakon(i)(7:7).eq.'S')) then + call shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) + else + call shape20h(xi,et,ze,xl,xsj,shp,iflag) + endif + elseif(nope.eq.8) then + call shape8h(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.10) then + call shape10tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.4) then + call shape4tet(xi,et,ze,xl,xsj,shp,iflag) + elseif(nope.eq.15) then + call shape15w(xi,et,ze,xl,xsj,shp,iflag) + else + call shape6w(xi,et,ze,xl,xsj,shp,iflag) + endif + c1=xsj*weight +! +! vkl(m2,m3) contains the derivative of the m2- +! component of the displacement with respect to +! direction m3 +! + do m3=1,3 + vkl(0,m3)=0.d0 + enddo +! + do m1=1,nope + do m3=1,3 + vkl(0,m3)=vkl(0,m3)+shp(m3,m1)*vl(0,m1) + enddo + enddo +! + kode=ncocon(1,imat) +! +! calculating the temperature difference in +! the integration point +! + t1lold=0.d0 + t1l=0.d0 + if(lakon(i)(4:5).eq.'8 ') then + do i1=1,nope + t1lold=t1lold+vold(0,konl(i1))/8.d0 + t1l=t1l+v(0,konl(i1))/8.d0 + enddo + elseif(lakon(i)(4:6).eq.'20 ') then + call lintemp_th(t0,vold,konl,nope,jj,t0l,t1lold,mi) + call lintemp_th(t0,v,konl,nope,jj,t0l,t1l,mi) + else + do i1=1,nope + t1lold=t1lold+shp(4,i1)*vold(0,konl(i1)) + t1l=t1l+shp(4,i1)*v(0,konl(i1)) + enddo + endif +! +! calculating the coordinates of the integration point +! for material orientation purposes (for cylindrical +! coordinate systems) +! + if((iorien.gt.0).or.(kode.le.-100)) then + do j=1,3 + pgauss(j)=0.d0 + do i1=1,nope + pgauss(j)=pgauss(j)+shp(4,i1)*co(j,konl(i1)) + enddo + enddo + endif +! +! material data; for linear elastic materials +! this includes the calculation of the stiffness +! matrix +! + istiff=0 +! + call materialdata_th(cocon,ncocon,imat,iorien,pgauss,orab, + & ntmat_,coconloc,mattyp,t1l,rhcon,nrhcon,rho,shcon, + & nshcon,sph,xstiff,jj,i,istiff,mi(1)) +! + call thermmodel(amat,i,jj,kode,coconloc,vkl,dtime, + & time,ttime,mi(1),nstate_,xstateini,xstate,qflux,xstiff, + & iorien,pgauss,orab,t1l,t1lold,vold,co,lakon(i),konl, + & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc) +! + qfx(1,jj,i)=qflux(1) + qfx(2,jj,i)=qflux(2) + qfx(3,jj,i)=qflux(3) + if(lakon(i)(6:7).eq.'RA') then + qfx(1,jj+4,i)=qflux(1) + qfx(2,jj+4,i)=qflux(2) + qfx(3,jj+4,i)=qflux(3) + endif +! +! calculation of the nodal flux +! + if(calcul_fn)then +! +! calculating fn using skl +! + if(lakon(i)(6:7).eq.'RA') then + do m1=1,nope + fn(0,konl(m1))=fn(0,konl(m1)) + & -c1*(qflux(1)*(shp(1,m1)+shp(1,iperm(m1))) + & +qflux(2)*(shp(2,m1)+shp(2,iperm(m1))) + & +qflux(3)*(shp(3,m1)+shp(3,iperm(m1)))) + enddo + else + do m1=1,nope + do m3=1,3 + fn(0,konl(m1))=fn(0,konl(m1))- + & c1*qflux(m3)*shp(m3,m1) + enddo + enddo + endif + endif + enddo +! +! q contains the contributions to the nodal force in the nodes +! belonging to the element at stake from other elements (elements +! already treated). These contributions have to be +! subtracted to get the contributions attributable to the element +! at stake only +! + if(calcul_qa) then + do m1=1,nope + qa(2)=qa(2)+dabs(fn(0,konl(m1))-q(0,m1)) + enddo + nal=nal+nope + endif + enddo +! + endif +! + if(calcul_qa) then + if(nal.gt.0) then + qa(2)=qa(2)/nal + endif + endif +! +! subtracting the mpc force (for each linear mpc there is one +! force; the actual force in a node belonging to the mpc is +! obtained by multiplying this force with the nodal coefficient. +! The force has to be subtracted from f, since it does not +! appear on the rhs of the equations system +! + if(calcul_fn)then + do i=1,nmpc + ist=ipompc(i) + node=nodempc(1,ist) + ndir=nodempc(2,ist) + if(ndir.gt.3) cycle + forcempc=fn(ndir,node)/coefmpc(ist) + fmpc(i)=forcempc + fn(ndir,node)=0.d0 + index=nodempc(3,ist) + if(index.eq.0) cycle + do + node=nodempc(1,index) + ndir=nodempc(2,index) + fn(ndir,node)=fn(ndir,node)-coefmpc(index)*forcempc + index=nodempc(3,index) + if(index.eq.0) exit + enddo + enddo + endif +! +! calculating the system force vector +! + if(calcul_f) then + do i=1,nk + do j=0,mi(2) + if(nactdof(j,i).ne.0) then + f(nactdof(j,i))=fn(j,i) + endif + enddo + enddo + endif +! +! adding the mpc force again to fn +! + if(calcul_fn)then + do i=1,nmpc + ist=ipompc(i) + node=nodempc(1,ist) + ndir=nodempc(2,ist) + if(ndir.gt.3) cycle + forcempc=fmpc(i) + fn(ndir,node)=forcempc*coefmpc(ist) + index=nodempc(3,ist) +! +! nodes not belonging to the structure have to be +! taken out +! + if(labmpc(i)(1:7).eq.'MEANROT') then + if(nodempc(3,nodempc(3,index)).eq.0) cycle + elseif(labmpc(i)(1:10).eq.'PRETENSION') then + if(nodempc(3,index).eq.0) cycle + elseif(labmpc(i)(1:5).eq.'RIGID') then + if(nodempc(3,nodempc(3,nodempc(3,nodempc(3,nodempc(3,inde + &x))))).eq.0) cycle + else + if(index.eq.0) cycle + endif + do + node=nodempc(1,index) + ndir=nodempc(2,index) + fn(ndir,node)=fn(ndir,node)+coefmpc(index)*forcempc + index=nodempc(3,index) + if(labmpc(i)(1:7).eq.'MEANROT') then + if(nodempc(3,nodempc(3,index)).eq.0) exit + elseif(labmpc(i)(1:10).eq.'PRETENSION') then + if(nodempc(3,index).eq.0) exit + elseif(labmpc(i)(1:5).eq.'RIGID') then + if(nodempc(3,nodempc(3,nodempc(3,nodempc(3,nodempc(3,i + &ndex))))).eq.0) exit + else + if(index.eq.0) exit + endif + enddo + enddo + endif +! +! no print requests +! + if(iout.le.0) then +! +! 2d basic dof results (displacements, temperature) are +! calculated in each iteration, so that they are available +! in the user subroutines +! + if(filab(1)(5:5).ne.' ') then + nfield=mt + call map3dto1d2d_v(v,ipkon,inum,kon,lakon,nfield,nk, + & ne,nactdof) + endif + return + endif +! +! output in dat file (with *NODE PRINT or *EL PRINT) +! + call printout(set,nset,istartset,iendset,ialset,nprint, + & prlab,prset,v,t1,fn,ipkon,lakon,stx,eei,xstate,ener, + & mi(1),nstate_,ithermal,co,kon,qfx,ttime,trab,inotr,ntrans, + & orab,ielorien,norien,nk,ne,inum,filab,vold,ikin) +! +! interpolation in the original nodes of 1d and 2d elements +! this operation has to be performed in any case since +! the interpolated values may be needed as boundary conditions +! in the next step (e.g. the temperature in a heat transfer +! calculation as boundary condition in a subsequent static +! step) +! + if(filab(1)(5:5).ne.' ') then + nfield=mt + cflag=filab(1)(5:5) + force=.false. + call map3dto1d2d(v,ipkon,inum,kon,lakon,nfield,nk, + & ne,cflag,co,vold,force,mi) + endif +! +! user defined output +! + call uout(v,mi) +! + if((filab(2)(1:4).eq.'NT ').and.(ithermal(1).le.1)) then + if(filab(2)(5:5).eq.'I') then + nfield=1 + cflag=filab(2)(5:5) + force=.false. + call map3dto1d2d(t1,ipkon,inum,kon,lakon,nfield,nk, + & ne,cflag,co,vold,force,mi) + endif + endif +! + cfd=0 +! +! determining the stresses in the nodes for output in frd format +! + if((filab(3)(1:4).eq.'S ').or.(filab(18)(1:4).eq.'PHS ').or. + & (filab(20)(1:4).eq.'MAXS')) then + nfield=6 + ndim=6 + if((norien.gt.0).and.(filab(3)(6:6).eq.'L')) then + iorienglob=1 + else + iorienglob=0 + endif + cflag=filab(3)(5:5) +! + call extrapolate(stx,stn,ipkon,inum,kon,lakon,nfield,nk, + & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, + & nelemload,nload,nodeboun,nboun,ndirboun,vold, + & ithermal,force,cfd) +! + endif +! +! determining the strains in the nodes for output in frd format +! + if((filab(4)(1:4).eq.'E ').or.(filab(30)(1:4).eq.'MAXE')) then + nfield=6 + ndim=6 + if((norien.gt.0).and.(filab(4)(6:6).eq.'L')) then + iorienglob=1 + else + iorienglob=0 + endif + cflag=filab(4)(5:5) + call extrapolate(eei,een,ipkon,inum,kon,lakon,nfield,nk, + & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, + & nelemload,nload,nodeboun,nboun,ndirboun,vold, + & ithermal,force,cfd) + endif +! +! determining the plastic equivalent strain in the nodes +! for output in frd format +! + if(filab(6)(1:4).eq.'PEEQ') then + nfield=1 + ndim=nstate_ + iorienglob=0 + cflag=filab(6)(5:5) + call extrapolate(xstate,epn,ipkon,inum,kon,lakon,nfield,nk, + & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, + & nelemload,nload,nodeboun,nboun,ndirboun,vold, + & ithermal,force,cfd) + endif +! +! determining the total energy in the nodes +! for output in frd format +! + if(filab(7)(1:4).eq.'ENER') then + nfield=1 + ndim=1 + iorienglob=0 + cflag=filab(7)(5:5) + call extrapolate(ener,enern,ipkon,inum,kon,lakon,nfield,nk, + & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, + & nelemload,nload,nodeboun,nboun,ndirboun,vold, + & ithermal,force,cfd) + endif +! +! determining the internal state variables in the nodes +! for output in frd format +! + if(filab(8)(1:4).eq.'SDV ') then + nfield=nstate_ + ndim=nstate_ + if((norien.gt.0).and.(filab(9)(6:6).eq.'L')) then + write(*,*) '*WARNING in results: SDV variables cannot' + write(*,*) ' be stored in a local frame;' + write(*,*) ' the global frame will be used' + endif + iorienglob=0 + cflag=filab(8)(5:5) + call extrapolate(xstate,xstaten,ipkon,inum,kon,lakon,nfield,nk, + & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, + & nelemload,nload,nodeboun,nboun,ndirboun,vold, + & ithermal,force,cfd) + endif +! +! determining the heat flux in the nodes for output in frd format +! + if((filab(9)(1:4).eq.'HFL ').and.(ithermal(1).gt.1)) then + nfield=3 + ndim=3 + if((norien.gt.0).and.(filab(9)(6:6).eq.'L')) then + iorienglob=1 + else + iorienglob=0 + endif + cflag=filab(9)(5:5) + call extrapolate(qfx,qfn,ipkon,inum,kon,lakon,nfield,nk, + & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, + & nelemload,nload,nodeboun,nboun,ndirboun,vold, + & ithermal,force,cfd) + endif +! +! if no element quantities requested in the nodes: calculate +! inum if nodal quantities are requested: used in subroutine frd +! to determine which nodes are active in the model +! + if((filab(1)(5:5).ne.'I').and. + & (filab(3)(1:4).ne.'S ').and.(filab(4)(1:4).ne.'E ').and. + & (filab(6)(1:4).ne.'PEEQ').and.(filab(7)(1:4).ne.'ENER').and. + & (filab(8)(1:4).ne.'SDV ').and.(filab(9)(1:4).ne.'HFL ').and. + & ((nmethod.ne.4).or.(iperturb(1).ge.2))) then +! + nfield=0 + ndim=0 + iorienglob=0 + cflag=filab(1)(5:5) + call createinum(ipkon,inum,kon,lakon,nk,ne,cflag,nelemload, + & nload,nodeboun,nboun,ndirboun,ithermal) + endif +! + if(ithermal(1).gt.1) then +! +! extrapolation for the network +! -interpolation for the total pressure and temperature +! in the middle nodes +! -extrapolation for the mass flow in the end nodes +! + call networkextrapolate(v,ipkon,inum,kon,lakon,ne,mi) +c endif +! +! printing values for environmental film, radiation and +! pressure nodes (these nodes are considered to be network +! nodes) +! + do i=1,nload + node=nelemload(2,i) + if(node.gt.0) then + if(inum(node).gt.0) cycle +c inum(node)=-1 + inum(node)=1 + endif + enddo +! +! printing values of prescribed boundary conditions (these +! nodes are considered to be structural nodes) +! +c if(ithermal(2).gt.1) then + do i=1,nboun + node=nodeboun(i) + if(inum(node).ne.0) cycle + if((cflag.ne.' ').and.(ndirboun(i).eq.3)) cycle + inum(node)=1 + enddo + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/resultsk.f calculix-ccx-2.3/ccx_2.3/src/resultsk.f --- calculix-ccx-2.1/ccx_2.3/src/resultsk.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/resultsk.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,72 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine resultsk(nk,nactdok,vtu,solk,solt,ipompc,nodempc, + & coefmpc,nmpc) +! +! calculates the turbulence correction (STEP 5) in the nodes +! + implicit none +! + integer ipompc(*),nodempc(3,*),nmpc,nk,nactdok(*),i,ist, + & node,ndir,index +! + real*8 coefmpc(*),solk(*),vtu(2,*),fixed_dispk,fixed_dispt, + & solt(*) +! +! extracting the pressure correction from the solution +! + do i=1,nk + if(nactdok(i).ne.0) then + vtu(1,i)=solk(nactdok(i)) + vtu(2,i)=solt(nactdok(i)) + else + vtu(1,i)=0.d0 + vtu(2,i)=0.d0 + endif + enddo +! +! inserting the mpc information: it is assumed that the +! temperature MPC's also apply to the turbulence +! +c do i=1,nmpc +c ist=ipompc(i) +c node=nodempc(1,ist) +c ndir=nodempc(2,ist) +c if(ndir.ne.0) cycle +c index=nodempc(3,ist) +c fixed_dispk=0.d0 +c fixed_dispt=0.d0 +c if(index.ne.0) then +c do +c fixed_dispk=fixed_dispk-coefmpc(index)* +c & vtu(1,nodempc(1,index)) +c fixed_dispt=fixed_dispt-coefmpc(index)* +c & vtu(2,nodempc(1,index)) +c index=nodempc(3,index) +c if(index.eq.0) exit +c enddo +c endif +c fixed_dispk=fixed_dispk/coefmpc(ist) +c vtu(1,node)=fixed_dispk +c fixed_dispt=fixed_dispt/coefmpc(ist) +c vtu(2,node)=fixed_dispt +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/resultsp.f calculix-ccx-2.3/ccx_2.3/src/resultsp.f --- calculix-ccx-2.1/ccx_2.3/src/resultsp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/resultsp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,66 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine resultsp(nk,nactdoh,v,sol,ipompc,nodempc,coefmpc,nmpc, + & mi) +! +! calculates the pressure correction (STEP 2) in the nodes +! + implicit none +! + integer ipompc(*),nodempc(3,*),nmpc,nk,nactdoh(0:4,*),i,ist, + & node,ndir,index,mi(2) +! + real*8 coefmpc(*),sol(*),v(0:mi(2),*),fixed_disp +! +! extracting the pressure correction from the solution +! + do i=1,nk + if(nactdoh(4,i).ne.0) then + v(4,i)=sol(nactdoh(4,i)) +c write(*,*) 'dpressureee ',i,v(4,i) + else + v(4,i)=0.d0 + endif + enddo +c write(*,*) 'sol307',v(4,307) +! +! inserting the mpc information: it is assumed that the +! temperature MPC's also apply to the pressure +! +c do i=1,nmpc +c ist=ipompc(i) +c node=nodempc(1,ist) +c ndir=nodempc(2,ist) +c if(ndir.ne.0) cycle +c index=nodempc(3,ist) +c fixed_disp=0.d0 +c if(index.ne.0) then +c do +c fixed_disp=fixed_disp-coefmpc(index)* +c & v(4,nodempc(1,index)) +c index=nodempc(3,index) +c if(index.eq.0) exit +c enddo +c endif +c fixed_disp=fixed_disp/coefmpc(ist) +c v(4,node)=fixed_disp +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/resultst.f calculix-ccx-2.3/ccx_2.3/src/resultst.f --- calculix-ccx-2.1/ccx_2.3/src/resultst.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/resultst.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,65 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine resultst(nk,nactdoh,v,sol,ipompc,nodempc,coefmpc,nmpc, + & mi) +! +! calculates the energy correction (STEP 4) in the nodes +! + implicit none +! + integer ipompc(*),nodempc(3,*),nmpc,nk,nactdoh(0:4,*),i,j,ist, + & node,ndir,index,mi(2) +! + real*8 coefmpc(*),sol(*),v(0:mi(2),*),fixed_disp +! +! extracting the energy correction from the solution +! + do i=1,nk + if(nactdoh(0,i).ne.0) then + v(0,i)=sol(nactdoh(0,i)) + else + v(0,i)=0.d0 + endif +c write(*,*) 'resultst ',i,nactdoh(0,i),v(0,i) + enddo +c write(*,*) 'sol307',v(0,307) +! +! inserting the mpc information +! +c do i=1,nmpc +c ist=ipompc(i) +c node=nodempc(1,ist) +c ndir=nodempc(2,ist) +c if(ndir.ne.0) cycle +c index=nodempc(3,ist) +c fixed_disp=0.d0 +c if(index.ne.0) then +c do +c fixed_disp=fixed_disp-coefmpc(index)* +c & v(nodempc(2,index),nodempc(1,index)) +c index=nodempc(3,index) +c if(index.eq.0) exit +c enddo +c endif +c fixed_disp=fixed_disp/coefmpc(ist) +c v(ndir,node)=fixed_disp +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/resultsv1.f calculix-ccx-2.3/ccx_2.3/src/resultsv1.f --- calculix-ccx-2.1/ccx_2.3/src/resultsv1.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/resultsv1.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,66 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine resultsv1(nk,nactdoh,v,sol,ipompc,nodempc,coefmpc,nmpc, + & mi) +! +! calculates the velocity correction (STEP 1) in the nodes +! + implicit none +! + integer ipompc(*),nodempc(3,*),nmpc,nk,nactdoh(0:4,*),i,j,ist, + & node,ndir,index,mi(2) +! + real*8 coefmpc(*),sol(*),v(0:mi(2),*),fixed_disp +! +! extracting the 1st velocity correction from the solution (STEP 1) +! + do i=1,nk + do j=1,3 + if(nactdoh(j,i).ne.0) then + v(j,i)=sol(nactdoh(j,i)) + else + v(j,i)=0.d0 + endif + enddo +c write(*,*) 'sollll ',i,(v(j,i),j=1,3) + enddo +c write(*,*) 'sol307',v(1,307),v(2,307),v(3,307) +! +! inserting the mpc information +! +c do i=1,nmpc +c ist=ipompc(i) +c node=nodempc(1,ist) +c ndir=nodempc(2,ist) +c index=nodempc(3,ist) +c fixed_disp=0.d0 +c if(index.ne.0) then +c do +c fixed_disp=fixed_disp-coefmpc(index)* +c & v(nodempc(2,index),nodempc(1,index)) +c index=nodempc(3,index) +c if(index.eq.0) exit +c enddo +c endif +c fixed_disp=fixed_disp/coefmpc(ist) +c v(ndir,node)=fixed_disp +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/resultsv2.f calculix-ccx-2.3/ccx_2.3/src/resultsv2.f --- calculix-ccx-2.1/ccx_2.3/src/resultsv2.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/resultsv2.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,66 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine resultsv2(nk,nactdoh,v,sol,ipompc,nodempc,coefmpc,nmpc, + & mi) +! +! calculates the velocity correction (STEP 3) in the nodes +! + implicit none +! + integer ipompc(*),nodempc(3,*),nmpc,nk,nactdoh(0:4,*),i,j,ist, + & node,ndir,index,mi(2) +! + real*8 coefmpc(*),sol(*),v(0:mi(2),*),fixed_disp +! +! extracting the 2nd velocity correction from the solution (STEP 3) +! + do i=1,nk + do j=1,3 + if(nactdoh(j,i).ne.0) then + v(j,i)=v(j,i)+sol(nactdoh(j,i)) +c else +c v(j,i)=0.d0 + endif + enddo +c write(*,*) 'sollll ',i,(v(j,i),j=1,3) + enddo +c write(*,*) 'sol307',v(1,307),v(2,307),v(3,307) +! +! inserting the mpc information +! +c do i=1,nmpc +c ist=ipompc(i) +c node=nodempc(1,ist) +c ndir=nodempc(2,ist) +c index=nodempc(3,ist) +c fixed_disp=0.d0 +c if(index.ne.0) then +c do +c fixed_disp=fixed_disp-coefmpc(index)* +c & v(nodempc(2,index),nodempc(1,index)) +c index=nodempc(3,index) +c if(index.eq.0) exit +c enddo +c endif +c fixed_disp=fixed_disp/coefmpc(ist) +c v(ndir,node)=fixed_disp +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/rhs.f calculix-ccx-2.3/ccx_2.3/src/rhs.f --- calculix-ccx-2.1/ccx_2.3/src/rhs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rhs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,535 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rhs(co,nk,kon,ipkon,lakon,ne, + & ipompc,nodempc,coefmpc,nmpc,nodeforc,ndirforc,xforc, + & nforc,nelemload,sideload,xload,nload,xbody,ipobody,nbody,cgr, + & fext,nactdof,neq,nmethod, + & ikmpc,ilmpc,elcon,nelcon,rhcon,nrhcon,alcon, + & nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_,t0,t1,ithermal, + & iprestr,vold,iperturb,iexpl,plicon, + & nplicon,plkcon,nplkcon,npmat_,ttime,time,istep,iinc,dtime, + & physcon,ibody,xloadold,reltime,veold,matname,mi,ikactmech, + & nactmech) +! +! filling the right hand side load vector b +! +! b contains the contributions due to mechanical forces only +! + implicit none +! + character*8 lakon(*) + character*20 sideload(*) + character*80 matname(*) +! + integer kon(*),ipompc(*),nodempc(3,*),ipobody(2,*),nbody, + & nodeforc(2,*),ndirforc(*),nelemload(2,*),ikmpc(*),mi(2), + & ilmpc(*),nactdof(0:mi(2),*),konl(20),nelcon(2,*),ibody(3,*), + & nrhcon(*),nalcon(2,*),ielmat(*),ielorien(*),ipkon(*), + & nk,ne,nmpc,nforc,nload,neq,nmethod,nom,m,idm, + & ithermal,iprestr,iperturb,i,j,k,idist,jj, + & id,ist,index,jdof1,jdof,node1,ntmat_,indexe,nope,norien, + & iexpl,idof1,iinc,istep,icalccg,nplicon(0:ntmat_,*), + & nplkcon(0:ntmat_,*),npmat_,ikactmech(*),nactmech +! + real*8 co(3,*),coefmpc(*),xforc(*),xload(2,*),p1(3,2), + & p2(3,2),fext(*),bodyf(3),elcon(0:21,ntmat_,*), + & rhcon(0:1,ntmat_,*),xloadold(2,*),reltime, + & alcon(0:6,ntmat_,*),alzero(*),orab(7,*),xbody(7,*),cgr(4,*), + & t0(*),t1(*),vold(0:mi(2),*),ff(60),time,ttime,dtime, + & plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*), + & om(2),physcon(*),veold(0:mi(2),*) +! + icalccg=0 +! + if((nmethod.ge.4).and.(iperturb.lt.2).and.(nactmech.lt.neq/2))then +! +! modal dynamics and steady state dynamics: +! only nonzeros are reset to zero +! + do i=1,nactmech + fext(ikactmech(i)+1)=0.d0 + enddo + else + do i=1,neq + fext(i)=0.d0 + enddo + endif + nactmech=0 +! +! distributed forces (body forces or thermal loads or +! residual stresses or distributed face loads) +! +c if((nbody.ne.0).or.(ithermal.ne.0).or. +c & (iprestr.ne.0).or.(nload.ne.0)) then + if((nbody.ne.0).or.(nload.ne.0)) then + idist=1 + else + idist=0 + endif +! +c if((ithermal.le.1).or.(ithermal.eq.3)) then + if(((ithermal.le.1).or.(ithermal.eq.3)).and.(idist.ne.0)) then +! +! mechanical analysis: loop over all elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! +! assigning centrifugal forces +! + if(nbody.gt.0) then + nom=0 + om(1)=0.d0 + om(2)=0.d0 + bodyf(1)=0.d0 + bodyf(2)=0.d0 + bodyf(3)=0.d0 +! + index=i + do + j=ipobody(1,index) + if(j.eq.0) exit + if(ibody(1,j).eq.1) then + nom=nom+1 + if(nom.gt.2) then + write(*,*)'*ERROR in rhs: no more than two centri-' + write(*,*)' fugal loading cards allowed' + stop + endif + om(nom)=xbody(1,j) + p1(1,nom)=xbody(2,j) + p1(2,nom)=xbody(3,j) + p1(3,nom)=xbody(4,j) + p2(1,nom)=xbody(5,j) + p2(2,nom)=xbody(6,j) + p2(3,nom)=xbody(7,j) +! +! assigning gravity forces +! + elseif(ibody(1,j).eq.2) then + bodyf(1)=bodyf(1)+xbody(1,j)*xbody(2,j) + bodyf(2)=bodyf(2)+xbody(1,j)*xbody(3,j) + bodyf(3)=bodyf(3)+xbody(1,j)*xbody(4,j) +! +! assigning newton gravity forces +! + elseif(ibody(1,j).eq.3) then + call newton(icalccg,ne,ipkon,lakon,kon,t0,co,rhcon, + & nrhcon,ntmat_,physcon,i,cgr,bodyf,ielmat,ithermal, + & vold) + endif + index=ipobody(2,index) + if(index.eq.0) exit + enddo + endif +! + if(idist.ne.0) + & call e_c3d_rhs(co,nk,konl,lakon(i),p1,p2,om,bodyf,nbody, + & ff,i,nmethod,rhcon,ielmat,ntmat_,vold,iperturb, + & nelemload,sideload,xload,nload,idist,ttime,time,istep, + & iinc,dtime,xloadold,reltime,ipompc,nodempc,coefmpc,nmpc, + & ikmpc,ilmpc,veold,matname,mi) +! +! modal dynamics and steady state dynamics: +! location of nonzeros is stored +! + if((nmethod.ge.4).and.(iperturb.lt.2)) then + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdof(k,node1) +! +! distributed forces +! + if(idist.ne.0) then + if(dabs(ff(jj)).lt.1.d-30) cycle + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8+k + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + do + jdof1=nactdof(nodempc(2,index), + & nodempc(1,index)) + if(jdof1.ne.0) then + fext(jdof1)=fext(jdof1) + & -coefmpc(index)*ff(jj)/coefmpc(ist) + call nident(ikactmech,jdof1-1,nactmech, + & idm) + do + if(idm.gt.0) then + if(ikactmech(idm).eq.jdof1-1) exit + endif + nactmech=nactmech+1 + do m=nactmech,idm+2,-1 + ikactmech(m)=ikactmech(m-1) + enddo + ikactmech(idm+1)=jdof1-1 + exit + enddo + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + fext(jdof1)=fext(jdof1)+ff(jj) + call nident(ikactmech,jdof1-1,nactmech, + & idm) + do + if(idm.gt.0) then + if(ikactmech(idm).eq.jdof1-1) exit + endif + nactmech=nactmech+1 + do m=nactmech,idm+2,-1 + ikactmech(m)=ikactmech(m-1) + enddo + ikactmech(idm+1)=jdof1-1 + exit + enddo + endif +! + enddo +! +! other procedures +! + else + do jj=1,3*nope +! + j=(jj-1)/3+1 + k=jj-3*(j-1) +! + node1=kon(indexe+j) + jdof1=nactdof(k,node1) +! +! distributed forces +! + if(idist.ne.0) then + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8+k + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + do + jdof1=nactdof(nodempc(2,index), + & nodempc(1,index)) + if(jdof1.ne.0) then + fext(jdof1)=fext(jdof1) + & -coefmpc(index)*ff(jj)/coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + fext(jdof1)=fext(jdof1)+ff(jj) + endif +! + enddo + endif + enddo +! +c else + elseif((ithermal.eq.2).and.(nload.gt.0)) then +! +! thermal analysis: loop over all elements +! + do i=1,ne +! + if(ipkon(i).lt.0) cycle + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + else + cycle + endif +! + do j=1,nope + konl(j)=kon(indexe+j) + enddo +! + if(nload.gt.0) + & call e_c3d_rhs_th(co,nk,konl,lakon(i), + & ff,i,nmethod,t0,t1,vold,nelemload, + & sideload,xload,nload,idist,dtime, + & ttime,time,istep,iinc,xloadold,reltime, + & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,mi) +! +! modal dynamics and steady state dynamics: +! location of nonzeros is stored +! + if((nmethod.ge.4.and.(iperturb.lt.2))) then + do jj=1,nope +! + j=jj +! + node1=kon(indexe+j) + jdof1=nactdof(0,node1) +! +! distributed forces +! + if(idist.ne.0) then + if(dabs(ff(jj)).lt.1.d-30) cycle + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8 + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + do + jdof1=nactdof(nodempc(2,index), + & nodempc(1,index)) + if(jdof1.ne.0) then + fext(jdof1)=fext(jdof1) + & -coefmpc(index)*ff(jj)/coefmpc(ist) + call nident(ikactmech,jdof1-1,nactmech, + & idm) + do + if(idm.gt.0) then + if(ikactmech(idm).eq.jdof1-1) exit + endif + nactmech=nactmech+1 + do m=nactmech,idm+2,-1 + ikactmech(m)=ikactmech(m-1) + enddo + ikactmech(idm+1)=jdof1-1 + exit + enddo + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + fext(jdof1)=fext(jdof1)+ff(jj) + call nident(ikactmech,jdof1-1,nactmech, + & idm) + do + if(idm.gt.0) then + if(ikactmech(idm).eq.jdof1-1) exit + endif + nactmech=nactmech+1 + do m=nactmech,idm+2,-1 + ikactmech(m)=ikactmech(m-1) + enddo + ikactmech(idm+1)=jdof1-1 + exit + enddo + endif +! + enddo +! +! +! other procedures +! + else + do jj=1,nope +! + j=jj +! + node1=kon(indexe+j) + jdof1=nactdof(0,node1) +! +! distributed forces +! + if(idist.ne.0) then + if(jdof1.eq.0) then + if(nmpc.ne.0) then + idof1=(node1-1)*8 + call nident(ikmpc,idof1,nmpc,id) + if((id.gt.0).and.(ikmpc(id).eq.idof1)) then + id=ilmpc(id) + ist=ipompc(id) + index=nodempc(3,ist) + do + jdof1=nactdof(nodempc(2,index), + & nodempc(1,index)) + if(jdof1.ne.0) then + fext(jdof1)=fext(jdof1) + & -coefmpc(index)*ff(jj)/coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + cycle + endif + fext(jdof1)=fext(jdof1)+ff(jj) + endif +! + enddo + endif + enddo +! + endif +! +! point forces +! +! modal dynamics and steady state dynamics: +! location of nonzeros is stored +! + if((nmethod.ge.4).and.(iperturb.lt.2)) then + do i=1,nforc + if(ndirforc(i).gt.3) cycle + if(dabs(xforc(i)).lt.1.d-30) cycle + jdof=nactdof(ndirforc(i),nodeforc(1,i)) + if(jdof.ne.0) then + fext(jdof)=fext(jdof)+xforc(i) + call nident(ikactmech,jdof-1,nactmech, + & idm) + do + if(idm.gt.0) then + if(ikactmech(idm).eq.jdof-1) exit + endif + nactmech=nactmech+1 + do m=nactmech,idm+2,-1 + ikactmech(m)=ikactmech(m-1) + enddo + ikactmech(idm+1)=jdof-1 + exit + enddo + else +! +! node is a dependent node of a MPC: distribute +! the forces among the independent nodes +! (proportional to their coefficients) +! + jdof=8*(nodeforc(1,i)-1)+ndirforc(i) + call nident(ikmpc,jdof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.jdof) then + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof=nactdof(nodempc(2,index),nodempc(1,index)) + if(jdof.ne.0) then + fext(jdof)=fext(jdof)- + & coefmpc(index)*xforc(i)/coefmpc(ist) + call nident(ikactmech,jdof-1,nactmech, + & idm) + do + if(idm.gt.0) then + if(ikactmech(idm).eq.jdof-1) exit + endif + nactmech=nactmech+1 + do m=nactmech,idm+2,-1 + ikactmech(m)=ikactmech(m-1) + enddo + ikactmech(idm+1)=jdof-1 + exit + enddo + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + endif + enddo + else +! +! other procedures +! + do i=1,nforc + if(ndirforc(i).gt.3) cycle + jdof=nactdof(ndirforc(i),nodeforc(1,i)) + if(jdof.ne.0) then + fext(jdof)=fext(jdof)+xforc(i) + else +! +! node is a dependent node of a MPC: distribute +! the forces among the independent nodes +! (proportional to their coefficients) +! + jdof=8*(nodeforc(1,i)-1)+ndirforc(i) + call nident(ikmpc,jdof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.jdof) then + ist=ipompc(id) + index=nodempc(3,ist) + if(index.eq.0) cycle + do + jdof=nactdof(nodempc(2,index),nodempc(1,index)) + if(jdof.ne.0) then + fext(jdof)=fext(jdof)- + & coefmpc(index)*xforc(i)/coefmpc(ist) + endif + index=nodempc(3,index) + if(index.eq.0) exit + enddo + endif + endif + endif + enddo + endif +c write(*,*) 'rhs ' +c write(*,'(6(1x,e11.4))') (fext(i),i=1,neq) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/rigidbodies.f calculix-ccx-2.3/ccx_2.3/src/rigidbodies.f --- calculix-ccx-2.1/ccx_2.3/src/rigidbodies.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rigidbodies.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,346 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rigidbodies(inpc,textpart,set,istartset,iendset, + & ialset,nset,nset_,nalset,nalset_,ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,lakon,ipkon,kon,nk,nk_, + & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_,iperturb,ne_, + & ctrl,typeboun,istep,istat,n,iline,ipol,inl,ipoinp,inp,co, + & ipoinpc) +! +! reading the input deck: *RIGID BODY +! + implicit none +! + character*1 typeboun(*),inpc(*) + character*8 lakon(*) + character*20 labmpc(*) + character*81 set(*),elset,noset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),ipompc(*),nodempc(3,*), + & nset,nset_,nalset,nalset_,nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), + & ilmpc(*),ipkon(*),kon(*),inoset,ielset,i,node,ielement,id, + & indexe,nope,istep,istat,n,irefnode,irotnode,ne_, + & j,idof,k,nodeboun(*),ndirboun(*),ikboun(*),ilboun(*), + & nboun,nboun_,key,iperturb,ipos,iline,ipol,inl,ipoinp(2,*), + & inp(3,*),ipoinpc(0:*) +! + real*8 coefmpc(3,*),ctrl(*),co(3,*) +! + if(istep.gt.0) then + write(*,*) + & '*ERROR in rigidbodies: *RIGID BODY should be placed' + write(*,*) ' before all step definitions' + stop + endif +! +! the *RIGID BODY option implies a nonlinear geometric +! calculation +! + if(iperturb.eq.1) then + write(*,*) '*ERROR in rigidbodies: the *RIGID BODY option' + write(*,*) ' cannot be used in a perturbation step' + stop + endif +! + elset=' + & ' + noset=' + & ' + irefnode=0 + irotnode=0 +! + do i=2,n + if(textpart(i)(1:6).eq.'ELSET=') then + if(noset(1:1).eq.' ') then + elset(1:80)=textpart(i)(7:86) + ipos=index(elset,' ') + elset(ipos:ipos)='E' + else + write(*,*) '*ERROR in rigidbodies: either NSET or' + write(*,*) ' ELSET can be specified, not both' + stop + endif + elseif(textpart(i)(1:5).eq.'NSET=') then + if(elset(1:1).eq.' ') then + noset(1:80)=textpart(i)(6:85) + ipos=index(noset,' ') + noset(ipos:ipos)='N' + else + write(*,*) '*ERROR in rigidbodies: either NSET or' + write(*,*) ' ELSET can be specified, not both' + stop + endif + elseif(textpart(i)(1:8).eq.'REFNODE=') then + read(textpart(i)(9:18),'(i10)',iostat=istat) irefnode + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(irefnode.gt.nk) then + write(*,*) '*ERROR in rigidbodies: ref node',irefnode + write(*,*) ' has not been defined' + stop + endif + elseif(textpart(i)(1:8).eq.'ROTNODE=') then + read(textpart(i)(9:18),'(i10)',iostat=istat) irotnode + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(irefnode.gt.nk) then + write(*,*) '*ERROR in rigidbodies: rot node',irotnode + write(*,*) ' has not been defined' + stop + endif + else + write(*,*) + & '*WARNING in rigidbodies: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! check whether a set was defined +! + if((elset(1:1).eq.' ').and. + & (noset(1:1).eq.' ')) then + write(*,*) '*WARNING in rigidbodies: no set defined' + return + endif +! + inoset=0 + ielset=0 +! +! checking whether the set exists +! + if(noset(1:1).ne.' ') then + do i=1,nset + if(set(i).eq.noset) then + inoset=i + exit + endif + enddo + if(inoset.eq.0) then + write(*,*) '*WARNING in rigidbodies: node set ',noset + write(*,*) ' does not exist' + return + endif + endif +! + if(elset(1:1).ne.' ') then + do i=1,nset + if(set(i).eq.elset) then + ielset=i + exit + endif + enddo + if(ielset.eq.0) then + write(*,*) '*WARNING in rigidbodies: element set ',elset + write(*,*) ' does not exist' + return + endif + endif +! +! check for the existence of irefnode and irotnode; if none were +! defined, new nodes are generated +! + if(irefnode.eq.0) then + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in rigidbodies: increase nk_' + stop + endif + irefnode=nk + endif +! + if(irotnode.eq.0) then + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in rigidbodies: increase nk_' + stop + endif + irotnode=nk + endif +! +! check whether other equations apply to the dependent nodes +! + if(inoset.ne.0) then + do i=istartset(inoset),iendset(inoset) + node=ialset(i) + if(node.gt.nk_) then + write(*,*) '*ERROR in rigidbodies: node ',node + write(*,*) ' belonging to set ',noset + write(*,*) ' has not been defined' + stop + endif + if((node.eq.irefnode).or.(node.eq.irotnode)) cycle + do j=1,3 + idof=8*(node-1)+j + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*WARNING in rigidbodies: dof ',j + write(*,*) ' of node ',node,' belonging' + write(*,*) ' to a rigid body is detected' + write(*,*) ' on the dependent side of ' + write(*,*) ' another equation; no rigid' + write(*,*) ' body constrained applied' + endif + endif + enddo + enddo + endif +! + if(ielset.ne.0) then + do i=istartset(ielset),iendset(ielset) + ielement=ialset(i) + if(ielement.gt.ne_) then + write(*,*) '*ERROR in rigidbodies: element ',ielement + write(*,*) ' belonging to set ',elset + write(*,*) ' has not been defined' + stop + endif + if(ipkon(ielement).lt.0) cycle + indexe=ipkon(ielement) + if(lakon(ielement)(4:4).eq.'2') then + nope=20 + elseif(lakon(ielement)(4:4).eq.'8') then + nope=8 + elseif(lakon(ielement)(4:5).eq.'10') then + nope=10 + elseif(lakon(ielement)(4:4).eq.'4') then + nope=4 + elseif(lakon(ielement)(4:5).eq.'15') then + nope=15 + else + nope=6 + endif + do k=indexe+1,indexe+nope + node=kon(k) + if((node.eq.irefnode).or.(node.eq.irotnode)) cycle + do j=1,3 + idof=8*(node-1)+j + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*)'*WARNING in rigidbodies: dof ',j,'of + &node ',node,' belonging to a' + write(*,*)' rigid body is detected on th + &e dependent side of another' + write(*,*)' equation; no rigid body cons + &trained applied' + endif + endif + enddo + enddo + enddo + endif +! +! generating the equations in basis form +! +! node set +! + if(inoset.ne.0) then + do i=istartset(inoset),iendset(inoset) + node=ialset(i) + if(node.gt.0) then + if((node.eq.irefnode).or.(node.eq.irotnode)) cycle + call rigidmpc(ipompc,nodempc,coefmpc,irefnode,irotnode, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_, + & nodeboun,ndirboun,ikboun,ilboun,nboun,nboun_,node, + & typeboun,co) + else + node=ialset(i-2) + do + node=node-ialset(i) + if(node.ge.ialset(i-1)) exit + if((node.eq.irefnode).or.(node.eq.irotnode)) cycle + call rigidmpc(ipompc,nodempc,coefmpc,irefnode, + & irotnode,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun,nboun, + & nboun_,node,typeboun,co) + enddo + endif + enddo + endif +! +! element set +! + if(ielset.ne.0) then + do i=istartset(ielset),iendset(ielset) + ielement=ialset(i) + if(ielement.gt.0) then + if(ipkon(ielement).lt.0) cycle + indexe=ipkon(ielement) + if(lakon(ielement)(4:4).eq.'2') then + nope=20 + elseif(lakon(ielement)(4:4).eq.'8') then + nope=8 + elseif(lakon(ielement)(4:5).eq.'10') then + nope=10 + elseif(lakon(ielement)(4:4).eq.'4') then + nope=4 + elseif(lakon(ielement)(4:5).eq.'15') then + nope=15 + else + nope=6 + endif + do k=indexe+1,indexe+nope + node=kon(k) + if((node.eq.irefnode).or.(node.eq.irotnode)) cycle + call rigidmpc(ipompc,nodempc,coefmpc,irefnode, + & irotnode,labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc, + & nk,nk_,nodeboun,ndirboun,ikboun,ilboun,nboun, + & nboun_,node,typeboun,co) + enddo + else + ielement=ialset(i-2) + do + ielement=ielement-ialset(i) + if(ielement.ge.ialset(i-1)) exit + if(ipkon(ielement).lt.0) cycle + indexe=ipkon(ielement) + if(lakon(ielement)(4:4).eq.'2') then + nope=20 + elseif(lakon(ielement)(4:4).eq.'8') then + nope=8 + elseif(lakon(ielement)(4:5).eq.'10') then + nope=10 + elseif(lakon(ielement)(4:4).eq.'4') then + nope=4 + elseif(lakon(ielement)(4:5).eq.'15') then + nope=15 + else + nope=6 + endif + do k=indexe+1,indexe+nope + node=kon(k) + if((node.eq.irefnode).or.(node.eq.irotnode)) cycle + call rigidmpc(ipompc,nodempc,coefmpc,irefnode, + & irotnode,labmpc,nmpc,nmpc_,mpcfree,ikmpc, + & ilmpc,nk,nk_,nodeboun,ndirboun,ikboun,ilboun, + & nboun,nboun_,node,typeboun,co) + enddo + enddo + endif + enddo + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/rigidmpc.f calculix-ccx-2.3/ccx_2.3/src/rigidmpc.f --- calculix-ccx-2.1/ccx_2.3/src/rigidmpc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rigidmpc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,130 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rigidmpc(ipompc,nodempc,coefmpc,irefnode,irotnode, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, + & ikboun,ilboun,nboun,nboun_,node,typeboun,co) +! +! generates three rigid body MPC's for node "node" about reference +! (translational) node irefnode and rotational node irotnode +! + implicit none +! + character*1 typeboun(*) + character*20 labmpc(*) +! + integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), + & ilmpc(*),node,id,mpcfreeold,j,idof,l,nodeboun(*), + & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,irefnode, + & irotnode +! + real*8 coefmpc(*),co(3,*),e(3,3,3) +! + data e /0.,0.,0.,0.,0.,-1.,0.,1.,0., + & 0.,0.,1.,0.,0.,0.,-1.,0.,0., + & 0.,-1.,0.,1.,0.,0.,0.,0.,0./ +! + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in rigidmpc: increase nk_' + stop + endif + do j=1,3 + idof=8*(node-1)+j + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + cycle + endif + endif + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in rigidmpc: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)='RIGID ' +! + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=j + coefmpc(mpcfree)=1.d0 + mpcfree=nodempc(3,mpcfree) +! +! translation term +! + nodempc(1,mpcfree)=irefnode + nodempc(2,mpcfree)=j + coefmpc(mpcfree)=-1.d0 + mpcfree=nodempc(3,mpcfree) +! +! rotation terms +! + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=1 + coefmpc(mpcfree)=e(j,1,1)*(co(1,irefnode)-co(1,node))+ + & e(j,2,1)*(co(2,irefnode)-co(2,node))+ + & e(j,3,1)*(co(3,irefnode)-co(3,node)) + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=2 + coefmpc(mpcfree)=e(j,1,2)*(co(1,irefnode)-co(1,node))+ + & e(j,2,2)*(co(2,irefnode)-co(2,node))+ + & e(j,3,2)*(co(3,irefnode)-co(3,node)) + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=irotnode + nodempc(2,mpcfree)=3 + coefmpc(mpcfree)=e(j,1,3)*(co(1,irefnode)-co(1,node))+ + & e(j,2,3)*(co(2,irefnode)-co(2,node))+ + & e(j,3,3)*(co(3,irefnode)-co(3,node)) + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=j + coefmpc(mpcfree)=1.d0 + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + idof=8*(nk-1)+j + call nident(ikboun,idof,nboun,id) + nboun=nboun+1 + if(nboun.gt.nboun_) then + write(*,*) '*ERROR in rigidmpc: increase nboun_' + stop + endif + nodeboun(nboun)=nk + ndirboun(nboun)=j + typeboun(nboun)='R' + do l=nboun,id+2,-1 + ikboun(l)=ikboun(l-1) + ilboun(l)=ilboun(l-1) + enddo + ikboun(id+1)=idof + ilboun(id+1)=nboun + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/rimseal_calc.f calculix-ccx-2.3/ccx_2.3/src/rimseal_calc.f --- calculix-ccx-2.1/ccx_2.3/src/rimseal_calc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rimseal_calc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,28 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rimseal_calc(p1) +! +! rimseal element +! + implicit none +! + real*8 p1 +! + write(*,*) 'p1' + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/rimseal.f calculix-ccx-2.3/ccx_2.3/src/rimseal.f --- calculix-ccx-2.1/ccx_2.3/src/rimseal.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rimseal.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,68 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rimseal(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,R,physcon,dvi,numf,set,mi) +! +! rimseal element +! + implicit none +! + logical identity + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(4),idirf(4),index,iflag,mi(2), + & inv,ipkon(*),kon(*),kgas,nelem_in,nelem_out, + & element0,node10,node20,node11,node21,node12,node22,node_cav, + & node_main,node_main2,node_in1,node_out1,node_in2,node_out2 +! + + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,R,a,d, + & p1,p2,T1,T2,Aeff,C1,C2,C3,cd,cp,physcon(3),p2p1,km1,dvi, + & kp1,kdkm1,tdkp1,km1dk,x,y,ca1,cb1,ca2,cb2,dT1,alambda, + & reynolds,pi,xflow_oil,s,Tcav,pcav,pmin,pmax, + & Tref,Alpha1, Alpha2, Alpha3, GF,kf,MRTAP_ref_ein, + & MRTAP_ref_aus, m_ref_ein, m_ref_aus,maus_zu_mref, + & mein_zu_mref, A_aus, A_ein, A_ges,m_aus, m_ein, m_sperr +! + pi=4.d0*datan(1.d0) + + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1) then +! + p1=v(2,node1) + call rimseal_calc(p1) + elseif (iflag.eq.2) then +! + elseif (iflag.eq.3) then +! + endif + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/rootls.f calculix-ccx-2.3/ccx_2.3/src/rootls.f --- calculix-ccx-2.1/ccx_2.3/src/rootls.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rootls.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,67 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rootls(n,root,maxwid,e2,adj,xadj,mask,ls,xls,depth, + & width) +! +! Sloan routine (Int.J.Num.Meth.Engng. 28,2651-2679(1989)) +! + integer root,depth,nbr,maxwid,lstrt,lstop,lwdth,node,nc,width,n, + & jstrt,jstop,i,j,e2,xadj(n+1),adj(e2),mask(n),xls(n+1),ls(n) +! + mask(root)=1 + ls(1)=root + nc=1 + width=1 + depth=0 + lstop=0 + lwdth=1 + 10 if(lwdth.gt.0) then +! + lstrt=lstop+1 + lstop=nc + depth=depth+1 + xls(depth)=lstrt +! + do 30 i=lstrt,lstop + node=ls(i) + jstrt=xadj(node) + jstop=xadj(node+1)-1 + do 20 j=jstrt,jstop + nbr=adj(j) + if(mask(nbr).eq.0) then + nc=nc+1 + ls(nc)=nbr + mask(nbr)=1 + endif + 20 continue + 30 continue +! + lwdth=nc-lstop + width=max(lwdth,width) +! + if(width.ge.maxwid) go to 35 + go to 10 + endif + xls(depth+1)=lstop+1 +! + 35 continue + do 40 i=1,nc + mask(ls(i))=0 + 40 continue + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/rs.f calculix-ccx-2.3/ccx_2.3/src/rs.f --- calculix-ccx-2.1/ccx_2.3/src/rs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,683 @@ + double precision function pythag(a,b) + double precision a,b +c +c finds dsqrt(a**2+b**2) without overflow or destructive underflow +c + double precision p,r,s,t,u + p = dmax1(dabs(a),dabs(b)) + if (p .eq. 0.0d0) go to 20 + r = (dmin1(dabs(a),dabs(b))/p)**2 + 10 continue + t = 4.0d0 + r + if (t .eq. 4.0d0) go to 20 + s = r/t + u = 1.0d0 + 2.0d0*s + p = u*p + r = (s/u)**2 * r + go to 10 + 20 pythag = p + return + end + subroutine rs(nm,n,a,w,matz,z,fv1,fv2,ierr) +c + integer n,nm,ierr,matz + double precision a(nm,n),w(n),z(nm,n),fv1(n),fv2(n) +c +c this subroutine calls the recommended sequence of +c subroutines from the eigensystem subroutine package (eispack) +c to find the eigenvalues and eigenvectors (if desired) +c of a real symmetric matrix. +c +c on input +c +c nm must be set to the row dimension of the two-dimensional +c array parameters as declared in the calling program +c dimension statement. +c +c n is the order of the matrix a. +c +c a contains the real symmetric matrix. +c +c matz is an integer variable set equal to zero if +c only eigenvalues are desired. otherwise it is set to +c any non-zero integer for both eigenvalues and eigenvectors. +c +c on output +c +c w contains the eigenvalues in ascending order. +c +c z contains the eigenvectors if matz is not zero. +c +c ierr is an integer output variable set equal to an error +c completion code described in the documentation for tqlrat +c and tql2. the normal completion code is zero. +c +c fv1 and fv2 are temporary storage arrays. +c +c questions and comments should be directed to burton s. garbow, +c mathematics and computer science div, argonne national laboratory +c +c this version dated august 1983. +c +c ------------------------------------------------------------------ +c + if (n .le. nm) go to 10 + ierr = 10 * n + go to 50 +c + 10 if (matz .ne. 0) go to 20 +c .......... find eigenvalues only .......... + call tred1(nm,n,a,w,fv1,fv2) +* tqlrat encounters catastrophic underflow on the Vax +* call tqlrat(n,w,fv2,ierr) + call tql1(n,w,fv1,ierr) + go to 50 +c .......... find both eigenvalues and eigenvectors .......... + 20 call tred2(nm,n,a,w,fv1,z) + call tql2(nm,n,w,fv1,z,ierr) + 50 return + end + subroutine tql1(n,d,e,ierr) +c + integer i,j,l,m,n,ii,l1,l2,mml,ierr + double precision d(n),e(n) + double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag +c +c this subroutine is a translation of the algol procedure tql1, +c num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and +c wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 227-240(1971). +c +c this subroutine finds the eigenvalues of a symmetric +c tridiagonal matrix by the ql method. +c +c on input +c +c n is the order of the matrix. +c +c d contains the diagonal elements of the input matrix. +c +c e contains the subdiagonal elements of the input matrix +c in its last n-1 positions. e(1) is arbitrary. +c +c on output +c +c d contains the eigenvalues in ascending order. if an +c error exit is made, the eigenvalues are correct and +c ordered for indices 1,2,...ierr-1, but may not be +c the smallest eigenvalues. +c +c e has been destroyed. +c +c ierr is set to +c zero for normal return, +c j if the j-th eigenvalue has not been +c determined after 30 iterations. +c +c calls pythag for dsqrt(a*a + b*b) . +c +c questions and comments should be directed to burton s. garbow, +c mathematics and computer science div, argonne national laboratory +c +c this version dated august 1983. +c +c ------------------------------------------------------------------ +c + ierr = 0 + if (n .eq. 1) go to 1001 +c + do 100 i = 2, n + 100 e(i-1) = e(i) +c + f = 0.0d0 + tst1 = 0.0d0 + e(n) = 0.0d0 +c + do 290 l = 1, n + j = 0 + h = dabs(d(l)) + dabs(e(l)) + if (tst1 .lt. h) tst1 = h +c .......... look for small sub-diagonal element .......... + do 110 m = l, n + tst2 = tst1 + dabs(e(m)) + if (tst2 .eq. tst1) go to 120 +c .......... e(n) is always zero, so there is no exit +c through the bottom of the loop .......... + 110 continue +c + 120 if (m .eq. l) go to 210 + 130 if (j .eq. 30) go to 1000 + j = j + 1 +c .......... form shift .......... + l1 = l + 1 + l2 = l1 + 1 + g = d(l) + p = (d(l1) - g) / (2.0d0 * e(l)) + r = pythag(p,1.0d0) + d(l) = e(l) / (p + dsign(r,p)) + d(l1) = e(l) * (p + dsign(r,p)) + dl1 = d(l1) + h = g - d(l) + if (l2 .gt. n) go to 145 +c + do 140 i = l2, n + 140 d(i) = d(i) - h +c + 145 f = f + h +c .......... ql transformation .......... + p = d(m) + c = 1.0d0 + c2 = c + el1 = e(l1) + s = 0.0d0 + mml = m - l +c .......... for i=m-1 step -1 until l do -- .......... + do 200 ii = 1, mml + c3 = c2 + c2 = c + s2 = s + i = m - ii + g = c * e(i) + h = c * p + r = pythag(p,e(i)) + e(i+1) = s * r + s = e(i) / r + c = p / r + p = c * d(i) - s * g + d(i+1) = h + s * (c * g + s * d(i)) + 200 continue +c + p = -s * s2 * c3 * el1 * e(l) / dl1 + e(l) = s * p + d(l) = c * p + tst2 = tst1 + dabs(e(l)) + if (tst2 .gt. tst1) go to 130 + 210 p = d(l) + f +c .......... order eigenvalues .......... + if (l .eq. 1) go to 250 +c .......... for i=l step -1 until 2 do -- .......... + do 230 ii = 2, l + i = l + 2 - ii + if (p .ge. d(i-1)) go to 270 + d(i) = d(i-1) + 230 continue +c + 250 i = 1 + 270 d(i) = p + 290 continue +c + go to 1001 +c .......... set error -- no convergence to an +c eigenvalue after 30 iterations .......... + 1000 ierr = l + 1001 return + end + subroutine tql2(nm,n,d,e,z,ierr) +c + integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr + double precision d(n),e(n),z(nm,n) + double precision c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag +c +c this subroutine is a translation of the algol procedure tql2, +c num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and +c wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 227-240(1971). +c +c this subroutine finds the eigenvalues and eigenvectors +c of a symmetric tridiagonal matrix by the ql method. +c the eigenvectors of a full symmetric matrix can also +c be found if tred2 has been used to reduce this +c full matrix to tridiagonal form. +c +c on input +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement. +c +c n is the order of the matrix. +c +c d contains the diagonal elements of the input matrix. +c +c e contains the subdiagonal elements of the input matrix +c in its last n-1 positions. e(1) is arbitrary. +c +c z contains the transformation matrix produced in the +c reduction by tred2, if performed. if the eigenvectors +c of the tridiagonal matrix are desired, z must contain +c the identity matrix. +c +c on output +c +c d contains the eigenvalues in ascending order. if an +c error exit is made, the eigenvalues are correct but +c unordered for indices 1,2,...,ierr-1. +c +c e has been destroyed. +c +c z contains orthonormal eigenvectors of the symmetric +c tridiagonal (or full) matrix. if an error exit is made, +c z contains the eigenvectors associated with the stored +c eigenvalues. +c +c ierr is set to +c zero for normal return, +c j if the j-th eigenvalue has not been +c determined after 30 iterations. +c +c calls pythag for dsqrt(a*a + b*b) . +c +c questions and comments should be directed to burton s. garbow, +c mathematics and computer science div, argonne national laboratory +c +c this version dated august 1983. +c +c ------------------------------------------------------------------ +c + ierr = 0 + if (n .eq. 1) go to 1001 +c + do 100 i = 2, n + 100 e(i-1) = e(i) +c + f = 0.0d0 + tst1 = 0.0d0 + e(n) = 0.0d0 +c + do 240 l = 1, n + j = 0 + h = dabs(d(l)) + dabs(e(l)) + if (tst1 .lt. h) tst1 = h +c .......... look for small sub-diagonal element .......... + do 110 m = l, n + tst2 = tst1 + dabs(e(m)) + if (tst2 .eq. tst1) go to 120 +c .......... e(n) is always zero, so there is no exit +c through the bottom of the loop .......... + 110 continue +c + 120 if (m .eq. l) go to 220 + 130 if (j .eq. 30) go to 1000 + j = j + 1 +c .......... form shift .......... + l1 = l + 1 + l2 = l1 + 1 + g = d(l) + p = (d(l1) - g) / (2.0d0 * e(l)) + r = pythag(p,1.0d0) + d(l) = e(l) / (p + dsign(r,p)) + d(l1) = e(l) * (p + dsign(r,p)) + dl1 = d(l1) + h = g - d(l) + if (l2 .gt. n) go to 145 +c + do 140 i = l2, n + 140 d(i) = d(i) - h +c + 145 f = f + h +c .......... ql transformation .......... + p = d(m) + c = 1.0d0 + c2 = c + el1 = e(l1) + s = 0.0d0 + mml = m - l +c .......... for i=m-1 step -1 until l do -- .......... + do 200 ii = 1, mml + c3 = c2 + c2 = c + s2 = s + i = m - ii + g = c * e(i) + h = c * p + r = pythag(p,e(i)) + e(i+1) = s * r + s = e(i) / r + c = p / r + p = c * d(i) - s * g + d(i+1) = h + s * (c * g + s * d(i)) +c .......... form vector .......... + do 180 k = 1, n + h = z(k,i+1) + z(k,i+1) = s * z(k,i) + c * h + z(k,i) = c * z(k,i) - s * h + 180 continue +c + 200 continue +c + p = -s * s2 * c3 * el1 * e(l) / dl1 + e(l) = s * p + d(l) = c * p + tst2 = tst1 + dabs(e(l)) + if (tst2 .gt. tst1) go to 130 + 220 d(l) = d(l) + f + 240 continue +c .......... order eigenvalues and eigenvectors .......... + do 300 ii = 2, n + i = ii - 1 + k = i + p = d(i) +c + do 260 j = ii, n + if (d(j) .ge. p) go to 260 + k = j + p = d(j) + 260 continue +c + if (k .eq. i) go to 300 + d(k) = d(i) + d(i) = p +c + do 280 j = 1, n + p = z(j,i) + z(j,i) = z(j,k) + z(j,k) = p + 280 continue +c + 300 continue +c + go to 1001 +c .......... set error -- no convergence to an +c eigenvalue after 30 iterations .......... + 1000 ierr = l + 1001 return + end + subroutine tred1(nm,n,a,d,e,e2) +c + integer i,j,k,l,n,ii,nm,jp1 + double precision a(nm,n),d(n),e(n),e2(n) + double precision f,g,h,scale +c +c this subroutine is a translation of the algol procedure tred1, +c num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 212-226(1971). +c +c this subroutine reduces a real symmetric matrix +c to a symmetric tridiagonal matrix using +c orthogonal similarity transformations. +c +c on input +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement. +c +c n is the order of the matrix. +c +c a contains the real symmetric input matrix. only the +c lower triangle of the matrix need be supplied. +c +c on output +c +c a contains information about the orthogonal trans- +c formations used in the reduction in its strict lower +c triangle. the full upper triangle of a is unaltered. +c +c d contains the diagonal elements of the tridiagonal matrix. +c +c e contains the subdiagonal elements of the tridiagonal +c matrix in its last n-1 positions. e(1) is set to zero. +c +c e2 contains the squares of the corresponding elements of e. +c e2 may coincide with e if the squares are not needed. +c +c questions and comments should be directed to burton s. garbow, +c mathematics and computer science div, argonne national laboratory +c +c this version dated august 1983. +c +c ------------------------------------------------------------------ +c + do 100 i = 1, n + d(i) = a(n,i) + a(n,i) = a(i,i) + 100 continue +c .......... for i=n step -1 until 1 do -- .......... + do 300 ii = 1, n + i = n + 1 - ii + l = i - 1 + h = 0.0d0 + scale = 0.0d0 + if (l .lt. 1) go to 130 +c .......... scale row (algol tol then not needed) .......... + do 120 k = 1, l + 120 scale = scale + dabs(d(k)) +c + if (scale .ne. 0.0d0) go to 140 +c + do 125 j = 1, l + d(j) = a(l,j) + a(l,j) = a(i,j) + a(i,j) = 0.0d0 + 125 continue +c + 130 e(i) = 0.0d0 + e2(i) = 0.0d0 + go to 300 +c + 140 do 150 k = 1, l + d(k) = d(k) / scale + h = h + d(k) * d(k) + 150 continue +c + e2(i) = scale * scale * h + f = d(l) + g = -dsign(dsqrt(h),f) + e(i) = scale * g + h = h - f * g + d(l) = f - g + if (l .eq. 1) go to 285 +c .......... form a*u .......... + do 170 j = 1, l + 170 e(j) = 0.0d0 +c + do 240 j = 1, l + f = d(j) + g = e(j) + a(j,j) * f + jp1 = j + 1 + if (l .lt. jp1) go to 220 +c + do 200 k = jp1, l + g = g + a(k,j) * d(k) + e(k) = e(k) + a(k,j) * f + 200 continue +c + 220 e(j) = g + 240 continue +c .......... form p .......... + f = 0.0d0 +c + do 245 j = 1, l + e(j) = e(j) / h + f = f + e(j) * d(j) + 245 continue +c + h = f / (h + h) +c .......... form q .......... + do 250 j = 1, l + 250 e(j) = e(j) - h * d(j) +c .......... form reduced a .......... + do 280 j = 1, l + f = d(j) + g = e(j) +c + do 260 k = j, l + 260 a(k,j) = a(k,j) - f * e(k) - g * d(k) +c + 280 continue +c + 285 do 290 j = 1, l + f = d(j) + d(j) = a(l,j) + a(l,j) = a(i,j) + a(i,j) = f * scale + 290 continue +c + 300 continue +c + return + end + subroutine tred2(nm,n,a,d,e,z) +c + integer i,j,k,l,n,ii,nm,jp1 + double precision a(nm,n),d(n),e(n),z(nm,n) + double precision f,g,h,hh,scale +c +c this subroutine is a translation of the algol procedure tred2, +c num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson. +c handbook for auto. comp., vol.ii-linear algebra, 212-226(1971). +c +c this subroutine reduces a real symmetric matrix to a +c symmetric tridiagonal matrix using and accumulating +c orthogonal similarity transformations. +c +c on input +c +c nm must be set to the row dimension of two-dimensional +c array parameters as declared in the calling program +c dimension statement. +c +c n is the order of the matrix. +c +c a contains the real symmetric input matrix. only the +c lower triangle of the matrix need be supplied. +c +c on output +c +c d contains the diagonal elements of the tridiagonal matrix. +c +c e contains the subdiagonal elements of the tridiagonal +c matrix in its last n-1 positions. e(1) is set to zero. +c +c z contains the orthogonal transformation matrix +c produced in the reduction. +c +c a and z may coincide. if distinct, a is unaltered. +c +c questions and comments should be directed to burton s. garbow, +c mathematics and computer science div, argonne national laboratory +c +c this version dated august 1983. +c +c ------------------------------------------------------------------ +c + do 100 i = 1, n +c + do 80 j = i, n + 80 z(j,i) = a(j,i) +c + d(i) = a(n,i) + 100 continue +c + if (n .eq. 1) go to 510 +c .......... for i=n step -1 until 2 do -- .......... + do 300 ii = 2, n + i = n + 2 - ii + l = i - 1 + h = 0.0d0 + scale = 0.0d0 + if (l .lt. 2) go to 130 +c .......... scale row (algol tol then not needed) .......... + do 120 k = 1, l + 120 scale = scale + dabs(d(k)) +c + if (scale .ne. 0.0d0) go to 140 + 130 e(i) = d(l) +c + do 135 j = 1, l + d(j) = z(l,j) + z(i,j) = 0.0d0 + z(j,i) = 0.0d0 + 135 continue +c + go to 290 +c + 140 do 150 k = 1, l + d(k) = d(k) / scale + h = h + d(k) * d(k) + 150 continue +c + f = d(l) + g = -dsign(dsqrt(h),f) + e(i) = scale * g + h = h - f * g + d(l) = f - g +c .......... form a*u .......... + do 170 j = 1, l + 170 e(j) = 0.0d0 +c + do 240 j = 1, l + f = d(j) + z(j,i) = f + g = e(j) + z(j,j) * f + jp1 = j + 1 + if (l .lt. jp1) go to 220 +c + do 200 k = jp1, l + g = g + z(k,j) * d(k) + e(k) = e(k) + z(k,j) * f + 200 continue +c + 220 e(j) = g + 240 continue +c .......... form p .......... + f = 0.0d0 +c + do 245 j = 1, l + e(j) = e(j) / h + f = f + e(j) * d(j) + 245 continue +c + hh = f / (h + h) +c .......... form q .......... + do 250 j = 1, l + 250 e(j) = e(j) - hh * d(j) +c .......... form reduced a .......... + do 280 j = 1, l + f = d(j) + g = e(j) +c + do 260 k = j, l + 260 z(k,j) = z(k,j) - f * e(k) - g * d(k) +c + d(j) = z(l,j) + z(i,j) = 0.0d0 + 280 continue +c + 290 d(i) = h + 300 continue +c .......... accumulation of transformation matrices .......... + do 500 i = 2, n + l = i - 1 + z(n,l) = z(l,l) + z(l,l) = 1.0d0 + h = d(i) + if (h .eq. 0.0d0) go to 380 +c + do 330 k = 1, l + 330 d(k) = z(k,i) / h +c + do 360 j = 1, l + g = 0.0d0 +c + do 340 k = 1, l + 340 g = g + z(k,i) * z(k,j) +c + do 360 k = 1, l + z(k,j) = z(k,j) - g * d(k) + 360 continue +c + 380 do 400 k = 1, l + 400 z(k,i) = 0.0d0 +c + 500 continue +c + 510 do 520 i = 1, n + d(i) = z(n,i) + z(n,i) = 0.0d0 + 520 continue +c + z(n,n) = 1.0d0 + e(1) = 0.0d0 + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/rubber.f calculix-ccx-2.3/ccx_2.3/src/rubber.f --- calculix-ccx-2.1/ccx_2.3/src/rubber.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/rubber.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,881 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine rubber(elconloc,elas,emec,kode,emec0,didc, + & d2idc2,dibdc,d2ibdc2,dudc,d2udc2,dldc,d2ldc2,dlbdc,d2lbdc2, + & ithermal,icmd,beta,stre) +! +! calculates stiffness and stresses for rubber and elastomeric +! foam materials +! +! icmd=3: stress at mechanical strain +! else: stress and stiffness matrix at mechanical strain +! + implicit none +! + logical ogden,hyperfoam,taylor +! + integer nelconst,kode,kk(84),i,j,k,l,m,nt,icmd,istart,iend, + & nc,n,ithermal,ii,jj,mm,neig +! + real*8 elconloc(*),elas(*),emec(*),emec0(*),didc(3,3,3), + & d2idc2(3,3,3,3,3),dibdc(3,3,3),d2ibdc2(3,3,3,3,3),dudc(3,3), + & d2udc2(3,3,3,3),dldc(3,3,3),d2ldc2(3,3,3,3,3),dlbdc(3,3,3), + & d2lbdc2(3,3,3,3,3),v1,v2,v3,c(3,3),cinv(3,3),d(3,3),djth, + & coef,bb,cc,cm,cn,tt,pi,dd,al(3),v1b,v2b,v3b, + & alb(3),beta(*),v33,v36,all(3),term,stre(*),total,coefa, + & coefb,coefd,coefm,constant(21) +! + data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, + & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, + & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, + & 2,3,2,3/ +c write(*,*) ' emec ' +c write(*,'(4(1x,e19.12))') (emec(i),i=1,6) +! +! copy the elastic constants into a new field, such that +! they can be mixed without influencing the field in the +! calling program +! + do i=1,21 + constant(i)=elconloc(i) + enddo +! +! type of hyperelastic law; taylor stands for everything +! which involves parts of a taylor expansion in terms of the +! reduced Green deformation invariants +! + ogden=.false. + hyperfoam=.false. + taylor=.false. + if((kode.lt.-3).and.(kode.gt.-7)) then + ogden=.true. + elseif((kode.lt.-14).and.(kode.gt.-18)) then + hyperfoam=.true. + else + taylor=.true. + endif +! +c if(icmd.eq.1) then + istart=1 + iend=1 +! +! reclassifying some classes of hyperelastic materials as +! subclasses of the polynomial model +! + if(((kode.lt.-1).and.(kode.gt.-4)).or. + & ((kode.lt.-6).and.(kode.gt.-13)).or. + & (kode.eq.-14)) then + if(kode.eq.-2) then + kode=-7 + nelconst=1 + elseif((kode.eq.-3).or.(kode.eq.-10)) then + constant(3)=constant(2) + constant(2)=0.d0 + kode=-7 + nelconst=1 + elseif(kode.eq.-11) then + constant(7)=constant(4) + constant(6)=constant(3) + constant(5)=0.d0 + constant(4)=0.d0 + constant(3)=constant(2) + constant(2)=0.d0 + kode=-8 + nelconst=2 + elseif((kode.eq.-12).or.(kode.eq.-14)) then + constant(12)=constant(6) + constant(11)=constant(5) + constant(10)=constant(4) + constant(9)=0.d0 + constant(8)=0.d0 + constant(7)=0.d0 + constant(6)=constant(3) + constant(5)=0.d0 + constant(4)=0.d0 + constant(3)=constant(2) + constant(2)=0.d0 + kode=-9 + nelconst=3 + elseif(kode.eq.-7) then + nelconst=1 + elseif(kode.eq.-8) then + nelconst=2 + elseif(kode.eq.-9) then + nelconst=3 + endif + endif +! +! major loop +! + do ii=istart,iend +! +! calculation of the Green deformation tensor for the total +! strain and the thermal strain +! + do i=1,3 + c(i,i)=emec(i)*2.d0+1.d0 + enddo + c(1,2)=2.d0*emec(4) + c(1,3)=2.d0*emec(5) + c(2,3)=2.d0*emec(6) +c write(*,*) ' c ' +c write(*,'(4(1x,e19.12))') (((c(i,j),i=1,3),j=1,3)) +! +! calculation of the invariants of c +! + v1=c(1,1)+c(2,2)+c(3,3) + v2=c(2,2)*c(3,3)+c(1,1)*c(3,3)+c(1,1)*c(2,2)- + & (c(2,3)*c(2,3)+c(1,3)*c(1,3)+c(1,2)*c(1,2)) +c v2=v1*v1 +c do i=1,3 +c v2=v2-c(i,i)*c(i,i) +c enddo +c v2=v2/2.d0 + v3=c(1,1)*(c(2,2)*c(3,3)-c(2,3)*c(2,3)) + & -c(1,2)*(c(1,2)*c(3,3)-c(1,3)*c(2,3)) + & +c(1,3)*(c(1,2)*c(2,3)-c(1,3)*c(2,2)) + v33=v3**(-1.d0/3.d0) + v36=v3**(-1.d0/6.d0) +! +! calculation of the thermal strain jacobian +! (not really needed) +! + djth=1.d0 +! +! inversion of c +! + cinv(1,1)=(c(2,2)*c(3,3)-c(2,3)*c(2,3))/v3 + cinv(2,2)=(c(1,1)*c(3,3)-c(1,3)*c(1,3))/v3 + cinv(3,3)=(c(1,1)*c(2,2)-c(1,2)*c(1,2))/v3 + cinv(1,2)=(c(1,3)*c(2,3)-c(1,2)*c(3,3))/v3 + cinv(1,3)=(c(1,2)*c(2,3)-c(2,2)*c(1,3))/v3 + cinv(2,3)=(c(1,2)*c(1,3)-c(1,1)*c(2,3))/v3 + cinv(2,1)=cinv(1,2) + cinv(3,1)=cinv(1,3) + cinv(3,2)=cinv(2,3) +! +! creation of the delta Dirac matrix d +! + do j=1,3 + do i=1,3 + d(i,j)=0.d0 + enddo + enddo + do i=1,3 + d(i,i)=1.d0 + enddo +! +! derivative of the c-invariants with respect to c(k,l) +! + do l=1,3 + do k=1,l + didc(k,l,1)=d(k,l) + didc(k,l,2)=v1*d(k,l)-c(k,l) + didc(k,l,3)=v3*cinv(k,l) + enddo + enddo +! +! second derivative of the c-invariants w.r.t. c(k,l) +! and c(m,n) +! + if(icmd.ne.3) then + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2idc2(k,l,m,n,1)=0.d0 + d2idc2(k,l,m,n,2)=d(k,l)*d(m,n)- + & (d(k,m)*d(l,n)+d(k,n)*d(l,m))/2.d0 + d2idc2(k,l,m,n,3)=v3*(cinv(m,n)*cinv(k,l)- + & (cinv(k,m)*cinv(n,l)+cinv(k,n)*cinv(m,l))/2.d0) + enddo + endif +! +! derivatives for the reduced invariants used in rubber materials +! + v1b=v1*v33 + v2b=v2*v33*v33 + v3b=dsqrt(v3)/djth +! +! first derivative of the reduced c-invariants w.r.t. c(k,l) +! + do l=1,3 + do k=1,l + if(taylor) then + dibdc(k,l,1)=-v33**4*v1*didc(k,l,3)/3.d0 + & +v33*didc(k,l,1) + dibdc(k,l,2)=-2.d0*v33**5*v2*didc(k,l,3)/3.d0 + & +v33**2*didc(k,l,2) + endif + dibdc(k,l,3)=didc(k,l,3)/(2.d0*dsqrt(v3)*djth) + enddo + enddo +! +! second derivative of the reduced c-invariants w.r.t. c(k,l) +! and c(m,n) +! + if(icmd.ne.3) then + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + if(taylor) then + d2ibdc2(k,l,m,n,1)=4.d0/9.d0*v33**7*v1*didc(k,l,3) + & *didc(m,n,3)-v33**4/3.d0*(didc(m,n,1)*didc(k,l,3) + & +didc(k,l,1)*didc(m,n,3))-v33**4/3.d0*v1* + & d2idc2(k,l,m,n,3)+v33*d2idc2(k,l,m,n,1) + d2ibdc2(k,l,m,n,2)=10.d0*v33**8/9.d0*v2*didc(k,l,3) + & *didc(m,n,3)-2.d0*v33**5/3.d0*(didc(m,n,2) + & *didc(k,l,3) + & +didc(k,l,2)*didc(m,n,3))-2.d0*v33**5/3.d0*v2* + & d2idc2(k,l,m,n,3)+v33**2*d2idc2(k,l,m,n,2) + endif + d2ibdc2(k,l,m,n,3)=-didc(k,l,3)*didc(m,n,3)/ + & (4.d0*djth*v3**1.5d0)+d2idc2(k,l,m,n,3)/ + & (2.d0*dsqrt(v3)*djth) + enddo + endif +! +! calculation of the principal stretches for the Ogden model and +! hyperfoam materials +! + if((ogden).or.(hyperfoam)) then +! +! taking the thermal jacobian into account +! + if((kode.lt.-14).and.(kode.gt.-18)) then + dd=djth**(1.d0/3.d0) + else + dd=1.d0 + endif +! + pi=4.d0*datan(1.d0) +! +! determining the eigenvalues of c (Simo & Hughes) and taking +! the square root to obtain the principal stretches +! +! neig is the number of different eigenvalues +! + neig=3 +! + bb=v2-v1*v1/3.d0 + cc=-2.d0*v1**3/27.d0+v1*v2/3.d0-v3 + if(dabs(bb).le.1.d-10) then + if(dabs(cc).gt.1.d-10) then + al(1)=-cc**(1.d0/3.d0) + else + al(1)=0.d0 + endif + al(2)=al(1) + al(3)=al(1) + neig=1 + else + cm=2.d0*dsqrt(-bb/3.d0) + cn=3.d0*cc/(cm*bb) + if(dabs(cn).gt.1.d0) then + if(cn.gt.1.d0) then + cn=1.d0 + else + cn=-1.d0 + endif + endif + tt=datan2(dsqrt(1.d0-cn*cn),cn)/3.d0 + al(1)=dcos(tt) + al(2)=dcos(tt+2.d0*pi/3.d0) + al(3)=dcos(tt+4.d0*pi/3.d0) +! +! check for two equal eigenvalues +! + if((dabs(al(1)-al(2)).lt.1.d-5).or. + & (dabs(al(1)-al(3)).lt.1.d-5).or. + & (dabs(al(2)-al(3)).lt.1.d-5)) neig=2 + al(1)=cm*al(1) + al(2)=cm*al(2) + al(3)=cm*al(3) + endif + do i=1,3 + al(i)=dsqrt(al(i)+v1/3.d0) + all(i)=(6.d0*al(i)**5-4.d0*v1*al(i)**3+2.d0*al(i)*v2)*dd + enddo +! +! first derivative of the principal stretches w.r.t. c(k,l) +! + if(neig.eq.3) then +! +! three different principal stretches +! + do i=1,3 + do l=1,3 + do k=1,l + dldc(k,l,i)=(al(i)**4*didc(k,l,1) + & -al(i)**2*didc(k,l,2)+didc(k,l,3))/all(i) + enddo + enddo + enddo + elseif(neig.eq.1) then +! +! three equal principal stretches +! + do i=1,3 + do l=1,3 + do k=1,l + dldc(k,l,i)=didc(k,l,1)/(6.d0*al(i)) + enddo + enddo + enddo + else +! +! two equal principal stretches +! + do i=1,3 + do l=1,3 + do k=1,l + dldc(k,l,i)=(dcos(tt+(i-1)*2.d0*pi/3.d0)* + & (2.d0*v1*didc(k,l,1)-3.d0*didc(k,l,2))/ + & (3.d0*dsqrt(v1*v1-3.d0*v2))+didc(k,l,1)/3.d0)/ + & (2.d0*al(i)) + enddo + enddo + enddo + endif +! +! second derivative of the principal stretches w.r.t. c(k,l) +! and c(m,n) +! + if(icmd.ne.3) then + if(neig.eq.3) then +! +! three different principal stretches +! + do i=1,3 + nt=0 + do j=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2ldc2(k,l,m,n,i)=(-30.d0*al(i)**4 + & *dldc(k,l,i)*dldc(m,n,i)+al(i)**4 + & *d2idc2(k,l,m,n,1) + & +4.d0*al(i)**3*(didc(k,l,1)*dldc(m,n,i) + & +didc(m,n,1) + & *dldc(k,l,i))+12.d0*v1*al(i)**2*dldc(k,l,i)* + & dldc(m,n,i)-d2idc2(k,l,m,n,2)*al(i)**2-2.d0 + & *al(i)* + & didc(k,l,2)*dldc(m,n,i)-2.d0*v2*dldc(k,l,i)* + & dldc(m,n,i)-2.d0*al(i)*didc(m,n,2)*dldc(k,l,i) + & +d2idc2(k,l,m,n,3))/all(i) + enddo + enddo + elseif(neig.eq.1) then +! +! three equal principal stretches +! + do i=1,3 + nt=0 + do j=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2ldc2(k,l,m,n,i)=(d2idc2(k,l,m,n,1)/6.d0 + & -dldc(k,l,i)*dldc(m,n,i))/al(i) + enddo + enddo + else +! +! two equal principal stretches +! + do i=1,3 + nt=0 + do j=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2ldc2(k,l,m,n,i)=(dcos(tt+(i-1)*2.d0*pi/3.d0)* + & (-(2.d0*v1*didc(k,l,1)-3.d0*didc(k,l,2))* + & (2.d0*v1*didc(m,n,1)-3.d0*didc(m,n,2))/ + & (6.d0*(v1*v1-3.d0*v2)**1.5)+ + & (2.d0*didc(k,l,1)*didc(m,n,1)+2.d0*v1* + & d2idc2(k,l,m,n,1)-3.d0*d2idc2(k,l,m,n,2))/ + & (3.d0*dsqrt(v1*v1-3.d0*v2))) + & +d2idc2(k,l,m,n,1)/3.d0)/(2.d0*al(i))- + & dldc(k,l,i)*dldc(m,n,i)/al(i) + enddo + enddo + endif + endif +! +! reduced principal stretches (Ogden model) +! + if(ogden) then +! +! calculation of the reduced principal stretches +! + do i=1,3 + alb(i)=al(i)*v36 + enddo +! +! first derivative of the reduced principal stretches +! w.r.t. c(k,l) +! + do i=1,3 + do l=1,3 + do k=1,l + dlbdc(k,l,i)=-v36**7*al(i)*didc(k,l,3)/6.d0 + & +v36*dldc(k,l,i) + enddo + enddo + enddo +! +! second derivative of the reduced principal stretches w.r.t. +! c(k,l) and c(m,n) +! + if(icmd.ne.3) then + do i=1,3 + nt=0 + do j=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2lbdc2(k,l,m,n,i)=7.d0*v36**13*al(i) + & *didc(k,l,3)*didc(m,n,3)/36.d0-v36**7/6.d0 + & *(dldc(m,n,i)*didc(k,l,3)+al(i) + & *d2idc2(k,l,m,n,3)+dldc(k,l,i)*didc(m,n,3)) + & +v36*d2ldc2(k,l,m,n,i) + enddo + enddo + endif +! + endif + endif +! +! calculation of the local stiffness matrix, and, if appropriate, +! the stresses +! +! Polynomial model +! + if((kode.lt.-6).and.(kode.gt.-10)) then +! +! first derivative of U w.r.t. c(k,l) +! + do l=1,3 + do k=1,l + dudc(k,l)=0.d0 + enddo + enddo +! + nc=0 + do m=1,nelconst + do j=0,m + i=m-j + nc=nc+1 + coef=constant(nc) + if(dabs(coef).lt.1.d-20) cycle + do l=1,3 + do k=1,l + total=0.d0 + if(i.gt.0) then + term=dibdc(k,l,1) + if(i.gt.1) term=i*term*(v1b-3.d0)**(i-1) + if(j.gt.0) term=term*(v2b-3.d0)**j + total=total+term + endif + if(j.gt.0) then + term=dibdc(k,l,2) + if(i.gt.0) term=term*(v1b-3.d0)**i + if(j.gt.1) term=j*term*(v2b-3.d0)**(j-1) + total=total+term + endif + dudc(k,l)=dudc(k,l)+total*coef + enddo + enddo + enddo + enddo + do m=1,nelconst + nc=nc+1 + coef=constant(nc) + do l=1,3 + do k=1,l + dudc(k,l)=dudc(k,l)+2.d0*m*(v3b-1.d0)** + & (2*m-1)*dibdc(k,l,3)/coef + enddo + enddo + enddo +! +! tangent stiffness matrix +! second derivative of U w.r.t. c(k,l) and c(m,n) +! + if(icmd.ne.3) then + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2udc2(k,l,m,n)=0.d0 + enddo + nc=0 + do mm=1,nelconst + do j=0,mm + i=mm-j + nc=nc+1 + coef=constant(nc) + if(dabs(coef).lt.1.d-20) cycle + nt=0 + do jj=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + total=0.d0 + if(i.gt.1) then + term=dibdc(k,l,1)*dibdc(m,n,1)*i*(i-1) + if(i.gt.2) term=term*(v1b-3.d0)**(i-2) + if(j.gt.0) term=term*(v2b-3.d0)**j + total=total+term + endif + if((i.gt.0).and.(j.gt.0)) then + term=dibdc(k,l,1)*dibdc(m,n,2)+ + & dibdc(m,n,1)*dibdc(k,l,2) + if(i.gt.1) term=i*term*(v1b-3.d0)**(i-1) + if(j.gt.1) term=j*term*(v2b-3.d0)**(j-1) + total=total+term + endif + if(i.gt.0) then + term=d2ibdc2(k,l,m,n,1) + if(i.gt.1) term=i*term*(v1b-3.d0)**(i-1) + if(j.gt.0) term=term*(v2b-3.d0)**j + total=total+term + endif + if(j.gt.1) then + term=dibdc(k,l,2)*dibdc(m,n,2)*j*(j-1) + if(i.gt.0) term=term*(v1b-3.d0)**i + if(j.gt.2) term=term*(v2b-3.d0)**(j-2) + total=total+term + endif + if(j.gt.0) then + term=d2ibdc2(k,l,m,n,2) + if(i.gt.0) term=term*(v1b-3.d0)**i + if(j.gt.1) term=j*term*(v2b-3.d0)**(j-1) + total=total+term + endif + d2udc2(k,l,m,n)=d2udc2(k,l,m,n)+total*coef + enddo + enddo + enddo +! + do mm=1,nelconst + nc=nc+1 + coef=constant(nc) + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + if(mm.eq.1) then + term=(2.d0*dibdc(k,l,3)*dibdc(m,n,3)+ + & 2.d0*(v3b-1.d0)*d2ibdc2(k,l,m,n,3))/coef + else + term= + & 2.d0*mm*(v3b-1.d0)**(2*mm-2)/coef* + & ((2*mm-1)*dibdc(k,l,3)*dibdc(m,n,3) + & +(v3b-1.d0)*d2ibdc2(k,l,m,n,3)) + endif + d2udc2(k,l,m,n)=d2udc2(k,l,m,n)+term + enddo + enddo + endif + endif +! +! Ogden form +! + if((kode.lt.-3).and.(kode.gt.-7)) then + if(kode.eq.-4) then + nelconst=1 + elseif(kode.eq.-5) then + nelconst=2 + elseif(kode.eq.-6) then + nelconst=3 + endif +! +! first derivative of U w.r.t. c(k,l) +! + do l=1,3 + do k=1,l + dudc(k,l)=0.d0 + enddo + enddo +! + do m=1,nelconst + coefa=constant(2*m) + coefd=constant(2*nelconst+m) + coefm=constant(2*m-1) + do l=1,3 + do k=1,l + term=0.d0 + do i=1,3 + term=term+alb(i)**(coefa-1.d0)*dlbdc(k,l,i) + enddo + dudc(k,l)=dudc(k,l)+2.d0*coefm/coefa + & *term+2.d0*m/coefd* + & (v3b-1.d0)**(2*m-1)*dibdc(k,l,3) + enddo + enddo + enddo +! +! tangent stiffness matrix +! second derivative of U w.r.t. c(k,l) and c(m,n) +! + if(icmd.ne.3) then + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2udc2(k,l,m,n)=0.d0 + enddo + do mm=1,nelconst + coefa=constant(2*mm) + coefd=constant(2*nelconst+mm) + coefm=constant(2*mm-1) + nt=0 + do jj=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + term=0.d0 + do i=1,3 + term=term+alb(i)**(coefa-2.d0)*dlbdc(k,l,i)* + & dlbdc(m,n,i) + enddo + term=term*(coefa-1.d0) + do i=1,3 + term=term+alb(i)**(coefa-1.d0) + & *d2lbdc2(k,l,m,n,i) + enddo + term=term*2.d0*coefm/coefa + d2udc2(k,l,m,n)=d2udc2(k,l,m,n)+term+(2*mm)* + & (2*mm-1)/coefd*(v3b-1.d0)**(2*mm-2)* + & dibdc(k,l,3)*dibdc(m,n,3)+2*mm/coefd + & *(v3b-1.d0)**(2*mm-1)*d2ibdc2(k,l,m,n,3) + enddo + enddo + endif + endif +! +! Arruda-Boyce model +! + if(kode.eq.-1) then + coef=constant(2) +! +! first derivative of U w.r.t. c(k,l) +! + do l=1,3 + do k=1,l + dudc(k,l)=constant(1)*(0.5d0+v1b/(10.d0* + & coef**2)+33.d0*v1b*v1b/(1050.d0* + & coef**4)+76.d0*v1b**3/(7000.d0* + & coef**6)+2595.d0*v1b**4/(673750.d0* + & coef**8))*dibdc(k,l,1)+(v3b-1.d0/v3b) + & *dibdc(k,l,3)/constant(3) + enddo + enddo +! +! tangent stiffness matrix +! second derivative of U w.r.t. c(k,l) and c(m,n) +! + if(icmd.ne.3) then + nt=0 + do jj=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2udc2(k,l,m,n)=constant(1)*(1.d0/(10.d0* + & coef**2)+66.d0*v1b/(1050.d0*coef**4)+228.d0 + & *v1b**2/(7000.d0*coef**6)+10380.d0*v1b**3/ + & (673750.d0*coef**8))*dibdc(k,l,1)*dibdc(m,n,1) + & +constant(1)*(0.5d0+v1b/(10.d0*coef**2) + & +33.d0*v1b**2/ + & (1050.d0*coef**4)+76.d0*v1b**3/(7000.d0*coef**6)+ + & 2595.d0*v1b**4/(673750.d0*coef**8)) + & *d2ibdc2(k,l,m,n,1) + & +(1.d0+1.d0/v3b**2)*dibdc(k,l,3)*dibdc(m,n,3)/ + & constant(3)+(v3b-1.d0/v3b)*d2ibdc2(k,l,m,n,3) + & /constant(3) + enddo + endif + endif +! +! elastomeric foam behavior +! + if((kode.lt.-15).and.(kode.gt.-18)) then + if(kode.eq.-15) then + nelconst=1 + elseif(kode.eq.-16) then + nelconst=2 + elseif(kode.eq.-17) then + nelconst=3 + endif +! +! first derivative of U w.r.t. c(k,l) +! + do l=1,3 + do k=1,l + dudc(k,l)=0.d0 + enddo + enddo +! + do m=1,nelconst + coefa=constant(2*m) + coefb=constant(2*nelconst+m)/(1.d0-2.d0 + & *constant(2*nelconst+m)) + coefm=constant(2*m-1) + do l=1,3 + do k=1,l + term=0.d0 + do i=1,3 + term=term+al(i)**(coefa-1.d0)*dldc(k,l,i) + enddo + dudc(k,l)=dudc(k,l)+2.d0*coefm/coefa + & *(term-v3b**(-coefa*coefb-1.d0)* + & dibdc(k,l,3)) + enddo + enddo + enddo +! +! tangent stiffness matrix +! second derivative of U w.r.t. c(k,l) and c(m,n) +! + if(icmd.ne.3) then + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2udc2(k,l,m,n)=0.d0 + enddo + do mm=1,nelconst + coefa=constant(2*mm) + coefb=constant(2*nelconst+mm)/(1.d0-2.d0 + & *constant(2*nelconst+mm)) + coefm=constant(2*mm-1) + nt=0 + do jj=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + term=0.d0 + do i=1,3 + term=term+(coefa-1.d0)*al(i)**(coefa-2.d0) + & *dldc(k,l,i)*dldc(m,n,i) + & +al(i)**(coefa-1.d0)*d2ldc2(k,l,m,n,i) + enddo + d2udc2(k,l,m,n)=d2udc2(k,l,m,n) + & +2.d0*coefm/ + & coefa*(term+(coefa*coefb+1.d0)*v3b + & **(-coefa*coefb-2.d0)*dibdc(k,l,3) + & *dibdc(m,n,3)-v3b**(-coefa*coefb-1.d0) + & *d2ibdc2(k,l,m,n,3)) + enddo + enddo + endif + endif +! +! storing the stiffness matrix and/or the stress +! + if(icmd.ne.3) then +! +! storing the stiffness matrix +! + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + elas(i)=4.d0*d2udc2(k,l,m,n) + enddo + endif +! +! store the stress at mechanical strain +! + stre(1)=2.d0*dudc(1,1) + stre(2)=2.d0*dudc(2,2) + stre(3)=2.d0*dudc(3,3) + stre(4)=2.d0*dudc(1,2) + stre(5)=2.d0*dudc(1,3) + stre(6)=2.d0*dudc(2,3) +! + enddo +! +c write(*,*) ' al ' +c write(*,'(4(1x,e19.12))') (al(i),i=1,3) +c write(*,*) ' all ' +c write(*,'(4(1x,e19.12))') (all(i),i=1,3) +c write(*,*) ' alb ' +c write(*,'(4(1x,e19.12))') (alb(i),i=1,3) +c write(*,*) ' dldc ' +c write(*,'(4(1x,e19.12))') (((dldc(i,j,k),i=1,3),j=1,3),k=1,3) +c write(*,*) ' d2ldc2 ' +c write(*,'(4(1x,e19.12))') (((((d2ldc2(i,j,k,l,m),i=1,3),j=1,3) +c & ,k=1,3),l=1,3),m=1,3) +c write(*,*) ' dlbdc ' +c write(*,'(4(1x,e19.12))') (((dlbdc(i,j,k),i=1,3),j=1,3),k=1,3) +c write(*,*) ' d2lbdc2 ' +c write(*,'(4(1x,e19.12))') (((((d2lbdc2(i,j,k,l,m),i=1,3),j=1,3) +c & ,k=1,3),l=1,3),m=1,3) +c write(*,*) ' elconloc ' +c write(*,'(4(1x,e19.12))') (elconloc(i),i=1,21) +c write(*,*) ' elas ' +c write(*,'(4(1x,e19.12))') (elas(i),i=1,21) +c write(*,*) ' dudc ' +c write(*,'(4(1x,e19.12))') (((dudc(i,j),i=1,3),j=1,3)) +c write(*,*) ' d2udc2 ' +c write(*,'(4(1x,e19.12))') (((((d2udc2(i,j,k,l),i=1,3),j=1,3) +c & ,k=1,3),l=1,3)) + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/saxpb.f calculix-ccx-2.3/ccx_2.3/src/saxpb.f --- calculix-ccx-2.1/ccx_2.3/src/saxpb.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/saxpb.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,28 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine saxpb(a,b,x,n,c) + implicit none + integer k,n + real*8 a(*),b(*),c(*),x +c....vector times scalar added to second vector + do 10 k = 1,n + c(k) = a(k)*x +b(k) +10 continue + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/scavenge_pump.f calculix-ccx-2.3/ccx_2.3/src/scavenge_pump.f --- calculix-ccx-2.1/ccx_2.3/src/scavenge_pump.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/scavenge_pump.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,56 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine scavenge_pump(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,r,physcon,dvi,numf,set,ntmat_,mi) +! +! scavenge pump element +! + implicit none +! + logical identity + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),numf,node1,node2,nodem, + & ielprop(*),nodef(5),idirf(5),index,iflag, + & ipkon(*),kon(*),mi(2),ntmat_ +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(5),kappa,cp,physcon(*) + & ,dvi,R +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1) then +! + elseif (iflag.eq.2) then +! + elseif (iflag.eq.3) then +! + endif + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/sdvini.f calculix-ccx-2.3/ccx_2.3/src/sdvini.f --- calculix-ccx-2.1/ccx_2.3/src/sdvini.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/sdvini.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,54 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine sdvini(statev,coords,nstatv,ncrds,noel,npt, + & layer,kspt) +! +! user subroutine sdvini +! +! +! INPUT: +! +! coords(1..3) global coordinates of the integration point +! nstatv number of internal variables (must be +! defined by the user with the *DEPVAR card) +! ncrds number of coordinates +! noel element number +! npt integration point number +! layer not used +! kspt not used +! +! OUTPUT: +! +! statev(1..nstatv) initial value of the internal state +! variables +! + implicit none +! + integer nstatv,ncrds,noel,npt,layer,kspt,i +! + real*8 statev(nstatv),coords(ncrds) +! +! code for retrieving the internal state variables +! + do i=1,13 + statev(i)=1.d0 + enddo + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/selcycsymmods.f calculix-ccx-2.3/ccx_2.3/src/selcycsymmods.f --- calculix-ccx-2.1/ccx_2.3/src/selcycsymmods.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/selcycsymmods.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,389 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine selcycsymmods(inpc,textpart,cs,ics,tieset,istartset, + & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc,ilmpc, + & mpcfree,mcs,set,nset,labmpc,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,nmethod,key,ipoinpc) +! +! reading the input deck: *SELECT CYCLIC SYMMETRY MODES +! + implicit none +! + character*1 inpc(*) + character*20 labmpc(*) + character*81 set(*),leftset,tieset(3,*) + character*132 textpart(16) +! + integer istep,istat,n,key,i,ns(5),ics(*),istartset(*), + & iendset(*),ialset(*),id,ipompc(*),nodempc(3,*),nmpc,nmpc_, + & ikmpc(*),ilmpc(*),mpcfree,i1(2),i2(2),i3,i4,i5,j,k, + & mpcfreeold,idof,node,ileft,nset,irepeat,ipoinpc(0:*), + & mpc,iline,ipol,inl,ipoinp(2,*),inp(3,*),mcs,lprev,ij,nmethod +! + real*8 coefmpc(*),csab(7),x1(2),x2(2),x3,x4,x5,dd,xn,yn,zn, + & cs(17,*) +! +! irepeat indicates whether the step was preceded by another +! cyclic symmetry step (irepeat=1) or not (irepeat=0) +! + data irepeat /0/ + save irepeat +! + if(istep.eq.0) then + write(*,*)'*ERROR in selcycsymmods:' + write(*,*)' *SELECT CYCLIC SYMMETRY MODES' + write(*,*)' should be placed within a step definition' + stop + endif +! +! check whether in case of cyclic symmetry the frequency procedure +! is chosen +! + if(nmethod.ne.2) then + write(*,*) '*ERROR in selcycsymmods: the only valid procedure' + write(*,*) ' for cyclic symmetry calculations' + write(*,*) ' with nodal diameters is *FREQUENCY' + stop + endif +! + ns(2)=0 + ns(3)=0 +! + do i=2,n + if(textpart(i)(1:5).eq.'NMIN=') then + read(textpart(i)(6:15),'(i10)',iostat=istat) ns(2) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:5).eq.'NMAX=') then + read(textpart(i)(6:15),'(i10)',iostat=istat) ns(3) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + write(*,*) + & '*WARNING in selcycsymmods: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! check the input +! + if(ns(2).lt.0) then + ns(2)=0 + write(*,*) '*WARNING in selcycsymmods: minimum nodal' + write(*,*) ' diameter must be nonnegative' + endif + if(ns(3).lt.ns(2)) then + write(*,*) '*ERROR in selcycsymmods: maximum nodal' + write(*,*) ' diameter should not exceed minimal one' + stop + endif +! +! loop over all cyclic symmetry parts +! + do ij=1,mcs + ns(1)=int(cs(1,ij)) + ns(4)=int(cs(4,ij)) + leftset=tieset(2,int(cs(17,ij))) + lprev=int(cs(14,ij)) + do i=1,7 + csab(i)=cs(5+i,ij) + enddo +! +! check whether cyclic symmetry axis is part of the structure +! + do i=1,nset + if(set(i).eq.leftset) exit + enddo + ileft=i +! +! if this step was preceded by a cyclic symmetry step: +! check for MPC's for nodes on the cyclic symmetry axis +! and delete them +! + if(irepeat.eq.1) then + do i=1,ns(4) + node=ics(lprev+i) + if(node.lt.0) then + node=-node + do k=1,3 + idof=8*(node-1)+k + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then +c write(*,*) 'removing MPC',node,k + mpc=ilmpc(id) + call mpcrem(mpc,mpcfree,nodempc,nmpc,ikmpc, + & ilmpc,labmpc,coefmpc,ipompc) + endif + endif + enddo + endif + enddo + endif +! + do i=1,ns(4) + node=ics(lprev+i) + if(node.lt.0) then + node=-node + if(ns(2).ne.ns(3)) then + if((ns(2).eq.0).or.(ns(2).eq.1)) then + write(*,*) '*ERROR: axis of cyclic symmetry' + write(*,*) ' is part of the structure;' + write(*,*) ' nodal diameters 0, 1, and' + write(*,*) ' those above must be each in' + write(*,*) ' separate steps.' + stop + endif + endif +! +! specifying special MPC's for nodes on the axis +! +! normal along the axis +! + xn=csab(4)-csab(1) + yn=csab(5)-csab(2) + zn=csab(6)-csab(3) + dd=dsqrt(xn*xn+yn*yn+zn*zn) + xn=xn/dd + yn=yn/dd + zn=zn/dd +! +! nodal diameter 0 +! + if(ns(2).eq.0) then + if(dabs(xn).gt.1.d-10) then + i1(1)=2 + i1(2)=3 + i2(1)=1 + i2(2)=1 + x1(1)=xn + x1(2)=xn + x2(1)=-yn + x2(2)=-zn + elseif(dabs(yn).gt.1.d-10) then + i1(1)=1 + i1(2)=3 + i2(1)=2 + i2(2)=2 + x1(1)=yn + x1(2)=yn + x2(1)=-xn + x2(2)=-zn + elseif(dabs(zn).gt.1.d-10) then + i1(1)=1 + i1(2)=2 + i2(1)=3 + i2(2)=3 + x1(1)=zn + x1(2)=zn + x2(1)=-xn + x2(2)=-yn + endif +! +! generating two MPC's expressing that the nodes cannot +! move in planes perpendicular to the cyclic symmetry +! axis +! + do k=1,2 + idof=8*(node-1)+i1(k) + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*ERROR in selcycsymmods:' + write(*,*) ' node',node, + & ' on cyclic symmetry' + write(*,*) ' axis is used in other MPC' + stop + endif + endif + nmpc=nmpc+1 + ipompc(nmpc)=mpcfree + labmpc(nmpc)=' ' +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=i1(k) + coefmpc(mpcfree)=x1(k) + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) '*ERROR in selcycsymmods:' + write(*,*) ' increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=i2(k) + coefmpc(mpcfree)=x2(k) + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) '*ERROR in selcycsymmods:' + write(*,*) ' increase nmpc_' + stop + endif + nodempc(3,mpcfreeold)=0 + enddo + elseif(ns(2).eq.1) then +! +! nodal diameter 1 +! + if(dabs(xn).gt.1.d-10) then + i3=1 + i4=2 + i5=3 + x3=xn + x4=yn + x5=zn + elseif(dabs(yn).gt.1.d-10) then + i3=2 + i4=2 + i5=3 + x3=yn + x4=xn + x5=zn + else + i3=3 + i4=1 + i5=2 + x3=zn + x4=xn + x5=yn + endif +! +! generating one MPC expressing that the nodes should +! not move along the axis +! + idof=8*(node-1)+i3 + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*ERROR in selcycsymmods:' + write(*,*) ' node',node, + & ' on cyclic symmetry' + write(*,*) ' axis is used in other MPC' + stop + endif + endif + nmpc=nmpc+1 + ipompc(nmpc)=mpcfree + labmpc(nmpc)=' ' +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=i3 + coefmpc(mpcfree)=x3 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) '*ERROR in selcycsymmods:' + write(*,*) ' increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=i4 + coefmpc(mpcfree)=x4 + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) '*ERROR in selcycsymmods:' + write(*,*) ' increase nmpc_' + stop + endif + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=i5 + coefmpc(mpcfree)=x5 + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) '*ERROR in selcycsymmods:' + write(*,*) ' increase nmpc_' + stop + endif + nodempc(3,mpcfreeold)=0 + else + do k=1,3 + idof=8*(node-1)+k + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*ERROR in selcycsymmods:' + write(*,*) ' node',node, + & ' on cyclic symmetry' + write(*,*) ' axis is used in other MPC' + stop + endif + endif + nmpc=nmpc+1 + ipompc(nmpc)=mpcfree + labmpc(nmpc)=' ' +! +! updating ikmpc and ilmpc +! + do j=nmpc,id+2,-1 + ikmpc(j)=ikmpc(j-1) + ilmpc(j)=ilmpc(j-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=k + coefmpc(mpcfree)=1.d0 + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + if(mpcfree.eq.0) then + write(*,*) '*ERROR in selcycsymmods:' + write(*,*) ' increase nmpc_' + stop + endif + nodempc(3,mpcfreeold)=0 + enddo + endif + endif + enddo +! + cs(2,ij)=ns(2)+0.5 + cs(3,ij)=ns(3)+0.5 + enddo +! + if(irepeat.eq.0) irepeat=1 +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! +c do j=1,nmpc +c call writempc(ipompc,nodempc,coefmpc,labmpc,j) +c enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/sgi.c calculix-ccx-2.3/ccx_2.3/src/sgi.c --- calculix-ccx-2.1/ccx_2.3/src/sgi.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/sgi.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,130 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifdef SGI + +#include +#include +#include +#include "CalculiX.h" +#include "sgi.h" + +int *irowsgi=NULL; +double *ausgi=NULL; + +void sgi_factor(double *ad, double *au, double *adb, double *aub, + double *sigma,int *icol, int *irow, + int *neq, int *nzs, int token){ + + char *oocpath="/yatmp/scr1",*env; + int i,j,k,l,*pointers=NULL,method; + long long ndim; + double ops=0,ooclimit=2000.; + + printf(" Factoring the system of equations using the sgi solver\n\n"); + + env=getenv("CCX_OOC_MEM"); + if(env) ooclimit=atoi(env); + + ndim=*neq+*nzs; + + pointers=NNEW(int,*neq+1); + irowsgi=NNEW(int,ndim); + ausgi=NNEW(double,ndim); + + k=ndim; + l=*nzs; + + if(*sigma==0.){ + pointers[*neq]=ndim; + for(i=*neq-1;i>=0;--i){ + for(j=0;j=0;--i){ + for(j=0;j200000){ + printf(" The out of core solver is used\n\n"); + DPSLDLT_OOCLimit(token,ooclimit); + DPSLDLT_OOCPath(token,oocpath); + DPSLDLT_FactorOOC(token,*neq,pointers,irowsgi,ausgi); + } + else{ + DPSLDLT_Factor(token,*neq,pointers,irowsgi,ausgi); + } + + free(pointers); + + return; +} + +void sgi_solve(double *b,int token){ + + DPSLDLT_Solve(token,b,b); + + return; +} + +void sgi_cleanup(int token){ + + DPSLDLT_Destroy(token); + free(irowsgi); + free(ausgi); + + return; +} + +void sgi_main(double *ad, double *au, double *adb, double *aub, double *sigma, + double *b, int *icol, int *irow, + int *neq, int *nzs, int token){ + + if(*neq==0) return; + + sgi_factor(ad,au,adb,aub,sigma,icol,irow, + neq,nzs,token); + + sgi_solve(b,token); + + sgi_cleanup(token); + + return; +} + +#endif + diff -Nru calculix-ccx-2.1/ccx_2.3/src/sgi.h calculix-ccx-2.3/ccx_2.3/src/sgi.h --- calculix-ccx-2.1/ccx_2.3/src/sgi.h 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/sgi.h 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,32 @@ +/* CALCULIX - A 3-dimensional finite element program */ +/* Copyright (C) 1998 Guido Dhondt */ +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation; either version 2 of */ +/* the License, or (at your option) any later version. */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include + +void sgi_main(double *ad, double *au, double *adb, double *aub, double *sigma, + double *b, int *icol, int *irow, + int *neq, int *nzs, int token); + +void sgi_factor(double *ad, double *au, double *adb, double *aub, + double *sigma,int *icol, int *irow, + int *neq, int *nzs, int token); + +void sgi_solve(double *b,int token); + +void sgi_cleanup(int token); + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape10tet.f calculix-ccx-2.3/ccx_2.3/src/shape10tet.f --- calculix-ccx-2.1/ccx_2.3/src/shape10tet.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape10tet.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,141 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape10tet(xi,et,ze,xl,xsj,shp,iflag) +! +! shape functions and derivatives for a 10-node quadratic +! isoparametric tetrahedral element. 0<=xi,et,ze<=1,xi+et+ze<=1. +! +! iflag=1: calculate only the value of the shape functions +! iflag=2: calculate the value of the shape functions and +! the Jacobian determinant +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian determinant +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,10),xs(3,3),xsi(3,3),xl(3,10),sh(3) +! + real*8 xi,et,ze,xsj,a +! +! shape functions and their glocal derivatives +! +! shape functions +! + a=1.d0-xi-et-ze + shp(4, 1)=(2.d0*a-1.d0)*a + shp(4, 2)=xi*(2.d0*xi-1.d0) + shp(4, 3)=et*(2.d0*et-1.d0) + shp(4, 4)=ze*(2.d0*ze-1.d0) + shp(4, 5)=4.d0*xi*a + shp(4, 6)=4.d0*xi*et + shp(4, 7)=4.d0*et*a + shp(4, 8)=4.d0*ze*a + shp(4, 9)=4.d0*xi*ze + shp(4,10)=4.d0*et*ze +! + if(iflag.eq.1) return +! +! local derivatives of the shape functions: xi-derivative +! + shp(1, 1)=1.d0-4.d0*(1.d0-xi-et-ze) + shp(1, 2)=4.d0*xi-1.d0 + shp(1, 3)=0.d0 + shp(1, 4)=0.d0 + shp(1, 5)=4.d0*(1.d0-2.d0*xi-et-ze) + shp(1, 6)=4.d0*et + shp(1, 7)=-4.d0*et + shp(1, 8)=-4.d0*ze + shp(1, 9)=4.d0*ze + shp(1,10)=0.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2, 1)=1.d0-4.d0*(1.d0-xi-et-ze) + shp(2, 2)=0.d0 + shp(2, 3)=4.d0*et-1.d0 + shp(2, 4)=0.d0 + shp(2, 5)=-4.d0*xi + shp(2, 6)=4.d0*xi + shp(2, 7)=4.d0*(1.d0-xi-2.d0*et-ze) + shp(2, 8)=-4.d0*ze + shp(2, 9)=0.d0 + shp(2,10)=4.d0*ze +! +! local derivatives of the shape functions: zeta-derivative +! + shp(3, 1)=1.d0-4.d0*(1.d0-xi-et-ze) + shp(3, 2)=0.d0 + shp(3, 3)=0.d0 + shp(3, 4)=4.d0*ze-1.d0 + shp(3, 5)=-4.d0*xi + shp(3, 6)=0.d0 + shp(3, 7)=-4.d0*et + shp(3, 8)=4.d0*(1.d0-xi-et-2.d0*ze) + shp(3, 9)=4.d0*xi + shp(3,10)=4.d0*et +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,10 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant +! + xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) + & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) + & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj + xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj + xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj + xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj + xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj + xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj + xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj + xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj + xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj +! +! computation of the global derivatives of the shape functions +! + do k=1,10 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape15w.f calculix-ccx-2.3/ccx_2.3/src/shape15w.f --- calculix-ccx-2.1/ccx_2.3/src/shape15w.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape15w.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,167 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape15w(xi,et,ze,xl,xsj,shp,iflag) +! +! shape functions and derivatives for a 15-node quadratic +! isoparametric wedge element. 0<=xi,et<=1,-1<=ze<=1,xi+et<=1. +! +! iflag=1: calculate only the value of the shape functions +! iflag=2: calculate the value of the shape functions and +! the Jacobian determinant +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian determinant +! +! +! Copyright (c) 2003 WB +! +! Written February 2003 on the basis of the Guido's shape function files +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,15),xs(3,3),xsi(3,3),xl(3,15),sh(3) +! + real*8 xi,et,ze,xsj,a +! +! shape functions and their glocal derivatives +! + a=1.d0-xi-et +! +! shape functions +! + shp(4, 1)=-0.5*a*(1.0-ze)*(2.0*xi+2.0*et+ze) + shp(4, 2)=0.5*xi*(1.0-ze)*(2.0*xi-2.0-ze) + shp(4, 3)=0.5*et*(1.0-ze)*(2.0*et-2.0-ze) + shp(4, 4)=-0.5*a*(1.0+ze)*(2.0*xi+2.0*et-ze) + shp(4, 5)=0.5*xi*(1.0+ze)*(2.0*xi-2.0+ze) + shp(4, 6)=0.5*et*(1.0+ze)*(2.0*et-2.0+ze) + shp(4, 7)=2.0*xi*a*(1.0-ze) + shp(4, 8)=2.0*xi*et*(1.0-ze) + shp(4, 9)=2.0*et*a*(1.0-ze) + shp(4, 10)=2.0*xi*a*(1.0+ze) + shp(4, 11)=2.0*xi*et*(1.0+ze) + shp(4, 12)=2.0*et*a*(1.0+ze) + shp(4, 13)= a*(1.0-ze*ze) + shp(4, 14)=xi*(1.0-ze*ze) + shp(4, 15)=et*(1.0-ze*ze) +! + if(iflag.eq.1) return +! +! local derivatives of the shape functions: xi-derivative +! + shp(1, 1)= 0.5*(1.0-ze)*(4.0*xi+4.0*et+ze-2.0) + shp(1, 2)= 0.5*(1.0-ze)*(4.0*xi-ze-2.0) + shp(1, 3)= 0.d0 + shp(1, 4)= 0.5*(1.0+ze)*(4.0*xi+4.0*et-ze-2.0) + shp(1, 5)= 0.5*(1.0+ze)*(4.0*xi+ze-2.0) + shp(1, 6)= 0.d0 + shp(1, 7)= 2.0*(1.0-ze)*(1.0-2.0*xi-et) + shp(1, 8)= 2.0*et*(1.0-ze) + shp(1, 9)= -2.0*et*(1.0-ze) + shp(1, 10)= 2.0*(1.0+ze)*(1.0-2.0*xi-et) + shp(1, 11)= 2.0*et*(1.0+ze) + shp(1, 12)= -2.0*et*(1.0+ze) + shp(1, 13)= -(1.0-ze*ze) + shp(1, 14)= (1.0-ze*ze) + shp(1, 15)= 0.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2, 1)= 0.5*(1.0-ze)*(4.0*xi+4.0*et+ze-2.0) + shp(2, 2)= 0.d0 + shp(2, 3)= 0.5*(1.0-ze)*(4.0*et-ze-2.0) + shp(2, 4)= 0.5*(1.0+ze)*(4.0*xi+4.0*et-ze-2.0) + shp(2, 5)= 0.d0 + shp(2, 6)= 0.5*(1.0+ze)*(4.0*et+ze-2.0) + shp(2, 7)=-2.0*xi*(1.0-ze) + shp(2, 8)= 2.0*xi*(1.0-ze) + shp(2, 9)= 2.0*(1.0-ze)*(1.0-xi-2.0*et) + shp(2, 10)=-2.0*xi*(1.0+ze) + shp(2, 11)= 2.0*xi*(1.0+ze) + shp(2, 12)= 2.0*(1.0+ze)*(1.0-xi-2.0*et) + shp(2, 13)=-(1.0-ze*ze) + shp(2, 14)= 0.0d0 + shp(2, 15)= (1.0-ze*ze) +! +! local derivatives of the shape functions: zeta-derivative +! + shp(3, 1)= a*(xi+et+ze-0.5) + shp(3, 2)= xi*(-xi+ze+0.5) + shp(3, 3)= et*(-et+ze+0.5) + shp(3, 4)= a*(-xi-et+ze+0.5) + shp(3, 5)= xi*(xi+ze-0.5) + shp(3, 6)= et*(et+ze-0.5) + shp(3, 7)= -2*xi*a + shp(3, 8)= -2*xi*et + shp(3, 9)= -2*et*a + shp(3, 10)= 2*xi*a + shp(3, 11)= 2*xi*et + shp(3, 12)= 2*et*a + shp(3, 13)=-2*a*ze + shp(3, 14)=-2*xi*ze + shp(3, 15)=-2*et*ze +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,15 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant +! + xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) + & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) + & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj + xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj + xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj + xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj + xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj + xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj + xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj + xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj + xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj +! +! computation of the global derivatives of the shape functions +! + do k=1,15 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape20h_ax.f calculix-ccx-2.3/ccx_2.3/src/shape20h_ax.f --- calculix-ccx-2.1/ccx_2.3/src/shape20h_ax.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape20h_ax.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,246 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape20h_ax(xi,et,ze,xl,xsj,shp,iflag) +! +! shape functions and derivatives for a 20-node quadratic +! isoparametric brick element. -1<=xi,et,ze<=1 +! special case: axisymmetric elements +! +! iflag=1: calculate only the value of the shape functions +! iflag=2: calculate the value of the shape functions and +! the Jacobian determinant +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian determinant +! + implicit none +! + integer j,k,iflag +! + real*8 shp(4,20),xs(3,3),xsi(3,3),xl(3,20),shpe(4,20),dd, + & dd1,dd2,dd3 +! + real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr, + & tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr, + & omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr +! +! shape functions and their glocal derivatives +! + omg=1.d0-xi + omh=1.d0-et + omr=1.d0-ze + opg=1.d0+xi + oph=1.d0+et + opr=1.d0+ze + tpgphpr=opg+oph+ze + tmgphpr=omg+oph+ze + tmgmhpr=omg+omh+ze + tpgmhpr=opg+omh+ze + tpgphmr=opg+oph-ze + tmgphmr=omg+oph-ze + tmgmhmr=omg+omh-ze + tpgmhmr=opg+omh-ze + omgopg=omg*opg/4.d0 + omhoph=omh*oph/4.d0 + omropr=omr*opr/4.d0 + omgmopg=(omg-opg)/4.d0 + omhmoph=(omh-oph)/4.d0 + omrmopr=(omr-opr)/4.d0 +! +! shape functions +! + shp(4, 1)=-omg*omh*omr*tpgphpr/8.d0 + shp(4, 2)=-opg*omh*omr*tmgphpr/8.d0 + shp(4, 3)=-opg*oph*omr*tmgmhpr/8.d0 + shp(4, 4)=-omg*oph*omr*tpgmhpr/8.d0 + shp(4, 5)=-omg*omh*opr*tpgphmr/8.d0 + shp(4, 6)=-opg*omh*opr*tmgphmr/8.d0 + shp(4, 7)=-opg*oph*opr*tmgmhmr/8.d0 + shp(4, 8)=-omg*oph*opr*tpgmhmr/8.d0 + shp(4, 9)=omgopg*omh*omr + shp(4,10)=omhoph*opg*omr + shp(4,11)=omgopg*oph*omr + shp(4,12)=omhoph*omg*omr + shp(4,13)=omgopg*omh*opr + shp(4,14)=omhoph*opg*opr + shp(4,15)=omgopg*oph*opr + shp(4,16)=omhoph*omg*opr + shp(4,17)=omropr*omg*omh + shp(4,18)=omropr*opg*omh + shp(4,19)=omropr*opg*oph + shp(4,20)=omropr*omg*oph +! + if(iflag.eq.1) return +! +! local derivatives of the shape functions: xi-derivative +! + shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0 + shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0 + shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0 + shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0 + shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0 + shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0 + shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0 + shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0 + shpe(1, 9)=omgmopg*omh*omr + shpe(1,10)=omhoph*omr + shpe(1,11)=omgmopg*oph*omr + shpe(1,12)=-omhoph*omr + shpe(1,13)=omgmopg*omh*opr + shpe(1,14)=omhoph*opr + shpe(1,15)=omgmopg*oph*opr + shpe(1,16)=-omhoph*opr + shpe(1,17)=-omropr*omh + shpe(1,18)=omropr*omh + shpe(1,19)=omropr*oph + shpe(1,20)=-omropr*oph +! +! local derivatives of the shape functions: eta-derivative +! + shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0 + shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0 + shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0 + shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0 + shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0 + shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0 + shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0 + shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0 + shpe(2, 9)=-omgopg*omr + shpe(2,10)=omhmoph*opg*omr + shpe(2,11)=omgopg*omr + shpe(2,12)=omhmoph*omg*omr + shpe(2,13)=-omgopg*opr + shpe(2,14)=omhmoph*opg*opr + shpe(2,15)=omgopg*opr + shpe(2,16)=omhmoph*omg*opr + shpe(2,17)=-omropr*omg + shpe(2,18)=-omropr*opg + shpe(2,19)=omropr*opg + shpe(2,20)=omropr*omg +! +! local derivatives of the shape functions: zeta-derivative +! + shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0 + shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0 + shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0 + shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0 + shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0 + shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0 + shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0 + shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0 + shpe(3, 9)=-omgopg*omh + shpe(3,10)=-omhoph*opg + shpe(3,11)=-omgopg*oph + shpe(3,12)=-omhoph*omg + shpe(3,13)=omgopg*omh + shpe(3,14)=omhoph*opg + shpe(3,15)=omgopg*oph + shpe(3,16)=omhoph*omg + shpe(3,17)=omrmopr*omg*omh + shpe(3,18)=omrmopr*opg*omh + shpe(3,19)=omrmopr*opg*oph + shpe(3,20)=omrmopr*omg*oph +! +! computation of the local derivative of the global coordinates +! (xs) +! +c do i=1,3 +c do j=1,3 +c xs(i,j)=0.d0 +c do k=1,20 +c xs(i,j)=xs(i,j)+xl(i,k)*shpe(j,k) +c enddo +c enddo +c enddo + do j=1,3 + xs(1,j)=xl(1,1)*(shpe(j,1)+shpe(j,5)) + & +xl(1,2)*(shpe(j,2)+shpe(j,6)) + & +xl(1,3)*(shpe(j,3)+shpe(j,7)) + & +xl(1,4)*(shpe(j,4)+shpe(j,8)) + & +xl(1,9)*(shpe(j,9)+shpe(j,13)) + & +xl(1,10)*(shpe(j,10)+shpe(j,14)) + & +xl(1,11)*(shpe(j,11)+shpe(j,15)) + & +xl(1,12)*(shpe(j,12)+shpe(j,16)) + & +xl(1,17)*shpe(j,17)+xl(1,18)*shpe(j,18) + & +xl(1,19)*shpe(j,19)+xl(1,20)*shpe(j,20) + xs(2,j)=xl(2,1)*(shpe(j,1)+shpe(j,5)+shpe(j,17)) + & +xl(2,2)*(shpe(j,2)+shpe(j,6)+shpe(j,18)) + & +xl(2,3)*(shpe(j,3)+shpe(j,7)+shpe(j,19)) + & +xl(2,4)*(shpe(j,4)+shpe(j,8)+shpe(j,20)) + & +xl(2,9)*(shpe(j,9)+shpe(j,13)) + & +xl(2,10)*(shpe(j,10)+shpe(j,14)) + & +xl(2,11)*(shpe(j,11)+shpe(j,15)) + & +xl(2,12)*(shpe(j,12)+shpe(j,16)) + xs(3,j)=xl(3,1)*(shpe(j,1)-shpe(j,5)) + & +xl(3,2)*(shpe(j,2)-shpe(j,6)) + & +xl(3,3)*(shpe(j,3)-shpe(j,7)) + & +xl(3,4)*(shpe(j,4)-shpe(j,8)) + & +xl(3,9)*(shpe(j,9)-shpe(j,13)) + & +xl(3,10)*(shpe(j,10)-shpe(j,14)) + & +xl(3,11)*(shpe(j,11)-shpe(j,15)) + & +xl(3,12)*(shpe(j,12)-shpe(j,16)) + enddo +! +! computation of the jacobian determinant +! + dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2) + dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3) + dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1) + xsj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3 +c xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) +c & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) +c & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) +! + if(iflag.eq.2) return +! + dd=1.d0/xsj +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=dd1*dd + xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd + xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd + xsi(2,1)=dd2*dd + xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd + xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd + xsi(3,1)=dd3*dd + xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd + xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd +c xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))*dd +c xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd +c xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd +c xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))*dd +c xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd +c xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd +c xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))*dd +c xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd +c xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd +! +! computation of the global derivatives of the shape functions +! + do k=1,20 + do j=1,3 + shp(j,k)=shpe(1,k)*xsi(1,j)+shpe(2,k)*xsi(2,j) + & +shpe(3,k)*xsi(3,j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape20h.f calculix-ccx-2.3/ccx_2.3/src/shape20h.f --- calculix-ccx-2.1/ccx_2.3/src/shape20h.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape20h.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,210 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape20h(xi,et,ze,xl,xsj,shp,iflag) +! +! shape functions and derivatives for a 20-node quadratic +! isoparametric brick element. -1<=xi,et,ze<=1 +! +! iflag=1: calculate only the value of the shape functions +! iflag=2: calculate the value of the shape functions and +! the Jacobian determinant +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian determinant +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,20),xs(3,3),xsi(3,3),xl(3,20),shpe(4,20),dd, + & dd1,dd2,dd3 +! + real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr, + & tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr, + & omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr +! +! shape functions and their glocal derivatives +! + omg=1.d0-xi + omh=1.d0-et + omr=1.d0-ze + opg=1.d0+xi + oph=1.d0+et + opr=1.d0+ze + tpgphpr=opg+oph+ze + tmgphpr=omg+oph+ze + tmgmhpr=omg+omh+ze + tpgmhpr=opg+omh+ze + tpgphmr=opg+oph-ze + tmgphmr=omg+oph-ze + tmgmhmr=omg+omh-ze + tpgmhmr=opg+omh-ze + omgopg=omg*opg/4.d0 + omhoph=omh*oph/4.d0 + omropr=omr*opr/4.d0 + omgmopg=(omg-opg)/4.d0 + omhmoph=(omh-oph)/4.d0 + omrmopr=(omr-opr)/4.d0 +! +! shape functions +! + shp(4, 1)=-omg*omh*omr*tpgphpr/8.d0 + shp(4, 2)=-opg*omh*omr*tmgphpr/8.d0 + shp(4, 3)=-opg*oph*omr*tmgmhpr/8.d0 + shp(4, 4)=-omg*oph*omr*tpgmhpr/8.d0 + shp(4, 5)=-omg*omh*opr*tpgphmr/8.d0 + shp(4, 6)=-opg*omh*opr*tmgphmr/8.d0 + shp(4, 7)=-opg*oph*opr*tmgmhmr/8.d0 + shp(4, 8)=-omg*oph*opr*tpgmhmr/8.d0 + shp(4, 9)=omgopg*omh*omr + shp(4,10)=omhoph*opg*omr + shp(4,11)=omgopg*oph*omr + shp(4,12)=omhoph*omg*omr + shp(4,13)=omgopg*omh*opr + shp(4,14)=omhoph*opg*opr + shp(4,15)=omgopg*oph*opr + shp(4,16)=omhoph*omg*opr + shp(4,17)=omropr*omg*omh + shp(4,18)=omropr*opg*omh + shp(4,19)=omropr*opg*oph + shp(4,20)=omropr*omg*oph +! + if(iflag.eq.1) return +! +! local derivatives of the shape functions: xi-derivative +! + shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0 + shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0 + shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0 + shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0 + shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0 + shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0 + shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0 + shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0 + shpe(1, 9)=omgmopg*omh*omr + shpe(1,10)=omhoph*omr + shpe(1,11)=omgmopg*oph*omr + shpe(1,12)=-omhoph*omr + shpe(1,13)=omgmopg*omh*opr + shpe(1,14)=omhoph*opr + shpe(1,15)=omgmopg*oph*opr + shpe(1,16)=-omhoph*opr + shpe(1,17)=-omropr*omh + shpe(1,18)=omropr*omh + shpe(1,19)=omropr*oph + shpe(1,20)=-omropr*oph +! +! local derivatives of the shape functions: eta-derivative +! + shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0 + shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0 + shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0 + shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0 + shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0 + shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0 + shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0 + shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0 + shpe(2, 9)=-omgopg*omr + shpe(2,10)=omhmoph*opg*omr + shpe(2,11)=omgopg*omr + shpe(2,12)=omhmoph*omg*omr + shpe(2,13)=-omgopg*opr + shpe(2,14)=omhmoph*opg*opr + shpe(2,15)=omgopg*opr + shpe(2,16)=omhmoph*omg*opr + shpe(2,17)=-omropr*omg + shpe(2,18)=-omropr*opg + shpe(2,19)=omropr*opg + shpe(2,20)=omropr*omg +! +! local derivatives of the shape functions: zeta-derivative +! + shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0 + shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0 + shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0 + shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0 + shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0 + shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0 + shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0 + shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0 + shpe(3, 9)=-omgopg*omh + shpe(3,10)=-omhoph*opg + shpe(3,11)=-omgopg*oph + shpe(3,12)=-omhoph*omg + shpe(3,13)=omgopg*omh + shpe(3,14)=omhoph*opg + shpe(3,15)=omgopg*oph + shpe(3,16)=omhoph*omg + shpe(3,17)=omrmopr*omg*omh + shpe(3,18)=omrmopr*opg*omh + shpe(3,19)=omrmopr*opg*oph + shpe(3,20)=omrmopr*omg*oph +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,20 + xs(i,j)=xs(i,j)+xl(i,k)*shpe(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant +! + dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2) + dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3) + dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1) + xsj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3 +! + if(iflag.eq.2) return +! + dd=1.d0/xsj +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=dd1*dd + xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd + xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd + xsi(2,1)=dd2*dd + xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd + xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd + xsi(3,1)=dd3*dd + xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd + xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd +! +! computation of the global derivatives of the shape functions +! + do k=1,20 + do j=1,3 + shp(j,k)=shpe(1,k)*xsi(1,j)+shpe(2,k)*xsi(2,j) + & +shpe(3,k)*xsi(3,j) + enddo + enddo +c do k=1,20 +c do j=1,3 +c shp(j,k)=shpe(j,k) +c enddo +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape20h_pl.f calculix-ccx-2.3/ccx_2.3/src/shape20h_pl.f --- calculix-ccx-2.1/ccx_2.3/src/shape20h_pl.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape20h_pl.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,244 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape20h_pl(xi,et,ze,xl,xsj,shp,iflag) +! +! shape functions and derivatives for a 20-node quadratic +! isoparametric brick element. -1<=xi,et,ze<=1 +! special case: plane stress and plane strain elements +! +! iflag=1: calculate only the value of the shape functions +! iflag=2: calculate the value of the shape functions and +! the Jacobian determinant +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian determinant +! + implicit none +! + integer j,k,iflag +! + real*8 shp(4,20),xs(3,3),xsi(3,3),xl(3,20),shpe(4,20),dd, + & dd1,dd2,dd3 +! + real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr, + & tpgphpr,tmgphpr,tmgmhpr,tpgmhpr,tpgphmr,tmgphmr,tmgmhmr,tpgmhmr, + & omgopg,omhoph,omropr,omgmopg,omhmoph,omrmopr +! +! shape functions and their glocal derivatives +! + omg=1.d0-xi + omh=1.d0-et + omr=1.d0-ze + opg=1.d0+xi + oph=1.d0+et + opr=1.d0+ze + tpgphpr=opg+oph+ze + tmgphpr=omg+oph+ze + tmgmhpr=omg+omh+ze + tpgmhpr=opg+omh+ze + tpgphmr=opg+oph-ze + tmgphmr=omg+oph-ze + tmgmhmr=omg+omh-ze + tpgmhmr=opg+omh-ze + omgopg=omg*opg/4.d0 + omhoph=omh*oph/4.d0 + omropr=omr*opr/4.d0 + omgmopg=(omg-opg)/4.d0 + omhmoph=(omh-oph)/4.d0 + omrmopr=(omr-opr)/4.d0 +! +! shape functions +! + shp(4, 1)=-omg*omh*omr*tpgphpr/8.d0 + shp(4, 2)=-opg*omh*omr*tmgphpr/8.d0 + shp(4, 3)=-opg*oph*omr*tmgmhpr/8.d0 + shp(4, 4)=-omg*oph*omr*tpgmhpr/8.d0 + shp(4, 5)=-omg*omh*opr*tpgphmr/8.d0 + shp(4, 6)=-opg*omh*opr*tmgphmr/8.d0 + shp(4, 7)=-opg*oph*opr*tmgmhmr/8.d0 + shp(4, 8)=-omg*oph*opr*tpgmhmr/8.d0 + shp(4, 9)=omgopg*omh*omr + shp(4,10)=omhoph*opg*omr + shp(4,11)=omgopg*oph*omr + shp(4,12)=omhoph*omg*omr + shp(4,13)=omgopg*omh*opr + shp(4,14)=omhoph*opg*opr + shp(4,15)=omgopg*oph*opr + shp(4,16)=omhoph*omg*opr + shp(4,17)=omropr*omg*omh + shp(4,18)=omropr*opg*omh + shp(4,19)=omropr*opg*oph + shp(4,20)=omropr*omg*oph +! + if(iflag.eq.1) return +! +! local derivatives of the shape functions: xi-derivative +! + shpe(1, 1)=omh*omr*(tpgphpr-omg)/8.d0 + shpe(1, 2)=(opg-tmgphpr)*omh*omr/8.d0 + shpe(1, 3)=(opg-tmgmhpr)*oph*omr/8.d0 + shpe(1, 4)=oph*omr*(tpgmhpr-omg)/8.d0 + shpe(1, 5)=omh*opr*(tpgphmr-omg)/8.d0 + shpe(1, 6)=(opg-tmgphmr)*omh*opr/8.d0 + shpe(1, 7)=(opg-tmgmhmr)*oph*opr/8.d0 + shpe(1, 8)=oph*opr*(tpgmhmr-omg)/8.d0 + shpe(1, 9)=omgmopg*omh*omr + shpe(1,10)=omhoph*omr + shpe(1,11)=omgmopg*oph*omr + shpe(1,12)=-omhoph*omr + shpe(1,13)=omgmopg*omh*opr + shpe(1,14)=omhoph*opr + shpe(1,15)=omgmopg*oph*opr + shpe(1,16)=-omhoph*opr + shpe(1,17)=-omropr*omh + shpe(1,18)=omropr*omh + shpe(1,19)=omropr*oph + shpe(1,20)=-omropr*oph +! +! local derivatives of the shape functions: eta-derivative +! + shpe(2, 1)=omg*omr*(tpgphpr-omh)/8.d0 + shpe(2, 2)=opg*omr*(tmgphpr-omh)/8.d0 + shpe(2, 3)=opg*(oph-tmgmhpr)*omr/8.d0 + shpe(2, 4)=omg*(oph-tpgmhpr)*omr/8.d0 + shpe(2, 5)=omg*opr*(tpgphmr-omh)/8.d0 + shpe(2, 6)=opg*opr*(tmgphmr-omh)/8.d0 + shpe(2, 7)=opg*(oph-tmgmhmr)*opr/8.d0 + shpe(2, 8)=omg*(oph-tpgmhmr)*opr/8.d0 + shpe(2, 9)=-omgopg*omr + shpe(2,10)=omhmoph*opg*omr + shpe(2,11)=omgopg*omr + shpe(2,12)=omhmoph*omg*omr + shpe(2,13)=-omgopg*opr + shpe(2,14)=omhmoph*opg*opr + shpe(2,15)=omgopg*opr + shpe(2,16)=omhmoph*omg*opr + shpe(2,17)=-omropr*omg + shpe(2,18)=-omropr*opg + shpe(2,19)=omropr*opg + shpe(2,20)=omropr*omg +! +! local derivatives of the shape functions: zeta-derivative +! + shpe(3, 1)=omg*omh*(tpgphpr-omr)/8.d0 + shpe(3, 2)=opg*omh*(tmgphpr-omr)/8.d0 + shpe(3, 3)=opg*oph*(tmgmhpr-omr)/8.d0 + shpe(3, 4)=omg*oph*(tpgmhpr-omr)/8.d0 + shpe(3, 5)=omg*omh*(opr-tpgphmr)/8.d0 + shpe(3, 6)=opg*omh*(opr-tmgphmr)/8.d0 + shpe(3, 7)=opg*oph*(opr-tmgmhmr)/8.d0 + shpe(3, 8)=omg*oph*(opr-tpgmhmr)/8.d0 + shpe(3, 9)=-omgopg*omh + shpe(3,10)=-omhoph*opg + shpe(3,11)=-omgopg*oph + shpe(3,12)=-omhoph*omg + shpe(3,13)=omgopg*omh + shpe(3,14)=omhoph*opg + shpe(3,15)=omgopg*oph + shpe(3,16)=omhoph*omg + shpe(3,17)=omrmopr*omg*omh + shpe(3,18)=omrmopr*opg*omh + shpe(3,19)=omrmopr*opg*oph + shpe(3,20)=omrmopr*omg*oph +! +! computation of the local derivative of the global coordinates +! (xs) +! +c do i=1,3 +c do j=1,3 +c xs(i,j)=0.d0 +c do k=1,20 +c xs(i,j)=xs(i,j)+xl(i,k)*shpe(j,k) +c enddo +c enddo +c enddo + do j=1,3 + xs(1,j)=xl(1,1)*(shpe(j,1)+shpe(j,5)+shpe(j,17)) + & +xl(1,2)*(shpe(j,2)+shpe(j,6)+shpe(j,18)) + & +xl(1,3)*(shpe(j,3)+shpe(j,7)+shpe(j,19)) + & +xl(1,4)*(shpe(j,4)+shpe(j,8)+shpe(j,20)) + & +xl(1,9)*(shpe(j,9)+shpe(j,13)) + & +xl(1,10)*(shpe(j,10)+shpe(j,14)) + & +xl(1,11)*(shpe(j,11)+shpe(j,15)) + & +xl(1,12)*(shpe(j,12)+shpe(j,16)) + xs(2,j)=xl(2,1)*(shpe(j,1)+shpe(j,5)+shpe(j,17)) + & +xl(2,2)*(shpe(j,2)+shpe(j,6)+shpe(j,18)) + & +xl(2,3)*(shpe(j,3)+shpe(j,7)+shpe(j,19)) + & +xl(2,4)*(shpe(j,4)+shpe(j,8)+shpe(j,20)) + & +xl(2,9)*(shpe(j,9)+shpe(j,13)) + & +xl(2,10)*(shpe(j,10)+shpe(j,14)) + & +xl(2,11)*(shpe(j,11)+shpe(j,15)) + & +xl(2,12)*(shpe(j,12)+shpe(j,16)) + xs(3,j)=xl(3,1)*(shpe(j,1)-shpe(j,5)) + & +xl(3,2)*(shpe(j,2)-shpe(j,6)) + & +xl(3,3)*(shpe(j,3)-shpe(j,7)) + & +xl(3,4)*(shpe(j,4)-shpe(j,8)) + & +xl(3,9)*(shpe(j,9)-shpe(j,13)) + & +xl(3,10)*(shpe(j,10)-shpe(j,14)) + & +xl(3,11)*(shpe(j,11)-shpe(j,15)) + & +xl(3,12)*(shpe(j,12)-shpe(j,16)) + enddo +! +! computation of the jacobian determinant +! + dd1=xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2) + dd2=xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3) + dd3=xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1) + xsj=xs(1,1)*dd1+xs(1,2)*dd2+xs(1,3)*dd3 +c xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) +c & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) +c & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) +! + if(iflag.eq.2) return +! + dd=1.d0/xsj +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=dd1*dd + xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd + xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd + xsi(2,1)=dd2*dd + xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd + xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd + xsi(3,1)=dd3*dd + xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd + xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd +c xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))*dd +c xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))*dd +c xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))*dd +c xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))*dd +c xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))*dd +c xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))*dd +c xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))*dd +c xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))*dd +c xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))*dd +! +! computation of the global derivatives of the shape functions +! + do k=1,20 + do j=1,3 + shp(j,k)=shpe(1,k)*xsi(1,j)+shpe(2,k)*xsi(2,j) + & +shpe(3,k)*xsi(3,j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape3l.f calculix-ccx-2.3/ccx_2.3/src/shape3l.f --- calculix-ccx-2.1/ccx_2.3/src/shape3l.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape3l.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,70 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape3l(xi,xl,xsj,xs,shp,iflag) +! +! shape functions and derivatives for a 3-node quadratic +! isoparametric 1-D element. -1<=xi<=1 +! +! iflag=2: calculate the value of the shape functions, +! their derivatives w.r.t. the local coordinates +! and the Jacobian (size of tangent vector to the +! curved line) +! + implicit none +! + integer i,k,iflag +! + real*8 shp(7,3),xs(3,7),xsi(2,3),xl(3,3),sh(3),xsj(3) +! + real*8 xi +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=xi-0.5d0 + shp(1,2)=-2.d0*xi + shp(1,3)=xi+0.5d0 +! +! shape functions +! + shp(4,1)=xi*(xi-1.d0)/2.d0 + shp(4,2)=(1.d0-xi)*(1.d0+xi) + shp(4,3)=xi*(xi+1.d0)/2.d0 +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + xs(i,1)=0.d0 + do k=1,3 + xs(i,1)=xs(i,1)+xl(i,k)*shp(1,k) + enddo + enddo +! +! computation of the jacobian vector +! + xsj(1)=dsqrt(xs(1,1)**2+xs(2,1)**2+xs(3,1)**2) +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape3tri.f calculix-ccx-2.3/ccx_2.3/src/shape3tri.f --- calculix-ccx-2.1/ccx_2.3/src/shape3tri.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape3tri.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,176 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape3tri(xi,et,xl,xsj,xs,shp,iflag) +! +! shape functions and derivatives for a 3-node linear +! isoparametric triangular element. 0<=xi,et<=1,xi+et<=1 +! +! iflag=2: calculate the value of the shape functions, +! their derivatives w.r.t. the local coordinates +! and the Jacobian vector (local normal to the +! surface) +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian vector (local normal +! to the surface) +! iflag=4: calculate the value of the shape functions, the +! value of their 1st and 2nd order derivatives +! w.r.t. the local coordinates, the Jacobian vector +! (local normal to the surface) +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(7,3),xs(3,7),xsi(2,3),xl(3,3),sh(3),xsj(3) +! + real*8 xi,et +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=-1.d0 + shp(1,2)=1.d0 + shp(1,3)=0.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=-1.d0 + shp(2,2)=0.d0 + shp(2,3)=1.d0 +! +! shape functions +! + shp(4,1)=1.d0-xi-et + shp(4,2)=xi + shp(4,3)=et +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,3 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian vector +! + xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + if(iflag.eq.3) then +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + if(dabs(xsj(3)).gt.1.d-10) then + xsi(1,1)=xs(2,2)/xsj(3) + xsi(2,2)=xs(1,1)/xsj(3) + xsi(1,2)=-xs(1,2)/xsj(3) + xsi(2,1)=-xs(2,1)/xsj(3) + if(dabs(xsj(2)).gt.1.d-10) then + xsi(2,3)=xs(1,1)/(-xsj(2)) + xsi(1,3)=-xs(1,2)/(-xsj(2)) + elseif(dabs(xsj(1)).gt.1.d-10) then + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + else + xsi(2,3)=0.d0 + xsi(1,3)=0.d0 + endif + elseif(dabs(xsj(2)).gt.1.d-10) then + xsi(1,1)=xs(3,2)/(-xsj(2)) + xsi(2,3)=xs(1,1)/(-xsj(2)) + xsi(1,3)=-xs(1,2)/(-xsj(2)) + xsi(2,1)=-xs(3,1)/(-xsj(2)) + if(dabs(xsj(1)).gt.1.d-10) then + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + else + xsi(1,2)=0.d0 + xsi(2,2)=0.d0 + endif + else + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + xsi(1,1)=0.d0 + xsi(2,1)=0.d0 + endif +c xsi(1,1)=xs(2,2)/xsj(3) +c xsi(2,1)=-xs(2,1)/xsj(3) +c xsi(1,2)=-xs(1,2)/xsj(3) +c xsi(2,2)=xs(1,1)/xsj(3) +c xsi(1,3)=-xs(2,2)/xsj(1) +c xsi(2,3)=xs(2,1)/xsj(1) +! +! computation of the global derivatives of the shape functions +! + do k=1,3 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + elseif(iflag.eq.4) then +! +! local 2nd order derivatives of the shape functions: xi,xi-derivative +! + shp(5,1)=0.d0 + shp(5,2)=0.d0 + shp(5,3)=0.d0 +! +! local 2nd order derivatives of the shape functions: xi,eta-derivative +! + shp(6,1)=0.d0 + shp(6,2)=0.d0 + shp(6,3)=0.d0 +! +! local 2nd order derivatives of the shape functions: eta,eta-derivative +! + shp(7,1)=0.d0 + shp(7,2)=0.d0 + shp(7,3)=0.d0 +! +! computation of the local 2nd derivatives of the global coordinates +! (xs) +! + do i=1,3 + do j=5,7 + xs(i,j)=0.d0 + enddo + enddo + endif +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape4q.f calculix-ccx-2.3/ccx_2.3/src/shape4q.f --- calculix-ccx-2.1/ccx_2.3/src/shape4q.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape4q.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,181 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape4q(xi,et,xl,xsj,xs,shp,iflag) +! +! iflag=2: calculate the value of the shape functions, +! their derivatives w.r.t. the local coordinates +! and the Jacobian vector (local normal to the +! surface) +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian vector (local normal +! to the surface) +! iflag=4: calculate the value of the shape functions, the +! value of their 1st and 2nd order derivatives +! w.r.t. the local coordinates, the Jacobian vector +! (local normal to the surface) +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(7,4),xs(3,7),xsi(2,3),xl(3,8),sh(3),xsj(3) +! + real*8 xi,et +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=-(1.d0-et)/4.d0 + shp(1,2)=(1.d0-et)/4.d0 + shp(1,3)=(1.d0+et)/4.d0 + shp(1,4)=-(1.d0+et)/4.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=-(1.d0-xi)/4.d0 + shp(2,2)=-(1.d0+xi)/4.d0 + shp(2,3)=(1.d0+xi)/4.d0 + shp(2,4)=(1.d0-xi)/4.d0 +! +! shape functions +! + shp(4,1)=(1.d0-xi)*(1.d0-et)/4.d0 + shp(4,2)=(1.d0+xi)*(1.d0-et)/4.d0 + shp(4,3)=(1.d0+xi)*(1.d0+et)/4.d0 + shp(4,4)=(1.d0-xi)*(1.d0+et)/4.d0 +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,4 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian vector +! + xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + if(iflag.eq.3) then +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! +c xsi(1,1)=xs(2,2)/xsj(3) +c xsi(2,1)=-xs(2,1)/xsj(3) +c xsi(1,2)=-xs(1,2)/xsj(3) +c xsi(2,2)=xs(1,1)/xsj(3) +c xsi(1,3)=-xs(2,2)/xsj(1) +c xsi(2,3)=xs(2,1)/xsj(1) + if(dabs(xsj(3)).gt.1.d-10) then + xsi(1,1)=xs(2,2)/xsj(3) + xsi(2,2)=xs(1,1)/xsj(3) + xsi(1,2)=-xs(1,2)/xsj(3) + xsi(2,1)=-xs(2,1)/xsj(3) + if(dabs(xsj(2)).gt.1.d-10) then + xsi(2,3)=xs(1,1)/(-xsj(2)) + xsi(1,3)=-xs(1,2)/(-xsj(2)) + elseif(dabs(xsj(1)).gt.1.d-10) then + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + else + xsi(2,3)=0.d0 + xsi(1,3)=0.d0 + endif + elseif(dabs(xsj(2)).gt.1.d-10) then + xsi(1,1)=xs(3,2)/(-xsj(2)) + xsi(2,3)=xs(1,1)/(-xsj(2)) + xsi(1,3)=-xs(1,2)/(-xsj(2)) + xsi(2,1)=-xs(3,1)/(-xsj(2)) + if(dabs(xsj(1)).gt.1.d-10) then + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + else + xsi(1,2)=0.d0 + xsi(2,2)=0.d0 + endif + else + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + xsi(1,1)=0.d0 + xsi(2,1)=0.d0 + endif +! +! computation of the global derivatives of the shape functions +! + do k=1,4 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + elseif(iflag.eq.4) then +! +! local 2nd order derivatives of the shape functions: xi,xi-derivative +! + shp(5,1)=0.d0 + shp(5,2)=0.d0 + shp(5,3)=0.d0 + shp(5,4)=0.d0 +! +! local 2nd order derivatives of the shape functions: xi,eta-derivative +! + shp(6,1)=0.25d0 + shp(6,2)=-0.25d0 + shp(6,3)=0.25d0 + shp(6,4)=-0.25d0 +! +! local 2nd order derivatives of the shape functions: eta,eta-derivative +! + shp(7,1)=0.d0 + shp(7,2)=0.d0 + shp(7,3)=0.d0 + shp(7,4)=0.d0 +! +! computation of the local 2nd derivatives of the global coordinates +! (xs) +! + do i=1,3 + xs(i,5)=0.d0 + xs(i,7)=0.d0 + enddo + do i=1,3 + xs(i,6)=0.d0 + do k=1,4 + xs(i,6)=xs(i,6)+xl(i,k)*shp(6,k) + enddo + enddo + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape4tet.f calculix-ccx-2.3/ccx_2.3/src/shape4tet.f --- calculix-ccx-2.1/ccx_2.3/src/shape4tet.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape4tet.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,116 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape4tet(xi,et,ze,xl,xsj,shp,iflag) +! +! shape functions and derivatives for a 4-node linear +! isoparametric tetrahedral element. 0<=xi,et,ze<=1,xi+et+ze<=1. +! +! iflag=1: calculate only the value of the shape functions +! iflag=2: calculate the value of the shape functions and +! the Jacobian determinant +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian determinant +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,4),xs(3,3),xsi(3,3),xl(3,4),sh(3) +! + real*8 xi,et,ze,xsj +! +! shape functions and their glocal derivatives +! +! shape functions +! + shp(4, 1)=1.d0-xi-et-ze + shp(4, 2)=xi + shp(4, 3)=et + shp(4, 4)=ze +! + if(iflag.eq.1) return +! +! local derivatives of the shape functions: xi-derivative +! + shp(1, 1)=-1.d0 + shp(1, 2)=1.d0 + shp(1, 3)=0.d0 + shp(1, 4)=0.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2, 1)=-1.d0 + shp(2, 2)=0.d0 + shp(2, 3)=1.d0 + shp(2, 4)=0.d0 +! +! local derivatives of the shape functions: zeta-derivative +! + shp(3, 1)=-1.d0 + shp(3, 2)=0.d0 + shp(3, 3)=0.d0 + shp(3, 4)=1.d0 +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,4 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant +! + xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) + & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) + & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj + xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj + xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj + xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj + xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj + xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj + xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj + xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj + xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj +! +! computation of the global derivatives of the shape functions +! + do k=1,4 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape6tri.f calculix-ccx-2.3/ccx_2.3/src/shape6tri.f --- calculix-ccx-2.1/ccx_2.3/src/shape6tri.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape6tri.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,194 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape6tri(xi,et,xl,xsj,xs,shp,iflag) +! +! iflag=2: calculate the value of the shape functions, +! their derivatives w.r.t. the local coordinates +! and the Jacobian vector (local normal to the +! surface) +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian vector (local normal +! to the surface) +! iflag=4: calculate the value of the shape functions, the +! value of their 1st and 2nd order derivatives +! w.r.t. the local coordinates, the Jacobian vector +! (local normal to the surface) +! +! shape functions and derivatives for a 6-node quadratic +! isoparametric triangular element. 0<=xi,et<=1,xi+et<=1 +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(7,6),xs(3,7),xsi(2,3),xl(3,6),sh(3),xsj(3) +! + real*8 xi,et +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=4.d0*(xi+et)-3.d0 + shp(1,2)=4.d0*xi-1.d0 + shp(1,3)=0.d0 + shp(1,4)=4.d0*(1.d0-2.d0*xi-et) + shp(1,5)=4.d0*et + shp(1,6)=-4.d0*et +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=4.d0*(xi+et)-3.d0 + shp(2,2)=0.d0 + shp(2,3)=4.d0*et-1.d0 + shp(2,4)=-4.d0*xi + shp(2,5)=4.d0*xi + shp(2,6)=4.d0*(1.d0-xi-2.d0*et) +! +! shape functions +! + shp(4,1)=2.d0*(0.5d0-xi-et)*(1.d0-xi-et) + shp(4,2)=xi*(2.d0*xi-1.d0) + shp(4,3)=et*(2.d0*et-1.d0) + shp(4,4)=4.d0*xi*(1.d0-xi-et) + shp(4,5)=4.d0*xi*et + shp(4,6)=4.d0*et*(1.d0-xi-et) +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,6 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian vector +! + xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + if(iflag.eq.3) then +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! +c xsi(1,1)=xs(2,2)/xsj(3) +c xsi(2,1)=-xs(2,1)/xsj(3) +c xsi(1,2)=-xs(1,2)/xsj(3) +c xsi(2,2)=xs(1,1)/xsj(3) +c xsi(1,3)=-xs(2,2)/xsj(1) +c xsi(2,3)=xs(2,1)/xsj(1) + if(dabs(xsj(3)).gt.1.d-10) then + xsi(1,1)=xs(2,2)/xsj(3) + xsi(2,2)=xs(1,1)/xsj(3) + xsi(1,2)=-xs(1,2)/xsj(3) + xsi(2,1)=-xs(2,1)/xsj(3) + if(dabs(xsj(2)).gt.1.d-10) then + xsi(2,3)=xs(1,1)/(-xsj(2)) + xsi(1,3)=-xs(1,2)/(-xsj(2)) + elseif(dabs(xsj(1)).gt.1.d-10) then + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + else + xsi(2,3)=0.d0 + xsi(1,3)=0.d0 + endif + elseif(dabs(xsj(2)).gt.1.d-10) then + xsi(1,1)=xs(3,2)/(-xsj(2)) + xsi(2,3)=xs(1,1)/(-xsj(2)) + xsi(1,3)=-xs(1,2)/(-xsj(2)) + xsi(2,1)=-xs(3,1)/(-xsj(2)) + if(dabs(xsj(1)).gt.1.d-10) then + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + else + xsi(1,2)=0.d0 + xsi(2,2)=0.d0 + endif + else + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + xsi(1,1)=0.d0 + xsi(2,1)=0.d0 + endif +! +! computation of the global derivatives of the shape functions +! + do k=1,6 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + elseif(iflag.eq.4) then +! +! local 2nd order derivatives of the shape functions: xi,xi-derivative +! + shp(5,1)=4.d0 + shp(5,2)=4.d0 + shp(5,3)=0.d0 + shp(5,4)=-8.d0 + shp(5,5)=0.d0 + shp(5,6)=0.d0 +! +! local 2nd order derivatives of the shape functions: xi,eta-derivative +! + shp(6,1)=4.d0 + shp(6,2)=0.d0 + shp(6,3)=0.d0 + shp(6,4)=-4.d0 + shp(6,5)=4.d0 + shp(6,6)=-4.d0 +! +! local 2nd order derivatives of the shape functions: eta,eta-derivative +! + shp(7,1)=4.d0 + shp(7,2)=0.d0 + shp(7,3)=4.d0 + shp(7,4)=0.d0 + shp(7,5)=0.d0 + shp(7,6)=-8.d0 +! +! computation of the local 2nd derivatives of the global coordinates +! (xs) +! + do i=1,3 + do j=5,7 + xs(i,j)=0.d0 + do k=1,6 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape6w.f calculix-ccx-2.3/ccx_2.3/src/shape6w.f --- calculix-ccx-2.1/ccx_2.3/src/shape6w.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape6w.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,134 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape6w(xi,et,ze,xl,xsj,shp,iflag) +! +! shape functions and derivatives for a 6-node linear +! isoparametric wedge element. 0<=xi,et<=1,xi+et<=1,-1<=ze<=1. +! +! iflag=1: calculate only the value of the shape functions +! iflag=2: calculate the value of the shape functions and +! the Jacobian determinant +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian determinant +! +! +! Copyright (c) 2003 WB +! +! Written January 2003 on the basis of the Guido's shape function files +! + + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,6),xs(3,3),xsi(3,3),xl(3,6),sh(3) +! + real*8 xi,et,ze,xsj,a +! +! shape functions and their glocal derivatives +! + a=1.d0-xi-et +! +! shape functions +! + shp(4, 1)=0.5d0*a *(1.d0-ze) + shp(4, 2)=0.5d0*xi*(1.d0-ze) + shp(4, 3)=0.5d0*et*(1.d0-ze) + shp(4, 4)=0.5d0*a *(1.d0+ze) + shp(4, 5)=0.5d0*xi*(1.d0+ze) + shp(4, 6)=0.5d0*et*(1.d0+ze) +! + if(iflag.eq.1) return +! +! local derivatives of the shape functions: xi-derivative +! + shp(1, 1)=-0.5d0*(1.d0-ze) + shp(1, 2)= 0.5d0*(1.d0-ze) + shp(1, 3)= 0.d0 + shp(1, 4)=-0.5d0*(1.d0+ze) + shp(1, 5)= 0.5d0*(1.d0+ze) + shp(1, 6)= 0.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2, 1)=-0.5d0*(1.d0-ze) + shp(2, 2)= 0.d0 + shp(2, 3)= 0.5d0*(1.d0-ze) + shp(2, 4)=-0.5d0*(1.d0+ze) + shp(2, 5)= 0.d0 + shp(2, 6)= 0.5d0*(1.d0+ze) + +! +! local derivatives of the shape functions: zeta-derivative +! + shp(3, 1)=-0.5d0*a + shp(3, 2)=-0.5d0*xi + shp(3, 3)=-0.5d0*et + shp(3, 4)= 0.5d0*a + shp(3, 5)= 0.5d0*xi + shp(3, 6)= 0.5d0*et +! +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,6 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant +! + xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) + & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) + & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj + xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj + xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj + xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj + xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj + xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj + xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj + xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj + xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj +! +! computation of the global derivatives of the shape functions +! + do k=1,6 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape8h.f calculix-ccx-2.3/ccx_2.3/src/shape8h.f --- calculix-ccx-2.1/ccx_2.3/src/shape8h.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape8h.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,139 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape8h(xi,et,ze,xl,xsj,shp,iflag) +! +! shape functions and derivatives for a 8-node linear isoparametric +! solid element +! +! iflag=1: calculate only the value of the shape functions +! iflag=2: calculate the value of the shape functions and +! the Jacobian determinant +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian determinant +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,20),xs(3,3),xsi(3,3),xl(3,20),sh(3) +! + real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr +! +! shape functions and their glocal derivatives +! + omg=1.d0-xi + omh=1.d0-et + omr=1.d0-ze + opg=1.d0+xi + oph=1.d0+et + opr=1.d0+ze +! +! shape functions +! + shp(4, 1)=omg*omh*omr/8.d0 + shp(4, 2)=opg*omh*omr/8.d0 + shp(4, 3)=opg*oph*omr/8.d0 + shp(4, 4)=omg*oph*omr/8.d0 + shp(4, 5)=omg*omh*opr/8.d0 + shp(4, 6)=opg*omh*opr/8.d0 + shp(4, 7)=opg*oph*opr/8.d0 + shp(4, 8)=omg*oph*opr/8.d0 +! + if(iflag.eq.1) return +! +! local derivatives of the shape functions: xi-derivative +! + shp(1, 1)=-omh*omr/8.d0 + shp(1, 2)=omh*omr/8.d0 + shp(1, 3)=oph*omr/8.d0 + shp(1, 4)=-oph*omr/8.d0 + shp(1, 5)=-omh*opr/8.d0 + shp(1, 6)=omh*opr/8.d0 + shp(1, 7)=oph*opr/8.d0 + shp(1, 8)=-oph*opr/8.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2, 1)=-omg*omr/8.d0 + shp(2, 2)=-opg*omr/8.d0 + shp(2, 3)=opg*omr/8.d0 + shp(2, 4)=omg*omr/8.d0 + shp(2, 5)=-omg*opr/8.d0 + shp(2, 6)=-opg*opr/8.d0 + shp(2, 7)=opg*opr/8.d0 + shp(2, 8)=omg*opr/8.d0 +! +! local derivatives of the shape functions: zeta-derivative +! + shp(3, 1)=-omg*omh/8.d0 + shp(3, 2)=-opg*omh/8.d0 + shp(3, 3)=-opg*oph/8.d0 + shp(3, 4)=-omg*oph/8.d0 + shp(3, 5)=omg*omh/8.d0 + shp(3, 6)=opg*omh/8.d0 + shp(3, 7)=opg*oph/8.d0 + shp(3, 8)=omg*oph/8.d0 +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,8 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant +! + xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) + & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) + & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj + xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj + xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj + xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj + xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj + xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj + xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj + xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj + xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj +! +! computation of the global derivatives of the shape functions +! + do k=1,8 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape8hr.f calculix-ccx-2.3/ccx_2.3/src/shape8hr.f --- calculix-ccx-2.1/ccx_2.3/src/shape8hr.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape8hr.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,208 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape8hr(xl,xsj,shp,gs,a) +! +! shape functions and derivatives for a 8-node linear isoparametric +! mean strain solid element with hourglass control +! +! Reference: Flanagan, D.P., Belytschko, T.; "Uniform strain hexahedron +! and quadrilateral with orthogonal Hourglass control". Int. J. Num. +! Meth. Engg., Vol. 17, 679-706, 1981. +! + implicit none +! + integer i,j,k,l + real*8 shp(4,20),xl(3,20),xsj,vol + real*8 x1,x2,x3,x4,x5,x6,x7,x8 + real*8 y1,y2,y3,y4,y5,y6,y7,y8 + real*8 z1,z2,z3,z4,z5,z6,z7,z8 + real*8 gb(8,4),gs(8,4),s0,a +! + data gb / 1.0d0, 1.0d0,-1.0d0,-1.0d0,-1.0d0,-1.0d0, 1.0d0, 1.0d0, + & 1.0d0,-1.0d0,-1.0d0, 1.0d0,-1.0d0, 1.0d0, 1.0d0,-1.0d0, + & 1.0d0,-1.0d0, 1.0d0,-1.0d0, 1.0d0,-1.0d0, 1.0d0,-1.0d0, + & -1.0d0, 1.0d0,-1.0d0, 1.0d0, 1.0d0,-1.0d0, 1.0d0,-1.0d0 / + +c write(6,*) "shape8hr", xl(1,1) +! +! shape functions and their global derivatives +! +! shape functions +! + shp(4, 1)=1.0d0/8.0d0 + shp(4, 2)=1.0d0/8.0d0 + shp(4, 3)=1.0d0/8.0d0 + shp(4, 4)=1.0d0/8.0d0 + shp(4, 5)=1.0d0/8.0d0 + shp(4, 6)=1.0d0/8.0d0 + shp(4, 7)=1.0d0/8.0d0 + shp(4, 8)=1.0d0/8.0d0 +! +! extract node point coordinates of element + x1=xl(1,1) + x2=xl(1,2) + x3=xl(1,3) + x4=xl(1,4) + x5=xl(1,5) + x6=xl(1,6) + x7=xl(1,7) + x8=xl(1,8) + y1=xl(2,1) + y2=xl(2,2) + y3=xl(2,3) + y4=xl(2,4) + y5=xl(2,5) + y6=xl(2,6) + y7=xl(2,7) + y8=xl(2,8) + z1=xl(3,1) + z2=xl(3,2) + z3=xl(3,3) + z4=xl(3,4) + z5=xl(3,5) + z6=xl(3,6) + z7=xl(3,7) + z8=xl(3,8) +! +! Average displacement derivative operator matrix, +! using eqn 16 in the reference above. +! Generated using maxima/wxmaxima and the following input lines. +! Note that shp array must be divided by the element volume. +! h1:(1-r)*(1-s)*(1-t)/8; +! h2:(1+r)*(1-s)*(1-t)/8; +! h3:(1+r)*(1+s)*(1-t)/8; +! h4:(1-r)*(1+s)*(1-t)/8; +! h5:(1-r)*(1-s)*(1+t)/8; +! h6:(1+r)*(1-s)*(1+t)/8; +! h7:(1+r)*(1+s)*(1+t)/8; +! h8:(1-r)*(1+s)*(1+t)/8; +! H:matrix([h1,h2,h3,h4,h5,h6,h7,h8])$ +! Bx:diff(H,r); +! By:diff(H,s); +! Bz:diff(H,t); +! B:matrix([Bx[1,1],Bx[1,2],Bx[1,3],Bx[1,4],Bx[1,5],Bx[1,6],Bx[1,7],Bx[1,8]], +! [By[1,1],By[1,2],By[1,3],By[1,4],By[1,5],By[1,6],By[1,7],By[1,8]], +! [Bz[1,1],Bz[1,2],Bz[1,3],Bz[1,4],Bz[1,5],Bz[1,6],Bz[1,7],Bz[1,8]]); +! x:matrix([x1,x2,x3,x4,x5,x6,x7,x8], +! [y1,y2,y3,y4,y5,y6,y7,y8], +! [z1,z2,z3,z4,z5,z6,z7,z8]); +! xr:B.transpose(x); +! det:determinant(xr); +! vol:factor(integrate(integrate(integrate(det,r,-1,1),s,-1,1),t,-1,1)); +! shp: matrix( [0,0,0,0,0,0,0,0], [0,0,0,0,0,0,0,0], [0,0,0,0,0,0,0,0])$ +! shp[1][1]:ratsimp(diff(vol,x1)); +! shp[1][2]:ratsimp(diff(vol,x2)); +! shp[1][3]:ratsimp(diff(vol,x3)); +! ... (more lines) +! shp[3][8]:ratsimp(diff(vol,z8)); +! fortran(shp); +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1) = ((y5-y4)*z8+(y2-y5)*z6+(-y8+y6-y4+y2)*z5+(y8+y5-y3-y2) + 1 *z4+(y4-y2)*z3+(-y6-y5+y4+y3)*z2)/1.2d+1 + shp(1,2) = -((y6-y3)*z7+(-y7+y5-y3+y1)*z6+(y1-y6)*z5+(y3-y1)*z4+( + 1 y7+y6-y4-y1)*z3+(-y6-y5+y4+y3)*z1)/1.2d+1 + shp(1,3) = -((y7-y4)*z8+(-y8+y6-y4+y2)*z7+(y2-y7)*z6+(y8+y7-y2-y1 + 1 )*z4+(-y7-y6+y4+y1)*z2+(y4-y2)*z1)/1.2d+1 + shp(1,4) = -((y7-y5+y3-y1)*z8+(y3-y8)*z7+(y8-y1)*z5+(-y8-y7+y2+y1 + 1 )*z3+(y1-y3)*z2+(y8+y5-y3-y2)*z1)/1.2d+1 + shp(1,5) = ((y7+y6-y4-y1)*z8+(y6-y8)*z7+(-y8-y7+y2+y1)*z6+(y8-y1) + 1 *z4+(y1-y6)*z2+(y8-y6+y4-y2)*z1)/1.2d+1 + shp(1,6) = ((y7-y5)*z8+(-y8-y5+y3+y2)*z7+(y8+y7-y2-y1)*z5+(y2-y7) + 1 *z3+(-y7+y5-y3+y1)*z2+(y5-y2)*z1)/1.2d+1 + shp(1,7) = -((y6+y5-y4-y3)*z8+(-y8-y5+y3+y2)*z6+(y6-y8)*z5+(y8-y3 + 1 )*z4+(y8-y6+y4-y2)*z3+(y3-y6)*z2)/1.2d+1 + shp(1,8) = ((y6+y5-y4-y3)*z7+(y5-y7)*z6+(-y7-y6+y4+y1)*z5+(y7-y5+ + 1 y3-y1)*z4+(y7-y4)*z3+(y4-y5)*z1)/1.2d+1 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1) = -((x5-x4)*z8+(x2-x5)*z6+(-x8+x6-x4+x2)*z5+(x8+x5-x3-x2 + 1 )*z4+(x4-x2)*z3+(-x6-x5+x4+x3)*z2)/1.2d+1 + shp(2,2) = ((x6-x3)*z7+(-x7+x5-x3+x1)*z6+(x1-x6)*z5+(x3-x1)*z4+(x + 1 7+x6-x4-x1)*z3+(-x6-x5+x4+x3)*z1)/1.2d+1 + shp(2,3) = ((x7-x4)*z8+(-x8+x6-x4+x2)*z7+(x2-x7)*z6+(x8+x7-x2-x1) + 1 *z4+(-x7-x6+x4+x1)*z2+(x4-x2)*z1)/1.2d+1 + shp(2,4) = ((x7-x5+x3-x1)*z8+(x3-x8)*z7+(x8-x1)*z5+(-x8-x7+x2+x1) + 1 *z3+(x1-x3)*z2+(x8+x5-x3-x2)*z1)/1.2d+1 + shp(2,5) = -((x7+x6-x4-x1)*z8+(x6-x8)*z7+(-x8-x7+x2+x1)*z6+(x8-x1 + 1 )*z4+(x1-x6)*z2+(x8-x6+x4-x2)*z1)/1.2d+1 + shp(2,6) = -((x7-x5)*z8+(-x8-x5+x3+x2)*z7+(x8+x7-x2-x1)*z5+(x2-x7 + 1 )*z3+(-x7+x5-x3+x1)*z2+(x5-x2)*z1)/1.2d+1 + shp(2,7) = ((x6+x5-x4-x3)*z8+(-x8-x5+x3+x2)*z6+(x6-x8)*z5+(x8-x3) + 1 *z4+(x8-x6+x4-x2)*z3+(x3-x6)*z2)/1.2d+1 + shp(2,8) = -((x6+x5-x4-x3)*z7+(x5-x7)*z6+(-x7-x6+x4+x1)*z5+(x7-x5 + 1 +x3-x1)*z4+(x7-x4)*z3+(x4-x5)*z1)/1.2d+1 +! +! local derivatives of the shape functions: zeta-derivative +! + shp(3,1) = ((x5-x4)*y8+(x2-x5)*y6+(-x8+x6-x4+x2)*y5+(x8+x5-x3-x2) + 1 *y4+(x4-x2)*y3+(-x6-x5+x4+x3)*y2)/1.2d+1 + shp(3,2) = -((x6-x3)*y7+(-x7+x5-x3+x1)*y6+(x1-x6)*y5+(x3-x1)*y4+( + 1 x7+x6-x4-x1)*y3+(-x6-x5+x4+x3)*y1)/1.2d+1 + shp(3,3) = -((x7-x4)*y8+(-x8+x6-x4+x2)*y7+(x2-x7)*y6+(x8+x7-x2-x1 + 1 )*y4+(-x7-x6+x4+x1)*y2+(x4-x2)*y1)/1.2d+1 + shp(3,4) = -((x7-x5+x3-x1)*y8+(x3-x8)*y7+(x8-x1)*y5+(-x8-x7+x2+x1 + 1 )*y3+(x1-x3)*y2+(x8+x5-x3-x2)*y1)/1.2d+1 + shp(3,5) = ((x7+x6-x4-x1)*y8+(x6-x8)*y7+(-x8-x7+x2+x1)*y6+(x8-x1) + 1 *y4+(x1-x6)*y2+(x8-x6+x4-x2)*y1)/1.2d+1 + shp(3,6) = ((x7-x5)*y8+(-x8-x5+x3+x2)*y7+(x8+x7-x2-x1)*y5+(x2-x7) + 1 *y3+(-x7+x5-x3+x1)*y2+(x5-x2)*y1)/1.2d+1 + shp(3,7) = -((x6+x5-x4-x3)*y8+(-x8-x5+x3+x2)*y6+(x6-x8)*y5+(x8-x3 + 1 )*y4+(x8-x6+x4-x2)*y3+(x3-x6)*y2)/1.2d+1 + shp(3,8) = ((x6+x5-x4-x3)*y7+(x5-x7)*y6+(-x7-x6+x4+x1)*y5+(x7-x5+ + 1 x3-x1)*y4+(x7-x4)*y3+(x4-x5)*y1)/1.2d+1 +! +! computation of element volume (eqn 15) +! + vol=0.0d0 + do k=1,8 + vol=vol+xl(1,k)*shp(1,k) + enddo +! +! computation of the average jacobian determinant +! + xsj=vol/8.0d0 +! +! hourglass control vectors(see appendix 2 from the reference above). +! divide shp array by element volume + a=0.0d0 + do i=1,8 + do j=1,3 + a=a+shp(j,i)*shp(j,i) + s0=shp(j,i)/vol + shp(j,i)=s0 + do k=1,4 + gs(i,k)=gb(i,k) + do l=1,8 + gs(i,k)=gs(i,k)-s0*xl(j,l)*gb(l,k) + enddo + enddo + enddo + enddo +c +c calculate hourglass control stiffness factor a +c (to be used in hgstiffness() and hgforce()) +c +c in ABAQUS, a 0.005 is used as default value. + a=0.0005*a/vol +c + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape8hu.f calculix-ccx-2.3/ccx_2.3/src/shape8hu.f --- calculix-ccx-2.1/ccx_2.3/src/shape8hu.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape8hu.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,223 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape8hu(xi,et,ze,xl,xsj,shp,iflag) +! +! shape functions and derivatives for a 8-node linear isoparametric +! solid element +! +! iflag=1: calculate only the value of the shape functions +! iflag=2: calculate the value of the shape functions and +! the Jacobian determinant +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian determinant +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(4,23),xs(3,3),xsi(3,3),xl(3,23),sh(3),xsi0(3,3) +! + real*8 xi,et,ze,xsj,omg,omh,omr,opg,oph,opr +! +! local derivatives at center point: xi-derivative +! + shp(1,1)=-1.0d0/8.d0 + shp(1,2)=1.0d0/8.d0 + shp(1,3)=1.0d0/8.d0 + shp(1,4)=-1.0d0/8.d0 + shp(1,5)=-1.0d0/8.d0 + shp(1,6)=1.0d0/8.d0 + shp(1,7)=1.0d0/8.d0 + shp(1,8)=-1.0d0/8.d0 +! +! local derivatives at center point: eta-derivative +! + shp(2,1)=-1.0d0/8.d0 + shp(2,2)=-1.0d0/8.d0 + shp(2,3)=1.0d0/8.d0 + shp(2,4)=1.0d0/8.d0 + shp(2,5)=-1.0d0/8.d0 + shp(2,6)=-1.0d0/8.d0 + shp(2,7)=1.0d0/8.d0 + shp(2,8)=1.0d0/8.d0 +! +! local derivatives at center point: zeta-derivative +! + shp(3,1)=-1.0d0/8.d0 + shp(3,2)=-1.0d0/8.d0 + shp(3,3)=-1.0d0/8.d0 + shp(3,4)=-1.0d0/8.d0 + shp(3,5)=1.0d0/8.d0 + shp(3,6)=1.0d0/8.d0 + shp(3,7)=1.0d0/8.d0 + shp(3,8)=1.0d0/8.d0 +! +! computation of the local derivative of the global coordinates +! (xs) at center point of element. +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,8 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant at center point +! + xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) + & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) + & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) +! +! computation of the global derivative of the local coordinates +! at center point of element. +! + xsi0(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj + xsi0(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj + xsi0(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj + xsi0(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj + xsi0(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj + xsi0(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj + xsi0(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj + xsi0(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj + xsi0(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj +! +! shape functions and their global derivatives +! + omg=1.d0-xi + omh=1.d0-et + omr=1.d0-ze + opg=1.d0+xi + oph=1.d0+et + opr=1.d0+ze +! +! shape functions +! + shp(4, 1)=omg*omh*omr/8.d0 + shp(4, 2)=opg*omh*omr/8.d0 + shp(4, 3)=opg*oph*omr/8.d0 + shp(4, 4)=omg*oph*omr/8.d0 + shp(4, 5)=omg*omh*opr/8.d0 + shp(4, 6)=opg*omh*opr/8.d0 + shp(4, 7)=opg*oph*opr/8.d0 + shp(4, 8)=omg*oph*opr/8.d0 + shp(4, 9)=0.0d0 + shp(4,10)=0.0d0 + shp(4,11)=0.0d0 +! + if(iflag.eq.1) return +! +! local derivatives of the shape functions: xi-derivative +! + shp(1, 1)=-omh*omr/8.d0 + shp(1, 2)=omh*omr/8.d0 + shp(1, 3)=oph*omr/8.d0 + shp(1, 4)=-oph*omr/8.d0 + shp(1, 5)=-omh*opr/8.d0 + shp(1, 6)=omh*opr/8.d0 + shp(1, 7)=oph*opr/8.d0 + shp(1, 8)=-oph*opr/8.d0 + shp(1, 9)=-2.0*xi + shp(1,10)=0.0 + shp(1,11)=0.0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2, 1)=-omg*omr/8.d0 + shp(2, 2)=-opg*omr/8.d0 + shp(2, 3)=opg*omr/8.d0 + shp(2, 4)=omg*omr/8.d0 + shp(2, 5)=-omg*opr/8.d0 + shp(2, 6)=-opg*opr/8.d0 + shp(2, 7)=opg*opr/8.d0 + shp(2, 8)=omg*opr/8.d0 + shp(2, 9)=0.0 + shp(2,10)=-2.0*et + shp(2,11)=0.0 +! +! local derivatives of the shape functions: zeta-derivative +! + shp(3, 1)=-omg*omh/8.d0 + shp(3, 2)=-opg*omh/8.d0 + shp(3, 3)=-opg*oph/8.d0 + shp(3, 4)=-omg*oph/8.d0 + shp(3, 5)=omg*omh/8.d0 + shp(3, 6)=opg*omh/8.d0 + shp(3, 7)=opg*oph/8.d0 + shp(3, 8)=omg*oph/8.d0 + shp(3, 9)=0.0 + shp(3,10)=0.0 + shp(3,11)=-2.0*ze +! +! computation of the local derivative of the global coordinates +! (xs). Incompatible modes are not included here. +! + do i=1,3 + do j=1,3 + xs(i,j)=0.d0 + do k=1,8 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian determinant +! + xsj=xs(1,1)*(xs(2,2)*xs(3,3)-xs(2,3)*xs(3,2)) + & -xs(1,2)*(xs(2,1)*xs(3,3)-xs(2,3)*xs(3,1)) + & +xs(1,3)*(xs(2,1)*xs(3,2)-xs(2,2)*xs(3,1)) +! + if(iflag.eq.2) return +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + xsi(1,1)=(xs(2,2)*xs(3,3)-xs(3,2)*xs(2,3))/xsj + xsi(1,2)=(xs(1,3)*xs(3,2)-xs(1,2)*xs(3,3))/xsj + xsi(1,3)=(xs(1,2)*xs(2,3)-xs(2,2)*xs(1,3))/xsj + xsi(2,1)=(xs(2,3)*xs(3,1)-xs(2,1)*xs(3,3))/xsj + xsi(2,2)=(xs(1,1)*xs(3,3)-xs(3,1)*xs(1,3))/xsj + xsi(2,3)=(xs(1,3)*xs(2,1)-xs(1,1)*xs(2,3))/xsj + xsi(3,1)=(xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2))/xsj + xsi(3,2)=(xs(1,2)*xs(3,1)-xs(1,1)*xs(3,2))/xsj + xsi(3,3)=(xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2))/xsj +! +! computation of the global derivatives of the shape functions +! + do k=1,8 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j)+shp(3,k)*xsi(3,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo + do k=9,11 + do j=1,3 + sh(j)=shp(1,k)*xsi0(1,j)+shp(2,k)*xsi0(2,j)+shp(3,k)*xsi0(3,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shape8q.f calculix-ccx-2.3/ccx_2.3/src/shape8q.f --- calculix-ccx-2.1/ccx_2.3/src/shape8q.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shape8q.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,200 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shape8q(xi,et,xl,xsj,xs,shp,iflag) +! +! shape functions and derivatives for a 8-node quadratic +! isoparametric quadrilateral element. -1<=xi,et<=1 +! +! iflag=2: calculate the value of the shape functions, +! their derivatives w.r.t. the local coordinates +! and the Jacobian vector (local normal to the +! surface) +! iflag=3: calculate the value of the shape functions, the +! value of their derivatives w.r.t. the global +! coordinates and the Jacobian vector (local normal +! to the surface) +! iflag=4: calculate the value of the shape functions, the +! value of their 1st and 2nd order derivatives +! w.r.t. the local coordinates, the Jacobian vector +! (local normal to the surface) +! + implicit none +! + integer i,j,k,iflag +! + real*8 shp(7,8),xs(3,7),xsi(2,3),xl(3,8),sh(3),xsj(3) +! + real*8 xi,et +! +! shape functions and their glocal derivatives for an element +! described with two local parameters and three global ones. +! +! local derivatives of the shape functions: xi-derivative +! + shp(1,1)=(1.d0-et)*(2.d0*xi+et)/4.d0 + shp(1,2)=(1.d0-et)*(2.d0*xi-et)/4.d0 + shp(1,3)=(1.d0+et)*(2.d0*xi+et)/4.d0 + shp(1,4)=(1.d0+et)*(2.d0*xi-et)/4.d0 + shp(1,5)=-xi*(1.d0-et) + shp(1,6)=(1.d0-et*et)/2.d0 + shp(1,7)=-xi*(1.d0+et) + shp(1,8)=-(1.d0-et*et)/2.d0 +! +! local derivatives of the shape functions: eta-derivative +! + shp(2,1)=(1.d0-xi)*(2.d0*et+xi)/4.d0 + shp(2,2)=(1.d0+xi)*(2.d0*et-xi)/4.d0 + shp(2,3)=(1.d0+xi)*(2.d0*et+xi)/4.d0 + shp(2,4)=(1.d0-xi)*(2.d0*et-xi)/4.d0 + shp(2,5)=-(1.d0-xi*xi)/2.d0 + shp(2,6)=-et*(1.d0+xi) + shp(2,7)=(1.d0-xi*xi)/2.d0 + shp(2,8)=-et*(1.d0-xi) +! +! shape functions +! + shp(4,1)=(1.d0-xi)*(1.d0-et)*(-xi-et-1.d0)/4.d0 + shp(4,2)=(1.d0+xi)*(1.d0-et)*(xi-et-1.d0)/4.d0 + shp(4,3)=(1.d0+xi)*(1.d0+et)*(xi+et-1.d0)/4.d0 + shp(4,4)=(1.d0-xi)*(1.d0+et)*(-xi+et-1.d0)/4.d0 + shp(4,5)=(1.d0-xi*xi)*(1.d0-et)/2.d0 + shp(4,6)=(1.d0+xi)*(1.d0-et*et)/2.d0 + shp(4,7)=(1.d0-xi*xi)*(1.d0+et)/2.d0 + shp(4,8)=(1.d0-xi)*(1.d0-et*et)/2.d0 +! +! computation of the local derivative of the global coordinates +! (xs) +! + do i=1,3 + do j=1,2 + xs(i,j)=0.d0 + do k=1,8 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo +! +! computation of the jacobian vector +! + xsj(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2) + xsj(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1) + xsj(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2) +! + if(iflag.eq.3) then +! +! computation of the global derivative of the local coordinates +! (xsi) (inversion of xs) +! + if(dabs(xsj(3)).gt.1.d-10) then + xsi(1,1)=xs(2,2)/xsj(3) + xsi(2,2)=xs(1,1)/xsj(3) + xsi(1,2)=-xs(1,2)/xsj(3) + xsi(2,1)=-xs(2,1)/xsj(3) + if(dabs(xsj(2)).gt.1.d-10) then + xsi(2,3)=xs(1,1)/(-xsj(2)) + xsi(1,3)=-xs(1,2)/(-xsj(2)) + elseif(dabs(xsj(1)).gt.1.d-10) then + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + else + xsi(2,3)=0.d0 + xsi(1,3)=0.d0 + endif + elseif(dabs(xsj(2)).gt.1.d-10) then + xsi(1,1)=xs(3,2)/(-xsj(2)) + xsi(2,3)=xs(1,1)/(-xsj(2)) + xsi(1,3)=-xs(1,2)/(-xsj(2)) + xsi(2,1)=-xs(3,1)/(-xsj(2)) + if(dabs(xsj(1)).gt.1.d-10) then + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + else + xsi(1,2)=0.d0 + xsi(2,2)=0.d0 + endif + else + xsi(1,2)=xs(3,2)/xsj(1) + xsi(2,3)=xs(2,1)/xsj(1) + xsi(1,3)=-xs(2,2)/xsj(1) + xsi(2,2)=-xs(3,1)/xsj(1) + xsi(1,1)=0.d0 + xsi(2,1)=0.d0 + endif +! +! computation of the global derivatives of the shape functions +! + do k=1,8 + do j=1,3 + sh(j)=shp(1,k)*xsi(1,j)+shp(2,k)*xsi(2,j) + enddo + do j=1,3 + shp(j,k)=sh(j) + enddo + enddo +! + elseif(iflag.eq.4) then +! +! local 2nd order derivatives of the shape functions: xi,xi-derivative +! + shp(5,1)=(1.d0-et)/2.d0 + shp(5,2)=(1.d0-et)/2.d0 + shp(5,3)=(1.d0+et)/2.d0 + shp(5,4)=(1.d0+et)/2.d0 + shp(5,5)=-(1.d0-et) + shp(5,6)=0.d0 + shp(5,7)=-(1.d0+et) + shp(5,8)=0.d0 +! +! local 2nd order derivatives of the shape functions: xi,eta-derivative +! + shp(6,1)=(1.d0-2.d0*(xi+et))/4.d0 + shp(6,2)=(-1.d0-2.d0*(xi-et))/4.d0 + shp(6,3)=(1.d0+2.d0*(xi+et))/4.d0 + shp(6,4)=(-1.d0-2.d0*(xi+et))/4.d0 + shp(6,5)=xi + shp(6,6)=-et + shp(6,7)=-xi + shp(6,8)=et +! +! local 2nd order derivatives of the shape functions: eta,eta-derivative +! + shp(7,1)=(1.d0-xi)/2.d0 + shp(7,2)=(1.d0+xi)/2.d0 + shp(7,3)=(1.d0+xi)/2.d0 + shp(7,4)=(1.d0-xi)/2.d0 + shp(7,5)=0.d0 + shp(7,6)=-(1.d0+xi) + shp(7,7)=0.d0 + shp(7,8)=-(1.d0-xi) +! +! computation of the local 2nd derivatives of the global coordinates +! (xs) +! + do i=1,3 + do j=5,7 + xs(i,j)=0.d0 + do k=1,8 + xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k) + enddo + enddo + enddo + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/shellsections.f calculix-ccx-2.3/ccx_2.3/src/shellsections.f --- calculix-ccx-2.1/ccx_2.3/src/shellsections.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/shellsections.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,194 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine shellsections(inpc,textpart,set,istartset,iendset, + & ialset,nset,ielmat,matname,nmat,ielorien,orname,norien, + & thicke,kon,ipkon,offset,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,lakon,iaxial,ipoinpc) +! +! reading the input deck: *SHELL SECTION +! + implicit none +! + logical nodalthickness +! + character*1 inpc(*) + character*8 lakon(*) + character*80 matname(*),orname(*),material,orientation + character*81 set(*),elset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),ielmat(*), + & ielorien(*),kon(*),ipkon(*),indexe,irstrt,nset,nmat,norien, + & istep,istat,n,key,i,j,k,l,imaterial,iorientation,ipos, + & iline,ipol,inl,ipoinp(2,*),inp(3,*),iaxial,ipoinpc(0:*) +! + real*8 thicke(2,*),thickness,offset(2,*),offset1 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in shellsections: *SHELL SECTION should' + write(*,*) ' be placed before all step definitions' + stop + endif +! + nodalthickness=.false. + offset1=0.d0 + orientation=' ' + do i=2,n + if(textpart(i)(1:9).eq.'MATERIAL=') then + material=textpart(i)(10:89) + elseif(textpart(i)(1:12).eq.'ORIENTATION=') then + orientation=textpart(i)(13:92) + elseif(textpart(i)(1:6).eq.'ELSET=') then + elset=textpart(i)(7:86) + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + elseif(textpart(i)(1:14).eq.'NODALTHICKNESS') then + nodalthickness=.true. + elseif(textpart(i)(1:7).eq.'OFFSET=') then + read(textpart(i)(8:27),'(f20.0)',iostat=istat) offset1 + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + write(*,*) + & '*WARNING in shellsections: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! check for the existence of the set,the material and orientation +! + do i=1,nmat + if(matname(i).eq.material) exit + enddo + if(i.gt.nmat) then + write(*,*) '*ERROR in shellsections: nonexistent material' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + imaterial=i +! + if(orientation.eq.' ') then + iorientation=0 + else + do i=1,norien + if(orname(i).eq.orientation) exit + enddo + if(i.gt.norien) then + write(*,*)'*ERROR in shellsections: nonexistent orientation' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iorientation=i + endif +! + do i=1,nset + if(set(i).eq.elset) exit + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR in shellsections: element set ',elset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! +! assigning the elements of the set the appropriate material, +! orientation number and offset +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + if(lakon(ialset(j))(1:1).ne.'S') then + write(*,*) '*ERROR in shellsections: *SHELL SECTION can' + write(*,*) ' only be used for shell elements.' + write(*,*) ' Element ',ialset(j),' is not a shell e + &lement.' + stop + endif + ielmat(ialset(j))=imaterial + ielorien(ialset(j))=iorientation + offset(1,ialset(j))=offset1 + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + if(lakon(k)(1:1).ne.'S') then + write(*,*) '*ERROR in shellsections: *SHELL SECTION ca + &n' + write(*,*) ' only be used for shell elements.' + write(*,*) ' Element ',k,' is not a shell elemen + &t.' + stop + endif + ielmat(k)=imaterial + ielorien(k)=iorientation + offset(1,k)=offset1 + enddo + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! +! assigning a thickness to the elements +! +c read(textpart(1)(1:20),'(f20.0)',iostat=istat) thickness +c if(istat.gt.0) then +c write(*,*) +c & '*ERROR in shellsections: shell thickness is lacking' +c call inputerror(inpc,ipoinpc,iline) +c endif +! + if(.not.nodalthickness) then + read(textpart(1)(1:20),'(f20.0)',iostat=istat) thickness + if(istat.gt.0) then + write(*,*) + & '*ERROR in shellsections: shell thickness is lacking' + call inputerror(inpc,ipoinpc,iline) + endif + if(iaxial.ne.0) thickness=thickness/iaxial + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + indexe=ipkon(ialset(j)) + do l=1,8 + thicke(1,indexe+l)=thickness + enddo + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + indexe=ipkon(k) + do l=1,8 + thicke(1,indexe+l)=thickness + enddo + enddo + endif + enddo + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/sigini.f calculix-ccx-2.3/ccx_2.3/src/sigini.f --- calculix-ccx-2.1/ccx_2.3/src/sigini.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/sigini.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,57 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine sigini(sigma,coords,ntens,ncrds,noel,npt,layer, + & kspt,lrebar,rebarn) +! +! user subroutine sigini +! +! INPUT: +! +! coords coordinates of the integration point +! ntens number of stresses to be defined +! ncrds number of coordinates +! noel element number +! npt integration point number +! layer currently not used +! kspt currently not used +! lrebar currently not used (value: 0) +! rebarn currently not used +! +! OUTPUT: +! +! sigma(1..ntens) residual stress values in the integration +! point. If ntens=6 the order of the +! components is 11,22,33,12,13,23 +! + implicit none +! + character*80 rebarn + integer ntens,ncrds,noel,npt,layer,kspt,lrebar + real*8 sigma(*),coords(*) +! + sigma(1)=-100.d0*coords(2) + sigma(2)=-100.d0*coords(2) + sigma(3)=-100.d0*coords(2) + sigma(4)=0.d0 + sigma(5)=0.d0 + sigma(6)=0.d0 +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/skip.f calculix-ccx-2.3/ccx_2.3/src/skip.f --- calculix-ccx-2.1/ccx_2.3/src/skip.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/skip.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,183 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine skip(nset,nalset,nload,nbody, + & nforc,nboun,nflow,nk,ne,nkon, + & mi,nmpc,memmpc_,nmat,ntmat_,npmat_,ncmat_,norien,ntrans,nam, + & nprint,nlabel,ncs_,ne1d,ne2d,infree,nmethod, + & iperturb,nener,iplas,ithermal,nstate_,iprestr,mcs,ntie) +! + implicit none +! + integer nset,nalset,nload,nforc,nboun,nflow,nk,ne,nkon,mi(2), + & nmpc,memmpc_,nmat,ntmat_,npmat_,ncmat_,norien,ntrans,nam, + & nprint,nlabel,ncs_,ne1d,ne2d,infree(4),i,mt, + & nmethod,iperturb(*),nener,iplas,ithermal,nstate_,iprestr,i4, + & maxamta,mcs,ntie,nbody +! + character*1 c1 + character*3 c3 + character*4 c4 + character*5 c5 + character*8 c8 + character*20 c20 + character*80 c80 + character*81 c81 + character*87 c87 +! + real*8 r8 +! + mt=mi(2)+1 +! +! skipping the next entries +! + read(15)(c81,i=1,nset) + read(15)(i4,i=1,nset) + read(15)(i4,i=1,nset) + do i=1,nalset + read(15)i4 + enddo + read(15)(r8,i=1,3*nk) + read(15)(i4,i=1,nkon) + read(15)(i4,i=1,ne) + read(15)(c8,i=1,ne) + read(15)(i4,i=1,nboun) + read(15)(i4,i=1,nboun) + read(15)(c1,i=1,nboun) + read(15)(r8,i=1,nboun) + read(15)(i4,i=1,nboun) + read(15)(i4,i=1,nboun) + if(nam.gt.0) read(15)(i4,i=1,nboun) + read(15)(i4,i=1,nboun) + read(15)(i4,i=1,nboun) + read(15)(r8,i=1,nboun) + read(15)(i4,i=1,nmpc) + read(15)(c20,i=1,nmpc) + read(15)(i4,i=1,nmpc) + read(15)(i4,i=1,nmpc) + read(15)(r8,i=1,nmpc) + read(15)(i4,i=1,3*memmpc_) + read(15)(r8,i=1,memmpc_) + read(15)(i4,i=1,nforc) + read(15)(i4,i=1,nforc) + read(15)(r8,i=1,nforc) + read(15)(i4,i=1,nforc) + read(15)(i4,i=1,nforc) + if(nam.gt.0) read(15)(i4,i=1,nforc) + read(15)(r8,i=1,nforc) + read(15)(i4,i=1,2*nload) + read(15)(c5,i=1,nload) + read(15)(r8,i=1,2*nload) + if(nam.gt.0) read(15)(i4,i=1,2*nload) + read(15)(r8,i=1,2*nload) + read(15)(c81,i=1,nbody) + read(15)(i4,i=1,2*nbody) + read(15)(r8,i=1,7*nbody) + read(15)(r8,i=1,7*nbody) + if(iprestr.gt.0) read(15) (r8,i=1,6*mi(1)*ne) +c read(15)(i4,i=1,2*nflow) +c read(15)(r8,i=1,nflow) +c if(nam.gt.0) read(15)(i4,i=1,nflow) +c read(15)(r8,i=1,nflow) + read(15)(c5,i=1,nprint) + read(15)(c81,i=1,nprint) + read(15)(c87,i=1,nlabel) + read(15)(r8,i=1,(ncmat_+1)*ntmat_*nmat) + read(15)(i4,i=1,2*nmat) + read(15)(r8,i=1,2*ntmat_*nmat) + read(15)(i4,i=1,nmat) + read(15)(r8,i=1,4*ntmat_*nmat) + read(15)(i4,i=1,nmat) + read(15)(r8,i=1,7*ntmat_*nmat) + read(15)(i4,i=1,2*nmat) + read(15)(r8,i=1,7*ntmat_*nmat) + read(15)(i4,i=1,2*nmat) + read(15)(r8,i=1,nmat) + read(15)(r8,i=1,3) + if(iplas.ne.0)then + read(15)(r8,i=1,(2*npmat_+1)*ntmat_*nmat) + read(15)(i4,i=1,(ntmat_+1)*nmat) + read(15)(r8,i=1,(2*npmat_+1)*ntmat_*nmat) + read(15)(i4,i=1,(ntmat_+1)*nmat) + endif + if(norien.ne.0)then + read(15)(c80,i=1,norien) + read(15)(r8,i=1,7*norien) + read(15)(i4,i=1,ne) + endif + if(ntrans.ne.0)then + read(15)(r8,i=1,7*ntrans) + read(15)(i4,i=1,2*nk) + endif + if(nam.gt.0)then + read(15)(c80,i=1,nam) + read(15)(i4,i=1,3*nam-1) + maxamta=2*i4 + read(15)i4 + read(15)(r8,i=1,maxamta) + endif + if(ithermal.gt.0)then + if((ne1d.gt.0).or.(ne2d.gt.0))then + read(15)(r8,i=1,3*nk) + read(15)(r8,i=1,3*nk) + else + read(15)(r8,i=1,nk) + read(15)(r8,i=1,nk) + endif + if(nam.gt.0) read(15)(i4,i=1,nk) + read(15)(r8,i=1,nk) + endif + read(15)(c80,i=1,nmat) + read(15)(i4,i=1,ne) + read(15)(r8,i=1,mt*nk) + if((nmethod.eq.4).or.((nmethod.eq.1).and.(iperturb(1).ge.2))) + & then + read(15)(r8,i=1,mt*nk) + endif + read(15)(i4,i=1,nk) + if((ne1d.gt.0).or.(ne2d.gt.0))then + read(15)(i4,i=1,2*nkon) + read(15)(r8,i=1,infree(1)-1) + read(15)(i4,i=1,infree(2)-1) + read(15)(r8,i=1,2*nkon) + read(15)(r8,i=1,2*ne) + read(15)(i4,i=1,infree(4)) + read(15)(i4,i=1,3*(infree(3)-1)) + read(15)(i4,i=1,infree(4)) + endif + if(ntie.gt.0) then + read(15)(c81,i=1,3*ntie) + read(15)(r8,i=1,2*ntie) + endif + if(ncs_.gt.0)then + read(15)(i4,i=1,ncs_) + endif + if(mcs.gt.0) then + read(15)(r8,i=1,17*mcs) + endif + read(15)(r8,i=1,6*mi(1)*ne) + read(15)(r8,i=1,6*mi(1)*ne) + if(nener.eq.1) read(15)(r8,i=1,mi(1)*ne) + if(nstate_.gt.0) read(15)(r8,i=1,nstate_*mi(1)*ne) + read(15) (r8,i=1,27) + read(15) (r8,i=1,2) + read(15) c3 + read(15) r8 +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/slavintmortar.f calculix-ccx-2.3/ccx_2.3/src/slavintmortar.f --- calculix-ccx-2.1/ccx_2.3/src/slavintmortar.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/slavintmortar.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,536 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine slavintmortar(tieset,ntie,itietri,ipkon,kon, + & lakon,set,cg,straight,nintpoint, + & koncont,co,vold,xo,yo,zo,x,y,z,nx,ny,nz,nset, + & iinc,iit, + & islavsurf,imastsurf,pmastsurf,itiefac, + & islavnode,nslavnode,slavnor,slavtan,imastop,gapmints, + &islavact,mi,ncont,ipe,ime,pslavsurf,pslavdual,i,l,ntri) +! +! Determining the location of the integration points in slave +! surface ifaces. This location depends on the triangulation of +! the opposite master surface. For the slave surface the local +! coordinates and the integration weight is stored in pslavsurf, +! the label of the opposite master face and the local coordinates +! of the opposite point on the master faces are stored in +! islavsurf and pmastsurf, respectively +! +! Author: Li, Yang; Rakotonanahary, Samoela; +! + implicit none +! + character*1 c + character*3 m11,m2,m3 + integer one,number_of_nodes +! + character*5 p0,p1,p2,p3,p7,p9999 + character*8 lakon(*) + character*81 tieset(3,*),slavset,set(*) +! + integer ntie,nset,nintpoint,imastop(3,*),kmax(3),ncont, + & itietri(2,ntie),ipkon(*),kon(*),koncont(4,*),node, + & neigh(10),iflag,kneigh,i,j,k,l,islav,isol, + & itri,kflag,n,ipos,nx(*),ny(*),iinc, + & nz(*),nstart,ifaceq(8,6),ifacet(6,4),index1,ifreeintersec, + & ifacew1(4,5),ifacew2(8,5),nelemm,jfacem,indexe,iit, + & nnodelem,nface,nope,nodef(8),m1,km1,km2,km3,number, + & islavsurf(2,*),islavnode(*),nslavnode(ntie+1), + & imastsurf(*),itiefac(2,*),ifaces,nelems,jfaces,mi(2), + & mint2d,m,nopes,konl(20),id,islavact(*),indexnode(8), + & itria(4),ntria,itriacorner(4,4),inodesin(3*ncont),line, + & nnodesin,inodesout(3*ncont),nnodesout,iactiveline(3,3*ncont), + & nactiveline,intersec(2,6*ncont),ipe(*),ime(4,*),k1,j1, + & ipiv(4),info,ipnt,ntri,nintpfirst, + & compt,il +! + real*8 cg(3,*),straight(16,*),co(3,*),vold(0:mi(2),*),p(3), + & xntersec(3,6*ncont),xo(*),yo(*),zo(*),x(*),y(*),z(*), + & pmastsurf(2,*),xl2m(3,8),et,xi,weight,xl2s(3,8),xsj2(3), + & shp2(7,8),pmiddle(3), + & xs2(3,2),slavnor(3,*),slavtan(6,*),dd, + & al,al1,al2,xn(3),xnabs(3),gapmints(*),slavstraight(20), + & pslavdual(16,*),diag_els(4),m_els(10),contribution,work(4) +! + real*4 rand + real*8 pslavsurf(3,*),err,pnodesin(3,3*ncont) +! + include "gauss.f" +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! + data iflag /2/ +! + kneigh=1 + err=1.d-6 +c err=1.d-2 + nintpfirst=nintpoint + compt=0 +c WRITE(*,*) "SLAVINTMORTAR" +! +! Research of the contact integration points +! + ifaces = islavsurf(1,l) + nelems = int(ifaces/10) + jfaces = ifaces - nelems*10 +! +! Decide the max integration points number, just consider 2D situation +! + if(lakon(nelems)(4:5).eq.'8R') then + nopes=4 + nope=8 + elseif(lakon(nelems)(4:4).eq.'8') then + nopes=4 + nope=8 + elseif(lakon(nelems)(4:6).eq.'20R') then + nopes=8 + nope=20 + elseif(lakon(nelems)(4:4).eq.'2') then +c nopes=8 +c nope=20 + nopes=4 + nope=20 + elseif(lakon(nelems)(4:5).eq.'10') then + nopes=6 + nope=10 + elseif(lakon(nelems)(4:4).eq.'4') then + nopes=3 + nope=4 +! +! treatment of wedge faces +! + elseif(lakon(nelems)(4:4).eq.'6') then + nope=6 + if(jfaces.le.2) then + nopes=3 + else + nopes=4 + endif + elseif(lakon(nelems)(4:5).eq.'15') then + nope=15 + if(jfaces.le.2) then + nopes=6 + else + nopes=8 + endif + endif +! +! actual position of the nodes belonging to the +! slave surface +! + do j=1,nope + konl(j)=kon(ipkon(nelems)+j) + enddo +! + if((nope.eq.20).or.(nope.eq.8)) then + do m=1,nopes + do j=1,3 + xl2s(j,m)=co(j,konl(ifaceq(m,jfaces)))+ + & vold(j,konl(ifaceq(m,jfaces))) +c & vold(j,konl(ifaceq(m,jfaces)))+err*rand(0) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + do m=1,nopes + do j=1,3 + xl2s(j,m)=co(j,konl(ifacet(m,jfaces)))+ + & vold(j,konl(ifacet(m,jfaces))) +c & vold(j,konl(ifacet(m,jfaces)))+err*rand(0) + enddo + enddo + else + do m=1,nopes + do j=1,3 + xl2s(j,m)=co(j,konl(ifacew1(m,jfaces)))+ + & vold(j,konl(ifacew1(m,jfaces))) +c & vold(j,konl(ifacew1(m,jfaces)))+err*rand(0) + enddo + enddo + endif +! +! slightly reducing the size of the slave surface in +! an aleatoric way +! + do j=1,3 + pmiddle(j)=0.d0 + do m=1,nopes + pmiddle(j)=pmiddle(j)+xl2s(j,m) + enddo + pmiddle(j)=pmiddle(j)/nopes + enddo + do j=1,3 + do m=1,nopes + xl2s(j,m)=xl2s(j,m)-err*rand(0)*(xl2s(j,m)-pmiddle(j)) + enddo + enddo +! +! calculate the mean normal vector on the Slave Surface +! + do k=1,3 + xn(k)=0.d0 + enddo + if(nopes.eq.8) then + do m = 1, nopes +! + if(nope.eq.20) then + node = konl(ifaceq(m,jfaces)) + elseif(nope.eq.15) then + node=konl(ifacew2(m,jfaces)) + endif +! + call nident(islavnode(nslavnode(i)+1), node, + & nslavnode(i+1)-nslavnode(i), id) + index1=nslavnode(i)+id + do k=1,3 + xn(k)=slavnor(k,index1)+xn(k) + enddo + enddo + elseif(nopes.eq.4) then + do m = 1, nopes +! + if((nope.eq.8).or.(nope.eq.20)) then + node = konl(ifaceq(m,jfaces)) + elseif(nope.eq.6) then + node=konl(ifacew1(m,jfaces)) + endif +! + call nident(islavnode(nslavnode(i)+1), node, + & nslavnode(i+1)-nslavnode(i), id) +! + index1=nslavnode(i)+id + do k=1,3 + xn(k)=slavnor(k,index1)+xn(k) + enddo + enddo + elseif(nopes.eq.6) then + do m = 1, nopes +! + if(nope.eq.10) then + node = konl(ifacet(m,jfaces)) + elseif(nope.eq.15) then + node = konl(ifacew2(m,jfaces)) + endif +! + call nident(islavnode(nslavnode(i)+1), node, + & nslavnode(i+1)-nslavnode(i), id) + index1=nslavnode(i)+id + do k=1,3 + xn(k)=slavnor(k,index1)+xn(k) + enddo + enddo + else + do m = 1, nopes +! + if(nope.eq.6) then + node = konl(ifacew1(m,jfaces)) + elseif(nope.eq.4) then + node = konl(ifacet(m,jfaces)) + endif +! + call nident(islavnode(nslavnode(i)+1), node, + & nslavnode(i+1)-nslavnode(i), id) + index1=nslavnode(i)+id + do k=1,3 + xn(k)=slavnor(k,index1)+xn(k) + enddo + enddo + endif +! +! normalizing the mean normal on the Slave surface +! + dd=dsqrt(xn(1)**2+xn(2)**2+xn(3)**2) + do k=1,3 + xn(k)=xn(k)/dd + enddo +! +! determine the equations of the triangle/quadrilateral +! (mean)plane and of the planes boardering the +! triangle/quadrilateral +! + if(nopes.eq.3) then + call straighteq3d(xl2s,slavstraight) + else + call approxplane(xl2s,slavstraight,xn) + endif +! +! determine the triangles corresponding to the corner +! nodes +! + ntria=0 + do j=1,4 + itria(j)=0 + do k=1,4 + itriacorner(j,k)=0 + enddo + enddo +! + do j=1,nopes + call neartriangle(xl2s(1,j),xn,xo,yo,zo,x,y,z,nx,ny,nz, + & ntri,neigh,kneigh,itietri,ntie,straight,imastop,itri,i) + if(itri.eq.0) cycle +! +! + node = konl(ifaceq(j,jfaces)) + call nident(islavnode(nslavnode(i)+1), node, + & nslavnode(i+1)-nslavnode(i), id) + if (islavact(nslavnode(i)+id).eq.-1) then + islavact(nslavnode(i)+id)=0 + endif +! +! + call nident(itria,itri,ntria,id) + if(id.gt.0) then + if(itria(id).eq.itri) then + itriacorner(j,id)=1 + cycle + endif + endif +! +! triangle was not covered yet: add to stack +! + ntria=ntria+1 + do k=ntria,id+2,-1 + itria(k)=itria(k-1) + do m=1,j-1 + itriacorner(m,k)=itriacorner(m,k-1) + enddo + enddo + itria(id+1)=itri + itriacorner(j,id+1)=1 + do m=1,j-1 + itriacorner(m,id+1)=0 + enddo + enddo +! + nnodesin=0 + nnodesout=0 + nactiveline=0 + ifreeintersec=0 +! +! treating the corner triangles first +! + do j=1,ntria + itri=itria(j) + nelemm=int(koncont(4,itri)/10.d0) + jfacem=koncont(4,itri)-10*nelemm +! + indexe=ipkon(nelemm) + if(lakon(nelemm)(4:4).eq.'2') then + nnodelem=8 + nface=6 + elseif(lakon(nelemm)(4:4).eq.'8') then + nnodelem=4 + nface=6 + elseif(lakon(nelemm)(4:5).eq.'10') then + nnodelem=6 + nface=4 + elseif(lakon(nelemm)(4:4).eq.'4') then + nnodelem=3 + nface=4 + elseif(lakon(nelemm)(4:5).eq.'15') then + if(jfacem.le.2) then + nnodelem=6 + else + nnodelem=8 + endif + nface=5 + nope=15 + elseif(lakon(nelemm)(4:4).eq.'6') then + if(jfacem.le.2) then + nnodelem=3 + else + nnodelem=4 + endif + nface=5 + nope=6 + else + cycle + endif +! +! determining the nodes of the face +! + if(nface.eq.4) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacet(k,jfacem)) + enddo + elseif(nface.eq.5) then + if(nope.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew1(k,jfacem)) + enddo + elseif(nope.eq.15) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew2(k,jfacem)) + enddo + endif + elseif(nface.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifaceq(k,jfacem)) + enddo + endif +! + do k1=1,nnodelem + do j1 = 1,3 + xl2m(j1,k1) = co(j1,nodef(k1))+vold(j1,nodef(k1)) + enddo + enddo +! + call treattriangle(inodesin,nnodesin,inodesout, + & nnodesout,nopes,slavstraight,xn,co,xl2s,ipe,ime, + & iactiveline,nactiveline,intersec,xntersec, + & ifreeintersec,itri,koncont,itriacorner(1,j), + & nintpoint,pslavsurf,ncont,imastsurf,pmastsurf, + & xl2m,nnodelem,vold,mi,pnodesin,straight,gapmints,l) + enddo +! +! retrieving all triangles by neighborhood search +! + do + line=iactiveline(1,1) + if(nactiveline.eq.0) exit + if(ime(2,line).eq.iactiveline(2,1)) then + itri=imastop(ime(3,line),ime(2,line)) + else + itri=ime(2,line) + endif +! +! corners of the Slave surface have already been treated +! + if(itri.eq.0) then + nactiveline=nactiveline-1 + do il=1,nactiveline + do k=1,3 + iactiveline(k,il)=iactiveline(k,il+1) + enddo + enddo + cycle + endif + do j=1,4 + itriacorner(j,1)=0 + enddo +! + nelemm=int(koncont(4,itri)/10.d0) + jfacem=koncont(4,itri)-10*nelemm +! + indexe=ipkon(nelemm) + if(lakon(nelemm)(4:4).eq.'2') then + nnodelem=8 + nface=6 + elseif(lakon(nelemm)(4:4).eq.'8') then + nnodelem=4 + nface=6 + elseif(lakon(nelemm)(4:5).eq.'10') then + nnodelem=6 + nface=4 + elseif(lakon(nelemm)(4:4).eq.'4') then + nnodelem=3 + nface=4 + elseif(lakon(nelemm)(4:5).eq.'15') then + if(jfacem.le.2) then + nnodelem=6 + else + nnodelem=8 + endif + nface=5 + nope=15 + elseif(lakon(nelemm)(4:4).eq.'6') then + if(jfacem.le.2) then + nnodelem=3 + else + nnodelem=4 + endif + nface=5 + nope=6 + else + cycle + endif +! +! determining the nodes of the face +! + if(nface.eq.4) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacet(k,jfacem)) + enddo + elseif(nface.eq.5) then + if(nope.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew1(k,jfacem)) + enddo + elseif(nope.eq.15) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew2(k,jfacem)) + enddo + endif + elseif(nface.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifaceq(k,jfacem)) + enddo + endif +! + do k1=1,nnodelem + do j1 = 1,3 + xl2m(j1,k1) = co(j1,nodef(k1))+vold(j1,nodef(k1)) + enddo + enddo +! + compt=compt+1 + call treattriangle(inodesin,nnodesin,inodesout, + & nnodesout,nopes,slavstraight,xn,co,xl2s,ipe,ime, + & iactiveline,nactiveline,intersec,xntersec, + & ifreeintersec,itri,koncont,itriacorner,nintpoint, + & pslavsurf,ncont,imastsurf,pmastsurf, + & xl2m,nnodelem,vold,mi,pnodesin,straight,gapmints,l) + enddo +! + islavsurf(2,l+1)=nintpoint +! +! +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/smooth.f calculix-ccx-2.3/ccx_2.3/src/smooth.f --- calculix-ccx-2.1/ccx_2.3/src/smooth.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/smooth.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,70 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine smooth(adb,aub,adl,sol,aux,icol,irow,jq, + & neq,nzl,csmooth) +! +! smoothing the finite element solution +! +! Ref: The Finite Element Method for Fluid Dynamics, +! O.C. Zienkiewicz, R.L. Taylor & P. Nithiarasu +! 6th edition (2006) ISBN 0 7506 6322 7 +! p. 61 +! + implicit none +! + integer icol(*),irow(*),jq(*),neq,nzl,i,j,k +! + real*8 adb(*),aub(*),adl(*),sol(*),aux(*),p,csmooth,c1,c2 +! +! multiplying the original matrix with zero +! diagonal with the actual solution +! + call op(neq,p,sol,aux,adb,aub,icol,irow,nzl) +c call op(neq,p,sol,aux,adl,aub,icol,irow,nzl) +! +! lumping the matrix set (adb,aux) and storing the resulting +! diagonal terms in adl +! + do i=1,neq + adl(i)=adb(i) + enddo +! + do j=1,neq + do k=jq(j),jq(j+1)-1 + i=irow(k) + adl(i)=adl(i)+aub(k) + adl(j)=adl(j)+aub(k) + enddo + enddo +! +! determining the multiplicative constants +! + c2=1.d0+csmooth/2.d0 + c1=1.d0/c2 + c2=csmooth/c2 +! +! smoothing the solution +! + do i=1,neq + sol(i)=c1*sol(i)+c2*aux(i)/adl(i)/2.d0 +c sol(i)=c1*sol(i)+c2*aux(i)/adl(i) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/smoothshock.f calculix-ccx-2.3/ccx_2.3/src/smoothshock.f --- calculix-ccx-2.1/ccx_2.3/src/smoothshock.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/smoothshock.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,46 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine smoothshock(adb,aub,adl,addiv,sol,aux,icol,irow,jq, + & neq,nzl,sa) +! +! smoothing the finite element solution +! +! Ref: The Finite Element Method for Fluid Dynamics, +! O.C. Zienkiewicz, R.L. Taylor & P. Nithiarasu +! 6th edition (2006) ISBN 0 7506 6322 7 +! p. 61 +! + implicit none +! + integer icol(*),irow(*),jq(*),neq,nzl,i,j,k +! + real*8 adb(*),aub(*),adl(*),sol(*),aux(*),p,sa(*),addiv(*) +! +! multiplying M-ML with the solution +! + call op(neq,p,sol,aux,adb,aub,icol,irow,nzl) +! +! smoothing the solution +! + do i=1,neq + sol(i)=sol(i)+sa(i)*aux(i)*adl(i) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/solidsections.f calculix-ccx-2.3/ccx_2.3/src/solidsections.f --- calculix-ccx-2.1/ccx_2.3/src/solidsections.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/solidsections.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,310 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine solidsections(inpc,textpart,set,istartset,iendset, + & ialset,nset,ielmat,matname,nmat,ielorien,orname,norien, + & lakon,thicke,kon,ipkon,irstrt,istep,istat,n,iline,ipol,inl, + & ipoinp,inp,cs,mcs,iaxial,ipoinpc) +! +! reading the input deck: *SOLID SECTION +! + implicit none +! + character*1 inpc(*) + character*8 lakon(*) + character*80 matname(*),orname(*),material,orientation + character*81 set(*),elset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),ielmat(*), + & ielorien(*),kon(*),ipkon(*),indexe,irstrt,nset,nmat,norien, + & istep,istat,n,key,i,j,k,l,imaterial,iorientation,ipos, + & iline,ipol,inl,ipoinp(2,*),inp(3,*),mcs,iaxial,ipoinpc(0:*) +! + real*8 thicke(2,*),thickness,pi,cs(17,*) +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in solidsections: *SOLID SECTION should' + write(*,*) ' be placed before all step definitions' + stop + endif +! + pi=4.d0*datan(1.d0) +! + orientation=' + & ' + elset=' + & ' + ipos=0 +! + do i=2,n + if(textpart(i)(1:9).eq.'MATERIAL=') then + material=textpart(i)(10:89) + elseif(textpart(i)(1:12).eq.'ORIENTATION=') then + orientation=textpart(i)(13:92) + elseif(textpart(i)(1:6).eq.'ELSET=') then + elset=textpart(i)(7:86) + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + else + write(*,*) + & '*WARNING in solidsections: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! +! check for the existence of the set,the material and orientation +! + do i=1,nmat + if(matname(i).eq.material) exit + enddo + if(i.gt.nmat) then + do i=1,nmat + if(matname(i)(1:11).eq.'ANISO_CREEP') then + if(matname(i)(12:20).eq.material(1:9)) exit + elseif(matname(i)(1:10).eq.'ANISO_PLAS') then + if(matname(i)(11:20).eq.material(1:10)) exit + endif + enddo + endif + if(i.gt.nmat) then + write(*,*) '*ERROR in solidsections: nonexistent material' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + imaterial=i +! + if(orientation.eq.' ') then + iorientation=0 + else + do i=1,norien + if(orname(i).eq.orientation) exit + enddo + if(i.gt.norien) then + write(*,*)'*ERROR in solidsections: nonexistent orientation' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iorientation=i + endif +! + if(ipos.eq.0) then + write(*,*) '*ERROR in solidsections: no element set ',elset + write(*,*) ' was been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + do i=1,nset + if(set(i).eq.elset) exit + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR in solidsections: element set ',elset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! +! assigning the elements of the set the appropriate material +! and orientation number +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + if((lakon(ialset(j))(1:1).eq.'B').or. + & (lakon(ialset(j))(1:1).eq.'S')) then + write(*,*) '*ERROR in solidsections: *SOLID SECTION can' + write(*,*) ' not be used for beam or shell elements + &' + write(*,*) ' Faulty element: ',ialset(j) + stop + endif + ielmat(ialset(j))=imaterial + ielorien(ialset(j))=iorientation + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + if((lakon(k)(1:1).eq.'B').or. + & (lakon(k)(1:1).eq.'S')) then + write(*,*) '*ERROR in solidsections: *SOLID SECTION ca + &n' + write(*,*) ' not be used for beam or shell eleme + &nts' + write(*,*) ' Faulty element: ',k + stop + endif + ielmat(k)=imaterial + ielorien(k)=iorientation + enddo + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! +! assigning a thickness to plane stress elements and an angle to +! axisymmetric elements +! + if((key.eq.0).or.(lakon(ialset(istartset(i)))(1:2).eq.'CA')) then + if(key.eq.0) then + read(textpart(1)(1:20),'(f20.0)',iostat=istat) thickness + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! +! for axial symmetric structures: +! thickness for axial symmetric elements: 1 degree +! thickness for plane stress elements: reduced by 360 +! thickness for plane strain elements: reduced by 360 +! + if(iaxial.ne.0) then + if(lakon(ialset(istartset(i)))(1:2).eq.'CA') then + thickness=datan(1.d0)*8.d0/iaxial + elseif(lakon(ialset(istartset(i)))(1:3).eq.'CPS') then + thickness=thickness/iaxial + elseif(lakon(ialset(istartset(i)))(1:3).eq.'CPE') then + thickness=thickness/iaxial + endif + endif + else + thickness=datan(1.d0)*8.d0/iaxial + endif +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + if((lakon(ialset(j))(1:2).eq.'CP').or. + & (lakon(ialset(j))(1:2).eq.'CA')) then + indexe=ipkon(ialset(j)) + do l=1,8 + thicke(1,indexe+l)=thickness + enddo + endif + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + if((lakon(k)(1:2).eq.'CP').or. + & (lakon(k)(1:2).eq.'CA')) then + indexe=ipkon(k) + do l=1,8 + thicke(1,indexe+l)=thickness + enddo + endif + enddo + endif + enddo +! +! defining cyclic symmetric conditions for axisymmetric +! elements (needed for cavity radiation) +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + if(lakon(ialset(j))(1:2).eq.'CA') then + if(mcs.gt.1) then + write(*,*) '*ERROR in solidsections: ' + write(*,*) ' axisymmetric elements cannot be + &combined with cyclic symmetry' + stop + elseif(mcs.eq.1) then + if(int(cs(1,1)).ne.int(2.d0*pi/thickness+0.5d0)) + & then + write(*,*) '*ERROR in solidsections: ' + write(*,*) ' it is not allowed to define t + &wo different' + write(*,*) ' angles for an axisymmetric st + &ructure' + stop + else + exit + endif + endif + mcs=1 + cs(1,1)=2.d0*pi/thickness+0.5d0 + cs(2,1)=-0.5d0 + cs(3,1)=-0.5d0 + cs(5,1)=1.5d0 + do k=6,9 + cs(k,1)=0.d0 + enddo + cs(10,1)=1.d0 + cs(11,1)=0.d0 + cs(12,1)=-1.d0 + cs(14,1)=0.5 + cs(15,1)=dcos(thickness) + cs(16,1)=dsin(thickness) + exit + endif + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit +c if(lakon(ialset(j))(1:2).eq.'CA') then + if(lakon(k)(1:2).eq.'CA') then + if(mcs.gt.1) then + write(*,*) '*ERROR in solidsections: ' + write(*,*) ' axisymmetric elements cannot + &be combined with cyclic symmetry' + stop + elseif(mcs.eq.1) then + if(int(cs(1,1)).ne.int(2.d0*pi/thickness+0.5d0)) + & then + write(*,*) '*ERROR in solidsections: ' + write(*,*) ' it is not allowed to defin + &e two different' + write(*,*) ' angles for an axisymmetric + & structure' + stop + else + exit + endif + endif + mcs=1 + cs(1,1)=2.d0*pi/thickness+0.5d0 + cs(2,1)=-0.5d0 + cs(3,1)=-0.5d0 + cs(5,1)=1.5d0 + do k=6,9 + cs(k,1)=0.d0 + enddo + cs(10,1)=1.d0 + cs(11,1)=0.d0 + cs(12,1)=-1.d0 + cs(14,1)=0.5 + cs(15,1)=dcos(thickness) + cs(16,1)=dsin(thickness) + exit + endif + enddo + endif + enddo +! + if(key.eq.0) then + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + endif + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/solveeq.f calculix-ccx-2.3/ccx_2.3/src/solveeq.f --- calculix-ccx-2.1/ccx_2.3/src/solveeq.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/solveeq.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,62 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine solveeq(adb,aub,adl,addiv,b,sol,aux,icol,irow,jq, + & neq,nzs,nzl) +! +! solving a system of equations by iteratively solving the +! lumped version +! The diagonal terms f the original system are stored in adb, +! the off-diagonal terms in aub +! Ref: The Finite Element Method for Fluid Dynamics, +! O.C. Zienkiewicz, R.L. Taylor & P. Nithiarasu +! 6th edition (2006) ISBN 0 7506 6322 7 +! p. 61 +! + implicit none +! + integer icol(*),irow(*),jq(*),neq,nzs,nzl,i,j,k,maxit +! + real*8 adb(*),aub(*),adl(*),addiv(*),b(*),sol(*),aux(*),p +! + data maxit /1/ +! +! first iteration +! + do i=1,neq + sol(i)=b(i)*adl(i) + enddo + if(maxit.eq.1) return +! +! iterating maxit times +! + do k=2,maxit +! +! multiplying the difference of the original matrix +! with the lumped matrix with the actual solution +! + call op(neq,p,sol,aux,adb,aub,icol,irow,nzl) +! + do i=1,neq + sol(i)=(b(i)-aux(i))*adl(i) + enddo +! + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/spcmatch.f calculix-ccx-2.3/ccx_2.3/src/spcmatch.f --- calculix-ccx-2.1/ccx_2.3/src/spcmatch.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/spcmatch.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,69 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine spcmatch(xboun,nodeboun,ndirboun,nboun,xbounold, + & nodebounold,ndirbounold,nbounold,ikboun,ilboun,vold,reorder, + & nreorder,mi) +! +! matches SPC boundary conditions of one step with those of +! the previous step +! + implicit none +! + integer nodeboun(*),ndirboun(*),nboun,nodebounold(*),ilboun(*), + & ndirbounold(*),nbounold,i,kflag,idof,id,nreorder(*),ikboun(*), + & mi(2) +! + real*8 xboun(*),xbounold(*),vold(0:mi(2),*),reorder(*) +! + kflag=2 +! + do i=1,nboun + nreorder(i)=0 + enddo +! + do i=1,nbounold + idof=8*(nodebounold(i)-1)+ndirbounold(i) + if(nboun.gt.0) then + call nident(ikboun,idof,nboun,id) + else + id=0 + endif + if((id.gt.0).and.(ikboun(id).eq.idof)) then + reorder(ilboun(id))=xbounold(i) + nreorder(ilboun(id))=1 + endif + enddo +! + do i=1,nboun + if(nreorder(i).eq.0) then + if(ndirboun(i).gt.4) then + reorder(i)=0.d0 + else + reorder(i)=vold(ndirboun(i),nodeboun(i)) + endif + endif + enddo +! + do i=1,nboun + xbounold(i)=reorder(i) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/specificgasconstants.f calculix-ccx-2.3/ccx_2.3/src/specificgasconstants.f --- calculix-ccx-2.1/ccx_2.3/src/specificgasconstants.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/specificgasconstants.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,66 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine specificgasconstants(inpc,textpart,shcon,nshcon, + & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, + & inp,ipoinpc) +! +! reading the input deck: *SPECIFIC GAS CONSTANT +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nshcon(*),nmat,ntmat_,istep,istat,n,ipoinpc(0:*), + & key,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),i +! + real*8 shcon(0:3,ntmat_,*) +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in specificheats: *SPECIFIC GAS CONSTANT' + write(*,*) ' should be placed before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in specificheats: *SPECIFIC GAS CONSTANT' + write(*,*) ' should be preceded by a *MATERIAL card' + stop + endif +! + do i=2,n + write(*,*) + & '*WARNING in specificgasconstants: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + enddo +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + read(textpart(1)(1:20),'(f20.0)',iostat=istat) + & shcon(3,1,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/specificheats.f calculix-ccx-2.3/ccx_2.3/src/specificheats.f --- calculix-ccx-2.1/ccx_2.3/src/specificheats.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/specificheats.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,77 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine specificheats(inpc,textpart,shcon,nshcon, + & nmat,ntmat_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp, + & inp,ipoinpc) +! +! reading the input deck: *SPECIFIC HEAT +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nshcon(*),nmat,ntmat,ntmat_,istep,istat,n,ipoinpc(0:*), + & key,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),i +! + real*8 shcon(0:3,ntmat_,*) +! + ntmat=0 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in specificheats: *SPECIFIC HEAT should be' + write(*,*) ' placed before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in specificheats: *SPECIFIC HEAT should be' + write(*,*) ' preceded by a *MATERIAL card' + stop + endif +! + do i=2,n + write(*,*) + & '*WARNING in specificheats: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + enddo +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + nshcon(nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in specificheats: increase ntmat_' + stop + endif + read(textpart(1)(1:20),'(f20.0)',iostat=istat) + & shcon(1,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) + & shcon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/splitline.f calculix-ccx-2.3/ccx_2.3/src/splitline.f --- calculix-ccx-2.1/ccx_2.3/src/splitline.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/splitline.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,94 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine splitline(text,textpart,n) +! + implicit none +! +! splits an input line (text) in n comma separated fields (textpart) +! +! n = # comma's +1, +! + integer n,i,j,k,ierror +! + character*1 ctext + character*132 text,textpart(16) +! + n=1 + j=0 + do i=1,132 + ctext=text(i:i) + if(ctext.ne.',') then + if(ctext.eq.' ') then +c cycle + exit + else +c if((ichar(ctext).ge.97).and.(ichar(ctext).le.122)) +c & ctext=char(ichar(ctext)-32) + endif + j=j+1 + if(j.le.132) textpart(n)(j:j)=ctext + else + do k=j+1,132 + textpart(n)(k:k)=' ' + enddo + j=0 + n=n+1 + if(n.gt.16) then + ierror=0 + do k=i+1,132 + if(text(k:k).eq.',') cycle + if(text(k:k).eq.' ') then + if(ierror.eq.0) then + exit + else + write(*,*) + & '*ERROR in splitline: there should not' + write(*,*)' be more than 16 entries in a ' + write(*,*) ' line; ' + write(*,'(a132)') text(1:k-1) + stop + endif + endif + ierror=1 + enddo + exit + endif + endif + enddo + if(j.eq.0) then + n=n-1 + else + do k=j+1,132 + textpart(n)(k:k)=' ' + enddo + endif +! +! clearing all textpart fields not used +! + do i=n+1,16 + textpart(i)=' + & + & ' + enddo +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/spooles.c calculix-ccx-2.3/ccx_2.3/src/spooles.c --- calculix-ccx-2.1/ccx_2.3/src/spooles.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/spooles.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,738 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ +/* + * The implementation is derived from the SPOOLES sample described in + * AllInOne.ps + * created -- 98jun04, cca + * + * Converted to something that resembles C and + * support for multithreaded solving added. + * (C) 2003 Manfred Spraul + */ + +#ifdef SPOOLES + +#include +#include +#include +#include +#include "CalculiX.h" +#include "spooles.h" + +#if USE_MT +int num_cpus = -1; +#endif + +#define TUNE_MAXZEROS 1000 +#define TUNE_MAXDOMAINSIZE 800 +#define TUNE_MAXSIZE 64 + +#define RNDSEED 7892713 +#define MAGIC_DTOL 0.0 +#define MAGIC_TAU 100.0 + +/* + * Substeps for solving A X = B: + * + * (1) form Graph object + * (2) order matrix and form front tree + * (3) get the permutation, permute the matrix and + * front tree and get the symbolic factorization + * (4) compute the numeric factorization + * (5) read in right hand side entries + * (6) compute the solution + * + * The ssolve_main functions free the input matrices internally + */ + +static void ssolve_creategraph(Graph ** graph, ETree ** frontETree, + InpMtx * mtxA, int size, FILE * msgFile) +{ + IVL *adjIVL; + int nedges; + + *graph = Graph_new(); + adjIVL = InpMtx_fullAdjacency(mtxA); + nedges = IVL_tsize(adjIVL); + Graph_init2(*graph, 0, size, 0, nedges, size, nedges, adjIVL, + NULL, NULL); + if (DEBUG_LVL > 1) { + fprintf(msgFile, "\n\n graph of the input matrix"); + Graph_writeForHumanEye(*graph, msgFile); + fflush(msgFile); + } + /* (2) order the graph using multiple minimum degree */ + + /*maxdomainsize=neqns/100; */ + /*if (maxdomainsize==0) maxdomainsize=1; */ + /* *frontETree = orderViaMMD(*graph, RNDSEED, DEBUG_LVL, msgFile) ; */ + /* *frontETree = orderViaND(*graph,maxdomainsize,RNDSEED,DEBUG_LVL,msgFile); */ + /* *frontETree = orderViaMS(*graph,maxdomainsize,RNDSEED,DEBUG_LVL,msgFile); */ + + *frontETree = + orderViaBestOfNDandMS(*graph, TUNE_MAXDOMAINSIZE, + TUNE_MAXZEROS, TUNE_MAXSIZE, RNDSEED, + DEBUG_LVL, msgFile); + if (DEBUG_LVL > 1) { + fprintf(msgFile, "\n\n front tree from ordering"); + ETree_writeForHumanEye(*frontETree, msgFile); + fflush(msgFile); + } +} + +static void ssolve_permuteA(IV ** oldToNewIV, IV ** newToOldIV, + IVL ** symbfacIVL, ETree * frontETree, + InpMtx * mtxA, FILE * msgFile, int *symmetryflag) +{ + int *oldToNew; + + *oldToNewIV = ETree_oldToNewVtxPerm(frontETree); + oldToNew = IV_entries(*oldToNewIV); + *newToOldIV = ETree_newToOldVtxPerm(frontETree); + ETree_permuteVertices(frontETree, *oldToNewIV); + InpMtx_permute(mtxA, oldToNew, oldToNew); + if(*symmetryflag!=2) InpMtx_mapToUpperTriangle(mtxA); + InpMtx_changeCoordType(mtxA, INPMTX_BY_CHEVRONS); + InpMtx_changeStorageMode(mtxA, INPMTX_BY_VECTORS); + *symbfacIVL = SymbFac_initFromInpMtx(frontETree, mtxA); + if (DEBUG_LVL > 1) { + fprintf(msgFile, "\n\n old-to-new permutation vector"); + IV_writeForHumanEye(*oldToNewIV, msgFile); + fprintf(msgFile, "\n\n new-to-old permutation vector"); + IV_writeForHumanEye(*newToOldIV, msgFile); + fprintf(msgFile, "\n\n front tree after permutation"); + ETree_writeForHumanEye(frontETree, msgFile); + fprintf(msgFile, "\n\n input matrix after permutation"); + InpMtx_writeForHumanEye(mtxA, msgFile); + fprintf(msgFile, "\n\n symbolic factorization"); + IVL_writeForHumanEye(*symbfacIVL, msgFile); + fflush(msgFile); + } +} + +static void ssolve_postfactor(FrontMtx *frontmtx, FILE *msgFile) +{ + FrontMtx_postProcess(frontmtx, DEBUG_LVL, msgFile); + if (DEBUG_LVL > 1) { + fprintf(msgFile, "\n\n factor matrix after post-processing"); + FrontMtx_writeForHumanEye(frontmtx, msgFile); + fflush(msgFile); + } +} + +static void ssolve_permuteB(DenseMtx *mtxB, IV *oldToNewIV, FILE* msgFile) +{ + DenseMtx_permuteRows(mtxB, oldToNewIV); + if (DEBUG_LVL > 1) { + fprintf(msgFile, + "\n\n right hand side matrix in new ordering"); + DenseMtx_writeForHumanEye(mtxB, msgFile); + fflush(msgFile); + } +} + +static void ssolve_permuteout(DenseMtx *mtxX, IV *newToOldIV, FILE *msgFile) +{ + DenseMtx_permuteRows(mtxX, newToOldIV); + if (DEBUG_LVL > 1) { + fprintf(msgFile, "\n\n solution matrix in original ordering"); + DenseMtx_writeForHumanEye(mtxX, msgFile); + fflush(msgFile); + } +} + + void factor(struct factorinfo *pfi, InpMtx *mtxA, int size, FILE *msgFile, + int *symmetryflag) +{ + Graph *graph; + IVL *symbfacIVL; + Chv *rootchv; + + /* Initialize pfi: */ + pfi->size = size; + pfi->msgFile = msgFile; + pfi->solvemap = NULL; + DVfill(10, pfi->cpus, 0.0); + + /* + * STEP 1 : find a low-fill ordering + * (1) create the Graph object + */ + ssolve_creategraph(&graph, &pfi->frontETree, mtxA, size, pfi->msgFile); + + /* + * STEP 2: get the permutation, permute the matrix and + * front tree and get the symbolic factorization + */ + ssolve_permuteA(&pfi->oldToNewIV, &pfi->newToOldIV, &symbfacIVL, pfi->frontETree, + mtxA, pfi->msgFile, symmetryflag); + + /* + * STEP 3: initialize the front matrix object + */ + { + pfi->frontmtx = FrontMtx_new(); + pfi->mtxmanager = SubMtxManager_new(); + SubMtxManager_init(pfi->mtxmanager, NO_LOCK, 0); + FrontMtx_init(pfi->frontmtx, pfi->frontETree, symbfacIVL, SPOOLES_REAL, + *symmetryflag, FRONTMTX_DENSE_FRONTS, + SPOOLES_PIVOTING, NO_LOCK, 0, NULL, + pfi->mtxmanager, DEBUG_LVL, pfi->msgFile); + } + + /* + * STEP 4: compute the numeric factorization + */ + { + ChvManager *chvmanager; + int stats[20]; + int error; + + chvmanager = ChvManager_new(); + ChvManager_init(chvmanager, NO_LOCK, 1); + IVfill(20, stats, 0); + rootchv = FrontMtx_factorInpMtx(pfi->frontmtx, mtxA, MAGIC_TAU, MAGIC_DTOL, + chvmanager, &error, pfi->cpus, + stats, DEBUG_LVL, pfi->msgFile); + ChvManager_free(chvmanager); + if (DEBUG_LVL > 1) { + fprintf(msgFile, "\n\n factor matrix"); + FrontMtx_writeForHumanEye(pfi->frontmtx, pfi->msgFile); + fflush(msgFile); + } + if (rootchv != NULL) { + fprintf(pfi->msgFile, "\n\n matrix found to be singular\n"); + exit(-1); + } + if (error >= 0) { + fprintf(pfi->msgFile, "\n\nerror encountered at front %d", + error); + exit(-1); + } + } + /* + * STEP 5: post-process the factorization + */ + ssolve_postfactor(pfi->frontmtx, pfi->msgFile); + + /* cleanup: */ + IVL_free(symbfacIVL); + InpMtx_free(mtxA); + Graph_free(graph); +} + +DenseMtx *fsolve(struct factorinfo *pfi, DenseMtx *mtxB) +{ + DenseMtx *mtxX; + /* + * STEP 6: permute the right hand side into the new ordering + */ + { + DenseMtx_permuteRows(mtxB, pfi->oldToNewIV); + if (DEBUG_LVL > 1) { + fprintf(pfi->msgFile, + "\n\n right hand side matrix in new ordering"); + DenseMtx_writeForHumanEye(mtxB, pfi->msgFile); + fflush(pfi->msgFile); + } + } + /* + * STEP 7: solve the linear system + */ + { + mtxX = DenseMtx_new(); + DenseMtx_init(mtxX, SPOOLES_REAL, 0, 0, pfi->size, 1, 1, pfi->size); + DenseMtx_zero(mtxX); + FrontMtx_solve(pfi->frontmtx, mtxX, mtxB, pfi->mtxmanager, pfi->cpus, + DEBUG_LVL, pfi->msgFile); + if (DEBUG_LVL > 1) { + fprintf(pfi->msgFile, "\n\n solution matrix in new ordering"); + DenseMtx_writeForHumanEye(mtxX, pfi->msgFile); + fflush(pfi->msgFile); + } + } + /* + * STEP 8: permute the solution into the original ordering + */ + ssolve_permuteout(mtxX, pfi->newToOldIV, pfi->msgFile); + + /* cleanup: */ + DenseMtx_free(mtxB); + + return mtxX; +} + +#ifdef USE_MT +static void factor_MT(struct factorinfo *pfi, InpMtx *mtxA, int size, FILE *msgFile, int *symmetryflag) +{ + Graph *graph; + IV *ownersIV; + IVL *symbfacIVL; + Chv *rootchv; + + /* Initialize pfi: */ + pfi->size = size; + pfi->msgFile = msgFile; + DVfill(10, pfi->cpus, 0.0); + + /* + * STEP 1 : find a low-fill ordering + * (1) create the Graph object + */ + ssolve_creategraph(&graph, &pfi->frontETree, mtxA, size, msgFile); + + /* + * STEP 2: get the permutation, permute the matrix and + * front tree and get the symbolic factorization + */ + ssolve_permuteA(&pfi->oldToNewIV, &pfi->newToOldIV, &symbfacIVL, pfi->frontETree, + mtxA, msgFile, symmetryflag); + + /* + * STEP 3: Prepare distribution to multiple threads/cpus + */ + { + DV *cumopsDV; + int nfront; + + nfront = ETree_nfront(pfi->frontETree); + + pfi->nthread = num_cpus; + if (pfi->nthread > nfront) + pfi->nthread = nfront; + + cumopsDV = DV_new(); + DV_init(cumopsDV, pfi->nthread, NULL); + ownersIV = ETree_ddMap(pfi->frontETree, SPOOLES_REAL, *symmetryflag, + cumopsDV, 1. / (2. * pfi->nthread)); + if (DEBUG_LVL > 1) { + fprintf(msgFile, + "\n\n map from fronts to threads"); + IV_writeForHumanEye(ownersIV, msgFile); + fprintf(msgFile, + "\n\n factor operations for each front"); + DV_writeForHumanEye(cumopsDV, msgFile); + fflush(msgFile); + } else { + fprintf(msgFile, "\n\n Using %d threads\n", + pfi->nthread); + } + DV_free(cumopsDV); + } + + /* + * STEP 4: initialize the front matrix object + */ + { + pfi->frontmtx = FrontMtx_new(); + pfi->mtxmanager = SubMtxManager_new(); + SubMtxManager_init(pfi->mtxmanager, LOCK_IN_PROCESS, 0); + FrontMtx_init(pfi->frontmtx, pfi->frontETree, symbfacIVL, SPOOLES_REAL, + *symmetryflag, FRONTMTX_DENSE_FRONTS, + SPOOLES_PIVOTING, LOCK_IN_PROCESS, 0, NULL, + pfi->mtxmanager, DEBUG_LVL, pfi->msgFile); + } + + /* + * STEP 5: compute the numeric factorization in parallel + */ + { + ChvManager *chvmanager; + int stats[20]; + int error; + + chvmanager = ChvManager_new(); + ChvManager_init(chvmanager, LOCK_IN_PROCESS, 1); + IVfill(20, stats, 0); + rootchv = FrontMtx_MT_factorInpMtx(pfi->frontmtx, mtxA, MAGIC_TAU, MAGIC_DTOL, + chvmanager, ownersIV, 0, + &error, pfi->cpus, stats, DEBUG_LVL, + pfi->msgFile); + ChvManager_free(chvmanager); + if (DEBUG_LVL > 1) { + fprintf(msgFile, "\n\n factor matrix"); + FrontMtx_writeForHumanEye(pfi->frontmtx, pfi->msgFile); + fflush(pfi->msgFile); + } + if (rootchv != NULL) { + fprintf(pfi->msgFile, "\n\n matrix found to be singular\n"); + exit(-1); + } + if (error >= 0) { + fprintf(pfi->msgFile, "\n\n fatal error at front %d", error); + exit(-1); + } + } + + /* + * STEP 6: post-process the factorization + */ + ssolve_postfactor(pfi->frontmtx, pfi->msgFile); + + /* + * STEP 7: get the solve map object for the parallel solve + */ + { + pfi->solvemap = SolveMap_new(); + SolveMap_ddMap(pfi->solvemap, *symmetryflag, + FrontMtx_upperBlockIVL(pfi->frontmtx), + FrontMtx_lowerBlockIVL(pfi->frontmtx), pfi->nthread, ownersIV, + FrontMtx_frontTree(pfi->frontmtx), RNDSEED, DEBUG_LVL, + pfi->msgFile); + } + + /* cleanup: */ + InpMtx_free(mtxA); + IVL_free(symbfacIVL); + Graph_free(graph); + IV_free(ownersIV); +} + +DenseMtx *fsolve_MT(struct factorinfo *pfi, DenseMtx *mtxB) +{ + DenseMtx *mtxX; + /* + * STEP 8: permute the right hand side into the new ordering + */ + ssolve_permuteB(mtxB, pfi->oldToNewIV, pfi->msgFile); + + + /* + * STEP 9: solve the linear system in parallel + */ + { + mtxX = DenseMtx_new(); + DenseMtx_init(mtxX, SPOOLES_REAL, 0, 0, pfi->size, 1, 1, pfi->size); + DenseMtx_zero(mtxX); + FrontMtx_MT_solve(pfi->frontmtx, mtxX, mtxB, pfi->mtxmanager, + pfi->solvemap, pfi->cpus, DEBUG_LVL, + pfi->msgFile); + if (DEBUG_LVL > 1) { + fprintf(pfi->msgFile, "\n\n solution matrix in new ordering"); + DenseMtx_writeForHumanEye(mtxX, pfi->msgFile); + fflush(pfi->msgFile); + } + } + + /* + * STEP 10: permute the solution into the original ordering + */ + ssolve_permuteout(mtxX, pfi->newToOldIV, pfi->msgFile); + + /* Cleanup */ + DenseMtx_free(mtxB); + + return mtxX; +} + +#endif + +/** + * factor a system of the form (au - sigma * aub) + * +*/ + +FILE *msgFile; +struct factorinfo pfi; + +void spooles_factor(double *ad, double *au, double *adb, double *aub, + double *sigma,int *icol, int *irow, + int *neq, int *nzs, int *symmetryflag, int *inputformat) +{ + int size = *neq; + InpMtx *mtxA; + + printf(" Factoring the system of equations using spooles\n\n"); + +/* if(*neq==0) return;*/ + + if ((msgFile = fopen("spooles.out", "a")) == NULL) { + fprintf(stderr, "\n fatal error in spooles.c" + "\n unable to open file spooles.out\n"); + } + + /* + * Create the InpMtx object from the Calculix matrix + * representation + */ + + { + int row, ipoint, ipo; + int nent,i,j; + + mtxA = InpMtx_new(); + + if((*inputformat==0)||(*inputformat==3)){ + nent = *nzs + *neq; /* estimated # of nonzero entries */ + }else if(*inputformat==1){ + nent=2**nzs+*neq; + }else if(*inputformat==2){ + nent=0; + for(i=0;i<*neq;i++){ + for(j=0;j<*neq;j++){ + if(fabs(ad[i**nzs+j])>1.e-20) nent++; + } + } + } + + InpMtx_init(mtxA, INPMTX_BY_ROWS, SPOOLES_REAL, nent, size); + + if(*inputformat==0){ + ipoint = 0; + + if(*sigma==0.){ + for (row = 0; row < size; row++) { + InpMtx_inputRealEntry(mtxA, row, row, ad[row]); + for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { + int col = irow[ipo] - 1; + InpMtx_inputRealEntry(mtxA, row, col, + au[ipo]); + } + ipoint = ipoint + icol[row]; + } + } + else{ + for (row = 0; row < size; row++) { + InpMtx_inputRealEntry(mtxA, row, row, ad[row]-*sigma*adb[row]); + for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { + int col = irow[ipo] - 1; + InpMtx_inputRealEntry(mtxA, row, col, + au[ipo]-*sigma*aub[ipo]); + } + ipoint = ipoint + icol[row]; + } + } + }else if(*inputformat==1){ + ipoint = 0; + + if(*sigma==0.){ + for (row = 0; row < size; row++) { + InpMtx_inputRealEntry(mtxA, row, row, ad[row]); + for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { + int col = irow[ipo] - 1; + InpMtx_inputRealEntry(mtxA, row, col, + au[ipo]); + InpMtx_inputRealEntry(mtxA, col,row, + au[ipo+*nzs]); + } + ipoint = ipoint + icol[row]; + } + } + else{ + for (row = 0; row < size; row++) { + InpMtx_inputRealEntry(mtxA, row, row, ad[row]-*sigma*adb[row]); + for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { + int col = irow[ipo] - 1; + InpMtx_inputRealEntry(mtxA, row, col, + au[ipo]-*sigma*aub[ipo]); + InpMtx_inputRealEntry(mtxA, col, row, + au[ipo+*nzs]-*sigma*aub[ipo+*nzs]); + } + ipoint = ipoint + icol[row]; + } + } + }else if(*inputformat==2){ + for(i=0;i<*neq;i++){ + for(j=0;j<*neq;j++){ + if(fabs(ad[i**nzs+j])>1.e-20){ + InpMtx_inputRealEntry(mtxA,j,i, + ad[i**nzs+j]); + } + } + } + }else if(*inputformat==3){ + ipoint = 0; + + if(*sigma==0.){ + for (row = 0; row < size; row++) { + InpMtx_inputRealEntry(mtxA, row, row, ad[row]); + for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { + int col = irow[ipo] - 1; + InpMtx_inputRealEntry(mtxA, col, row, + au[ipo]); + } + ipoint = ipoint + icol[row]; + } + } + else{ + for (row = 0; row < size; row++) { + InpMtx_inputRealEntry(mtxA, row, row, ad[row]-*sigma*adb[row]); + for (ipo = ipoint; ipo < ipoint + icol[row]; ipo++) { + int col = irow[ipo] - 1; + InpMtx_inputRealEntry(mtxA, col, row, + au[ipo]-*sigma*aub[ipo]); + } + ipoint = ipoint + icol[row]; + } + } + } + + InpMtx_changeStorageMode(mtxA, INPMTX_BY_VECTORS); + + if (DEBUG_LVL > 1) { + fprintf(msgFile, "\n\n input matrix"); + InpMtx_writeForHumanEye(mtxA, msgFile); + fflush(msgFile); + } + } + + /* solve it! */ + + +#ifdef USE_MT + /* Rules for parallel solve: + * - if CCX_NPROC is positive, then use CCX_NPROC cpus, unless + * that exceeds the number of cpus in the system. + * - if CCX_NPROC is -1, then use the number of cpus in the system. + * - otherwise use 1 cpu (default). + */ + if (num_cpus < 0) { + int sys_cpus; + char *env; + + num_cpus = 0; +#ifdef _SC_NPROCESSORS_CONF + sys_cpus = sysconf(_SC_NPROCESSORS_CONF); + if (sys_cpus <= 0) + sys_cpus = 1; +#else + sys_cpus = 1; +#endif + env = getenv("CCX_NPROC"); + if (env) + num_cpus = atoi(env); + if (num_cpus > 0) { +// if (num_cpus > sys_cpus) +// num_cpus = sys_cpus; + } else if (num_cpus == -1) { + num_cpus = sys_cpus; + } else { + num_cpus = 1; + } + printf("Using up to %d cpu(s) for spooles.\n", num_cpus); + } + if (num_cpus > 1) { + /* do not use the multithreaded solver unless + * we have multiple threads - avoid the + * locking overhead + */ + factor_MT(&pfi, mtxA, size, msgFile,symmetryflag); + } else { + factor(&pfi, mtxA, size, msgFile,symmetryflag); + } +#else + factor(&pfi, mtxA, size, msgFile,symmetryflag); +#endif +} + +/** + * solve a system of equations with rhs b + * factorization must have been performed before + * using spooles_factor + * +*/ + +void spooles_solve(double *b, int *neq) +{ + /* rhs vector B + * Note that there is only one rhs vector, thus + * a bit simpler that the AllInOne example + */ + int size = *neq; + DenseMtx *mtxB,*mtxX; + + { + int i; + mtxB = DenseMtx_new(); + DenseMtx_init(mtxB, SPOOLES_REAL, 0, 0, size, 1, 1, size); + DenseMtx_zero(mtxB); + for (i = 0; i < size; i++) { + DenseMtx_setRealEntry(mtxB, i, 0, b[i]); + } + if (DEBUG_LVL > 1) { + fprintf(msgFile, "\n\n rhs matrix in original ordering"); + DenseMtx_writeForHumanEye(mtxB, msgFile); + fflush(msgFile); + } + } + +#ifdef USE_MT + if (num_cpus > 1) { + /* do not use the multithreaded solver unless + * we have multiple threads - avoid the + * locking overhead + */ + mtxX=fsolve_MT(&pfi, mtxB); + } else { + mtxX=fsolve(&pfi, mtxB); + } +#else + mtxX=fsolve(&pfi, mtxB); +#endif + + /* convert the result back to Calculix representation */ + { + int i; + for (i = 0; i < size; i++) { + b[i] = DenseMtx_entries(mtxX)[i]; + } + } + /* cleanup */ + DenseMtx_free(mtxX); +} + +void spooles_cleanup() +{ + + FrontMtx_free(pfi.frontmtx); + IV_free(pfi.newToOldIV); + IV_free(pfi.oldToNewIV); + SubMtxManager_free(pfi.mtxmanager); + if (pfi.solvemap) + SolveMap_free(pfi.solvemap); + ETree_free(pfi.frontETree); + fclose(msgFile); +} + + +/** + * spooles: Main interface between Calculix and spooles: + * + * Perform 3 operations: + * 1) factor + * 2) solve + * 3) cleanup + * + */ + +void spooles(double *ad, double *au, double *adb, double *aub, double *sigma, + double *b, int *icol, int *irow, + int *neq, int *nzs, int *symmetryflag, int *inputformat) +{ + + if(*neq==0) return; + + spooles_factor(ad,au,adb,aub,sigma,icol,irow,neq,nzs,symmetryflag, + inputformat); + + spooles_solve(b,neq); + + spooles_cleanup(); + +} + +#endif diff -Nru calculix-ccx-2.1/ccx_2.3/src/spooles.h calculix-ccx-2.3/ccx_2.3/src/spooles.h --- calculix-ccx-2.1/ccx_2.3/src/spooles.h 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/spooles.h 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,57 @@ +/* CALCULIX - A 3-dimensional finite element program */ +/* Copyright (C) 1998 Guido Dhondt */ +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation; either version 2 of */ +/* the License, or (at your option) any later version. */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifndef __CCX_SPOOLES_H +#define __CCX_SPOOLES_H + +/* + * seperated from CalculiX.h: otherwise everyone would have to include + * the spooles header files + */ +#include +#include +#include +#if USE_MT +#include +#endif + +/* increase this for debugging */ +#define DEBUG_LVL 0 + +struct factorinfo +{ + int size; + double cpus[11]; + IV *newToOldIV, *oldToNewIV; + SolveMap *solvemap; + FrontMtx *frontmtx; + SubMtxManager *mtxmanager; + ETree *frontETree; + int nthread; + FILE *msgFile; + +}; + +void spooles_factor(double *ad, double *au, double *adb, double *aub, + double *sigma, int *icol, int *irow, + int *neq, int *nzs, int *symmetryflag, + int *inputformat); + +void spooles_solve(double *b, int *neq); + +void spooles_cleanup(); + +#endif diff -Nru calculix-ccx-2.1/ccx_2.3/src/springforc.f calculix-ccx-2.3/ccx_2.3/src/springforc.f --- calculix-ccx-2.1/ccx_2.3/src/springforc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/springforc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,361 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine springforc(xl,konl,vl,imat,elcon,nelcon, + & elas,fnl,ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc, + & plicon,nplicon,npmat_,veoldl,senergy,iener,cstr,mi, + & springarea,nmethod,ne0,iperturb,nstate_,xstateini, + & xstate,reltime) +! +! calculates the force of the spring +! + implicit none +! + character*8 lakonl +! + integer konl(9),i,j,imat,ncmat_,ntmat_,nope,nterms,iflag,mi(2), + & kode,niso,id,nplicon(0:ntmat_,*),npmat_,nelcon(2,*),iener, + & nmethod,ne0,iperturb(2),nstate_ +! + real*8 xl(3,9),elas(21),ratio(9),t0l,t1l,al(3),vl(0:mi(2),9), + & pl(3,9),xn(3),dm,alpha,beta,fnl(3,9),tp(3),te(3),ftrial(3), + & veoldl(0:mi(2),9),dist,c2,c3,t(3),dt,dftrial,vertan(3), + & elcon(0:ncmat_,ntmat_,*),pproj(3),xsj2(3),xs2(3,7),val, + & shp2(7,8),xi,et,elconloc(21),plconloc(82),xk,fk,dd, + & xiso(20),yiso(20),dd0,plicon(0:2*npmat_,ntmat_,*), + & um,eps,pi,senergy,cstr(6),dvertan,dg,dfshear,dfnl, + & fricforc,springarea(2),ver(3),dvernor, + & xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*),t1(3),t2(3), + & dt1,dte,alnew(3),reltime +! + data iflag /2/ +! +! actual positions of the nodes belonging to the contact spring +! + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i)+vl(j,i) + enddo + enddo +! + if(lakonl(7:7).eq.'A') then + dd0=dsqrt((xl(1,2)-xl(1,1))**2 + & +(xl(2,2)-xl(2,1))**2 + & +(xl(3,2)-xl(3,1))**2) + dd=dsqrt((pl(1,2)-pl(1,1))**2 + & +(pl(2,2)-pl(2,1))**2 + & +(pl(3,2)-pl(3,1))**2) + do i=1,3 + xn(i)=(pl(i,2)-pl(i,1))/dd + enddo + val=dd-dd0 +! +! interpolating the material data +! + call materialdata_sp(elcon,nelcon,imat,ntmat_,i,t1l, + & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) +! +! calculating the spring force and the spring constant +! + if(kode.eq.2)then + xk=elconloc(1) + fk=xk*val + if(iener.eq.1) then + senergy=fk*val/2.d0 + endif + else + niso=int(plconloc(81)) + do i=1,niso + xiso(i)=plconloc(2*i-1) + yiso(i)=plconloc(2*i) + enddo + call ident(xiso,val,niso,id) + if(id.eq.0) then + xk=0.d0 + fk=yiso(1) + if(iener.eq.1) then + senergy=fk*val; + endif + elseif(id.eq.niso) then + xk=0.d0 + fk=yiso(niso) + if(iener.eq.1) then + senergy=yiso(1)*xiso(1) + do i=2,niso + senergy=senergy+(xiso(i)-xiso(i-1))*(yiso(i)+yiso( + & i-1))/2.d0 + enddo + senergy=senergy+(val-xiso(niso))*yiso(niso) + endif + else + xk=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) + fk=yiso(id)+xk*(val-xiso(id)) + if(iener.eq.1) then + senergy=yiso(1)*xiso(1) + do i=2, id + senergy=senergy+(xiso(i)-xiso(i-1))* + & (yiso(i)+yiso(i-1))/2.d0 + enddo + senergy=senergy+(val-xiso(id))*(fk+yiso(id))/2.d0 + endif + endif + endif +! + do i=1,3 + fnl(i,1)=-fk*xn(i) + fnl(i,2)=fk*xn(i) + enddo + return + endif +! + nterms=nope-1 +! +! vector vr connects the dependent node with its projection +! on the independent face +! + do i=1,3 + pproj(i)=pl(i,nope) + enddo +c write(*,*) 'springforc ',(pproj(i),i=1,3) + call attach(pl,pproj,nterms,ratio,dist,xi,et) + do i=1,3 + al(i)=pl(i,nope)-pproj(i) + enddo +! +! determining the jacobian vector on the surface +! + if(nterms.eq.8) then + call shape8q(xi,et,pl,xsj2,xs2,shp2,iflag) + elseif(nterms.eq.4) then + call shape4q(xi,et,pl,xsj2,xs2,shp2,iflag) + elseif(nterms.eq.6) then + call shape6tri(xi,et,pl,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,pl,xsj2,xs2,shp2,iflag) + endif +! +! normal on the surface +! + dm=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+xsj2(3)*xsj2(3)) + do i=1,3 + xn(i)=xsj2(i)/dm + enddo +! +! distance from surface along normal (= clearance) +! + val=al(1)*xn(1)+al(2)*xn(2)+al(3)*xn(3) +! +! check for a reduction of the initial penetration, if any +! + if(nmethod.eq.1) then + val=val-springarea(2)*(1.d0-reltime) + endif + if(val.le.0.d0) cstr(1)=val +! +! representative area: usually the slave surface stored in +! springarea; however, if no area was assigned because the +! node does not belong to any element, the master surface +! is used +! + if(springarea(1).le.0.d0) then + if(nterms.eq.3) then + springarea(1)=dm/2.d0 + else + springarea(1)=dm*4.d0 + endif + endif +! + if(elcon(1,1,imat).gt.0.d0) then +! +! exponential overclosure +! + if(dabs(elcon(2,1,imat)).lt.1.d-30) then + elas(1)=0.d0 + beta=1.d0 + else +! + alpha=elcon(2,1,imat)*springarea(1) + beta=elcon(1,1,imat) + if(-beta*val.gt.23.d0-dlog(alpha)) then + beta=(dlog(alpha)-23.d0)/val + endif + elas(1)=dexp(-beta*val+dlog(alpha)) + endif + else +! +! linear overclosure +! + pi=4.d0*datan(1.d0) + eps=-elcon(1,1,imat)*pi/elcon(2,1,imat) + elas(1)=(-springarea(1)*elcon(2,1,imat)*val* + & (0.5d0+datan(-val/eps)/pi)) +c & -elcon(1,1,imat)*springarea(1) + endif +! +! forces in the nodes of the contact element +! + do i=1,3 + fnl(i,nope)=-elas(1)*xn(i) + enddo + if(iener.eq.1) then + senergy=elas(1)/beta; + endif + cstr(4)=elas(1)/springarea(1) +! +! Coulomb friction for static calculations +! + if(ncmat_.ge.7) then + if(iperturb(1).gt.1) then + um=elcon(6,1,imat) + if(um.gt.0.d0) then + if(1.d0 - dabs(xn(1)).lt.1.5231d-6) then +! +! calculating the local directions on master surface +! + t1(1)=-xn(3)*xn(1) + t1(2)=-xn(3)*xn(2) + t1(3)=1.d0-xn(3)*xn(3) + else + t1(1)=1.d0-xn(1)*xn(1) + t1(2)=-xn(1)*xn(2) + t1(3)=-xn(1)*xn(3) + endif + dt1=dsqrt(t1(1)*t1(1)+t1(2)*t1(2)+t1(3)*t1(3)) + do i=1,3 + t1(i)=t1(i)/dt1 + enddo + t2(1)=xn(2)*t1(3)-xn(3)*t1(2) + t2(2)=xn(3)*t1(1)-xn(1)*t1(3) + t2(3)=xn(1)*t1(2)-xn(2)*t1(1) +! +! linear stiffness of the shear stress versus +! slip curve +! + xk=elcon(7,1,imat)*springarea(1) +! +! calculating the relative displacement between the slave node +! and its projection on the master surface +! + do i=1,3 + alnew(i)=vl(i,nope) + do j=1,nterms + alnew(i)=alnew(i)-ratio(j)*vl(i,j) + enddo + enddo +! +! calculating the difference in relative displacement since +! the start of the increment = lamda^* +! + do i=1,3 + al(i)=alnew(i)-xstateini(3+i,1,ne0+konl(nope+1)) + enddo +! +! ||lambda^*|| +! + val=al(1)*xn(1)+al(2)*xn(2)+al(3)*xn(3) +! +! update the relative tangential displacement +! + do i=1,3 + t(i)=xstateini(6+i,1,ne0+konl(nope+1))+al(i)-val*xn(i) + enddo +! +! store the actual relative displacement and +! the actual relative tangential displacement +! + do i=1,3 + xstate(3+i,1,ne0+konl(nope+1))=alnew(i) + xstate(6+i,1,ne0+konl(nope+1))=t(i) + enddo +! +! size of normal force +! + dfnl=dsqrt(fnl(1,nope)**2+fnl(2,nope)**2+fnl(3,nope)**2) +! +! maximum size of shear force +! + dfshear=um*dfnl +! +! plastic and elastic slip +! + do i=1,3 + tp(i)=xstateini(i,1,ne0+konl(nope+1)) + te(i)=t(i)-tp(i) + enddo + dte=dsqrt(te(1)*te(1)+te(2)*te(2)+te(3)*te(3)) +! +! trial force +! + do i=1,3 + ftrial(i)=xk*te(i) + enddo + dftrial=dsqrt(ftrial(1)**2+ftrial(2)**2+ftrial(3)**2) +! +! check whether stick or slip +! + if((dftrial.lt.dfshear) .or. (dftrial.le.0.d0)) then +! +! stick +! + write(*,*)'STICK' + do i=1,3 + fnl(i,nope)=fnl(i,nope)+ftrial(i) + enddo + cstr(5)=(ftrial(1)*t1(1)+ftrial(2)*t1(2)+ + & ftrial(3)*t1(3))/springarea(1) + cstr(6)=(ftrial(1)*t2(1)+ftrial(2)*t2(2)+ + & ftrial(3)*t2(3))/springarea(1) + else +! +! slip +! + write(*,*)'SLIP' + dg=(dftrial-dfshear)/xk + do i=1,3 + ftrial(i)=te(i)/dte + fnl(i,nope)=fnl(i,nope)+dfshear*ftrial(i) + xstate(i,1,ne0+konl(nope+1))=tp(i)+dg*ftrial(i) + enddo + cstr(5)=(dfshear*ftrial(1)*t1(1)+ + & dfshear*ftrial(2)*t1(2)+ + & dfshear*ftrial(3)*t1(3))/springarea(1) + cstr(6)=(dfshear*ftrial(1)*t2(1)+ + & dfshear*ftrial(2)*t2(2)+ + & dfshear*ftrial(3)*t2(3))/springarea(1) + + endif + endif +! +! storing the tangential displacements +! + cstr(2)=t(1)*t1(1)+t(2)*t1(2)+t(3)*t1(3) + cstr(3)=t(1)*t2(1)+t(2)*t2(2)+t(3)*t2(3) + endif + endif +! +! force in the master nodes +! + do i=1,3 + do j=1,nterms + fnl(i,j)=-ratio(j)*fnl(i,nope) + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/springforc_th.f calculix-ccx-2.3/ccx_2.3/src/springforc_th.f --- calculix-ccx-2.1/ccx_2.3/src/springforc_th.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/springforc_th.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,185 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine springforc_th(xl,vl,imat,elcon,nelcon, + & tnl,ncmat_,ntmat_,nope,kode,elconloc, + & plicon,nplicon,npmat_,mi,springarea,timeend,matname, + & node,noel,istep,iinc) +! +! calculates the heat flux across a contact area +! + implicit none +! + character*80 matname(*),slname,msname +! + integer i,j,imat,ncmat_,ntmat_,nope,nterms,iflag,mi(2), + & kode,niso,id,nplicon(0:ntmat_,*),npmat_,nelcon(2,*), + & node,noel,istep,iinc,npred +! + real*8 xl(3,9),ratio(9),t0l,t1l,al(3),vl(0:mi(2),9), + & pl(3,9),xn(3),dm,alpha,beta,tnl(9),pressure,dtemp, + & dist,conductance,eps,pi,springarea,timeend(2),ak(5), + & elcon(0:ncmat_,ntmat_,*),pproj(3),xsj2(3),xs2(3,7),val, + & shp2(7,8),xi,et,elconloc(21),plconloc(82),xk,d(2),flowm(2), + & xiso(20),yiso(20),plicon(0:2*npmat_,ntmat_,*),temp(2), + & predef(2),coords(3),tmean +! + data iflag /2/ +! +! actual positions of the nodes belonging to the contact spring +! + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i)+vl(j,i) + enddo + enddo +! + nterms=nope-1 +! +! vector vr connects the dependent node with its projection +! on the independent face +! + do i=1,3 + pproj(i)=pl(i,nope) + enddo + call attach(pl,pproj,nterms,ratio,dist,xi,et) + do i=1,3 + al(i)=pl(i,nope)-pproj(i) + enddo +! +! determining the jacobian vector on the surface +! + if(nterms.eq.8) then + call shape8q(xi,et,pl,xsj2,xs2,shp2,iflag) + elseif(nterms.eq.4) then + call shape4q(xi,et,pl,xsj2,xs2,shp2,iflag) + elseif(nterms.eq.6) then + call shape6tri(xi,et,pl,xsj2,xs2,shp2,iflag) + else + call shape3tri(xi,et,pl,xsj2,xs2,shp2,iflag) + endif +! +! normal on the surface +! + dm=dsqrt(xsj2(1)*xsj2(1)+xsj2(2)*xsj2(2)+xsj2(3)*xsj2(3)) + do i=1,3 + xn(i)=xsj2(i)/dm + enddo +! +! distance from surface along normal +! + val=al(1)*xn(1)+al(2)*xn(2)+al(3)*xn(3) +! +! representative area: usually the slave surface stored in +! springarea; however, if no area was assigned because the +! node does not belong to any element, the master surface +! is used +! + if(springarea.le.0.d0) then + if(nterms.eq.3) then + springarea=dm/2.d0 + else + springarea=dm*4.d0 + endif + endif +! + if(elcon(1,1,imat).gt.0.d0) then +! +! exponential overclosure +! + if(dabs(elcon(2,1,imat)).lt.1.d-30) then + pressure=0.d0 + beta=1.d0 + else +! + alpha=elcon(2,1,imat) + beta=elcon(1,1,imat) + if(-beta*val.gt.23.d0-dlog(alpha)) then + beta=(dlog(alpha)-23.d0)/val + endif + pressure=dexp(-beta*val+dlog(alpha)) + endif + else +! +! linear overclosure +! + pi=4.d0*datan(1.d0) + eps=-elcon(1,1,imat)*pi/elcon(2,1,imat) + pressure=-elcon(2,1,imat)*val* + & (0.5d0+datan(-val/eps)/pi) + endif +! +! calculating the temperature difference across the contact +! area and the mean temperature for the determination of the +! conductance +! + t1l=0.d0 + do j=1,nterms + t1l=t1l+ratio(j)*vl(0,j) + enddo + dtemp=t1l-vl(0,nope) + tmean=(vl(0,nope)+t1l)/2.d0 +! +! interpolating the material data according to temperature +! + call materialdata_sp(elcon,nelcon,imat,ntmat_,i,tmean, + & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) +! +! interpolating the material data according to pressure +! + niso=int(plconloc(81)) +! + if(niso.eq.0) then + d(1)=val + d(2)=pressure + temp(1)=vl(0,nope) + temp(2)=t1l + do j=1,3 + coords(j)=xl(j,nope) + enddo + call gapcon(ak,d,flowm,temp,predef,timeend,matname(imat), + & slname,msname,coords,noel,node,npred,istep,iinc) + conductance=ak(1) + else + do i=1,niso + xiso(i)=plconloc(2*i-1) + yiso(i)=plconloc(2*i) + enddo + call ident(xiso,pressure,niso,id) + if(id.eq.0) then + xk=0.d0 + conductance=yiso(1) + elseif(id.eq.niso) then + xk=0.d0 + conductance=yiso(niso) + else + xk=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) + conductance=yiso(id)+xk*(pressure-xiso(id)) + endif + endif +! +! calculating the concentrated heat flow +! + tnl(nope)=-springarea*conductance*dtemp + do j=1,nterms + tnl(j)=-ratio(j)*tnl(nope) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/springs.f calculix-ccx-2.3/ccx_2.3/src/springs.f --- calculix-ccx-2.1/ccx_2.3/src/springs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/springs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,194 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine springs(inpc,textpart,nelcon,nmat,ntmat_,npmat_, + & plicon,nplicon, + & ncmat_,elcon,matname,irstrt,istep,istat,n,iline,ipol, + & inl,ipoinp,inp,nmat_,set,istartset,iendset,ialset, + & nset,ielmat,ielorien,ipoinpc) +! +! reading the input deck: *SPRING +! + implicit none +! + logical linear +! + character*1 inpc(*) + character*80 matname(*) + character*81 set(*),elset + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat_,ntmat,npmat_,npmat,istep, + & n,key,i,nplicon(0:ntmat_,*),ncmat_,istat,istartset(*), + & iendset(*),irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),nmat_, + & ialset(*),ipos,nset,j,k,ielmat(*),ielorien(*),ipoinpc(0:*) +! + real*8 plicon(0:2*npmat_,ntmat_,*),temperature, + & elcon(0:ncmat_,ntmat_,*) +! + linear=.true. +! + ntmat=0 + npmat=0 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in springs: *SPRING should be placed' + write(*,*) ' before all step definitions' + stop + endif +! + nmat=nmat+1 + if(nmat.gt.nmat_) then + write(*,*) '*ERROR in materials: increase nmat_' + stop + endif + matname(nmat)(1:6)='SPRING' + do i=7,80 + matname(nmat)(i:i)=' ' + enddo +! + do i=2,n + if(textpart(i)(1:9).eq.'NONLINEAR') then + linear=.false. + elseif(textpart(i)(1:6).eq.'ELSET=') then + elset=textpart(i)(7:86) + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + else + write(*,*) + & '*WARNING in springs: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(linear) then + nelcon(1,nmat)=2 +! +! linear spring +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + ntmat=ntmat+1 + nelcon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in springs: increase ntmat_' + stop + endif + do i=1,2 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + if(textpart(3)(1:1).ne.' ') then + read(textpart(3)(1:20),'(f20.0)',iostat=istat) + & elcon(0,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + elcon(0,ntmat,nmat)=0.d0 + endif + enddo + else + nelcon(1,nmat)=-51 +! +! kinematic hardening coefficients +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + read(textpart(3)(1:20),'(f20.0)',iostat=istat) temperature + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! +! first temperature +! + if(ntmat.eq.0) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in springs: increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature +! +! new temperature +! + elseif(plicon(0,ntmat,nmat).ne.temperature) then + npmat=0 + ntmat=ntmat+1 + if(ntmat.gt.ntmat_) then + write(*,*) '*ERROR in springs: increase ntmat_' + stop + endif + nplicon(0,nmat)=ntmat + plicon(0,ntmat,nmat)=temperature + endif + do i=1,2 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & plicon(2*npmat+i,ntmat,nmat) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + npmat=npmat+1 + if(npmat.gt.npmat_) then + write(*,*) '*ERROR in springs: increase npmat_' + stop + endif + nplicon(ntmat,nmat)=npmat + enddo + endif +! + if(ntmat.eq.0) then + write(*,*) '*ERROR in springs: *SPRING card without data' + stop + endif + do i=1,nset + if(set(i).eq.elset) exit + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR in springs: element set ',elset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! +! assigning the elements of the set the appropriate material +! + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + ielmat(ialset(j))=nmat + ielorien(ialset(j))=0 + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + ielmat(k)=nmat + ielorien(k)=0 + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/springstiff.f calculix-ccx-2.3/ccx_2.3/src/springstiff.f --- calculix-ccx-2.1/ccx_2.3/src/springstiff.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/springstiff.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,575 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine springstiff(xl,elas,konl,voldl,s,imat,elcon,nelcon, + & ncmat_,ntmat_,nope,lakonl,t0l,t1l,kode,elconloc,plicon, + & nplicon,npmat_,iperturb,springarea,nmethod,mi,ne0, + & nstate_,xstateini,xstate,reltime) +! +! calculates the stiffness of a spring +! + implicit none +! + character*8 lakonl +! + integer konl(20),i,j,imat,ncmat_,ntmat_,k,l,nope,nterms,iflag, + & i1,kode,niso,id,nplicon(0:ntmat_,*),npmat_,nelcon(2,*), + & iperturb,nmethod,mi(2),ne0,nstate_ +! + real*8 xl(3,9),elas(21),ratio(9),q(3),val,shp2(7,9), + & al(3),s(60,60),voldl(0:mi(2),9),pl(3,9),xn(3),dm, + & c1,c2,c3,c4,alpha,beta,elcon(0:ncmat_,ntmat_,*),xm(3), + & xmu(3,3,9),dxmu(3,9),dval(3,9),fpu(3,3,9),xi,et, + & xs2(3,7),t0l,t1l,elconloc(21),plconloc(82),xk,fk, + & xiso(20),yiso(20),dd0,plicon(0:2*npmat_,ntmat_,*), + & a11,a12,a22,b1(3,9),b2(3,9),dal(3,3,9),qxxy(3),fnl(3), + & qxyy(3),dxi(3,9),det(3,9),determinant,c11,c12,c22, + & qxyx(3),qyxy(3),springarea(2),dd,dist,t(3),tu(3,3,9), + & xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*), + & dt,um,eps,pi,dftdt(3,3),tp(3),te(3),ftrial(3), + & dftrial,dfnl,dfshear,dg,dte,alnew(3),dfn(3,9),reltime +! + data iflag /4/ +! +! actual positions of the nodes belonging to the contact spring +! + if(iperturb.eq.0) then + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i) + enddo + enddo + else + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i)+voldl(j,i) + enddo + enddo + endif +! + if(lakonl(7:7).eq.'A') then + dd0=dsqrt((xl(1,2)-xl(1,1))**2 + & +(xl(2,2)-xl(2,1))**2 + & +(xl(3,2)-xl(3,1))**2) + dd=dsqrt((pl(1,2)-pl(1,1))**2 + & +(pl(2,2)-pl(2,1))**2 + & +(pl(3,2)-pl(3,1))**2) + do i=1,3 + xn(i)=(pl(i,2)-pl(i,1))/dd + enddo + val=dd-dd0 +! +! interpolating the material data +! + call materialdata_sp(elcon,nelcon,imat,ntmat_,i,t1l, + & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) +! +! calculating the spring force and the spring constant +! + if(kode.eq.2)then + xk=elconloc(1) + fk=xk*val + else + niso=int(plconloc(81)) + do i=1,niso + xiso(i)=plconloc(2*i-1) + yiso(i)=plconloc(2*i) + enddo + call ident(xiso,val,niso,id) + if(id.eq.0) then + xk=0.d0 + fk=yiso(1) + elseif(id.eq.niso) then + xk=0.d0 + fk=yiso(niso) + else + xk=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) + fk=yiso(id)+xk*(val-xiso(id)) + endif + endif +! + c1=fk/dd + c2=xk-c1 + do i=1,3 + do j=1,3 + s(i,j)=c2*xn(i)*xn(j) + enddo + s(i,i)=s(i,i)+c1 + enddo + do i=1,3 + do j=1,3 + s(i+3,j)=-s(i,j) + s(i,j+3)=-s(i,j) + s(i+3,j+3)=s(i,j) + enddo + enddo + return + endif +! +! contact springs +! + nterms=nope-1 +! +! vector al connects the actual position of the slave node +! with its projection on the master face +! + do i=1,3 + q(i)=pl(i,nope) + enddo + call attach(pl,q,nterms,ratio,dist,xi,et) + do i=1,3 + al(i)=pl(i,nope)-q(i) + enddo +! +! determining the jacobian vector on the surface +! + if(nterms.eq.8) then + call shape8q(xi,et,pl,xm,xs2,shp2,iflag) + elseif(nterms.eq.4) then + call shape4q(xi,et,pl,xm,xs2,shp2,iflag) + elseif(nterms.eq.6) then + call shape6tri(xi,et,pl,xm,xs2,shp2,iflag) + else + call shape3tri(xi,et,pl,xm,xs2,shp2,iflag) + endif +! +! dxi(i,j) is the derivative of xi w.r.t. pl(i,j), +! det(i,j) is the derivative of eta w.r.t. pl(i,j) +! +! dxi and det are determined from the orthogonality +! condition +! + a11=-(xs2(1,1)*xs2(1,1)+xs2(2,1)*xs2(2,1)+xs2(3,1)*xs2(3,1)) + & +al(1)*xs2(1,5)+al(2)*xs2(2,5)+al(3)*xs2(3,5) + a12=-(xs2(1,1)*xs2(1,2)+xs2(2,1)*xs2(2,2)+xs2(3,1)*xs2(3,2)) + & +al(1)*xs2(1,6)+al(2)*xs2(2,6)+al(3)*xs2(3,6) + a22=-(xs2(1,2)*xs2(1,2)+xs2(2,2)*xs2(2,2)+xs2(3,2)*xs2(3,2)) + & +al(1)*xs2(1,7)+al(2)*xs2(2,7)+al(3)*xs2(3,7) +! + do i=1,3 + do j=1,nterms + b1(i,j)=shp2(4,j)*xs2(i,1)-shp2(1,j)*al(i) + b2(i,j)=shp2(4,j)*xs2(i,2)-shp2(2,j)*al(i) + enddo + b1(i,nope)=-xs2(i,1) + b2(i,nope)=-xs2(i,2) + enddo +! + determinant=a11*a22-a12*a12 + c11=a22/determinant + c12=-a12/determinant + c22=a11/determinant +! + do i=1,3 + do j=1,nope + dxi(i,j)=c11*b1(i,j)+c12*b2(i,j) + det(i,j)=c12*b1(i,j)+c22*b2(i,j) + enddo + enddo +! +! dal(i,j,k) is the derivative of al(i) w.r.t pl(j,k) +! ( d al / d u_k) +! + do i=1,nope + do j=1,3 + do k=1,3 + dal(j,k,i)=-xs2(j,1)*dxi(k,i)-xs2(j,2)*det(k,i) + enddo + enddo + enddo + do i=1,nterms + do j=1,3 + dal(j,j,i)=dal(j,j,i)-shp2(4,i) + enddo + enddo + do j=1,3 + dal(j,j,nope)=dal(j,j,nope)+1.d0 + enddo +! +! d2q/dxx x dq/dy +! + qxxy(1)=xs2(2,5)*xs2(3,2)-xs2(3,5)*xs2(2,2) + qxxy(2)=xs2(3,5)*xs2(1,2)-xs2(1,5)*xs2(3,2) + qxxy(3)=xs2(1,5)*xs2(2,2)-xs2(2,5)*xs2(1,2) +! +! dq/dx x d2q/dyy +! + qxyy(1)=xs2(2,1)*xs2(3,7)-xs2(3,1)*xs2(2,7) + qxyy(2)=xs2(3,1)*xs2(1,7)-xs2(1,1)*xs2(3,7) + qxyy(3)=xs2(1,1)*xs2(2,7)-xs2(2,1)*xs2(1,7) +! +! Modified by Stefan Sicklinger +! +! dq/dx x d2q/dxy +! + qxyx(1)=xs2(2,1)*xs2(3,6)-xs2(3,1)*xs2(2,6) + qxyx(2)=xs2(3,1)*xs2(1,6)-xs2(1,1)*xs2(3,6) + qxyx(3)=xs2(1,1)*xs2(2,6)-xs2(2,1)*xs2(1,6) +! +! d2q/dxy x dq/dy +! + qyxy(1)=xs2(2,6)*xs2(3,2)-xs2(3,6)*xs2(2,2) + qyxy(2)=xs2(3,6)*xs2(1,2)-xs2(1,6)*xs2(3,2) + qyxy(3)=xs2(1,6)*xs2(2,2)-xs2(2,6)*xs2(1,2) +! +! +! End modifications +! +! normal on the surface +! + dm=dsqrt(xm(1)*xm(1)+xm(2)*xm(2)+xm(3)*xm(3)) + do i=1,3 + xn(i)=xm(i)/dm + enddo +! +! distance from surface along normal (= clearance) +! + val=al(1)*xn(1)+al(2)*xn(2)+al(3)*xn(3) + if(nmethod.eq.1) then + val=val-springarea(2)*(1.d0-reltime) + endif +! +! representative area: usually the slave surface stored in +! springarea; however, if no area was assigned because the +! node does not belong to any element, the master surface +! is used +! + if(springarea(1).le.0.d0) then + if(nterms.eq.3) then + springarea(1)=dm/2.d0 + else + springarea(1)=dm*4.d0 + endif + endif +! +! alpha and beta, taking the representative area into account +! (conversion of pressure into force) +! + if(elcon(1,1,imat).gt.0.d0) then +! +! exponential overclosure +! + if(dabs(elcon(2,1,imat)).lt.1.d-30) then + elas(1)=0.d0 + elas(2)=0.d0 + else + alpha=elcon(2,1,imat)*springarea(1) + beta=elcon(1,1,imat) + if(-beta*val.gt.23.d0-dlog(alpha)) then + beta=(dlog(alpha)-23.d0)/val + endif + elas(1)=dexp(-beta*val+dlog(alpha)) + elas(2)=-beta*elas(1) + endif + else +! +! linear overclosure +! + pi=4.d0*datan(1.d0) + eps=-elcon(1,1,imat)*pi/elcon(2,1,imat) + elas(1)=(-springarea(1)*elcon(2,1,imat)*val* + & (0.5d0+datan(-val/eps)/pi)) +c & -elcon(1,1,imat)*springarea(1) + elas(2)=-springarea(1)*elcon(2,1,imat)* + & ((0.5d0+datan(-val/eps)/pi)- + & val/(pi*eps*(1.d0+(val/eps)**2))) + endif +! +! contact force +! + do i=1,3 + fnl(i)=-elas(1)*xn(i) + enddo +! +! derivatives of the jacobian vector w.r.t. the displacement +! vectors (d m / d u_k) +! + do k=1,nterms + xmu(1,1,k)=0.d0 + xmu(2,2,k)=0.d0 + xmu(3,3,k)=0.d0 + xmu(1,2,k)=shp2(1,k)*xs2(3,2)-shp2(2,k)*xs2(3,1) + xmu(2,3,k)=shp2(1,k)*xs2(1,2)-shp2(2,k)*xs2(1,1) + xmu(3,1,k)=shp2(1,k)*xs2(2,2)-shp2(2,k)*xs2(2,1) + xmu(1,3,k)=-xmu(3,1,k) + xmu(2,1,k)=-xmu(1,2,k) + xmu(3,2,k)=-xmu(2,3,k) + enddo + do i=1,3 + do j=1,3 + xmu(i,j,nope)=0.d0 + enddo + enddo +! +! correction due to change of xi and eta +! + do k=1,nope + do j=1,3 + do i=1,3 +! +! modified by Stefan Sicklinger +! + xmu(i,j,k)=xmu(i,j,k)+(qxxy(i)+qxyx(i))*dxi(j,k) + & +(qxyy(i)+qyxy(i))*det(j,k) + enddo + enddo + enddo +! +! derivatives of the size of the jacobian vector w.r.t. the +! displacement vectors (d ||m||/d u_k) +! + do k=1,nope + do i=1,3 + dxmu(i,k)=xn(1)*xmu(1,i,k)+xn(2)*xmu(2,i,k)+ + & xn(3)*xmu(3,i,k) + enddo +! +! auxiliary variable: (d val d u_k)*||m|| +! + do i=1,3 + dval(i,k)=al(1)*xmu(1,i,k)+al(2)*xmu(2,i,k)+ + & al(3)*xmu(3,i,k)-val*dxmu(i,k)+ + & xm(1)*dal(1,i,k)+xm(2)*dal(2,i,k)+xm(3)*dal(3,i,k) + enddo +! + enddo +! + c1=1.d0/dm + c2=c1*c1 + c3=elas(2)*c2 + c4=elas(1)*c1 +! +! derivatives of the forces w.r.t. the displacement vectors +! + do k=1,nope + do j=1,3 + do i=1,3 + fpu(i,j,k)=-c3*xm(i)*dval(j,k) + & +c4*(xn(i)*dxmu(j,k)-xmu(i,j,k)) + enddo + enddo + enddo +! +! Coulomb friction for static calculations +! + if(ncmat_.ge.7) then + if(iperturb.gt.1) then + um=elcon(6,1,imat) + if(um.gt.0.d0) then +! +! stiffness of shear stress versus slip curve +! + xk=elcon(7,1,imat)*springarea(1) +! +! calculating the relative displacement between the slave node +! and its projection on the master surface +! + do i=1,3 + alnew(i)=voldl(i,nope) + do j=1,nterms + alnew(i)=alnew(i)-ratio(j)*voldl(i,j) + enddo + enddo +! +! calculating the difference in relative displacement since +! the start of the increment = lamda^* +! + do i=1,3 + al(i)=alnew(i)-xstateini(3+i,1,ne0+konl(nope+1)) + enddo +! +! ||lambda^*|| +! + val=al(1)*xn(1)+al(2)*xn(2)+al(3)*xn(3) +! +! update the relative tangential displacement +! + do i=1,3 + t(i)=xstateini(6+i,1,ne0+konl(nope+1))+al(i)-val*xn(i) + enddo +! +! store the actual relative displacement and +! the actual relative tangential displacement +! + do i=1,3 + xstate(3+i,1,ne0+konl(nope+1))=alnew(i) + xstate(6+i,1,ne0+konl(nope+1))=t(i) + enddo +! +! d al/d u_k -> d al^*/d u_k +! notice: xi & et are const. +! + do k=1,nope + do i=1,3 + do j=1,3 + dal(i,j,k)=0.d0 + enddo + enddo + enddo + + do i=1,nterms + do j=1,3 + dal(j,j,i)=-shp2(4,i) + enddo + enddo + + do j=1,3 + dal(j,j,nope)=1.d0 + enddo +! +! (d al/d u_k).||m|| -> (d al^*/d u_k).||m|| +! + do k=1,nope + do i=1,3 + dval(i,k)=al(1)*xmu(1,i,k)+al(2)*xmu(2,i,k) + & +al(3)*xmu(3,i,k)-val*dxmu(i,k) + & +xm(1)*dal(1,i,k)+xm(2)*dal(2,i,k) + & +xm(3)*dal(3,i,k) + enddo + enddo +! +! d t/d u_k +! + do k=1,nope + do j=1,3 + do i=1,3 + tu(i,j,k)=dal(i,j,k) + & -c1*(xn(i)*(dval(j,k)-val*dxmu(j,k)) + & +val*xmu(i,j,k)) + enddo + enddo + enddo +! +! size of normal force +! + dfnl=dsqrt(fnl(1)**2+fnl(2)**2+fnl(3)**2) +! +! maximum size of shear force +! + dfshear=um*dfnl +! +! plastic and elastic slip +! + do i=1,3 + tp(i)=xstateini(i,1,ne0+konl(nope+1)) + te(i)=t(i)-tp(i) + enddo +! +c do k=1,nope +c do i=1,3 +c dfn(i,k)=xn(1)*fpu(1,i,k)+xn(2)*fpu(2,i,k)+ +c & xn(3)*fpu(3,i,k) +c enddo +c enddo +! + dte=dsqrt(te(1)*te(1)+te(2)*te(2)+te(3)*te(3)) +! +! trial force +! + do i=1,3 + ftrial(i)=xk*te(i) + enddo + dftrial=dsqrt(ftrial(1)**2+ftrial(2)**2+ftrial(3)**2) +! +! check whether stick or slip +! + if((dftrial.lt.dfshear) .or. (dftrial.le.0.d0)) then +! +! stick force +! + do i=1,3 + fnl(i)=fnl(i)+ftrial(i) + enddo +! +! stick stiffness +! + do k=1,nope + do j=1,3 + do i=1,3 + fpu(i,j,k)=fpu(i,j,k)+xk*tu(i,j,k) + enddo + enddo + enddo + else +! +! slip force +! + dg=(dftrial-dfshear)/xk + do i=1,3 + ftrial(i)=te(i)/dte + fnl(i)=fnl(i)+dfshear*ftrial(i) + xstate(i,1,ne0+konl(nope+1))=tp(i)+dg*ftrial(i) + enddo +! +! slip stiffness +! + c1=xk*dfshear/dftrial + do i=1,3 + do j=1,3 + dftdt(i,j)=-c1*ftrial(i)*ftrial(j) + enddo + dftdt(i,i)=dftdt(i,i)+c1 + enddo +! + do k=1,nope + do j=1,3 + do i=1,3 + do l=1,3 + fpu(i,j,k)=fpu(i,j,k)+dftdt(i,l)*tu(l,j,k) +c & +um*ftrial(i)*dfn(j,k) + enddo + enddo + enddo + enddo + endif + endif + endif + endif +! +! determining the stiffness matrix contributions +! +! complete field shp2 +! + shp2(1,nope)=0.d0 + shp2(2,nope)=0.d0 + shp2(4,nope)=-1.d0 +! + do k=1,nope + do l=1,nope + do i=1,3 + i1=i+(k-1)*3 + do j=1,3 + s(i1,j+(l-1)*3)=-shp2(4,k)*fpu(i,j,l) + & -shp2(1,k)*fnl(i)*dxi(j,l) + & -shp2(2,k)*fnl(i)*det(j,l) + enddo + enddo + enddo + enddo +! +! symmetrizing the matrix +! + do j=1,3*nope + do i=1,j-1 + s(i,j)=(s(i,j)+s(j,i))/2.d0 + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/springstiff_th.f calculix-ccx-2.3/ccx_2.3/src/springstiff_th.f --- calculix-ccx-2.1/ccx_2.3/src/springstiff_th.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/springstiff_th.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,206 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine springstiff_th(xl,voldl,s,imat,elcon,nelcon, + & ncmat_,ntmat_,nope,kode,plicon, + & nplicon,npmat_,iperturb,springarea,mi,timeend,matname, + & node,noel,istep,iinc) +! +! calculates the stiffness of a spring +! + implicit none +! + character*80 matname(*),slname,msname +! + integer i,j,imat,ncmat_,ntmat_,k,nope,nterms,iflag, + & kode,niso,id,nplicon(0:ntmat_,*),npmat_,nelcon(2,*), + & iperturb,mi(2),node,noel,istep,iinc,npred +! + real*8 xl(3,9),ratio(9),q(3),val,shp2(7,9),ak(5), + & al(3),s(60,60),voldl(0:mi(2),9),pl(3,9),xn(3),dm, + & alpha,beta,elcon(0:ncmat_,ntmat_,*),xm(3),pressure, + & xi,et,xs2(3,7),t1l,elconloc(21),plconloc(82),xk, + & xiso(20),yiso(20),plicon(0:2*npmat_,ntmat_,*), + & springarea,dist,eps,pi,constant,conductance,dtemp,temp(2), + & predef(2),coords(3),tmean,d(2),timeend(2),flowm(2) +! + data iflag /4/ +! +! actual positions of the nodes belonging to the contact spring +! + if(iperturb.eq.0) then + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i) + enddo + enddo + else + do i=1,nope + do j=1,3 + pl(j,i)=xl(j,i)+voldl(j,i) + enddo + enddo + endif +! +! contact springs +! + nterms=nope-1 +! +! vector al connects the actual position of the slave node +! with its projection on the master face +! + do i=1,3 + q(i)=pl(i,nope) + enddo + call attach(pl,q,nterms,ratio,dist,xi,et) + do i=1,3 + al(i)=pl(i,nope)-q(i) + enddo +! +! determining the jacobian vector on the surface +! + if(nterms.eq.8) then + call shape8q(xi,et,pl,xm,xs2,shp2,iflag) + elseif(nterms.eq.4) then + call shape4q(xi,et,pl,xm,xs2,shp2,iflag) + elseif(nterms.eq.6) then + call shape6tri(xi,et,pl,xm,xs2,shp2,iflag) + else + call shape3tri(xi,et,pl,xm,xs2,shp2,iflag) + endif +! +! +! normal on the surface +! + dm=dsqrt(xm(1)*xm(1)+xm(2)*xm(2)+xm(3)*xm(3)) + do i=1,3 + xn(i)=xm(i)/dm + enddo +! +! distance from surface along normal +! + val=al(1)*xn(1)+al(2)*xn(2)+al(3)*xn(3) +! +! representative area: usually the slave surface stored in +! springarea; however, if no area was assigned because the +! node does not belong to any element, the master surface +! is used +! + if(springarea.le.0.d0) then + if(nterms.eq.3) then + springarea=dm/2.d0 + else + springarea=dm*4.d0 + endif + endif +! +! alpha and beta, taking the representative area into account +! (conversion of pressure into force) +! + if(elcon(1,1,imat).gt.0.d0) then +! +! exponential overclosure +! + if(dabs(elcon(2,1,imat)).lt.1.d-30) then + pressure=0.d0 + else + alpha=elcon(2,1,imat) + beta=elcon(1,1,imat) + if(-beta*val.gt.23.d0-dlog(alpha)) then + beta=(dlog(alpha)-23.d0)/val + endif + pressure=dexp(-beta*val+dlog(alpha)) + endif + else +! +! linear overclosure +! + pi=4.d0*datan(1.d0) + eps=-elcon(1,1,imat)*pi/elcon(2,1,imat) + pressure=-elcon(2,1,imat)*val* + & (0.5d0+datan(-val/eps)/pi) + endif +! +! calculating the temperature difference across the contact +! area and the mean temperature for the determination of the +! conductance +! + t1l=0.d0 + do j=1,nterms + t1l=t1l+ratio(j)*voldl(0,j) + enddo + dtemp=t1l-voldl(0,nope) + tmean=(voldl(0,nope)+t1l)/2.d0 +! +! interpolating the material data according to temperature +! + call materialdata_sp(elcon,nelcon,imat,ntmat_,i,tmean, + & elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_) +! +! interpolating the material data according to pressure +! + niso=int(plconloc(81)) +! + if(niso.eq.0) then +! +! user subroutine for the conductance +! + d(1)=val + d(2)=pressure + temp(1)=voldl(0,nope) + temp(2)=t1l + do j=1,3 + coords(j)=xl(j,nope) + enddo + call gapcon(ak,d,flowm,temp,predef,timeend,matname(imat), + & slname,msname,coords,noel,node,npred,istep,iinc) + conductance=ak(1) + else + do i=1,niso + xiso(i)=plconloc(2*i-1) + yiso(i)=plconloc(2*i) + enddo + call ident(xiso,pressure,niso,id) + if(id.eq.0) then + xk=0.d0 + conductance=yiso(1) + elseif(id.eq.niso) then + xk=0.d0 + conductance=yiso(niso) + else + xk=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id)) + conductance=yiso(id)+xk*(pressure-xiso(id)) + endif + endif +! +! assembling the upper triangle of the element matrix +! + constant=conductance*springarea + s(nope,nope)=constant + do k=1,nterms + s(k,nope)=-shp2(4,k)*constant + enddo + do i=1,nterms + do j=i,nterms + s(i,j)=shp2(4,i)*shp2(4,j)*constant + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/statics.f calculix-ccx-2.3/ccx_2.3/src/statics.f --- calculix-ccx-2.1/ccx_2.3/src/statics.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/statics.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,222 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine statics(inpc,textpart,nmethod,iperturb,isolver,istep, + & istat,n,tinc,tper,tmin,tmax,idrct,iline,ipol,inl,ipoinp,inp, + & ithermal,cs,ics,tieset,istartset, + & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc, + & ilmpc,mpcfree,mcs,set,nset,labmpc,ipoinpc,iexpl,cfd,ttime, + & iaxial) +! +! reading the input deck: *STATIC +! +! isolver=0: SPOOLES +! 2: iterative solver with diagonal scaling +! 3: iterative solver with Cholesky preconditioning +! 4: sgi solver +! 5: TAUCS +! 7: pardiso +! +! iexpl==0: structure:implicit, fluid:semi-implicit +! iexpl==1: structure:implicit, fluid:explicit +! + implicit none +! + logical timereset +! + character*1 inpc(*) + character*20 labmpc(*),solver + character*81 set(*),tieset(3,*) + character*132 textpart(16) +! + integer nmethod,iperturb,isolver,istep,istat,n,key,i,idrct, + & iline,ipol,inl,ipoinp(2,*),inp(3,*),ithermal,ics(*),iexpl, + & istartset(*),iendset(*),ialset(*),ipompc(*),nodempc(3,*), + & nmpc,nmpc_,ikmpc(*),ilmpc(*),mpcfree,nset,mcs,ipoinpc(0:*), + & cfd,iaxial +! + real*8 tinc,tper,tmin,tmax,cs(17,*),coefmpc(*),ttime +! + idrct=0 + tmin=0.d0 + tmax=0.d0 + timereset=.false. +! + if((iperturb.eq.1).and.(istep.ge.1)) then + write(*,*) '*ERROR in statics: perturbation analysis is' + write(*,*) ' not provided in a *STATIC step. Perform' + write(*,*) ' a genuine nonlinear geometric calculation' + write(*,*) ' instead (parameter NLGEOM)' + stop + endif +! + if(istep.lt.1) then + write(*,*) '*ERROR in statics: *STATIC can only be used' + write(*,*) ' within a STEP' + stop + endif +! +! no heat transfer analysis +! + if(ithermal.gt.1) then + ithermal=1 + endif +! +! default solver +! + solver=' ' + if(isolver.eq.0) then + solver(1:7)='SPOOLES' + elseif(isolver.eq.2) then + solver(1:16)='ITERATIVESCALING' + elseif(isolver.eq.3) then + solver(1:17)='ITERATIVECHOLESKY' + elseif(isolver.eq.4) then + solver(1:3)='SGI' + elseif(isolver.eq.5) then + solver(1:5)='TAUCS' + elseif(isolver.eq.7) then + solver(1:7)='PARDISO' + endif +! + do i=2,n + if(textpart(i)(1:7).eq.'SOLVER=') then + read(textpart(i)(8:27),'(a20)') solver + elseif(textpart(i)(1:8).eq.'EXPLICIT') then + iexpl=1 + elseif((textpart(i)(1:6).eq.'DIRECT').and. + & (textpart(i)(1:9).ne.'DIRECT=NO')) then + idrct=1 + elseif(textpart(i)(1:9).eq.'TIMERESET') then + timereset=.true. + else + write(*,*) + & '*WARNING in statics: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(solver(1:7).eq.'SPOOLES') then + isolver=0 + elseif(solver(1:16).eq.'ITERATIVESCALING') then + isolver=2 + elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then + isolver=3 + elseif(solver(1:3).eq.'SGI') then + isolver=4 + elseif(solver(1:5).eq.'TAUCS') then + isolver=5 + elseif(solver(1:7).eq.'PARDISO') then + isolver=7 + else + write(*,*) '*WARNING in statics: unknown solver;' + write(*,*) ' the default solver is used' + endif +! + nmethod=1 +! +! check for nodes on a cyclic symmetry axis +! + if((mcs.eq.0).or.(iaxial.ne.0)) then + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + else + n=3 + textpart(2)='NMIN=0 + & + & ' + textpart(3)='NMAX=0 + & + & ' + nmethod=2 + call selcycsymmods(inpc,textpart,cs,ics,tieset,istartset, + & iendset,ialset,ipompc,nodempc,coefmpc,nmpc,nmpc_,ikmpc, + & ilmpc,mpcfree,mcs,set,nset,labmpc,istep,istat,n,iline, + & ipol,inl,ipoinp,inp,nmethod,key,ipoinpc) + nmethod=1 + do i=1,mcs + cs(2,i)=-0.5 + cs(3,i)=-0.5 + enddo + endif +! + if((istat.lt.0).or.(key.eq.1)) then + if((iperturb.ge.2).or.(cfd.eq.1)) then + write(*,*) '*WARNING in statics: a nonlinear geometric analy + &sis is requested' + write(*,*) ' but no time increment nor step is speci + &fied' + write(*,*) ' the defaults (1,1) are used' + tinc=1.d0 + tper=1.d0 + tmin=1.d-5 + tmax=1.d+30 + else + tper=1.d0 + endif + if(timereset)ttime=ttime-tper + return + endif +! + read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) tmin + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(4)(1:20),'(f20.0)',iostat=istat) tmax + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! + if(tper.lt.0.d0) then + write(*,*) '*ERROR in statics: step size is negative' + stop + elseif(tper.le.0.d0) then + tper=1.d0 + endif + if(tinc.lt.0.d0) then + write(*,*) '*ERROR in statics: initial increment size is negati + &ve' + stop + elseif(tinc.le.0.d0) then + tinc=tper + endif + if(tinc.gt.tper) then + write(*,*) '*ERROR in statics: initial increment size exceeds s + &tep size' + stop + endif +! + if(idrct.ne.1) then + if(dabs(tmin).lt.1.d-10) then + tmin=min(tinc,1.d-5*tper) + endif + if(dabs(tmax).lt.1.d-10) then + tmax=1.d+30 + endif + endif +! + if(timereset)ttime=ttime-tper +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/steadystate.c calculix-ccx-2.3/ccx_2.3/src/steadystate.c --- calculix-ccx-2.1/ccx_2.3/src/steadystate.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/steadystate.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,2513 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif +#ifdef PARDISO + #include "pardiso.h" +#endif + +void steadystate(double **cop, int *nk, int **konp, int **ipkonp, char **lakonp, int *ne, + int **nodebounp, int **ndirbounp, double **xbounp, int *nboun, + int **ipompcp, int **nodempcp, double **coefmpcp, char **labmpcp, + int *nmpc, int *nodeforc,int *ndirforc,double *xforc, + int *nforc,int *nelemload, char *sideload,double *xload, + int *nload, + int **nactdofp,int *neq, int *nzl,int *icol, int *irow, + int *nmethod, int **ikmpcp, int **ilmpcp, int **ikbounp, + int **ilbounp,double *elcon, int *nelcon, double *rhcon, + int *nrhcon,double *cocon, int *ncocon, + double *alcon, int *nalcon, double *alzero, + int **ielmatp,int **ielorienp, int *norien, double *orab, + int *ntmat_,double **t0p, + double **t1p,int *ithermal,double *prestr, int *iprestr, + double **voldp,int *iperturb, double *sti, int *nzs, + double *tinc, double *tper, double *xmodal, + double *veold, char *amname, double *amta, + int *namta, int *nam, int *iamforc, int *iamload, + int **iamt1p,int *jout, + int *kode, char *filab,double **emep, double *xforcold, + double *xloadold, + double **t1oldp, int **iambounp, double **xbounoldp, int *iexpl, + double *plicon, int *nplicon, double *plkcon,int *nplkcon, + double *xstate, int *npmat_, char *matname, int *mi, + int *ncmat_, int *nstate_, double **enerp, char *jobnamec, + double *ttime, char *set, int *nset, int *istartset, + int *iendset, int *ialset, int *nprint, char *prlab, + char *prset, int *nener, double *trab, + int **inotrp, int *ntrans, double **fmpcp, char *cbody, int *ibody, + double *xbody, int *nbody, double *xbodyold, int *istep, + int *isolver, int *jq, char *output, int *mcs,int *nkon, + int *ics, double *cs, int *mpcend, int **nnnp,double *ctrl){ + + char fneig[132]="",description[13]=" ",*lakon=NULL,*labmpc=NULL, + *labmpcold=NULL,cflag[1]=" "; + + int nev,i,j,k, *inum=NULL,*ipobody=NULL,inewton=0,nsectors,im, + iinc=0,l,iout,ielas,icmd,iprescribedboundary,ndata,nmd,nevd, + ndatatot,*iphaseforc=NULL,*iphaseload=NULL,*iphaseboun=NULL, + *isave=NULL,nfour,ii,ir,ic,mode,noddiam=-1,*nm=NULL, + *kon=NULL,*ipkon=NULL,*ielmat=NULL,*ielorien=NULL,*inotr=NULL, + *nodeboun=NULL,*ndirboun=NULL,*iamboun=NULL,*ikboun=NULL,jj, + *ilboun=NULL,*nactdof=NULL,*ipompc=NULL,*nodempc=NULL,*ikmpc=NULL, + *ilmpc=NULL,*ipompcold=NULL,*nodempcold=NULL,*ikmpcold=NULL, + *ilmpcold=NULL,nmpcold,mpcendold,kflag=2,*iamt1=NULL,ifreebody, + *itg=NULL,ntg=0,symmetryflag=0,inputformat=0,dashpot,nrhs=1, + *ipiv=NULL,info,nev2,ngraph=1,nkg,neg,iflag=1,idummy=1,imax, + nzse[3],*nnn=*nnnp,mt=mi[1]+1,*ikactmech=NULL,nactmech,i2,id, + *imddof=NULL,nmddof,*imdnode=NULL,nmdnode,*imdboun=NULL,nmdboun, + *imdmpc=NULL,nmdmpc,*izdof=NULL,nzdof,nrset,cyclicsymmetry, + *ikactmechr=NULL,*ikactmechi=NULL,nactmechr,nactmechi,intpointvar, + iforc,iload; + + double *d=NULL, *z=NULL,*stiini=NULL,*vini=NULL,*freqnh=NULL, + *xforcact=NULL, *xloadact=NULL,y,*fr=NULL,*fi=NULL,*cc=NULL, + *t1act=NULL, *ampli=NULL, *aa=NULL, *bb=NULL, *vr=NULL,*vi=NULL, + *stn=NULL, *stx=NULL, *een=NULL, *adb=NULL,*xstiff=NULL, + *aub=NULL, *aux=NULL, *bjr=NULL, *bji=NULL,*xbodyr=NULL, + *f=NULL, *fn=NULL, *xbounact=NULL,*epn=NULL,*xstateini=NULL, + *enern=NULL,*xstaten=NULL,*eei=NULL,*enerini=NULL,*qfn=NULL, + *qfx=NULL, *xbodyact=NULL, *cgr=NULL, *au=NULL,*xbodyi=NULL, + time,dtime,reltime,*co=NULL,*xboun=NULL,*xbounold=NULL, + physcon[1],qa[3],cam[5],accold[1],bet,gam,*ad=NULL,sigma=0.,alpham,betam, + fmin,fmax,bias,*freq=NULL,*xforcr=NULL,dd,pi,vreal,constant, + *xforci=NULL,*xloadr=NULL,*xloadi=NULL,*xbounr=NULL,*xbouni=NULL, + *br=NULL,*bi=NULL,*ubr=NULL,*ubi=NULL,*mubr=NULL,*mubi=NULL, + *wsave=NULL,*r=NULL,*xbounacttime=NULL,*btot=NULL,breal,tmin,tmax, + *vold=NULL,*eme=NULL,*ener=NULL,*coefmpc=NULL,*fmpc=NULL, + *coefmpcold=NULL,*t0=NULL,*t1=NULL,*t1old=NULL,*adc=NULL,*auc=NULL, + *am=NULL,*bm=NULL,*zc=NULL,*e=NULL,*stnr=NULL,*stni=NULL, + *vmax=NULL,*stnmax=NULL,*va=NULL,*vp=NULL,*fric=NULL,*springarea=NULL, + *stna=NULL,*stnp=NULL,*bp=NULL,*eenmax=NULL; + + /* dummy arguments for the call of expand*/ + + char* tieset=NULL; + int *jqe=NULL,*icole=NULL,*irowe=NULL,ntie=0; + double *adbe=NULL,*aube=NULL; + + FILE *f1; + + int *ipneigh=NULL,*neigh=NULL; + +#ifdef SGI + int token; +#endif + + co=*cop;kon=*konp;ipkon=*ipkonp;lakon=*lakonp;ielmat=*ielmatp; + ielorien=*ielorienp;inotr=*inotrp;nodeboun=*nodebounp; + ndirboun=*ndirbounp;iamboun=*iambounp;xboun=*xbounp; + xbounold=*xbounoldp;ikboun=*ikbounp;ilboun=*ilbounp;nactdof=*nactdofp; + vold=*voldp;eme=*emep;ener=*enerp;ipompc=*ipompcp;nodempc=*nodempcp; + coefmpc=*coefmpcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; + fmpc=*fmpcp;iamt1=*iamt1p;t0=*t0p;t1=*t1p;t1old=*t1oldp; + + xstiff=NNEW(double,27*mi[0]**ne); + + pi=4.*atan(1.); + iout=2; + + alpham=xmodal[0]; + betam=xmodal[1]; + + nrset=(int)xmodal[9]; + + fmin=2.*pi*xmodal[2]; + fmax=2.*pi*xmodal[3]; + ndata=floor(xmodal[4]); + bias=xmodal[5]; + nfour=floor(xmodal[6]); + if(nfour>0){ + tmin=xmodal[7]; + tmax=xmodal[8]; + } + + /* determining nzl */ + + *nzl=0; + for(i=neq[1];i>0;i--){ + if(icol[i-1]>0){ + *nzl=i; + break; + } + } + + /* check for cyclic symmetry */ + + if((*mcs==0)||(cs[1]<0)){cyclicsymmetry=0;}else{cyclicsymmetry=1;} + + /* creating imddof containing the degrees of freedom + retained by the user and imdnode containing the nodes */ + + nmddof=0;nmdnode=0;nmdboun=0;nmdmpc=0; + if(nrset!=0){ + imddof=NNEW(int,*nk*3); + imdnode=NNEW(int,*nk); + imdboun=NNEW(int,*nboun); + imdmpc=NNEW(int,*nmpc); + FORTRAN(createmddof,(imddof,&nmddof,&nrset,istartset,iendset, + ialset,nactdof,ithermal,mi,imdnode,&nmdnode, + ikmpc,ilmpc,ipompc,nodempc,nmpc, + imdmpc,&nmdmpc,imdboun,&nmdboun,ikboun, + nboun,nset,&ntie,tieset,set,lakon,kon,ipkon,labmpc, + ilboun)); + + /* checking for user-defined loads: all relevant nodes belonging to + elements subject to user-defined loads are stored in imdnode + as well (vold and veold are made available in the user subroutines */ + + if(!cyclicsymmetry){ + for(i=0;i<*nload;i++){ + iload=i+1; + FORTRAN(addimdnodedload,(nelemload,sideload,ipkon,kon,lakon, + &iload,imdnode,&nmdnode,ikmpc,ilmpc,ipompc,nodempc,nmpc, + imddof,&nmddof,nactdof,mi,imdmpc,&nmdmpc,imdboun,&nmdboun, + ikboun,nboun,ilboun,ithermal)); + } + + for(i=0;i<*nforc;i++){ + iforc=i+1; + FORTRAN(addimdnodecload,(nodeforc,&iforc,imdnode,&nmdnode,xforc, + ikmpc,ilmpc,ipompc,nodempc,nmpc,imddof,&nmddof, + nactdof,mi,imdmpc,&nmdmpc,imdboun,&nmdboun, + ikboun,nboun,ilboun,ithermal)); + } + } + + RENEW(imddof,int,nmddof); + RENEW(imdnode,int,nmdnode); + RENEW(imdboun,int,nmdboun); + RENEW(imdmpc,int,nmdmpc); + } + + /* reading the eigenvalue and eigenmode information */ + + strcpy(fneig,jobnamec); + strcat(fneig,".eig"); + + if((f1=fopen(fneig,"rb"))==NULL){ + printf("*ERROR: cannot open eigenvalue file for reading..."); + exit(0); + } + + nsectors=1; + + if(!cyclicsymmetry){ + + nkg=*nk; + neg=*ne; + + if(fread(&nev,sizeof(int),1,f1)!=1){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + d=NNEW(double,nev); + + if(fread(d,sizeof(double),nev,f1)!=nev){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + ad=NNEW(double,neq[1]); + adb=NNEW(double,neq[1]); + au=NNEW(double,nzs[2]); + aub=NNEW(double,nzs[1]); + + if(fread(ad,sizeof(double),neq[1],f1)!=neq[1]){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + if(fread(au,sizeof(double),nzs[2],f1)!=nzs[2]){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + if(fread(adb,sizeof(double),neq[1],f1)!=neq[1]){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + if(fread(aub,sizeof(double),nzs[1],f1)!=nzs[1]){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + + z=NNEW(double,neq[1]*nev); + + if(fread(z,sizeof(double),neq[1]*nev,f1)!=neq[1]*nev){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + } + else{ + nev=0; + do{ + if(fread(&nmd,sizeof(int),1,f1)!=1){ + break; + } + if(fread(&nevd,sizeof(int),1,f1)!=1){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + if(nev==0){ + d=NNEW(double,nevd); + nm=NNEW(int,nevd); + }else{ + RENEW(d,double,nev+nevd); + RENEW(nm,int,nev+nevd); + } + + if(fread(&d[nev],sizeof(double),nevd,f1)!=nevd){ + printf("*ERROR reading the eigenvalue file..."); + exit(0); + } + for(i=nev;insectors) nsectors=(int)(cs[17*i]+0.5); + } + + /* determining the maximum number of sectors to be plotted */ + + for(j=0;j<*mcs;j++){ + if(cs[17*j+4]>ngraph) ngraph=(int)cs[17*j+4]; + } + nkg=*nk*ngraph; + neg=*ne*ngraph; + + /* allocating field for the expanded structure */ + + RENEW(co,double,3**nk*nsectors); + + /* next line is necessary for multiple cyclic symmetry + conditions */ + + for(i=3**nk;i<3**nk*nsectors;i++){co[i]=0.;} + if(*ithermal!=0){ + RENEW(t0,double,*nk*nsectors); + RENEW(t1old,double,*nk*nsectors); + RENEW(t1,double,*nk*nsectors); + if(*nam>0) RENEW(iamt1,int,*nk*nsectors); + } + RENEW(nactdof,int,mt**nk*nsectors); + if(*ntrans>0) RENEW(inotr,int,2**nk*nsectors); + RENEW(kon,int,*nkon*nsectors); + RENEW(ipkon,int,*ne*nsectors); + for(i=*ne;i<*ne*nsectors;i++){ipkon[i]=-1;} + RENEW(lakon,char,8**ne*nsectors); + RENEW(ielmat,int,*ne*nsectors); + if(*norien>0) RENEW(ielorien,int,*ne*nsectors); +// RENEW(z,double,(long long)neq[1]*nev*nsectors/2); + + RENEW(nodeboun,int,*nboun*nsectors); + RENEW(ndirboun,int,*nboun*nsectors); + if(*nam>0) RENEW(iamboun,int,*nboun*nsectors); + RENEW(xboun,double,*nboun*nsectors); + RENEW(xbounold,double,*nboun*nsectors); + RENEW(ikboun,int,*nboun*nsectors); + RENEW(ilboun,int,*nboun*nsectors); + + ipompcold=NNEW(int,*nmpc); + nodempcold=NNEW(int,3**mpcend); + coefmpcold=NNEW(double,*mpcend); + labmpcold=NNEW(char,20**nmpc); + ikmpcold=NNEW(int,*nmpc); + ilmpcold=NNEW(int,*nmpc); + + for(i=0;i<*nmpc;i++){ipompcold[i]=ipompc[i];} + for(i=0;i<3**mpcend;i++){nodempcold[i]=nodempc[i];} + for(i=0;i<*mpcend;i++){coefmpcold[i]=coefmpc[i];} + for(i=0;i<20**nmpc;i++){labmpcold[i]=labmpc[i];} + for(i=0;i<*nmpc;i++){ikmpcold[i]=ikmpc[i];} + for(i=0;i<*nmpc;i++){ilmpcold[i]=ilmpc[i];} + nmpcold=*nmpc; + mpcendold=*mpcend; + + RENEW(ipompc,int,*nmpc*nsectors); + RENEW(nodempc,int,3**mpcend*nsectors); + RENEW(coefmpc,double,*mpcend*nsectors); + RENEW(labmpc,char,20**nmpc*nsectors+1); + RENEW(ikmpc,int,*nmpc*nsectors); + RENEW(ilmpc,int,*nmpc*nsectors); + RENEW(fmpc,double,*nmpc*nsectors); + + /* reallocating the fields for the nodes in which the + solution has to be calculated */ + + RENEW(imddof,int,neq[1]/2*nsectors); + RENEW(imdnode,int,*nk*nsectors); + RENEW(imdboun,int,*nboun*nsectors); + RENEW(imdmpc,int,*nmpc*nsectors); + + izdof=NNEW(int,1); + + expand(co,nk,kon,ipkon,lakon,ne,nodeboun,ndirboun,xboun,nboun, + ipompc,nodempc,coefmpc,labmpc,nmpc,nodeforc,ndirforc,xforc, + nforc,nelemload,sideload,xload,nload,nactdof,neq, + nmethod,ikmpc,ilmpc,ikboun,ilboun,elcon,nelcon,rhcon,nrhcon, + alcon,nalcon,alzero,ielmat,ielorien,norien,orab,ntmat_, + t0,ithermal,prestr,iprestr,vold,iperturb,sti,nzs, + adb,aub,filab,eme,plicon,nplicon,plkcon,nplkcon, + xstate,npmat_,matname,mi,ics,cs,mpcend,ncmat_, + nstate_,mcs,nkon,ener,jobnamec,output,set,nset,istartset, + iendset,ialset,nprint,prlab,prset,nener,trab, + inotr,ntrans,ttime,fmpc,&nev,&z,iamboun,xbounold, + &nsectors,nm,icol,irow,nzl,nam,ipompcold,nodempcold,coefmpcold, + labmpcold,&nmpcold,xloadold,iamload,t1old,t1,iamt1,xstiff,&icole,&jqe, + &irowe,isolver,nzse,&adbe,&aube,iexpl, + ibody,xbody,nbody,cocon,ncocon,tieset,&ntie,&nnn,imddof,&nmddof, + imdnode,&nmdnode,imdboun,&nmdboun,imdmpc,&nmdmpc,&izdof,&nzdof); + + RENEW(imddof,int,nmddof); + RENEW(imdnode,int,nmdnode); + RENEW(imdboun,int,nmdboun); + RENEW(imdmpc,int,nmdmpc); + + free(vold);vold=NNEW(double,mt**nk); + RENEW(eme,double,6*mi[0]**ne); + +// RENEW(xstiff,double,(long long)27*mi[0]**ne); + RENEW(xstiff,double,(long long)27*mi[0]**ne*nsectors); + if(*nener==1) RENEW(ener,double,mi[0]**ne); + } + + fclose(f1); + + fric=NNEW(double,nev); + + /* check whether there are dashpot elements */ + + dashpot=0; + for(i=0;i<*ne;i++){ + if(ipkon[i]==-1) continue; + if(strcmp1(&lakon[i*8],"ED")==0){ + dashpot=1;break;} + } + if(dashpot){ + + if(cyclicsymmetry){ + printf("*ERROR in steadystate: dashpots are not allowed in combination with cyclic symmetry\n"); + FORTRAN(stop,()); + } + + /* cc is the reduced damping matrix (damping matrix mapped onto + space spanned by eigenmodes) */ + + cc=NNEW(double,nev*nev); + nev2=2*nev; + am=NNEW(double,nev2*nev2); + bm=NNEW(double,nev2); + ipiv=NNEW(int,nev2); + } + + inum=NNEW(int,*nk); + strcpy1(&cflag[0],&filab[4],1); + FORTRAN(createinum,(ipkon,inum,kon,lakon,nk,ne,&cflag[0],nelemload, + nload,nodeboun,nboun,ndirboun,ithermal)); + + /* check whether integration point values are requested; if not, + the stress fields do not have to be allocated */ + + intpointvar=0; + if(*ithermal<=1){ + + /* mechanical */ + + if((strcmp1(&filab[174],"S")==0)|| + (strcmp1(&filab[261],"E")==0)|| + (strcmp1(&filab[348],"RF")==0)|| + (strcmp1(&filab[435],"PEEQ")==0)|| + (strcmp1(&filab[522],"ENER")==0)|| + (strcmp1(&filab[609],"SDV")==0)|| + (strcmp1(&filab[1044],"ZZS")==0)|| + (strcmp1(&filab[1479],"PHS")==0)|| + (strcmp1(&filab[1653],"MAXS")==0)|| + (strcmp1(&filab[2175],"CONT")==0)|| + (strcmp1(&filab[2262],"CELS")==0)) intpointvar=1; + for(i=0;i<*nprint;i++){ + if((strcmp1(&prlab[6*i],"S")==0)|| + (strcmp1(&prlab[6*i],"E")==0)|| + (strcmp1(&prlab[6*i],"PEEQ")==0)|| + (strcmp1(&prlab[6*i],"ENER")==0)|| + (strcmp1(&prlab[6*i],"SDV")==0)|| + (strcmp1(&prlab[6*i],"RF")==0)) {intpointvar=1;break;} + } + }else{ + + /* thermal */ + + if((strcmp1(&filab[696],"HFL")==0)|| + (strcmp1(&filab[783],"RFL")==0)) intpointvar=1; + for(i=0;i<*nprint;i++){ + if((strcmp1(&prlab[6*i],"HFL")==0)|| + (strcmp1(&prlab[6*i],"RFL")==0)) {intpointvar=1;break;} + } + } + + if(nfour<=0){ + + /* harmonic excitation */ + + ikactmechr=NNEW(int,neq[1]);ikactmechi=NNEW(int,neq[1]); + nactmechr=0;nactmechi=0; + + /* result fields */ + + if(intpointvar==1){ + fn=NNEW(double,mt**nk); + stnr=NNEW(double,6**nk); + stni=NNEW(double,6**nk); + stx=NNEW(double,6*mi[0]**ne); + eei=NNEW(double,6*mi[0]**ne); + + if(*ithermal>1) {qfn=NNEW(double,3**nk);qfx=NNEW(double,3*mi[0]**ne);} + + if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); + if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); + + if(*nener==1){ + stiini=NNEW(double,6*mi[0]**ne); + enerini=NNEW(double,mi[0]**ne);} + } + + /* determining the frequency data points */ + + freq=NNEW(double,ndata*(nev+1)); + + ndatatot=0.; + freq[0]=fmin; + if(fabs(fmax-fmin)<1.e-10){ + ndatatot=1; + }else{ + + /* copy the eigenvalues and sort them in ascending order + (important for values from distinct nodal diameters */ + + e=NNEW(double,nev); + for(i=0;i=fmin){ + if(e[i]<=fmax){ + for(j=1;j1.e-10){ + iprescribedboundary=1; + break; + } + } + + if((iprescribedboundary)&&(cyclicsymmetry)){ + printf("*ERROR in steadystate: prescribed boundaries are not allowed in combination with cyclic symmetry\n"); + FORTRAN(stop,()); + } + + /* calculating the damping coefficients = friction coefficient*2*eigenvalue */ + + if(xmodal[10]<0){ + for(i=0;i(1.e-10)){ + fric[i]=(alpham+betam*d[i]*d[i]); + } + else { + printf("*WARNING in steadystate: one of the frequencies is zero\n"); + printf(" no Rayleigh mass damping allowed\n"); + fric[i]=0.; + } + } + } + else{ + if(iprescribedboundary){ + printf("*ERROR in steadystate: prescribed boundaries are not allowed in combination with direct modal damping\n"); + FORTRAN(stop,()); + } + + /*copy the damping coefficients for every eigenfrequencie from xmodal[11....] */ + if(nev<(int)xmodal[10]){ + imax=nev; + printf("*WARNING in steadystate: too many modal damping coefficients applied\n"); + printf(" damping coefficients corresponding to nonexisting eigenvalues are ignored\n"); + } + else{ + imax=(int)xmodal[10]; + } + for(i=0; i=nsectors){ + iphaseforc[i]=1; + } + } + + iphaseload=NNEW(int,*nload); + for (i=0;i<*nload;i++){ + if(nelemload[2*i+1]>=nsectors){ + iphaseload[i]=1; + } + } + + if(iprescribedboundary){ + iphaseboun=NNEW(int,*nboun); + for (i=0;i<*nboun;i++){ + if(nodeboun[i]>*nk){ + iphaseboun[i]=1; + nodeboun[i]=nodeboun[i]-*nk; + } + } + } + + /* allocating actual loading fields */ + + xforcact=NNEW(double,*nforc); + xforcr=NNEW(double,*nforc); + xforci=NNEW(double,*nforc); + + xloadact=NNEW(double,2**nload); + xloadr=NNEW(double,2**nload); + xloadi=NNEW(double,2**nload); + + xbodyact=NNEW(double,7**nbody); + xbodyr=NNEW(double,7**nbody); + xbodyi=NNEW(double,7**nbody); + /* copying the rotation axis and/or acceleration vector */ + for(k=0;k<7**nbody;k++){xbodyact[k]=xbody[k];} + + xbounact=NNEW(double,*nboun); + + if(*ithermal==1) t1act=NNEW(double,*nk); + + /* assigning the body forces to the elements */ + + if(*nbody>0){ + ifreebody=*ne+1; + ipobody=NNEW(int,2*ifreebody**nbody); + for(k=1;k<=*nbody;k++){ + FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, + iendset,ialset,&inewton,nset,&ifreebody,&k)); + RENEW(ipobody,int,2*(*ne+ifreebody)); + } + RENEW(ipobody,int,2*(ifreebody-1)); + } + + br=NNEW(double,neq[1]); /* load rhs vector */ + bi=NNEW(double,neq[1]); /* load rhs vector */ + + if(iprescribedboundary){ + xbounr=NNEW(double,*nboun); + xbouni=NNEW(double,*nboun); + + fr=NNEW(double,neq[1]); /* force corresponding to real particular solution */ + fi=NNEW(double,neq[1]); /* force corresponding to imaginary particular solution */ + + ubr=NNEW(double,neq[1]); /* real particular solution */ + ubi=NNEW(double,neq[1]); /* imaginary particular solution */ + + mubr=NNEW(double,neq[1]); /* mass times real particular solution */ + mubi=NNEW(double,neq[1]); /* mass times imaginary particular solution */ + } + + bjr=NNEW(double,nev); /* real response modal decomposition */ + bji=NNEW(double,nev); /* imaginary response modal decomposition */ + + ampli=NNEW(double,*nam); /* instantaneous amplitude */ + + aa=NNEW(double,nev); /* modal coefficients of the real loading */ + bb=NNEW(double,nev); /* modal coefficients of the imaginary loading */ + + /* result fields */ + + vr=NNEW(double,mt**nk); + vi=NNEW(double,mt**nk); + + if(iprescribedboundary){ + + /* LU decomposition of the stiffness matrix */ + + if(*isolver==0){ +#ifdef SPOOLES + spooles_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1], + &symmetryflag,&inputformat); +#else + printf("*ERROR in steadystate: the SPOOLES library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==4){ +#ifdef SGI + token=1; + sgi_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1],token); +#else + printf("*ERROR in steadystate: the SGI library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_factor(ad,&au,adb,aub,&sigma,icol,&irow,&neq[1],&nzs[1]); +#else + printf("*ERROR in steadystate: the TAUCS library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_factor(ad,au,adb,aub,&sigma,icol,irow,&neq[1],&nzs[1]); +#else + printf("*ERROR in steadystate: the PARDISO library is not linked\n\n"); + FORTRAN(stop,()); +#endif + } + } + + for(l=0;l0.){vp[mt*i+j]=90.;} + else{vp[mt*i+j]=-90.;} + } + else{ + vp[mt*i+j]=atan(vi[mt*i+j]/vreal)*constant; + if(vreal<0.) vp[mt*i+j]+=180.; + } + } + } + }else{ + for(jj=0;jj0.){vp[mt*i+j]=90.;} + else{vp[mt*i+j]=-90.;} + } + else{ + vp[mt*i+j]=atan(vi[mt*i+j]/vreal)*constant; + if(vreal<0.) vp[mt*i+j]+=180.; + } + } + } + } + } + else{ + if(nmdnode==0){ + for(i=0;i<*nk;i++){ + vreal=vr[mt*i]; + va[mt*i]=sqrt(vr[mt*i]*vr[mt*i]+vi[mt*i]*vi[mt*i]); + if(fabs(vreal)<1.e-10){ + if(vi[mt*i]>0){vp[mt*i]=90.;} + else{vp[mt*i]=-90.;} + } + else{ + vp[mt*i]=atan(vi[mt*i]/vreal)*constant; + if(vreal<0.) vp[mt*i]+=180.; + } + } + }else{ + for(jj=0;jj0){vp[mt*i]=90.;} + else{vp[mt*i]=-90.;} + } + else{ + vp[mt*i]=atan(vi[mt*i]/vreal)*constant; + if(vreal<0.) vp[mt*i]+=180.; + } + } + } + } + } + + if(strcmp1(&filab[1479],"PHS")==0){ + + constant=180./pi; + stna=NNEW(double,6**nk); + stnp=NNEW(double,6**nk); + + if(*ithermal<=1){ + if(nmdnode==0){ + for(i=0;i<*nk;i++){ + for(j=0;j<6;j++){ + vreal=stnr[6*i+j]; + stna[6*i+j]=sqrt(stnr[6*i+j]*stnr[6*i+j]+stni[6*i+j]*stni[6*i+j]); + if(fabs(vreal)<1.e-10){ + if(stni[6*i+j]>0.){stnp[6*i+j]=90.;} + else{stnp[6*i+j]=-90.;} + } + else{ + stnp[6*i+j]=atan(stni[6*i+j]/vreal)*constant; + if(vreal<0.) stnp[6*i+j]+=180.; + } + } + } + }else{ + for(jj=0;jj0){vp[mt*i]=90.;} + else{vp[mt*i]=-90.;} + } + else{ + vp[mt*i]=atan(vi[mt*i]/vreal)*constant; + if(vreal<0.) vp[mt*i]+=180.; + } + } + } + } + } + + (*kode)++; + mode=0; + + if(strcmp1(&filab[1044],"ZZS")==0){ + neigh=NNEW(int,40**ne);ipneigh=NNEW(int,*nk); + } + FORTRAN(out,(co,&nkg,kon,ipkon,lakon,&neg,vi,stni,inum,nmethod, + kode,filab, + een,t1,fn,ttime,epn,ielmat,matname,enern,xstaten,nstate_,istep, + &iinc, + iperturb,ener,mi,output,ithermal,qfn,&mode,&noddiam, + trab,inotr,ntrans,orab,ielorien,norien,description, + ipneigh,neigh,stx,va,vp,stna,stnp,vmax,stnmax,&ngraph,veold, + &neg,cs,set,nset,istartset,iendset,ialset,eenmax)); + if(strcmp1(&filab[1044],"ZZS")==0){free(ipneigh);free(neigh);} + + free(va);free(vp);free(stna);free(stnp); + + } + + /* restoring the imaginary loading */ + + free(iphaseforc);free(xforcr);free(xforci); + + free(iphaseload);free(xloadr);free(xloadi); + + free(xbodyr);free(xbodyi); + + if(iprescribedboundary){ + for (i=0;i<*nboun;i++){ + if(iphaseboun[i]==1){ + nodeboun[i]=nodeboun[i]+*nk; + } + } + free(iphaseboun); + } + + /* updating the loading at the end of the step; + important in case the amplitude at the end of the step + is not equal to one */ + + for(k=0;k<*nboun;++k){xboun[k]=xbounact[k];} + for(k=0;k<*nforc;++k){xforc[k]=xforcact[k];} + for(k=0;k<2**nload;++k){xload[k]=xloadact[k];} + for(k=0;k<7**nbody;k=k+7){xbody[k]=xbodyact[k];} + if(*ithermal==1){ + for(k=0;k<*nk;++k){t1[k]=t1act[k];} + } + + free(br);free(bi);free(bjr);free(bji),free(freq); + free(xforcact);free(xloadact);free(xbounact);free(aa);free(bb); + free(ampli);free(xbodyact);free(vr);free(vi);if(*nbody>0) free(ipobody); + + if(*ithermal==1) free(t1act); + + if(iprescribedboundary){ + if(*isolver==0){ +#ifdef SPOOLES + spooles_cleanup(); +#endif + } + else if(*isolver==4){ +#ifdef SGI + sgi_cleanup(token); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_cleanup(); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_cleanup(&neq[1]); +#endif + } + free(xbounr);free(xbouni);free(fr);free(fi);free(ubr);free(ubi); + free(mubr);free(mubi); + } + + free(ikactmechr);free(ikactmechi); + + if(intpointvar==1){ + free(fn);free(stnr);free(stni);free(stx);free(eei); + + if(*ithermal>1) {free(qfn);free(qfx);} + + if(strcmp1(&filab[261],"E ")==0) free(een); + if(strcmp1(&filab[522],"ENER")==0) free(enern); + + if(*nener==1){free(stiini);free(enerini);} + } + + }else{ + + /* steady state response to a nonharmonic periodic loading */ + + ikactmech=NNEW(int,neq[1]); + nactmech=0; + + xforcact=NNEW(double,nfour**nforc); + xloadact=NNEW(double,nfour*2**nload); + xbodyact=NNEW(double,nfour*7**nbody); + xbounact=NNEW(double,nfour**nboun); + xbounacttime=NNEW(double,nfour**nboun); + if(*ithermal==1) t1act=NNEW(double,*nk); + + r=NNEW(double,nfour); + wsave=NNEW(double,2*nfour); + isave=NNEW(int,15); + + /* check for nonzero SPC's */ + + iprescribedboundary=0; + for(i=0;i<*nboun;i++){ + if(fabs(xboun[i])>1.e-10){ + iprescribedboundary=1; + break; + } + } + + if((iprescribedboundary)&&(cyclicsymmetry)){ + printf("*ERROR in steadystate: prescribed boundaries are not allowed in combination with cyclic symmetry\n"); + FORTRAN(stop,()); + } + + /* calculating the damping coefficients = friction coefficient*2*eigenvalue */ + + if(xmodal[10]<0){ + for(i=0;i(1.e-10)){ + fric[i]=(alpham+betam*d[i]*d[i]); + } + else { + printf("*WARNING in steadystate: one of the frequencies is zero\n"); + printf(" no Rayleigh mass damping allowed\n"); + fric[i]=0.; + } + } + } + else{ + if(iprescribedboundary){ + printf("*ERROR in steadystate: prescribed boundaries are not allowed in combination with direct modal damping\n"); + FORTRAN(stop,()); + } + + /*copy the damping coefficients for every eigenfrequencie from xmodal[11....] */ + if(nev<(int)xmodal[10]){ + imax=nev; + printf("*WARNING in steadystate: too many modal damping coefficients applied\n"); + printf(" damping coefficients corresponding to nonexisting eigenvalues are ignored\n"); + } + else{ + imax=(int)xmodal[10]; + } + for(i=0; i=fmin){ + if(e[i]<=fmax){ + for(j=1;j0){ + ifreebody=*ne+1; + ipobody=NNEW(int,2*ifreebody**nbody); + for(k=1;k<=*nbody;k++){ + FORTRAN(bodyforce,(cbody,ibody,ipobody,nbody,set,istartset, + iendset,ialset,&inewton,nset,&ifreebody,&k)); + RENEW(ipobody,int,2*(*ne+ifreebody)); + } + RENEW(ipobody,int,2*(ifreebody-1)); + } + + br=NNEW(double,neq[1]); /* load rhs vector (real part) */ + bi=NNEW(double,neq[1]); /* load rhs vector (imaginary part) */ + btot=NNEW(double,nfour*neq[1]); + + bjr=NNEW(double,nev); /* real response modal decomposition */ + bji=NNEW(double,nev); /* imaginary response modal decomposition */ + + aa=NNEW(double,nev); /* modal coefficients of the real loading */ + bb=NNEW(double,nev); /* modal coefficients of the imaginary loading */ + + /* loop over all Fourier frequencies */ + + freq=NNEW(double,nfour); + + for(l=0;l0.){bi[i]=pi/2.;} + else{bi[i]=-pi/2.;} + } + else{ + bi[i]=atan(bi[i]/breal); + if(breal<0.){bi[i]+=pi;} + } + } + + /* correction for the sinus terms */ + + if((l!=0)&&(2*(int)floor(l/2.+0.1)==l)){ + for(i=0;i0.){bi[i]=pi/2.;} + else{bi[i]=-pi/2.;} + } + else{ + bi[i]=atan(bi[i]/breal); + if(breal<0.){bi[i]+=pi;} + } + } + + /* correction for the sinus terms */ + + if((l!=0)&&(2*(int)floor(l/2.+0.1)==l)){ + for(jj=0;jj0) free(ipobody); + if(iprescribedboundary) {free(xbounr);free(fr);free(ubr);free(mubr);} + + + /* result fields */ + + vr=NNEW(double,mt**nk); + + if(intpointvar==1){ + fn=NNEW(double,mt**nk); + stn=NNEW(double,6**nk); + stx=NNEW(double,6*mi[0]**ne); + + if(*ithermal>1) { + qfn=NNEW(double,3**nk);qfx=NNEW(double,3*mi[0]**ne);} + + if(strcmp1(&filab[261],"E ")==0) een=NNEW(double,6**nk); + if(strcmp1(&filab[522],"ENER")==0) enern=NNEW(double,*nk); + + eei=NNEW(double,6*mi[0]**ne); + if(*nener==1){ + stiini=NNEW(double,6*mi[0]**ne); + enerini=NNEW(double,mi[0]**ne);} + } + + /* storing the results */ + + for(l=0;l1) {free(qfn);free(qfx);} + + if(strcmp1(&filab[261],"E ")==0) free(een); + if(strcmp1(&filab[522],"ENER")==0) free(enern); + + if(*nener==1){free(stiini);free(enerini);} + } + + } + free(xforcact);free(xloadact);free(xbodyact);free(xbounact); + free(xbounacttime);free(freqnh); + if(*ithermal==1) free(t1act); + if(iprescribedboundary){ + if(*isolver==0){ +#ifdef SPOOLES + spooles_cleanup(); +#endif + } + else if(*isolver==4){ +#ifdef SGI + sgi_cleanup(token); +#endif + } + else if(*isolver==5){ +#ifdef TAUCS + tau_cleanup(); +#endif + } + else if(*isolver==7){ +#ifdef PARDISO + pardiso_cleanup(&neq[1]); +#endif + } + } + + free(ikactmech); + + } + + free(adb);free(aub);free(z);free(d);free(inum); + + if(!cyclicsymmetry){ + free(ad);free(au); + }else{ + free(izdof); + + *nk/=nsectors; + *ne/=nsectors; + *nboun/=nsectors; + neq[1]=neq[1]*2/nsectors; + + RENEW(co,double,3**nk); + if(*ithermal!=0){ + RENEW(t0,double,*nk); + RENEW(t1old,double,*nk); + RENEW(t1,double,*nk); + if(*nam>0) RENEW(iamt1,int,*nk); + } + RENEW(nactdof,int,mt**nk); + if(*ntrans>0) RENEW(inotr,int,2**nk); + RENEW(kon,int,*nkon); + RENEW(ipkon,int,*ne); + RENEW(lakon,char,8**ne); + RENEW(ielmat,int,*ne); + if(*norien>0) RENEW(ielorien,int,*ne); + RENEW(nodeboun,int,*nboun); + RENEW(ndirboun,int,*nboun); + if(*nam>0) RENEW(iamboun,int,*nboun); + RENEW(xboun,double,*nboun); + RENEW(xbounold,double,*nboun); + RENEW(ikboun,int,*nboun); + RENEW(ilboun,int,*nboun); + + /* recovering the original multiple point constraints */ + + RENEW(ipompc,int,*nmpc); + RENEW(nodempc,int,3**mpcend); + RENEW(coefmpc,double,*mpcend); + RENEW(labmpc,char,20**nmpc+1); + RENEW(ikmpc,int,*nmpc); + RENEW(ilmpc,int,*nmpc); + RENEW(fmpc,double,*nmpc); + + *nmpc=nmpcold; + *mpcend=mpcendold; + for(i=0;i<*nmpc;i++){ipompc[i]=ipompcold[i];} + for(i=0;i<3**mpcend;i++){nodempc[i]=nodempcold[i];} + for(i=0;i<*mpcend;i++){coefmpc[i]=coefmpcold[i];} + for(i=0;i<20**nmpc;i++){labmpc[i]=labmpcold[i];} + for(i=0;i<*nmpc;i++){ikmpc[i]=ikmpcold[i];} + for(i=0;i<*nmpc;i++){ilmpc[i]=ilmpcold[i];} + free(ipompcold);free(nodempcold);free(coefmpcold); + free(labmpcold);free(ikmpcold);free(ilmpcold); + + RENEW(vold,double,mt**nk); + RENEW(eme,double,6*mi[0]**ne); + if(*nener==1)RENEW(ener,double,mi[0]**ne); + +/* distributed loads */ + + for(i=0;i<*nload;i++){ + if(nelemload[2*i]<=*ne*nsectors){ + nelemload[2*i]-=*ne*nelemload[2*i+1]; + }else{ + nelemload[2*i]-=*ne*(nsectors+nelemload[2*i+1]-1); + } + } + + /* sorting the elements with distributed loads */ + + if(*nload>0){ + if(*nam>0){ + FORTRAN(isortiddc2,(nelemload,iamload,xload,xloadold,sideload,nload,&kflag)); + }else{ + FORTRAN(isortiddc1,(nelemload,xload,xloadold,sideload,nload,&kflag)); + } + } + +/* point loads */ + + for(i=0;i<*nforc;i++){ + if(nodeforc[2*i]<=*nk*nsectors){ + nodeforc[2*i]-=*nk*nodeforc[2*i+1]; + }else{ + nodeforc[2*i]-=*nk*(nsectors+nodeforc[2*i+1]-1); + } + } + } + + free(xstiff);free(fric); + + if(dashpot){free(cc);free(am);free(bm);free(ipiv);} + + if(nmdnode>0){free(imddof);free(imdnode);free(imdboun);free(imdmpc);} + + *cop=co;*konp=kon;*ipkonp=ipkon;*lakonp=lakon;*ielmatp=ielmat; + *ielorienp=ielorien;*inotrp=inotr;*nodebounp=nodeboun; + *ndirbounp=ndirboun;*iambounp=iamboun;*xbounp=xboun; + *xbounoldp=xbounold;*ikbounp=ikboun;*ilbounp=ilboun;*nactdofp=nactdof; + *voldp=vold;*emep=eme;*enerp=ener;*ipompcp=ipompc;*nodempcp=nodempc; + *coefmpcp=coefmpc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; + *fmpcp=fmpc;*iamt1p=iamt1;*t0p=t0;*t1oldp=t1old;*t1p=t1;*nnnp=nnn; + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/steadystatedynamics.f calculix-ccx-2.3/ccx_2.3/src/steadystatedynamics.f --- calculix-ccx-2.1/ccx_2.3/src/steadystatedynamics.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/steadystatedynamics.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,228 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine steadystatedynamics(inpc,textpart,nmethod, + & iexpl,istep,istat,n,iline,ipol,inl,ipoinp,inp,iperturb,isolver, + & xmodal,cs,mcs,ipoinpc,nforc,nload,nbody,iprestr,t0,t1,ithermal, + & nk,set,nset) +! +! reading the input deck: *STEADY STATE DYNAMICS +! + implicit none +! + logical cyclicsymmetry,nodalset +! + character*1 inpc(*) + character*3 harmonic + character*20 solver + character*81 set(*),noset + character*132 textpart(16) +! + integer nmethod,istep,istat,n,key,iexpl,iline,ipol,inl,nset, + & ipoinp(2,*),inp(3,*),iperturb(2),isolver,i,ndata,nfour,mcs, + & ipoinpc(0:*),nforc,nload,nbody,iprestr,ithermal,j,nk,ipos +! + real*8 fmin,fmax,bias,tmin,tmax,xmodal(*),cs(17,*),t0(*),t1(*) +! + iexpl=0 + iperturb(1)=0 + iperturb(2)=0 + harmonic='YES' + if((mcs.ne.0).and.(cs(2,1).ge.0.d0)) then + cyclicsymmetry=.true. + else + cyclicsymmetry=.false. + endif + nodalset=.false. +! + if(istep.lt.1) then + write(*,*) '*ERROR in steadystatedynamics: *STEADY STATE DYNAMI + &CS' + write(*,*) ' can only be used within a STEP' + stop + endif +! +! default solver +! + solver=' ' + if(isolver.eq.0) then + solver(1:7)='SPOOLES' + elseif(isolver.eq.2) then + solver(1:16)='ITERATIVESCALING' + elseif(isolver.eq.3) then + solver(1:17)='ITERATIVECHOLESKY' + elseif(isolver.eq.4) then + solver(1:3)='SGI' + elseif(isolver.eq.5) then + solver(1:5)='TAUCS' + elseif(isolver.eq.7) then + solver(1:7)='PARDISO' + endif +! + do i=2,n + if(textpart(i)(1:7).eq.'SOLVER=') then + read(textpart(i)(8:27),'(a20)') solver + elseif(textpart(i)(1:9).eq.'HARMONIC=') then + read(textpart(i)(10:12),'(a3)') harmonic + elseif(textpart(i)(1:14).eq.'CYCLICSYMMETRY') then + cyclicsymmetry=.true. + elseif(textpart(i)(1:5).eq.'NSET=') then + nodalset=.true. + noset=textpart(i)(6:85) + noset(81:81)=' ' + ipos=index(noset,' ') + noset(ipos:ipos)='N' + else + write(*,*) + & '*WARNING in steadystatedynamics: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(solver(1:7).eq.'SPOOLES') then + isolver=0 + elseif(solver(1:16).eq.'ITERATIVESCALING') then + write(*,*) '*WARNING in steadystatedynamics: the iterative scal + &ing' + write(*,*) ' procedure is not available for modal' + write(*,*) ' dynamic calculations; the default solver' + write(*,*) ' is used' + elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then + write(*,*) '*WARNING in steadystatedynamics: the iterative scal + &ing' + write(*,*) ' procedure is not available for modal' + write(*,*) ' dynamic calculations; the default solver' + write(*,*) ' is used' + elseif(solver(1:3).eq.'SGI') then + isolver=4 + elseif(solver(1:5).eq.'TAUCS') then + isolver=5 + elseif(solver(1:13).eq.'MATRIXSTORAGE') then + isolver=6 + elseif(solver(1:7).eq.'PARDISO') then + isolver=7 + else + write(*,*) '*WARNING in steadystatedynamics: unknown solver;' + write(*,*) ' the default solver is used' + endif +! + if((isolver.eq.2).or.(isolver.eq.3)) then + write(*,*) '*ERROR in steadystatedynamics: the default solver ' + & ,solver + write(*,*) ' cannot be used for modal dynamic' + write(*,*) ' calculations ' + stop + endif +! + if(nodalset) then + do i=1,nset + if(set(i).eq.noset) exit + enddo + if(i.gt.nset) then + noset(ipos:ipos)=' ' + write(*,*) '*ERROR in steadystatedynamics: node set ',noset + write(*,*) ' has not yet been defined.' + stop + endif + xmodal(10)=i+0.5d0 + else + if(cyclicsymmetry) then + write(*,*) '*ERROR in steadystatedynamics: cyclic symmetric' + write(*,*) ' structure, yet no node set defined' + stop + endif + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*) '*ERROR in steadystatedynamics: definition not compl + &ete' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + read(textpart(1)(1:20),'(f20.0)',iostat=istat) fmin + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + xmodal(3)=fmin + read(textpart(2)(1:20),'(f20.0)',iostat=istat) fmax + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + xmodal(4)=fmax + read(textpart(3)(1:20),'(i10)',iostat=istat) ndata + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(ndata.lt.2) ndata=20 + xmodal(5)=ndata+0.5 + read(textpart(4)(1:20),'(f20.0)',iostat=istat) bias + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(bias.lt.1.) bias=3. + xmodal(6)=bias +! + if(harmonic.eq.'YES') then + xmodal(7)=-0.5 + else + read(textpart(5)(1:10),'(i10)',iostat=istat) nfour + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(nfour.le.0) nfour=20 + if(n.ge.6) then + read(textpart(6)(1:20),'(f20.0)',iostat=istat) tmin + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + tmin=0.d0 + endif + if(n.ge.7) then + read(textpart(7)(1:20),'(f20.0)',iostat=istat) tmax + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + else + tmax=1.d0 + endif + xmodal(7)=nfour+0.5 + xmodal(8)=tmin + xmodal(9)=tmax + endif +! +! removing the present loading +! + nforc=0 + nload=0 + nbody=0 + iprestr=0 + if((ithermal.eq.1).or.(ithermal.eq.3)) then + do j=1,nk + t1(j)=t0(j) + enddo + endif +! + nmethod=5 +! +! correction for cyclic symmetric structures: +! if the present step was not preceded by a frequency step +! no nodal diameter has been selected. To make sure that +! mastructcs is called instead of mastruct a fictitious +! minimum nodal diameter is stored +! + if((cyclicsymmetry).and.(mcs.ne.0).and.(cs(2,1)<0.d0)) + & cs(2,1)=0.d0 +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/steps.f calculix-ccx-2.3/ccx_2.3/src/steps.f --- calculix-ccx-2.1/ccx_2.3/src/steps.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/steps.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,123 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine steps(inpc,textpart,iperturb,iprestr,nbody, + & nforc,nload,ithermal,t0,t1,nk,irstrt,istep,istat,n,jmax,ctrl, + & iline,ipol,inl,ipoinp,inp,newstep,ipoinpc,physcon) +! +! reading the input deck: *STEP +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer iperturb(*),nforc,nload,ithermal,nk,istep,istat,n,key, + & i,j,iprestr,jmax(2),irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*), + & newstep,nbody,ipoinpc(0:*) +! + real*8 t0(*),t1(*),ctrl(*),physcon(*) +! + if(newstep.eq.1) then + write(*,*) '*ERROR in steps: *STEP statement detected' + write(*,*) ' within step ',istep + stop + else + newstep=1 + endif +! + if(iperturb(1).lt.2) iperturb(1)=0 + if(irstrt.lt.0) irstrt=0 + istep=istep+1 + jmax(1)=100 + jmax(2)=10000 + physcon(9)=0.5d0 +! + do i=2,n + if(textpart(i)(1:12).eq.'PERTURBATION') then + iperturb(1)=1 + iperturb(2)=1 +! +! removing the present loading (check!!) +! + nforc=0 + iprestr=0 + if((ithermal.eq.1).or.(ithermal.eq.3)) then + do j=1,nk + t1(j)=t0(j) + enddo + endif +! + elseif((textpart(i)(1:6).eq.'NLGEOM').and. + & (textpart(i)(7:9).ne.'=NO')) then +! +! geometrically nonlinear calculations +! + iperturb(2)=1 + if(iperturb(1).eq.0) then + iperturb(1)=2 + elseif(iperturb(1).eq.1) then + write(*,*) '*ERROR in steps: PERTURBATION and NLGEOM' + write(*,*) ' are mutually exclusive; ' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! + elseif(textpart(i)(1:4).eq.'INC=') then +! +! maximum number of increments +! + read(textpart(i)(5:14),'(i10)',iostat=istat) jmax(1) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! + elseif(textpart(i)(1:5).eq.'INCF=') then +! +! maximum number of fluid increments +! + read(textpart(i)(6:15),'(i10)',iostat=istat) jmax(2) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:16).eq.'TURBULENCEMODEL=') then +! +! turbulence model +! + if(textpart(i)(17:25).eq.'NONE') then + physcon(9)=0.5d0 + elseif(textpart(i)(17:25).eq.'K-EPSILON') then + physcon(9)=1.5d0 + elseif(textpart(i)(17:23).eq.'K-OMEGA') then + physcon(9)=2.5d0 + elseif(textpart(i)(17:19).eq.'SST') then + physcon(9)=3.5d0 + endif + else + write(*,*) '*WARNING in steps: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/stiff2mat.f calculix-ccx-2.3/ccx_2.3/src/stiff2mat.f --- calculix-ccx-2.1/ccx_2.3/src/stiff2mat.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/stiff2mat.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,150 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine stiff2mat(elas,ckl,vj,cauchy) +! +! elas(21): stiffness constants in the spatial description, i.e. +! the derivative of the Cauchy stress or the Kirchhoff +! stress with respect to the Eulerian strain +! ckl(3,3): inverse deformation gradient +! vj: Jacobian determinant +! cauchy: logical variable +! if true: elas is written in terms of Cauchy stress +! if false: elas is written in terms of Kirchhoff stress +! +! OUTPUT: +! +! elas(21): stiffness constants in the material description,i.e. +! the derivative of the second Piola-Kirchhoff stress (PK2) +! with respect to the Lagrangian strain +! + implicit none +! + logical cauchy +! + integer kk(84),i,nt,k,l,m,n +! + real*8 elas(21),e(21),ckl(3,3),vj +! + data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, + & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, + & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, + & 2,3,2,3/ +! + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + e(i)=elas(1)*ckl(k,1)*ckl(l,1)*ckl(m,1)*ckl(n,1) + & +elas(2)*(ckl(k,2)*ckl(l,2)*ckl(m,1)*ckl(n,1)+ + & ckl(k,1)*ckl(l,1)*ckl(m,2)*ckl(n,2)) + & +elas(3)*ckl(k,2)*ckl(l,2)*ckl(m,2)*ckl(n,2) + & +elas(4)*(ckl(k,3)*ckl(l,3)*ckl(m,1)*ckl(n,1)+ + & ckl(k,1)*ckl(l,1)*ckl(m,3)*ckl(n,3)) + & +elas(5)*(ckl(k,3)*ckl(l,3)*ckl(m,2)*ckl(n,2)+ + & ckl(k,2)*ckl(l,2)*ckl(m,3)*ckl(n,3)) + & +elas(6)*ckl(k,3)*ckl(l,3)*ckl(m,3)*ckl(n,3) + & +elas(7)*(ckl(k,2)*ckl(l,1)*ckl(m,1)*ckl(n,1)+ + & ckl(k,1)*ckl(l,2)*ckl(m,1)*ckl(n,1)+ + & ckl(k,1)*ckl(l,1)*ckl(m,2)*ckl(n,1)+ + & ckl(k,1)*ckl(l,1)*ckl(m,1)*ckl(n,2)) + & +elas(8)*(ckl(k,2)*ckl(l,2)*ckl(m,2)*ckl(n,1)+ + & ckl(k,2)*ckl(l,2)*ckl(m,1)*ckl(n,2)+ + & ckl(k,2)*ckl(l,1)*ckl(m,2)*ckl(n,2)+ + & ckl(k,1)*ckl(l,2)*ckl(m,2)*ckl(n,2)) + & +elas(9)*(ckl(k,3)*ckl(l,3)*ckl(m,2)*ckl(n,1)+ + & ckl(k,3)*ckl(l,3)*ckl(m,1)*ckl(n,2)+ + & ckl(k,2)*ckl(l,1)*ckl(m,3)*ckl(n,3)+ + & ckl(k,1)*ckl(l,2)*ckl(m,3)*ckl(n,3)) + & +elas(10)*(ckl(k,2)*ckl(l,1)*ckl(m,2)*ckl(n,1)+ + & ckl(k,1)*ckl(l,2)*ckl(m,2)*ckl(n,1)+ + & ckl(k,2)*ckl(l,1)*ckl(m,1)*ckl(n,2)+ + & ckl(k,1)*ckl(l,2)*ckl(m,1)*ckl(n,2)) + & +elas(11)*(ckl(k,3)*ckl(l,1)*ckl(m,1)*ckl(n,1)+ + & ckl(k,1)*ckl(l,3)*ckl(m,1)*ckl(n,1)+ + & ckl(k,1)*ckl(l,1)*ckl(m,3)*ckl(n,1)+ + & ckl(k,1)*ckl(l,1)*ckl(m,1)*ckl(n,3)) + & +elas(12)*(ckl(k,2)*ckl(l,2)*ckl(m,3)*ckl(n,1)+ + & ckl(k,3)*ckl(l,1)*ckl(m,2)*ckl(n,2)+ + & ckl(k,1)*ckl(l,3)*ckl(m,2)*ckl(n,2)+ + & ckl(k,2)*ckl(l,2)*ckl(m,3)*ckl(n,1)) + & +elas(13)*(ckl(k,3)*ckl(l,3)*ckl(m,3)*ckl(n,1)+ + & ckl(k,3)*ckl(l,3)*ckl(m,1)*ckl(n,3)+ + & ckl(k,3)*ckl(l,1)*ckl(m,3)*ckl(n,3)+ + & ckl(k,1)*ckl(l,3)*ckl(m,3)*ckl(n,3)) + & +elas(14)*(ckl(k,3)*ckl(l,1)*ckl(m,2)*ckl(n,1)+ + & ckl(k,1)*ckl(l,3)*ckl(m,2)*ckl(n,1)+ + & ckl(k,2)*ckl(l,1)*ckl(m,3)*ckl(n,1)+ + & ckl(k,1)*ckl(l,2)*ckl(m,3)*ckl(n,1)+ + & ckl(k,3)*ckl(l,1)*ckl(m,1)*ckl(n,2)+ + & ckl(k,1)*ckl(l,3)*ckl(m,1)*ckl(n,2)+ + & ckl(k,2)*ckl(l,1)*ckl(m,1)*ckl(n,3)+ + & ckl(k,1)*ckl(l,2)*ckl(m,1)*ckl(n,3)) + & +elas(15)*(ckl(k,3)*ckl(l,1)*ckl(m,3)*ckl(n,1)+ + & ckl(k,1)*ckl(l,3)*ckl(m,3)*ckl(n,1)+ + & ckl(k,3)*ckl(l,1)*ckl(m,1)*ckl(n,3)+ + & ckl(k,1)*ckl(l,3)*ckl(m,1)*ckl(n,3)) + & +elas(16)*(ckl(k,3)*ckl(l,2)*ckl(m,1)*ckl(n,1)+ + & ckl(k,2)*ckl(l,3)*ckl(m,1)*ckl(n,1)+ + & ckl(k,1)*ckl(l,1)*ckl(m,3)*ckl(n,2)+ + & ckl(k,1)*ckl(l,1)*ckl(m,2)*ckl(n,3)) + & +elas(17)*(ckl(k,3)*ckl(l,2)*ckl(m,2)*ckl(n,2)+ + & ckl(k,2)*ckl(l,3)*ckl(m,2)*ckl(n,2)+ + & ckl(k,2)*ckl(l,2)*ckl(m,3)*ckl(n,2)+ + & ckl(k,2)*ckl(l,2)*ckl(m,2)*ckl(n,3)) + & +elas(18)*(ckl(k,3)*ckl(l,3)*ckl(m,3)*ckl(n,2)+ + & ckl(k,3)*ckl(l,3)*ckl(m,2)*ckl(n,3)+ + & ckl(k,3)*ckl(l,2)*ckl(m,3)*ckl(n,3)+ + & ckl(k,2)*ckl(l,3)*ckl(m,3)*ckl(n,3)) + & +elas(19)*(ckl(k,3)*ckl(l,2)*ckl(m,2)*ckl(n,1)+ + & ckl(k,2)*ckl(l,3)*ckl(m,2)*ckl(n,1)+ + & ckl(k,3)*ckl(l,2)*ckl(m,1)*ckl(n,2)+ + & ckl(k,2)*ckl(l,3)*ckl(m,1)*ckl(n,2)+ + & ckl(k,2)*ckl(l,1)*ckl(m,3)*ckl(n,2)+ + & ckl(k,1)*ckl(l,2)*ckl(m,3)*ckl(n,2)+ + & ckl(k,2)*ckl(l,1)*ckl(m,2)*ckl(n,3)+ + & ckl(k,1)*ckl(l,2)*ckl(m,2)*ckl(n,3)) + & +elas(20)*(ckl(k,3)*ckl(l,2)*ckl(m,3)*ckl(n,1)+ + & ckl(k,2)*ckl(l,3)*ckl(m,3)*ckl(n,1)+ + & ckl(k,3)*ckl(l,1)*ckl(m,3)*ckl(n,2)+ + & ckl(k,1)*ckl(l,3)*ckl(m,3)*ckl(n,2)+ + & ckl(k,3)*ckl(l,2)*ckl(m,1)*ckl(n,3)+ + & ckl(k,2)*ckl(l,3)*ckl(m,1)*ckl(n,3)+ + & ckl(k,3)*ckl(l,1)*ckl(m,2)*ckl(n,3)+ + & ckl(k,1)*ckl(l,3)*ckl(m,2)*ckl(n,3)) + & +elas(21)*(ckl(k,3)*ckl(l,2)*ckl(m,3)*ckl(n,2)+ + & ckl(k,2)*ckl(l,3)*ckl(m,3)*ckl(n,2)+ + & ckl(k,3)*ckl(l,2)*ckl(m,2)*ckl(n,3)+ + & ckl(k,2)*ckl(l,3)*ckl(m,2)*ckl(n,3)) + enddo +! + if(cauchy) then + do i=1,21 + elas(i)=e(i)*vj + enddo + else + do i=1,21 + elas(i)=e(i) + enddo + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/stop.f calculix-ccx-2.3/ccx_2.3/src/stop.f --- calculix-ccx-2.1/ccx_2.3/src/stop.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/stop.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,26 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine stop() +! + implicit none +! + call closefile() +! + stop + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/storecontactdof.c calculix-ccx-2.3/ccx_2.3/src/storecontactdof.c --- calculix-ccx-2.1/ccx_2.3/src/storecontactdof.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/storecontactdof.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,126 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +#ifdef SPOOLES + #include "spooles.h" +#endif +#ifdef SGI + #include "sgi.h" +#endif +#ifdef TAUCS + #include "tau.h" +#endif +#ifdef PARDISO + #include "pardiso.h" +#endif + +void storecontactdof(int *nope,int *nactdof, int *mt, int *konl, int **ikactcontp, + int *nactcont,int *nactcont_, double *bcont, double *fnl, + int *ikmpc, int *nmpc, int *ilmpc,int *ipompc, int *nodempc, + double *coefmpc){ + + int j,j1,jdof,id,k,l,ist,index,node,ndir,*ikactcont=*ikactcontp; + + for(j=0;j<*nope;j++){ + for(j1=0;j1<3;j1++){ + jdof=nactdof[*mt*(konl[j]-1)+j1+1]; + if(jdof!=0){ + + jdof--; + FORTRAN(nident,(ikactcont,&jdof,nactcont,&id)); + do{ + if(id>0){ + if(ikactcont[id-1]==jdof){ + break; + } + } + (*nactcont)++; + if(*nactcont>*nactcont_){ + *nactcont_=(int)(1.1**nactcont_); + RENEW(ikactcont,int,*nactcont_); + } + k=*nactcont-1; + l=k-1; + while(k>id){ + ikactcont[k--]=ikactcont[l--]; + } + ikactcont[id]=jdof; + break; + }while(1); + + bcont[jdof]-=fnl[3*j+j1]; + }else{ + jdof=8*(konl[j]-1)+j1+1; + FORTRAN(nident,(ikmpc,&jdof,nmpc,&id)); + if(id>0){ + if(ikmpc[id-1]==jdof){ + id=ilmpc[id-1]; + ist=ipompc[id-1]; + index=nodempc[3*ist-1]; + if(index==0) continue; + do{ + node=nodempc[3*index-3]; + ndir=nodempc[3*index-2]; + jdof=nactdof[*mt*(node-1)+ndir]; + if(jdof!=0){ + + jdof--; + FORTRAN(nident,(ikactcont,&jdof,nactcont,&id)); + do{ + if(id>0){ + if(ikactcont[id-1]==jdof){ + break; + } + } + (*nactcont)++; + if(*nactcont>*nactcont_){ + *nactcont_=(int)(1.1**nactcont_); + RENEW(ikactcont,int,*nactcont_); + } + k=*nactcont-1; + l=k-1; + while(k>id){ + ikactcont[k--]=ikactcont[l--]; + } + ikactcont[id]=jdof; + break; + }while(1); + +/* bcont[jdof]+=coefmpc[index-1]* + fnl[3*j+j1]/coefmpc[ist-1];*/ + bcont[jdof]-=coefmpc[index-1]* + fnl[3*j+j1]/coefmpc[ist-1]; + } + index=nodempc[3*index-1]; + if(index==0) break; + }while(1); + } + } + } + } + } + + *ikactcontp=ikactcont; + + return; +} + diff -Nru calculix-ccx-2.1/ccx_2.3/src/storeresidual.f calculix-ccx-2.3/ccx_2.3/src/storeresidual.f --- calculix-ccx-2.1/ccx_2.3/src/storeresidual.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/storeresidual.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,127 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine storeresidual(nactdof,b,fn,filab,ithermal,nk,sti,stn, + & ipkon,inum,kon,lakon,ne,mi,orab,ielorien,co,nelemload, + & nload,nodeboun,nboun,itg,ntg,vold,ndirboun) +! +! This routine is called in case of divergence: +! stores the residual forces in fn and changes the +! file storage labels so that the independent +! variables (displacements and/or temperatures) and +! the corresponding residual forces are stored in the +! frd file +! + implicit none +! + logical force +! + character*1 cflag + character*8 lakon(*) + character*87 filab(*) +! + integer mi(2),nactdof(0:mi(2),*),ithermal(2),i,j,nk, + & nfield,ndim,iorienglob,cfd, + & nelemload(2,*),nload,nodeboun(*),nboun,ipkon(*),inum(*),kon(*), + & ne,ielorien,itg(*),ntg,ndirboun(*),mt,nlabel +! + real*8 b(*),fn(0:mi(2),*),sti(6,mi(1),*),stn(6,*),orab(7,*), + & co(3,*),vold(0:mi(2),*) +! + mt=mi(2)+1 +! + nlabel=30 +! +! storing the residual forces in field fn +! + do i=1,nk + do j=0,mi(2) + if(nactdof(j,i).gt.0) then + fn(j,i)=b(nactdof(j,i)) + else + fn(j,i)=0.d0 + endif + enddo + enddo +! +! adapting the storage labels +! + do i=1,nlabel + filab(i)(1:4)=' ' + enddo +! + if(ithermal(1).ne.2) then + filab(1)(1:4)='U ' + filab(5)(1:4)='RF ' + else + filab(1)(1:4)=' ' + filab(5)(1:4)=' ' + endif +! + if(ithermal(1).gt.1) then + filab(2)(1:4)='NT ' + filab(10)(1:4)='RFL ' + filab(14)(1:4)='TT ' + filab(15)(1:4)='MF ' + filab(16)(1:4)='TP ' + filab(17)(1:4)='ST ' + else + filab(2)(1:4)=' ' + filab(10)(1:4)=' ' + filab(14)(1:4)=' ' + filab(15)(1:4)=' ' + filab(16)(1:4)=' ' + filab(17)(1:4)=' ' + endif +! +! calculating inum +! + nfield=0 + ndim=0 + iorienglob=0 + cflag=filab(1)(5:5) + cfd=0 + call extrapolate(sti,stn,ipkon,inum,kon,lakon,nfield,nk, + & ne,mi(1),ndim,orab,ielorien,co,iorienglob,cflag, + & nelemload,nload,nodeboun,nboun,ndirboun,vold, + & ithermal,force,cfd) +! + if(ithermal(1).gt.1) then + call networkextrapolate(vold,ipkon,inum,kon,lakon,ne,mi) + endif +! +! interpolation for 1d/2d elements +! + if(filab(1)(5:5).eq.'I') then + nfield=mt + cflag=filab(1)(5:5) + force=.false. + call map3dto1d2d(vold,ipkon,inum,kon,lakon,nfield,nk, + & ne,cflag,co,vold,force,mi) + endif +! +! marking gas nodes by multiplying inum by -1 +! + do i=1,ntg + inum(itg(i))=-inum(itg(i)) + enddo +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/str2mat.f calculix-ccx-2.3/ccx_2.3/src/str2mat.f --- calculix-ccx-2.1/ccx_2.3/src/str2mat.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/str2mat.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,89 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine str2mat(str,ckl,vj,cauchy) +! +! converts the stress in spatial coordinates into material coordinates +! or the strain in material coordinates into spatial coordinates. +! +! INPUT: +! +! str(6): Cauchy stress, Kirchhoff stress or Lagrange strain +! component order: 11,22,33,12,13,23 +! ckl(3,3): the inverse deformation gradient +! vj: Jakobian determinant +! cauchy: logical variable +! if true: str contains the Cauchy stress +! if false: str contains the Kirchhoff stress or +! Lagrange strain +! +! OUTPUT: +! +! str(6): Piola-Kirchhoff stress of the second kind (PK2) or +! Euler strain +! + implicit none +! + logical cauchy +! + integer i,m1,m2 +! + real*8 str(6),s(6),ckl(3,3),vj +! + do i=1,6 + if(i.eq.1) then + m1=1 + m2=1 + elseif(i.eq.2) then + m1=2 + m2=2 + elseif(i.eq.3) then + m1=3 + m2=3 + elseif(i.eq.4) then + m1=2 + m2=1 + elseif(i.eq.5) then + m1=3 + m2=1 + else + m1=3 + m2=2 + endif +! + s(i)=(str(1)*ckl(m1,1)*ckl(m2,1)+ + & str(2)*ckl(m1,2)*ckl(m2,2)+ + & str(3)*ckl(m1,3)*ckl(m2,3)+ + & str(4)*(ckl(m1,1)*ckl(m2,2)+ckl(m1,2)*ckl(m2,1))+ + & str(5)*(ckl(m1,1)*ckl(m2,3)+ckl(m1,3)*ckl(m2,1))+ + & str(6)*(ckl(m1,2)*ckl(m2,3)+ckl(m1,3)*ckl(m2,2))) +! + enddo +! + if(cauchy) then + do i=1,6 + str(i)=s(i)*vj + enddo + else + do i=1,6 + str(i)=s(i) + enddo + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/straighteq2d.f calculix-ccx-2.3/ccx_2.3/src/straighteq2d.f --- calculix-ccx-2.1/ccx_2.3/src/straighteq2d.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/straighteq2d.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,97 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine straighteq2d(col,straight) +! +! calculate the equation of the edges of a triangle with +! (col(1,1),col(2,1)),(col(1,2),col(2,2)),(col(1,3),col(2,3)) +! as vertices. The equation of the edge +! opposite notet(1) is of the form +! straight(1)*x+straight(2)*y+straight(3)=0, such that the +! vector (straight(1),straight(2)) points outwards; for the edge +! opposite of nodet(2) the equation is +! straight(4)*x+straight(5)*y+straight(6)=0 and for the edge +! oppositie of nodet(3) it is +! straight(7)*x+straight(8)*y+straight(8)=0. Here too, the normals +! (straight(4),straight(5)) and (straight(7),straight(8)) point +! outwards of the triangle. +! + implicit none +! + real*8 col(2,3),straight(9),x1,y1,dd +! +! edge opposite of 1 +! + x1=col(1,3)-col(1,2) + y1=col(2,3)-col(2,2) + dd=dsqrt(x1*x1+y1*y1) +! + straight(1)=y1/dd + straight(2)=-x1/dd +! + straight(3)=-(straight(1)*col(1,3)+ + & straight(2)*col(2,3)) +! + if(straight(1)*col(1,1)+straight(2)*col(2,1)+ + & straight(3).gt.0.d0) then + straight(1)=-straight(1) + straight(2)=-straight(2) + straight(3)=-straight(3) + endif +! +! edge opposite of 2 +! + x1=col(1,1)-col(1,3) + y1=col(2,1)-col(2,3) + dd=dsqrt(x1*x1+y1*y1) +! + straight(4)=y1/dd + straight(5)=-x1/dd +! + straight(6)=-(straight(4)*col(1,1)+ + & straight(5)*col(2,1)) +! + if(straight(4)*col(1,2)+straight(5)*col(2,2)+ + & straight(6).gt.0.d0) then + straight(4)=-straight(4) + straight(5)=-straight(5) + straight(6)=-straight(6) + endif +! +! edge opposite of 3 +! + x1=col(1,2)-col(1,1) + y1=col(2,2)-col(2,1) + dd=dsqrt(x1*x1+y1*y1) +! + straight(7)=y1/dd + straight(8)=-x1/dd +! + straight(9)=-(straight(7)*col(1,2)+ + & straight(8)*col(2,2)) +! + if(straight(7)*col(1,3)+straight(8)*col(2,3)+ + & straight(9).gt.0.d0) then + straight(7)=-straight(7) + straight(8)=-straight(8) + straight(9)=-straight(9) + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/straighteq3d.f calculix-ccx-2.3/ccx_2.3/src/straighteq3d.f --- calculix-ccx-2.1/ccx_2.3/src/straighteq3d.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/straighteq3d.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,113 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine straighteq3d(col,straight) +! +! calculate the equation of the planes through the +! edges of a triangle and perpendicular to the triangle together +! with the plane of the triangle itself with +! (col(1,1),col(2,1),col(3,1)),(col(1,2),col(2,2),col(3,2)), +! (col(1,3),col(2,3),col(3,3)) +! as vertices. The equation of the plane through the edge +! opposite nodet(1) is of the form +! straight(1)*x+straight(2)*y+straight(3)*z+straight(4)=0, such that the +! vector (straight(1),straight(2),straight(3)) points outwards; +! for the edge opposite of nodet(2) the equation is +! straight(5)*x+straight(6)*y+straight(7)*z+straight(8)=0 and for the edge +! oppositie of nodet(3) it is +! straight(9)*x+straight(10)*y+straight(11)*z+straight(12)=0. +! Here too, the normals +! (straight(5),straight(6),straight(7)) and +! (straight(9),straight(10),straight(11)) point +! outwards of the triangle. The equation of the triangle plane is +! straight(13)*x+straight(14)*y+straight(15)*z+straight(16)=0 such +! that the triangle is numbered clockwise when looking in the +! direction of vector (straight(13),straight(14),straight(15)). +! + implicit none +! + integer i +! + real*8 col(3,3),straight(16),p12(3),p23(3),p31(3),dd +! +! sides of the triangle +! + do i=1,3 + p12(i)=col(i,2)-col(i,1) + p23(i)=col(i,3)-col(i,2) + p31(i)=col(i,1)-col(i,3) + enddo +! +! normalized vector normal to the triangle: xn = p12 x p23 +! + straight(13)=p12(2)*p23(3)-p12(3)*p23(2) + straight(14)=p12(3)*p23(1)-p12(1)*p23(3) + straight(15)=p12(1)*p23(2)-p12(2)*p23(1) + dd=dsqrt(straight(13)*straight(13)+straight(14)*straight(14)+ + & straight(15)*straight(15)) + do i=13,15 + straight(i)=straight(i)/dd + enddo +! +! p12 x xn +! + straight(9)=p12(2)*straight(15)-p12(3)*straight(14) + straight(10)=p12(3)*straight(13)-p12(1)*straight(15) + straight(11)=p12(1)*straight(14)-p12(2)*straight(13) + dd=dsqrt(straight(9)*straight(9)+straight(10)*straight(10)+ + & straight(11)*straight(11)) + do i=9,11 + straight(i)=straight(i)/dd + enddo +! +! p23 x xn +! + straight(1)=p23(2)*straight(15)-p23(3)*straight(14) + straight(2)=p23(3)*straight(13)-p23(1)*straight(15) + straight(3)=p23(1)*straight(14)-p23(2)*straight(13) + dd=dsqrt(straight(1)*straight(1)+straight(2)*straight(2)+ + & straight(3)*straight(3)) + do i=1,3 + straight(i)=straight(i)/dd + enddo +! +! p31 x xn +! + straight(5)=p31(2)*straight(15)-p31(3)*straight(14) + straight(6)=p31(3)*straight(13)-p31(1)*straight(15) + straight(7)=p31(1)*straight(14)-p31(2)*straight(13) + dd=dsqrt(straight(5)*straight(5)+straight(6)*straight(6)+ + & straight(7)*straight(7)) + do i=5,7 + straight(i)=straight(i)/dd + enddo +! +! determining the inhomogeneous terms +! + straight(12)=-straight(9)*col(1,1)-straight(10)*col(2,1)- + & straight(11)*col(3,1) + straight(4)=-straight(1)*col(1,2)-straight(2)*col(2,2)- + & straight(3)*col(3,2) + straight(8)=-straight(5)*col(1,3)-straight(6)*col(2,3)- + & straight(7)*col(3,3) + straight(16)=-straight(13)*col(1,1)-straight(14)*col(2,1)- + & straight(15)*col(3,1) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/straightmpc.f calculix-ccx-2.3/ccx_2.3/src/straightmpc.f --- calculix-ccx-2.1/ccx_2.3/src/straightmpc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/straightmpc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,134 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine straightmpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, + & ikboun,ilboun,nboun,nboun_,xboun,inode,node,co,typeboun) +! +! generates MPC's for nodes staying on a straight line defined +! by two nodes a and b. The parameter inode indicates how many +! times the present routine was called within the same *MPC +! definition. For inode=1 "node" is node a, for inode=2 "node" +! is node b. Starting with inode=3 MPC's are defined. +! + implicit none +! + character*1 typeboun(*) + character*20 labmpc(*) +! + integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), + & ilmpc(*),node,id,mpcfreeold,j,idof,l,nodeboun(*),nodea,nodeb, + & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,inode,jmax,k +! + real*8 coefmpc(3,*),co(3,*),dd,dmax,xboun(*) +! + save nodea,nodeb,jmax +! + if(inode.eq.1) then + nodea=node + return + elseif(inode.eq.2) then + nodeb=node + dmax=0.d0 + do k=1,3 + dd=abs((co(k,nodea)-co(k,nodeb))) + if(dd.gt.dmax) then + dmax=dd + jmax=k + endif + enddo + return + endif +! + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in straightmpc: increase nk_' + stop + endif + do j=1,3 + if(j.eq.jmax) cycle + idof=8*(node-1)+j + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*WARNING in straightmpc: DOF for node ',node + write(*,*) ' in direction ',j,' has been used' + write(*,*) ' on the dependent side of another MPC' + write(*,*) ' STRAIGHT constraint cannot be applied' + cycle + endif + endif + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in straightmpc: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)='STRAIGHT ' +! + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc +! + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=j + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=node + nodempc(2,mpcfree)=jmax + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodea + nodempc(2,mpcfree)=j + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodea + nodempc(2,mpcfree)=jmax + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodeb + nodempc(2,mpcfree)=j + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nodeb + nodempc(2,mpcfree)=jmax + mpcfree=nodempc(3,mpcfree) + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=j + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + idof=8*(nk-1)+j + call nident(ikboun,idof,nboun,id) + nboun=nboun+1 + if(nboun.gt.nboun_) then + write(*,*) '*ERROR in straightmpc: increase nboun_' + stop + endif + nodeboun(nboun)=nk + ndirboun(nboun)=j + typeboun(nboun)='S' + do l=nboun,id+2,-1 + ikboun(l)=ikboun(l-1) + ilboun(l)=ilboun(l-1) + enddo + ikboun(id+1)=idof + ilboun(id+1)=nboun + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/strcmp1.c calculix-ccx-2.3/ccx_2.3/src/strcmp1.c --- calculix-ccx-2.1/ccx_2.3/src/strcmp1.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/strcmp1.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,50 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +int strcmp1(const char *s1, const char *s2) +{ + int a,b; + + do { + a=*s1++; + b=*s2++; + +/* the statement if((a=='\0')||(b=='\0')) has been treated separately + in order to avoid the first field (s1) to be defined one longer + than required; s1 is assumed to be a variable field, s2 is + assumed to be a fixed string */ + + if(b=='\0'){ + a='\0'; + b='\0'; + break; + } + if(a=='\0'){ + a='\0'; + b='\0'; + break; + } + }while(a==b); + return(a-b); +} + diff -Nru calculix-ccx-2.1/ccx_2.3/src/strcpy1.c calculix-ccx-2.3/ccx_2.3/src/strcpy1.c --- calculix-ccx-2.1/ccx_2.3/src/strcpy1.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/strcpy1.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,43 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include +#include "CalculiX.h" + +int strcpy1(char *s1, const char *s2, int length) +{ + int b,i,blank=0; + + for(i=0;i nk' + else + nalset=nalset+1 + iendset(iset)=nalset + endif + endif + enddo +! + else +! +! element surface +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + if(iendset(nset).eq.0) then + nset=nset-1 + endif + return + endif + if(nalset+1.gt.nalset_) then + write(*,*) '*ERROR in surfaces: increase nalset_' + stop + endif +! + read(textpart(2)(1:20),'(a20)',iostat=istat) label +! + if(label(2:4).eq.'NEG') then + label(2:4)='1 ' + elseif(label(2:4).eq.'POS') then + label(2:4)='2 ' + endif + if(label(2:2).eq.'N') then + label(2:2)='5' + elseif(label(2:2).eq.'P') then + label(2:2)='6' + endif +! + if((label(1:2).ne.'S1').and.(label(1:2).ne.'S2').and. + & (label(1:2).ne.'S3').and.(label(1:2).ne.'S4').and. + & (label(1:2).ne.'S5').and.(label(1:2).ne.'S6')) then + call inputerror(inpc,ipoinpc,iline) + endif +! + read(textpart(1)(1:10),'(i10)',iostat=istat)l + if(istat.gt.0) then + elset=textpart(1)(1:80) + elset(81:81)=' ' + ipos=index(elset,' ') + elset(ipos:ipos)='E' + do i=1,nset + if(set(i).eq.elset) then + do j=istartset(i),iendset(i) + l=ialset(j) + if(l.gt.0) then + kstart=kend + kend=l + nalset=nalset+1 + if(nalset.gt.nalset_) then + write(*,*) + & '*ERROR in surfaces: increase nalset_' + stop + endif + newlabel=label + if((lakon(l)(1:2).eq.'CP').or. + & (lakon(l)(2:2).eq.'A')) then + if(label(1:2).eq.'S1') then + newlabel(1:2)='S3' + elseif(label(1:2).eq.'S2') then + newlabel(1:2)='S4' + elseif(label(1:2).eq.'S3') then + newlabel(1:2)='S5' + elseif(label(1:2).eq.'S4') then + newlabel(1:2)='S6' + elseif(label(1:2).eq.'S5') then + newlabel(1:2)='S1' + elseif(label(1:2).eq.'S6') then + newlabel(1:2)='S2' + endif + endif + read(newlabel(2:2),'(i1)',iostat=istat) iside + ialset(nalset)=iside+10*l + else + kstart=kstart + nalset=nalset-1 + kincrement=-ialset(j) + do l=kstart+kincrement,kend,kincrement + nalset=nalset+1 + if(nalset.gt.nalset_) then + write(*,*) + & '*ERROR in surfaces: increase nalset_' + stop + endif + newlabel=label + if((lakon(l)(1:2).eq.'CP').or. + & (lakon(l)(2:2).eq.'A')) then + if(label(1:2).eq.'S1') then + newlabel(1:2)='S3' + elseif(label(1:2).eq.'S2') then + newlabel(1:2)='S4' + elseif(label(1:2).eq.'S3') then + newlabel(1:2)='S5' + elseif(label(1:2).eq.'S4') then + newlabel(1:2)='S6' + elseif(label(1:2).eq.'S5') then + newlabel(1:2)='S1' + elseif(label(1:2).eq.'S6') then + newlabel(1:2)='S2' + endif + endif + read(newlabel(2:2),'(i1)',iostat=istat) + & iside + ialset(nalset)=iside+10*l + enddo + endif + enddo + iendset(iset)=nalset + exit + endif + enddo + if(i.gt.nset) then + elset(ipos:ipos)=' ' + write(*,*) '*ERROR in surfaces: element set ',elset + write(*,*) ' does not exist' + stop + endif + else + if(l.gt.ne) then + write(*,*) '*WARNING in surfaces: value ', + & ialset(nalset+1) + write(*,*) ' in set ',set(iset),' > ne' + else + newlabel=label + if((lakon(l)(1:2).eq.'CP').or. + & (lakon(l)(2:2).eq.'A')) then + if(label(1:2).eq.'S1') then + newlabel(1:2)='S3' + elseif(label(1:2).eq.'S2') then + newlabel(1:2)='S4' + elseif(label(1:2).eq.'S3') then + newlabel(1:2)='S5' + elseif(label(1:2).eq.'S4') then + newlabel(1:2)='S6' + elseif(label(1:2).eq.'S5') then + newlabel(1:2)='S1' + elseif(label(1:2).eq.'S6') then + newlabel(1:2)='S2' + endif + endif + read(newlabel(2:2),'(i1)',iostat=istat) iside + nalset=nalset+1 + ialset(nalset)=iside+10*l + iendset(iset)=nalset + endif + endif + enddo + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/tau.c calculix-ccx-2.3/ccx_2.3/src/tau.c --- calculix-ccx-2.1/ccx_2.3/src/tau.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/tau.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,190 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifdef TAUCS + +#include +#include +#include +#include "CalculiX.h" +#include "tau.h" +#include + +taucs_ccs_matrix aa[1]; +void* F=NULL; +char* taufactor[]={ "taucs.factor.LLT=true","taucs.factor.mf=true", + "taucs.factor.ordering=amd",NULL }; +char* taufactorooc[]={ "taucs.factor.LLT=true","taucs.ooc=true", + "taucs.ooc.basename=/home/guido/scratch/scratch", + "taucs.ooc.memory=500000000.0",NULL }; +char* tausolve[]={ "taucs.factor=false",NULL }; +char* tausolveooc[]={"taucs.factor=false",NULL }; +int *irowtau=NULL,*pointtau=NULL; +double *autau=NULL; +int* perm; + + +void tau_factor(double *ad, double **aup, double *adb, double *aub, + double *sigma,int *icol, int **irowp, + int *neq, int *nzs){ + + int i,j,k,l,*irow=NULL; + long long ndim; + double *au=NULL; + double memory_mb = -1.0; + int mb = -1; + int ret; + + printf(" Factoring the system of equations using TAUCS\n\n"); + + taucs_logfile("stdout"); + + au=*aup; + irow=*irowp; + + ndim=*neq+*nzs; + + autau= NNEW(double,ndim); + irowtau=NNEW(int,ndim); + pointtau=NNEW(int,*neq+1); + + k=ndim; + l=*nzs; + + if(*sigma==0.){ + pointtau[*neq]=ndim; + for(i=*neq-1;i>=0;--i){ + for(j=0;j=0;--i){ + for(j=0;jn = *neq; + aa->m = *neq; + aa->flags = TAUCS_SYMMETRIC | TAUCS_LOWER | TAUCS_DOUBLE; + aa->colptr = pointtau; + aa->rowind = irowtau; + aa->values.d = autau; + + if(*neq<50000){ + taucs_linsolve(aa,&F,0,NULL,NULL,taufactor,NULL); + } + else{ + /*ret = taucs_linsolve(aa,&F,0,NULL,NULL,taufactorooc,NULL);*/ + + if (mb > 0) + memory_mb = (double) mb; + else + memory_mb = ((double) (-mb)) * taucs_available_memory_size()/1048576.0; + + F = taucs_io_create_multifile("~/scratch/scratch"); + + ret = taucs_ooc_factor_llt(aa,F,memory_mb*1048576.0); + + printf(" Return Code from Factoring %d\n\n",ret); + } + + *aup=au; + *irowp=irow; + + return; +} + +void tau_solve(double *b,int *neq){ + + int i; + /*static int j;*/ + double *x=NULL; + int ret; + + x=NNEW(double,*neq); + + if(*neq<150){ + taucs_linsolve(aa,&F,1,x,b,tausolve,NULL); + } + else{ + /*ret = taucs_linsolve(aa,&F,1,x,b,tausolveooc,NULL);*/ + + ret = taucs_ooc_solve_llt(F, x, b); + + printf(" Return Code from Solving %d\n\n",ret); + + taucs_io_delete(F); + } + + for(i=0;i<=*neq-1;++i){ + b[i]=x[i]; + } + free(x);/* + if (mb > 0) + memory_mb = (double) mb; + else + memory_mb = ((double) (-mb)) * taucs_available_memory_size()/1048576.0; + */ + /*j++;printf("%d\n",j);*/ + + return; +} + +void tau_cleanup(){ + + /*taucs_linsolve(NULL,&F,0,NULL,NULL,NULL,NULL);*/ + free(pointtau); + free(irowtau); + free(autau); + + return; +} + +void tau(double *ad, double **aup, double *adb, double *aub, double *sigma, + double *b, int *icol, int **irowp, + int *neq, int *nzs){ + + if(*neq==0) return; + + + tau_factor(ad,aup,adb,aub,sigma,icol,irowp, + neq,nzs); + + tau_solve(b,neq); + + tau_cleanup(); + + + return; +} + +#endif diff -Nru calculix-ccx-2.1/ccx_2.3/src/tau.h calculix-ccx-2.3/ccx_2.3/src/tau.h --- calculix-ccx-2.1/ccx_2.3/src/tau.h 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/tau.h 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,30 @@ +/* CALCULIX - A 3-dimensional finite element program */ +/* Copyright (C) 1998 Guido Dhondt */ +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation; either version 2 of */ +/* the License, or (at your option) any later version. */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +void tau(double *ad, double **aup, double *adb, double *aubp, double *sigma, + double *b, int *icol, int **irowp, + int *neq, int *nzs); + +void tau_factor(double *ad, double **aup, double *adb, double *aub, + double *sigma,int *icol, int **irowp, + int *neq, int *nzs); + +void tau_solve(double *b,int *neq); + +void tau_cleanup(); + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/temperatures.f calculix-ccx-2.3/ccx_2.3/src/temperatures.f --- calculix-ccx-2.1/ccx_2.3/src/temperatures.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/temperatures.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,224 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine temperatures(inpc,textpart,set,istartset,iendset, + & ialset,nset,t0,t1,nk,ithermal,iamt1,amname,nam,inoelfree,nk_, + & nmethod,temp_flag,istep,istat,n,iline,ipol,inl,ipoinp,inp, + & nam_,namtot_,namta,amta,ipoinpc) +! +! reading the input deck: *TEMPERATURE +! + implicit none +! + logical temp_flag,user +! + character*1 inpc(*) + character*80 amname(*),amplitude + character*81 set(*),noset + character*132 textpart(16) +! + integer istartset(*),iendset(*),ialset(*),iamt1(*),nmethod, + & nset,nk,ithermal,istep,istat,n,key,i,j,k,l,nam,ipoinpc(0:*), + & iamplitude,ipos,inoelfree,nk_,iline,ipol,inl,ipoinp(2,*), + & inp(3,*),nam_,namtot,namtot_,namta(3,*),idelay +! + real*8 t0(*),t1(*),temperature,tempgrad1,tempgrad2,amta(2,*) +! + iamplitude=0 + idelay=0 + user=.false. +! + if(nmethod.eq.3) then + write(*,*) '*ERROR in temperatures: temperature' + write(*,*) ' loading is not allowed in a linear' + write(*,*) ' buckling step; perform a static' + write(*,*) ' nonlinear calculation instead' + stop + endif +! + if(istep.lt.1) then + write(*,*) '*ERROR in temperatures: *TEMPERATURE' + write(*,*) ' should only be used within a STEP' + stop + endif +! + if(ithermal.ne.1) then + write(*,*) '*ERROR in temperatures: a *TEMPERATURE' + write(*,*) ' card is detected but no thermal' + write(*,*) ' *INITIAL CONDITIONS are given' + stop + endif +! + do i=2,n + if((textpart(i).eq.'OP=NEW').and.(.not.temp_flag)) then + do j=1,nk + t1(j)=t0(j) + enddo + elseif(textpart(i)(1:10).eq.'AMPLITUDE=') then + read(textpart(i)(11:90),'(a80)') amplitude + do j=nam,1,-1 + if(amname(j).eq.amplitude) then + iamplitude=j + exit + endif + enddo + if(j.eq.0) then + write(*,*)'*ERROR in temperatures: nonexistent amplitude' + write(*,*) ' ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + iamplitude=j + elseif(textpart(i)(1:10).eq.'TIMEDELAY=') THEN + if(idelay.ne.0) then + write(*,*) '*ERROR in temperatures: the parameter TIME' + write(*,*) ' DELAY is used twice in the same' + write(*,*) ' keyword; ' + call inputerror(inpc,ipoinpc,iline) + stop + else + idelay=1 + endif + nam=nam+1 + if(nam.gt.nam_) then + write(*,*) '*ERROR in temperatures: increase nam_' + stop + endif + amname(nam)=' + & ' + if(iamplitude.eq.0) then + write(*,*) '*ERROR in temperatures: time delay must be' + write(*,*) ' preceded by the amplitude parameter' + stop + endif + namta(3,nam)=isign(iamplitude,namta(3,iamplitude)) + iamplitude=nam + if(nam.eq.1) then + namtot=0 + else + namtot=namta(2,nam-1) + endif + namtot=namtot+1 + if(namtot.gt.namtot_) then + write(*,*) '*ERROR temperatures: increase namtot_' + stop + endif + namta(1,nam)=namtot + namta(2,nam)=namtot + read(textpart(i)(11:30),'(f20.0)',iostat=istat) + & amta(1,namtot) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:4).eq.'USER') then + user=.true. + else + write(*,*) + & '*WARNING in temperatures: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(user.and.(iamplitude.ne.0)) then + write(*,*) '*WARNING: no amplitude definition is allowed' + write(*,*) ' for temperatures defined by a' + write(*,*) ' user routine' + iamplitude=0 + endif +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + read(textpart(2)(1:20),'(f20.0)',iostat=istat) temperature + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! +! dummy temperature consisting of the first primes +! + if(user) temperature=1.2357111317d0 +! + if(inoelfree.ne.0) then + tempgrad1=0.d0 + tempgrad2=0.d0 + if(n.gt.2) then + read(textpart(3)(1:20),'(f20.0)',iostat=istat) tempgrad1 + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + endif + if(n.gt.3) then + read(textpart(4)(1:20),'(f20.0)',iostat=istat) tempgrad2 + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + endif + endif +! + read(textpart(1)(1:10),'(i10)',iostat=istat) l + if(istat.eq.0) then + if(l.gt.nk) then + write(*,*) '*WARNING in temperatures: node ',l + write(*,*) ' exceeds the largest defined ', + & 'node number' + cycle + endif + t1(l)=temperature + if(nam.gt.0) iamt1(l)=iamplitude + if(inoelfree.ne.0) then + t1(nk_+l)=tempgrad1 + t1(2*nk_+l)=tempgrad2 + endif + else + read(textpart(1)(1:80),'(a80)',iostat=istat) noset + noset(81:81)=' ' + ipos=index(noset,' ') + noset(ipos:ipos)='N' + do i=1,nset + if(set(i).eq.noset) exit + enddo + if(i.gt.nset) then + noset(ipos:ipos)=' ' + write(*,*) '*ERROR in temperatures: node set ',noset + write(*,*) ' has not yet been defined. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + t1(ialset(j))=temperature + if(nam.gt.0) iamt1(ialset(j))=iamplitude + if(inoelfree.ne.0) then + t1(nk_+ialset(j))=tempgrad1 + t1(2*nk_+ialset(j))=tempgrad2 + endif + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + t1(k)=temperature + if(nam.gt.0) iamt1(k)=iamplitude + if(inoelfree.ne.0) then + t1(nk_+k)=tempgrad1 + t1(2*nk_+k)=tempgrad2 + endif + enddo + endif + enddo + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/temploaddiff.f calculix-ccx-2.3/ccx_2.3/src/temploaddiff.f --- calculix-ccx-2.1/ccx_2.3/src/temploaddiff.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/temploaddiff.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,414 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine temploaddiff(xforcold,xforc,xforcact,iamforc,nforc, + & xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, + & xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk, + & amta,namta,nam,ampli,time,reltime,ttime,dtime,ithermal,nmethod, + & xbounold,xboun,xbounact,iamboun,nboun, + & nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, + & co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload,mi, + & xforcdiff,xloaddiff,xbodydiff,t1diff,xboundiff,iabsload, + & iprescribedboundary,ntrans,trab,inotr,veold,nactdof,bcont) +! +! calculates the loading at a given time and the difference with +! the last call of temploaddiff: is needed in the modal dynamic +! procedure (dyna.c, dynacont.c; speeds up the calculation) +! + implicit none +! + logical gasnode +! + character*20 sideload(*) + character*80 amname(*) +! + integer iamforc(*),iamload(2,*),iamt1(*),nelemload(2,*), + & nam,i,istart,iend,id,nforc,nload,nk,namta(3,*),ithermal, + & nmethod,iamt1i,iamboun(*),nboun,iamforci,iambouni, + & iamloadi1,iamloadi2,ibody(3,*),itg(*),ntg,idof, + & nbody,iambodyi,nodeboun(*),ndirboun(*),nodeforc(2,*), + & ndirforc(*),istep,iinc,msecpt,node,j,ikboun(*),ilboun(*), + & ipresboun,mi(2),iabsload,iprescribedboundary,ntrans,inotr(2,*), + & nactdof(0:mi(2),*) +! + real*8 xforc(*),xforcact(*),xload(2,*),xloadact(2,*), + & t1(*),t1act(*),amta(2,*),ampli(*),time,xforcdiff(*), + & xforcold(*),xloadold(2,*),t1old(*),reltime,xloaddiff(2,*), + & xbounold(*),xboun(*),xbounact(*),ttime,dtime,reftime, + & xbody(7,*),xbodyold(7,*),xbodydiff(7,*),t1diff(*), + & xbodyact(7,*),co(3,*),vold(0:mi(2),*),abqtime(2),coords(3), + & xboundiff(*),trab(7,*), veold(0:mi(2),*),bcont(*) +! + data msecpt /1/ +! +! if an amplitude is active, the loading is scaled according to +! the actual time. If no amplitude is active, then the load is +! - scaled according to the relative time for a static step +! - applied as a step loading for a dynamic step +! +! calculating all amplitude values for the current time +! + do i=1,nam + if(namta(3,i).lt.0) then + reftime=ttime+dtime + else + reftime=time + endif + if(abs(namta(3,i)).ne.i) then + reftime=reftime-amta(1,namta(1,i)) + istart=namta(1,abs(namta(3,i))) + iend=namta(2,abs(namta(3,i))) + if(istart.eq.0) then + call uamplitude(reftime,amname(namta(3,i)),ampli(i)) + cycle + endif + else + istart=namta(1,i) + iend=namta(2,i) + if(istart.eq.0) then + call uamplitude(reftime,amname(i),ampli(i)) + cycle + endif + endif + call identamta(amta,reftime,istart,iend,id) + if(id.lt.istart) then + ampli(i)=amta(2,istart) + elseif(id.eq.iend) then + ampli(i)=amta(2,iend) + else + ampli(i)=amta(2,id)+(amta(2,id+1)-amta(2,id)) + & *(reftime-amta(1,id))/(amta(1,id+1)-amta(1,id)) + endif + enddo +! +! scaling the boundary conditions +! + if(iprescribedboundary.eq.1) then + do i=1,nboun + if((xboun(i).lt.1.2357111318d0).and. + & (xboun(i).gt.1.2357111316d0)) then +! +! user subroutine for boundary conditions +! + node=nodeboun(i) +! +! check whether node is a gasnode +! + gasnode=.false. + call nident(itg,node,ntg,id) + if(id.gt.0) then + if(itg(id).eq.node) then + gasnode=.true. + endif + endif +! + abqtime(1)=time + abqtime(2)=ttime+dtime +! +! a gasnode cannot move (displacement DOFs are used +! for other purposes, e.g. mass flow and pressure) +! + if(gasnode) then + do j=1,3 + coords(j)=co(j,node) + enddo + else + do j=1,3 + coords(j)=co(j,node)+vold(j,node) + enddo + endif +! + if(iabsload.eq.0) then + xboundiff(i)=xbounact(i) + else + xboundiff(i)=xbounact(i)-xboundiff(i) + endif + if(ndirboun(i).eq.0) then + call utemp(xbounact(i),msecpt,istep,iinc,abqtime,node, + & coords,vold,mi) + else + call uboun(xbounact(i),istep,iinc,abqtime,node, + & ndirboun(i),coords,vold,mi) + endif + xboundiff(i)=xbounact(i)-xboundiff(i) + cycle + endif +! + if(nam.gt.0) then + iambouni=iamboun(i) + else + iambouni=0 + endif +! + if(iabsload.eq.0) then + xboundiff(i)=xbounact(i) + else + xboundiff(i)=xbounact(i)-xboundiff(i) + endif + if(iambouni.gt.0) then + xbounact(i)=xboun(i)*ampli(iambouni) + elseif(nmethod.eq.1) then + xbounact(i)=xbounold(i)+ + & (xboun(i)-xbounold(i))*reltime + else + xbounact(i)=xboun(i) + endif + xboundiff(i)=xbounact(i)-xboundiff(i) + enddo + endif +! +! scaling the loading +! + do i=1,nforc + if(ndirforc(i).eq.0) then + if((xforc(i).lt.1.2357111318d0).and. + & (xforc(i).gt.1.2357111316d0)) then + iabsload=2 +! +! user subroutine for the concentrated heat flux +! + node=nodeforc(1,i) +! +! check whether node is a gasnode +! + gasnode=.false. + call nident(itg,node,ntg,id) + if(id.gt.0) then + if(itg(id).eq.node) then + gasnode=.true. + endif + endif +! + abqtime(1)=time + abqtime(2)=ttime+dtime +! +! a gasnode cannot move (displacement DOFs are used +! for other purposes, e.g. mass flow and pressure) +! + if(gasnode) then + do j=1,3 + coords(j)=co(j,node) + enddo + else + do j=1,3 + coords(j)=co(j,node)+vold(j,node) + enddo + endif +! + if(iabsload.eq.0) then + xforcdiff(i)=xforcact(i) + else + xforcdiff(i)=xforcact(i)-xforcdiff(i) + endif + call cflux(xforcact(i),msecpt,istep,iinc,abqtime,node, + & coords,vold,mi) + xforcdiff(i)=xforcact(i)-xforcdiff(i) + cycle + endif + else + if((xforc(i).lt.1.2357111318d0).and. + & (xforc(i).gt.1.2357111316d0)) then + iabsload=2 +! +! user subroutine for the concentrated force +! + node=nodeforc(1,i) +! + abqtime(1)=time + abqtime(2)=ttime+dtime +! + do j=1,3 + coords(j)=co(j,node)+vold(j,node) + enddo +! + if(iabsload.eq.0) then + xforcdiff(i)=xforcact(i) + else + xforcdiff(i)=xforcact(i)-xforcdiff(i) + endif + call cload(xforcact(i),istep,iinc,abqtime,node, + & ndirforc(i),coords,vold,mi,ntrans,trab,inotr,veold, + & nmethod,nactdof,bcont) + xforcdiff(i)=xforcact(i)-xforcdiff(i) + cycle + endif + endif + if(nam.gt.0) then + iamforci=iamforc(i) + else + iamforci=0 + endif +! + if(iabsload.eq.0) then + xforcdiff(i)=xforcact(i) + else + xforcdiff(i)=xforcact(i)-xforcdiff(i) + endif + if(iamforci.gt.0) then + xforcact(i)=xforc(i)*ampli(iamforci) + elseif(nmethod.eq.1) then + xforcact(i)=xforcold(i)+ + & (xforc(i)-xforcold(i))*reltime + else + xforcact(i)=xforc(i) + endif + xforcdiff(i)=xforcact(i)-xforcdiff(i) + enddo +! + do i=1,nload +! +! check for dload subroutine +! + if(sideload(i)(3:4).eq.'NU') then + iabsload=2 + cycle + endif +! + ipresboun=0 +! +! check for pressure boundary conditions +! + if(sideload(i)(3:4).eq.'NP') then + node=nelemload(2,i) + idof=8*(node-1)+2 + call nident(ikboun,idof,nboun,id) + if(id.gt.0) then + if(ikboun(id).eq.idof) then + ipresboun=1 + if(iabsload.eq.0) then + xloaddiff(1,i)=xloadact(1,i) + else + xloaddiff(1,i)=xloadact(1,i)-xloaddiff(1,i) + endif + xloadact(1,i)=xbounact(ilboun(id)) + xloaddiff(1,i)=xloadact(1,i)-xloaddiff(1,i) + endif + endif + endif +! + if(ipresboun.eq.0) then + if(nam.gt.0) then + iamloadi1=iamload(1,i) + iamloadi2=iamload(2,i) + else + iamloadi1=0 + iamloadi2=0 + endif +! + if(iabsload.eq.0) then + xloaddiff(1,i)=xloadact(1,i) + else + xloaddiff(1,i)=xloadact(1,i)-xloaddiff(1,i) + endif + if(iamloadi1.gt.0) then + xloadact(1,i)=xload(1,i)*ampli(iamloadi1) + elseif(nmethod.eq.1) then + xloadact(1,i)=xloadold(1,i)+ + & (xload(1,i)-xloadold(1,i))*reltime + else + xloadact(1,i)=xload(1,i) + endif + xloaddiff(1,i)=xloadact(1,i)-xloaddiff(1,i) +! + if(iabsload.eq.0) then + xloaddiff(2,i)=xloadact(1,i) + else + xloaddiff(2,i)=xloadact(2,i)-xloaddiff(2,i) + endif + if(iamloadi2.gt.0) then + xloadact(2,i)=xload(2,i)*ampli(iamloadi2) + elseif(nmethod.eq.1) then + xloadact(2,i)=xload(2,i) + else + xloadact(2,i)=xload(2,i) + endif + xloaddiff(2,i)=xloadact(2,i)-xloaddiff(2,i) + endif + enddo +! + do i=1,nbody + if(nam.gt.0) then + iambodyi=ibody(2,i) + else + iambodyi=0 + endif +! + if(iabsload.eq.0) then + xbodydiff(1,i)=xbodyact(1,i) + else + xbodydiff(1,i)=xbodyact(1,i)-xbodydiff(1,i) + endif + if(iambodyi.gt.0) then + xbodyact(1,i)=xbody(1,i)*ampli(iambodyi) + elseif(nmethod.eq.1) then + xbodyact(1,i)=xbodyold(1,i)+ + & (xbody(1,i)-xbodyold(1,i))*reltime + else + xbodyact(1,i)=xbody(1,i) + endif + xbodydiff(1,i)=xbodyact(1,i)-xbodydiff(1,i) + enddo +! +! scaling the temperatures +! set inactive for modal dynamics calculations +! +c if(ithermal.eq.1) then +c do i=1,nk +c if((t1(i).lt.1.2357111318d0).and. +c & (t1(i).gt.1.2357111316d0)) then +c! +c abqtime(1)=time +c abqtime(2)=ttime+dtime +c! +c do j=1,3 +c coords(j)=co(j,i)+vold(j,i) +c enddo +c if(iabsload.eq.0) then +c t1diff(i)=t1act(i) +c else +c t1diff(i)=t1act(i)-t1diff(i) +c endif +c call utemp(t1act(i),msecpt,istep,iinc,abqtime,i, +c & coords,vold,mi) +c t1diff(i)=t1act(i)-t1diff(i) +c cycle +c endif +c if(nam.gt.0) then +c iamt1i=iamt1(i) +c else +c iamt1i=0 +c endif +c! +c if(iabsload.eq.0) then +c t1diff(i)=t1act(i) +c else +c t1diff(i)=t1act(i)-t1diff(i) +c endif +c if(iamt1i.gt.0) then +c t1act(i)=t1(i)*ampli(iamt1i) +c elseif(nmethod.eq.1) then +c t1act(i)=t1old(i)+(t1(i)-t1old(i))*reltime +c else +c t1act(i)=t1(i) +c endif +c t1diff(i)=t1act(i)-t1diff(i) +c enddo +c endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/tempload.f calculix-ccx-2.3/ccx_2.3/src/tempload.f --- calculix-ccx-2.1/ccx_2.3/src/tempload.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/tempload.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,337 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine tempload(xforcold,xforc,xforcact,iamforc,nforc, + & xloadold,xload,xloadact,iamload,nload,ibody,xbody,nbody, + & xbodyold,xbodyact,t1old,t1,t1act,iamt1,nk, + & amta,namta,nam,ampli,time,reltime,ttime,dtime,ithermal,nmethod, + & xbounold,xboun,xbounact,iamboun,nboun, + & nodeboun,ndirboun,nodeforc,ndirforc,istep,iinc, + & co,vold,itg,ntg,amname,ikboun,ilboun,nelemload,sideload,mi, + & ntrans,trab,inotr,veold) +! +! calculates the loading at a given time +! + implicit none +! + logical gasnode +! + character*20 sideload(*) + character*80 amname(*) +! + integer iamforc(*),iamload(2,*),iamt1(*),nelemload(2,*), + & nam,i,istart,iend,id,nforc,nload,nk,namta(3,*),ithermal, + & nmethod,iamt1i,iamboun(*),nboun,iamforci,iambouni, + & iamloadi1,iamloadi2,ibody(3,*),itg(*),ntg,idof, + & nbody,iambodyi,nodeboun(*),ndirboun(*),nodeforc(2,*), + & ndirforc(*),istep,iinc,msecpt,node,j,ikboun(*),ilboun(*), + & ipresboun,mi(2),ntrans,inotr(2,*),idummy +! + real*8 xforc(*),xforcact(*),xload(2,*),xloadact(2,*), + & t1(*),t1act(*),amta(2,*),ampli(*),time, + & xforcold(*),xloadold(2,*),t1old(*),reltime, + & xbounold(*),xboun(*),xbounact(*),ttime,dtime,reftime, + & xbody(7,*),xbodyold(7,*),xbodyact(7,*),co(3,*), + & vold(0:mi(2),*),abqtime(2),coords(3),trab(7,*), + & veold(0:mi(2),*),ddummy +! + data msecpt /1/ +! +! if an amplitude is active, the loading is scaled according to +! the actual time. If no amplitude is active, then the load is +! - scaled according to the relative time for a static step +! - applied as a step loading for a dynamic step +! +! calculating all amplitude values for the current time +! + do i=1,nam + if(namta(3,i).lt.0) then + reftime=ttime+dtime + else + reftime=time + endif + if(abs(namta(3,i)).ne.i) then + reftime=reftime-amta(1,namta(1,i)) + istart=namta(1,abs(namta(3,i))) + iend=namta(2,abs(namta(3,i))) + if(istart.eq.0) then + call uamplitude(reftime,amname(namta(3,i)),ampli(i)) + cycle + endif + else + istart=namta(1,i) + iend=namta(2,i) + if(istart.eq.0) then + call uamplitude(reftime,amname(i),ampli(i)) + cycle + endif + endif + call identamta(amta,reftime,istart,iend,id) + if(id.lt.istart) then + ampli(i)=amta(2,istart) + elseif(id.eq.iend) then + ampli(i)=amta(2,iend) + else + ampli(i)=amta(2,id)+(amta(2,id+1)-amta(2,id)) + & *(reftime-amta(1,id))/(amta(1,id+1)-amta(1,id)) + endif + enddo +! +! scaling the boundary conditions +! + do i=1,nboun + if((xboun(i).lt.1.2357111318d0).and. + & (xboun(i).gt.1.2357111316d0)) then +! +! user subroutine for boundary conditions +! + node=nodeboun(i) +! +! check whether node is a gasnode +! + gasnode=.false. + call nident(itg,node,ntg,id) + if(id.gt.0) then + if(itg(id).eq.node) then + gasnode=.true. + endif + endif +! + abqtime(1)=time + abqtime(2)=ttime+dtime +! +! a gasnode cannot move (displacement DOFs are used +! for other purposes, e.g. mass flow and pressure) +! + if(gasnode) then + do j=1,3 + coords(j)=co(j,node) + enddo + else + do j=1,3 + coords(j)=co(j,node)+vold(j,node) + enddo + endif +! + if(ndirboun(i).eq.0) then + call utemp(xbounact(i),msecpt,istep,iinc,abqtime,node, + & coords,vold,mi) + else + call uboun(xbounact(i),istep,iinc,abqtime,node, + & ndirboun(i),coords,vold,mi) + endif + cycle + endif +! + if(nam.gt.0) then + iambouni=iamboun(i) + else + iambouni=0 + endif + if(iambouni.gt.0) then + xbounact(i)=xboun(i)*ampli(iambouni) + elseif(nmethod.eq.1) then + xbounact(i)=xbounold(i)+ + & (xboun(i)-xbounold(i))*reltime + else + xbounact(i)=xboun(i) + endif + enddo +! +! scaling the loading +! + do i=1,nforc + if(ndirforc(i).eq.0) then + if((xforc(i).lt.1.2357111318d0).and. + & (xforc(i).gt.1.2357111316d0)) then +! +! user subroutine for the concentrated heat flux +! + node=nodeforc(1,i) +! +! check whether node is a gasnode +! + gasnode=.false. + call nident(itg,node,ntg,id) + if(id.gt.0) then + if(itg(id).eq.node) then + gasnode=.true. + endif + endif +! + abqtime(1)=time + abqtime(2)=ttime+dtime +! +! a gasnode cannot move (displacement DOFs are used +! for other purposes, e.g. mass flow and pressure) +! + if(gasnode) then + do j=1,3 + coords(j)=co(j,node) + enddo + else + do j=1,3 + coords(j)=co(j,node)+vold(j,node) + enddo + endif +! + call cflux(xforcact(i),msecpt,istep,iinc,abqtime,node, + & coords,vold,mi) + cycle + endif + else + if((xforc(i).lt.1.2357111318d0).and. + & (xforc(i).gt.1.2357111316d0)) then +! +! user subroutine for the concentrated load +! + node=nodeforc(1,i) +! + abqtime(1)=time + abqtime(2)=ttime+dtime +! + do j=1,3 + coords(j)=co(j,node)+vold(j,node) + enddo +! + call cload(xforcact(i),istep,iinc,abqtime,node, + & ndirforc(i),coords,vold,mi,ntrans,trab,inotr,veold, + & nmethod,idummy,ddummy) + cycle + endif + endif + if(nam.gt.0) then + iamforci=iamforc(i) + else + iamforci=0 + endif + if(iamforci.gt.0) then + xforcact(i)=xforc(i)*ampli(iamforci) + elseif(nmethod.eq.1) then + xforcact(i)=xforcold(i)+ + & (xforc(i)-xforcold(i))*reltime + else + xforcact(i)=xforc(i) + endif + enddo +! + do i=1,nload + ipresboun=0 +! +! check for pressure boundary conditions +! + if(sideload(i)(3:4).eq.'NP') then + node=nelemload(2,i) + idof=8*(node-1)+2 + call nident(ikboun,idof,nboun,id) + if(id.gt.0) then + if(ikboun(id).eq.idof) then + ipresboun=1 + xloadact(1,i)=xbounact(ilboun(id)) + endif + endif + endif +! + if(ipresboun.eq.0) then + if(nam.gt.0) then + iamloadi1=iamload(1,i) + iamloadi2=iamload(2,i) + else + iamloadi1=0 + iamloadi2=0 + endif + if(iamloadi1.gt.0) then + xloadact(1,i)=xload(1,i)*ampli(iamloadi1) + elseif(nmethod.eq.1) then + xloadact(1,i)=xloadold(1,i)+ + & (xload(1,i)-xloadold(1,i))*reltime + else + xloadact(1,i)=xload(1,i) + endif + if(iamloadi2.gt.0) then + xloadact(2,i)=xload(2,i)*ampli(iamloadi2) + elseif(nmethod.eq.1) then + xloadact(2,i)=xload(2,i) + else + xloadact(2,i)=xload(2,i) + endif + endif + enddo +! + do i=1,nbody + if(nam.gt.0) then + iambodyi=ibody(2,i) + else + iambodyi=0 + endif + if(iambodyi.gt.0) then + xbodyact(1,i)=xbody(1,i)*ampli(iambodyi) + elseif(nmethod.eq.1) then + xbodyact(1,i)=xbodyold(1,i)+ + & (xbody(1,i)-xbodyold(1,i))*reltime + else + xbodyact(1,i)=xbody(1,i) + endif + enddo +! +! scaling the temperatures +! + if(ithermal.eq.1) then + do i=1,nk + if((t1(i).lt.1.2357111318d0).and. + & (t1(i).gt.1.2357111316d0)) then +! + abqtime(1)=time + abqtime(2)=ttime+dtime +! + do j=1,3 + coords(j)=co(j,i)+vold(j,i) + enddo + call utemp(t1act(i),msecpt,istep,iinc,abqtime,i, + & coords,vold,mi) + cycle + endif + if(nam.gt.0) then + iamt1i=iamt1(i) + else + iamt1i=0 + endif + if(iamt1i.gt.0) then + t1act(i)=t1(i)*ampli(iamt1i) + elseif(nmethod.eq.1) then + t1act(i)=t1old(i)+(t1(i)-t1old(i))*reltime + else + t1act(i)=t1(i) + endif + enddo + endif +c write(*,*) 'nboun' +c do i=1,nboun +c write(*,'(i7,1x,e11.4,1x,e11.4)') i,xbounact(i),xboun(i) +c enddo +c write(*,*) 'nforc' +c do i=1,nforc +c write(*,'(i7,1x,e11.4,1x,e11.4)') i,xforcact(i),xforc(i) +c enddo +c write(*,*) 'nload' +c do i=1,nload +c write(*,'(i7,1x,e11.4,1x,e11.4)') i,xloadact(1,i),xload(1,i) +c enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/temploadmodal.f calculix-ccx-2.3/ccx_2.3/src/temploadmodal.f --- calculix-ccx-2.1/ccx_2.3/src/temploadmodal.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/temploadmodal.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,92 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine temploadmodal(amta,namta,nam,ampli,time,ttime,dtime, + & xbounold,xboun,xbounact,iamboun,nboun,nodeboun,ndirboun, + & amname) +! +! calculates the SPC boundary conditions at a given time for +! a modal dynamic procedure; used to calculate the velocity and +! acceleration by use of finite differences +! + implicit none +! + character*80 amname(*) +! + integer nam,i,istart,iend,id,namta(3,*), + & iamboun(*),nboun,iambouni,nodeboun(*),ndirboun(*) +! + real*8 amta(2,*),ampli(*),time, + & xbounold(*),xboun(*),xbounact(*),ttime,dtime,reftime +! +! if an amplitude is active, the loading is scaled according to +! the actual time. If no amplitude is active, then the load is +! applied as a step loading +! +! calculating all amplitude values for the current time +! + do i=1,nam + if(namta(3,i).lt.0) then + reftime=ttime+dtime + else + reftime=time + endif + if(abs(namta(3,i)).ne.i) then + reftime=reftime-amta(1,namta(1,i)) + istart=namta(1,abs(namta(3,i))) + iend=namta(2,abs(namta(3,i))) + if(istart.eq.0) then + call uamplitude(reftime,amname(namta(3,i)),ampli(i)) + cycle + endif + else + istart=namta(1,i) + iend=namta(2,i) + if(istart.eq.0) then + call uamplitude(reftime,amname(i),ampli(i)) + cycle + endif + endif + call identamta(amta,reftime,istart,iend,id) + if(id.lt.istart) then + ampli(i)=amta(2,istart) + elseif(id.eq.iend) then + ampli(i)=amta(2,iend) + else + ampli(i)=amta(2,id)+(amta(2,id+1)-amta(2,id)) + & *(reftime-amta(1,id))/(amta(1,id+1)-amta(1,id)) + endif + enddo +! +! scaling the boundary conditions +! + do i=1,nboun + if(nam.gt.0) then + iambouni=iamboun(i) + else + iambouni=0 + endif + if(iambouni.gt.0) then + xbounact(i)=xboun(i)*ampli(iambouni) + else + xbounact(i)=xboun(i) + endif + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/thermmodel.f calculix-ccx-2.3/ccx_2.3/src/thermmodel.f --- calculix-ccx-2.1/ccx_2.3/src/thermmodel.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/thermmodel.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,164 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine thermmodel(amat,iel,iint,kode,coconloc,vkl, + & dtime,time,ttime,mi,nstate_,xstateini,xstate,qflux,xstiff, + & iorien,pgauss,orab,t1l,t1lold,vold,co,lakonl,konl, + & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc) +! + character*8 lakonl + character*80 amat +! + integer iel,iint,kode,mi(2),nstate_,iorien,ntgrd,ncoconst, + & layer,kspt,kstep,kinc,kal(2,6),konl(20),ipompc(*), + & nodempc(3,*),nmpc,ikmpc(*),ilmpc(*) +! + real*8 coconloc(*),vkl(0:3,3),dtime,time,ttime,cond(6), + & xstateini(nstate_,mi(1),*),xstate(nstate_,mi(1),*),qflux(3), + & pgauss(3),orab(7,*),abqtime(2),u,dudt,dudg(3),dfdt(3), + & dfdg(3,3),dtemp,dtemdx(3),predef(1),dpred(1),pnewdt, + & skl(3,3),t1lold,xstiff(27,mi(1),*),xa(3,3),vold(0:mi(2),*), + & co(3,*),coefmpc(*) +! + data kal /1,1,2,2,3,3,1,2,1,3,2,3/ +! + if(kode.eq.1) then +! +! linear isotropic +! + do i=1,3 + cond(i)=coconloc(1) + enddo + do i=4,6 + cond(i)=0.d0 + enddo +! + do i=1,3 + qflux(i)=-coconloc(1)*vkl(0,i) + enddo +! + elseif((kode.eq.3).or.(kode.eq.6)) then + if((kode.eq.3).and.(iorien.eq.0)) then +! +! orthotropic +! + do i=1,3 + cond(i)=coconloc(i) + enddo + do i=4,6 + cond(i)=0.d0 + enddo +! + do i=1,3 + qflux(i)=-coconloc(i)*vkl(0,i) + enddo +! + else + if(iorien.ne.0) then +! +! transformation due to special orientation +! +! calculating the transformation matrix +! + call transformatrix(orab(1,iorien),pgauss,skl) +! +! modifying the conductivity constants +! + if(kode.eq.3) then + do j=4,6 + coconloc(j)=0.d0 + enddo + endif +! + xa(1,1)=coconloc(1) + xa(1,2)=coconloc(4) + xa(1,3)=coconloc(5) + xa(2,1)=coconloc(4) + xa(2,2)=coconloc(2) + xa(2,3)=coconloc(6) + xa(3,1)=coconloc(5) + xa(3,2)=coconloc(6) + xa(3,3)=coconloc(3) +! + do jj=1,6 + coconloc(jj)=0.d0 + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + coconloc(jj)=coconloc(jj)+ + & xa(j3,j4)*skl(j1,j3)*skl(j2,j4) + enddo + enddo + enddo + endif +! +! anisotropy +! + do i=1,6 + cond(i)=coconloc(i) + enddo +! + qflux(1)=-coconloc(1)*vkl(0,1)-coconloc(4)*vkl(0,2)- + & coconloc(5)*vkl(0,3) + qflux(2)=-coconloc(4)*vkl(0,1)-coconloc(2)*vkl(0,2)- + & coconloc(6)*vkl(0,3) + qflux(3)=-coconloc(5)*vkl(0,1)-coconloc(6)*vkl(0,2)- + & coconloc(3)*vkl(0,3) +! + endif + else +! +! user material +! + ncoconst=-kode-100 +! + do i=1,nstate_ + xstate(i,iint,iel)=xstateini(i,iint,iel) + enddo +! + abqtime(1)=time-dtime + abqtime(2)=ttime-dtime +! + ntgrd=3 + dtemp=t1l-t1lold + do i=1,3 + dtemdx(i)=vkl(0,i) + enddo +! + call umatht(u,dudt,dudg,qflux,dfdt,dfdg,xstate,t1lold,dtemp, + & dtemdx,abqtime,dtime,predef,dpred,amat,ntgrd,nstate_, + & coconloc,ncoconst,pgauss,pnewdt,iel,iint,layer,kspt, + & kstep,kinc,vold,co,lakonl,konl, + & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,mi) +! + cond(1)=dfdg(1,1) + cond(2)=dfdg(2,2) + cond(3)=dfdg(3,3) + cond(4)=dfdg(1,2) + cond(5)=dfdg(1,3) + cond(6)=dfdg(2,3) +! + endif +! + do i=1,6 + xstiff(21+i,iint,iel)=cond(i) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/tiedcontact.c calculix-ccx-2.3/ccx_2.3/src/tiedcontact.c --- calculix-ccx-2.1/ccx_2.3/src/tiedcontact.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/tiedcontact.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,202 @@ +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +#include +#include "CalculiX.h" + +void tiedcontact(int *ntie, char *tieset, int *nset, char *set, + int *istartset, int *iendset, int *ialset, + char *lakon, int *ipkon, int *kon, + double *tietol, + int *nmpc, int *mpcfree, int *memmpc_, + int **ipompcp, char **labmpcp, int **ikmpcp, int **ilmpcp, + double **fmpcp, int **nodempcp, double **coefmpcp, + int *ithermal, double *co, double *vold, int *cfd, + int *nmpc_, int *mi, int *nk){ + + char kind1[2]="T",kind2[2]="T",*labmpc=NULL; + + int *itietri=NULL,*koncont=NULL,nconf,i,k,*nx=NULL,im, + *ny=NULL,*nz=NULL,*ifaceslave=NULL,*istartfield=NULL, + *iendfield=NULL,*ifield=NULL,ntrimax,index, + ncont,ncone,*ipompc=NULL,*ikmpc=NULL, + *ilmpc=NULL,*nodempc=NULL,ismallsliding=0,neq,neqterms, + nmpctied,mortar=0,*ipe=NULL,*ime=NULL,*imastop=NULL,ifreeme; + + double *xo=NULL,*yo=NULL,*zo=NULL,*x=NULL,*y=NULL,*z=NULL, + *cg=NULL,*straight=NULL,*fmpc=NULL,*coefmpc=NULL; + + ipompc=*ipompcp;labmpc=*labmpcp;ikmpc=*ikmpcp;ilmpc=*ilmpcp; + fmpc=*fmpcp;nodempc=*nodempcp;coefmpc=*coefmpcp; + + /* identifying the slave surfaces as nodal or facial surfaces */ + + ifaceslave=NNEW(int,*ntie); + + FORTRAN(identifytiedface,(tieset,ntie,set,nset,ifaceslave)); + + /* determining the number of triangles of the triangulation + of the master surface and the number of entities on the + slave side */ + + FORTRAN(allocont,(&ncont,ntie,tieset,nset,set,istartset,iendset, + ialset,lakon,&ncone,tietol,&ismallsliding,kind1, + kind2,&mortar)); + + if(ncont==0) return; + + /* allocation of space for the triangulation; + koncont(1..3,i): nodes belonging to triangle i + koncont(4,i): face label to which the triangle belongs = + 10*element+side number */ + + itietri=NNEW(int,2**ntie); + koncont=NNEW(int,4*ncont); + + /* triangulation of the master surface */ + + FORTRAN(triangucont,(&ncont,ntie,tieset,nset,set,istartset,iendset, + ialset,itietri,lakon,ipkon,kon,koncont,kind1,kind2)); + + /* catalogueing the neighbors of the master triangles */ + + RENEW(ipe,int,*nk); + RENEW(ime,int,12*ncont); + DMEMSET(ipe,0,*nk,0.); + DMEMSET(ime,0,12*ncont,0.); + imastop=NNEW(int,3*ncont); + + FORTRAN(trianeighbor,(ipe,ime,imastop,&ncont,koncont, + &ifreeme)); + + free(ipe);free(ime); + + /* allocation of space for the center of gravity of the triangles + and the 4 describing planes */ + + cg=NNEW(double,3*ncont); + straight=NNEW(double,16*ncont); + + FORTRAN(updatecont,(koncont,&ncont,co,vold,cg,straight,mi)); + + /* determining the nodes belonging to the slave face surfaces */ + + istartfield=NNEW(int,*ntie); + iendfield=NNEW(int,*ntie); + ifield=NNEW(int,8*ncone); + + FORTRAN(nodestiedface,(tieset,ntie,ipkon,kon, + lakon,set,istartset,iendset,ialset, + nset,ifaceslave,istartfield,iendfield,ifield,&nconf,&ncone)); + + /* determining the maximum number of equations neq */ + + if(*cfd==1){ + if(ithermal[1]<=1){ + neq=4; + }else{ + neq=5; + } + }else{ + if(ithermal[1]<=1){ + neq=3; + }else if(ithermal[1]==2){ + neq=1; + }else{ + neq=4; + } + } + neq*=(ncone+nconf); + + /* reallocating the MPC fields for the new MPC's + ncone: number of MPC'S due to nodal slave surfaces + nconf: number of MPC's due to facal slave surfaces */ + + RENEW(ipompc,int,*nmpc_+neq); + RENEW(labmpc,char,20*(*nmpc_+neq)+1); + RENEW(ikmpc,int,*nmpc_+neq); + RENEW(ilmpc,int,*nmpc_+neq); + RENEW(fmpc,double,*nmpc_+neq); + + /* determining the maximum number of terms; + expanding nodempc and coefmpc to accommodate + those terms */ + + neqterms=9*neq; + index=*memmpc_; + (*memmpc_)+=neqterms; + RENEW(nodempc,int,3**memmpc_); + RENEW(coefmpc,double,*memmpc_); + for(k=index;k<*memmpc_;k++){ + nodempc[3*k-1]=k+1; + } + nodempc[3**memmpc_-1]=0; + + /* determining the size of the auxiliary fields */ + + ntrimax=0; + for(i=0;i<*ntie;i++){ + if(itietri[2*i+1]-itietri[2*i]+1>ntrimax) + ntrimax=itietri[2*i+1]-itietri[2*i]+1; + } + xo=NNEW(double,ntrimax); + yo=NNEW(double,ntrimax); + zo=NNEW(double,ntrimax); + x=NNEW(double,ntrimax); + y=NNEW(double,ntrimax); + z=NNEW(double,ntrimax); + nx=NNEW(int,ntrimax); + ny=NNEW(int,ntrimax); + nz=NNEW(int,ntrimax); + + /* generating the tie MPC's */ + + FORTRAN(gentiedmpc,(tieset,ntie,itietri,ipkon,kon, + lakon,set,istartset,iendset,ialset,cg,straight, + koncont,co,xo,yo,zo,x,y,z,nx,ny,nz,nset, + ifaceslave,istartfield,iendfield,ifield, + ipompc,nodempc,coefmpc,nmpc,&nmpctied,mpcfree,ikmpc,ilmpc, + labmpc,ithermal,tietol,cfd,&ncont,imastop)); + + (*nmpc_)+=nmpctied; + + free(xo);free(yo);free(zo);free(x);free(y);free(z);free(nx); + free(ny);free(nz);free(imastop); + + free(ifaceslave);free(istartfield);free(iendfield);free(ifield); + free(itietri);free(koncont);free(cg);free(straight); + + /* reallocating the MPC fields */ + + /* RENEW(ipompc,int,nmpc_); + RENEW(labmpc,char,20*nmpc_+1); + RENEW(ikmpc,int,nmpc_); + RENEW(ilmpc,int,nmpc_); + RENEW(fmpc,double,nmpc_);*/ + + *ipompcp=ipompc;*labmpcp=labmpc;*ikmpcp=ikmpc;*ilmpcp=ilmpc; + *fmpcp=fmpc;*nodempcp=nodempc;*coefmpcp=coefmpc; + + /* for(i=0;i<*nmpc;i++){ + j=i+1; + FORTRAN(writempc,(ipompc,nodempc,coefmpc,labmpc,&j)); + }*/ + + return; +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/tiefaccont.f calculix-ccx-2.3/ccx_2.3/src/tiefaccont.f --- calculix-ccx-2.1/ccx_2.3/src/tiefaccont.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/tiefaccont.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,473 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine tiefaccont(lakon,ipkon,kon,ntie,tieset,nset,set, + & istartset,iendset,ialset,itiefac,islavsurf,islavnode, + & imastnode,nslavnode,nmastnode,nslavs,nmasts,ifacecount, + & iponoels,inoels,ifreenoels, + & mortar,ipoface,nodface,nk) +! +! Catalogueing the slave faces (itieface, islavsurf) +! the slave nodes (islavnode, nslavnode) +! the slave faces to which the slave nodes +! belong +! the master nodes (imastnode, nmastnode; only +! for surface-to-surface contact) +! +! Authors: Li,Yang; Rakotonanahary, Samoela; +! + implicit none +! + logical nodeslavsurf +! + character*8 lakon(*) + character*81 tieset(3,*),slavset,mastset,set(*) +! + logical exist +! + integer ntie,i,j,k,l,nset,istartset(*),iendset(*),ialset(*), + & ifaces,nelems,jfaces,ifacem,nelemm,nslavs,nmasts, + & jfacem,indexe,nopes,nopem,ipkon(*),kon(*),id, + & ifaceq(8,6),ifacet(6,4),ifacew1(4,5),ifacew2(8,5),node, + & itiefac(2,*),islavsurf(2,*),islavnode(*),imastnode(*), + & nslavnode(ntie+1),nmastnode(ntie+1),ifacecount,islav,imast, + & ipos,index1,iponoels(*),inoels(3,*),ifreenoels,ifreenoelold, + & mortar,numbern,numberf,iface,kflag,nk,ipoface(*), + & nodface(5,*) +! +! nslavnode: num of slave nodes +! islavnode: all slave nodes, tie by tie, ordered within one tie constraint +! nmastnode: num of master nodes +! imastnode: all master nodes, tie by tie, ordered within one tie constraint +! islavsurf: all slave faces +! itiefac: pointer into field islavsurf +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! + ifacecount=0 + nslavs=0 + nmasts=0 + ifreenoels=0 +! +! counters for new fields islavsurf and itiefac +! + do i=1,ntie +! +! check for contact conditions +! + if((tieset(1,i)(81:81).eq.'C').or. + & (tieset(1,i)(81:81).eq.'-')) then + slavset=tieset(2,i) +! +! check whether facial slave surface; +! + ipos=index(slavset,' ')-1 +! +! default for node-to-surface contact is +! a nodal slave surface +! + if(slavset(ipos:ipos).eq.'S') then + nodeslavsurf=.true. + endif +! +! determining the slave surface +! + do j=1,nset + if(set(j).eq.slavset) exit + enddo + if(j.gt.nset) then + do j=1,nset + if((set(j)(1:ipos-1).eq.slavset(1:ipos-1)).and. + & (set(j)(ipos:ipos).eq.'T')) then + nodeslavsurf=.false. + exit + endif + enddo + endif +! + islav=j +! + if((mortar.eq.0).and.(nodeslavsurf)) then +! +! nodal slave surface and node-to-surface contact +! +! storing the slave nodes in islavnode (sorted) +! + nslavnode(i)=nslavs + numbern=0 + do j=istartset(islav),iendset(islav) + if(ialset(j).gt.0) then + k=ialset(j) + call nident(islavnode(nslavs+1),k,numbern,id) + if(id.gt.0) then + if(islavnode(nslavs+id).eq.k) cycle + endif + numbern=numbern+1 + do l=numbern,id+2,-1 + islavnode(nslavs+l)=islavnode(nslavs+l-1) + enddo + islavnode(nslavs+id+1)=k + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + call nident(islavnode(nslavs+1),k,numbern,id) + if(id.gt.0) then + if(islavnode(nslavs+id).eq.k) cycle + endif + numbern=numbern+1 + do l=numbern,id+2,-1 + islavnode(nslavs+l)=islavnode(nslavs+l-1) + enddo + islavnode(nslavs+id+1)=k + enddo + endif + nslavnode(i+1)=nslavnode(i)+numbern + enddo +! +! check all external solid faces whether they contain +! slave nodes +! +! islavsurf(1,*) contains the faces (ordered) +! islavsurf(2,*) contains the position of the +! original order +! + itiefac(1,i)=ifacecount+1 + numberf=0 +! + do j=1,nk + index1=ipoface(j) + do + if(index1.eq.0) exit + iface=nodface(4,index1) + do k=0,3 + if(k.eq.0) then + node=j + else + node=nodface(k,index1) + endif +! +! check whether node belongs to slave surface +! + call nident(islavnode(nslavs+1),node,numbern, + & id) + if(id.gt.0) then + if(islavnode(nslavs+id).eq.node) then + call nident2(islavsurf(1,ifacecount+1), + & iface,numberf,id) +! + ipos=0 + if(id.gt.0) then + if(islavsurf(1,ifacecount+id).eq.iface) + & then + ipos=id + endif + endif +! +! check whether new face +! + if(ipos.eq.0) then + numberf=numberf+1 + do l=ifacecount+numberf,ifacecount+id+2 + & ,-1 + islavsurf(1,l)=islavsurf(1,l-1) + islavsurf(2,l)=islavsurf(2,l-1) + enddo + islavsurf(1,ifacecount+id+1)=iface + islavsurf(2,ifacecount+id+1)=numberf + ipos=numberf + endif +! +! update info to which faces a slave node +! belongs +! +! for node-to-surface contact inoels(2,*) +! contains the number of nodes belonging to +! the face; +! + ifreenoelold=iponoels(node) + ifreenoels=ifreenoels+1 + iponoels(node)=ifreenoels + inoels(1,ifreenoels)=ifacecount+ipos + if(nodface(4,index1).eq.0) then + inoels(2,ifreenoels)=3 + else + inoels(2,ifreenoels)=4 + endif + inoels(3,ifreenoels)=ifreenoelold + endif + endif + enddo + index1=nodface(5,index1) + enddo + enddo +! +! restoring the right order of islavsurf(1,*); +! thereafter islavsurf(2,*) is obsolete for node-to-surface +! contact +! + kflag=2 + call isort2i(islavsurf(1,ifacecount+1),numberf,kflag) +! +! update ifacecount and itiefac +! + itiefac(2,i)=ifacecount+numberf +! + nslavs=nslavnode(i+1) + ifacecount=itiefac(2,i) +! + cycle + endif +! +! element face slave surface (node-to-surface or +! surface-to-surface contact) +! +c islav=j + nslavnode(i)=nslavs +! + itiefac(1,i)=ifacecount+1 + do j=istartset(islav),iendset(islav) + if(ialset(j).gt.0) then +! +! store the slave face in islavsurf +! + ifacecount=ifacecount+1 + islavsurf(1,ifacecount)=ialset(j) +! +! store the nodes belonging to the slave face +! in islavnode +! + ifaces = ialset(j) + nelems = int(ifaces/10) + jfaces = ifaces - nelems*10 + indexe = ipkon(nelems) +! + if(lakon(nelems)(4:4).eq.'2') then +c nopes=8 + nopes=4 + elseif(lakon(nelems)(4:4).eq.'8') then + nopes=4 + elseif(lakon(nelems)(4:5).eq.'10') then +c nopes=6 + nopes=3 + elseif(lakon(nelems)(4:4).eq.'4') then + nopes=3 + endif +! + if(lakon(nelems)(4:4).eq.'6') then + if(jfaces.le.2) then + nopes=3 + else + nopes=4 + endif + endif + if(lakon(nelems)(4:5).eq.'15') then + if(jfaces.le.2) then +c nopes=6 + nopes=3 + else +c nopes=8 + nopes=4 + endif + endif +! + do l=1,nopes + if((lakon(nelems)(4:4).eq.'2').or. + & (lakon(nelems)(4:4).eq.'8')) then + node=kon(indexe+ifaceq(l,jfaces)) + elseif((lakon(nelems)(4:4).eq.'4').or. + & (lakon(nelems)(4:5).eq.'10')) then + node=kon(indexe+ifacet(l,jfaces)) + elseif(lakon(nelems)(4:4).eq.'6') then + node=kon(indexe+ifacew1(l,jfaces)) + elseif(lakon(nelems)(4:5).eq.'15') then + node=kon(indexe+ifacew2(l,jfaces)) + endif + call nident(islavnode(nslavnode(i)+1),node, + & nslavs-nslavnode(i),id) + exist=.FALSE. + if(id.gt.0) then + if(islavnode(nslavnode(i)+id).eq.node) then + exist=.TRUE. + endif + endif + if(.not.exist) then + nslavs=nslavs+1 + do k=nslavs,nslavnode(i)+id+2,-1 + islavnode(k)=islavnode(k-1) + enddo + islavnode(nslavnode(i)+id+1)=node + endif +! +! filling fields iponoels and inoels +! +! for node-to-surface contact inoels(2,*) +! contains the number of nodes belonging to +! the face; +! for surface-to-surface contact inoels(2,*) +! contains the local node number +! + ifreenoelold=iponoels(node) + ifreenoels=ifreenoels+1 + iponoels(node)=ifreenoels + inoels(1,ifreenoels)=ifacecount + if(mortar.eq.1) then + inoels(2,ifreenoels)=l + else + inoels(2,ifreenoels)=nopes + endif + inoels(3,ifreenoels)=ifreenoelold + enddo +! + endif + enddo + nslavnode(ntie+1)=nslavs + itiefac(2,i)=ifacecount +c! +c! for node-to-surface contact ncone is the number of slave +c! nodes +c! + if(mortar.eq.0) then +c ncone=nslavnode(ntie+1)-nslavnode(ntie) + cycle + endif +! +! what follows is only for surface-to-surface contact +! determining the master surface +! + mastset=tieset(3,i) + do j=1,nset + if(set(j).eq.mastset) exit + enddo + if(j.gt.nset) then + write(*,*) '*ERROR in tiefaccont: master surface' + write(*,*) ' does not exist' + stop + endif + imast=j + nmastnode(i)=nmasts +! + do j=istartset(imast),iendset(imast) + if(ialset(j).gt.0) then +! +! Decide imastnode, and nmastnode +! + ifacem = ialset(j) + nelemm = int(ifacem/10) + jfacem = ifacem - nelemm*10 + indexe = ipkon(nelemm) +! + if(lakon(nelemm)(4:4).eq.'2') then + nopem=8 + elseif(lakon(nelemm)(4:4).eq.'8') then + nopem=4 + elseif(lakon(nelemm)(4:5).eq.'10') then + nopem=6 + elseif(lakon(nelemm)(4:4).eq.'4') then + nopem=3 + endif +! + if(lakon(nelemm)(4:4).eq.'6') then + if(jfacem.le.2) then + nopem=3 + else + nopem=4 + endif + endif + if(lakon(nelemm)(4:5).eq.'15') then + if(jfacem.le.2) then + nopem=6 + else + nopem=8 + endif + endif +! + do l=1,nopem + if((lakon(nelemm)(4:4).eq.'2').or. + & (lakon(nelemm)(4:4).eq.'8')) then + node=kon(indexe+ifaceq(l,jfacem)) + elseif((lakon(nelemm)(4:4).eq.'4').or. + & (lakon(nelemm)(4:5).eq.'10')) then + node=kon(indexe+ifacet(l,jfacem)) + elseif(lakon(nelemm)(4:4).eq.'6') then + node=kon(indexe+ifacew1(l,jfacem)) + elseif(lakon(nelemm)(4:5).eq.'15') then + node=kon(indexe+ifacew2(l,jfacem)) + endif + call nident(imastnode(nmastnode(i)+1),node, + & nmasts-nmastnode(i),id) + exist=.FALSE. + if(id.gt.0) then + if(imastnode(nmastnode(i)+id).eq.node) then + exist=.TRUE. + endif + endif + if(exist) cycle + nmasts=nmasts+1 + do k=nmasts,id+2,-1 + imastnode(k)=imastnode(k-1) + enddo + imastnode(id+1)=node + enddo +! + endif + enddo + nmastnode(ntie+1)=nmasts +! + else +! +! no contact tie +! + nslavnode(i+1)=nslavnode(i) + if(mortar.eq.1) nmastnode(i+1)=nmastnode(i) + endif + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/ties.f calculix-ccx-2.3/ccx_2.3/src/ties.f --- calculix-ccx-2.1/ccx_2.3/src/ties.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ties.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,131 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine ties(inpc,textpart,tieset,tietol,istep, + & istat,n,iline,ipol,inl,ipoinp,inp,ntie,ntie_,ipoinpc) +! +! reading the input deck: *TIE +! + implicit none +! + logical multistage,tied +! + character*1 inpc(*) + character*81 tieset(3,*) + character*132 textpart(16) +! + integer istep,istat,n,i,key,ipos,iline,ipol,inl,ipoinp(2,*), + & inp(3,*),ntie,ntie_,ipoinpc(0:*) +! + real*8 tietol(2,*) +! + multistage=.false. + tied=.true. +! + if(istep.gt.0) then + write(*,*) '*ERROR in ties: *TIE should' + write(*,*) ' be placed before all step definitions' + stop + endif +! + ntie=ntie+1 + if(ntie.gt.ntie_) then + write(*,*) '*ERROR in ties: increase ntie_' + stop + endif +! + tietol(1,ntie)=-1.d0 +! + do i=2,n + if(textpart(i)(1:18).eq.'POSITIONTOLERANCE=') then + read(textpart(i)(19:38),'(f20.0)',iostat=istat) + & tietol(1,ntie) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:5).eq.'NAME=') then + read(textpart(i)(6:85),'(a80)',iostat=istat) + & tieset(1,ntie)(1:80) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:14).eq.'CYCLICSYMMETRY') then + tied=.false. + elseif(textpart(i)(1:10).eq.'MULTISTAGE') then + multistage=.true. + tied=.false. + else + write(*,*) + & '*WARNING in ties: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo + if(tieset(1,ntie)(1:1).eq.' ') then + write(*,*) '*ERROR in ties: tie name is lacking' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*)'*ERROR in ties: definition of the tie' + write(*,*) ' is not complete.' + stop + endif +! + if ( multistage ) then + tieset(1,ntie)(81:81)='M' + elseif(tied) then + tieset(1,ntie)(81:81)='T' + endif +! + if(tied) then +! +! slave surface can be nodal or facial +! + tieset(2,ntie)(1:80)=textpart(1)(1:80) + tieset(2,ntie)(81:81)=' ' +! +! master surface must be facial +! + tieset(3,ntie)(1:80)=textpart(2)(1:80) + tieset(3,ntie)(81:81)=' ' + ipos=index(tieset(3,ntie),' ') + tieset(3,ntie)(ipos:ipos)='T' + else +! +! slave and master surface must be nodal +! + tieset(2,ntie)(1:80)=textpart(1)(1:80) + tieset(2,ntie)(81:81)=' ' + ipos=index(tieset(2,ntie),' ') + tieset(2,ntie)(ipos:ipos)='S' +! + tieset(3,ntie)(1:80)=textpart(2)(1:80) + tieset(3,ntie)(81:81)=' ' + ipos=index(tieset(3,ntie),' ') + tieset(3,ntie)(ipos:ipos)='S' + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/timepointss.f calculix-ccx-2.3/ccx_2.3/src/timepointss.f --- calculix-ccx-2.1/ccx_2.3/src/timepointss.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/timepointss.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,155 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine timepointss(inpc,textpart,amname,amta,namta,nam, + & nam_,namtot_,irstrt,istep,istat,n,iline,ipol,inl,ipoinp,inp, + & ipoinpc) +! +! reading the input deck: *AMPLITUDE +! + implicit none +! + character*1 inpc(*) + character*80 amname(*) + character*132 textpart(16) +! + integer namta(3,*),nam,nam_,istep,istat,n,key,i,namtot, + & namtot_,irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),ipos, + & ipoinpc(0:*),nttp +! + logical igen +! +! + real*8 amta(2,*),x,tpmin,tpmax,tpinc +! + igen=.false. + + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*) '*ERROR in timepointss: *AMPLITUDE should be' + write(*,*) ' placed before all step definitions' + stop + endif +! + nam=nam+1 + if(nam.gt.nam_) then + write(*,*) '*ERROR in timepointss: increase nam_' + stop + endif + namta(3,nam)=nam + amname(nam)=' + & ' +! + do i=2,n + if(textpart(i)(1:5).eq.'NAME=') then + amname(nam)=textpart(i)(6:85) + if(textpart(i)(86:86).ne.' ') then + write(*,*) + & '*ERROR in timepointss: amplitude name too long' + write(*,*) ' (more than 80 characters)' + write(*,*) ' amplitude name:',textpart(i)(1:132) + stop + endif + elseif(textpart(i)(1:14).eq.'TIME=TOTALTIME') then + namta(3,nam)=-nam + elseif(textpart(i)(1:8).eq.'GENERATE') then + igen=.true. + else + write(*,*) + & '*WARNING in timepointss: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(amname(nam).eq.' + & ') then + write(*,*) '*ERROR in timepointss: Amplitude has no name' + call inputerror(inpc,ipoinpc,iline) + endif +! + if(nam.eq.1) then + namtot=0 + else + namtot=namta(2,nam-1) + endif + namta(1,nam)=namtot+1 +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) exit + if(.not.igen)then + do i=1,8 + if(textpart(i)(1:1).ne.' ') then + namtot=namtot+1 + if(namtot.gt.namtot_) then + write(*,*) + & '*ERROR in timepointss: increase namtot_' + stop + endif + read(textpart(i),'(f20.0)',iostat=istat) x + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + amta(1,namtot)=x + namta(2,nam)=namtot + else + exit + endif + enddo + else +c if((textpart(1)(1:1).ne.' ').and. +c & (textpart(2)(1:1).ne.' ').and. +c & (textpart(3)(1:1).ne.' ')) then +c + read(textpart(1)(1:20),'(f20.0)',iostat=istat) tpmin + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) tpmax + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) tpinc + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + + nttp=INT((tpmax-tpmin)/tpinc) + + if(namtot+2+nttp.gt.namtot_) then + write(*,*) '*ERROR in timepoints: increase namtot_' + stop + endif + amta(1,namtot+1)=tpmin + do i=1,nttp + amta(1,namtot+1+i)=tpmin+(i*tpinc) + enddo + namtot=namtot+2+nttp + amta(1,namtot)=tpmax + namta(2,nam)=namtot +c else +c exit +c endif + endif + enddo +! + if(namta(1,nam).gt.namta(2,nam)) then + ipos=index(amname(nam),' ') + write(*,*) '*WARNING in timepointss: *TIME POINTS definition ', + & amname(nam)(1:ipos-1) + write(*,*) ' has no data points' + nam=nam-1 + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/TODO calculix-ccx-2.3/ccx_2.3/src/TODO --- calculix-ccx-2.1/ccx_2.3/src/TODO 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/TODO 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,9 @@ +=================================================== +Things which might be useful if built into CalculiX Version 2.3 +=================================================== + +- gap/contact elements + +- incompressible elements + +- tension-only material diff -Nru calculix-ccx-2.1/ccx_2.3/src/transformatrix.f calculix-ccx-2.3/ccx_2.3/src/transformatrix.f --- calculix-ccx-2.1/ccx_2.3/src/transformatrix.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/transformatrix.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,141 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine transformatrix(xab,p,a) +! +! determines the transformation matrix a in a point p for a carthesian +! (xab(7)>0) or cylindrical transformation (xab(7)<0) +! + implicit none +! + integer j +! + real*8 xab(7),p(3),a(3,3),e1(3),e2(3),e3(3),dd +! + if(xab(7).gt.0) then +! +! carthesian transformation +! + e1(1)=xab(1) + e1(2)=xab(2) + e1(3)=xab(3) +! + e2(1)=xab(4) + e2(2)=xab(5) + e2(3)=xab(6) +! + dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3)) + do j=1,3 + e1(j)=e1(j)/dd + enddo +! + dd=e1(1)*e2(1)+e1(2)*e2(2)+e1(3)*e2(3) + do j=1,3 + e2(j)=e2(j)-dd*e1(j) + enddo +! + dd=dsqrt(e2(1)*e2(1)+e2(2)*e2(2)+e2(3)*e2(3)) + do j=1,3 + e2(j)=e2(j)/dd + enddo +! + e3(1)=e1(2)*e2(3)-e2(2)*e1(3) + e3(2)=e1(3)*e2(1)-e1(1)*e2(3) + e3(3)=e1(1)*e2(2)-e2(1)*e1(2) +! + else +! +! cylindrical coordinate system in point p +! + e1(1)=p(1)-xab(1) + e1(2)=p(2)-xab(2) + e1(3)=p(3)-xab(3) +! + e3(1)=xab(4)-xab(1) + e3(2)=xab(5)-xab(2) + e3(3)=xab(6)-xab(3) +! + dd=dsqrt(e3(1)*e3(1)+e3(2)*e3(2)+e3(3)*e3(3)) +! + do j=1,3 + e3(j)=e3(j)/dd + enddo +! + dd=e1(1)*e3(1)+e1(2)*e3(2)+e1(3)*e3(3) +! + do j=1,3 + e1(j)=e1(j)-dd*e3(j) + enddo +! + dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3)) +! +! check whether p belongs to the cylindrical coordinate axis +! if so, an arbitrary vector perpendicular to the axis can +! be taken +! + if(dd.lt.1.d-10) then +c write(*,*) '*WARNING in transformatrix: point on axis' + if(dabs(e3(1)).gt.1.d-10) then + e1(2)=1.d0 + e1(3)=0.d0 + e1(1)=-e3(2)/e3(1) + elseif(dabs(e3(2)).gt.1.d-10) then + e1(3)=1.d0 + e1(1)=0.d0 + e1(2)=-e3(3)/e3(2) + else + e1(1)=1.d0 + e1(2)=0.d0 + e1(3)=-e3(1)/e3(3) + endif + dd=dsqrt(e1(1)*e1(1)+e1(2)*e1(2)+e1(3)*e1(3)) + endif +! + do j=1,3 + e1(j)=e1(j)/dd + enddo +! + e2(1)=e3(2)*e1(3)-e1(2)*e3(3) + e2(2)=e3(3)*e1(1)-e1(3)*e3(1) + e2(3)=e3(1)*e1(2)-e1(1)*e3(2) +! + endif +! +! finding the transformation matrix +! + do j=1,3 + a(j,1)=e1(j) + a(j,2)=e2(j) + a(j,3)=e3(j) + enddo +! + return + end + + + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/transforms.f calculix-ccx-2.3/ccx_2.3/src/transforms.f --- calculix-ccx-2.1/ccx_2.3/src/transforms.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/transforms.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,115 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine transforms(inpc,textpart,trab,ntrans,ntrans_, + & inotr,set,istartset,iendset,ialset,nset,istep,istat, + & n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *TRANSFORM +! + implicit none +! + real*8 trab(7,*) +! + character*1 inpc(*) + character*81 set(*),noset + character*132 textpart(16) +! + integer ntrans,ntrans_,istep,istat,n,key,i,j,k,inotr(2,*), + & istartset(*),iendset(*),ialset(*),nset,ipos,iline,ipol, + & inl,ipoinp(2,*),inp(3,*),ipoinpc(0:*) +! + if(istep.gt.0) then + write(*,*) '*ERROR in transforms: *TRANSFORM should be' + write(*,*) ' placed before all step definitions' + stop + endif +! + ntrans=ntrans+1 + if(ntrans.gt.ntrans_) then + write(*,*) '*ERROR in transforms: increase ntrans_' + stop + endif +! +! rectangular coordinate system: trab(7,norien)=1 +! cylindrical coordinate system: trab(7,norien)=-1 +! default is rectangular +! + trab(7,ntrans)=1.d0 +! + do i=2,n + if(textpart(i)(1:5).eq.'NSET=') then + noset=textpart(i)(6:85) + noset(81:81)=' ' + ipos=index(noset,' ') + noset(ipos:ipos)='N' + elseif(textpart(i)(1:5).eq.'TYPE=') then + if(textpart(i)(6:6).eq.'C') then + trab(7,ntrans)=-1.d0 + endif + else + write(*,*) + & '*WARNING in transforms: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*)'*ERROR in transforms: definition of a' + write(*,*) ' transformation is not complete' + call inputerror(inpc,ipoinpc,iline) + stop + endif +! + do i=1,6 + read(textpart(i)(1:20),'(f20.0)',iostat=istat) trab(i,ntrans) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! + do i=1,nset + if(set(i).eq.noset) exit + enddo + if(i.gt.nset) then + noset(ipos:ipos)=' ' + write(*,*) '*ERROR in transforms: node set ',noset + write(*,*) ' has not yet been defined.' + stop + endif + do j=istartset(i),iendset(i) + if(ialset(j).gt.0) then + inotr(1,ialset(j))=ntrans + else + k=ialset(j-2) + do + k=k-ialset(j) + if(k.ge.ialset(j-1)) exit + inotr(1,k)=ntrans + enddo + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/treattriangle.f calculix-ccx-2.3/ccx_2.3/src/treattriangle.f --- calculix-ccx-2.1/ccx_2.3/src/treattriangle.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/treattriangle.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,280 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine treattriangle(inodesin,nnodesin,inodesout, + & nnodesout,nopes,slavstraight,xn,co,xl2s,ipe,ime,iactiveline, + & nactiveline,intersec,xntersec,ifreeintersec,itri,koncont, + & itriacornerl,nintpoint,pslavsurf,ncont,imastsurf,pmastsurf, + & xl2m,nnodelem,vold,mi,pnodesin,straight,gapmints,ssurf) +! +! cuts a triangle of the master surface with a slave surface +! + integer inodesin(*),nnodesin,nvertex,lvertex(13),inodesout(*), + & nnodesout,nopes,ipe(*),ime(4,*),iactiveline(3,*),nactiveline, + & intersec(2,*),ifreeintersec,itri,koncont(4,*),itriacornerl(4), + & i,j,k,nintpoint,ncont,idin,imastsurf(*),nnodelem,mi(2),ijk, + & ninsert,nodel,ssurf +! + real*8 pvertex(3,13),pnodesin(3,*),slavstraight(20),xn(3), + & co(3,*),xilm,etlm,del,straight(16,*),spin, + & xl2s(3,*),xntersec(3,*),p(3,7),p1(3),p2(3),pslavsurf(3,*), + & ratio(8),dist,xil,etl,area,areax,areay,areaz,pmastsurf(2,*), + & xl2m(3,8),vold(0:mi(2),*),al,gapmints(*) +! + include "gauss.f" +! + data ijk /0/ + save ijk +! + nvertex=0 +! + node1=koncont(1,itri) + node2=koncont(2,itri) + node3=koncont(3,itri) +! +! check whether node 1 lies inside S +! + call checktriavertex(inodesin,nnodesin,node1,nvertex,pvertex, + & lvertex,pnodesin,inodesout,nnodesout,nopes,slavstraight, + & xn,co,xl2s,vold,mi) +! +! intersections of line node1-node2 with the edges of S +! +! test pour idin +! + if (node1.lt.node2) then + call nident(inodesin,node1,nnodesin,idin) + if (idin.gt.0) then + if (inodesin(idin).ne.node1) then + idin=0 + endif + endif + else + call nident(inodesin,node2,nnodesin,idin) + if (idin.gt.0) then + if (inodesin(idin).ne.node2) then + idin=0 + endif + endif + endif +! +! + call checktriaedge(node1,node2,ipe,ime,iactiveline, + & nactiveline,intersec,xntersec,nvertex,pvertex,lvertex, + & ifreeintersec,xn,co,nopes,xl2s,itri,idin,vold,mi) +! +! if there are intersections, check whether the S-vertex at +! the end of an intersected S-edge must be included +! +! +! check whether node 2 lies inside S +! + call checktriavertex(inodesin,nnodesin,node2,nvertex,pvertex, + & lvertex,pnodesin,inodesout,nnodesout,nopes,slavstraight, + & xn,co,xl2s,vold,mi) +! +! intersections of line node2-node3 with the edges of S +! +! test pour idin +! + if (node2.lt.node3) then + call nident(inodesin,node2,nnodesin,idin) + if (idin.gt.0) then + if (inodesin(idin).ne.node2) then + idin=0 + endif + endif + else + call nident(inodesin,node3,nnodesin,idin) + if (idin.gt.0) then + if (inodesin(idin).ne.node3) then + idin=0 + endif + endif + endif +! + call checktriaedge(node2,node3,ipe,ime,iactiveline, + & nactiveline,intersec,xntersec,nvertex,pvertex,lvertex, + & ifreeintersec,xn,co,nopes,xl2s,itri,idin,vold,mi) +! +! if there are intersections, check whether the S-vertex at +! the end of an intersected S-edge must be included +! +! check whether node 3 lies inside S +! + call checktriavertex(inodesin,nnodesin,node3,nvertex,pvertex, + & lvertex,pnodesin,inodesout,nnodesout,nopes,slavstraight, + & xn,co,xl2s,vold,mi) +! +! intersections of line node3-node1 with the edges of S +! +! test pour idin +! + if (node3.lt.node1) then + call nident(inodesin,node3,nnodesin,idin) + if (idin.gt.0) then + if (inodesin(idin).ne.node3) then + idin=0 + endif + endif + else + call nident(inodesin,node1,nnodesin,idin) + if (idin.gt.0) then + if (inodesin(idin).ne.node1) then + idin=0 + endif + endif + endif +! + call checktriaedge(node3,node1,ipe,ime,iactiveline, + & nactiveline,intersec,xntersec,nvertex,pvertex,lvertex, + & ifreeintersec,xn,co,nopes,xl2s,itri,idin,vold,mi) +! +! if there are intersections, check whether the S-vertex at +! the end of an intersected S-edge must be included +! +! check if there is always a slave node with value 1 +! + do nodel=4,1,-1 + if(itriacornerl(nodel).eq.1) then + nvertex=nvertex+1 + if (nvertex.lt.4) then + do i=1,3 + pvertex(i,nvertex)=xl2s(i,nodel) + enddo + itriacornerl(nodel)=2 + else +! +! The convexity of the polygone has to be checked +! + ninsert=nvertex-1 + spin=((pvertex(2,1)-xl2s(2,nodel))*(pvertex(3,ninsert)- + & xl2s(3,nodel))- + & (pvertex(3,1)-xl2s(3,nodel))*(pvertex(2,ninsert)- + & xl2s(2,nodel)))*xn(1)- + & ((pvertex(1,1)-xl2s(1,nodel))*(pvertex(3,ninsert)- + & xl2s(3,nodel))- + & (pvertex(3,1)-xl2s(3,nodel))*(pvertex(1,ninsert)- + & xl2s(1,nodel)))*xn(2)+ + & ((pvertex(1,1)-xl2s(1,nodel))*(pvertex(2,ninsert)- + & xl2s(2,nodel))- + & (pvertex(2,1)-xl2s(2,nodel))*(pvertex(1,ninsert)- + & xl2s(1,nodel)))*xn(3) +10 if ((spin.gt.0.d0).and.(ninsert.gt.0)) then + pvertex(1,ninsert+1)=pvertex(1,ninsert) + pvertex(2,ninsert+1)=pvertex(2,ninsert) + pvertex(3,ninsert+1)=pvertex(3,ninsert) + spin=((pvertex(2,ninsert)-xl2s(2,nodel))*(pvertex(3,ninsert-1)- + & xl2s(3,nodel))- + & (pvertex(3,ninsert)-xl2s(3,nodel))*(pvertex(2,ninsert-1)- + & xl2s(2,nodel)))*xn(1)- + & ((pvertex(1,ninsert)-xl2s(1,nodel))*(pvertex(3,ninsert-1)- + & xl2s(3,nodel))- + & (pvertex(3,ninsert)-xl2s(3,nodel))*(pvertex(1,ninsert-1)- + & xl2s(1,nodel)))*xn(2)+ + & ((pvertex(1,ninsert)-xl2s(1,nodel))*(pvertex(2,ninsert-1)- + & xl2s(2,nodel))- + & (pvertex(2,ninsert)-xl2s(2,nodel))*(pvertex(1,ninsert-1)- + & xl2s(1,nodel)))*xn(3) + ninsert=ninsert-1 + goto 10 + endif + pvertex(1,ninsert+1)=xl2s(1,nodel) + pvertex(2,ninsert+1)=xl2s(2,nodel) + pvertex(3,ninsert+1)=xl2s(3,nodel) + itriacornerl(nodel)=2 + endif + endif + enddo +! +! generating integration points on the slave surface S +! + do k=1,nvertex-2 + p1(1)=pvertex(1,1+k)-pvertex(1,1) + p1(2)=pvertex(2,1+k)-pvertex(2,1) + p1(3)=pvertex(3,1+k)-pvertex(3,1) + p2(1)=pvertex(1,2+k)-pvertex(1,1) + p2(2)=pvertex(2,2+k)-pvertex(2,1) + p2(3)=pvertex(3,2+k)-pvertex(3,1) + areax=((p1(2)*p2(3))-(p2(2)*p1(3)))**2 + areay=(-(p1(1)*p2(3))+(p2(1)*p1(3)))**2 + areaz=((p1(1)*p2(2))-(p2(1)*p1(2)))**2 + area=dsqrt(areax+areay+areaz)/2. +! +! storing the triangulation of the slave surfaces +! + ijk=ijk+1 + write(40,100) ijk,(pvertex(i,1),i=1,3) + ijk=ijk+1 + write(40,100) ,ijk,(pvertex(i,k+1),i=1,3) + ijk=ijk+1 + write(40,100) ijk,(pvertex(i,k+2),i=1,3) + write(40,101) ijk-2,ijk-2,ijk-1 + write(40,101) ijk-1,ijk-1,ijk + write(40,101) ijk,ijk,ijk-2 + 100 format('PNT ',i10,'P',3(1x,e15.8)) + 101 format('LINE ',i10,'L',i10,'P ',i10,'P') +! +! 7 points scheme +! + do i=1,7 + do j=1,3 + p(j,i)=pvertex(j,1)*gauss2d6(1,i)+ + & pvertex(j,1+k)*gauss2d6(2,i)+ + & pvertex(j,2+k)*(1.d0-gauss2d6(1,i)-gauss2d6(2,i)) +! + enddo +! + nintpoint=nintpoint+1 +! +! projection of the integration point in the mean +! slave plane onto the slave surface +! + call attachline(xl2s,p(1,i),nopes,ratio,dist,xil,etl,xn) +! +! Calculation of the gap function at the integration point +! + al=-(straight(16,itri)+straight(13,itri)*p(1,i) + & +straight(14,itri)*p(2,i)+straight(15,itri)*p(3,i))/ + & (straight(13,itri)*xn(1)+straight(14,itri)*xn(2) + & +straight(15,itri)*xn(3)) + gapmints(nintpoint)=al +! +! calculation of the intersection with the master triangle +! + p(1,i)=p(1,i)+al*xn(1) + p(2,i)=p(2,i)+al*xn(2) + p(3,i)=p(3,i)+al*xn(3) +! +! projection of the master integration point onto the +! master surface in order to get the local coordinates +! + call attach(xl2m,p(1,i),nnodelem,ratio,dist,xilm,etlm) +! + pslavsurf(1,nintpoint)=xil + pslavsurf(2,nintpoint)=etl + pslavsurf(3,nintpoint)=area*weight2d6(i) + pmastsurf(1,nintpoint)=xilm + pmastsurf(2,nintpoint)=etlm + imastsurf(nintpoint)=koncont(4,itri) + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/trianeighbor.f calculix-ccx-2.3/ccx_2.3/src/trianeighbor.f --- calculix-ccx-2.1/ccx_2.3/src/trianeighbor.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/trianeighbor.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,97 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine trianeighbor(ipe,ime,imastop,ncont,koncont, + & ifreeme) +! +! Catalogueing the neighboring triangles for a given master +! triangle +! +! Authors: Li,Yang; Rakotonanahary, Samoela; +! + implicit none +! + integer j,k,node,ipe(*),ime(4,*),imastop(3,*),ipos,node1,node2, + & index1,index1old,ifreeme,ncont,koncont(4,*) +! +! catalogueing the edges in the triangulation +! determining neighboring triangles +! + ifreeme=0 + do j=1,ncont + do k=1,3 + node1=koncont(k,j) + if(k.eq.3) then + node2=koncont(1,j) + else + node2=koncont(k+1,j) + endif +! + if(k.eq.1) then + ipos=3 + else + ipos=k-1 + endif +! +! making sure that node1 < node2 +! + if(node1.gt.node2) then + node=node1 + node1=node2 + node2=node + endif + if(ipe(node1).eq.0) then + ifreeme=ifreeme+1 + ipe(node1)=ifreeme + ime(1,ifreeme)=node2 + ime(2,ifreeme)=j + ime(3,ifreeme)=ipos + else + index1=ipe(node1) + if(ime(1,index1).eq.node2) then + imastop(ipos,j)=ime(2,index1) + imastop(ime(3,index1),ime(2,index1))=j + cycle + endif +! + index1old=index1 + index1=ime(4,index1) + do + if(index1.eq.0) then + ifreeme=ifreeme+1 + ime(4,index1old)=ifreeme + ime(1,ifreeme)=node2 + ime(2,ifreeme)=j + ime(3,ifreeme)=ipos + exit + endif + if(ime(1,index1).eq.node2) then + imastop(ipos,j)=ime(2,index1) + imastop(ime(3,index1),ime(2,index1))=j +c ime(4,index1old)=ime(4,index1) + exit + endif + index1old=index1 + index1=ime(4,index1) + enddo + endif + enddo + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/triangucont.f calculix-ccx-2.3/ccx_2.3/src/triangucont.f --- calculix-ccx-2.1/ccx_2.3/src/triangucont.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/triangucont.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,342 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine triangucont(ncont,ntie,tieset,nset,set,istartset, + & iendset,ialset,itietri,lakon,ipkon,kon,koncont,kind1,kind2) +! +! generate a triangulation of the contact master surfaces +! + implicit none +! + character*1 kind1,kind2 + character*8 lakon(*) + character*81 tieset(3,*),rightset,set(*) +! + integer ncont,ntie,i,j,k,l,nset,istartset(*),iendset(*),ialset(*), + & iright,itietri(2,ntie),nelem,jface,indexe,ipkon(*),nope,m, + & ifaceq(8,6),ifacet(6,4),ifacew1(4,5),ifacew2(8,5),node, + & ntrifac,itrifac3(3,1),itrifac4(3,2),itrifac6(3,4),itrifac8(3,6), + & itrifac(3,6),nnodelem,nface,nodef(8),kon(*),koncont(4,*) +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! +! triangulation for three-node face +! + data itrifac3 /1,2,3/ +! +! triangulation for four-node face +! + data itrifac4 /1,2,4,2,3,4/ +! +! triangulation for six-node face +! + data itrifac6 /1,4,6,4,2,5,6,5,3,4,5,6/ +! +! triangulation for eight-node face +! + data itrifac8 /1,5,8,5,2,6,7,6,3,8,7,4,8,5,7,5,6,7/ +! + ncont=0 +! + do i=1,ntie +! +! check for contact conditions +! + if((tieset(1,i)(81:81).eq.kind1).or. + & (tieset(1,i)(81:81).eq.kind2)) then + rightset=tieset(3,i) +! +! determining the master surface +! + do j=1,nset + if(set(j).eq.rightset) exit + enddo + if(j.gt.nset) then + write(*,*) '*ERROR in triangucont: master surface', + & rightset + write(*,*) ' does not exist' + stop + endif + iright=j +! + itietri(1,i)=ncont+1 +! + do j=istartset(iright),iendset(iright) + if(ialset(j).gt.0) then +c if(j.gt.istartset(iright)) then +c if(ialset(j).eq.ialset(j-1)) cycle +c endif +! + nelem=int(ialset(j)/10.d0) + jface=ialset(j)-10*nelem +! + indexe=ipkon(nelem) +! + if(lakon(nelem)(4:4).eq.'2') then + nnodelem=8 + nface=6 + elseif(lakon(nelem)(4:4).eq.'8') then + nnodelem=4 + nface=6 + elseif(lakon(nelem)(4:5).eq.'10') then + nnodelem=6 + nface=4 + elseif(lakon(nelem)(4:4).eq.'4') then + nnodelem=3 + nface=4 + elseif(lakon(nelem)(4:5).eq.'15') then + if(jface.le.2) then + nnodelem=6 + else + nnodelem=8 + endif + nface=5 + nope=15 + elseif(lakon(nelem)(4:4).eq.'6') then + if(jface.le.2) then + nnodelem=3 + else + nnodelem=4 + endif + nface=5 + nope=6 + else + cycle + endif +! +! determining the nodes of the face +! + if(nface.eq.4) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacet(k,jface)) + enddo + elseif(nface.eq.5) then + if(nope.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew1(k,jface)) + enddo + elseif(nope.eq.15) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew2(k,jface)) + enddo + endif + elseif(nface.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifaceq(k,jface)) + enddo + endif +! +! number of triangles +! + if(nnodelem.eq.3) then + ntrifac=1 + do l=1,ntrifac + do k=1,3 + itrifac(k,l)=itrifac3(k,l) + enddo + enddo + elseif(nnodelem.eq.4) then + ntrifac=2 + do l=1,ntrifac + do k=1,3 + itrifac(k,l)=itrifac4(k,l) + enddo + enddo + elseif(nnodelem.eq.6) then + ntrifac=4 + do l=1,ntrifac + do k=1,3 + itrifac(k,l)=itrifac6(k,l) + enddo + enddo + elseif(nnodelem.eq.8) then + ntrifac=6 + do l=1,ntrifac + do k=1,3 + itrifac(k,l)=itrifac8(k,l) + enddo + enddo + endif +! +! storing the topology of the triangles +! + do l=1,ntrifac +! + ncont=ncont+1 + do k=1,3 + node=nodef(itrifac(k,l)) + koncont(k,ncont)=node + enddo +! + koncont(4,ncont)=ialset(j) +! + enddo +! + else + m=ialset(j-2) + do + m=m-ialset(j) + if(m.ge.ialset(j-1)) exit +! + nelem=int(m/10.d0) + jface=m-10*nelem +! + indexe=ipkon(nelem) +! + if(lakon(nelem)(4:4).eq.'2') then + nnodelem=8 + nface=6 + elseif(lakon(nelem)(4:4).eq.'8') then + nnodelem=4 + nface=6 + elseif(lakon(nelem)(4:5).eq.'10') then + nnodelem=6 + nface=4 + elseif(lakon(nelem)(4:4).eq.'4') then + nnodelem=3 + nface=4 + elseif(lakon(nelem)(4:5).eq.'15') then + if(jface.le.2) then + nnodelem=6 + else + nnodelem=8 + endif + nface=5 + nope=15 + elseif(lakon(nelem)(4:4).eq.'6') then + if(jface.le.2) then + nnodelem=3 + else + nnodelem=4 + endif + nface=5 + nope=6 + else + cycle + endif +! +! determining the nodes of the face +! + if(nface.eq.4) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacet(k,jface)) + enddo + elseif(nface.eq.5) then + if(nope.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew1(k,jface)) + enddo + elseif(nope.eq.15) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifacew2(k,jface)) + enddo + endif + elseif(nface.eq.6) then + do k=1,nnodelem + nodef(k)=kon(indexe+ifaceq(k,jface)) + enddo + endif +! +! number of triangles +! + if(nnodelem.eq.3) then + ntrifac=1 + do l=1,ntrifac + do k=1,3 + itrifac(k,l)=itrifac3(k,l) + enddo + enddo + elseif(nnodelem.eq.4) then + ntrifac=2 + do l=1,ntrifac + do k=1,3 + itrifac(k,l)=itrifac4(k,l) + enddo + enddo + elseif(nnodelem.eq.6) then + ntrifac=4 + do l=1,ntrifac + do k=1,3 + itrifac(k,l)=itrifac6(k,l) + enddo + enddo + elseif(nnodelem.eq.8) then + ntrifac=6 + do l=1,ntrifac + do k=1,3 + itrifac(k,l)=itrifac8(k,l) + enddo + enddo + endif +! +! storing the topology of the triangles +! + do l=1,ntrifac +! + ncont=ncont+1 + do k=1,3 + node=nodef(itrifac(k,l)) + koncont(k,ncont)=node + enddo +! + koncont(4,ncont)=m +! + enddo +! + enddo + endif + enddo +! + itietri(2,i)=ncont +! + endif + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/triangulate.f calculix-ccx-2.3/ccx_2.3/src/triangulate.f --- calculix-ccx-2.1/ccx_2.3/src/triangulate.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/triangulate.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,302 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine triangulate(ics,rcs0,zcs0,ncsnodes, + & rcscg,rcs0cg,zcscg,zcs0cg,nrcg,nzcg,jcs,kontri,straight, + & ne,ipkon,kon,lakon,lcs,netri,ifacetet,inodface) +! +! generate a triangulation of the independent side (= right side) +! +! the element faces of the independent side are identified and +! triangulated. The nodes belonging to the faces are stored in +! field inodface, face after face. For a triangle i the value +! ifacetet(i) points to the last node in field inodface of the +! face the triangle belongs to. +! + implicit none +! + character*8 lakon(*) +! + integer jcs(*),l,j,ics(*),nodef(8),ifacetet(*), + & nrcg(*),node,ncsnodes,id,ifaceq(8,6),ifacet(6,4), + & ifacew1(4,5),iface(8,6),nodelem(20),nnodelem,nzcg(*), + & itrifac3(3,1),itrifac4(3,2),itrifac6(3,4),itrifac8(3,6), + & itrifac(3,6),ifacew2(8,5),lcs(*),inodface(*),nnodface, + & k,kflag,i,ne,ipkon(*),kon(*),indexe,nope,nface,nodface,jface, + & netri,ntrifac,kontri(3,*) +! + real*8 straight(9,*),zcscg(*),rcscg(*),zcs0cg(*), + & rcs0cg(*),cgl(2),col(2,3),rcs0(*),zcs0(*) +! +! nodes per face for hex elements +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ +! +! nodes per face for tet elements +! + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ +! +! nodes per face for linear wedge elements +! + data ifacew1 /1,3,2,0, + & 4,5,6,0, + & 1,2,5,4, + & 2,3,6,5, + & 4,6,3,1/ +! +! nodes per face for quadratic wedge elements +! + data ifacew2 /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ +! +! triangulation for three-node face +! + data itrifac3 /1,2,3/ +! +! triangulation for four-node face +! + data itrifac4 /1,2,4,2,3,4/ +! +! triangulation for six-node face +! + data itrifac6 /1,4,6,4,2,5,6,5,3,4,5,6/ +! +! triangulation for eight-node face +! + data itrifac8 /1,5,8,5,2,6,7,6,3,8,7,4,8,5,7,5,6,7/ +! +! pointer into field inodface +! + nnodface=0 +! +! sort the nodes on the independent side +! + do j=1,ncsnodes + jcs(j)=abs(ics(j)) + lcs(j)=j + enddo +! + kflag=2 + call isortii(jcs,lcs,ncsnodes,kflag) +! + netri=0 +! +! check the elements adjacent to the independent nodes +! + do i=1,ne + indexe=ipkon(i) + if(lakon(i)(4:4).eq.'2') then + nope=20 + nface=6 + nodface=8 + elseif(lakon(i)(4:4).eq.'8') then + nope=8 + nface=6 + nodface=4 + elseif(lakon(i)(4:5).eq.'10') then + nope=10 + nface=4 + nodface=6 + elseif(lakon(i)(4:4).eq.'4') then + nope=4 + nface=4 + nodface=3 + elseif(lakon(i)(4:5).eq.'15') then + nope=15 + nface=5 + nodface=8 + elseif(lakon(i)(4:4).eq.'6') then + nope=6 + nface=5 + nodface=4 + else + cycle + endif +! +! check which nodes of the element belong to the independent set +! + nnodelem=0 + do j=1,nope + nodelem(j)=0 + node=kon(indexe+j) + call nident(jcs,node,ncsnodes,id) + if(id.le.0) cycle + if(jcs(id).ne.node) cycle + nodelem(j)=node + nnodelem=nnodelem+1 + enddo + if(nnodelem.eq.0) cycle +! + if(nface.eq.4) then + do j=1,nface + do k=1,nodface + iface(k,j)=ifacet(k,j) + enddo + enddo + elseif(nface.eq.5) then + if(nope.eq.6) then + do j=1,nface + do k=1,nodface + iface(k,j)=ifacew1(k,j) + enddo + enddo + elseif(nope.eq.15) then + do j=1,nface + do k=1,nodface + iface(k,j)=ifacew2(k,j) + enddo + enddo + endif + elseif(nface.eq.6) then + do j=1,nface + do k=1,nodface + iface(k,j)=ifaceq(k,j) + enddo + enddo + endif +! +! check which face of the element belongs to the independent side +! + jface=0 + loop: do j=1,nface + do k=1,nodface + if(iface(k,j).eq.0) then + nnodelem=k-1 + exit + endif + if(nodelem(iface(k,j)).eq.0) cycle loop + enddo + jface=j + exit + enddo loop + if(jface.eq.0) cycle +! +! store the node numbers in a local face field +! + do k=1,nnodelem + nodef(k)=nodelem(iface(k,jface)) + inodface(nnodface+k)=nodef(k) + enddo + nnodface=nnodface+nnodelem +! +! number of triangles +! + if(nnodelem.eq.3) then + ntrifac=1 + do j=1,ntrifac + do k=1,3 + itrifac(k,j)=itrifac3(k,j) + enddo + enddo + elseif(nnodelem.eq.4) then + ntrifac=2 + do j=1,ntrifac + do k=1,3 + itrifac(k,j)=itrifac4(k,j) + enddo + enddo + elseif(nnodelem.eq.6) then + ntrifac=4 + do j=1,ntrifac + do k=1,3 + itrifac(k,j)=itrifac6(k,j) + enddo + enddo + elseif(nnodelem.eq.8) then + ntrifac=6 + do j=1,ntrifac + do k=1,3 + itrifac(k,j)=itrifac8(k,j) + enddo + enddo + endif +! + do j=1,ntrifac +! +! new triangle +! + netri=netri+1 + do l=1,2 + cgl(l)=0.d0 + enddo + do k=1,3 + node=nodef(itrifac(k,j)) + kontri(k,netri)=node + call nident(jcs,node,ncsnodes,id) + col(1,k)=rcs0(lcs(id)) + col(2,k)=zcs0(lcs(id)) + do l=1,2 + cgl(l)=cgl(l)+col(l,k) + enddo + enddo +! +! center of gravity of the triangle +! +c write(*,*) netri,zcs0(101) + rcscg(netri)=cgl(1)/3.d0 +c write(*,*) netri,zcs0(101),rcscg(netri) + zcscg(netri)=cgl(2)/3.d0 +c write(*,*) 'triangle ',netri,(kontri(k,netri),k=1,3) +c write(*,*) col(1,1),col(2,1) +c write(*,*) col(1,2),col(2,2) +c write(*,*) col(1,3),col(2,3) +c write(*,*) rcscg(netri),zcscg(netri) +! +! determining the equations of the straight lines bordering +! the triangle +! + call straighteq2d(col,straight(1,netri)) +! + ifacetet(netri)=nnodface +! + enddo + enddo +! + if(netri.eq.0) then + write(*,*) '*ERROR in triangulate: no faces found on the' + write(*,*) ' independent side' + stop + endif +! +! initialization of near2d +! + do i=1,netri + nrcg(i)=i + nzcg(i)=i + rcs0cg(i)=rcscg(i) + zcs0cg(i)=zcscg(i) + enddo +! + kflag=2 + call dsort(rcscg,nrcg,netri,kflag) + call dsort(zcscg,nzcg,netri,kflag) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/ts_calc.f calculix-ccx-2.3/ccx_2.3/src/ts_calc.f --- calculix-ccx-2.1/ccx_2.3/src/ts_calc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ts_calc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,116 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine ts_calc(xflow,Tt,Pt,kappa,r,a,Ts,icase) +! +! this subroutine solves the implicit equation +! f=xflow*dsqrt(Tt)/(a*Pt)-C*(TtdT)**expon*(Ttdt-1)**0.5d0 +! + implicit none +! + integer inv,icase,i +! + real*8 xflow,Tt,Pt,Ts,kappa,r,f,df,a,expon,Ts_old,C,TtzTs, + & deltaTs,TtzTs_crit, Qred_crit,Qred,h1,h2,h3 + expon=-0.5d0*(kappa+1.d0)/(kappa-1.d0) +! + C=dsqrt(2.d0/r*kappa/(kappa-1.d0)) +! +! f=xflow*dsqrt(Tt)/(a*Pt)-C*(TtdT)**expon*(Ttdt-1)**0.5d0 +! +! df=-C*Ttdt**expon*(expon/Ts*(TtdT-1)**0.5d0 +! & -0.5d0*TtdT/Ts*(TtdT-1.d0)**(-0.5d0)) +! + Ts_old=Tt +! +! + if(xflow.lt.0d0) then + inv=-1 + else + inv=1 + endif +! + if(dabs(xflow).le.1e-9) then + Ts=Tt + return + endif +! + Qred=abs(xflow)*dsqrt(Tt)/(a*Pt) +! +! optimised estimate of T static +! + Ts=Tt/(1+(Qred**2/C**2)) +! +! adiabatic +! + if(icase.eq.0) then +! + TtzTs_crit=(kappa+1.d0)/2.d0 +! +! isothermal +! + else +! + TtzTs_crit=(1d0+(kappa-1.d0)/(2.d0*kappa)) +! + endif +! + Qred_crit=C*(TtzTs_crit)**expon*(Ttzts_crit-1.d0)**0.5d0 +! +! xflow_crit=inv*Qred_crit/dsqrt(Tt)*A*Pt +! + if(Qred.ge.Qred_crit) then +! + Ts=Tt/TtzTs_crit +! + return +! + endif + i=0 +! + do + i=i+1 + Ttzts=Tt/Ts + h1=Ttzts-1.d0 + h2=dsqrt(h1) + h3=Ttzts**expon +! + f=C*h2*h3 +! + df=f*(expon+0.5d0*Ttzts/h1)/Ts +! + f=Qred-f + deltaTs=-f/df +! + Ts=Ts+deltaTs +! + if( (((dabs(Ts-Ts_old)/ts_old).le.1.E-8)) + & .or.((dabs(Ts-Ts_old)).le.1.E-10)) then + exit + else if(i.gt.20) then + Ts=0.9*Tt + exit + endif + Ts_old=Ts + enddo +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/tt_calc.f calculix-ccx-2.3/ccx_2.3/src/tt_calc.f --- calculix-ccx-2.1/ccx_2.3/src/tt_calc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/tt_calc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,159 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine tt_calc(xflow,Tt,Pt,kappa,r,a,Ts,icase,iflag) +! +! this subroutine solves the implicit equation +! f=xflow*dsqrt(Tt)/(a*Pt)-C*(TtdT)**expon*(Ttdt-1)**0.5d0 +! in order to find Tt when ts , xflow, pt and a are given +! + implicit none +! + integer inv,icase,i,iflag +! + real*8 xflow,Tt,Pt,Ts,kappa,r,f,df,a,expon,Tt_old,C,TtzTs, + & deltaTt,TtzTs_crit, Qred_crit,Qred,h1,h2,h3,Tt_crit +! + expon=-0.5d0*(kappa+1.d0)/(kappa-1.d0) +! + C=dsqrt(2.d0/r*kappa/(kappa-1.d0)) +! +! f=xflow*dsqrt(Tt)/(a*Pt)-C*(TtdT)**expon*(Ttdt-1)**0.5d0 +! +! df=-C*Ttdt**expon*(expon/Ts*(TtdT-1)**0.5d0 +! & -0.5d0*TtdT/Ts*(TtdT-1.d0)**(-0.5d0)) +! + Tt_old=Tt +! +! + if(xflow.lt.0d0) then + inv=-1 + else + inv=1 + endif +! + if(dabs(xflow).le.1e-9) then + Tt=Ts + return + endif +! + Qred=abs(xflow)*dsqrt(Tt)/(a*Pt) +! +c write(*,*) 'epsilon',(Qred/C)**2 +! +! optimised estimate of T static +! + Tt=Ts*(1+(Qred**2/C**2)) +! +! adiabatic +! + if(icase.eq.0) then +! + TtzTs_crit=(kappa+1.d0)/2.d0 +! +! isothermal +! + else +! +! if(iflag.ne.3) then + TtzTs_crit=(1d0+(kappa-1.d0)/(2.d0*kappa)) + if(iflag.ne.3) then + Tt_crit=(A*pt/(dabs(xflow))*C*Ttzts_crit**expon* + & (TtzTs_crit-1)**0.5d0)**2 +! if(iflag.ne.3) then + if(Tt.gt.Tt_crit) then + Tt=Tt_crit + endif + endif +! Tt=Tt_crit +! Qred=abs(xflow)*dsqrt(Tt)/(a*Pt) +! + endif +! + Qred_crit=C*(TtzTs_crit)**expon*(Ttzts_crit-1.d0)**0.5d0 +! +! + if(Qred.ge.Qred_crit) then +! + Tt=Ts*TtzTs_crit +! + return +! + endif + i=0 +! + do + i=i+1 + Ttzts=Tt/Ts + h1=Ttzts-1.d0 + h2= dsqrt(h1) + h3=Ttzts**expon +! + f=C*h2*h3 +! + df=0.5*inv*xflow/(A*Pt*dsqrt(Tt)) + & -1/Tt*C*h2*h3*(expon+0.5d0*(h1)**(-1)) +! + f=Qred-f + deltaTt=-f/df +c write(*,*) 'deltaTs=',deltaTs +! + Tt=Tt+deltaTt +c write(*,*) 'Ts',Ts +! + if( (((dabs(Tt-Tt_old)/tt_old).le.1.E-8)) + & .or.((dabs(Tt-Tt_old)).le.1.E-10) + & .or.((f.le.1E-5).and.(deltaTt.lt.1E-3))) then +c write(*,*) 'f=',f +c write(*,*) 'Ts=',Ts +c write(*,*) 'i',i +c$$$c write(*,*) '' +c$$$ write(*,*) 'f',f +c$$$ write(*,*) '' +c$$$ write(*,*) 'Ts',Ts +c$$$ write(*,*) 'Tt',Tt +c$$$ write(*,*) '' + Qred_crit=C*(TtzTs_crit)**expon*(Ttzts_crit-1.d0)**0.5d0 + Qred=abs(xflow)*dsqrt(Tt)/(a*Pt) +! + if((Qred.ge.Qred_crit).and.(iflag.eq.3)) then +! + Tt=Ts*TtzTs_crit +! + endif + exit + else if((i.gt.40)) then + Tt=0.99*Ts*TtzTs_crit +c$$$ Tt=1.2*Ts +c$$$ write(*,*) 'Break' +c$$$ write(*,*) 'f',f +c$$$ write(*,*) 'Ts',Ts +c$$$ write(*,*) 'Tt',Tt +c$$$ write(*,*) '' + exit + endif + Tt_old=Tt + enddo +! +C write(*,*) 'end of ts_clac.f' +c write(*,*) '' + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/twodint.f calculix-ccx-2.3/ccx_2.3/src/twodint.f --- calculix-ccx-2.1/ccx_2.3/src/twodint.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/twodint.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,229 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +C +C 1.TASK INTERPOLATION OF A TWO DIMENSIONAL FUNCTION DEFINED POINT BY POINT +C ********* THE X COORDINATES ARE USER SPECIFIED. +c THE INTERPOLATION TYPE CAN BE INDEPENDANTLY CHOSEN IN THE TWO DIRECTIONS +C EITHER CONSTANT, LINEAR OR DOUBLE QUADRATIC. +C BEYOND THE FIELD OF INTERPOLATION AN EXTRAOLATION IS CARRIED OUT. +C FOR ALL FOUR EXTRAPOLATION DIRECTIONS DIFFERENT EXTRAPOLATION METHOD +C (C ONSTANT,LINEAR,QUADRATIC) CAN BE CHOSEN, WHICH ORDER MUST NOT BE HIGHER +C THAN THE IONTERPOLATION ORDER +C +C 2.UP-AUFRUF CALL TWODINT(T,LSP,IART,XA,YA,ZA,NA,IEXP,IER) +C *********** T = MATRIX OF THE SAMPLE POINTS FORMATED AS FOLLOW +C T(1,1) = NX + NY * 0.001 +C NX = NUMBER OF LINES T +C NY = NUMBER OF COLUMNS T +C T(1,2) ... T(1,NY) +C VECTOR OF THE Y COORDINATES OF THE T MATRIX +C T(2,1) ... T(NX,1) +C VECTOR OF THE X COORDINATES OF THE T MATRIX +C REST OF T-MATRIX: +C POINT(X,Y) OF THE T MATRIX +C +C LSP = COLUMN STEPOF T +C IART = TYPE OF INTERPOLATION +C IART = INTX * 10 + INTY +C INTX INTERPOLATION TYPE IN X-DIRECTION +C INTY INTERPOLATION TYPE IN Y-DIRECTION +C XA = VECTOR OF THE X COORDINATES OF THE VALUE TO BE INTERPOLATED +C YA = VECTOR OF THE Y COORDINATES OF THE VALUE TO BE INTERPOLATED +C ZA = VECTOR OF THE INTERPOLATED VALUES +C NA = ACTUAL LENGTH OF THE 3 PREVIOUS VECTORS +C IEXP = TWO ELEMENT VECTOR CONTRAINING THE TYPE OF EXTRAPOLATION +C CHOSEN BEYOND THE INTERPOLATION DOMAIN +C IEXP(1): EXTRAPOLATION IN X-DIRECTION +C IEXP(1) = IEXPX1 * 10 + IEXPXN +C IEXPX1: EXTRAPOLATION BENEATH THE FIRST POINT +C IEXPXN: EXTRAPOLATION BEYOND THE LAST POINT +C IEXP(2): EXTRAPOLATION IN Y-DIRECTION +C IEXP(2) = IEXPY1 * 10 + IEXPYN +C SAME METHOD AS FOR IEXP(1): +C IER = ERROR CODE +C IER = 0: NORMAL PROCEEDING +C IER = -1: ERROR INPUTDATA +C +C REMARK: CHOICE OF THE INTER- EXTRAPOLATION TYPE IART AND IEXP - +C -------- ASSIGNEMENT OF INTX,INTY,IEXPX1, +C IEXPXN,IEXPY1,IEXPYN: +C = 0 : CONSTANT +C = 1 : LINEAR +C = 2 : DOUBLE QUADRATIC FROM +C THE SECOND UNTIL PENULTIMATE +C INTERVAL IN THE INTERPOLATION MATRIX T,OTHERWISE QUADRATIC +C +C 3.RESTRICTIONS THE SAMPLING POINT VECTORS (X UND Y COORDINATES +C *************** OF THE MATRICX T MUST BE STRICTLY MONOTONIC INCREASING SORTED +C THE PARAMETER FOR THE TYPE OF EXTRAPOLATION +c MUST NOT BE GREATER THAN THE ONE FOR TH EINTERPOLATION TYPE +C OTHERWISE THE VALUE IS AUTOMATICALLY ADAPTATED +C IF THE NUMBER OF THE SAMPLING POINTS FOR THE REQUIRED TYPE OF INTERPOLATION IS TOO SMALL, +C THE DEGREE OF INTERPOLATION WILL BE ACCORDINGLY ADAPTATED +C +C 4.USED UP'S ONEDINT (ONE DIMENSIONAL INTERPOLATION ANALOG TO THIS PROGRAMM) +C + + SUBROUTINE TWODINT (T,LSP,IART,XA,YA,ZA,NA,IEXP,IER) + IMPLICIT NONE + INTEGER IEXP(2),IYU,IYO,IXU,IXO,IDX,IDY,LL,INPY,IEXPX1,IEXPXN, + & IEXPY1,IEXPYN,LX,LY,INPX,IART,LSP,IER,NX,NY,L,NA + REAL*8 T(LSP,1),XA(1),YA(1),ZA(1) + REAL*8 Z1(4),Z2(4) +C ENTRY ZWEINT (T,LSP,IART,XA,YA,ZA,NA,IEXP,IER) + IER = 0 + NX = T(1,1) + NY = (T(1,1)-NX)*1000 + 0.1 +C +C TESTING INPUT +C-------------- + IF ((NX-2).lt.0) then + go to 900 + elseif((nx-2).eq.0) then + go to 30 + else + go to 10 + endif + 10 DO 20 L = 3,NX + 20 IF ((T(L,1)-T(L-1,1)) .LE. 0) GO TO 900 + 30 IF ((NY-2).lt.0) then + go to 900 + elseif((ny-2).eq.0) then + go to 60 + else + go to 40 + endif + 40 DO 50 L = 3,NY + 50 IF ((T(1,L)-T(1,L-1)) .LE. 0) GO TO 900 + 60 IF (NA .LE. 0) GO TO 900 +C +C DEFINING THE CONTROL VALUES +C--------------------------- + 100 INPX = IART/10 + INPY = IART - INPX*10 + 0.1 + IEXPX1 = IEXP(1)/10 + IEXPXN = IEXP(1) - IEXPX1*10 + IEXPY1 = IEXP(2)/10 + IEXPYN = IEXP(2) - IEXPY1*10 + IF (NX-2 .LT. INPX) INPX = NX - 2 + IF (NY-2 .LT. INPY) INPY = NY - 2 + IF (IEXPX1 .GT. INPX) IEXPX1 = INPX + IF (IEXPXN .GT. INPX) IEXPXN = INPX + IF (IEXPY1 .GT. INPY) IEXPY1 = INPY + IF (IEXPYN .GT. INPY) IEXPYN = INPY +C +C SUCCESSIVE PROCESSING THE INTERPOLATION EXIGENCES +C------------------------------------------------------- + DO 400 L = 1,NA + LX = 2 +C +C SETTING REFERENCE POINTS (LX,LY) +C--------------------------------- + 200 IF (XA(L) .LT. T(LX,1)) GO TO 220 + LX = LX + 1 + IF ((LX-NX).le.0) then + go to 200 + else + go to 210 + endif + 210 LX = NX + 220 DO 230 LY = 2,NY + 230 IF (YA(L) .LT. T(1,LY)) GO TO 235 + LY = NY + 235 IYU = LY - INPY + IYO = LY + INPY - 1 + IF (IYU .GE. 2) GO TO 240 + IYU = 2 + IYO = IYU + INPY + 240 IF (IYO .GT. NY) IYO = NY + IXU = LX - INPX + IXO = LX + INPX - 1 + IF (IXU .GE. 2) GO TO 245 + IXU = 2 + IXO = IXU + INPX + 245 IF (IXO .GT. NX) IXO = NX + IDX = IXO - IXU + 1 + IF (IXU .LT. IXO) GO TO 270 + IF (IYU .LT. IYO) GO TO 250 +C +C CONSTANT INTERPOLATION +C------------------------ + IF (LX .GT. 2 .AND. XA(L) .LT. T(NX,1)) LX = LX - 1 + IF (LY .GT. 2 .AND. YA(L) .LT. T(1,NY)) LY = LY - 1 + ZA(L) = T(LX,LY) + GO TO 400 +C +C LINEAR AND QUADRATIC INTERPOLATION USING ONEDINT (ONEDIMENSIONAL) +C--------------------------------------------------------------------- +C +C INTERPOLATION ONLY IN Y-DIRECTION +C + 250 IDY = 0 + DO 260 LL = IYU,IYO + IDY = IDY + 1 + Z1(IDY) = T(1,LL) + 260 Z2(IDY) = T(LX,LL) + GO TO 300 +C +C INTERPOLATION ONLY IN X-DIRECTION +C + 270 IF (IYU .LT. IYO) GO TO 280 + CALL ONEDINT(T(IXU,1),T(IXU,LY),IDX,XA(L),ZA(L),1,INPX,IEXP(1), + 1 IER) + IF (IER.eq.0) then + go to 400 + else + go to 900 + endif +C +C 1.INTERPOLATION STEP IN X-DIRECTION +C + 280 IDY = 0 + DO 290 LL = IYU,IYO + IDY = IDY + 1 + Z1(IDY) = T(1,LL) + CALL ONEDINT (T(IXU,1),T(IXU,LL),IDX,XA(L),Z2(IDY),1,INPX, + 1 IEXP(1),IER) + IF (IER.eq.0) then + go to 290 + else + go to 900 + endif + 290 CONTINUE +C +C 1.OR 2.INTERPOLATION STEP IN Y-DIRECTION +C + 300 CALL ONEDINT (Z1,Z2,IDY,YA(L),ZA(L),1,INPY,IEXP(2),IER) + IF (IER.eq.0) then + go to 400 + else + go to 900 + endif +C +C RETURN BY NORMAL PROCEEDING +C-------------------------------- + 400 CONTINUE + IER = 0 + RETURN +C +C ERROR RETURN +C------------- + 900 IER = -1 + RETURN + END diff -Nru calculix-ccx-2.1/ccx_2.3/src/two_phase_flow.f calculix-ccx-2.3/ccx_2.3/src/two_phase_flow.f --- calculix-ccx-2.1/ccx_2.3/src/two_phase_flow.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/two_phase_flow.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,267 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine two_phase_flow(Tt1,pt1,T1,Tt2,pt2,T2,xflow_air, + & xflow_oil,nelem,lakon,kon,ipkon,ielprop,prop,v, + & dvi_air,cp,r,k_oil,phi,lambda,nshcon,nrhcon,shcon + & ,rhcon,ntmat_,mi) +! +! two phase flow correlations +! + implicit none +! + character*8 lakon(*) +! + integer nelem,ielprop(*),index,mi(2), + & ipkon(*),kon(*),icase,kgas,k_oil,mtlog,ier,nshcon(*), + & nrhcon(*),ntmat_ +! + real*8 prop(*),v(0:mi(2),*),kappa,R,a,d,l, + & T1,T2,Tt1,Tt2,pt1,pt2,cp,dvi_air,dvi_oil, + & reynolds,lambda,ks,form_fact,f, + & l_neg,xflow_air,xflow_oil,A1,A2, + & rho_air,rho_oil,nue_air,nue_oil,zeta,reynolds_h,mpg, + & xp,xpm2,xpmini,isothermal,dvi_h,zeta_h,auxphi, + & rad,theta,phi,phizeta,x, + & rho_q,p1,shcon(0:3,ntmat_,*), + & rhcon(0:1,ntmat_,*),cp_oil,r_oil +! + parameter ( xpmini=1.E10) +! +! this subroutine enables to take in account the existence of +! 2 phase flows (air /oil) in some flow elements. +! +! the 2 following tables are used in Lockhart Martinelli Method. +! See table p.44 +! + real*8 TX(17),TF(17) + data TX + & /0.01d0,0.02d0,0.04d0,0.07d0, + & 0.10d0,0.20d0,0.40d0,0.70d0, + & 1.00d0,2.00d0,4.00d0,7.00d0, + & 10.0d0,20.0d0,40.0d0,70.0d0, + & 100.d0/ +! + data TF + & /1.28d0,1.37d0,1.54d0,1.71d0, + & 1.85d0,2.23d0,2.83d0,3.53d0, + & 4.20d0,6.20d0,9.50d0,13.7d0, + & 17.5d0,29.5d0,51.5d0,82.0d0, + & 111.d0/ +! + index=ielprop(nelem) + Tt2=Tt2 + pt2=pt2 + T2=t2 +! + if((lakon(nelem)(2:5).eq.'GAPF') + & .or.(lakon(nelem)(2:5).eq.'GAPI')) then + A=prop(index+1) + d=prop(index+2) + l=prop(index+3) + ks=prop(index+4) + form_fact=prop(index+5) + endif + + if(xflow_oil.eq.0) then + write(*,*) '*WARNING:in two_phase_flow' + write(*,*) 'massflow oil for element',nelem,'in null' + write(*,*) 'Calculation proceeds without oil correction' + phi=1.d0 + endif +! + + xflow_air=dabs(xflow_air) + kappa=Cp/(Cp-R) +! +! First case: +! the element is a restrictor of type +! THICK-WALLED ORIFICE IN LARGE WALL (L/DH > 0.015) +! I.E. IDL'CHIK (SECTION IV PAGE 144)! +! and +! Second case: +! the element is a restrictor of type +! SMOOTH BENDS B.H.R.A HANDBOOK (Miller) +! +! Two phase flow correlations are taken from: +! H.Zimmermann, A.Kammerer, R.Fischer and D. Rebhan +! "Two phase flow correlations in Air/Oil systems of +! Aero Engines." +! ASME 91-GT-54 +! + if((lakon(nelem)(2:7).eq.'RELOID').or. + & (lakon(nelem)(2:7).eq.'REBEMI')) then +! + icase=0 + + A1=prop(index+1) + A2=prop(index+2) + call ts_calc(xflow_air,Tt1,Pt1,kappa,r,A1,T1,icase) + + d=dsqrt(A1*4/(4.d0*datan(1.d0))) +! +! calculating the dynamic viscosity, the kinematic viscosity and +! the density of air +! + kgas=0 +! + P1=Pt1*(T1/Tt1)**(kappa/kappa-1) + rho_air=P1/(R*T1) + nue_air=dvi_air/rho_air +! +! calculating the dynamic viscosity, the kinematic viscosity and +! the density of oil +! + call materialdata_tg(k_oil,ntmat_,T1,shcon,nshcon,cp_oil,r_oil, + & dvi_oil,rhcon,nrhcon,rho_oil) +! + if(xflow_oil.eq.0) then +! +! pure air + call zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,Kappa,v,mi) + lambda=zeta + return + else +! +! air/oil mixture for orifice or bend +! For Bend see section 4.2.1 +! For orifices see 4.2.3 + + mpg = xflow_air +xflow_oil + xp=xflow_air/mpg + if(mpg.gt.xflow_air*xpmini) then + xpm2=xpmini**2 + else + xpm2=(mpg/xflow_air)**2 + endif +! + rho_q=rho_oil/rho_air +! +! homogene dynamic viscosity (mass flow rate averaged) + dvi_h=dvi_oil*dvi_air/((dvi_oil-dvi_air)*xp+dvi_air) +! +! homogene reynolds number + reynolds_h=mpg*d/(A1*dvi_h) +! + call zeta_calc(nelem,prop,ielprop,lakon,reynolds_h,zeta_h, + & isothermal,kon,ipkon,R,Kappa,v,mi) +! +! orifice in a wall + if(lakon(nelem)(2:7).eq.'RELOID') then + + auxphi=(1.d0+xp*(rho_q**(1.d0/6.d0)-1.d0)) + & *(1.d0+xp*(rho_q**(5.d0/6.d0)-1.d0)) +! +! bend + elseif(lakon(nelem)(2:7).eq.'REBEMI') then +! +! radius of the bend + rad=prop(index+4) +! angle of the bend + theta=prop(index+5) +! + f=(1.d0+2.2d0*theta/90.d0/(zeta_h*(2.d0+rad/d))) + & *xp*(1.d0-xp)+xp**2 +! + auxphi=1.d0+(rho_q-1.d0)*f + endif +! + phi=1/rho_q*auxphi*xpm2 + phizeta=zeta_h/rho_q*auxphi*xpm2 + lambda=zeta_h +! + endif + +! Third case: +! the element is a pipe +! the zeta coefficient is corrected according to +! Lockhart Martinelli Method +! Reference: R.W. Lockhart and R.C. Martinelli +! University of California, BErkeley, California +! "Proposed correlation of data for +! isothermal two-phase two-component +! flow in pipes" +! Chemical Engineering Progress vol.45, N°1 +! + elseif(((lakon(nelem)(2:5).eq.'GAPF') + & .or. (lakon(nelem)(2:5).eq.'GAPI')) + & .or.((lakon(nelem)(2:7).ne.'REBEMI') + & .and.(lakon(nelem)(2:7)).ne.'RELOID'))then +! + if((lakon(nelem)(2:6).eq.'GAPFA') + & .or.(lakon(nelem)(2:6).eq.'GAPIA'))then + icase=0 + elseif((lakon(nelem)(2:6).eq.'GAPFI') + & .or.(lakon(nelem)(2:6).eq.'GAPII'))then + icase=1 + else + icase=0 + endif +! + if((lakon(nelem)(2:3).eq.'RE').and. + & (lakon(nelem)(4:5).ne.'BR')) then + a=min(prop(index+1),prop(index+2)) + endif +! + call ts_calc(xflow_air,Tt1,Pt1,kappa,r,a,T1,icase) +! +! calculating kinematic viscosity and density for air +! + P1=Pt1*(T1/Tt1)**(kappa/kappa-1) + rho_air=P1/(R*T1) + nue_air=dvi_air/rho_air +! +! calculation of the dynamic viscosity for oil +! + call materialdata_tg(k_oil,ntmat_,T1,shcon,nshcon,cp_oil,r_oil, + & dvi_oil,rhcon,nrhcon,rho_oil) +! + nue_oil=dvi_oil/rho_oil +! +! Definition of the two phase flow modulus as defined in table 1 +! + x=dabs(xflow_oil/xflow_air)*(rho_air/rho_oil)**(0.553d0) + & *(nue_oil/nue_air)**(0.111d0) +! + mtlog=17 +! Interpolating x in the table + call onedint(TX,TF,mtlog,x,phi,1,2,11,IER) +! + if((lakon(nelem)(2:4).eq.'GAP'))then +! +! Computing the friction coefficient +! + reynolds=dabs(xflow_air)*d/(dvi_air*a) +! + if(reynolds.lt.100.d0) then + reynolds= 100.d0 + endif +! + call friction_coefficient(l_neg,d,ks,reynolds,form_fact, + & lambda) + else + lambda=0 + endif + endif +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/uamplitude.f calculix-ccx-2.3/ccx_2.3/src/uamplitude.f --- calculix-ccx-2.1/ccx_2.3/src/uamplitude.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/uamplitude.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,48 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine uamplitude(time,name,amplitude) +! +! user subroutine uamplitude: user defined amplitude definition +! +! INPUT: +! +! name amplitude name +! time time at which the amplitude is to be +! evaluated +! +! OUTPUT: +! +! amplitude value of the amplitude at time +! + implicit none +! + character*80 name +! + real*8 time,amplitude +! + if(name(1:9).eq.'QUADRATIC') then + amplitude=time**2 + else + write(*,*) '*ERROR in uamplitude: unknown amplitude' + stop + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/uboun.f calculix-ccx-2.3/ccx_2.3/src/uboun.f --- calculix-ccx-2.1/ccx_2.3/src/uboun.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/uboun.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,59 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine uboun(boun,kstep,kinc,time,node,idof,coords,vold,mi) +! +! user subroutine uboun +! +! +! INPUT: +! +! kstep step number +! kinc increment number +! time(1) current step time +! time(2) current total time +! node node number +! idof degree of freedom +! coords (1..3) global coordinates of the node +! vold(0..4,1..nk) solution field in all nodes +! 0: temperature +! 1: displacement in global x-direction +! (or mass flow rate for fluid nodes) +! 2: displacement in global y-direction +! 3: displacement in global z-direction +! 4: static pressure +! mi(1) max # of integration points per element (max +! over all elements) +! mi(2) max degree of freedomm per node (max over all +! nodes) in fields like v(0:mi(2))... +! +! OUTPUT: +! +! boun boundary value for degree of freedom idof +! in node "node" +! + implicit none +! + integer kstep,kinc,node,idof,mi(2) + real*8 boun,time(2),coords(3),vold(0:mi(2),*) +! + boun=10.d0 +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/u_calloc.c calculix-ccx-2.3/ccx_2.3/src/u_calloc.c --- calculix-ccx-2.1/ccx_2.3/src/u_calloc.c 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/u_calloc.c 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,42 @@ + +/* CalculiX - A 3-dimensional finite element program */ +/* Copyright (C) 1998-2007 Guido Dhondt */ + +/* This program is free software; you can redistribute it and/or */ +/* modify it under the terms of the GNU General Public License as */ +/* published by the Free Software Foundation(version 2); */ +/* */ + +/* This program is distributed in the hope that it will be useful, */ +/* but WITHOUT ANY WARRANTY; without even the implied warranty of */ +/* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the */ +/* GNU General Public License for more details. */ + +/* You should have received a copy of the GNU General Public License */ +/* along with this program; if not, write to the Free Software */ +/* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#include +#include +/* + Diehl program +*/ + +void *u_calloc(size_t num,size_t size){ + + void *a; + if(num==0){ + a=NULL; + return(a); + } + + a=calloc(num,size); + if(a==NULL){ + printf("*ERROR in u_calloc: error allocating memory\n"); + printf("num=%ld,size=%ld\n",num,size); + exit(16); + } + else { + return(a); + } +} diff -Nru calculix-ccx-2.1/ccx_2.3/src/ucreep.f calculix-ccx-2.3/ccx_2.3/src/ucreep.f --- calculix-ccx-2.1/ccx_2.3/src/ucreep.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ucreep.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,67 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine ucreep(amat,iel,iint,t1l,epini,ep,dtime,svm,dsvm) +! +! INPUT: +! +! amat: material name +! iel: element number +! iint: integration point number +! t1l: temperature +! epini: equivalent creep strain at the start +! of the increment +! ep: present equivalent creep strain; values of ep < epini +! are equivalent to ep=epini. +! dtime: time increment +! +! OUTPUT: +! +! svm: present Von Mises stress +! dsvm: derivative of the Von Mises true stress with respect +! to the present equivalent creep strain. +! Numerically: change the present equivalent +! strain with a small amount, calculate the amount +! of change this causes in the present Von Mises +! true stress, and divide the latter amount through the +! former amount. +! + implicit none +! + character*80 amat + real*8 t1l,epini,ep,dtime,svm,dsvm +! + integer iel,iint + if(ep.le.epini) then + svm=0.d0 + dsvm=1.d10 + else + svm=((ep-epini)/(dtime*1.d-10))**0.2d0 + dsvm=((ep-epini)/(dtime*1.d-10))**(-0.8d0)/(5.d-10*dtime) + endif +! + RETURN + end + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/ufaceload.f calculix-ccx-2.3/ccx_2.3/src/ufaceload.f --- calculix-ccx-2.1/ccx_2.3/src/ufaceload.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/ufaceload.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,54 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine ufaceload(co,ipkon,kon,lakon, + & nelemload,sideload,nload) +! +! +! INPUT: +! +! co(0..3,1..nk) coordinates of the nodes +! ipkon(*) element topology pointer into field kon +! kon(*) topology vector of all elements +! lakon(*) vector with elements labels +! nelemload(1..2,*) 1: elements faces of which are loaded +! 2: nodes for environmental temperatures +! sideload(*) load label +! nload number of facial distributed loads +! +! user routine called at the start of each step; possible use: +! calculation of the area of sets of elements for +! further use to calculate film or radiation coefficients. +! The areas can be shared using common blocks. +! + implicit none +! + character*8 lakon(*) + character*20 sideload(*) +! + integer nelemload(2,*),nload,kon(*),ipkon(*) +! + real*8 co(3,*) +! +! enter code here +! + return + end + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/uhardening.f calculix-ccx-2.3/ccx_2.3/src/uhardening.f --- calculix-ccx-2.1/ccx_2.3/src/uhardening.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/uhardening.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,53 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine uhardening(amat,iel,iint,t1l,epini,ep,dtime,fiso,dfiso, + & fkin,dfkin) +! +! hardening user subroutine +! +! INPUT: +! +! amat: material name (maximum 20 characters) +! iel: element number +! iint: integration point number +! t1l: temperature at the end of the increment +! epini: equivalent irreversible strain at the start +! of the increment +! ep: present equivalent irreversible strain +! dtime: time increment +! +! OUTPUT: +! +! fiso: present isotropic hardening Von Mises stress +! dfiso: present isotropic hardening tangent (derivative +! of the Von Mises stress with respect to the +! equivalent irreversible strain) +! fkin: present kinematic hardening Von Mises stress +! dfkin: present kinematic hardening tangent (derivative +! of the Von Mises stress with respect to the +! equivalent irreversible strain) +! + implicit none +! + character*80 amat + integer iel,iint + real*8 t1l,epini,ep,dtime,fiso,dfiso,fkin,dfkin +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_abaqus.f calculix-ccx-2.3/ccx_2.3/src/umat_abaqus.f --- calculix-ccx-2.1/ccx_2.3/src/umat_abaqus.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_abaqus.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,358 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_abaqus(amat,iel,iint,kode,elconloc,emec,emec0, + & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi,nstate_,xstateini,xstate,stre,stiff, + & iorien,pgauss,orab,kstep,kinc) +! +! calculates stiffness and stresses for a nonlinear material +! defined by an ABAQUS umat routine +! +! icmd=3: calculates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! +! This routine allows for the use of an ABAQUS umat user subroutine +! in CalculiX. +! +! Note that the following fields are not supported +! so far: sse,spd,scd,rpl,ddsddt,drplde,drpldt,predef, +! dpred,drot,pnewdt,celent,layer,kspt +! +! Furthermore, the following fields have a different meaning in +! ABAQUS and CalculiX: +! +! stran: in CalculiX: Lagrangian strain tensor +! in ABAQUS: logarithmic strain tensor +! dstran: in CalculiX: Lagrangian strain increment tensor +! in ABAQUS: logarithmic strain increment tensor +! temp: in CalculiX: temperature at the end of the increment +! in ABAQUS: temperature at the start of the increment +! dtemp: in CalculiX: zero +! in ABAQUS: temperature increment +! +! Because of this, this routine should only be used for small +! deformations and small rotations (in that case all strain +! measures basically reduce to the infinitesimal strain). +! + implicit none +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),i,iorien, + & ndi,nshr,ntens,nprops,layer,kspt,kstep,kinc,kal(2,6),kel(4,21), + & j1,j2,j3,j4,j5,j6,j7,j8,jj +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & time,ttime,skl(3,3),xa(3,3),ya(3,3,3,3),xstate(nstate_,mi(1),*), + & xstateini(nstate_,mi(1),*) +! + real*8 ddsdde(6,6),sse,spd,scd,rpl,ddsddt(6),drplde(6), + & drpldt,stran(6),dstran(6),abqtime(2),predef,temp,dtemp, + & dpred,drot(3,3),celent,pnewdt +! + data kal /1,1,2,2,3,3,1,2,1,3,2,3/ +! + data kel /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, + & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3, + & 3,3,1,3,1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3, + & 1,2,2,3,1,3,2,3,2,3,2,3/ +! + data drot /1.d0,0.d0,0.d0,0.d0,1.d0,0.d0,0.d0,0.d0,1.d0/ +! +! calculating the mechanical strain +! + do i=1,6 + stran(i)=emec0(i) + dstran(i)=emec(i)-emec0(i) + enddo +! + ntens=6 +! + do i=1,nstate_ + xstate(i,iint,iel)=xstateini(i,iint,iel) + enddo +! + abqtime(1)=time-dtime + abqtime(2)=ttime +! + temp=t1l + dtemp=0.d0 +! + ndi=3 + nshr=3 + ntens=ndi+nshr +! + nprops=-kode-100 +c nprops=21 +! +! taking local material orientations into account +! + if(iorien.ne.0) then + call transformatrix(orab(1,iorien),pgauss,skl) +! +! rotating the stress into the local system +! + xa(1,1)=stre(1) + xa(1,2)=stre(4) + xa(1,3)=stre(5) + xa(2,1)=stre(4) + xa(2,2)=stre(2) + xa(2,3)=stre(6) + xa(3,1)=stre(5) + xa(3,2)=stre(6) + xa(3,3)=stre(3) +! + do jj=1,6 + stre(jj)=0.d0 + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + stre(jj)=stre(jj)+ + & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) + enddo + enddo + enddo +! +! rotating the strain into the local system +! + xa(1,1)=stran(1) + xa(1,2)=stran(4) + xa(1,3)=stran(5) + xa(2,1)=stran(4) + xa(2,2)=stran(2) + xa(2,3)=stran(6) + xa(3,1)=stran(5) + xa(3,2)=stran(6) + xa(3,3)=stran(3) +! + do jj=1,6 + stran(jj)=0.d0 + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + stran(jj)=stran(jj)+ + & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) + enddo + enddo + enddo +! +! rotating the strain increment into the local system +! + xa(1,1)=dstran(1) + xa(1,2)=dstran(4) + xa(1,3)=dstran(5) + xa(2,1)=dstran(4) + xa(2,2)=dstran(2) + xa(2,3)=dstran(6) + xa(3,1)=dstran(5) + xa(3,2)=dstran(6) + xa(3,3)=dstran(3) +! + do jj=1,6 + dstran(jj)=0.d0 + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + dstran(jj)=dstran(jj)+ + & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) + enddo + enddo + enddo + endif +! +! changing physical strain into engineering strain +! + do i=4,6 + stran(i)=2.d0*stran(i) + dstran(i)=2.d0*dstran(i) + enddo +! + call umat(stre,xstate(1,iint,iel),ddsdde,sse,spd,scd,rpl,ddsddt, + & drplde,drpldt,stran,dstran,abqtime,dtime,temp,dtemp,predef, + & dpred,amat,ndi,nshr,ntens,nstate_,elconloc,nprops,pgauss,drot, + & pnewdt,celent,xokl,xkl,iel,iint,layer,kspt,kstep,kinc) +! +! taking local material orientations into account +! + if(iorien.ne.0) then +! +! rotating the stress into the global system +! + xa(1,1)=stre(1) + xa(1,2)=stre(4) + xa(1,3)=stre(5) + xa(2,1)=stre(4) + xa(2,2)=stre(2) + xa(2,3)=stre(6) + xa(3,1)=stre(5) + xa(3,2)=stre(6) + xa(3,3)=stre(3) +! + do jj=1,6 + stre(jj)=0.d0 + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + stre(jj)=stre(jj)+ + & xa(j3,j4)*skl(j1,j3)*skl(j2,j4) + enddo + enddo + enddo + endif +! +! calculate the stiffness matrix (the matrix is symmetrized) +! + if(icmd.ne.3) then + stiff(1)=ddsdde(1,1) + stiff(2)=(ddsdde(1,2)+ddsdde(2,1))/2.d0 + stiff(3)=ddsdde(2,2) + stiff(4)=(ddsdde(1,3)+ddsdde(3,1))/2.d0 + stiff(5)=(ddsdde(2,3)+ddsdde(3,2))/2.d0 + stiff(6)=ddsdde(3,3) + stiff(7)=(ddsdde(1,4)+ddsdde(4,1))/2.d0 + stiff(8)=(ddsdde(2,4)+ddsdde(4,2))/2.d0 + stiff(9)=(ddsdde(3,4)+ddsdde(4,3))/2.d0 + stiff(10)=ddsdde(4,4) + stiff(11)=(ddsdde(1,5)+ddsdde(5,1))/2.d0 + stiff(12)=(ddsdde(2,5)+ddsdde(5,2))/2.d0 + stiff(13)=(ddsdde(3,5)+ddsdde(5,3))/2.d0 + stiff(14)=(ddsdde(4,5)+ddsdde(5,4))/2.d0 + stiff(15)=ddsdde(5,5) + stiff(16)=(ddsdde(1,6)+ddsdde(6,1))/2.d0 + stiff(17)=(ddsdde(2,6)+ddsdde(6,2))/2.d0 + stiff(18)=(ddsdde(3,6)+ddsdde(6,3))/2.d0 + stiff(19)=(ddsdde(4,6)+ddsdde(6,4))/2.d0 + stiff(20)=(ddsdde(5,6)+ddsdde(6,5))/2.d0 + stiff(21)=ddsdde(6,6) +! + if(iorien.ne.0) then +! +! rotating the stiffness coefficients into the global system +! + call anisotropic(stiff,ya) +! + do jj=1,21 + j1=kel(1,jj) + j2=kel(2,jj) + j3=kel(3,jj) + j4=kel(4,jj) + stiff(jj)=0.d0 + do j5=1,3 + do j6=1,3 + do j7=1,3 + do j8=1,3 + stiff(jj)=stiff(jj)+ya(j5,j6,j7,j8)* + & skl(j1,j5)*skl(j2,j6)*skl(j3,j7)*skl(j4,j8) + enddo + enddo + enddo + enddo + enddo + endif + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_abaqusnl.f calculix-ccx-2.3/ccx_2.3/src/umat_abaqusnl.f --- calculix-ccx-2.1/ccx_2.3/src/umat_abaqusnl.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_abaqusnl.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,645 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_abaqusnl(amat,iel,iint,kode,elconloc,emec,emec0, + & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi,nstate_,xstateini,xstate,stre,stiff, + & iorien,pgauss,orab,kstep,kinc) +! +! calculates stiffness and stresses for a nonlinear material +! defined by an ABAQUS umat routine +! +! icmd=3: calcutates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! +! This routine allows for the use of an ABAQUS umat user subroutine +! in CalculiX. +! +! Note that the following fields are not supported +! so far: sse,spd,scd,rpl,ddsddt,drplde,drpldt,predef, +! dpred,pnewdt,celent,layer,kspt +! +! Furthermore, the following fields have a different meaning in +! ABAQUS and CalculiX: +! +! temp: in CalculiX: temperature at the end of the increment +! in ABAQUS: temperature at the start of the increment +! dtemp: in CalculiX: zero +! in ABAQUS: temperature increment +! + implicit none +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),i,iorien, + & ndi,nshr,ntens,nprops,layer,kspt,kstep,kinc,kal(2,6),kel(4,21), + & j1,j2,j3,j4,j5,j6,j7,j8,jj,n,ier,j,matz +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & time,ttime,skl(3,3),xa(3,3),ya(3,3,3,3),xstate(nstate_,mi(1),*), + & xstateini(nstate_,mi(1),*),w(3),fv1(3),fv2(3),d(6), + & v1,v2,v3,c(6),r(3,3),r0(3,3),eln0(6),eln(6),e(3,3),tkl(3,3), + & u(6),c2(6),dd,um1(3,3),z(3,3),u0(3,3) +! + real*8 ddsdde(6,6),sse,spd,scd,rpl,ddsddt(6),drplde(6), + & drpldt,stran(6),dstran(6),abqtime(2),predef,temp,dtemp, + & dpred,drot(3,3),celent,pnewdt +! + data kal /1,1,2,2,3,3,1,2,1,3,2,3/ +! + data kel /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, + & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3, + & 3,3,1,3,1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3, + & 1,2,2,3,1,3,2,3,2,3,2,3/ +! + data d /1.d0,1.d0,1.d0,0.d0,0.d0,0.d0/ +! +! calculating the logarithmic mechanical strain at the +! start of the increment +! + e(1,1)=emec0(1) + e(2,2)=emec0(2) + e(3,3)=emec0(3) + e(1,2)=emec0(4) + e(1,3)=emec0(5) + e(2,3)=emec0(6) + e(2,1)=emec0(4) + e(3,1)=emec0(5) + e(3,2)=emec0(6) +! +! calculating the eigenvalues and eigenvectors +! + n=3 + matz=1 +! + call rs(n,n,e,w,matz,z,fv1,fv2,ier) +! + if(ier.ne.0) then + write(*,*) ' + & *ERROR calculating the eigenvalues/vectors in umat_abaqusnl' + stop + endif +! +! calculating the principal stretches at the start of the increment +! + do i=1,3 + w(i)=dsqrt(2.d0*w(i)+1.d0) + enddo +! +! calculating the invariants at the start of the increment +! + v1=w(1)+w(2)+w(3) + v2=w(1)*w(2)+w(2)*w(3)+w(3)*w(1) + v3=w(1)*w(2)*w(3) +! +! calculating the right Cauchy-Green tensor at the start of the +! increment +! + do i=1,3 + c(i)=2.d0*emec0(i)+1.d0 + enddo + do i=4,6 + c(i)=2.d0*emec0(i) + enddo +! +! calculating the square of the right Cauchy-Green tensor at the +! start of the increment +! + c2(1)=c(1)*c(1)+c(4)*c(4)+c(5)*c(5) + c2(2)=c(4)*c(4)+c(2)*c(2)+c(6)*c(6) + c2(3)=c(5)*c(5)+c(6)*c(6)+c(3)*c(3) + c2(4)=c(1)*c(4)+c(4)*c(2)+c(5)*c(6) + c2(5)=c(1)*c(5)+c(4)*c(6)+c(5)*c(3) + c2(6)=c(4)*c(5)+c(2)*c(6)+c(6)*c(3) +! +! calculating the right stretch tensor at the start of the increment +! (cf. Simo and Hughes, Computational Inelasticity) +! + dd=v1*v2-v3 + do i=1,6 + u(i)=(-c2(i)+(v1*v1-v2)*c(i)+v1*v3*d(i))/dd + enddo +! + u0(1,1)=u(1) + u0(2,2)=u(2) + u0(3,3)=u(3) + u0(1,2)=u(4) + u0(1,3)=u(5) + u0(2,3)=u(6) + u0(2,1)=u(4) + u0(3,1)=u(5) + u0(3,2)=u(6) +! +! calculating the inverse of the right stretch tensor at the start +! of the increment +! + um1(1,1)=(c(1)-v1*u(1)+v2)/v3 + um1(2,2)=(c(2)-v1*u(2)+v2)/v3 + um1(3,3)=(c(3)-v1*u(3)+v2)/v3 + um1(1,2)=(c(4)-v1*u(4))/v3 + um1(1,3)=(c(5)-v1*u(5))/v3 + um1(2,3)=(c(6)-v1*u(6))/v3 + um1(2,1)=um1(1,2) + um1(3,1)=um1(1,3) + um1(3,2)=um1(2,3) +! +! calculation of the local rotation tensor at the start of the +! increment +! + do i=1,3 + do j=1,3 + r0(i,j)=xokl(i,1)*um1(1,j)+xokl(i,2)*um1(2,j)+ + & xokl(i,3)*um1(3,j) + enddo + enddo +! +! calculating the logarithmic strain at the start of the increment +! + do i=1,3 + w(i)=log(w(i)) + enddo +! +! logarithmic strain in global coordinates at the start of the +! increment +! + eln0(1)=z(1,1)*z(1,1)*w(1)+z(1,2)*z(1,2)*w(2)+ + & z(1,3)*z(1,3)*w(3) + eln0(2)=z(2,1)*z(2,1)*w(1)+z(2,2)*z(2,2)*w(2)+ + & z(2,3)*z(2,3)*w(3) + eln0(3)=z(3,1)*z(3,1)*w(1)+z(3,2)*z(3,2)*w(2)+ + & z(3,3)*z(3,3)*w(3) + eln0(4)=z(1,1)*z(2,1)*w(1)+z(1,2)*z(2,2)*w(2)+ + & z(1,3)*z(2,3)*w(3) + eln0(5)=z(1,1)*z(3,1)*w(1)+z(1,2)*z(3,2)*w(2)+ + & z(1,3)*z(3,3)*w(3) + eln0(6)=z(2,1)*z(3,1)*w(1)+z(2,2)*z(3,2)*w(2)+ + & z(2,3)*z(3,3)*w(3) +! +! calculating the logarithmic mechanical strain at the +! end of the increment +! + e(1,1)=emec(1) + e(2,2)=emec(2) + e(3,3)=emec(3) + e(1,2)=emec(4) + e(1,3)=emec(5) + e(2,3)=emec(6) + e(2,1)=emec(4) + e(3,1)=emec(5) + e(3,2)=emec(6) +! +! calculating the eigenvalues and eigenvectors +! + call rs(n,n,e,w,matz,z,fv1,fv2,ier) +! + if(ier.ne.0) then + write(*,*) ' + & *ERROR calculating the eigenvalues/vectors in umat_abaqusnl' + stop + endif +! +! calculating the principal stretches at the end of the increment +! + do i=1,3 + w(i)=dsqrt(2.d0*w(i)+1.d0) + enddo +! +! calculating the invariants at the end of the increment +! + v1=w(1)+w(2)+w(3) + v2=w(1)*w(2)+w(2)*w(3)+w(3)*w(1) + v3=w(1)*w(2)*w(3) +! +! calculating the right Cauchy-Green tensor at the end of the +! increment +! + do i=1,3 + c(i)=2.d0*emec0(i)+1.d0 + enddo + do i=4,6 + c(i)=2.d0*emec0(i) + enddo +! +! calculating the square of the right Cauchy-Green tensor at the +! end of the increment +! + c2(1)=c(1)*c(1)+c(4)*c(4)+c(5)*c(5) + c2(2)=c(4)*c(4)+c(2)*c(2)+c(6)*c(6) + c2(3)=c(5)*c(5)+c(6)*c(6)+c(3)*c(3) + c2(4)=c(1)*c(4)+c(4)*c(2)+c(5)*c(6) + c2(5)=c(1)*c(5)+c(4)*c(6)+c(5)*c(3) + c2(6)=c(4)*c(5)+c(2)*c(6)+c(6)*c(3) +! +! calculating the right stretch tensor at the end of the increment +! (cf. Simo and Hughes, Computational Inelasticity) +! + dd=v1*v2-v3 + do i=1,6 + u(i)=(-c2(i)+(v1*v1-v2)*c(i)+v1*v3*d(i))/dd + enddo +! +! calculating the inverse of the right stretch tensor at the end +! of the increment +! + um1(1,1)=(c(1)-v1*u(1)+v2)/v3 + um1(2,2)=(c(2)-v1*u(2)+v2)/v3 + um1(3,3)=(c(3)-v1*u(3)+v2)/v3 + um1(1,2)=(c(4)-v1*u(4))/v3 + um1(1,3)=(c(5)-v1*u(5))/v3 + um1(2,3)=(c(6)-v1*u(6))/v3 + um1(2,1)=um1(1,2) + um1(3,1)=um1(1,3) + um1(3,2)=um1(2,3) +! +! calculation of the local rotation tensor at the end of the +! increment +! + do i=1,3 + do j=1,3 + r(i,j)=xokl(i,1)*um1(1,j)+xokl(i,2)*um1(2,j)+ + & xokl(i,3)*um1(3,j) + enddo + enddo +! +! calculating the logarithmic strain at the end of the increment +! Elog=Z.ln(w).Z^T +! + do i=1,3 + w(i)=log(w(i)) + enddo +! +! logarithmic strain in global coordinates at the end of the +! increment +! + eln(1)=z(1,1)*z(1,1)*w(1)+z(1,2)*z(1,2)*w(2)+ + & z(1,3)*z(1,3)*w(3) + eln(2)=z(2,1)*z(2,1)*w(1)+z(2,2)*z(2,2)*w(2)+ + & z(2,3)*z(2,3)*w(3) + eln(3)=z(3,1)*z(3,1)*w(1)+z(3,2)*z(3,2)*w(2)+ + & z(3,3)*z(3,3)*w(3) + eln(4)=z(1,1)*z(2,1)*w(1)+z(1,2)*z(2,2)*w(2)+ + & z(1,3)*z(2,3)*w(3) + eln(5)=z(1,1)*z(3,1)*w(1)+z(1,2)*z(3,2)*w(2)+ + & z(1,3)*z(3,3)*w(3) + eln(6)=z(2,1)*z(3,1)*w(1)+z(2,2)*z(3,2)*w(2)+ + & z(2,3)*z(3,3)*w(3) +c write(*,*) 'iel', iel +c write(*,*) 'emec',(emec(i),i=1,6) +c write(*,*) 'eln',(eln(i),i=1,6) +c write(*,*) 'r0',((r0(i,j),j=1,3),i=1,3) +c write(*,*) 'r',((r(i,j),j=1,3),i=1,3) +! +! calculating the incremental rotation tensor +! drot=r.r0^T +! + do i=1,3 + do j=1,3 + drot(i,j)=r(i,1)*r0(j,1)+r(i,2)*r0(j,2)+r(i,3)*r0(j,3) + enddo + enddo +! + ntens=6 +! + do i=1,nstate_ + xstate(i,iint,iel)=xstateini(i,iint,iel) + enddo +! + abqtime(1)=time-dtime + abqtime(2)=ttime +! + temp=t1l + dtemp=0.d0 +! + ndi=3 + nshr=3 + ntens=ndi+nshr +! + nprops=-kode-100 +! +! taking local material orientations into account +! + if(iorien.ne.0) then + call transformatrix(orab(1,iorien),pgauss,skl) +! +! rotating the strain at the start of the increment +! into the local system: Elog'=T^T.Elog.T +! + xa(1,1)=eln0(1) + xa(1,2)=eln0(4) + xa(1,3)=eln0(5) + xa(2,1)=eln0(4) + xa(2,2)=eln0(2) + xa(2,3)=eln0(6) + xa(3,1)=eln0(5) + xa(3,2)=eln0(6) + xa(3,3)=eln0(3) +! + do jj=1,6 + stran(jj)=0.d0 + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + stran(jj)=stran(jj)+ + & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) + enddo + enddo + enddo +! +! rotating the strain at the end of the increment +! into the local system +! + xa(1,1)=eln(1) + xa(1,2)=eln(4) + xa(1,3)=eln(5) + xa(2,1)=eln(4) + xa(2,2)=eln(2) + xa(2,3)=eln(6) + xa(3,1)=eln(5) + xa(3,2)=eln(6) + xa(3,3)=eln(3) +! + do jj=1,6 + dstran(jj)=-stran(jj) + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + dstran(jj)=dstran(jj)+ + & xa(j3,j4)*skl(j3,j1)*skl(j4,j2) + enddo + enddo + enddo + else + do jj=1,6 + stran(jj)=eln0(jj) + dstran(jj)=eln(jj)-eln0(jj) + enddo + endif +! +! rotating the stress into the local system +! s'=J^(-1).U.S.U^T (no orientation card) or +! s'=J^(-1).U.T^T.S.T.U^T (orientation card) +! + if(iorien.ne.0) then + do i=1,3 + do j=1,3 + tkl(i,j)=u0(i,1)*skl(j,1)+u0(i,2)*skl(j,2)+ + & u0(i,3)*skl(j,3) + enddo + enddo + else + do i=1,3 + do j=1,3 + tkl(i,j)=u0(i,j) + enddo + enddo + endif +! + xa(1,1)=stre(1) + xa(1,2)=stre(4) + xa(1,3)=stre(5) + xa(2,1)=stre(4) + xa(2,2)=stre(2) + xa(2,3)=stre(6) + xa(3,1)=stre(5) + xa(3,2)=stre(6) + xa(3,3)=stre(3) +! + do jj=1,6 + stre(jj)=0.d0 + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + stre(jj)=stre(jj)+ + & xa(j3,j4)*tkl(j1,j3)*tkl(j2,j4) + enddo + enddo + stre(jj)=stre(jj)/voj + enddo +! +! changing physical strain into engineering strain +! ABAQUS uses the engineering strain! +! + do i=4,6 + stran(i)=2.d0*stran(i) + dstran(i)=2.d0*dstran(i) + enddo +! + call umat(stre,xstate(1,iint,iel),ddsdde,sse,spd,scd,rpl,ddsddt, + & drplde,drpldt,stran,dstran,abqtime,dtime,temp,dtemp,predef, + & dpred,amat,ndi,nshr,ntens,nstate_,elconloc,nprops,pgauss,drot, + & pnewdt,celent,xokl,xkl,iel,iint,layer,kspt,kstep,kinc) +! +! rotating the stress into the global system +! S=J.U^(-1).s'.U^(-T) (no orientation card) or +! S=J.T.U^(-1).s'.U^(-T).T^T (orientation card) +! + if(iorien.ne.0) then + do i=1,3 + do j=1,3 + tkl(i,j)=skl(i,1)*um1(1,j)+skl(i,2)*um1(2,j)+ + & skl(i,3)*um1(3,j) + enddo + enddo + else + do i=1,3 + do j=1,3 + tkl(i,j)=um1(i,j) + enddo + enddo + endif +! + xa(1,1)=stre(1) + xa(1,2)=stre(4) + xa(1,3)=stre(5) + xa(2,1)=stre(4) + xa(2,2)=stre(2) + xa(2,3)=stre(6) + xa(3,1)=stre(5) + xa(3,2)=stre(6) + xa(3,3)=stre(3) +! + do jj=1,6 + stre(jj)=0.d0 + j1=kal(1,jj) + j2=kal(2,jj) + do j3=1,3 + do j4=1,3 + stre(jj)=stre(jj)+ + & xa(j3,j4)*tkl(j1,j3)*tkl(j2,j4) + enddo + enddo + stre(jj)=stre(jj)*vj + enddo +! +! calculate the stiffness matrix (the matrix is symmetrized) +! + if(icmd.ne.3) then + stiff(1)=ddsdde(1,1) + stiff(2)=(ddsdde(1,2)+ddsdde(2,1))/2.d0 + stiff(3)=ddsdde(2,2) + stiff(4)=(ddsdde(1,3)+ddsdde(3,1))/2.d0 + stiff(5)=(ddsdde(2,3)+ddsdde(3,2))/2.d0 + stiff(6)=ddsdde(3,3) + stiff(7)=(ddsdde(1,4)+ddsdde(4,1))/2.d0 + stiff(8)=(ddsdde(2,4)+ddsdde(4,2))/2.d0 + stiff(9)=(ddsdde(3,4)+ddsdde(4,3))/2.d0 + stiff(10)=ddsdde(4,4) + stiff(11)=(ddsdde(1,5)+ddsdde(5,1))/2.d0 + stiff(12)=(ddsdde(2,5)+ddsdde(5,2))/2.d0 + stiff(13)=(ddsdde(3,5)+ddsdde(5,3))/2.d0 + stiff(14)=(ddsdde(4,5)+ddsdde(5,4))/2.d0 + stiff(15)=ddsdde(5,5) + stiff(16)=(ddsdde(1,6)+ddsdde(6,1))/2.d0 + stiff(17)=(ddsdde(2,6)+ddsdde(6,2))/2.d0 + stiff(18)=(ddsdde(3,6)+ddsdde(6,3))/2.d0 + stiff(19)=(ddsdde(4,6)+ddsdde(6,4))/2.d0 + stiff(20)=(ddsdde(5,6)+ddsdde(6,5))/2.d0 + stiff(21)=ddsdde(6,6) +c stiff(1)=ddsdde(1,1) +c stiff(2)=ddsdde(1,2) +c stiff(3)=ddsdde(2,2) +c stiff(4)=ddsdde(1,3) +c stiff(5)=ddsdde(2,3) +c stiff(6)=ddsdde(3,3) +c stiff(7)=ddsdde(1,4) +c stiff(8)=ddsdde(2,4) +c stiff(9)=ddsdde(3,4) +c stiff(10)=ddsdde(4,4) +c stiff(11)=ddsdde(1,5) +c stiff(12)=ddsdde(2,5) +c stiff(13)=ddsdde(3,5) +c stiff(14)=ddsdde(4,5) +c stiff(15)=ddsdde(5,5) +c stiff(16)=ddsdde(1,6) +c stiff(17)=ddsdde(2,6) +c stiff(18)=ddsdde(3,6) +c stiff(19)=ddsdde(4,6) +c stiff(20)=ddsdde(5,6) +c stiff(21)=ddsdde(6,6) +! +! rotating the stiffness coefficients into the global system +! + call anisotropic(stiff,ya) +! + do jj=1,21 + j1=kel(1,jj) + j2=kel(2,jj) + j3=kel(3,jj) + j4=kel(4,jj) + stiff(jj)=0.d0 + do j5=1,3 + do j6=1,3 + do j7=1,3 + do j8=1,3 + stiff(jj)=stiff(jj)+ya(j5,j6,j7,j8)* + & tkl(j1,j5)*tkl(j2,j6)*tkl(j3,j7)*tkl(j4,j8) + enddo + enddo + enddo + enddo + enddo + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_aniso_creep.f calculix-ccx-2.3/ccx_2.3/src/umat_aniso_creep.f --- calculix-ccx-2.1/ccx_2.3/src/umat_aniso_creep.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_aniso_creep.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1189 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_aniso_creep(amat,iel,iint,kode,elconloc,emec, + & emec0,beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas, + & mi,nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, + & orab) +! +! calculates stiffness and stresses for a user defined material +! law +! +! icmd=3: calculates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account: for +! creep this does not make sense. +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! Notice that the matrix is an integral part of the +! fourth order material tensor, i.e. the Voigt notation +! is not used. +! + implicit none +! + logical interval,cauchy,exitcriterion +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien +! + integer i,j,ipiv(6),info,neq,lda,ldb,j1,j2,j3,j4,j5,j6,j7,j8, + & nrhs,iplas,kel(4,21),iloop,leximp,lend,layer,kspt,kstep, + & kinc,ii +! + real*8 ep0(6),epqini,ep(6),b,Pn(6),dg,ddg,c(21),x(21),cm1(21), + & stri(6),htri,sg(6),r(13),ee(6),dd,gl(6,6),gr(6,6),c0,c1,c2, + & skl(3,3),gcreep,gm1,ya(3,3,3,3),dsg,detc,strinv, + & depq,svm,dsvm,dg1,dg2,fu,fu1,fu2,expon,ec(2), + & timeabq(2),r1(13),ep1(6),gl1(6,6),sg1(6),ckl(3,3) +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & time,ttime,decra(5),deswa(5),serd,esw(2),p,predef(1),dpred(1), + & dtemp +! + real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) +! + data kel /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, + & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3, + & 3,3,1,3,1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3, + & 1,2,2,3,1,3,2,3,2,3,2,3/ +! + data leximp /1/ + data lend /3/ +! + if(ithermal.eq.0) then + write(*,*)'*ERROR in umat_aniso_creep: no temperature defined;' + write(*,*) ' a creep calculation without temperature' + write(*,*) ' does not make sense' + write(*,*) + stop + endif +! + iloop=0 + exitcriterion=.false. +! + c0=dsqrt(2.d0/3.d0) + c1=2.d0/3.d0 + c2=-1.d0/3.d0 +! +! elastic constants +! + if(iorien.gt.0) then +! + call transformatrix(orab(1,iorien),pgauss,skl) +! + call orthotropic(elconloc,ya) +! + do j=1,21 + j1=kel(1,j) + j2=kel(2,j) + j3=kel(3,j) + j4=kel(4,j) + c(j)=0.d0 + do j5=1,3 + do j6=1,3 + do j7=1,3 + do j8=1,3 + c(j)=c(j)+ya(j5,j6,j7,j8)* + & skl(j1,j5)*skl(j2,j6)*skl(j3,j7)*skl(j4,j8) + enddo + enddo + enddo + enddo + enddo +! + else + do i=1,9 + c(i)=elconloc(i) + enddo + endif +! +! state variables +! +! equivalent plastic strain +! + epqini=xstateini(1,iint,iel) +! +! plastic strain +! + do i=1,6 + ep0(i)=xstateini(1+i,iint,iel) + enddo +c!start +c! inverse deformation gradient +c! +c ckl(1,1)=(xkl(2,2)*xkl(3,3)-xkl(2,3)*xkl(3,2))/vj +c ckl(2,2)=(xkl(1,1)*xkl(3,3)-xkl(1,3)*xkl(3,1))/vj +c ckl(3,3)=(xkl(1,1)*xkl(2,2)-xkl(1,2)*xkl(2,1))/vj +c ckl(1,2)=(xkl(1,3)*xkl(3,2)-xkl(1,2)*xkl(3,3))/vj +c ckl(1,3)=(xkl(1,2)*xkl(2,3)-xkl(2,2)*xkl(1,3))/vj +c ckl(2,3)=(xkl(2,1)*xkl(1,3)-xkl(1,1)*xkl(2,3))/vj +c ckl(2,1)=(xkl(3,1)*xkl(2,3)-xkl(2,1)*xkl(3,3))/vj +c ckl(3,1)=(xkl(2,1)*xkl(3,2)-xkl(2,2)*xkl(3,1))/vj +c ckl(3,2)=(xkl(3,1)*xkl(1,2)-xkl(1,1)*xkl(3,2))/vj +c! +c! converting the Lagrangian strain into Eulerian +c! strain +c! +c cauchy=.false. +c call str2mat(emec,ckl,vj,cauchy) +c!end +! elastic strains +! + do i=1,6 + ee(i)=emec(i)-ep0(i) + enddo +! +! global trial stress tensor +! + if(iorien.gt.0) then + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ + & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) + & -beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ + & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) + & -beta(2) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ + & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) + & -beta(3) + stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ + & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) + & -beta(4) + stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ + & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) + & -beta(5) + stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ + & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) + & -beta(6) + else + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) + stri(4)=2.d0*c(7)*ee(4)-beta(4) + stri(5)=2.d0*c(8)*ee(5)-beta(5) + stri(6)=2.d0*c(9)*ee(6)-beta(6) + endif +! +! stress radius (only deviatoric part of stress enters) +! + strinv=(stri(1)+stri(2)+stri(3))/3.d0 + do i=1,3 + sg(i)=stri(i)-strinv + enddo + do i=4,6 + sg(i)=stri(i) + enddo + dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ + & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) +! +! evaluation of the yield surface +! + ec(1)=epqini +! + htri=dsg +! +! check whether plasticity occurs +! +c if(htri.gt.0.d0) then + if(htri.gt.1.d-10) then + iplas=1 + else + iplas=0 + endif +! + if((iplas.eq.0).or.(ielas.eq.1)) then +! +! elastic stress +! + do i=1,6 + stre(i)=stri(i) + enddo +! +! elastic stiffness +! + if(icmd.ne.3) then + if(iorien.gt.0) then + do i=1,21 + stiff(i)=c(i) + enddo + else + stiff(1)=c(1) + stiff(2)=c(2) + stiff(3)=c(3) + stiff(4)=c(4) + stiff(5)=c(5) + stiff(6)=c(6) + stiff(7)=0.d0 + stiff(8)=0.d0 + stiff(9)=0.d0 + stiff(10)=c(7) + stiff(11)=0.d0 + stiff(12)=0.d0 + stiff(13)=0.d0 + stiff(14)=0.d0 + stiff(15)=c(8) + stiff(16)=0.d0 + stiff(17)=0.d0 + stiff(18)=0.d0 + stiff(19)=0.d0 + stiff(20)=0.d0 + stiff(21)=c(9) + endif + endif +! + return + endif +! +! plastic deformation +! + neq=6 + nrhs=1 + lda=6 + ldb=6 +! +! initializing the state variables +! + do i=1,6 + ep(i)=ep0(i) + enddo + dg=0.d0 +! +! determining the inverse of c +! + if(iorien.gt.0) then +! +! solve gl:C=gr +! + gl(1,1)=c(1) + gl(1,2)=c(2) + gl(2,2)=c(3) + gl(1,3)=c(4) + gl(2,3)=c(5) + gl(3,3)=c(6) + gl(1,4)=c(7) + gl(2,4)=c(8) + gl(3,4)=c(9) + gl(4,4)=c(10) + gl(1,5)=c(11) + gl(2,5)=c(12) + gl(3,5)=c(13) + gl(4,5)=c(14) + gl(5,5)=c(15) + gl(1,6)=c(16) + gl(2,6)=c(17) + gl(3,6)=c(18) + gl(4,6)=c(19) + gl(5,6)=c(20) + gl(6,6)=c(21) + do i=1,6 + do j=1,i-1 + gl(i,j)=gl(j,i) + enddo + enddo + do i=1,6 + do j=1,6 + gr(i,j)=0.d0 + enddo + gr(i,i)=1.d0 + enddo + nrhs=6 + call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif + nrhs=1 + cm1(1)=gr(1,1) + cm1(2)=gr(1,2) + cm1(3)=gr(2,2) + cm1(4)=gr(1,3) + cm1(5)=gr(2,3) + cm1(6)=gr(3,3) + cm1(7)=gr(1,4)/2.d0 + cm1(8)=gr(2,4)/2.d0 + cm1(9)=gr(3,4)/2.d0 + cm1(10)=gr(4,4)/4.d0 + cm1(11)=gr(1,5)/2.d0 + cm1(12)=gr(2,5)/2.d0 + cm1(13)=gr(3,5)/2.d0 + cm1(14)=gr(4,5)/4.d0 + cm1(15)=gr(5,5)/4.d0 + cm1(16)=gr(1,6)/2.d0 + cm1(17)=gr(2,6)/2.d0 + cm1(18)=gr(3,6)/2.d0 + cm1(19)=gr(4,6)/4.d0 + cm1(20)=gr(5,6)/4.d0 + cm1(21)=gr(6,6)/4.d0 + else + detc=c(1)*(c(3)*c(6)-c(5)*c(5))- + & c(2)*(c(2)*c(6)-c(4)*c(5))+ + & c(4)*(c(2)*c(5)-c(4)*c(3)) + cm1(1)=(c(3)*c(6)-c(5)*c(5))/detc + cm1(2)=(c(5)*c(4)-c(2)*c(6))/detc + cm1(3)=(c(1)*c(6)-c(4)*c(4))/detc + cm1(4)=(c(2)*c(5)-c(3)*c(4))/detc + cm1(5)=(c(2)*c(4)-c(1)*c(5))/detc + cm1(6)=(c(1)*c(3)-c(2)*c(2))/detc + cm1(7)=1.d0/(4.d0*c(7)) + cm1(8)=1.d0/(4.d0*c(8)) + cm1(9)=1.d0/(4.d0*c(9)) + endif +! +! first attempt: root search with Newton-Raphson +! + loop: do +! + iloop=iloop+1 +! +! elastic strains +! + do i=1,6 + ee(i)=emec(i)-ep(i) + enddo +! +! global trial stress tensor +! + if(iorien.gt.0) then + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ + & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) + & -beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ + & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) + & -beta(2) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ + & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) + & -beta(3) + stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ + & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) + & -beta(4) + stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ + & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) + & -beta(5) + stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ + & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) + & -beta(6) + else + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) + stri(4)=2.d0*c(7)*ee(4)-beta(4) + stri(5)=2.d0*c(8)*ee(5)-beta(5) + stri(6)=2.d0*c(9)*ee(6)-beta(6) + endif +! +! stress radius (only deviatoric part of stress enters) +! + strinv=(stri(1)+stri(2)+stri(3))/3.d0 + do i=1,3 + sg(i)=stri(i)-strinv + enddo + do i=4,6 + sg(i)=stri(i) + enddo + dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ + & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) +! +! evaluation of the yield surface +! + ec(1)=epqini + decra(1)=c0*dg + call creep(decra,deswa,xstateini(1,iint,iel),serd,ec, + & esw,p,svm,t1l,dtemp,predef,dpred,timeabq,dtime, + & amat,leximp,lend,pgauss,nstate_,iel,iint,layer,kspt, + & kstep,kinc) +! +! if the creep routine returns an increased value of decra(1) +! it means that there is a lower cut-off for decra(1); +! if the routine stays in a range lower than this cut-off, +! it will never leave it and the exit conditions are +! assumed to be satisfied. +! + if(decra(1).gt.c0*dg) then + dg=decra(1)/c0 + if(iloop.gt.1) exitcriterion=.true. + endif +! + htri=dsg-c0*svm +! + do i=1,6 + sg(i)=sg(i)/dsg + enddo +! +! determining the residual matrix +! + do i=1,6 + r(i)=ep0(i)-ep(i)+dg*sg(i) + enddo +! +! check convergence +! + if(exitcriterion) exit + if((dabs(htri).le.1.d-3).and. + & ((iloop.gt.1).and.((dabs(ddg).lt.1.d-10).or. + & (dabs(ddg).lt.1.d-3*dabs(dg))))) then + dd=0.d0 + do i=1,6 + dd=dd+r(i)*r(i) + enddo + dd=sqrt(dd) + if(dd.le.1.d-10) then + exit + endif + endif +! +! determining b.x +! + b=dg/dsg +! + x(1)=b*(c1-sg(1)*sg(1)) + x(2)=b*(c2-sg(1)*sg(2)) + x(3)=b*(c1-sg(2)*sg(2)) + x(4)=b*(c2-sg(1)*sg(3)) + x(5)=b*(c2-sg(2)*sg(3)) + x(6)=b*(c1-sg(3)*sg(3)) + x(7)=-b*sg(1)*sg(4) + x(8)=-b*sg(2)*sg(4) + x(9)=-b*sg(3)*sg(4) + x(10)=b*(.5d0-sg(4)*sg(4)) + x(11)=-b*sg(1)*sg(5) + x(12)=-b*sg(2)*sg(5) + x(13)=-b*sg(3)*sg(5) + x(14)=-b*sg(4)*sg(5) + x(15)=b*(.5d0-sg(5)*sg(5)) + x(16)=-b*sg(1)*sg(6) + x(17)=-b*sg(2)*sg(6) + x(18)=-b*sg(3)*sg(6) + x(19)=-b*sg(4)*sg(6) + x(20)=-b*sg(5)*sg(6) + x(21)=b*(.5d0-sg(6)*sg(6)) +! +! filling the LHS +! + if(iorien.gt.0) then + gl(1,1)=cm1(1)+x(1) + gl(1,2)=cm1(2)+x(2) + gl(2,2)=cm1(3)+x(3) + gl(1,3)=cm1(4)+x(4) + gl(2,3)=cm1(5)+x(5) + gl(3,3)=cm1(6)+x(6) + gl(1,4)=cm1(7)+x(7) + gl(2,4)=cm1(8)+x(8) + gl(3,4)=cm1(9)+x(9) + gl(4,4)=cm1(10)+x(10) + gl(1,5)=cm1(11)+x(11) + gl(2,5)=cm1(12)+x(12) + gl(3,5)=cm1(13)+x(13) + gl(4,5)=cm1(14)+x(14) + gl(5,5)=cm1(15)+x(15) + gl(1,6)=cm1(16)+x(16) + gl(2,6)=cm1(17)+x(17) + gl(3,6)=cm1(18)+x(18) + gl(4,6)=cm1(19)+x(19) + gl(5,6)=cm1(20)+x(20) + gl(6,6)=cm1(21)+x(21) + do i=1,6 + do j=1,i-1 + gl(i,j)=gl(j,i) + enddo + enddo + else + gl(1,1)=cm1(1)+x(1) + gl(1,2)=cm1(2)+x(2) + gl(2,2)=cm1(3)+x(3) + gl(1,3)=cm1(4)+x(4) + gl(2,3)=cm1(5)+x(5) + gl(3,3)=cm1(6)+x(6) + gl(1,4)=x(7) + gl(2,4)=x(8) + gl(3,4)=x(9) + gl(4,4)=cm1(7)+x(10) + gl(1,5)=x(11) + gl(2,5)=x(12) + gl(3,5)=x(13) + gl(4,5)=x(14) + gl(5,5)=cm1(8)+x(15) + gl(1,6)=x(16) + gl(2,6)=x(17) + gl(3,6)=x(18) + gl(4,6)=x(19) + gl(5,6)=x(20) + gl(6,6)=cm1(9)+x(21) + do i=1,6 + do j=1,i-1 + gl(i,j)=gl(j,i) + enddo + enddo + endif +! +! filling the RHS +! + do i=1,6 + gr(i,1)=sg(i) + enddo +! +! solve gl:(P:n)=gr +! + call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! + do i=1,6 + Pn(i)=gr(i,1) + enddo +! +! calculating the creep contribution +! + gcreep=c1/decra(5) +! +! calculating the correction to the consistency parameter +! + gm1=Pn(1)*sg(1)+Pn(2)*sg(2)+Pn(3)*sg(3)+ + & (Pn(4)*sg(4)+Pn(5)*sg(5)+Pn(6)*sg(6)) + gm1=1.d0/(gm1+gcreep) + ddg=gm1*(htri-(Pn(1)*r(1)+Pn(2)*r(2)+Pn(3)*r(3)+ + & (Pn(4)*r(4)+Pn(5)*r(5)+Pn(6)*r(6)))) +c if((iel.eq.380).and.(iint.eq.1)) then +c write(*,*) 'depq,svm ',decra(1),svm +c write(*,*) 'dg,ddg,gm1 ',dg,ddg,gm1 +c endif +! +! updating the residual matrix +! + do i=1,6 + r(i)=r(i)+ddg*sg(i) + enddo +! +! update the plastic strain +! + gr(1,1)=r(1) + gr(2,1)=r(2) + gr(3,1)=r(3) + gr(4,1)=r(4) + gr(5,1)=r(5) + gr(6,1)=r(6) +! + call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! + if(iorien.gt.0) then + ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+cm1(4)*gr(3,1)+ + & (cm1(7)*gr(4,1)+cm1(11)*gr(5,1)+cm1(16)*gr(6,1)) + ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+cm1(5)*gr(3,1)+ + & (cm1(8)*gr(4,1)+cm1(12)*gr(5,1)+cm1(17)*gr(6,1)) + ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+cm1(6)*gr(3,1)+ + & (cm1(9)*gr(4,1)+cm1(13)*gr(5,1)+cm1(18)*gr(6,1)) + ep(4)=ep(4)+cm1(7)*gr(1,1)+cm1(8)*gr(2,1)+cm1(9)*gr(3,1)+ + & (cm1(10)*gr(4,1)+cm1(14)*gr(5,1)+cm1(19)*gr(6,1)) + ep(5)=ep(5)+cm1(11)*gr(1,1)+cm1(12)*gr(2,1)+cm1(13)*gr(3,1)+ + & (cm1(14)*gr(4,1)+cm1(15)*gr(5,1)+cm1(20)*gr(6,1)) + ep(6)=ep(6)+cm1(16)*gr(1,1)+cm1(17)*gr(2,1)+cm1(18)*gr(3,1)+ + & (cm1(19)*gr(4,1)+cm1(20)*gr(5,1)+cm1(21)*gr(6,1)) + else + ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+cm1(4)*gr(3,1) + ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+cm1(5)*gr(3,1) + ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+cm1(6)*gr(3,1) + ep(4)=ep(4)+cm1(7)*gr(4,1) + ep(5)=ep(5)+cm1(8)*gr(5,1) + ep(6)=ep(6)+cm1(9)*gr(6,1) + endif +! +! update the consistency parameter +! + dg=dg+ddg +! +! end of major loop +! + if((iloop.gt.15).or.(dg.le.0.d0)) then +c write(*,*) dg,iloop,dsg,svm,iel,iint + iloop=1 + dg=0.d0 + do i=1,6 + ep(i)=ep0(i) + enddo +! +c write(*,*) 'second attempt' +! +! second attempt: root search through interval division +! + do +! +! elastic strains +! + do i=1,6 + ee(i)=emec(i)-ep(i) + enddo +! +! global trial stress tensor +! + if(iorien.gt.0) then + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ + & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) + & -beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ + & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) + & -beta(2) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ + & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) + & -beta(3) + stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ + & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) + & -beta(4) + stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ + & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) + & -beta(5) + stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ + & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) + & -beta(6) + else + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) + stri(4)=2.d0*c(7)*ee(4)-beta(4) + stri(5)=2.d0*c(8)*ee(5)-beta(5) + stri(6)=2.d0*c(9)*ee(6)-beta(6) + endif +! +! stress radius (only deviatoric part of stress enters) +! + strinv=(stri(1)+stri(2)+stri(3))/3.d0 + do i=1,3 + sg(i)=stri(i)-strinv + enddo + do i=4,6 + sg(i)=stri(i) + enddo + dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ + & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) +! +! evaluation of the yield surface +! + ec(1)=epqini + decra(1)=c0*dg + call creep(decra,deswa,xstateini(1,iint,iel),serd,ec, + & esw,p,svm,t1l,dtemp,predef,dpred,timeabq,dtime, + & amat,leximp,lend,pgauss,nstate_,iel,iint,layer,kspt, + & kstep,kinc) + if(decra(1).gt.c0*dg) then +c write(*,*) 'dg was changed from ',dg, +c & ' to ',decra(1)/c0 + dg=decra(1)/c0 + if(abs(iloop).gt.2) exitcriterion=.true. + endif +! +! needed in case decra(1) was changed in subroutine creep, +! for instance because it is too small +! + dg=decra(1)/c0 +! + htri=dsg-c0*svm +! + do i=1,6 + sg(i)=sg(i)/dsg + enddo +! +! determining the residual matrix +! + do i=1,6 + r(i)=ep0(i)-ep(i)+dg*sg(i) + enddo +! +! check convergence +! + if(exitcriterion) exit loop + if((dabs(htri).le.1.d-3).and. + & ((iloop.gt.2).and.((dabs(ddg).lt.1.d-10).or. + & (dabs(ddg).lt.1.d-3*dabs(dg))))) then + dd=0.d0 + do i=1,6 + dd=dd+r(i)*r(i) + enddo + dd=sqrt(dd) + if(dd.le.1.d-10) then + exit loop + endif + endif + if(iloop.gt.100) then + write(*,*) + & '*ERROR: no convergence in umat_aniso_creep' + write(*,*) ' iloop>100' + write(*,*) 'htri,dd ',htri,dd + exit loop + endif +! +! determining b.x +! + b=dg/dsg +! + x(1)=b*(c1-sg(1)*sg(1)) + x(2)=b*(c2-sg(1)*sg(2)) + x(3)=b*(c1-sg(2)*sg(2)) + x(4)=b*(c2-sg(1)*sg(3)) + x(5)=b*(c2-sg(2)*sg(3)) + x(6)=b*(c1-sg(3)*sg(3)) + x(7)=-b*sg(1)*sg(4) + x(8)=-b*sg(2)*sg(4) + x(9)=-b*sg(3)*sg(4) + x(10)=b*(.5d0-sg(4)*sg(4)) + x(11)=-b*sg(1)*sg(5) + x(12)=-b*sg(2)*sg(5) + x(13)=-b*sg(3)*sg(5) + x(14)=-b*sg(4)*sg(5) + x(15)=b*(.5d0-sg(5)*sg(5)) + x(16)=-b*sg(1)*sg(6) + x(17)=-b*sg(2)*sg(6) + x(18)=-b*sg(3)*sg(6) + x(19)=-b*sg(4)*sg(6) + x(20)=-b*sg(5)*sg(6) + x(21)=b*(.5d0-sg(6)*sg(6)) +! +! filling the LHS +! + if(iorien.gt.0) then + gl(1,1)=cm1(1)+x(1) + gl(1,2)=cm1(2)+x(2) + gl(2,2)=cm1(3)+x(3) + gl(1,3)=cm1(4)+x(4) + gl(2,3)=cm1(5)+x(5) + gl(3,3)=cm1(6)+x(6) + gl(1,4)=cm1(7)+x(7) + gl(2,4)=cm1(8)+x(8) + gl(3,4)=cm1(9)+x(9) + gl(4,4)=cm1(10)+x(10) + gl(1,5)=cm1(11)+x(11) + gl(2,5)=cm1(12)+x(12) + gl(3,5)=cm1(13)+x(13) + gl(4,5)=cm1(14)+x(14) + gl(5,5)=cm1(15)+x(15) + gl(1,6)=cm1(16)+x(16) + gl(2,6)=cm1(17)+x(17) + gl(3,6)=cm1(18)+x(18) + gl(4,6)=cm1(19)+x(19) + gl(5,6)=cm1(20)+x(20) + gl(6,6)=cm1(21)+x(21) + do i=1,6 + do j=1,i-1 + gl(i,j)=gl(j,i) + enddo + enddo + else + gl(1,1)=cm1(1)+x(1) + gl(1,2)=cm1(2)+x(2) + gl(2,2)=cm1(3)+x(3) + gl(1,3)=cm1(4)+x(4) + gl(2,3)=cm1(5)+x(5) + gl(3,3)=cm1(6)+x(6) + gl(1,4)=x(7) + gl(2,4)=x(8) + gl(3,4)=x(9) + gl(4,4)=cm1(7)+x(10) + gl(1,5)=x(11) + gl(2,5)=x(12) + gl(3,5)=x(13) + gl(4,5)=x(14) + gl(5,5)=cm1(8)+x(15) + gl(1,6)=x(16) + gl(2,6)=x(17) + gl(3,6)=x(18) + gl(4,6)=x(19) + gl(5,6)=x(20) + gl(6,6)=cm1(9)+x(21) + do i=1,6 + do j=1,i-1 + gl(i,j)=gl(j,i) + enddo + enddo + endif +! +! filling the RHS +! + do i=1,6 + gr(i,1)=sg(i) + enddo +! +! solve gl:(P:n)=gr +! + call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! + do i=1,6 + Pn(i)=gr(i,1) + enddo +! +! calculating the creep contribution +! + gcreep=c1/decra(5) +! +! calculating the correction to the consistency parameter +! + gm1=Pn(1)*sg(1)+Pn(2)*sg(2)+Pn(3)*sg(3)+ + & (Pn(4)*sg(4)+Pn(5)*sg(5)+Pn(6)*sg(6)) + gm1=1.d0/(gm1+gcreep) + fu=(htri-(Pn(1)*r(1)+Pn(2)*r(2)+Pn(3)*r(3)+ + & (Pn(4)*r(4)+Pn(5)*r(5)+Pn(6)*r(6)))) +! + if(iloop.eq.1) then +c write(*,*) 'iloop,dg,fu ',iloop,dg,fu + dg1=0.d0 + fu1=fu + iloop=2 + dg=1.d-10 + ddg=dg + do i=1,6 + ep1(i)=ep(i) + r1(i)=r(i) + sg1(i)=sg(i) + do j=1,6 + gl1(i,j)=gl(i,j) + enddo + enddo + elseif((iloop.eq.2).or.(iloop.lt.0)) then + if(fu*fu1.lt.0.d0) then +c write(*,*) 'iloop,dg,fu ',iloop,dg,fu + if(iloop.eq.2) then + iloop=3 + else + iloop=-iloop+1 + endif + fu2=fu + dg2=dg + dg=(dg1+dg2)/2.d0 + ddg=(dg2-dg1)/2.d0 + do i=1,6 + ep(i)=ep1(i) + r(i)=r1(i) + sg(i)=sg1(i) + do j=1,6 + gl(i,j)=gl1(i,j) + enddo + enddo + else +c write(*,*) 'iloop,dg,fu ',iloop,dg,fu +c dg1=dg +c fu1=fu + if(iloop.eq.2) then + if(dabs(fu).gt.dabs(fu1)) exitcriterion=.true. + dg1=dg + fu1=fu + ddg=dg*9.d0 + dg=dg*10.d0 + else + dg1=dg + fu1=fu + dg=dg+ddg + iloop=iloop-1 + endif + if(dg.gt.10.1d0) then + write(*,*) + & '*ERROR: no convergence in umat_aniso_creep' + write(*,*) ' dg>10.' + stop + endif + do i=1,6 + ep1(i)=ep(i) + r1(i)=r(i) + sg1(i)=sg(i) + do j=1,6 + gl1(i,j)=gl(i,j) + enddo + enddo + endif + else +c write(*,*) 'iloop,dg,fu ',iloop,dg,fu + if(fu*fu1.ge.0.d0) then + dg1=dg + fu1=fu + dg=(dg1+dg2)/2.d0 + ddg=(dg2-dg1)/2.d0 + do i=1,6 + ep1(i)=ep(i) + r1(i)=r(i) + sg1(i)=sg(i) + do j=1,6 + gl1(i,j)=gl(i,j) + enddo + enddo + iloop=-iloop-1 + else + dg2=dg + fu2=fu + dg=(dg1+dg2)/2.d0 + ddg=(dg2-dg1)/2.d0 + do i=1,6 + ep(i)=ep1(i) + r(i)=r1(i) + sg(i)=sg1(i) + do j=1,6 + gl(i,j)=gl1(i,j) + enddo + enddo + iloop=iloop+1 + endif + endif +! +! updating the residual matrix +! + do i=1,6 + r(i)=r(i)+ddg*sg(i) + enddo +! +! update the plastic strain +! + gr(1,1)=r(1) + gr(2,1)=r(2) + gr(3,1)=r(3) + gr(4,1)=r(4) + gr(5,1)=r(5) + gr(6,1)=r(6) +! + call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb, + & info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! + if(iorien.gt.0) then + ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+ + & cm1(4)*gr(3,1)+ + & (cm1(7)*gr(4,1)+cm1(11)*gr(5,1)+ + & cm1(16)*gr(6,1)) + ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+ + & cm1(5)*gr(3,1)+ + & (cm1(8)*gr(4,1)+cm1(12)*gr(5,1)+ + & cm1(17)*gr(6,1)) + ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1) + & +cm1(6)*gr(3,1)+ + & (cm1(9)*gr(4,1)+cm1(13)*gr(5,1)+ + & cm1(18)*gr(6,1)) + ep(4)=ep(4)+cm1(7)*gr(1,1)+cm1(8)*gr(2,1)+ + & cm1(9)*gr(3,1)+ + & (cm1(10)*gr(4,1)+cm1(14)*gr(5,1)+ + & cm1(19)*gr(6,1)) + ep(5)=ep(5)+cm1(11)*gr(1,1)+cm1(12)*gr(2,1)+ + & cm1(13)*gr(3,1)+ + & (cm1(14)*gr(4,1)+cm1(15)*gr(5,1)+ + & cm1(20)*gr(6,1)) + ep(6)=ep(6)+cm1(16)*gr(1,1)+cm1(17)*gr(2,1)+ + & cm1(18)*gr(3,1)+ + & (cm1(19)*gr(4,1)+cm1(20)*gr(5,1)+ + & cm1(21)*gr(6,1)) + else + ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+ + & cm1(4)*gr(3,1) + ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+ + & cm1(5)*gr(3,1) + ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+ + & cm1(6)*gr(3,1) + ep(4)=ep(4)+cm1(7)*gr(4,1) + ep(5)=ep(5)+cm1(8)*gr(5,1) + ep(6)=ep(6)+cm1(9)*gr(6,1) + endif +! +! end of major loop +! + enddo +! + endif +! + enddo loop +! +! storing the stress +! + do i=1,6 + stre(i)=stri(i) + enddo +! +! converting the stress into the material frame of +! reference +! +c cauchy=.true. +c call str2mat(stre,ckl,vj,cauchy) +! +! calculating the tangent stiffness matrix +! + if(icmd.ne.3) then +! +! determining p +! + gr(1,1)=1.d0 + gr(1,2)=0. + gr(2,2)=1.d0 + gr(1,3)=0. + gr(2,3)=0. + gr(3,3)=1.d0 + gr(1,4)=0. + gr(2,4)=0. + gr(3,4)=0. + gr(4,4)=1.d0 + gr(1,5)=0. + gr(2,5)=0. + gr(3,5)=0. + gr(4,5)=0. + gr(5,5)=1.d0 + gr(1,6)=0. + gr(2,6)=0. + gr(3,6)=0. + gr(4,6)=0. + gr(5,6)=0. + gr(6,6)=1.d0 + do i=1,6 + do j=1,i-1 + gr(i,j)=gr(j,i) + enddo + enddo + nrhs=6 +! + call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! + stiff(1)=gr(1,1)-gm1*Pn(1)*Pn(1) + stiff(2)=gr(1,2)-gm1*Pn(1)*Pn(2) + stiff(3)=gr(2,2)-gm1*Pn(2)*Pn(2) + stiff(4)=gr(1,3)-gm1*Pn(1)*Pn(3) + stiff(5)=gr(2,3)-gm1*Pn(2)*Pn(3) + stiff(6)=gr(3,3)-gm1*Pn(3)*Pn(3) + stiff(7)=(gr(1,4)-gm1*Pn(1)*Pn(4))/2.d0 + stiff(8)=(gr(2,4)-gm1*Pn(2)*Pn(4))/2.d0 + stiff(9)=(gr(3,4)-gm1*Pn(3)*Pn(4))/2.d0 + stiff(10)=(gr(4,4)-gm1*Pn(4)*Pn(4))/4.d0 + stiff(11)=(gr(1,5)-gm1*Pn(1)*Pn(5))/2.d0 + stiff(12)=(gr(2,5)-gm1*Pn(2)*Pn(5))/2.d0 + stiff(13)=(gr(3,5)-gm1*Pn(3)*Pn(5))/2.d0 + stiff(14)=(gr(4,5)-gm1*Pn(4)*Pn(5))/4.d0 + stiff(15)=(gr(5,5)-gm1*Pn(5)*Pn(5))/4.d0 + stiff(16)=(gr(1,6)-gm1*Pn(1)*Pn(6))/2.d0 + stiff(17)=(gr(2,6)-gm1*Pn(2)*Pn(6))/2.d0 + stiff(18)=(gr(3,6)-gm1*Pn(3)*Pn(6))/2.d0 + stiff(19)=(gr(4,6)-gm1*Pn(4)*Pn(6))/4.d0 + stiff(20)=(gr(5,6)-gm1*Pn(5)*Pn(6))/4.d0 + stiff(21)=(gr(6,6)-gm1*Pn(6)*Pn(6))/4.d0 +c!start +c! conversion of the stiffness matrix from spatial coordinates +c! coordinates into material coordinates +c! +c call stiff2mat(stiff,ckl,vj,cauchy) +c!end + endif +! +! updating the state variables +! + xstate(1,iint,iel)=epqini+c0*dg + do i=1,6 + xstate(1+i,iint,iel)=ep(i) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_aniso_plas.f calculix-ccx-2.3/ccx_2.3/src/umat_aniso_plas.f --- calculix-ccx-2.1/ccx_2.3/src/umat_aniso_plas.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_aniso_plas.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1097 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_aniso_plas(amat,iel,iint,kode,elconloc,emec, + & emec0,beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas, + & mi,nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, + & orab) +! +! calculates stiffness and stresses for a user defined material +! law +! +! icmd=3: calcutates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! Notice that the matrix is an integral part of the +! fourth order material tensor, i.e. the Voigt notation +! is not used. +! + implicit none +! + logical creep +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien +! + integer i,j,ipiv(6),info,neq,lda,ldb,j1,j2,j3,j4,j5,j6,j7,j8, + & nrhs,iplas,kel(4,21) +! + real*8 ep0(6),al10,al20(6),eeq,ep(6),al1,b,Pn(6),QSn(6), + & al2(6),dg,ddg,ca,cn,c(21),r0,x(21),cm1(21),h1,h2, + & q1,q2(6),stri(6),htri,sg(6),r(13),au1(21),au2(21), + & ee(6),dd,gl(6,6),gr(6,6),c0,c1,c2,c3,c4,c5,c6, + & skl(3,3),gcreep,gm1,ya(3,3,3,3),d1,d2,dsg,detc,strinv +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & time,ttime +! + real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) +! + data kel /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, + & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3, + & 3,3,1,3,1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3, + & 1,2,2,3,1,3,2,3,2,3,2,3/ +! + c0=dsqrt(2.d0/3.d0) + c1=2.d0/3.d0 + c2=-1.d0/3.d0 +! +! elastic constants +! + if(iorien.gt.0) then +! + call transformatrix(orab(1,iorien),pgauss,skl) +! + call orthotropic(elconloc,ya) +! + do j=1,21 + j1=kel(1,j) + j2=kel(2,j) + j3=kel(3,j) + j4=kel(4,j) + c(j)=0.d0 + do j5=1,3 + do j6=1,3 + do j7=1,3 + do j8=1,3 + c(j)=c(j)+ya(j5,j6,j7,j8)* + & skl(j1,j5)*skl(j2,j6)*skl(j3,j7)*skl(j4,j8) + enddo + enddo + enddo + enddo + enddo +! + else + do i=1,9 + c(i)=elconloc(i) + enddo + endif +! +! state variables +! +! equivalent plastic strain +! + eeq=xstateini(1,iint,iel) +! +! plastic strain +! + do i=1,6 + ep0(i)=xstateini(1+i,iint,iel) + enddo +! +! isotropic hardening variable +! + al10=xstateini(8,iint,iel) +! +! kinematic hardening variable +! + do i=1,6 + al20(i)=xstateini(8+i,iint,iel) + enddo +! + if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) 'element, int.point,kstep,kinc ',iel,iint + endif +! +! elastic strains +! + do i=1,6 + ee(i)=emec(i)-ep0(i) + enddo + if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) 'emec ',(emec(i),i=1,6) +c write(*,*) 'ep0 ',(ep0(i),i=1,6) +c write(*,*) 'ee ',(ee(i),i=1,6) + endif +! +! (visco)plastic constants +! + r0=elconloc(10) + d1=elconloc(11) + d2=elconloc(12) + ca=c0/(elconloc(13)*ttime**elconloc(15)*dtime) + cn=elconloc(14) +! + if(ca.lt.0.d0) then + creep=.false. + else + creep=.true. + endif +! + h1=d1 + h2=2.d0*d2/3.d0 +! +! stress state variables q1 and q2 +! + q1=-d1*al10 + do i=1,6 + q2(i)=-d2*al20(i) + enddo + if((iint.eq.1).and.(iel.eq.1)) then +c write(*,200) q1 +c 200 format('q10 ',/,(6(1x,e11.4))) +c write(*,201) (q2(i),i=1,6) +c 201 format('q20 ',/,(6(1x,e11.4))) + endif +! +! global trial stress tensor +! + if(iorien.gt.0) then + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ + & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) + & -beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ + & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) + & -beta(2) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ + & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) + & -beta(3) + stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ + & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) + & -beta(4) + stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ + & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) + & -beta(5) + stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ + & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) + & -beta(6) + else + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) + stri(4)=2.d0*c(7)*ee(4)-beta(4) + stri(5)=2.d0*c(8)*ee(5)-beta(5) + stri(6)=2.d0*c(9)*ee(6)-beta(6) + endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) 'stri ',(stri(i),i=1,6) +c endif +! +! stress radius (only deviatoric part of stress enters) +! +c do i=1,6 +c sgold(i)=0.d0 +c enddo + strinv=(stri(1)+stri(2)+stri(3))/3.d0 + do i=1,3 + sg(i)=stri(i)-strinv+q2(i) + enddo + do i=4,6 + sg(i)=stri(i)+q2(i) + enddo + dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ + & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) +! +! evaluation of the yield surface +! + htri=dsg+c0*(q1-r0) +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) 'htri ',htri +c endif +! +! check whether plasticity occurs +! + if(htri.gt.0.d0) then + iplas=1 + else + iplas=0 + endif +! + if((iplas.eq.0).or.(ielas.eq.1)) then +! +! elastic stress +! + do i=1,6 + stre(i)=stri(i) + enddo +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) ' stress ' +c write(*,'(6(1x,e11.4))') (stre(i),i=1,6) +c endif +! +! elastic stiffness +! + if(icmd.ne.3) then + if(iorien.gt.0) then + do i=1,21 + stiff(i)=c(i) + enddo + else + stiff(1)=c(1) + stiff(2)=c(2) + stiff(3)=c(3) + stiff(4)=c(4) + stiff(5)=c(5) + stiff(6)=c(6) + stiff(7)=0.d0 + stiff(8)=0.d0 + stiff(9)=0.d0 + stiff(10)=c(7) + stiff(11)=0.d0 + stiff(12)=0.d0 + stiff(13)=0.d0 + stiff(14)=0.d0 + stiff(15)=c(8) + stiff(16)=0.d0 + stiff(17)=0.d0 + stiff(18)=0.d0 + stiff(19)=0.d0 + stiff(20)=0.d0 + stiff(21)=c(9) + endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) 'stiffness ' +c write(*,'(6(1x,e11.4))') (stiff(i),i=1,21) +c endif + endif +! + return + endif +! +! plastic deformation +! + neq=6 + nrhs=1 + lda=6 + ldb=6 +! +! initializing the state variables +! + do i=1,6 + ep(i)=ep0(i) + enddo + al1=al10 + do i=1,6 + al2(i)=al20(i) + enddo + dg=0.d0 + ddg=0.d0 +! +! determining the inverse of c +! + if(iorien.gt.0) then +! +! solve gl:C=gr +! + gl(1,1)=c(1) + gl(1,2)=c(2) + gl(2,2)=c(3) + gl(1,3)=c(4) + gl(2,3)=c(5) + gl(3,3)=c(6) + gl(1,4)=c(7) + gl(2,4)=c(8) + gl(3,4)=c(9) + gl(4,4)=c(10) + gl(1,5)=c(11) + gl(2,5)=c(12) + gl(3,5)=c(13) + gl(4,5)=c(14) + gl(5,5)=c(15) + gl(1,6)=c(16) + gl(2,6)=c(17) + gl(3,6)=c(18) + gl(4,6)=c(19) + gl(5,6)=c(20) + gl(6,6)=c(21) + do i=1,6 + do j=1,i-1 + gl(i,j)=gl(j,i) + enddo + enddo + do i=1,6 + do j=4,6 + gl(i,j)=2.d0*gl(i,j) + enddo + enddo + do i=1,6 + do j=1,6 + gr(i,j)=0.d0 + enddo + if(i.le.3) then + gr(i,i)=1.d0 + else + gr(i,i)=0.5d0 + endif + enddo + nrhs=6 + call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif + nrhs=1 + cm1(1)=gr(1,1) + cm1(2)=gr(1,2) + cm1(3)=gr(2,2) + cm1(4)=gr(1,3) + cm1(5)=gr(2,3) + cm1(6)=gr(3,3) + cm1(7)=gr(1,4) + cm1(8)=gr(2,4) + cm1(9)=gr(3,4) + cm1(10)=gr(4,4) + cm1(11)=gr(1,5) + cm1(12)=gr(2,5) + cm1(13)=gr(3,5) + cm1(14)=gr(4,5) + cm1(15)=gr(5,5) + cm1(16)=gr(1,6) + cm1(17)=gr(2,6) + cm1(18)=gr(3,6) + cm1(19)=gr(4,6) + cm1(20)=gr(5,6) + cm1(21)=gr(6,6) + else + detc=c(1)*(c(3)*c(6)-c(5)*c(5))- + & c(2)*(c(2)*c(6)-c(4)*c(5))+ + & c(4)*(c(2)*c(5)-c(4)*c(3)) + cm1(1)=(c(3)*c(6)-c(5)*c(5))/detc + cm1(2)=(c(5)*c(4)-c(2)*c(6))/detc + cm1(3)=(c(1)*c(6)-c(4)*c(4))/detc + cm1(4)=(c(2)*c(5)-c(3)*c(4))/detc + cm1(5)=(c(2)*c(4)-c(1)*c(5))/detc + cm1(6)=(c(1)*c(3)-c(2)*c(2))/detc + cm1(7)=1.d0/(4.d0*c(7)) + cm1(8)=1.d0/(4.d0*c(8)) + cm1(9)=1.d0/(4.d0*c(9)) + endif +! +! loop +! + if((iint.eq.1).and.(iel.eq.1)) then +c write(*,202) dg +c 202 format('dg ',/,(6(1x,e11.4))) + endif + do +! +! elastic strains +! + do i=1,6 + ee(i)=emec(i)-ep(i) + enddo +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,605) (emec(i),i=1,6) +c 605 format('emec ',/,(6(1x,e11.4))) +c endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,606) (ep(i),i=1,6) +c 606 format('ep ',/,(6(1x,e11.4))) +c endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,607) (ee(i),i=1,6) +c 607 format('ee ',/,(6(1x,e11.4))) +c endif +! +! stress state variables q1 and q2 +! + q1=-d1*al1 + do i=1,6 + q2(i)=-d2*al2(i) + enddo +! +! global trial stress tensor +! + if(iorien.gt.0) then + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)+ + & 2.d0*(c(7)*ee(4)+c(11)*ee(5)+c(16)*ee(6)) + & -beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)+ + & 2.d0*(c(8)*ee(4)+c(12)*ee(5)+c(17)*ee(6)) + & -beta(2) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)+ + & 2.d0*(c(9)*ee(4)+c(13)*ee(5)+c(18)*ee(6)) + & -beta(3) + stri(4)=c(7)*ee(1)+c(8)*ee(2)+c(9)*ee(3)+ + & 2.d0*(c(10)*ee(4)+c(14)*ee(5)+c(19)*ee(6)) + & -beta(4) + stri(5)=c(11)*ee(1)+c(12)*ee(2)+c(13)*ee(3)+ + & 2.d0*(c(14)*ee(4)+c(15)*ee(5)+c(20)*ee(6)) + & -beta(5) + stri(6)=c(16)*ee(1)+c(17)*ee(2)+c(18)*ee(3)+ + & 2.d0*(c(19)*ee(4)+c(20)*ee(5)+c(21)*ee(6)) + & -beta(6) + else + stri(1)=c(1)*ee(1)+c(2)*ee(2)+c(4)*ee(3)-beta(1) + stri(2)=c(2)*ee(1)+c(3)*ee(2)+c(5)*ee(3)-beta(1) + stri(3)=c(4)*ee(1)+c(5)*ee(2)+c(6)*ee(3)-beta(1) + stri(4)=2.d0*c(7)*ee(4)-beta(4) + stri(5)=2.d0*c(8)*ee(5)-beta(5) + stri(6)=2.d0*c(9)*ee(6)-beta(6) + endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,805) (stri(i),i=1,6) +c 805 format('stri ',/,(6(1x,e11.4))) +c endif +! +! stress radius (only deviatoric part of stress enters) +! + strinv=(stri(1)+stri(2)+stri(3))/3.d0 + do i=1,3 + sg(i)=stri(i)-strinv+q2(i) + enddo + do i=4,6 + sg(i)=stri(i)+q2(i) + enddo + dsg=dsqrt(sg(1)*sg(1)+sg(2)*sg(2)+sg(3)*sg(3)+ + & 2.d0*(sg(4)*sg(4)+sg(5)*sg(5)+sg(6)*sg(6))) +! +! evaluation of the yield surface +! +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,611) dsg,q1,r0,c0 +c 611 format('dsg,q1,r0,c0,al1,d1 ',/,(6(1x,e11.4))) +c write(*,612) (q2(i),i=1,6) +c 612 format('q2 ',/,(6(1x,e11.4))) +c endif + if(creep) then + htri=dsg+c0*(q1-r0-(ca*dg)**(1.d0/cn)) + else + htri=dsg+c0*(q1-r0) + endif +! + do i=1,6 + sg(i)=sg(i)/dsg + enddo +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,905) (sg(i),i=1,6) +c 905 format('sg ',/,(6(1x,e11.4))) +c endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,203) htri +c 203 format('htri ',/,(6(1x,e11.4))) +c endif +! +! determining the residual matrix +! + do i=1,6 + r(i)=ep0(i)-ep(i)+dg*sg(i) + enddo + r(7)=al10-al1+dg*c0 + do i=1,6 + r(7+i)=al20(i)-al2(i)+dg*sg(i) + enddo +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,205) (r(i),i=1,13) +c 205 format('r ',/,(6(1x,e11.4))) +c endif +! +! check convergence +! + if((htri.le.1.d-5).or.(dabs(ddg).lt.1.d-3*dabs(dg))) then + dd=0.d0 + do i=1,13 + dd=dd+r(i)*r(i) + enddo + dd=sqrt(dd) + if(dd.le.1.d-10) then +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) 'CONVERGENCE!' +c endif + exit + endif + endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) 'no convergence' +c endif +! +! determining b.x +! + b=dg/dsg +! + x(1)=b*(c1-sg(1)*sg(1)) + x(2)=b*(c2-sg(1)*sg(2)) + x(3)=b*(c1-sg(2)*sg(2)) + x(4)=b*(c2-sg(1)*sg(3)) + x(5)=b*(c2-sg(2)*sg(3)) + x(6)=b*(c1-sg(3)*sg(3)) + x(7)=-b*sg(1)*sg(4) + x(8)=-b*sg(2)*sg(4) + x(9)=-b*sg(3)*sg(4) + x(10)=b*(.5d0-sg(4)*sg(4)) + x(11)=-b*sg(1)*sg(5) + x(12)=-b*sg(2)*sg(5) + x(13)=-b*sg(3)*sg(5) + x(14)=-b*sg(4)*sg(5) + x(15)=b*(.5d0-sg(5)*sg(5)) + x(16)=-b*sg(1)*sg(6) + x(17)=-b*sg(2)*sg(6) + x(18)=-b*sg(3)*sg(6) + x(19)=-b*sg(4)*sg(6) + x(20)=-b*sg(5)*sg(6) + x(21)=b*(.5d0-sg(6)*sg(6)) +! + do i=1,21 + au1(i)=h2*x(i) + enddo + au1(1)=au1(1)+1.d0 + au1(3)=au1(3)+1.d0 + au1(6)=au1(6)+1.d0 + au1(10)=au1(10)+.5d0 + au1(15)=au1(15)+.5d0 + au1(21)=au1(21)+.5d0 +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,811) (au1(i),i=1,21) +c 811 format('au1 ',/,(6(1x,e11.4))) +c endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,811) (cm1(i),i=1,21) +c 812 format('cm1 ',/,(6(1x,e11.4))) +c endif +! +! filling the LHS +! + if(iorien.gt.0) then + gl(1,1)=au1(1)*cm1(1)+au1(2)*cm1(2)+au1(4)*cm1(4)+ + & 2.d0*(au1(7)*cm1(7)+au1(11)*cm1(11)+au1(16)*cm1(16))+ + & x(1) + gl(1,2)=au1(1)*cm1(2)+au1(2)*cm1(3)+au1(4)*cm1(5)+ + & 2.d0*(au1(7)*cm1(8)+au1(11)*cm1(12)+au1(16)*cm1(17))+ + & x(2) + gl(2,2)=au1(2)*cm1(2)+au1(3)*cm1(3)+au1(5)*cm1(5)+ + & 2.d0*(au1(8)*cm1(8)+au1(12)*cm1(12)+au1(17)*cm1(17))+ + & x(3) + gl(1,3)=au1(1)*cm1(4)+au1(2)*cm1(5)+au1(4)*cm1(6)+ + & 2.d0*(au1(7)*cm1(9)+au1(11)*cm1(13)+au1(16)*cm1(18))+ + & x(4) + gl(2,3)=au1(2)*cm1(4)+au1(3)*cm1(5)+au1(5)*cm1(6)+ + & 2.d0*(au1(8)*cm1(9)+au1(12)*cm1(13)+au1(17)*cm1(18))+ + & x(5) + gl(3,3)=au1(4)*cm1(4)+au1(5)*cm1(5)+au1(6)*cm1(6)+ + & 2.d0*(au1(9)*cm1(9)+au1(13)*cm1(13)+au1(18)*cm1(18))+ + & x(6) + gl(1,4)=au1(1)*cm1(7)+au1(2)*cm1(8)+au1(4)*cm1(9)+ + & 2.d0*(au1(7)*cm1(10)+au1(11)*cm1(14)+au1(16)*cm1(19))+ + & x(7) + gl(2,4)=au1(2)*cm1(7)+au1(3)*cm1(8)+au1(5)*cm1(9)+ + & 2.d0*(au1(8)*cm1(10)+au1(12)*cm1(14)+au1(17)*cm1(19))+ + & x(8) + gl(3,4)=au1(4)*cm1(7)+au1(5)*cm1(8)+au1(6)*cm1(9)+ + & 2.d0*(au1(9)*cm1(10)+au1(13)*cm1(14)+au1(18)*cm1(19))+ + & x(9) + gl(4,4)=au1(7)*cm1(7)+au1(8)*cm1(8)+au1(9)*cm1(9)+ + & 2.d0*(au1(10)*cm1(10)+au1(14)*cm1(14)+au1(19)*cm1(19))+ + & x(10) + gl(1,5)=au1(1)*cm1(11)+au1(2)*cm1(12)+au1(4)*cm1(13)+ + & 2.d0*(au1(7)*cm1(14)+au1(11)*cm1(15)+au1(16)*cm1(20))+ + & x(11) + gl(2,5)=au1(2)*cm1(11)+au1(3)*cm1(12)+au1(5)*cm1(13)+ + & 2.d0*(au1(8)*cm1(14)+au1(12)*cm1(15)+au1(17)*cm1(20))+ + & x(12) + gl(3,5)=au1(4)*cm1(11)+au1(5)*cm1(12)+au1(6)*cm1(13)+ + & 2.d0*(au1(9)*cm1(14)+au1(13)*cm1(15)+au1(18)*cm1(20))+ + & x(13) + gl(4,5)=au1(7)*cm1(11)+au1(8)*cm1(12)+au1(9)*cm1(13)+ + & 2.d0*(au1(10)*cm1(14)+au1(14)*cm1(15)+au1(19)*cm1(20))+ + & x(14) + gl(5,5)=au1(11)*cm1(11)+au1(12)*cm1(12)+au1(13)*cm1(13)+ + & 2.d0*(au1(14)*cm1(14)+au1(15)*cm1(15)+au1(20)*cm1(20))+ + & x(15) + gl(1,6)=au1(1)*cm1(16)+au1(2)*cm1(17)+au1(4)*cm1(18)+ + & 2.d0*(au1(7)*cm1(19)+au1(11)*cm1(20)+au1(16)*cm1(21))+ + & x(16) + gl(2,6)=au1(2)*cm1(16)+au1(3)*cm1(17)+au1(5)*cm1(18)+ + & 2.d0*(au1(8)*cm1(19)+au1(12)*cm1(20)+au1(17)*cm1(21))+ + & x(17) + gl(3,6)=au1(4)*cm1(16)+au1(5)*cm1(17)+au1(6)*cm1(18)+ + & 2.d0*(au1(9)*cm1(19)+au1(13)*cm1(20)+au1(18)*cm1(21))+ + & x(18) + gl(4,6)=au1(7)*cm1(16)+au1(8)*cm1(17)+au1(9)*cm1(18)+ + & 2.d0*(au1(10)*cm1(19)+au1(14)*cm1(20)+au1(19)*cm1(21))+ + & x(19) + gl(5,6)=au1(11)*cm1(16)+au1(12)*cm1(17)+au1(13)*cm1(18)+ + & 2.d0*(au1(14)*cm1(19)+au1(15)*cm1(20)+au1(20)*cm1(21))+ + & x(20) + gl(6,6)=au1(16)*cm1(16)+au1(17)*cm1(17)+au1(18)*cm1(18)+ + & 2.d0*(au1(19)*cm1(19)+au1(20)*cm1(20)+au1(21)*cm1(21))+ + & x(21) + do i=1,6 + do j=1,i-1 + gl(i,j)=gl(j,i) + enddo + enddo + do i=1,6 + do j=4,6 + gl(i,j)=2.d0*gl(i,j) + enddo + enddo + else + gl(1,1)=au1(1)*cm1(1)+au1(2)*cm1(2)+au1(4)*cm1(4)+x(1) + gl(1,2)=au1(1)*cm1(2)+au1(2)*cm1(3)+au1(4)*cm1(5)+x(2) + gl(2,2)=au1(2)*cm1(2)+au1(3)*cm1(3)+au1(5)*cm1(5)+x(3) + gl(1,3)=au1(1)*cm1(4)+au1(2)*cm1(5)+au1(4)*cm1(6)+x(4) + gl(2,3)=au1(2)*cm1(4)+au1(3)*cm1(5)+au1(5)*cm1(6)+x(5) + gl(3,3)=au1(4)*cm1(4)+au1(5)*cm1(5)+au1(6)*cm1(6)+x(6) + gl(1,4)=2.d0*au1(7)*cm1(7)+x(7) + gl(2,4)=2.d0*au1(8)*cm1(7)+x(8) + gl(3,4)=2.d0*au1(9)*cm1(7)+x(9) + gl(4,4)=2.d0*au1(10)*cm1(7)+x(10) + gl(1,5)=2.d0*au1(11)*cm1(8)+x(11) + gl(2,5)=2.d0*au1(12)*cm1(8)+x(12) + gl(3,5)=2.d0*au1(13)*cm1(8)+x(13) + gl(4,5)=2.d0*au1(14)*cm1(8)+x(14) + gl(5,5)=2.d0*au1(15)*cm1(8)+x(15) + gl(1,6)=2.d0*au1(16)*cm1(9)+x(16) + gl(2,6)=2.d0*au1(17)*cm1(9)+x(17) + gl(3,6)=2.d0*au1(18)*cm1(9)+x(18) + gl(4,6)=2.d0*au1(19)*cm1(9)+x(19) + gl(5,6)=2.d0*au1(20)*cm1(9)+x(20) + gl(6,6)=2.d0*au1(21)*cm1(9)+x(21) + do i=1,6 + do j=1,i-1 + gl(i,j)=gl(j,i) + enddo + enddo + do i=1,6 + do j=4,6 + gl(i,j)=2.d0*gl(i,j) + enddo + enddo + endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,813) ((gl(i,j),j=1,6),i=1,6) +c 813 format('gl ',/,(6(1x,e11.4))) +c endif +! +! filling the RHS +! + do i=1,6 + gr(i,1)=sg(i) + enddo +! +! solve gl:(P:n)=gr +! + call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! + do i=1,6 + Pn(i)=gr(i,1) + enddo +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,411) (Pn(i),i=1,6) +c 411 format('Pn ',/,(6(1x,e11.4))) +c endif +! +c c3=-1.d0/(a+b) + c3=-h2/(1.d0+b*h2) + QSn(1)=c3*(x(1)*Pn(1)+x(2)*Pn(2)+x(4)*Pn(3)+ + & 2.d0*(x(7)*Pn(4)+x(11)*Pn(5)+x(16)*Pn(6)))+sg(1)*h2 + QSn(2)=c3*(x(2)*Pn(1)+x(3)*Pn(2)+x(5)*Pn(3)+ + & 2.d0*(x(8)*Pn(4)+x(12)*Pn(5)+x(17)*Pn(6)))+sg(2)*h2 + QSn(3)=c3*(x(4)*Pn(1)+x(5)*Pn(2)+x(6)*Pn(3)+ + & 2.d0*(x(9)*Pn(4)+x(13)*Pn(5)+x(18)*Pn(6)))+sg(3)*h2 + QSn(4)=c3*(x(7)*Pn(1)+x(8)*Pn(2)+x(9)*Pn(3)+ + & 2.d0*(x(10)*Pn(4)+x(14)*Pn(5)+x(19)*Pn(6)))+sg(4)*h2 + QSn(5)=c3*(x(11)*Pn(1)+x(12)*Pn(2)+x(13)*Pn(3)+ + & 2.d0*(x(14)*Pn(4)+x(15)*Pn(5)+x(20)*Pn(6)))+sg(5)*h2 + QSn(6)=c3*(x(16)*Pn(1)+x(17)*Pn(2)+x(18)*Pn(3)+ + & 2.d0*(x(19)*Pn(4)+x(20)*Pn(5)+x(21)*Pn(6)))+sg(6)*h2 +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,412) (QSn(i),i=1,6) +c 412 format('QSn ',/,(6(1x,e11.4))) +c endif +! +! calculating the creep contribution +! + if(creep) then + if(dg.gt.0.d0) then + gcreep=c0*ca/cn*(dg*ca)**(1.d0/cn-1.d0) + else +! +! for gamma ein default of 1.d-10 is taken to +! obtain a finite gradient +! + gcreep=c0*ca/cn*(1.d-10*ca)**(1.d0/cn-1.d0) + endif + endif +! +! calculating the correction to the consistency parameter +! + gm1=Pn(1)*sg(1)+Pn(2)*sg(2)+Pn(3)*sg(3)+ + & 2.d0*(Pn(4)*sg(4)+Pn(5)*sg(5)+Pn(6)*sg(6))+ + & c1*h1+ + & QSn(1)*sg(1)+QSn(2)*sg(2)+QSn(3)*sg(3)+ + & 2.d0*(QSn(4)*sg(4)+QSn(5)*sg(5)+QSn(6)*sg(6)) + if(creep) then + gm1=1.d0/(gm1+gcreep) + else + gm1=1.d0/gm1 + endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,512) gm1 +c 512 format('gm1 ',/,(6(1x,e11.4))) +c endif + ddg=gm1*(htri-(Pn(1)*r(1)+Pn(2)*r(2)+Pn(3)*r(3)+ + & 2.d0*(Pn(4)*r(4)+Pn(5)*r(5)+Pn(6)*r(6))+ + & c0*h1*r(7)+ + & QSn(1)*r(8)+QSn(2)*r(9)+QSn(3)*r(10)+ + & 2.d0*(QSn(4)*r(11)+QSn(5)*r(12)+QSn(6)*r(13)))) +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,313) ddg +c 313 format('ddg ',/,(6(1x,e11.4))) +c endif +! +! updating the residual matrix +! + do i=1,6 + r(i)=r(i)+ddg*sg(i) + enddo + r(7)=r(7)+ddg*c0 + do i=1,6 + r(7+i)=r(7+i)+ddg*sg(i) + enddo +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,210) (r(i),i=1,13) +c 210 format('r up ',/,(6(1x,e11.4))) +c endif +! +! update the plastic strain +! + gr(1,1)=au1(1)*r(1)+au1(2)*r(2)+au1(4)*r(3)+ + & 2.d0*(au1(7)*r(4)+au1(11)*r(5)+au1(16)*r(6)) + & -h2*(x(1)*r(8)+x(2)*r(9)+x(4)*r(10)+ + & 2.d0*(x(7)*r(11)+x(11)*r(12)+x(16)*r(13))) + gr(2,1)=au1(2)*r(1)+au1(3)*r(2)+au1(5)*r(3)+ + & 2.d0*(au1(8)*r(4)+au1(12)*r(5)+au1(17)*r(6)) + & -h2*(x(2)*r(8)+x(3)*r(9)+x(5)*r(10)+ + & 2.d0*(x(8)*r(11)+x(12)*r(12)+x(17)*r(13))) + gr(3,1)=au1(4)*r(1)+au1(5)*r(2)+au1(6)*r(3)+ + & 2.d0*(au1(9)*r(4)+au1(13)*r(5)+au1(18)*r(6)) + & -h2*(x(4)*r(8)+x(5)*r(9)+x(6)*r(10)+ + & 2.d0*(x(9)*r(11)+x(13)*r(12)+x(18)*r(13))) + gr(4,1)=au1(7)*r(1)+au1(8)*r(2)+au1(9)*r(3)+ + & 2.d0*(au1(10)*r(4)+au1(14)*r(5)+au1(19)*r(6)) + & -h2*(x(7)*r(8)+x(8)*r(9)+x(9)*r(10)+ + & 2.d0*(x(10)*r(11)+x(14)*r(12)+x(19)*r(13))) + gr(5,1)=au1(11)*r(1)+au1(12)*r(2)+au1(13)*r(3)+ + & 2.d0*(au1(14)*r(4)+au1(15)*r(5)+au1(20)*r(6)) + & -h2*(x(11)*r(8)+x(12)*r(9)+x(13)*r(10)+ + & 2.d0*(x(14)*r(11)+x(15)*r(12)+x(20)*r(13))) + gr(6,1)=au1(16)*r(1)+au1(17)*r(2)+au1(18)*r(3)+ + & 2.d0*(au1(19)*r(4)+au1(20)*r(5)+au1(21)*r(6)) + & -h2*(x(16)*r(8)+x(17)*r(9)+x(18)*r(10)+ + & 2.d0*(x(19)*r(11)+x(20)*r(12)+x(21)*r(13))) +! + call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! + if(iorien.gt.0) then + ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+cm1(4)*gr(3,1)+ + & 2.d0*(cm1(7)*gr(4,1)+cm1(11)*gr(5,1)+cm1(16)*gr(6,1)) + ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+cm1(5)*gr(3,1)+ + & 2.d0*(cm1(8)*gr(4,1)+cm1(12)*gr(5,1)+cm1(17)*gr(6,1)) + ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+cm1(6)*gr(3,1)+ + & 2.d0*(cm1(9)*gr(4,1)+cm1(13)*gr(5,1)+cm1(18)*gr(6,1)) + ep(4)=ep(4)+cm1(7)*gr(1,1)+cm1(8)*gr(2,1)+cm1(9)*gr(3,1)+ + & 2.d0*(cm1(10)*gr(4,1)+cm1(14)*gr(5,1)+cm1(19)*gr(6,1)) + ep(5)=ep(5)+cm1(11)*gr(1,1)+cm1(12)*gr(2,1)+cm1(13)*gr(3,1)+ + & 2.d0*(cm1(14)*gr(4,1)+cm1(15)*gr(5,1)+cm1(20)*gr(6,1)) + ep(6)=ep(6)+cm1(16)*gr(1,1)+cm1(17)*gr(2,1)+cm1(18)*gr(3,1)+ + & 2.d0*(cm1(19)*gr(4,1)+cm1(20)*gr(5,1)+cm1(21)*gr(6,1)) + else + ep(1)=ep(1)+cm1(1)*gr(1,1)+cm1(2)*gr(2,1)+cm1(4)*gr(3,1) + ep(2)=ep(2)+cm1(2)*gr(1,1)+cm1(3)*gr(2,1)+cm1(5)*gr(3,1) + ep(3)=ep(3)+cm1(4)*gr(1,1)+cm1(5)*gr(2,1)+cm1(6)*gr(3,1) + ep(4)=ep(4)+2.d0*cm1(7)*gr(4,1) + ep(5)=ep(5)+2.d0*cm1(8)*gr(5,1) + ep(6)=ep(6)+2.d0*cm1(9)*gr(6,1) + endif +! +! update the isotropic hardening variable +! + al1=al1+r(7) +! +! update the kinematic hardening variables +! +c c4=a/(a+b) +c c6=b/(a+b) + c4=1.d0/(1.d0+b*h2) + c6=c4*b*h2 + c5=c6/3.d0 + au2(1)=c4+c5+c6*sg(1)*sg(1) + au2(2)=c5+c6*sg(1)*sg(2) + au2(3)=c4+c5+c6*sg(2)*sg(2) + au2(4)=c5+c6*sg(1)*sg(3) + au2(5)=c5+c6*sg(2)*sg(3) + au2(6)=c4+c5+c6*sg(3)*sg(3) + au2(7)=c6*sg(1)*sg(4) + au2(8)=c6*sg(2)*sg(4) + au2(9)=c6*sg(3)*sg(4) + au2(10)=c4/2.d0+c6*sg(4)*sg(4) + au2(11)=c6*sg(1)*sg(5) + au2(12)=c6*sg(2)*sg(5) + au2(13)=c6*sg(3)*sg(5) + au2(14)=c6*sg(4)*sg(5) + au2(15)=c4/2.d0+c6*sg(5)*sg(5) + au2(16)=c6*sg(1)*sg(6) + au2(17)=c6*sg(2)*sg(6) + au2(18)=c6*sg(3)*sg(6) + au2(19)=c6*sg(4)*sg(6) + au2(20)=c6*sg(5)*sg(6) + au2(21)=c4/2.d0+c6*sg(6)*sg(6) +! + al2(1)=al2(1)+au2(1)*r(8)+au2(2)*r(9)+au2(4)*r(10)+ + & 2.d0*(au2(7)*r(11)+au2(11)*r(12)+au2(16)*r(13)) + & -c4*(x(1)*gr(1,1)+x(2)*gr(2,1)+x(4)*gr(3,1)+ + & 2.d0*(x(7)*gr(4,1)+x(11)*gr(5,1)+x(16)*gr(6,1))) + al2(2)=al2(2)+au2(2)*r(8)+au2(3)*r(9)+au2(5)*r(10)+ + & 2.d0*(au2(8)*r(11)+au2(12)*r(12)+au2(17)*r(13)) + & -c4*(x(2)*gr(1,1)+x(3)*gr(2,1)+x(5)*gr(3,1)+ + & 2.d0*(x(8)*gr(4,1)+x(12)*gr(5,1)+x(17)*gr(6,1))) + al2(3)=al2(3)+au2(4)*r(8)+au2(5)*r(9)+au2(6)*r(10)+ + & 2.d0*(au2(9)*r(11)+au2(13)*r(12)+au2(18)*r(13)) + & -c4*(x(4)*gr(1,1)+x(5)*gr(2,1)+x(6)*gr(3,1)+ + & 2.d0*(x(9)*gr(4,1)+x(13)*gr(5,1)+x(18)*gr(6,1))) + al2(4)=al2(4)+au2(7)*r(8)+au2(8)*r(9)+au2(9)*r(10)+ + & 2.d0*(au2(10)*r(11)+au2(14)*r(12)+au2(19)*r(13)) + & -c4*(x(7)*gr(1,1)+x(8)*gr(2,1)+x(9)*gr(3,1)+ + & 2.d0*(x(10)*gr(4,1)+x(14)*gr(5,1)+x(19)*gr(6,1))) + al2(5)=al2(5)+au2(11)*r(8)+au2(12)*r(9)+au2(13)*r(10)+ + & 2.d0*(au2(14)*r(11)+au2(15)*r(12)+au2(20)*r(13)) + & -c4*(x(11)*gr(1,1)+x(12)*gr(2,1)+x(13)*gr(3,1)+ + & 2.d0*(x(14)*gr(4,1)+x(15)*gr(5,1)+x(20)*gr(6,1))) + al2(6)=al2(6)+au2(16)*r(8)+au2(17)*r(9)+au2(18)*r(10)+ + & 2.d0*(au2(19)*r(11)+au2(20)*r(12)+au2(21)*r(13)) + & -c4*(x(16)*gr(1,1)+x(17)*gr(2,1)+x(18)*gr(3,1)+ + & 2.d0*(x(19)*gr(4,1)+x(20)*gr(5,1)+x(21)*gr(6,1))) +! +! update the consistency parameter +! + dg=dg+ddg +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) 'ep ',(ep(i),i=1,6) +c write(*,211) al1 +c 211 format('al1new ',/,(6(1x,e11.4))) +c write(*,212) (al2(i),i=1,6) +c 212 format('al2new ',/,(6(1x,e11.4))) +c write(*,213) dg +c 213 format('dg ',/,(6(1x,e11.4))) +c endif +! +! end of major loop +! + enddo +! +! storing the stress +! + do i=1,6 + stre(i)=stri(i) + enddo +! +! calculating the tangent stiffness matrix +! + if(icmd.ne.3) then +! +! determining p +! + gr(1,1)=au1(1) + gr(1,2)=au1(2) + gr(2,2)=au1(3) + gr(1,3)=au1(4) + gr(2,3)=au1(5) + gr(3,3)=au1(6) + gr(1,4)=au1(7) + gr(2,4)=au1(8) + gr(3,4)=au1(9) + gr(4,4)=au1(10) + gr(1,5)=au1(11) + gr(2,5)=au1(12) + gr(3,5)=au1(13) + gr(4,5)=au1(14) + gr(5,5)=au1(15) + gr(1,6)=au1(16) + gr(2,6)=au1(17) + gr(3,6)=au1(18) + gr(4,6)=au1(19) + gr(5,6)=au1(20) + gr(6,6)=au1(21) + do i=1,6 + do j=1,i-1 + gr(i,j)=gr(j,i) + enddo + enddo + nrhs=6 +! + call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,714) ((gr(i,j),j=1,6),i=1,6) +c 714 format('gr ',/,(6(1x,e11.4))) +c endif + stiff(1)=gr(1,1)-gm1*Pn(1)*Pn(1) + stiff(2)=gr(1,2)-gm1*Pn(1)*Pn(2) + stiff(3)=gr(2,2)-gm1*Pn(2)*Pn(2) + stiff(4)=gr(1,3)-gm1*Pn(1)*Pn(3) + stiff(5)=gr(2,3)-gm1*Pn(2)*Pn(3) + stiff(6)=gr(3,3)-gm1*Pn(3)*Pn(3) + stiff(7)=gr(1,4)-gm1*Pn(1)*Pn(4) + stiff(8)=gr(2,4)-gm1*Pn(2)*Pn(4) + stiff(9)=gr(3,4)-gm1*Pn(3)*Pn(4) + stiff(10)=gr(4,4)-gm1*Pn(4)*Pn(4) + stiff(11)=gr(1,5)-gm1*Pn(1)*Pn(5) + stiff(12)=gr(2,5)-gm1*Pn(2)*Pn(5) + stiff(13)=gr(3,5)-gm1*Pn(3)*Pn(5) + stiff(14)=gr(4,5)-gm1*Pn(4)*Pn(5) + stiff(15)=gr(5,5)-gm1*Pn(5)*Pn(5) + stiff(16)=gr(1,6)-gm1*Pn(1)*Pn(6) + stiff(17)=gr(2,6)-gm1*Pn(2)*Pn(6) + stiff(18)=gr(3,6)-gm1*Pn(3)*Pn(6) + stiff(19)=gr(4,6)-gm1*Pn(4)*Pn(6) + stiff(20)=gr(5,6)-gm1*Pn(5)*Pn(6) + stiff(21)=gr(6,6)-gm1*Pn(6)*Pn(6) +! +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) 'stiffness ' +c write(*,'(6(1x,e11.4))') (stiff(i),i=1,21) +c endif + endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,311) q1 +c 311 format('q1new ',/,(6(1x,e11.4))) +c write(*,312) (q2(i),i=1,6) +c 312 format('q2new ',/,(6(1x,e11.4))) +c endif +c if((iint.eq.1).and.(iel.eq.1)) then +c write(*,*) ' stress ' +c write(*,'(6(1x,e11.4))') (stri(i),i=1,6) +c write(*,214) dg,dtime +c 214 format('dg ',/,(6(1x,e11.4))) +c endif +! +! updating the state variables +! + xstate(1,iint,iel)=eeq+c0*dg + do i=1,6 + xstate(1+i,iint,iel)=ep(i) + enddo + xstate(8,iint,iel)=al1 + do i=1,6 + xstate(8+i,iint,iel)=al2(i) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_elastic_fiber.f calculix-ccx-2.3/ccx_2.3/src/umat_elastic_fiber.f --- calculix-ccx-2.1/ccx_2.3/src/umat_elastic_fiber.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_elastic_fiber.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,390 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_elastic_fiber + & (amat,iel,iint,kode,elconloc,emec,emec0, + & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi, + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) +! +! calculates stiffness and stresses for a user defined material +! law +! +! icmd=3: calcutates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! Notice that the matrix is an integral part of the +! fourth order material tensor, i.e. the Voigt notation +! is not used. +! + implicit none +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),nfiber,i, + & j,k,l,m,n,ioffset,nt,kk(84),iorien +! + real*8 elconloc(21),stiff(21),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,c(3,3),a(3),pgauss(3), + & orab(7,*),skl(3,3),aa(3),emec(6),time,ttime +! + real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*), + & constant(21),dd,dm(3,3,4),djdc(3,3,4),d2jdc2(3,3,3,3,4), + & v1,v1b,v3,v3bi,v4(4),v4br(4),djbdc(3,3,4),d2jbdc2(3,3,3,3,4), + & didc(3,3,3),d2idc2(3,3,3,3,3),dibdc(3,3,3),d2ibdc2(3,3,3,3,3), + & dudc(3,3),d2udc2(3,3,3,3),v33,cinv(3,3),xk1,xk2,d(3,3),term +! + data kk /1,1,1,1,1,1,2,2,2,2,2,2,1,1,3,3,2,2,3,3,3,3,3,3, + & 1,1,1,2,2,2,1,2,3,3,1,2,1,2,1,2,1,1,1,3,2,2,1,3,3,3,1,3, + & 1,2,1,3,1,3,1,3,1,1,2,3,2,2,2,3,3,3,2,3,1,2,2,3,1,3,2,3, + & 2,3,2,3/ +! +! calculating the transformation matrix +! + if(iorien.gt.0) then + call transformatrix(orab(1,iorien),pgauss,skl) + endif +! +! # of fibers +! + nfiber=(-kode-102)/4 + do i=1,-kode-100 + constant(i)=elconloc(i) + enddo + if(dabs(constant(2)).lt.1.d-10) then + constant(2)=1.d0/(20.d0*constant(1)) + endif +! +! calculation of the Green deformation tensor for the +! mechanical strain +! + do i=1,3 + c(i,i)=emec(i)*2.d0+1.d0 + enddo + c(1,2)=2.d0*emec(4) + c(1,3)=2.d0*emec(5) + c(2,3)=2.d0*emec(6) +! +! creation of the delta Dirac matrix d +! + do i=1,3 + d(i,i)=1.d0 + enddo + d(1,2)=0.d0 + d(1,3)=0.d0 + d(2,3)=0.d0 +! +! calculation of the structural tensors +! + do k=1,nfiber + ioffset=4*k-1 + a(1)=constant(ioffset) + a(2)=constant(ioffset+1) + dd=a(1)*a(1)+a(2)*a(2) + if(dd.gt.1.d0) then + write(*,*) '*ERROR in umat_el_fiber: components of' + write(*,*) ' direction vector ',k,' are too big' + stop + endif + a(3)=dsqrt(1.d0-dd) +! +! check for local coordinate systems +! + if(iorien.gt.0) then + do j=1,3 + aa(j)=a(j) + enddo + do j=1,3 + a(j)=skl(j,1)*aa(1)+skl(j,2)*aa(2)+skl(j,3)*aa(3) + enddo + endif +! + do j=1,3 + do i=1,j + dm(i,j,k)=a(i)*a(j) + enddo + enddo + enddo +! +! calculation of the invariants +! + v1=c(1,1)+c(2,2)+c(3,3) + v3=c(1,1)*(c(2,2)*c(3,3)-c(2,3)*c(2,3)) + & -c(1,2)*(c(1,2)*c(3,3)-c(1,3)*c(2,3)) + & +c(1,3)*(c(1,2)*c(2,3)-c(1,3)*c(2,2)) + do j=1,nfiber + v4(j)=dm(1,1,j)*c(1,1)+dm(2,2,j)*c(2,2)+dm(3,3,j)*c(3,3)+ + & 2.d0*(dm(1,2,j)*c(1,2)+dm(1,3,j)*c(1,3)+dm(2,3,j)*c(2,3)) + enddo +! + v33=v3**(-1.d0/3.d0) +! +! inversion of c +! + cinv(1,1)=(c(2,2)*c(3,3)-c(2,3)*c(2,3))/v3 + cinv(2,2)=(c(1,1)*c(3,3)-c(1,3)*c(1,3))/v3 + cinv(3,3)=(c(1,1)*c(2,2)-c(1,2)*c(1,2))/v3 + cinv(1,2)=(c(1,3)*c(2,3)-c(1,2)*c(3,3))/v3 + cinv(1,3)=(c(1,2)*c(2,3)-c(2,2)*c(1,3))/v3 + cinv(2,3)=(c(1,2)*c(1,3)-c(1,1)*c(2,3))/v3 + cinv(2,1)=cinv(1,2) + cinv(3,1)=cinv(1,3) + cinv(3,2)=cinv(2,3) +! +! first derivative of the invariants with respect to c(k,l) +! + do l=1,3 + do k=1,l + didc(k,l,1)=d(k,l) + didc(k,l,3)=v3*cinv(k,l) + do j=1,nfiber + djdc(k,l,j)=dm(k,l,j) + enddo + enddo + enddo +! +! second derivative of the invariants w.r.t. c(k,l) +! and c(m,n) +! + if(icmd.ne.3) then + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2idc2(k,l,m,n,1)=0.d0 + d2idc2(k,l,m,n,3)=v3*(cinv(m,n)*cinv(k,l)- + & (cinv(k,m)*cinv(n,l)+cinv(k,n)*cinv(m,l))/2.d0) + do j=1,nfiber + d2jdc2(k,l,m,n,j)=0.d0 + enddo + enddo + endif +! +! derivatives for the reduced invariants +! + v1b=v1*v33 + v3bi=1.d0/dsqrt(v3) + do j=1,nfiber + v4br(j)=v4(j)*v33-1.d0 + enddo +! +! first derivative of the reduced c-invariants w.r.t. c(k,l) +! + do l=1,3 + do k=1,l + dibdc(k,l,1)=-v33**4*v1*didc(k,l,3)/3.d0 + & +v33*didc(k,l,1) + do j=1,nfiber + djbdc(k,l,j)=-v33**4*v4(j)*didc(k,l,3)/3.d0 + & +v33*djdc(k,l,j) + enddo + enddo + enddo +! +! second derivative of the reduced c-invariants w.r.t. c(k,l) +! and c(m,n) +! + if(icmd.ne.3) then + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + d2ibdc2(k,l,m,n,1)=4.d0/9.d0*v33**7*v1*didc(k,l,3) + & *didc(m,n,3)-v33**4/3.d0*(didc(m,n,1)*didc(k,l,3) + & +didc(k,l,1)*didc(m,n,3))-v33**4/3.d0*v1* + & d2idc2(k,l,m,n,3)+v33*d2idc2(k,l,m,n,1) + do j=1,nfiber + d2jbdc2(k,l,m,n,j)=4.d0/9.d0*v33**7*v4(j)*didc(k,l,3) + & *didc(m,n,3)-v33**4/3.d0*(djdc(m,n,j)*didc(k,l,3) + & +djdc(k,l,j)*didc(m,n,3))-v33**4/3.d0*v4(j)* + & d2idc2(k,l,m,n,3)+v33*d2jdc2(k,l,m,n,j) + enddo + enddo + endif +! +! calculation of the stress +! the anisotropy is only taken into account for v4br(j)>=0 +! + do l=1,3 + do k=1,l + dudc(k,l)=constant(1)*dibdc(k,l,1)+ + & (1.d0-v3bi)*didc(k,l,3)/constant(2) + do j=1,nfiber + if(v4br(j).lt.0.d0) cycle + if(xk2*v4br(j)**2.gt.227.d0) then + write(*,*) '*ERROR in umat_elastic_fiber' + write(*,*) ' fiber extension is too large' + write(*,*) ' for exponential function' + stop + endif + ioffset=4*j + xk1=constant(ioffset+1) + xk2=constant(ioffset+2) + dudc(k,l)=dudc(k,l)+xk1*v4br(j)* + & dexp(xk2*v4br(j)**2)*djbdc(k,l,j) + enddo + enddo + enddo +! +! calculation of the stiffness matrix +! the anisotropy is only taken into account for v4br(j)>=0 +! + if(icmd.ne.3) then + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + term=constant(1)*d2ibdc2(k,l,m,n,1)+ + & v3bi**3*didc(k,l,3)*didc(m,n,3)/(2.d0*constant(2)) + & +(1.d0-v3bi)*d2idc2(k,l,m,n,3)/constant(2) + do j=1,nfiber + if(v4br(j).lt.0.d0) cycle + ioffset=4*j + xk1=constant(ioffset+1) + xk2=constant(ioffset+2) + term=term+xk1*dexp(xk2*v4br(j)**2)* + & (djbdc(k,l,j)*djbdc(m,n,j)*(1.d0+2.d0*xk2*v4br(j)**2)+ + & v4br(j)*d2jbdc2(k,l,m,n,j)) + enddo + d2udc2(k,l,m,n)=term + enddo + endif +! +! storing the stiffness matrix and/or the stress +! + if(icmd.ne.3) then +! +! storing the stiffness matrix +! + nt=0 + do i=1,21 + k=kk(nt+1) + l=kk(nt+2) + m=kk(nt+3) + n=kk(nt+4) + nt=nt+4 + stiff(i)=4.d0*d2udc2(k,l,m,n) + enddo + endif +! +! store the stress at mechanical strain +! + stre(1)=2.d0*dudc(1,1) + stre(2)=2.d0*dudc(2,2) + stre(3)=2.d0*dudc(3,3) + stre(4)=2.d0*dudc(1,2) + stre(5)=2.d0*dudc(1,3) + stre(6)=2.d0*dudc(2,3) +! + return + end + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat.f calculix-ccx-2.3/ccx_2.3/src/umat.f --- calculix-ccx-2.1/ccx_2.3/src/umat.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,92 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat(stress,statev,ddsdde,sse,spd,scd, + & rpl,ddsddt,drplde,drpldt, + & stran,dstran,time,dtime,temp,dtemp,predef,dpred,cmname, + & ndi,nshr,ntens,nstatv,props,nprops,coords,drot,pnewdt, + & celent,dfgrd0,dfgrd1,noel,npt,layer,kspt,kstep,kinc) +! +! here, an ABAQUS umat routine can be inserted +! +! note that reals should be double precision (REAL*8) +! + implicit none +! + character*80 cmname +! + integer ndi,nshr,ntens,nstatv,nprops,noel,npt,layer,kspt, + & kstep,kinc +! + real*8 stress(ntens),statev(nstatv), + & ddsdde(ntens,ntens),ddsddt(ntens),drplde(ntens), + & stran(ntens),dstran(ntens),time(2),celent, + & props(nprops),coords(3),drot(3,3),dfgrd0(3,3),dfgrd1(3,3), + & sse,spd,scd,rpl,drpldt,dtime,temp,dtemp,predef,dpred, + & pnewdt +! +! START EXAMPLE LINEAR ELASTIC MATERIAL +! + integer i,j + real*8 e,un,al,um,am1,am2 +! +c write(*,*) 'noel,npt ',noel,npt +c write(*,*) 'stress ',(stress(i),i=1,6) +c write(*,*) 'stran ',(stran(i),i=1,6) +c write(*,*) 'dstran ',(dstran(i),i=1,6) +c write(*,*) 'drot ',((drot(i,j),i=1,3),j=1,3) + e=props(1) + un=props(2) + al=un*e/(1.d0+un)/(1.d0-2.d0*un) + um=e/2.d0/(1.d0+un) + am1=al+2.d0*um + am2=um +! +! stress +! + stress(1)=stress(1)+am1*dstran(1)+al*(dstran(2)+dstran(3)) + stress(2)=stress(2)+am1*dstran(2)+al*(dstran(1)+dstran(3)) + stress(3)=stress(3)+am1*dstran(3)+al*(dstran(1)+dstran(2)) + stress(4)=stress(4)+am2*dstran(4) + stress(5)=stress(5)+am2*dstran(5) + stress(6)=stress(6)+am2*dstran(6) +! +! stiffness +! + do i=1,6 + do j=1,6 + ddsdde(i,j)=0.d0 + enddo + enddo + ddsdde(1,1)=al+2.d0*um + ddsdde(1,2)=al + ddsdde(2,1)=al + ddsdde(2,2)=al+2.d0*um + ddsdde(1,3)=al + ddsdde(3,1)=al + ddsdde(2,3)=al + ddsdde(3,2)=al + ddsdde(3,3)=al+2.d0*um + ddsdde(4,4)=um + ddsdde(5,5)=um + ddsdde(6,6)=um +! +! END EXAMPLE LINEAR ELASTIC MATERIAL +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_gurson.f calculix-ccx-2.3/ccx_2.3/src/umat_gurson.f --- calculix-ccx-2.1/ccx_2.3/src/umat_gurson.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_gurson.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,523 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_gurson(amat,iel,iint,kode,elconloc,emec,emec0, + & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi,nstate_,xstateini,xstate,stre,stiff, + & iorien,pgauss,orab) +! +! calculates stiffness and stresses for a Gurson-type material +! law +! +! icmd=3: calcutates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! Notice that the matrix is an integral part of the +! fourth order material tensor, i.e. the Voigt notation +! is not used. +! + implicit none +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien, + & i,j,n,nrhs,lda,ldb,ipiv(7),info +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & time,ttime,xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*), + & um,un,aa,f,um2,dg,ddg,ep(6),s(6),de(6),h,r(7),rg,residual, + & dij(6,6),a(4,4),constant,constant1,constant2,fv(4),bb(4,2), + & ra(4),fa(4),gg,tan(6,6),hv(4),cg,ak,ehydro,af(7),ar(7),edev(6), + & ainv(6,6),acp(6,6),d,al,dij4(4,4),xd(6),s23,s32,c1,c2,c3,fc,ff, + & fn,en,sn,r0,um3,q0,f0,el(6),p,ds,xn(6),svm,svm2,dp,dsvm,dei,den, + & aki,arg,cco,sco,c1c2,c1c2f,c1c2fp,q2,q3,q4,depr,devm,dhs,dhss, + & dhsq,dhp,dhpp,dhpq,dhpf,dhq,dhf,b11,b12,b21,b22,q,ep0(6),fnsn, + & eplm +! + data dij /1.d0,0.d0,0.d0,0.d0,0.d0,0.d0, + & 0.d0,1.d0,0.d0,0.d0,0.d0,0.d0, + & 0.d0,0.d0,1.d0,0.d0,0.d0,0.d0, + & 0.d0,0.d0,0.d0,.5d0,0.d0,0.d0, + & 0.d0,0.d0,0.d0,0.d0,.5d0,0.d0, + & 0.d0,0.d0,0.d0,0.d0,0.d0,.5d0/ + data dij4 /1.d0,0.d0,0.d0,0.d0, + & 0.d0,1.d0,0.d0,0.d0, + & 0.d0,0.d0,1.d0,0.d0, + & 0.d0,0.d0,0.d0,1.d0/ + data xd /1.d0,1.d0,1.d0,0.d0,0.d0,0.d0/ +! + s23=dsqrt(2.d0/3.d0) + s32=dsqrt(1.5d0) +! +! material constants +! + um=elconloc(1) + un=elconloc(2) + c1=elconloc(3) + c2=elconloc(4) + c3=elconloc(5) + fc=elconloc(6) + ff=elconloc(7) + fn=elconloc(8) + en=elconloc(9) + sn=elconloc(10) + r0=elconloc(11) +! + um2=2.d0*um + um3=1.d0/(3.d0*um) +! +! internal variables at the start of the increment +! +! yield stress of the fully dense material +! + q0=xstateini(1,iint,iel) +! +! plastic strain +! + do i=1,6 + ep0(i)=xstateini(1+i,iint,iel) + enddo +! +! void volume fraction +! + f0=xstateini(8,iint,iel) +! +! elastic strain in the assumption that no plasticity +! occurs in the present increment +! + do i=1,6 + el(i)=emec(i)-ep0(i) + enddo +! +! hydrostatic strain +! + ehydro=(el(1)+el(2)+el(3))/3.d0 +! +! deviatoric strain +! + do i=1,3 + edev(i)=el(i)-ehydro + enddo + do i=4,6 + edev(i)=el(i) + enddo +! +! deviatoric trial stress +! + do i=1,6 + s(i)=um2*edev(i) + enddo +! +! trial pressure +! + ak=3.d0*(2.d0*um*(1.d0+un))/(3.d0*(1.d0-2.d0*un)) + p=ak*ehydro +! +! radial vector +! + ds=dsqrt(s(1)*s(1)+s(2)*s(2)+s(3)*s(3)+ + & 2.d0*(s(4)*s(4)+s(5)*s(5)+s(6)*s(6))) + do i=1,6 + xn(i)=s(i)/ds + enddo +! +! von Mises stress +! + svm=s32*ds +! +! yield criterion +! + h=(svm*svm)/(q0*q0)+2.d0*c1*f0*dcosh(3.d0*p*c2/(2.d0*q0)) + & -(1.d0+c3*f0*f0) +! + if(h.le.0.d0) then + do i=1,3 + stre(i)=s(i)+ak*ehydro + enddo + do i=4,6 + stre(i)=s(i) + enddo +! + if(icmd.ne.3) then + al=2.d0*un*um/(1.d0-2.d0*un) + stiff(1)=al+2.d0*um + stiff(2)=al + stiff(3)=al+2.d0*um + stiff(4)=al + stiff(5)=al + stiff(6)=al+2.d0*um + stiff(7)=0.d0 + stiff(8)=0.d0 + stiff(9)=0.d0 + stiff(10)=um + stiff(11)=0.d0 + stiff(12)=0.d0 + stiff(13)=0.d0 + stiff(14)=0.d0 + stiff(15)=um + stiff(16)=0.d0 + stiff(17)=0.d0 + stiff(18)=0.d0 + stiff(19)=0.d0 + stiff(20)=0.d0 + stiff(21)=um + endif +! + return + endif +! +! plasticity; initialization of the fields +! + dg=0.d0 + ddg=0.d0 + dp=0.d0 + dsvm=0.d0 + q=q0 + f=f0 +! +! total strain increment +! + do i=1,6 + de(i)=emec(i)-emec0(i) + enddo + dei=de(1)+de(2)+de(3) + den=de(1)*xn(1)+de(2)*xn(2)+de(3)*xn(3)+ + & 2.d0*(de(4)*xn(4)+de(5)*xn(5)+de(6)*xn(6)) +! +! auxiliary variables +! + aki=1.d0/ak + fnsn=fn/(sn*dsqrt(8.d0*datan(1.d0))) +! +! starting the loop to determine the consistency parameter +! + do +! +! inverse of the tangent hardening modulus (to complete!) +! + d=1. + eplm=1. +! +! void nucleation constant +! + aa=fnsn*dexp(-((eplm-en)/sn)**2/2.d0) +! +! auxiliary variables +! + arg=3.d0*c2*p/(2.d0*q) + cco=dcosh(arg) + sco=dsinh(arg) + c1c2=c1*c2 + c1c2f=c1c2*f + q2=q*q +! + depr=dei+dp*aki + devm=dsvm*um3-s23*den + svm2=svm*svm +! +! determining the residuals +! + r(1)=-depr+dg*3.d0*c1c2f*sco/q + r(2)=-devm+dg*2.d0*svm/q2 + r(3)=(1-f)*d*q*(q0-q)+devm*svm-depr*p + r(4)=f0-f+(1.d0-f)*depr-aa*d*(q-q0) +! + rg=(svm2)/q2+2.d0*c1*f*cco+1.d0+c3*f*f +! +! check convergence +! + residual=r(1)*r(1)+r(2)*r(2)+r(3)*r(3)+r(4)*r(4)+rg*rg + if((residual.le.1.d-10).or.(dabs(ddg).lt.1.d-3*dabs(dg))) exit +! +! auxiliary variables +! + c1c2fp=c1c2f*p + q3=q2*q + q4=q3*q +! +! derivatives of the yield function +! + dhs=2.d0*svm/q2 + dhss=2.d0/q2 + dhsq=-4.d0*svm/q +! + dhp=3.d0*c1c2f*sco/q + dhpp=9.d0*c1c2f*c2*cco/(2.d0*q2) + dhpq=-3.d0*c1c2f*sco/q2-9.d0*c1c2fp*c2*cco/(2.d0*q3) + dhpf=3.d0*c1c2*sco/q +! + dhq=-2.d0*svm2/q3-3.d0*c1c2fp*sco/q2 +! + dhf=2.d0*c1*cco+2.d0*c3*f +! + a(1,1)=dg*dhpp-1.d0*aki + a(1,2)=0.d0 + a(1,3)=dg*dhpq + a(4,4)=dg*dhpf + a(2,1)=0.d0 + a(2,2)=dg*dhss+um3 + a(2,3)=dg*dhsq + a(2,4)=0.d0 + a(3,1)=-2.d0*p*aki + a(3,2)=-2.d0*svm*um3 + a(3,3)=-(1.d0-f)*d*(2.d0*q-q0) + a(3,4)=d*q*(q-q0) + a(4,1)=-f*aki + a(4,2)=0.d0 + a(4,3)=-aa*d + a(4,4)=-depr-1.d0 +! +! copying a +! + do i=1,7 + do j=1,7 + ainv(i,j)=a(j,i) + acp(i,j)=a(i,j) + enddo + enddo +! +! vector f +! + fv(1)=dhp + fv(2)=dhs + fv(3)=0.d0 + fv(4)=0.d0 +! +! solving for A:R and A:F +! + do i=1,4 + bb(i,1)=r(i) + bb(i,2)=fv(i) + enddo + n=4 + nrhs=2 + lda=4 + ldb=4 + call dgesv(n,nrhs,a,lda,ipiv,bb,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in umat_gurson:' + write(*,*) ' singular system of equations' + stop + endif + do i=1,4 + ra(i)=bb(i,1) + fa(i)=bb(i,2) + enddo +! +! determination of vector field h and the constant cg +! + hv(1)=dhp + hv(2)=dhs + hv(3)=dhq + hv(4)=dhf + cg=0.d0 +! +! calculating ddg +! + gg=(hv(1)*af(1)+hv(2)*af(2)+hv(3)*af(3)+hv(4)*af(4))-cg + ddg=(rg-(hv(1)*ar(1)+hv(2)*ar(2)+hv(3)*ar(3)+hv(4)*ar(4)))/gg +! + dg=dg+ddg +! +! update p,svm,q and f +! + dp=-ar(1)-ddg*af(1) + p=p+dp + dsvm=-ar(2)-ddg*af(2) + svm=svm+dsvm + q=q-ar(3)-ddg*af(3) + f=f-ar(4)-ddg*af(4) +! + enddo +! +! convergence: calculate the plastic strain +! + devm=s23*dei-dsvm*um3 + depr=dei+dp*aki + constant1=s32*devm + constant2=depr/3.d0 + do i=1,6 + ep(i)=ep0(i)+constant1*xn(i) + enddo + do i=1,3 + ep(i)=ep(i)+constant2 + enddo +! + if(icmd.ne.3) then +! +! tangent matrix +! + nrhs=1 + call dgesv(n,nrhs,ainv,lda,ipiv,hv,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in umat_gurson:' + write(*,*) ' singular system of equations' + stop + endif +! + do i=1,2 + do j=1,2 + tan(i,j)=acp(i,1)*(dij4(1,j)-fv(1)*hv(j)/gg)+ + & acp(i,2)*(dij4(2,j)-fv(2)*hv(j)/gg)+ + & acp(i,3)*(dij4(3,j)-fv(3)*hv(j)/gg)+ + & acp(i,4)*(dij4(4,j)-fv(4)*hv(j)/gg) + enddo + enddo +! + constant=s23*svm+um2/ds + b11=-tan(1,1)-constant/3.d0 + b12=-s23*tan(1,2) + b21=s23*tan(2,1) + b22=s23*s23*tan(2,2)-constant +! + do i=1,6 + do j=1,6 + tan(i,j)=dij(i,j)*constant+b11*xd(i)*xd(j)+ + & b12*xn(i)*xd(j)+b21*xd(i)*xn(j)+ + & b22*xn(i)*xn(j) + enddo + enddo +! +! symmatrizing the stiffness matrix +! + stiff(1)=tan(1,1) + stiff(2)=(tan(1,2)+tan(2,1))/2.d0 + stiff(3)=tan(2,2) + stiff(4)=(tan(1,3)+tan(3,1))/2.d0 + stiff(5)=(tan(2,3)+tan(3,2))/2.d0 + stiff(6)=tan(3,3) + stiff(7)=(tan(1,4)+tan(4,1))/2.d0 + stiff(8)=(tan(2,4)+tan(4,2))/2.d0 + stiff(9)=(tan(3,4)+tan(4,3))/2.d0 + stiff(10)=tan(4,4) + stiff(11)=(tan(1,5)+tan(5,1))/2.d0 + stiff(12)=(tan(2,5)+tan(5,2))/2.d0 + stiff(13)=(tan(3,5)+tan(5,3))/2.d0 + stiff(14)=(tan(4,5)+tan(5,4))/2.d0 + stiff(15)=tan(5,5) + stiff(16)=(tan(1,6)+tan(6,1))/2.d0 + stiff(17)=(tan(2,6)+tan(6,2))/2.d0 + stiff(18)=(tan(3,6)+tan(6,3))/2.d0 + stiff(19)=(tan(4,6)+tan(6,4))/2.d0 + stiff(20)=(tan(5,6)+tan(6,5))/2.d0 + stiff(21)=tan(6,6) +! + endif +! +! internal variables at the end of the increment +! +! yield stress of the fully dense material +! + xstate(1,iint,iel)=q +! +! plastic strain +! + do i=1,6 + xstate(1+i,iint,iel)=ep(i) + enddo +! +! void volume fraction +! + xstate(8,iint,iel)=f +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/umatht.f calculix-ccx-2.3/ccx_2.3/src/umatht.f --- calculix-ccx-2.1/ccx_2.3/src/umatht.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umatht.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,311 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umatht(u,dudt,dudg,flux,dfdt,dfdg, + & statev,temp,dtemp,dtemdx,time,dtime,predef,dpred, + & cmname,ntgrd,nstatv,props,nprops,coords,pnewdt, + & noel,npt,layer,kspt,kstep,kinc,vold,co,lakonl,konl, + & ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,mi) +! +! heat transfer material subroutine +! +! INPUT: +! +! statev(nstatv) internal state variables at the start +! of the increment +! temp temperature at the start of the increment +! dtemp increment of temperature +! dtemdx(ntgrd) current values of the spatial gradients of the +! temperature +! time(1) step time at the beginning of the increment +! time(2) total time at the beginning of the increment +! dtime time increment +! predef not used +! dpred not used +! cmname material name +! ntgrd number of spatial gradients of temperature +! nstatv number of internal state variables as defined +! on the *DEPVAR card +! props(nprops) user defined constants defined by the keyword +! card *USER MATERIAL,TYPE=THERMAL +! nprops number of user defined constants, as specified +! on the *USER MATERIAL,TYPE=THERMAL card +! coords global coordinates of the integration point +! pnewd not used +! noel element number +! npt integration point number +! layer not used +! kspt not used +! kstep not used +! kinc not used +! vold(0..4,1..nk) solution field in all nodes +! 0: temperature +! 1: displacement in global x-direction +! 2: displacement in global y-direction +! 3: displacement in global z-direction +! 4: static pressure +! co(3,1..nk) coordinates of all nodes +! 1: coordinate in global x-direction +! 2: coordinate in global y-direction +! 3: coordinate in global z-direction +! lakonl element label +! konl(1..20) nodes belonging to the element +! ipompc(1..nmpc)) ipompc(i) points to the first term of +! MPC i in field nodempc +! nodempc(1,*) node number of a MPC term +! nodempc(2,*) coordinate direction of a MPC term +! nodempc(3,*) if not 0: points towards the next term +! of the MPC in field nodempc +! if 0: MPC definition is finished +! coefmpc(*) coefficient of a MPC term +! nmpc number of MPC's +! ikmpc(1..nmpc) ordered global degrees of freedom of the MPC's +! the global degree of freedom is +! 8*(node-1)+direction of the dependent term of +! the MPC (direction = 0: temperature; +! 1-3: displacements; 4: static pressure; +! 5-7: rotations) +! ilmpc(1..nmpc) ilmpc(i) is the MPC number corresponding +! to the reference number in ikmpc(i) +! mi(1) max # of integration points per element (max +! over all elements) +! mi(2) max degree of freedomm per node (max over all +! nodes) in fields like v(0:mi(2))... +! +! OUTPUT: +! +! u not used +! dudt not used +! dudg(ntgrd) not used +! flux(ntgrd) heat flux at the end of the increment +! dfdt(ntgrd) not used +! dfdg(ntgrd,ntgrd) variation of the heat flux with respect to the +! spatial temperature gradient +! statev(nstatv) internal state variables at the end of the +! increment +! + implicit none +! + character*8 lakonl + character*80 cmname +! + integer ntgrd,nstatv,nprops,noel,npt,layer,kspt,kstep,kinc, + & konl(20),ipompc(*),nodempc(3,*),nmpc,ikmpc(*),ilmpc(*),mi(2) +! + real*8 u,dudt,dudg(ntgrd),flux(ntgrd),dfdt(ntgrd), + & statev(nstatv),pnewdt,temp,dtemp,dtemdx(ntgrd),time(2),dtime, + & predef,dpred,props(nprops),coords(3),dfdg(ntgrd,ntgrd), + & vold(0:mi(2),*),co(3,*),coefmpc(*) +! +! the code starting here up to the end of the file serves as +! an example for combined mechanical-lubrication problems. +! Please replace it by your own code for your concrete application. +! + integer ifaceq(8,6),ifacet(6,4),ifacew(8,5),ig,nelem,nopes, + & iflag,i,j,nope,node,idof,id +! + real*8 xl21(3,8),xi,et,al,rho,um,h,pnode1(3),pnode2(3), + & ratio(8),dist,xl22(3,8) +! + data ifaceq /4,3,2,1,11,10,9,12, + & 5,6,7,8,13,14,15,16, + & 1,2,6,5,9,18,13,17, + & 2,3,7,6,10,19,14,18, + & 3,4,8,7,11,20,15,19, + & 4,1,5,8,12,17,16,20/ + data ifacet /1,3,2,7,6,5, + & 1,2,4,5,9,8, + & 2,3,4,6,10,9, + & 1,4,3,8,10,7/ + data ifacew /1,3,2,9,8,7,0,0, + & 4,5,6,10,11,12,0,0, + & 1,2,5,4,7,14,10,13, + & 2,3,6,5,8,15,11,14, + & 4,6,3,1,12,15,9,13/ + data iflag /2/ +! + nelem=noel + i=npt +! + if(lakonl(4:4).eq.'2') then + nope=20 + nopes=8 + elseif(lakonl(4:4).eq.'8') then + nope=8 + nopes=4 + elseif(lakonl(4:5).eq.'10') then + nope=10 + nopes=6 + elseif(lakonl(4:4).eq.'4') then + nope=4 + nopes=3 + elseif(lakonl(4:5).eq.'15') then + nope=15 + elseif(lakonl(4:4).eq.'6') then + nope=6 + endif +! +! treatment of wedge faces +! + if(lakonl(4:4).eq.'6') then + if(ig.le.2) then + nopes=3 + else + nopes=4 + endif + endif + if(lakonl(4:5).eq.'15') then + if(ig.le.2) then + nopes=6 + else + nopes=8 + endif + endif +! +! first side of the oil film +! + ig=1 +! + if((nope.eq.20).or.(nope.eq.8)) then + do i=1,nopes + node=konl(ifaceq(i,ig)) + idof=8*(node-1)+4 + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in umatht: node ',node + write(*,*) ' is not connected to the structure' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + do j=1,3 + xl21(j,i)=co(j,node)+ + & vold(j,node) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + write(*,*) '*ERROR in umatht: tetrahedral elements' + write(*,*) ' are not allowed' + stop + else + do i=1,nopes + node=konl(ifacew(i,ig)) + idof=8*(node-1)+4 + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in umatht: node ',node + write(*,*) ' is not connected to the structure' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + do j=1,3 + xl21(j,i)=co(j,node)+ + & vold(j,node) + enddo + enddo + endif +! +! projecting the integration point on the first side of the +! oil film +! + do j=1,3 + pnode1(j)=coords(j) + enddo +! + call attach(xl21,pnode1,nopes,ratio,dist,xi,et) +! +! second side of the oil film +! + ig=2 +! + if((nope.eq.20).or.(nope.eq.8)) then + do i=1,nopes + node=konl(ifaceq(i,ig)) + idof=8*(node-1)+4 + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in umatht: node ',node + write(*,*) ' is not connected to the structure' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + do j=1,3 + xl22(j,i)=co(j,node)+ + & vold(j,node) + enddo + enddo + elseif((nope.eq.10).or.(nope.eq.4)) then + write(*,*) '*ERROR in umatht: tetrahedral elements' + write(*,*) ' are not allowed' + stop + else + do i=1,nopes + node=konl(ifacew(i,ig)) + idof=8*(node-1)+4 + call nident(ikmpc,idof,nmpc,id) + if((id.eq.0).or.(ikmpc(id).ne.idof)) then + write(*,*) '*ERROR in umatht: node ',node + write(*,*) ' is not connected to the structure' + stop + endif + node=nodempc(1,nodempc(3,ipompc(ilmpc(id)))) + do j=1,3 + xl22(j,i)=co(j,node)+ + & vold(j,node) + enddo + enddo + endif +! +! projecting the integration point on the second side of the +! oil film +! + do j=1,3 + pnode2(j)=coords(j) + enddo +! + call attach(xl22,pnode2,nopes,ratio,dist,xi,et) +! +! calculating the thickness of the oil film +! + h=dsqrt((pnode1(1)-pnode2(1))**2+ + & (pnode1(2)-pnode2(2))**2+ + & (pnode1(3)-pnode2(3))**2) +! +! density, viscosity (oil, SI units, 290 K) +! + rho=890.d-9 + um=1.d-6 +! + al=(h**3)*rho/(12.d0*um) +! +! filling the tangent matrix +! + do i=1,3 + do j=1,3 + dfdg(i,j)=0.d0 + enddo + dfdg(i,i)=al + enddo +! +! determining the equivalent flux +! + do j=1,ntgrd + flux(j)=-al*dtemdx(j) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_ideal_gas.f calculix-ccx-2.3/ccx_2.3/src/umat_ideal_gas.f --- calculix-ccx-2.1/ccx_2.3/src/umat_ideal_gas.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_ideal_gas.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,157 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_ideal_gas(amat,iel,iint,kode,elconloc,emec,emec0, + & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi, + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) +! +! calculates stiffness and stresses for an ideal gas +! For this material there is just one material constant equal to +! density x specific gas constant x temperature in Kelvin +! The user should list this constant as a function of temperature +! underneath the *USER MATERIAL,CONSTANTS=1 card. The name of the +! material has to start with IDEAL_GAS, e.g. IDEAL_GAS_AIR or +! IDEAL_GAS_NITROGEN etc. +! +! icmd=3: calcutates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! Notice that the matrix is an integral part of the +! fourth order material tensor, i.e. the Voigt notation +! is not used. +! + implicit none +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien,i +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & time,ttime +! + real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*),xk +! + real*8 e,un,al,um,am1,am2 +! + xk=elconloc(1) +! +! insert here code to calculate the stresses +! + stre(1)=xk*(emec(1)+emec(2)+emec(3)) + stre(2)=xk*(emec(1)+emec(2)+emec(3)) + stre(3)=xk*(emec(1)+emec(2)+emec(3)) + stre(4)=0.d0 + stre(5)=0.d0 + stre(6)=0.d0 + if(icmd.ne.3) then +! +! insert here code to calculate the stiffness matrix +! + do i=1,6 + stiff(i)=xk + enddo + do i=7,21 + stiff(i)=0.d0 + enddo + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_iso_creep.f calculix-ccx-2.3/ccx_2.3/src/umat_iso_creep.f --- calculix-ccx-2.1/ccx_2.3/src/umat_iso_creep.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_iso_creep.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,297 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_iso_creep(amat,iel,iint,kode,elconloc,emec, + & emec0,beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas, + & mi,nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, + & orab) +! +! calculates stiffness and stresses for an elastically isotropic +! material with isotropic creep +! +! icmd=3: calculates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! at mechanical strain +! 3: calculate only stress at mechanical strain +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! Notice that the matrix is an integral part of the +! fourth order material tensor, i.e. the Voigt notation +! is not used. +! + implicit none +! +! + character*20 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien +! + integer i +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & time,ttime,arg +! + real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) +! + real*8 c1,c2,c3,ep0(6),eei(6),e,un,al,am1,um2,ep(6),dg, + & ddg,stri(6),p,eeq0,eeq,um,dstri,c4,c5,f,df +! + INTEGER LEXIMP,LEND,NSTATV,KSPT,KSTEP,KINC,LAYER + REAL*8 DECRA(5),DESWA,STATEV,SERD,EC0,ESW0,DTEMP,PREDEF,DPRED, + & DUMMY,COORDS +! + data c1 /0.8164965809277260d0/ + data c2 /0.6666666666666666d0/ + data leximp /1/ +! +! state variables +! + eeq0=xstateini(1,iint,iel) + do i=1,6 + ep0(i)=xstateini(i+1,iint,iel) + enddo +! +! elastic strains +! + do i=1,6 + eei(i)=emec(i)-ep0(i) + enddo +! +! elastic constants +! + e=elconloc(1) + un=elconloc(2) +! + um2=e/(1.d0+un) + al=un*um2/(1.d0-2.d0*un) + am1=al+um2 + um=um2/2.d0 +! + if(ielas.eq.1) then +! + stre(1)=am1*eei(1)+al*(eei(2)+eei(3)) + stre(2)=am1*eei(2)+al*(eei(1)+eei(3)) + stre(3)=am1*eei(3)+al*(eei(1)+eei(2)) + stre(4)=um2*eei(4) + stre(5)=um2*eei(5) + stre(6)=um2*eei(6) +! + if(icmd.ne.3) then + stiff(1)=am1 + stiff(2)=al + stiff(3)=am1 + stiff(4)=al + stiff(5)=al + stiff(6)=am1 + stiff(7)=0.d0 + stiff(8)=0.d0 + stiff(9)=0.d0 + stiff(10)=um + stiff(11)=0.d0 + stiff(12)=0.d0 + stiff(13)=0.d0 + stiff(14)=0.d0 + stiff(15)=um + stiff(16)=0.d0 + stiff(17)=0.d0 + stiff(18)=0.d0 + stiff(19)=0.d0 + stiff(20)=0.d0 + stiff(21)=um + endif + return + endif +! +! creep +! + stri(1)=am1*eei(1)+al*(eei(2)+eei(3)) + stri(2)=am1*eei(2)+al*(eei(1)+eei(3)) + stri(3)=am1*eei(3)+al*(eei(1)+eei(2)) + stri(4)=um2*eei(4) + stri(5)=um2*eei(5) + stri(6)=um2*eei(6) +! + p=-(stri(1)+stri(2)+stri(3))/3.d0 + do i=1,3 + stri(i)=stri(i)+p + enddo +! + dstri=dsqrt(stri(1)*stri(1)+stri(2)*stri(2)+stri(3)*stri(3)+ + & 2.d0*(stri(4)*stri(4)+stri(5)*stri(5)+stri(6)*stri(6))) +! +! unit trial vector +! + do i=1,6 + stri(i)=stri(i)/dstri + enddo +! + dg=0.d0 + eeq=eeq0+c1*dg +! +! determination of the consistency parameter +! + do + arg=(dstri-um2*dg)/c1 + call CREEP( DECRA, DESWA, STATEV, SERD, EC0, ESW0, p, arg, + & t1l, DTEMP, PREDEF, DPRED, DUMMY, dtime, amat, + & leximp, LEND, COORDS, NSTATV, iel, iint, LAYER, + & KSPT, KSTEP, KINC ) + f=decra(1) + df=decra(5) + ddg=(c1*f-c2*dg)/(um2*df+c2) + dg=dg+ddg + eeq=eeq0+c1*dg + if((ddg.lt.dg*1.d-4).or.(ddg.lt.1.d-10)) exit + enddo +! + do i=1,6 + ep(i)=dg*stri(i) + eei(i)=eei(i)-ep(i) + ep(i)=ep0(i)+ep(i) + enddo +! +! stress values +! + stre(1)=am1*eei(1)+al*(eei(2)+eei(3)) + stre(2)=am1*eei(2)+al*(eei(1)+eei(3)) + stre(3)=am1*eei(3)+al*(eei(1)+eei(2)) + stre(4)=um2*eei(4) + stre(5)=um2*eei(5) + stre(6)=um2*eei(6) +! +! stiffness matrix +! + if(icmd.ne.3) then +! + c3=um2*um2 + c4=c3*dg/dstri + c3=c4-c3*df/(um2*df+c2) + c5=c4/3.d0 +! + stiff(1)=am1+c3*stri(1)*stri(1)+c5-c4 + stiff(2)=al+c3*stri(1)*stri(2)+c5 + stiff(3)=am1+c3*stri(2)*stri(2)+c5-c4 + stiff(4)=al+c3*stri(1)*stri(3)+c5 + stiff(5)=al+c3*stri(2)*stri(3)+c5 + stiff(6)=am1+c3*stri(3)*stri(3)+c5-c4 + stiff(7)=0.d0+c3*stri(1)*stri(4) + stiff(8)=0.d0+c3*stri(2)*stri(4) + stiff(9)=0.d0+c3*stri(3)*stri(4) + stiff(10)=um+c3*stri(4)*stri(4)-c4/2.d0 + stiff(11)=0.d0+c3*stri(1)*stri(5) + stiff(12)=0.d0+c3*stri(2)*stri(5) + stiff(13)=0.d0+c3*stri(3)*stri(5) + stiff(14)=0.d0+c3*stri(4)*stri(5) + stiff(15)=um+c3*stri(5)*stri(5)-c4/2.d0 + stiff(16)=0.d0+c3*stri(1)*stri(6) + stiff(17)=0.d0+c3*stri(2)*stri(6) + stiff(18)=0.d0+c3*stri(3)*stri(6) + stiff(19)=0.d0+c3*stri(4)*stri(6) + stiff(20)=0.d0+c3*stri(5)*stri(6) + stiff(21)=um+c3*stri(6)*stri(6)-c4/2.d0 + endif +! +! state variables +! + xstate(1,iint,iel)=eeq + do i=1,6 + xstate(i+1,iint,iel)=ep(i) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_lin_iso_el.f calculix-ccx-2.3/ccx_2.3/src/umat_lin_iso_el.f --- calculix-ccx-2.1/ccx_2.3/src/umat_lin_iso_el.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_lin_iso_el.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,173 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_lin_iso_el(amat,iel,iint,kode,elconloc,emec,emec0, + & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi, + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) +! +! calculates stiffness and stresses for a user defined material +! law +! +! icmd=3: calcutates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! Notice that the matrix is an integral part of the +! fourth order material tensor, i.e. the Voigt notation +! is not used. +! + implicit none +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & time,ttime +! + real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) +! + real*8 e,un,al,um,am1,am2 +! +! insert here code to calculate the stresses +! + e=elconloc(1) + un=elconloc(2) + al=un*e/(1.d0+un)/(1.d0-2.d0*un) + um=e/2.d0/(1.d0+un) + am1=al+2.d0*um + am2=2.d0*um +! + stre(1)=am1*emec(1)+al*(emec(2)+emec(3))-beta(1) + stre(2)=am1*emec(2)+al*(emec(1)+emec(3))-beta(2) + stre(3)=am1*emec(3)+al*(emec(1)+emec(2))-beta(3) + stre(4)=am2*emec(4)-beta(4) + stre(5)=am2*emec(5)-beta(5) + stre(6)=am2*emec(6)-beta(6) +! + if(icmd.ne.3) then +! +! insert here code to calculate the stiffness matrix +! + stiff(1)=al+2.d0*um + stiff(2)=al + stiff(3)=al+2.d0*um + stiff(4)=al + stiff(5)=al + stiff(6)=al+2.d0*um + stiff(7)=0.d0 + stiff(8)=0.d0 + stiff(9)=0.d0 + stiff(10)=um + stiff(11)=0.d0 + stiff(12)=0.d0 + stiff(13)=0.d0 + stiff(14)=0.d0 + stiff(15)=um + stiff(16)=0.d0 + stiff(17)=0.d0 + stiff(18)=0.d0 + stiff(19)=0.d0 + stiff(20)=0.d0 + stiff(21)=um + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_main.f calculix-ccx-2.3/ccx_2.3/src/umat_main.f --- calculix-ccx-2.1/ccx_2.3/src/umat_main.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_main.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,134 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_main(amat,iel,iint,kode,elconloc,emec,emec0, + & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi, + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, + & orab,pnewdt,istep,iinc,ipkon) +! +! calculates stiffness and stresses for a user defined material +! law +! + implicit none +! + character*80 amat,amatloc +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien, + & istep,iinc,ipkon(*) +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xikl(3,3),vij,pgauss(3),orab(7,*), + & time,ttime,pnewdt +! + real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) +! + if(amat(1:8).eq.'ABAQUSNL') then +! + amatloc(1:72)=amat(9:80) + amatloc(73:80)=' ' + call umat_abaqusnl(amatloc,iel,iint,kode,elconloc,emec, + & emec0,beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi(1),nstate_,xstateini,xstate,stre,stiff, + & iorien,pgauss,orab,istep,iinc) +! + elseif(amat(1:6).eq.'ABAQUS') then +! + amatloc(1:74)=amat(7:80) + amatloc(75:80)=' ' + call umat_abaqus(amatloc,iel,iint,kode,elconloc,emec, + & emec0,beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi(1),nstate_,xstateini,xstate,stre,stiff, + & iorien,pgauss,orab,istep,iinc) +! + elseif(amat(1:10).eq.'ANISO_PLAS') then +! + amatloc(1:70)=amat(11:80) + amatloc(71:80)=' ' + call umat_aniso_plas(amatloc, + & iel,iint,kode,elconloc,emec,emec0, + & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi(1), + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) +! + elseif(amat(1:11).eq.'ANISO_CREEP') then +! + amatloc(1:69)=amat(12:80) + amatloc(70:80)=' ' + call umat_aniso_creep(amatloc, + & iel,iint,kode,elconloc,emec,emec0, + & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi(1), + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) +! + elseif(amat(1:13).eq.'ELASTIC_FIBER') then +! + amatloc(1:67)=amat(14:80) + amatloc(68:80)=' ' + call umat_elastic_fiber(amat(14:80), + & iel,iint,kode,elconloc,emec,emec0, + & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi(1), + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) +! + elseif(amat(1:10).eq.'LIN_ISO_EL') then +! + amatloc(1:70)=amat(11:80) + amatloc(71:80)=' ' + call umat_lin_iso_el(amatloc, + & iel,iint,kode,elconloc,emec,emec0, + & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi(1), + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) +! + elseif(amat(1:9).eq.'IDEAL_GAS') then +! + amatloc(1:71)=amat(10:80) + amatloc(72:80)=' ' + call umat_ideal_gas(amatloc, + & iel,iint,kode,elconloc,emec,emec0, + & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi(1), + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) +! + elseif(amat(1:14).eq.'SINGLE_CRYSTAL') then +! + amatloc(1:66)=amat(15:80) + amatloc(67:80)=' ' + call umat_single_crystal(amatloc, + & iel,iint,kode,elconloc,emec, + & emec0,beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi(1), + & nstate_,xstateini,xstate,stre,stiff,iorien,pgauss,orab) +! + elseif(amat(1:4).eq.'USER') then +! + amatloc(1:76)=amat(5:80) + amatloc(77:80)=' ' + call umat_user(amatloc,iel,iint,kode,elconloc,emec,emec0, + & beta,xikl,vij,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi(1),nstate_,xstateini,xstate,stre,stiff, + & iorien,pgauss,orab,pnewdt,ipkon) + else + write(*,*) '*ERROR in umat: no user material subroutine' + write(*,*) ' defined for material ',amat + stop + endif +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_single_crystal.f calculix-ccx-2.3/ccx_2.3/src/umat_single_crystal.f --- calculix-ccx-2.1/ccx_2.3/src/umat_single_crystal.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_single_crystal.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1422 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_single_crystal(amat,iel,iint,kode,elconloc,emec, + & emec0,beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas, + & mi,nstate_,xstateini,xstate,stre,stiff,iorien,pgauss, + & orab) +! +! calculates stiffness and stresses for a user defined material +! law +! +! icmd=3: calcutates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! Notice that the matrix is an integral part of the +! fourth order material tensor, i.e. the Voigt notation +! is not used. +! + implicit none +! + logical active(18),convergence,creep +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien +! + integer index(18),i,j,k,l,ipiv(18),info,ichange,neq,lda,ldb, + & nrhs,iplas,icounter +! + real*8 ep0(6),al10(18),al20(18),dg0(18),ep(6),al1(18), + & al2(18),dg(18),ddg(18),xm(6,18),h(18,18),ck(18),cn(18), + & c(18),d(18),phi(18),delta(18),r0(18),q(18),b(18),cphi(18), + & q1(18),q2(18),stri(6),htri(18),sg(18),r(42),xmc(6,18),aux(18), + & t(42),gl(18,18),gr(18,18),ee(6),c1111,c1122,c1212,dd, + & skl(3,3),xmtran(3,3),ddsdde(6,6),xx(6,18) +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & elas(21),time,ttime +! + real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) +! + save ep0,al10,al20,dg0,xx,h +! +! +! crystallographic slip planes: +! +! 1. n=1,1,1 l=1,-1,0 +! 2. n=1,1,1 l=1,0,-1 +! 3. n=1,1,1 l=0,1,-1 +! 4. n=1,-1,1 l=0,1,1 +! 5. n=1,-1,1 l=1,0,-1 +! 6. n=1,-1,1 l=1,1,0 +! 7. n=1,-1,-1 l=0,1,-1 +! 8. n=1,-1,-1 l=1,0,1 +! 9. n=1,-1,-1 l=1,1,0 +! 10. n=1,1,-1 l=0,1,1 +! 11. n=1,1,-1 l=1,0,1 +! 12. n=1,1,-1 l=1,-1,0 +! 13. n=1,0,0 l=0,1,1 +! 14. n=1,0,0 l=0,1,-1 +! 15. n=0,1,0 l=1,0,1 +! 16. n=0,1,0 l=1,0,-1 +! 17. n=0,0,1 l=1,1,0 +! 18. n=0,0,1 l=1,-1,0 +! + data xm + & /0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.2041241452319E+00,-0.2041241452319E+00, + & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, + & 0.2041241452319E+00, 0.0000000000000E+00,-0.2041241452319E+00, + & 0.0000000000000E+00, 0.4082482904639E+00,-0.4082482904639E+00, + & 0.2041241452319E+00,-0.2041241452319E+00, 0.0000000000000E+00, + & 0.0000000000000E+00,-0.4082482904639E+00, 0.4082482904639E+00, + & 0.2041241452319E+00, 0.2041241452319E+00, 0.0000000000000E+00, + & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, + & -0.2041241452319E+00, 0.0000000000000E+00, 0.2041241452319E+00, + & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.2041241452319E+00, 0.2041241452319E+00, + & 0.0000000000000E+00,-0.4082482904639E+00, 0.4082482904639E+00, + & 0.2041241452319E+00,-0.2041241452319E+00, 0.0000000000000E+00, + & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, + & -0.2041241452319E+00, 0.0000000000000E+00,-0.2041241452319E+00, + & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, + & 0.0000000000000E+00,-0.2041241452319E+00,-0.2041241452319E+00, + & 0.0000000000000E+00, 0.4082482904639E+00,-0.4082482904639E+00, + & 0.2041241452319E+00, 0.2041241452319E+00, 0.0000000000000E+00, + & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, + & 0.2041241452319E+00, 0.0000000000000E+00, 0.2041241452319E+00, + & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, + & 0.0000000000000E+00,-0.2041241452319E+00, 0.2041241452319E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.3535533905933E+00, 0.3535533905933E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.3535533905933E+00,-0.3535533905933E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.3535533905933E+00, 0.0000000000000E+00, 0.3535533905933E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.3535533905933E+00, 0.0000000000000E+00,-0.3535533905933E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.3535533905933E+00, 0.3535533905933E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.3535533905933E+00,-0.3535533905933E+00/ +! + data xx + & /0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.2041241452319E+00,-0.2041241452319E+00, + & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, + & 0.2041241452319E+00, 0.0000000000000E+00,-0.2041241452319E+00, + & 0.0000000000000E+00, 0.4082482904639E+00,-0.4082482904639E+00, + & 0.2041241452319E+00,-0.2041241452319E+00, 0.0000000000000E+00, + & 0.0000000000000E+00,-0.4082482904639E+00, 0.4082482904639E+00, + & 0.2041241452319E+00, 0.2041241452319E+00, 0.0000000000000E+00, + & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, + & -0.2041241452319E+00, 0.0000000000000E+00, 0.2041241452319E+00, + & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.2041241452319E+00, 0.2041241452319E+00, + & 0.0000000000000E+00,-0.4082482904639E+00, 0.4082482904639E+00, + & 0.2041241452319E+00,-0.2041241452319E+00, 0.0000000000000E+00, + & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, + & -0.2041241452319E+00, 0.0000000000000E+00,-0.2041241452319E+00, + & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, + & 0.0000000000000E+00,-0.2041241452319E+00,-0.2041241452319E+00, + & 0.0000000000000E+00, 0.4082482904639E+00,-0.4082482904639E+00, + & 0.2041241452319E+00, 0.2041241452319E+00, 0.0000000000000E+00, + & 0.4082482904639E+00, 0.0000000000000E+00,-0.4082482904639E+00, + & 0.2041241452319E+00, 0.0000000000000E+00, 0.2041241452319E+00, + & 0.4082482904639E+00,-0.4082482904639E+00, 0.0000000000000E+00, + & 0.0000000000000E+00,-0.2041241452319E+00, 0.2041241452319E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.3535533905933E+00, 0.3535533905933E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.3535533905933E+00,-0.3535533905933E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.3535533905933E+00, 0.0000000000000E+00, 0.3535533905933E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.3535533905933E+00, 0.0000000000000E+00,-0.3535533905933E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.3535533905933E+00, 0.3535533905933E+00, + & 0.0000000000000E+00, 0.0000000000000E+00, 0.0000000000000E+00, + & 0.0000000000000E+00, 0.3535533905933E+00,-0.3535533905933E+00/ +! + data h + & /0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00, 0.1E+01,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00, + & -0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00, + & -0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00, 0.1E+01,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.1E+01,-0.1E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00,-0.1E+00, 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00, + & 0.1E+01,-0.1E+00,-0.1E+00,-0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00, + & -0.1E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00, + & -0.1E+00,-0.1E+00,-0.1E+00, 0.1E+01,-0.1E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, 0.0E+00, + & 0.0E+00, 0.0E+00, 0.0E+00,-0.1E+00,-0.1E+00,-0.1E+00,-0.1E+00, + & -0.1E+00, 0.1E+01/ +! +! elastic constants +! + c1111=elconloc(1) + c1122=elconloc(2) + c1212=elconloc(3) +! + if(iorien.gt.0) then + call transformatrix(orab(1,iorien),pgauss,skl) + do k=1,18 + do i=1,3 + do j=i,3 + xmtran(i,j)=skl(i,1)*skl(j,1)*xx(1,k)+ + & skl(i,2)*skl(j,2)*xx(2,k)+ + & skl(i,3)*skl(j,3)*xx(3,k)+ + & (skl(i,1)*skl(j,2)+ + & skl(i,2)*skl(j,1))*xx(4,k)+ + & (skl(i,1)*skl(j,3)+ + & skl(i,3)*skl(j,1))*xx(5,k)+ + & (skl(i,2)*skl(j,3)+ + & skl(i,3)*skl(j,2))*xx(6,k) + enddo + enddo + xm(1,k)=xmtran(1,1) + xm(2,k)=xmtran(2,2) + xm(3,k)=xmtran(3,3) + xm(4,k)=xmtran(1,2) + xm(5,k)=xmtran(1,3) + xm(6,k)=xmtran(2,3) + enddo +! + elas( 1)= + & skl(1,1)*skl(1,1)*skl(1,1)*skl(1,1)*c1111+ + & skl(1,1)*skl(1,1)*skl(1,2)*skl(1,2)*c1122+ + & skl(1,1)*skl(1,1)*skl(1,3)*skl(1,3)*c1122+ + & skl(1,1)*skl(1,2)*skl(1,1)*skl(1,2)*c1212+ + & skl(1,1)*skl(1,2)*skl(1,2)*skl(1,1)*c1212+ + & skl(1,1)*skl(1,3)*skl(1,1)*skl(1,3)*c1212+ + & skl(1,1)*skl(1,3)*skl(1,3)*skl(1,1)*c1212+ + & skl(1,2)*skl(1,1)*skl(1,1)*skl(1,2)*c1212+ + & skl(1,2)*skl(1,1)*skl(1,2)*skl(1,1)*c1212+ + & skl(1,2)*skl(1,2)*skl(1,1)*skl(1,1)*c1122+ + & skl(1,2)*skl(1,2)*skl(1,2)*skl(1,2)*c1111+ + & skl(1,2)*skl(1,2)*skl(1,3)*skl(1,3)*c1122+ + & skl(1,2)*skl(1,3)*skl(1,2)*skl(1,3)*c1212+ + & skl(1,2)*skl(1,3)*skl(1,3)*skl(1,2)*c1212+ + & skl(1,3)*skl(1,1)*skl(1,1)*skl(1,3)*c1212+ + & skl(1,3)*skl(1,1)*skl(1,3)*skl(1,1)*c1212+ + & skl(1,3)*skl(1,2)*skl(1,2)*skl(1,3)*c1212+ + & skl(1,3)*skl(1,2)*skl(1,3)*skl(1,2)*c1212+ + & skl(1,3)*skl(1,3)*skl(1,1)*skl(1,1)*c1122+ + & skl(1,3)*skl(1,3)*skl(1,2)*skl(1,2)*c1122+ + & skl(1,3)*skl(1,3)*skl(1,3)*skl(1,3)*c1111 + elas( 2)= + & skl(1,1)*skl(1,1)*skl(2,1)*skl(2,1)*c1111+ + & skl(1,1)*skl(1,1)*skl(2,2)*skl(2,2)*c1122+ + & skl(1,1)*skl(1,1)*skl(2,3)*skl(2,3)*c1122+ + & skl(1,1)*skl(1,2)*skl(2,1)*skl(2,2)*c1212+ + & skl(1,1)*skl(1,2)*skl(2,2)*skl(2,1)*c1212+ + & skl(1,1)*skl(1,3)*skl(2,1)*skl(2,3)*c1212+ + & skl(1,1)*skl(1,3)*skl(2,3)*skl(2,1)*c1212+ + & skl(1,2)*skl(1,1)*skl(2,1)*skl(2,2)*c1212+ + & skl(1,2)*skl(1,1)*skl(2,2)*skl(2,1)*c1212+ + & skl(1,2)*skl(1,2)*skl(2,1)*skl(2,1)*c1122+ + & skl(1,2)*skl(1,2)*skl(2,2)*skl(2,2)*c1111+ + & skl(1,2)*skl(1,2)*skl(2,3)*skl(2,3)*c1122+ + & skl(1,2)*skl(1,3)*skl(2,2)*skl(2,3)*c1212+ + & skl(1,2)*skl(1,3)*skl(2,3)*skl(2,2)*c1212+ + & skl(1,3)*skl(1,1)*skl(2,1)*skl(2,3)*c1212+ + & skl(1,3)*skl(1,1)*skl(2,3)*skl(2,1)*c1212+ + & skl(1,3)*skl(1,2)*skl(2,2)*skl(2,3)*c1212+ + & skl(1,3)*skl(1,2)*skl(2,3)*skl(2,2)*c1212+ + & skl(1,3)*skl(1,3)*skl(2,1)*skl(2,1)*c1122+ + & skl(1,3)*skl(1,3)*skl(2,2)*skl(2,2)*c1122+ + & skl(1,3)*skl(1,3)*skl(2,3)*skl(2,3)*c1111 + elas( 3)= + & skl(2,1)*skl(2,1)*skl(2,1)*skl(2,1)*c1111+ + & skl(2,1)*skl(2,1)*skl(2,2)*skl(2,2)*c1122+ + & skl(2,1)*skl(2,1)*skl(2,3)*skl(2,3)*c1122+ + & skl(2,1)*skl(2,2)*skl(2,1)*skl(2,2)*c1212+ + & skl(2,1)*skl(2,2)*skl(2,2)*skl(2,1)*c1212+ + & skl(2,1)*skl(2,3)*skl(2,1)*skl(2,3)*c1212+ + & skl(2,1)*skl(2,3)*skl(2,3)*skl(2,1)*c1212+ + & skl(2,2)*skl(2,1)*skl(2,1)*skl(2,2)*c1212+ + & skl(2,2)*skl(2,1)*skl(2,2)*skl(2,1)*c1212+ + & skl(2,2)*skl(2,2)*skl(2,1)*skl(2,1)*c1122+ + & skl(2,2)*skl(2,2)*skl(2,2)*skl(2,2)*c1111+ + & skl(2,2)*skl(2,2)*skl(2,3)*skl(2,3)*c1122+ + & skl(2,2)*skl(2,3)*skl(2,2)*skl(2,3)*c1212+ + & skl(2,2)*skl(2,3)*skl(2,3)*skl(2,2)*c1212+ + & skl(2,3)*skl(2,1)*skl(2,1)*skl(2,3)*c1212+ + & skl(2,3)*skl(2,1)*skl(2,3)*skl(2,1)*c1212+ + & skl(2,3)*skl(2,2)*skl(2,2)*skl(2,3)*c1212+ + & skl(2,3)*skl(2,2)*skl(2,3)*skl(2,2)*c1212+ + & skl(2,3)*skl(2,3)*skl(2,1)*skl(2,1)*c1122+ + & skl(2,3)*skl(2,3)*skl(2,2)*skl(2,2)*c1122+ + & skl(2,3)*skl(2,3)*skl(2,3)*skl(2,3)*c1111 + elas( 4)= + & skl(1,1)*skl(1,1)*skl(3,1)*skl(3,1)*c1111+ + & skl(1,1)*skl(1,1)*skl(3,2)*skl(3,2)*c1122+ + & skl(1,1)*skl(1,1)*skl(3,3)*skl(3,3)*c1122+ + & skl(1,1)*skl(1,2)*skl(3,1)*skl(3,2)*c1212+ + & skl(1,1)*skl(1,2)*skl(3,2)*skl(3,1)*c1212+ + & skl(1,1)*skl(1,3)*skl(3,1)*skl(3,3)*c1212+ + & skl(1,1)*skl(1,3)*skl(3,3)*skl(3,1)*c1212+ + & skl(1,2)*skl(1,1)*skl(3,1)*skl(3,2)*c1212+ + & skl(1,2)*skl(1,1)*skl(3,2)*skl(3,1)*c1212+ + & skl(1,2)*skl(1,2)*skl(3,1)*skl(3,1)*c1122+ + & skl(1,2)*skl(1,2)*skl(3,2)*skl(3,2)*c1111+ + & skl(1,2)*skl(1,2)*skl(3,3)*skl(3,3)*c1122+ + & skl(1,2)*skl(1,3)*skl(3,2)*skl(3,3)*c1212+ + & skl(1,2)*skl(1,3)*skl(3,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(1,1)*skl(3,1)*skl(3,3)*c1212+ + & skl(1,3)*skl(1,1)*skl(3,3)*skl(3,1)*c1212+ + & skl(1,3)*skl(1,2)*skl(3,2)*skl(3,3)*c1212+ + & skl(1,3)*skl(1,2)*skl(3,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(1,3)*skl(3,1)*skl(3,1)*c1122+ + & skl(1,3)*skl(1,3)*skl(3,2)*skl(3,2)*c1122+ + & skl(1,3)*skl(1,3)*skl(3,3)*skl(3,3)*c1111 + elas( 5)= + & skl(2,1)*skl(2,1)*skl(3,1)*skl(3,1)*c1111+ + & skl(2,1)*skl(2,1)*skl(3,2)*skl(3,2)*c1122+ + & skl(2,1)*skl(2,1)*skl(3,3)*skl(3,3)*c1122+ + & skl(2,1)*skl(2,2)*skl(3,1)*skl(3,2)*c1212+ + & skl(2,1)*skl(2,2)*skl(3,2)*skl(3,1)*c1212+ + & skl(2,1)*skl(2,3)*skl(3,1)*skl(3,3)*c1212+ + & skl(2,1)*skl(2,3)*skl(3,3)*skl(3,1)*c1212+ + & skl(2,2)*skl(2,1)*skl(3,1)*skl(3,2)*c1212+ + & skl(2,2)*skl(2,1)*skl(3,2)*skl(3,1)*c1212+ + & skl(2,2)*skl(2,2)*skl(3,1)*skl(3,1)*c1122+ + & skl(2,2)*skl(2,2)*skl(3,2)*skl(3,2)*c1111+ + & skl(2,2)*skl(2,2)*skl(3,3)*skl(3,3)*c1122+ + & skl(2,2)*skl(2,3)*skl(3,2)*skl(3,3)*c1212+ + & skl(2,2)*skl(2,3)*skl(3,3)*skl(3,2)*c1212+ + & skl(2,3)*skl(2,1)*skl(3,1)*skl(3,3)*c1212+ + & skl(2,3)*skl(2,1)*skl(3,3)*skl(3,1)*c1212+ + & skl(2,3)*skl(2,2)*skl(3,2)*skl(3,3)*c1212+ + & skl(2,3)*skl(2,2)*skl(3,3)*skl(3,2)*c1212+ + & skl(2,3)*skl(2,3)*skl(3,1)*skl(3,1)*c1122+ + & skl(2,3)*skl(2,3)*skl(3,2)*skl(3,2)*c1122+ + & skl(2,3)*skl(2,3)*skl(3,3)*skl(3,3)*c1111 + elas( 6)= + & skl(3,1)*skl(3,1)*skl(3,1)*skl(3,1)*c1111+ + & skl(3,1)*skl(3,1)*skl(3,2)*skl(3,2)*c1122+ + & skl(3,1)*skl(3,1)*skl(3,3)*skl(3,3)*c1122+ + & skl(3,1)*skl(3,2)*skl(3,1)*skl(3,2)*c1212+ + & skl(3,1)*skl(3,2)*skl(3,2)*skl(3,1)*c1212+ + & skl(3,1)*skl(3,3)*skl(3,1)*skl(3,3)*c1212+ + & skl(3,1)*skl(3,3)*skl(3,3)*skl(3,1)*c1212+ + & skl(3,2)*skl(3,1)*skl(3,1)*skl(3,2)*c1212+ + & skl(3,2)*skl(3,1)*skl(3,2)*skl(3,1)*c1212+ + & skl(3,2)*skl(3,2)*skl(3,1)*skl(3,1)*c1122+ + & skl(3,2)*skl(3,2)*skl(3,2)*skl(3,2)*c1111+ + & skl(3,2)*skl(3,2)*skl(3,3)*skl(3,3)*c1122+ + & skl(3,2)*skl(3,3)*skl(3,2)*skl(3,3)*c1212+ + & skl(3,2)*skl(3,3)*skl(3,3)*skl(3,2)*c1212+ + & skl(3,3)*skl(3,1)*skl(3,1)*skl(3,3)*c1212+ + & skl(3,3)*skl(3,1)*skl(3,3)*skl(3,1)*c1212+ + & skl(3,3)*skl(3,2)*skl(3,2)*skl(3,3)*c1212+ + & skl(3,3)*skl(3,2)*skl(3,3)*skl(3,2)*c1212+ + & skl(3,3)*skl(3,3)*skl(3,1)*skl(3,1)*c1122+ + & skl(3,3)*skl(3,3)*skl(3,2)*skl(3,2)*c1122+ + & skl(3,3)*skl(3,3)*skl(3,3)*skl(3,3)*c1111 + elas( 7)= + & skl(1,1)*skl(1,1)*skl(1,1)*skl(2,1)*c1111+ + & skl(1,1)*skl(1,1)*skl(1,2)*skl(2,2)*c1122+ + & skl(1,1)*skl(1,1)*skl(1,3)*skl(2,3)*c1122+ + & skl(1,1)*skl(1,2)*skl(1,1)*skl(2,2)*c1212+ + & skl(1,1)*skl(1,2)*skl(1,2)*skl(2,1)*c1212+ + & skl(1,1)*skl(1,3)*skl(1,1)*skl(2,3)*c1212+ + & skl(1,1)*skl(1,3)*skl(1,3)*skl(2,1)*c1212+ + & skl(1,2)*skl(1,1)*skl(1,1)*skl(2,2)*c1212+ + & skl(1,2)*skl(1,1)*skl(1,2)*skl(2,1)*c1212+ + & skl(1,2)*skl(1,2)*skl(1,1)*skl(2,1)*c1122+ + & skl(1,2)*skl(1,2)*skl(1,2)*skl(2,2)*c1111+ + & skl(1,2)*skl(1,2)*skl(1,3)*skl(2,3)*c1122+ + & skl(1,2)*skl(1,3)*skl(1,2)*skl(2,3)*c1212+ + & skl(1,2)*skl(1,3)*skl(1,3)*skl(2,2)*c1212+ + & skl(1,3)*skl(1,1)*skl(1,1)*skl(2,3)*c1212+ + & skl(1,3)*skl(1,1)*skl(1,3)*skl(2,1)*c1212+ + & skl(1,3)*skl(1,2)*skl(1,2)*skl(2,3)*c1212+ + & skl(1,3)*skl(1,2)*skl(1,3)*skl(2,2)*c1212+ + & skl(1,3)*skl(1,3)*skl(1,1)*skl(2,1)*c1122+ + & skl(1,3)*skl(1,3)*skl(1,2)*skl(2,2)*c1122+ + & skl(1,3)*skl(1,3)*skl(1,3)*skl(2,3)*c1111 + elas( 8)= + & skl(2,1)*skl(2,1)*skl(1,1)*skl(2,1)*c1111+ + & skl(2,1)*skl(2,1)*skl(1,2)*skl(2,2)*c1122+ + & skl(2,1)*skl(2,1)*skl(1,3)*skl(2,3)*c1122+ + & skl(2,1)*skl(2,2)*skl(1,1)*skl(2,2)*c1212+ + & skl(2,1)*skl(2,2)*skl(1,2)*skl(2,1)*c1212+ + & skl(2,1)*skl(2,3)*skl(1,1)*skl(2,3)*c1212+ + & skl(2,1)*skl(2,3)*skl(1,3)*skl(2,1)*c1212+ + & skl(2,2)*skl(2,1)*skl(1,1)*skl(2,2)*c1212+ + & skl(2,2)*skl(2,1)*skl(1,2)*skl(2,1)*c1212+ + & skl(2,2)*skl(2,2)*skl(1,1)*skl(2,1)*c1122+ + & skl(2,2)*skl(2,2)*skl(1,2)*skl(2,2)*c1111+ + & skl(2,2)*skl(2,2)*skl(1,3)*skl(2,3)*c1122+ + & skl(2,2)*skl(2,3)*skl(1,2)*skl(2,3)*c1212+ + & skl(2,2)*skl(2,3)*skl(1,3)*skl(2,2)*c1212+ + & skl(2,3)*skl(2,1)*skl(1,1)*skl(2,3)*c1212+ + & skl(2,3)*skl(2,1)*skl(1,3)*skl(2,1)*c1212+ + & skl(2,3)*skl(2,2)*skl(1,2)*skl(2,3)*c1212+ + & skl(2,3)*skl(2,2)*skl(1,3)*skl(2,2)*c1212+ + & skl(2,3)*skl(2,3)*skl(1,1)*skl(2,1)*c1122+ + & skl(2,3)*skl(2,3)*skl(1,2)*skl(2,2)*c1122+ + & skl(2,3)*skl(2,3)*skl(1,3)*skl(2,3)*c1111 + elas( 9)= + & skl(3,1)*skl(3,1)*skl(1,1)*skl(2,1)*c1111+ + & skl(3,1)*skl(3,1)*skl(1,2)*skl(2,2)*c1122+ + & skl(3,1)*skl(3,1)*skl(1,3)*skl(2,3)*c1122+ + & skl(3,1)*skl(3,2)*skl(1,1)*skl(2,2)*c1212+ + & skl(3,1)*skl(3,2)*skl(1,2)*skl(2,1)*c1212+ + & skl(3,1)*skl(3,3)*skl(1,1)*skl(2,3)*c1212+ + & skl(3,1)*skl(3,3)*skl(1,3)*skl(2,1)*c1212+ + & skl(3,2)*skl(3,1)*skl(1,1)*skl(2,2)*c1212+ + & skl(3,2)*skl(3,1)*skl(1,2)*skl(2,1)*c1212+ + & skl(3,2)*skl(3,2)*skl(1,1)*skl(2,1)*c1122+ + & skl(3,2)*skl(3,2)*skl(1,2)*skl(2,2)*c1111+ + & skl(3,2)*skl(3,2)*skl(1,3)*skl(2,3)*c1122+ + & skl(3,2)*skl(3,3)*skl(1,2)*skl(2,3)*c1212+ + & skl(3,2)*skl(3,3)*skl(1,3)*skl(2,2)*c1212+ + & skl(3,3)*skl(3,1)*skl(1,1)*skl(2,3)*c1212+ + & skl(3,3)*skl(3,1)*skl(1,3)*skl(2,1)*c1212+ + & skl(3,3)*skl(3,2)*skl(1,2)*skl(2,3)*c1212+ + & skl(3,3)*skl(3,2)*skl(1,3)*skl(2,2)*c1212+ + & skl(3,3)*skl(3,3)*skl(1,1)*skl(2,1)*c1122+ + & skl(3,3)*skl(3,3)*skl(1,2)*skl(2,2)*c1122+ + & skl(3,3)*skl(3,3)*skl(1,3)*skl(2,3)*c1111 + elas(10)= + & skl(1,1)*skl(2,1)*skl(1,1)*skl(2,1)*c1111+ + & skl(1,1)*skl(2,1)*skl(1,2)*skl(2,2)*c1122+ + & skl(1,1)*skl(2,1)*skl(1,3)*skl(2,3)*c1122+ + & skl(1,1)*skl(2,2)*skl(1,1)*skl(2,2)*c1212+ + & skl(1,1)*skl(2,2)*skl(1,2)*skl(2,1)*c1212+ + & skl(1,1)*skl(2,3)*skl(1,1)*skl(2,3)*c1212+ + & skl(1,1)*skl(2,3)*skl(1,3)*skl(2,1)*c1212+ + & skl(1,2)*skl(2,1)*skl(1,1)*skl(2,2)*c1212+ + & skl(1,2)*skl(2,1)*skl(1,2)*skl(2,1)*c1212+ + & skl(1,2)*skl(2,2)*skl(1,1)*skl(2,1)*c1122+ + & skl(1,2)*skl(2,2)*skl(1,2)*skl(2,2)*c1111+ + & skl(1,2)*skl(2,2)*skl(1,3)*skl(2,3)*c1122+ + & skl(1,2)*skl(2,3)*skl(1,2)*skl(2,3)*c1212+ + & skl(1,2)*skl(2,3)*skl(1,3)*skl(2,2)*c1212+ + & skl(1,3)*skl(2,1)*skl(1,1)*skl(2,3)*c1212+ + & skl(1,3)*skl(2,1)*skl(1,3)*skl(2,1)*c1212+ + & skl(1,3)*skl(2,2)*skl(1,2)*skl(2,3)*c1212+ + & skl(1,3)*skl(2,2)*skl(1,3)*skl(2,2)*c1212+ + & skl(1,3)*skl(2,3)*skl(1,1)*skl(2,1)*c1122+ + & skl(1,3)*skl(2,3)*skl(1,2)*skl(2,2)*c1122+ + & skl(1,3)*skl(2,3)*skl(1,3)*skl(2,3)*c1111 + elas(11)= + & skl(1,1)*skl(1,1)*skl(1,1)*skl(3,1)*c1111+ + & skl(1,1)*skl(1,1)*skl(1,2)*skl(3,2)*c1122+ + & skl(1,1)*skl(1,1)*skl(1,3)*skl(3,3)*c1122+ + & skl(1,1)*skl(1,2)*skl(1,1)*skl(3,2)*c1212+ + & skl(1,1)*skl(1,2)*skl(1,2)*skl(3,1)*c1212+ + & skl(1,1)*skl(1,3)*skl(1,1)*skl(3,3)*c1212+ + & skl(1,1)*skl(1,3)*skl(1,3)*skl(3,1)*c1212+ + & skl(1,2)*skl(1,1)*skl(1,1)*skl(3,2)*c1212+ + & skl(1,2)*skl(1,1)*skl(1,2)*skl(3,1)*c1212+ + & skl(1,2)*skl(1,2)*skl(1,1)*skl(3,1)*c1122+ + & skl(1,2)*skl(1,2)*skl(1,2)*skl(3,2)*c1111+ + & skl(1,2)*skl(1,2)*skl(1,3)*skl(3,3)*c1122+ + & skl(1,2)*skl(1,3)*skl(1,2)*skl(3,3)*c1212+ + & skl(1,2)*skl(1,3)*skl(1,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(1,1)*skl(1,1)*skl(3,3)*c1212+ + & skl(1,3)*skl(1,1)*skl(1,3)*skl(3,1)*c1212+ + & skl(1,3)*skl(1,2)*skl(1,2)*skl(3,3)*c1212+ + & skl(1,3)*skl(1,2)*skl(1,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(1,3)*skl(1,1)*skl(3,1)*c1122+ + & skl(1,3)*skl(1,3)*skl(1,2)*skl(3,2)*c1122+ + & skl(1,3)*skl(1,3)*skl(1,3)*skl(3,3)*c1111 + elas(12)= + & skl(2,1)*skl(2,1)*skl(1,1)*skl(3,1)*c1111+ + & skl(2,1)*skl(2,1)*skl(1,2)*skl(3,2)*c1122+ + & skl(2,1)*skl(2,1)*skl(1,3)*skl(3,3)*c1122+ + & skl(2,1)*skl(2,2)*skl(1,1)*skl(3,2)*c1212+ + & skl(2,1)*skl(2,2)*skl(1,2)*skl(3,1)*c1212+ + & skl(2,1)*skl(2,3)*skl(1,1)*skl(3,3)*c1212+ + & skl(2,1)*skl(2,3)*skl(1,3)*skl(3,1)*c1212+ + & skl(2,2)*skl(2,1)*skl(1,1)*skl(3,2)*c1212+ + & skl(2,2)*skl(2,1)*skl(1,2)*skl(3,1)*c1212+ + & skl(2,2)*skl(2,2)*skl(1,1)*skl(3,1)*c1122+ + & skl(2,2)*skl(2,2)*skl(1,2)*skl(3,2)*c1111+ + & skl(2,2)*skl(2,2)*skl(1,3)*skl(3,3)*c1122+ + & skl(2,2)*skl(2,3)*skl(1,2)*skl(3,3)*c1212+ + & skl(2,2)*skl(2,3)*skl(1,3)*skl(3,2)*c1212+ + & skl(2,3)*skl(2,1)*skl(1,1)*skl(3,3)*c1212+ + & skl(2,3)*skl(2,1)*skl(1,3)*skl(3,1)*c1212+ + & skl(2,3)*skl(2,2)*skl(1,2)*skl(3,3)*c1212+ + & skl(2,3)*skl(2,2)*skl(1,3)*skl(3,2)*c1212+ + & skl(2,3)*skl(2,3)*skl(1,1)*skl(3,1)*c1122+ + & skl(2,3)*skl(2,3)*skl(1,2)*skl(3,2)*c1122+ + & skl(2,3)*skl(2,3)*skl(1,3)*skl(3,3)*c1111 + elas(13)= + & skl(3,1)*skl(3,1)*skl(1,1)*skl(3,1)*c1111+ + & skl(3,1)*skl(3,1)*skl(1,2)*skl(3,2)*c1122+ + & skl(3,1)*skl(3,1)*skl(1,3)*skl(3,3)*c1122+ + & skl(3,1)*skl(3,2)*skl(1,1)*skl(3,2)*c1212+ + & skl(3,1)*skl(3,2)*skl(1,2)*skl(3,1)*c1212+ + & skl(3,1)*skl(3,3)*skl(1,1)*skl(3,3)*c1212+ + & skl(3,1)*skl(3,3)*skl(1,3)*skl(3,1)*c1212+ + & skl(3,2)*skl(3,1)*skl(1,1)*skl(3,2)*c1212+ + & skl(3,2)*skl(3,1)*skl(1,2)*skl(3,1)*c1212+ + & skl(3,2)*skl(3,2)*skl(1,1)*skl(3,1)*c1122+ + & skl(3,2)*skl(3,2)*skl(1,2)*skl(3,2)*c1111+ + & skl(3,2)*skl(3,2)*skl(1,3)*skl(3,3)*c1122+ + & skl(3,2)*skl(3,3)*skl(1,2)*skl(3,3)*c1212+ + & skl(3,2)*skl(3,3)*skl(1,3)*skl(3,2)*c1212+ + & skl(3,3)*skl(3,1)*skl(1,1)*skl(3,3)*c1212+ + & skl(3,3)*skl(3,1)*skl(1,3)*skl(3,1)*c1212+ + & skl(3,3)*skl(3,2)*skl(1,2)*skl(3,3)*c1212+ + & skl(3,3)*skl(3,2)*skl(1,3)*skl(3,2)*c1212+ + & skl(3,3)*skl(3,3)*skl(1,1)*skl(3,1)*c1122+ + & skl(3,3)*skl(3,3)*skl(1,2)*skl(3,2)*c1122+ + & skl(3,3)*skl(3,3)*skl(1,3)*skl(3,3)*c1111 + elas(14)= + & skl(1,1)*skl(2,1)*skl(1,1)*skl(3,1)*c1111+ + & skl(1,1)*skl(2,1)*skl(1,2)*skl(3,2)*c1122+ + & skl(1,1)*skl(2,1)*skl(1,3)*skl(3,3)*c1122+ + & skl(1,1)*skl(2,2)*skl(1,1)*skl(3,2)*c1212+ + & skl(1,1)*skl(2,2)*skl(1,2)*skl(3,1)*c1212+ + & skl(1,1)*skl(2,3)*skl(1,1)*skl(3,3)*c1212+ + & skl(1,1)*skl(2,3)*skl(1,3)*skl(3,1)*c1212+ + & skl(1,2)*skl(2,1)*skl(1,1)*skl(3,2)*c1212+ + & skl(1,2)*skl(2,1)*skl(1,2)*skl(3,1)*c1212+ + & skl(1,2)*skl(2,2)*skl(1,1)*skl(3,1)*c1122+ + & skl(1,2)*skl(2,2)*skl(1,2)*skl(3,2)*c1111+ + & skl(1,2)*skl(2,2)*skl(1,3)*skl(3,3)*c1122+ + & skl(1,2)*skl(2,3)*skl(1,2)*skl(3,3)*c1212+ + & skl(1,2)*skl(2,3)*skl(1,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(2,1)*skl(1,1)*skl(3,3)*c1212+ + & skl(1,3)*skl(2,1)*skl(1,3)*skl(3,1)*c1212+ + & skl(1,3)*skl(2,2)*skl(1,2)*skl(3,3)*c1212+ + & skl(1,3)*skl(2,2)*skl(1,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(2,3)*skl(1,1)*skl(3,1)*c1122+ + & skl(1,3)*skl(2,3)*skl(1,2)*skl(3,2)*c1122+ + & skl(1,3)*skl(2,3)*skl(1,3)*skl(3,3)*c1111 + elas(15)= + & skl(1,1)*skl(3,1)*skl(1,1)*skl(3,1)*c1111+ + & skl(1,1)*skl(3,1)*skl(1,2)*skl(3,2)*c1122+ + & skl(1,1)*skl(3,1)*skl(1,3)*skl(3,3)*c1122+ + & skl(1,1)*skl(3,2)*skl(1,1)*skl(3,2)*c1212+ + & skl(1,1)*skl(3,2)*skl(1,2)*skl(3,1)*c1212+ + & skl(1,1)*skl(3,3)*skl(1,1)*skl(3,3)*c1212+ + & skl(1,1)*skl(3,3)*skl(1,3)*skl(3,1)*c1212+ + & skl(1,2)*skl(3,1)*skl(1,1)*skl(3,2)*c1212+ + & skl(1,2)*skl(3,1)*skl(1,2)*skl(3,1)*c1212+ + & skl(1,2)*skl(3,2)*skl(1,1)*skl(3,1)*c1122+ + & skl(1,2)*skl(3,2)*skl(1,2)*skl(3,2)*c1111+ + & skl(1,2)*skl(3,2)*skl(1,3)*skl(3,3)*c1122+ + & skl(1,2)*skl(3,3)*skl(1,2)*skl(3,3)*c1212+ + & skl(1,2)*skl(3,3)*skl(1,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(3,1)*skl(1,1)*skl(3,3)*c1212+ + & skl(1,3)*skl(3,1)*skl(1,3)*skl(3,1)*c1212+ + & skl(1,3)*skl(3,2)*skl(1,2)*skl(3,3)*c1212+ + & skl(1,3)*skl(3,2)*skl(1,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(3,3)*skl(1,1)*skl(3,1)*c1122+ + & skl(1,3)*skl(3,3)*skl(1,2)*skl(3,2)*c1122+ + & skl(1,3)*skl(3,3)*skl(1,3)*skl(3,3)*c1111 + elas(16)= + & skl(1,1)*skl(1,1)*skl(2,1)*skl(3,1)*c1111+ + & skl(1,1)*skl(1,1)*skl(2,2)*skl(3,2)*c1122+ + & skl(1,1)*skl(1,1)*skl(2,3)*skl(3,3)*c1122+ + & skl(1,1)*skl(1,2)*skl(2,1)*skl(3,2)*c1212+ + & skl(1,1)*skl(1,2)*skl(2,2)*skl(3,1)*c1212+ + & skl(1,1)*skl(1,3)*skl(2,1)*skl(3,3)*c1212+ + & skl(1,1)*skl(1,3)*skl(2,3)*skl(3,1)*c1212+ + & skl(1,2)*skl(1,1)*skl(2,1)*skl(3,2)*c1212+ + & skl(1,2)*skl(1,1)*skl(2,2)*skl(3,1)*c1212+ + & skl(1,2)*skl(1,2)*skl(2,1)*skl(3,1)*c1122+ + & skl(1,2)*skl(1,2)*skl(2,2)*skl(3,2)*c1111+ + & skl(1,2)*skl(1,2)*skl(2,3)*skl(3,3)*c1122+ + & skl(1,2)*skl(1,3)*skl(2,2)*skl(3,3)*c1212+ + & skl(1,2)*skl(1,3)*skl(2,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(1,1)*skl(2,1)*skl(3,3)*c1212+ + & skl(1,3)*skl(1,1)*skl(2,3)*skl(3,1)*c1212+ + & skl(1,3)*skl(1,2)*skl(2,2)*skl(3,3)*c1212+ + & skl(1,3)*skl(1,2)*skl(2,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(1,3)*skl(2,1)*skl(3,1)*c1122+ + & skl(1,3)*skl(1,3)*skl(2,2)*skl(3,2)*c1122+ + & skl(1,3)*skl(1,3)*skl(2,3)*skl(3,3)*c1111 + elas(17)= + & skl(2,1)*skl(2,1)*skl(2,1)*skl(3,1)*c1111+ + & skl(2,1)*skl(2,1)*skl(2,2)*skl(3,2)*c1122+ + & skl(2,1)*skl(2,1)*skl(2,3)*skl(3,3)*c1122+ + & skl(2,1)*skl(2,2)*skl(2,1)*skl(3,2)*c1212+ + & skl(2,1)*skl(2,2)*skl(2,2)*skl(3,1)*c1212+ + & skl(2,1)*skl(2,3)*skl(2,1)*skl(3,3)*c1212+ + & skl(2,1)*skl(2,3)*skl(2,3)*skl(3,1)*c1212+ + & skl(2,2)*skl(2,1)*skl(2,1)*skl(3,2)*c1212+ + & skl(2,2)*skl(2,1)*skl(2,2)*skl(3,1)*c1212+ + & skl(2,2)*skl(2,2)*skl(2,1)*skl(3,1)*c1122+ + & skl(2,2)*skl(2,2)*skl(2,2)*skl(3,2)*c1111+ + & skl(2,2)*skl(2,2)*skl(2,3)*skl(3,3)*c1122+ + & skl(2,2)*skl(2,3)*skl(2,2)*skl(3,3)*c1212+ + & skl(2,2)*skl(2,3)*skl(2,3)*skl(3,2)*c1212+ + & skl(2,3)*skl(2,1)*skl(2,1)*skl(3,3)*c1212+ + & skl(2,3)*skl(2,1)*skl(2,3)*skl(3,1)*c1212+ + & skl(2,3)*skl(2,2)*skl(2,2)*skl(3,3)*c1212+ + & skl(2,3)*skl(2,2)*skl(2,3)*skl(3,2)*c1212+ + & skl(2,3)*skl(2,3)*skl(2,1)*skl(3,1)*c1122+ + & skl(2,3)*skl(2,3)*skl(2,2)*skl(3,2)*c1122+ + & skl(2,3)*skl(2,3)*skl(2,3)*skl(3,3)*c1111 + elas(18)= + & skl(3,1)*skl(3,1)*skl(2,1)*skl(3,1)*c1111+ + & skl(3,1)*skl(3,1)*skl(2,2)*skl(3,2)*c1122+ + & skl(3,1)*skl(3,1)*skl(2,3)*skl(3,3)*c1122+ + & skl(3,1)*skl(3,2)*skl(2,1)*skl(3,2)*c1212+ + & skl(3,1)*skl(3,2)*skl(2,2)*skl(3,1)*c1212+ + & skl(3,1)*skl(3,3)*skl(2,1)*skl(3,3)*c1212+ + & skl(3,1)*skl(3,3)*skl(2,3)*skl(3,1)*c1212+ + & skl(3,2)*skl(3,1)*skl(2,1)*skl(3,2)*c1212+ + & skl(3,2)*skl(3,1)*skl(2,2)*skl(3,1)*c1212+ + & skl(3,2)*skl(3,2)*skl(2,1)*skl(3,1)*c1122+ + & skl(3,2)*skl(3,2)*skl(2,2)*skl(3,2)*c1111+ + & skl(3,2)*skl(3,2)*skl(2,3)*skl(3,3)*c1122+ + & skl(3,2)*skl(3,3)*skl(2,2)*skl(3,3)*c1212+ + & skl(3,2)*skl(3,3)*skl(2,3)*skl(3,2)*c1212+ + & skl(3,3)*skl(3,1)*skl(2,1)*skl(3,3)*c1212+ + & skl(3,3)*skl(3,1)*skl(2,3)*skl(3,1)*c1212+ + & skl(3,3)*skl(3,2)*skl(2,2)*skl(3,3)*c1212+ + & skl(3,3)*skl(3,2)*skl(2,3)*skl(3,2)*c1212+ + & skl(3,3)*skl(3,3)*skl(2,1)*skl(3,1)*c1122+ + & skl(3,3)*skl(3,3)*skl(2,2)*skl(3,2)*c1122+ + & skl(3,3)*skl(3,3)*skl(2,3)*skl(3,3)*c1111 + elas(19)= + & skl(1,1)*skl(2,1)*skl(2,1)*skl(3,1)*c1111+ + & skl(1,1)*skl(2,1)*skl(2,2)*skl(3,2)*c1122+ + & skl(1,1)*skl(2,1)*skl(2,3)*skl(3,3)*c1122+ + & skl(1,1)*skl(2,2)*skl(2,1)*skl(3,2)*c1212+ + & skl(1,1)*skl(2,2)*skl(2,2)*skl(3,1)*c1212+ + & skl(1,1)*skl(2,3)*skl(2,1)*skl(3,3)*c1212+ + & skl(1,1)*skl(2,3)*skl(2,3)*skl(3,1)*c1212+ + & skl(1,2)*skl(2,1)*skl(2,1)*skl(3,2)*c1212+ + & skl(1,2)*skl(2,1)*skl(2,2)*skl(3,1)*c1212+ + & skl(1,2)*skl(2,2)*skl(2,1)*skl(3,1)*c1122+ + & skl(1,2)*skl(2,2)*skl(2,2)*skl(3,2)*c1111+ + & skl(1,2)*skl(2,2)*skl(2,3)*skl(3,3)*c1122+ + & skl(1,2)*skl(2,3)*skl(2,2)*skl(3,3)*c1212+ + & skl(1,2)*skl(2,3)*skl(2,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(2,1)*skl(2,1)*skl(3,3)*c1212+ + & skl(1,3)*skl(2,1)*skl(2,3)*skl(3,1)*c1212+ + & skl(1,3)*skl(2,2)*skl(2,2)*skl(3,3)*c1212+ + & skl(1,3)*skl(2,2)*skl(2,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(2,3)*skl(2,1)*skl(3,1)*c1122+ + & skl(1,3)*skl(2,3)*skl(2,2)*skl(3,2)*c1122+ + & skl(1,3)*skl(2,3)*skl(2,3)*skl(3,3)*c1111 + elas(20)= + & skl(1,1)*skl(3,1)*skl(2,1)*skl(3,1)*c1111+ + & skl(1,1)*skl(3,1)*skl(2,2)*skl(3,2)*c1122+ + & skl(1,1)*skl(3,1)*skl(2,3)*skl(3,3)*c1122+ + & skl(1,1)*skl(3,2)*skl(2,1)*skl(3,2)*c1212+ + & skl(1,1)*skl(3,2)*skl(2,2)*skl(3,1)*c1212+ + & skl(1,1)*skl(3,3)*skl(2,1)*skl(3,3)*c1212+ + & skl(1,1)*skl(3,3)*skl(2,3)*skl(3,1)*c1212+ + & skl(1,2)*skl(3,1)*skl(2,1)*skl(3,2)*c1212+ + & skl(1,2)*skl(3,1)*skl(2,2)*skl(3,1)*c1212+ + & skl(1,2)*skl(3,2)*skl(2,1)*skl(3,1)*c1122+ + & skl(1,2)*skl(3,2)*skl(2,2)*skl(3,2)*c1111+ + & skl(1,2)*skl(3,2)*skl(2,3)*skl(3,3)*c1122+ + & skl(1,2)*skl(3,3)*skl(2,2)*skl(3,3)*c1212+ + & skl(1,2)*skl(3,3)*skl(2,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(3,1)*skl(2,1)*skl(3,3)*c1212+ + & skl(1,3)*skl(3,1)*skl(2,3)*skl(3,1)*c1212+ + & skl(1,3)*skl(3,2)*skl(2,2)*skl(3,3)*c1212+ + & skl(1,3)*skl(3,2)*skl(2,3)*skl(3,2)*c1212+ + & skl(1,3)*skl(3,3)*skl(2,1)*skl(3,1)*c1122+ + & skl(1,3)*skl(3,3)*skl(2,2)*skl(3,2)*c1122+ + & skl(1,3)*skl(3,3)*skl(2,3)*skl(3,3)*c1111 + elas(21)= + & skl(2,1)*skl(3,1)*skl(2,1)*skl(3,1)*c1111+ + & skl(2,1)*skl(3,1)*skl(2,2)*skl(3,2)*c1122+ + & skl(2,1)*skl(3,1)*skl(2,3)*skl(3,3)*c1122+ + & skl(2,1)*skl(3,2)*skl(2,1)*skl(3,2)*c1212+ + & skl(2,1)*skl(3,2)*skl(2,2)*skl(3,1)*c1212+ + & skl(2,1)*skl(3,3)*skl(2,1)*skl(3,3)*c1212+ + & skl(2,1)*skl(3,3)*skl(2,3)*skl(3,1)*c1212+ + & skl(2,2)*skl(3,1)*skl(2,1)*skl(3,2)*c1212+ + & skl(2,2)*skl(3,1)*skl(2,2)*skl(3,1)*c1212+ + & skl(2,2)*skl(3,2)*skl(2,1)*skl(3,1)*c1122+ + & skl(2,2)*skl(3,2)*skl(2,2)*skl(3,2)*c1111+ + & skl(2,2)*skl(3,2)*skl(2,3)*skl(3,3)*c1122+ + & skl(2,2)*skl(3,3)*skl(2,2)*skl(3,3)*c1212+ + & skl(2,2)*skl(3,3)*skl(2,3)*skl(3,2)*c1212+ + & skl(2,3)*skl(3,1)*skl(2,1)*skl(3,3)*c1212+ + & skl(2,3)*skl(3,1)*skl(2,3)*skl(3,1)*c1212+ + & skl(2,3)*skl(3,2)*skl(2,2)*skl(3,3)*c1212+ + & skl(2,3)*skl(3,2)*skl(2,3)*skl(3,2)*c1212+ + & skl(2,3)*skl(3,3)*skl(2,1)*skl(3,1)*c1122+ + & skl(2,3)*skl(3,3)*skl(2,2)*skl(3,2)*c1122+ + & skl(2,3)*skl(3,3)*skl(2,3)*skl(3,3)*c1111 + endif +! + do i=1,6 + ep0(i)=xstateini(i,iint,iel) + enddo + do i=1,18 + q1(i)=xstateini(6+i,iint,iel) + q2(i)=xstateini(24+i,iint,iel) + dg0(i)=xstateini(42+i,iint,iel) + enddo +! +! elastic strains +! + do i=1,6 + ee(i)=emec(i)-ep0(i) + enddo +! +! (visco)plastic constants: octahedral slip system +! + do i=1,12 + ck(i)=elconloc(4) + cn(i)=elconloc(5) + c(i)=elconloc(6) + d(i)=elconloc(7) + phi(i)=elconloc(8) + delta(i)=elconloc(9) + r0(i)=elconloc(10) + q(i)=elconloc(11) + b(i)=elconloc(12) + enddo +! +! (visco)plastic constants: cubic slip system +! + do i=13,18 + ck(i)=elconloc(13) + cn(i)=elconloc(14) + c(i)=elconloc(15) + d(i)=elconloc(16) + phi(i)=elconloc(17) + delta(i)=elconloc(18) + r0(i)=elconloc(19) + q(i)=elconloc(20) + b(i)=elconloc(21) + enddo +! +! stress state variables q1 and q2 +! + do i=1,18 + al10(i)=-q1(i)/(b(i)*q(i)) + al20(i)=-q2(i)/c(i) + enddo +! +! global trial stress tensor +! + if(iorien.gt.0) then + stri(1)=elas(1)*ee(1)+elas(2)*ee(2)+elas(4)*ee(3)+ + & 2.d0*(elas(7)*ee(4)+elas(11)*ee(5)+elas(16)*ee(6)) + & -beta(1) + stri(2)=elas(2)*ee(1)+elas(3)*ee(2)+elas(5)*ee(3)+ + & 2.d0*(elas(8)*ee(4)+elas(12)*ee(5)+elas(17)*ee(6)) + & -beta(2) + stri(3)=elas(4)*ee(1)+elas(5)*ee(2)+elas(6)*ee(3)+ + & 2.d0*(elas(9)*ee(4)+elas(13)*ee(5)+elas(18)*ee(6)) + & -beta(3) + stri(4)=elas(7)*ee(1)+elas(8)*ee(2)+elas(9)*ee(3)+ + & 2.d0*(elas(10)*ee(4)+elas(14)*ee(5)+elas(19)*ee(6)) + & -beta(4) + stri(5)=elas(11)*ee(1)+elas(12)*ee(2)+elas(13)*ee(3)+ + & 2.d0*(elas(14)*ee(4)+elas(15)*ee(5)+elas(20)*ee(6)) + & -beta(5) + stri(6)=elas(16)*ee(1)+elas(17)*ee(2)+elas(18)*ee(3)+ + & 2.d0*(elas(19)*ee(4)+elas(20)*ee(5)+elas(21)*ee(6)) + & -beta(6) + else + stri(1)=c1111*ee(1)+c1122*(ee(2)+ee(3))-beta(1) + stri(2)=c1111*ee(2)+c1122*(ee(1)+ee(3))-beta(2) + stri(3)=c1111*ee(3)+c1122*(ee(1)+ee(2))-beta(3) + stri(4)=2.d0*c1212*ee(4)-beta(4) + stri(5)=2.d0*c1212*ee(5)-beta(5) + stri(6)=2.d0*c1212*ee(6)-beta(6) + endif +! +! stress radius in each slip plane +! + do i=1,18 + sg(i)=xm(1,i)*stri(1)+xm(2,i)*stri(2)+xm(3,i)*stri(3)+ + & 2.d0*(xm(4,i)*stri(4)+xm(5,i)*stri(5)+xm(6,i)*stri(6))+q2(i) + enddo +! +! evaluation of the yield surface +! + do i=1,18 + htri(i)=dabs(sg(i))-r0(i) + do j=1,18 + htri(i)=htri(i)+h(i,j)*q1(j) + enddo + enddo +! +! check whether plasticity occurs +! + iplas=0 + do i=1,18 + if(htri(i).gt.0.d0) then + iplas=1 + go to 8 + endif + enddo + 8 continue +! + if((iplas.eq.0).or.(ielas.eq.1)) then +! +! elastic stress +! + do i=1,6 + stre(i)=stri(i) + enddo +! +! elastic stiffness +! + if(icmd.ne.3) then + if(iorien.gt.0) then + do i=1,21 + stiff(i)=elas(i) + enddo + else + stiff(1)=c1111 + stiff(2)=c1122 + stiff(3)=c1111 + stiff(4)=c1122 + stiff(5)=c1122 + stiff(6)=c1111 + stiff(7)=0.d0 + stiff(8)=0.d0 + stiff(9)=0.d0 + stiff(10)=c1212 + stiff(11)=0.d0 + stiff(12)=0.d0 + stiff(13)=0.d0 + stiff(14)=0.d0 + stiff(15)=c1212 + stiff(16)=0.d0 + stiff(17)=0.d0 + stiff(18)=0.d0 + stiff(19)=0.d0 + stiff(20)=0.d0 + stiff(21)=c1212 + endif + endif +! + return + endif +! +! plastic deformation +! + creep=.true. + nrhs=1 + lda=18 + ldb=18 +! +! determining the active slip planes +! + do i=1,18 + if(htri(i).gt.0.d0) then + active(i)=.true. + else + active(i)=.false. + endif + enddo +! +! initializing the state variables +! + do i=1,6 + ep(i)=ep0(i) + enddo + do i=1,18 + al1(i)=al10(i) + al2(i)=al20(i) +c dg0(i)=xstateini(42+i,iint,iel) +c dg(i)=xstate(42+i,iint,iel)-dg0(i) + dg(i)=0.d0 + enddo +! +! major loop +! + icounter=0 + do + icounter=icounter+1 + if(icounter.gt.100) then + write(*,*) '*ERROR in umat_single_crystal: no convergence' + stop + endif +! +! elastic strains +! + do i=1,6 + ee(i)=emec(i)-ep(i) + enddo +! +! stress state variables q1 and q2 +! + do i=1,18 + q1(i)=-b(i)*q(i)*al1(i) + q2(i)=-c(i)*al2(i) + enddo +! +! global trial stress tensor +! + if(iorien.gt.0) then + stri(1)=elas(1)*ee(1)+elas(2)*ee(2)+elas(4)*ee(3)+ + & 2.d0*(elas(7)*ee(4)+elas(11)*ee(5)+elas(16)*ee(6)) + & -beta(1) + stri(2)=elas(2)*ee(1)+elas(3)*ee(2)+elas(5)*ee(3)+ + & 2.d0*(elas(8)*ee(4)+elas(12)*ee(5)+elas(17)*ee(6)) + & -beta(2) + stri(3)=elas(4)*ee(1)+elas(5)*ee(2)+elas(6)*ee(3)+ + & 2.d0*(elas(9)*ee(4)+elas(13)*ee(5)+elas(18)*ee(6)) + & -beta(3) + stri(4)=elas(7)*ee(1)+elas(8)*ee(2)+elas(9)*ee(3)+ + & 2.d0*(elas(10)*ee(4)+elas(14)*ee(5)+elas(19)*ee(6)) + & -beta(4) + stri(5)=elas(11)*ee(1)+elas(12)*ee(2)+elas(13)*ee(3)+ + & 2.d0*(elas(14)*ee(4)+elas(15)*ee(5)+elas(20)*ee(6)) + & -beta(5) + stri(6)=elas(16)*ee(1)+elas(17)*ee(2)+elas(18)*ee(3)+ + & 2.d0*(elas(19)*ee(4)+elas(20)*ee(5)+elas(21)*ee(6)) + & -beta(6) + else + stri(1)=c1111*ee(1)+c1122*(ee(2)+ee(3))-beta(1) + stri(2)=c1111*ee(2)+c1122*(ee(1)+ee(3))-beta(2) + stri(3)=c1111*ee(3)+c1122*(ee(1)+ee(2))-beta(3) + stri(4)=2.d0*c1212*ee(4)-beta(4) + stri(5)=2.d0*c1212*ee(5)-beta(5) + stri(6)=2.d0*c1212*ee(6)-beta(6) + endif +! +! stress radius in each slip plane +! + do i=1,18 + sg(i)=xm(1,i)*stri(1)+xm(2,i)*stri(2)+xm(3,i)*stri(3)+ + & 2.d0*(xm(4,i)*stri(4)+xm(5,i)*stri(5)+xm(6,i)*stri(6)) + & +q2(i) + enddo +! +! evaluation of the yield surface +! + do i=1,18 + htri(i)=dabs(sg(i))-r0(i)-ck(i)*(dg(i)/dtime)**(1.d0/cn(i)) + do j=1,18 + htri(i)=htri(i)+h(i,j)*q1(j) + enddo + enddo +! +! replace sg(i) by sgn(sg(i)) +! + do i=1,18 + if(sg(i).lt.0.d0) then + sg(i)=-1.d0 + else + sg(i)=1.d0 + endif + enddo +! +! determining the effect of the accumulated plasticity +! + do i=1,18 + cphi(i)=phi(i)+(1.d0-phi(i))*exp(-delta(i)*(dg0(i)+dg(i))) + enddo +! +! minor loop +! + do +! +! determining the residual matrix +! + do i=1,6 + r(i)=ep0(i)-ep(i) + enddo + do i=1,18 + r(5+2*i)=al10(i)-al1(i) + r(6+2*i)=al20(i)-al2(i) + enddo + do i=1,18 + if(active(i)) then + do j=1,6 + r(j)=r(j)+xm(j,i)*sg(i)*dg(i) + enddo + r(5+2*i)=r(5+2*i)+(1.d0-b(i)*al1(i))*dg(i) + r(6+2*i)=r(6+2*i)+(cphi(i)*sg(i)-d(i)*al2(i))*dg(i) + endif + enddo +! +! check convergence +! + convergence=.true. + do i=1,18 + if(.not.active(i)) cycle + if(htri(i).gt.1.d-5) then + convergence=.false. + go to 9 + endif + enddo + 9 continue + if(convergence) then + dd=0.d0 + do i=1,6 + dd=dd+r(i)*r(i) + enddo + do i=1,18 + if(.not.active(i)) cycle + dd=dd+r(5+2*i)*r(5+2*i)+r(6+2*i)*r(6+2*i) + enddo + dd=sqrt(dd) + if(dd.gt.1.d-10) then + convergence=.false. + else + go to 12 + endif + endif +! +! compute xmc=c:xm +! + do i=1,18 + if(iorien.gt.0) then + xmc(1,i)=elas(1)*xm(1,i)+elas(2)*xm(2,i)+ + & elas(4)*xm(3,i)+2.d0*(elas(7)*xm(4,i)+ + & elas(11)*xm(5,i)+elas(16)*xm(6,i)) + xmc(2,i)=elas(2)*xm(1,i)+elas(3)*xm(2,i)+ + & elas(5)*xm(3,i)+2.d0*(elas(8)*xm(4,i)+ + & elas(12)*xm(5,i)+elas(17)*xm(6,i)) + xmc(3,i)=elas(4)*xm(1,i)+elas(5)*xm(2,i)+ + & elas(6)*xm(3,i)+2.d0*(elas(9)*xm(4,i)+ + & elas(13)*xm(5,i)+elas(18)*xm(6,i)) + xmc(4,i)=elas(7)*xm(1,i)+elas(8)*xm(2,i)+ + & elas(9)*xm(3,i)+2.d0*(elas(10)*xm(4,i)+ + & elas(14)*xm(5,i)+elas(19)*xm(6,i)) + xmc(5,i)=elas(11)*xm(1,i)+elas(12)*xm(2,i)+ + & elas(13)*xm(3,i)+2.d0*(elas(14)*xm(4,i)+ + & elas(15)*xm(5,i)+elas(20)*xm(6,i)) + xmc(6,i)=elas(16)*xm(1,i)+elas(17)*xm(2,i)+ + & elas(18)*xm(3,i)+2.d0*(elas(19)*xm(4,i)+ + & elas(20)*xm(5,i)+elas(21)*xm(6,i)) + else + xmc(1,i)=c1111*xm(1,i)+c1122*(xm(2,i)+xm(3,i)) + xmc(2,i)=c1111*xm(2,i)+c1122*(xm(1,i)+xm(3,i)) + xmc(3,i)=c1111*xm(3,i)+c1122*(xm(1,i)+xm(2,i)) + xmc(4,i)=2.d0*c1212*xm(4,i) + xmc(5,i)=2.d0*c1212*xm(5,i) + xmc(6,i)=2.d0*c1212*xm(6,i) + endif + enddo +! +! indexing the active slip planes +! + do i=1,18 + if(active(i)) then + index(i)=1.d0 + else + index(i)=0.d0 + endif + enddo + neq=0 + do i=1,18 + if(index(i).eq.1) then + neq=neq+1 + index(i)=neq + endif + enddo +! +! filling the LHS +! + do 1 i=1,18 + if(.not.active(i)) go to 1 + aux(i)=(q(i)+q1(i))/(1.d0/b(i)+dg(i)) + 1 continue +! + do 2 i=1,18 + if(.not.active(i)) go to 2 + do 3 j=1,18 + if(.not.active(j)) go to 3 + if(i.ne.j) then + gl(index(i),index(j))=(xm(1,i)*xmc(1,j)+ + & xm(2,i)*xmc(2,j)+xm(3,i)*xmc(3,j)+2.d0* + & (xm(4,i)*xmc(4,j)+xm(5,i)*xmc(5,j)+ + & xm(6,i)*xmc(6,j))) + & *sg(i)*sg(j)+h(i,j)*aux(j) + else + gl(index(i),index(j))=(xm(1,i)*xmc(1,j)+ + & xm(2,i)*xmc(2,j)+xm(3,i)*xmc(3,j)+2.d0* + & (xm(4,i)*xmc(4,j)+xm(5,i)*xmc(5,j)+ + & xm(6,i)*xmc(6,j))) + & +h(i,j)*aux(j)+(cphi(j)*c(j)+d(j)*q2(j)*sg(j)) + & /(1.d0+dg(j)*d(j)) + endif + 3 continue + if(creep)then + if(dg(i).gt.0.d0) then + gl(index(i),index(i))=gl(index(i),index(i))+ + & (dg(i)/dtime)**(1.d0/cn(i)-1.d0)*ck(i)/ + & (cn(i)*dtime) + else +! +! for gamma ein default of 1.d-10 is taken to +! obtain a finite gradient +! + gl(index(i),index(i))=gl(index(i),index(i))+ + & (1.d-10/dtime)**(1.d0/cn(i)-1.d0)*ck(i)/ + & (cn(i)*dtime) + endif + endif + 2 continue +! +! filling the RHS +! + do 4 i=1,18 + if(.not.active(i)) go to 4 + do j=1,6 + t(j)=xmc(j,i)*sg(i) + enddo + do j=1,18 + t(5+2*j)=h(i,j)*q(j)/(1.d0/b(j)+dg(j)) + t(6+2*j)=0.d0 + enddo + t(6+2*i)=c(i)*sg(i)/(1.d0+dg(i)*d(i)) + if(creep) then + gr(index(i),1)=htri(i) + else + gr(index(i),1)=htri(i) + & +ck(i)*(dg(i)/dtime)**(1.d0/cn(i)) + endif + do j=1,42 + gr(index(i),1)=gr(index(i),1)-t(j)*r(j) + enddo + gr(index(i),1)=gr(index(i),1) + & -t(4)*r(4)-t(5)*r(5)-t(6)*r(6) + 4 continue +! +! solve gl*ddg=gr +! + call dgesv(neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! + do i=1,18 + if(active(i)) then + ddg(i)=gr(index(i),1) + else + ddg(i)=0.d0 + endif + enddo +! +! check whether active slip planes have changed +! + ichange=0 + do 5 i=1,18 + if(.not.active(i)) go to 5 + if(dg(i)+ddg(i).lt.0.d0) then + active(i)=.false. + dg(i)=0.d0 + al1(i)=al10(i) + al2(i)=al20(i) + ichange=1 + endif + 5 continue + if(ichange.eq.0) then + go to 13 + endif +! +! end of minor loop +! + enddo + 13 continue +! +! updating the residual matrix +! + do i=1,18 + if(active(i)) then + do j=1,6 + r(j)=r(j)+xm(j,i)*sg(i)*ddg(i) + enddo + r(5+2*i)=r(5+2*i)+(1.d0-b(i)*al1(i))*ddg(i) + r(6+2*i)=r(6+2*i)+(cphi(i)*sg(i)-d(i)*al2(i))*ddg(i) + endif + enddo +! +! update the state variables +! + do i=1,6 + ep(i)=ep(i)+r(i) + enddo + do i=1,18 + if(active(i)) then + al1(i)=al1(i)+r(5+2*i)/(1.d0+b(i)*dg(i)) + al2(i)=al2(i)+r(6+2*i)/(1.d0+d(i)*dg(i)) + endif + enddo + do i=1,18 + if(active(i)) then + dg(i)=dg(i)+ddg(i) + endif + enddo +! +! end of major loop +! + enddo + 12 continue +! +! inversion of G +! + do i=1,neq + do j=1,neq + gr(i,j)=0.d0 + enddo + gr(i,i)=1.d0 + enddo + nrhs=neq + call dgetrs('No transpose',neq,nrhs,gl,lda,ipiv,gr,ldb,info) + if(info.ne.0) then + write(*,*) '*ERROR in sc.f: linear equation solver' + write(*,*) ' exited with error: info = ',info + stop + endif +! +! storing the stress +! + do i=1,6 + stre(i)=stri(i) + enddo +! +! calculating the tangent stiffness matrix +! + if(icmd.ne.3) then + if(iorien.gt.0) then + ddsdde(1,1)=elas(1) + ddsdde(1,2)=elas(2) + ddsdde(1,3)=elas(4) + ddsdde(1,4)=elas(7) + ddsdde(1,5)=elas(11) + ddsdde(1,6)=elas(16) + ddsdde(2,1)=elas(2) + ddsdde(2,2)=elas(3) + ddsdde(2,3)=elas(5) + ddsdde(2,4)=elas(8) + ddsdde(2,5)=elas(12) + ddsdde(2,6)=elas(17) + ddsdde(3,1)=elas(4) + ddsdde(3,2)=elas(5) + ddsdde(3,3)=elas(6) + ddsdde(3,4)=elas(9) + ddsdde(3,5)=elas(13) + ddsdde(3,6)=elas(18) + ddsdde(4,1)=elas(7) + ddsdde(4,2)=elas(8) + ddsdde(4,3)=elas(9) + ddsdde(4,4)=elas(10) + ddsdde(4,5)=elas(14) + ddsdde(4,6)=elas(19) + ddsdde(5,1)=elas(11) + ddsdde(5,2)=elas(12) + ddsdde(5,3)=elas(13) + ddsdde(5,4)=elas(14) + ddsdde(5,5)=elas(15) + ddsdde(5,6)=elas(20) + ddsdde(6,1)=elas(16) + ddsdde(6,2)=elas(17) + ddsdde(6,3)=elas(18) + ddsdde(6,4)=elas(19) + ddsdde(6,5)=elas(20) + ddsdde(6,6)=elas(21) + else + do i=1,6 + do j=1,6 + ddsdde(i,j)=0.d0 + enddo + enddo + do i=1,3 + ddsdde(i,i)=c1111 + enddo + do i=1,3 + do j=i+1,3 + ddsdde(i,j)=c1122 + enddo + do j=1,i-1 + ddsdde(i,j)=c1122 + enddo + ddsdde(i+3,i+3)=c1212 + enddo + endif + do 6 i=1,18 + if(.not.active(i)) go to 6 + do 7 j=1,18 + if(.not.active(j)) go to 7 + do k=1,6 + do l=1,6 + ddsdde(k,l)=ddsdde(k,l)- + & gr(index(i),index(j))*xmc(k,i)*sg(i)*xmc(l,j)*sg(j) + enddo + enddo + 7 continue + 6 continue +! +! symmatrizing the stiffness matrix +! + stiff(1)=ddsdde(1,1) + stiff(2)=(ddsdde(1,2)+ddsdde(2,1))/2.d0 + stiff(3)=ddsdde(2,2) + stiff(4)=(ddsdde(1,3)+ddsdde(3,1))/2.d0 + stiff(5)=(ddsdde(2,3)+ddsdde(3,2))/2.d0 + stiff(6)=ddsdde(3,3) + stiff(7)=(ddsdde(1,4)+ddsdde(4,1))/2.d0 + stiff(8)=(ddsdde(2,4)+ddsdde(4,2))/2.d0 + stiff(9)=(ddsdde(3,4)+ddsdde(4,3))/2.d0 + stiff(10)=ddsdde(4,4) + stiff(11)=(ddsdde(1,5)+ddsdde(5,1))/2.d0 + stiff(12)=(ddsdde(2,5)+ddsdde(5,2))/2.d0 + stiff(13)=(ddsdde(3,5)+ddsdde(5,3))/2.d0 + stiff(14)=(ddsdde(4,5)+ddsdde(5,4))/2.d0 + stiff(15)=ddsdde(5,5) + stiff(16)=(ddsdde(1,6)+ddsdde(6,1))/2.d0 + stiff(17)=(ddsdde(2,6)+ddsdde(6,2))/2.d0 + stiff(18)=(ddsdde(3,6)+ddsdde(6,3))/2.d0 + stiff(19)=(ddsdde(4,6)+ddsdde(6,4))/2.d0 + stiff(20)=(ddsdde(5,6)+ddsdde(6,5))/2.d0 + stiff(21)=ddsdde(6,6) +! + endif +! +! updating the state variables +! + do i=1,6 + xstate(i,iint,iel)=ep(i) + enddo + do i=1,18 + xstate(6+i,iint,iel)=q1(i) + xstate(24+i,iint,iel)=q2(i) + xstate(42+i,iint,iel)=dg0(i)+dg(i) + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umat_user.f calculix-ccx-2.3/ccx_2.3/src/umat_user.f --- calculix-ccx-2.1/ccx_2.3/src/umat_user.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umat_user.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,151 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umat_user(amat,iel,iint,kode,elconloc,emec,emec0, + & beta,xokl,voj,xkl,vj,ithermal,t1l,dtime,time,ttime, + & icmd,ielas,mi,nstate_,xstateini,xstate,stre,stiff, + & iorien,pgauss,orab,pnewdt,ipkon) +! +! calculates stiffness and stresses for a user defined material +! law +! +! icmd=3: calcutates stress at mechanical strain +! else: calculates stress at mechanical strain and the stiffness +! matrix +! +! INPUT: +! +! amat material name +! iel element number +! iint integration point number +! +! kode material type (-100-#of constants entered +! under *USER MATERIAL): can be used for materials +! with varying number of constants +! +! elconloc(21) user defined constants defined by the keyword +! card *USER MATERIAL (max. 21, actual # = +! -kode-100), interpolated for the +! actual temperature t1l +! +! emec(6) Lagrange mechanical strain tensor (component order: +! 11,22,33,12,13,23) at the end of the increment +! (thermal strains are subtracted) +! emec0(6) Lagrange mechanical strain tensor at the start of the +! increment (thermal strains are subtracted) +! beta(6) residual stress tensor (the stress entered under +! the keyword *INITIAL CONDITIONS,TYPE=STRESS) +! +! xokl(3,3) deformation gradient at the start of the increment +! voj Jacobian at the start of the increment +! xkl(3,3) deformation gradient at the end of the increment +! vj Jacobian at the end of the increment +! +! ithermal 0: no thermal effects are taken into account +! 1: thermal effects are taken into account (triggered +! by the keyword *INITIAL CONDITIONS,TYPE=TEMPERATURE) +! t1l temperature at the end of the increment +! dtime time length of the increment +! time step time at the end of the current increment +! ttime total time at the start of the current increment +! +! icmd not equal to 3: calculate stress and stiffness +! 3: calculate only stress +! ielas 0: no elastic iteration: irreversible effects +! are allowed +! 1: elastic iteration, i.e. no irreversible +! deformation allowed +! +! mi(1) max. # of integration points per element in the +! model +! nstate_ max. # of state variables in the model +! +! xstateini(nstate_,mi(1),# of elements) +! state variables at the start of the increment +! xstate(nstate_,mi(1),# of elements) +! state variables at the end of the increment +! +! stre(6) Piola-Kirchhoff stress of the second kind +! at the start of the increment +! +! iorien number of the local coordinate axis system +! in the integration point at stake (takes the value +! 0 if no local system applies) +! pgauss(3) global coordinates of the integration point +! orab(7,*) description of all local coordinate systems. +! If a local coordinate system applies the global +! tensors can be obtained by premultiplying the local +! tensors with skl(3,3). skl is determined by calling +! the subroutine transformatrix: +! call transformatrix(orab(1,iorien),pgauss,skl) +! +! +! OUTPUT: +! +! xstate(nstate_,mi(1),# of elements) +! updated state variables at the end of the increment +! stre(6) Piola-Kirchhoff stress of the second kind at the +! end of the increment +! stiff(21): consistent tangent stiffness matrix in the material +! frame of reference at the end of the increment. In +! other words: the derivative of the PK2 stress with +! respect to the Lagrangian strain tensor. The matrix +! is supposed to be symmetric, only the upper half is +! to be given in the same order as for a fully +! anisotropic elastic material (*ELASTIC,TYPE=ANISO). +! Notice that the matrix is an integral part of the +! fourth order material tensor, i.e. the Voigt notation +! is not used. +! pnewdt to be specified by the user if the material +! routine is unable to return the stiffness matrix +! and/or the stress due to divergence within the +! routine. pnewdt is the factor by which the time +! increment is to be multiplied in the next +! trial and should exceed zero but be less than 1. +! Default is -1 indicating that the user routine +! has converged. +! ipkon(*) ipkon(iel) points towards the position in field +! kon prior to the first node of the element's +! topology. If ipkon(iel) is set to -1, the +! element is removed from the mesh +! + implicit none +! + character*80 amat +! + integer ithermal,icmd,kode,ielas,iel,iint,nstate_,mi(2),iorien, + & ipkon(*) +! + real*8 elconloc(21),stiff(21),emec(6),emec0(6),beta(6),stre(6), + & vj,t1l,dtime,xkl(3,3),xokl(3,3),voj,pgauss(3),orab(7,*), + & time,ttime,pnewdt +! + real*8 xstate(nstate_,mi(1),*),xstateini(nstate_,mi(1),*) +! +! insert here code to calculate the stresses +! + if(icmd.ne.3) then +! +! insert here code to calculate the stiffness matrix +! + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/umpc_dist.f calculix-ccx-2.3/ccx_2.3/src/umpc_dist.f --- calculix-ccx-2.1/ccx_2.3/src/umpc_dist.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umpc_dist.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,221 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umpc_dist(x,u,f,a,jdof,n,force,iit,idiscon) +! +! updates the coefficients in a dist mpc (name DIST) +! +! a dist mpc specifies that the distance between two nodes +! a and b must not exceed value d +! +! input nodes: a,a,a,b,b,b,c +! +! node c is a fictitious node. The value d must be assigned +! to the first coordinate of node c by means of a *NODE card; +! the other coordinates of the node can be arbitrary. +! +! A value of zero must be assigned to the first DOF of node c by using +! a *BOUNDARY card. The second DOF of node c is not constrained and is +! used when the distance between nodes a and b is less than d: in +! that case there is no constraint at all. +! +! INPUT: +! +! x(3,n) Carthesian coordinates of the nodes in the +! user mpc. +! u(3,n) Actual displacements of the nodes in the +! user mpc. +! jdof Actual degrees of freedom of the mpc terms +! n number of terms in the user mpc +! force Actual value of the mpc force +! iit iteration number +! +! OUTPUT: +! +! f Actual value of the mpc. If the mpc is +! exactly satisfied, this value is zero +! a(n) coefficients of the linearized mpc +! jdof Corrected degrees of freedom of the mpc terms +! idiscon 0: no discontinuity +! 1: discontinuity +! If a discontinuity arises the previous +! results are not extrapolated at the start of +! a new increment +! + implicit none +! + integer jdof(*),n,iit,ifix,idiscon +! + real*8 x(3,*),u(3,*),f,a(*),dist(3),force +! +c write(*,*) (jdof(i),i=1,7) + if(jdof(7).eq.1) then + ifix=1 + else + ifix=0 + jdof(7)=2 + endif +! + dist(1)=x(1,1)+u(1,1)-x(1,4)-u(1,4) + dist(2)=x(2,1)+u(2,1)-x(2,4)-u(2,4) + dist(3)=x(3,1)+u(3,1)-x(3,4)-u(3,4) +! + f=dist(1)**2+dist(2)**2+dist(3)**2-x(1,7)**2 +! +c write(*,*) 'mpcforc=, f= ',force,f +! + a(7)=-1. +! +! only one change per increment is allowed +! (change= from free to linked or vice versa) +! ifix=0: free +! ifix=1: linked +! + if(ifix.eq.0) then +! +! previous state: free +! + if(f.lt.0) then +! +! new state: free +! + f=0.d0 + elseif(iit.le.1) then +! +! new state: linked +! + write(*,*) 'switch to linked' + write(*,*) + jdof(7)=1 + idiscon=1 + else +! +! new state: free +! + f=0.d0 + endif + else +! +! previous state: linked +! + if(force.le.0.d0) then +! +! new state: linked +! + elseif(iit.le.1) then +! +! new state: free +! + write(*,*) 'switch to free' + write(*,*) + jdof(7)=2 + f=0.d0 + idiscon=1 + else +! +! new state: linked +! + endif + endif +! + if(dabs(dist(jdof(1))).gt.1.d-10) then + a(1)=2.d0*dist(jdof(1)) + if(jdof(1).eq.1) then + jdof(2)=2 + jdof(3)=3 + elseif(jdof(1).eq.2) then + jdof(2)=3 + jdof(3)=1 + else + jdof(2)=1 + jdof(3)=2 + endif + a(2)=2.d0*dist(jdof(2)) + a(3)=2.d0*dist(jdof(3)) + else + if(jdof(1).eq.3) then + jdof(1)=1 + else + jdof(1)=jdof(1)+1 + endif + if(dabs(dist(jdof(1))).gt.1.d-10) then + a(1)=2.d0*dist(jdof(1)) + if(jdof(1).eq.1) then + jdof(2)=2 + jdof(3)=3 + elseif(jdof(1).eq.2) then + jdof(2)=3 + jdof(3)=1 + else + jdof(2)=1 + jdof(3)=2 + endif + a(2)=2.d0*dist(jdof(2)) + a(3)=2.d0*dist(jdof(3)) + else + if(jdof(1).eq.3) then + jdof(1)=1 + else + jdof(1)=jdof(1)+1 + endif + if(dabs(dist(jdof(1))).gt.1.d-10) then + a(1)=2.d0*dist(jdof(1)) + if(jdof(1).eq.1) then + jdof(2)=2 + jdof(3)=3 + elseif(jdof(1).eq.2) then + jdof(2)=3 + jdof(3)=1 + else + jdof(2)=1 + jdof(3)=2 + endif + a(2)=2.d0*dist(jdof(2)) + a(3)=2.d0*dist(jdof(3)) + endif + endif + endif +! + a(4)=-2.d0*dist(1) + a(5)=-2.d0*dist(2) + a(6)=-2.d0*dist(3) + jdof(4)=1 + jdof(5)=2 + jdof(6)=3 +! +c write(*,*) 'jdof,a' +c do i=1,7 +c write(*,*) jdof(i),a(i) +c enddo +c write(*,*) 'f ',f +! + return + end + + + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/umpc_gap.f calculix-ccx-2.3/ccx_2.3/src/umpc_gap.f --- calculix-ccx-2.1/ccx_2.3/src/umpc_gap.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umpc_gap.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,219 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umpc_gap(x,u,f,a,jdof,n,force,iit,idiscon) +! +! updates the coefficients in a gap mpc (name GAP) +! +! a gap MPC is triggered by a *GAP definition applied to +! a GAPUNI element. The gap direction is stored in +! x(1..3,7), the clearance in x(1,8), which is also the +! constant term +! +! INPUT: +! +! x(3,n) Carthesian coordinates of the nodes in the +! user mpc. +! u(3,n) Actual displacements of the nodes in the +! user mpc. +! jdof Actual degrees of freedom of the mpc terms +! n number of terms in the user mpc +! force Actual value of the mpc force +! iit iteration number +! +! OUTPUT: +! +! f Actual value of the mpc. If the mpc is +! exactly satisfied, this value is zero +! a(n) coefficients of the linearized mpc +! jdof Corrected degrees of freedom of the mpc terms +! idiscon 0: no discontinuity +! 1: discontinuity +! If a discontinuity arises the previous +! results are not extrapolated at the start of +! a new increment +! + implicit none +! + integer jdof(*),n,iit,ifix,idiscon +! + real*8 x(3,*),u(3,*),f,a(*),dist(3),xn(3),force +! +c write(*,*) (jdof(i),i=1,7) + if(jdof(7).eq.1) then + ifix=1 + else + ifix=0 + jdof(7)=2 + endif +! + dist(1)=u(1,4)-u(1,1) + dist(2)=u(2,4)-u(2,1) + dist(3)=u(3,4)-u(3,1) +! +! gap direction +! + xn(1)=x(1,7) + xn(2)=x(2,7) + xn(3)=x(3,7) +! + f=dist(1)*xn(1)+dist(2)*xn(2)+dist(3)*xn(3)+x(1,8) +! +c write(*,*) 'dist,xn',dist(1),dist(2),dist(3),xn(1),xn(2),xn(3) +c write(*,*) 'mpcforc=, f= ',force,f +! + a(7)=-1. +! +! only one change per increment is allowed +! (change= from free to linked or vice versa) +! ifix=0: free +! ifix=1: linked +! + if(ifix.eq.0) then +! +! previous state: free +! + if(f.gt.0) then +! +! new state: free +! + f=0.d0 + elseif(iit.le.1) then +! +! new state: linked +! + write(*,*) 'switch to linked' + write(*,*) + jdof(7)=1 + idiscon=1 + else +! +! new state: free +! + f=0.d0 + endif + else +! +! previous state: linked +! + if(force.ge.0.d0) then +! +! new state: linked +! + elseif(iit.le.1) then +! +! new state: free +! + write(*,*) 'switch to free' + write(*,*) + jdof(7)=2 + f=0.d0 + idiscon=1 + else +! +! new state: linked +! + endif + endif +! + if(dabs(xn(jdof(1))).gt.1.d-10) then + a(1)=-xn(jdof(1)) + if(jdof(1).eq.1) then + jdof(2)=2 + jdof(3)=3 + elseif(jdof(1).eq.2) then + jdof(2)=3 + jdof(3)=1 + else + jdof(2)=1 + jdof(3)=2 + endif + a(2)=-xn(jdof(2)) + a(3)=-xn(jdof(3)) + else + if(jdof(1).eq.3) then + jdof(1)=1 + else + jdof(1)=jdof(1)+1 + endif + if(dabs(xn(jdof(1))).gt.1.d-10) then + a(1)=-xn(jdof(1)) + if(jdof(1).eq.1) then + jdof(2)=2 + jdof(3)=3 + elseif(jdof(1).eq.2) then + jdof(2)=3 + jdof(3)=1 + else + jdof(2)=1 + jdof(3)=2 + endif + a(2)=-xn(jdof(2)) + a(3)=-xn(jdof(3)) + else + if(jdof(1).eq.3) then + jdof(1)=1 + else + jdof(1)=jdof(1)+1 + endif + if(dabs(xn(jdof(1))).gt.1.d-10) then + a(1)=-xn(jdof(1)) + if(jdof(1).eq.1) then + jdof(2)=2 + jdof(3)=3 + elseif(jdof(1).eq.2) then + jdof(2)=3 + jdof(3)=1 + else + jdof(2)=1 + jdof(3)=2 + endif + a(2)=-xn(jdof(2)) + a(3)=-xn(jdof(3)) + endif + endif + endif +! + a(4)=xn(1) + a(5)=xn(2) + a(6)=xn(3) + jdof(4)=1 + jdof(5)=2 + jdof(6)=3 +! +c write(*,*) 'jdof,a' +c do i=1,7 +c write(*,*) jdof(i),a(i) +c enddo +c write(*,*) 'f ',f +! + return + end + + + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/umpc_mean_rot.f calculix-ccx-2.3/ccx_2.3/src/umpc_mean_rot.f --- calculix-ccx-2.1/ccx_2.3/src/umpc_mean_rot.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umpc_mean_rot.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,199 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umpc_mean_rot(x,u,f,a,jdof,n,force,iit,idiscon) +! +! updates the coefficients in a mean rotation mpc +! +! INPUT: +! +! x(3,n) Carthesian coordinates of the nodes in the +! user mpc. +! u(3,n) Actual displacements of the nodes in the +! user mpc. +! jdof Actual degrees of freedom of the mpc terms +! n number of terms in the user mpc +! force Actual value of the mpc force +! iit iteration number +! +! OUTPUT: +! +! f Actual value of the mpc. If the mpc is +! exactly satisfied, this value is zero +! a(n) coefficients of the linearized mpc +! jdof Corrected degrees of freedom of the mpc terms +! idiscon 0: no discontinuity +! 1: discontinuity +! If a discontinuity arises the previous +! results are not extrapolated at the start of +! a new increment +! + implicit none +! + integer jdof(*),n,nkn,i,j,k,imax,iit,idiscon +! + real*8 x(3,*),u(3,*),f,a(*),aa(3),cgx(3),cgu(3),pi(3), + & xi(3),dd,al,a1,amax,c1,c2,c3,c4,c9,c10,force +! + nkn=(n-1)/3 + if(3*nkn.ne.n-1) then + write(*,*) + & '*ERROR in meanrotmpc: MPC has wrong number of terms' + stop + endif +! +! normal along the rotation axis +! + dd=0.d0 + do i=1,3 + aa(i)=x(i,n) + dd=dd+aa(i)**2 + enddo + dd=dsqrt(dd) + if(dd.lt.1.d-10) then + write(*,*) + & '*ERROR in meanrotmpc: rotation vector has zero length' + stop + endif + do i=1,3 + aa(i)=aa(i)/dd + enddo +! +! finding the center of gravity of the position and the +! displacements of the nodes involved in the MPC +! + do i=1,3 + cgx(i)=0.d0 + cgu(i)=0.d0 + enddo +! + do i=1,nkn +c write(*,*) 'x,u' +c write(*,101) (x(j,3*i-2),j=1,3),(u(j,3*i-2),j=1,3) +c 101 format(6(1x,e11.4)) + do j=1,3 + cgx(j)=cgx(j)+x(j,3*i-2) + cgu(j)=cgu(j)+u(j,3*i-2) + enddo + enddo +! + do i=1,3 + cgx(i)=cgx(i)/nkn + cgu(i)=cgu(i)/nkn + enddo +c write(*,*) 'cgx ',(cgx(i),i=1,3) +c write(*,*) 'cgu ',(cgu(i),i=1,3) +! +! initializing a +! + do i=1,n + a(i)=0.d0 + enddo +! +! calculating the partial derivatives and storing them in a +! + f=0.d0 + do i=1,nkn +! +! relative positions +! + do j=1,3 + pi(j)=x(j,3*i-2)-cgx(j) + xi(j)=u(j,3*i-2)-cgu(j)+pi(j) + enddo +! + c1=pi(1)*pi(1)+pi(2)*pi(2)+pi(3)*pi(3) + if(c1.lt.1.d-20) then + write(*,*) '*WARNING in meanrotmpc: node on rotation axis' + cycle + endif + c3=xi(1)*xi(1)+xi(2)*xi(2)+xi(3)*xi(3) + c2=dsqrt(c1*c3) +! + al=(aa(1)*pi(2)*xi(3)+aa(2)*pi(3)*xi(1)+aa(3)*pi(1)*xi(2) + & -aa(3)*pi(2)*xi(1)-aa(1)*pi(3)*xi(2)-aa(2)*pi(1)*xi(3)) + & /c2 +! + f=f+dasin(al) +c write(*,*) 'f ',dasin(al) +! + do j=1,3 + if(j.eq.1) then + c4=aa(2)*pi(3)-aa(3)*pi(2) + elseif(j.eq.2) then + c4=aa(3)*pi(1)-aa(1)*pi(3) + else + c4=aa(1)*pi(2)-aa(2)*pi(1) + endif + c9=(c4/c2-al*xi(j)/c3)/dsqrt(1.d0-al*al) +! + do k=1,nkn + if(i.eq.k) then + c10=c9*(1.d0-1.d0/real(nkn)) + else + c10=-c9/real(nkn) + endif + a(k*3-3+j)=a(k*3-3+j)+c10 + enddo + enddo + enddo + a(n)=-nkn + f=f-nkn*u(1,n) +! +! assigning the degrees of freedom +! + do i=1,nkn + jdof(i*3-2)=1 + jdof(i*3-1)=2 + jdof(i*3)=3 + enddo + jdof(n)=1 +! +! looking for the maximum tangent to decide which DOF should be +! taken to be the dependent one +! + if(dabs(a(1)).lt.1.d-5) then + amax=0.d0 + do i=1,3 + if(dabs(a(i)).gt.amax) then + amax=abs(a(i)) + imax=i + endif + enddo +c write(*,*) 'a(1),a(2),a(3) ',a(1),a(2),a(3) +c write(*,*) 'jdof ',jdof(1),jdof(2),jdof(3) +! + jdof(1)=imax + a1=a(1) + a(1)=a(imax) + do i=2,3 + if(i.eq.imax) then + jdof(i)=1 + a(i)=a1 + write(*,*) '*INFO: DOF in umpc_mean_rot changed' +c stop + else + jdof(i)=i + endif + enddo + endif +c write(*,*) 'a(1),a(2),a(3) ',a(1),a(2),a(3) +c write(*,*) 'jdof ',jdof(1),jdof(2),jdof(3) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/umpc_user.f calculix-ccx-2.3/ccx_2.3/src/umpc_user.f --- calculix-ccx-2.1/ccx_2.3/src/umpc_user.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/umpc_user.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,67 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine umpc_user(x,u,f,a,jdof,n,force,iit,idiscon) +! +! updates the coefficients in a user mpc +! +! INPUT: +! +! x(3,n) Carthesian coordinates of the nodes in the +! user mpc. +! u(3,n) Actual displacements of the nodes in the +! user mpc. +! jdof Actual degrees of freedom of the mpc terms +! n number of terms in the user mpc +! force Actual value of the mpc force +! iit iteration number +! +! OUTPUT: +! +! f Actual value of the mpc. If the mpc is +! exactly satisfied, this value is zero +! a(n) coefficients of the linearized mpc +! jdof Corrected degrees of freedom of the mpc terms +! idiscon 0: no discontinuity +! 1: discontinuity +! If a discontinuity arises the previous +! results are not extrapolated at the start of +! a new increment +! + implicit none +! + integer jdof(*),n,iit,idiscon +! + real*8 x(3,*),u(3,*),f,a(*),force +! +! + return + end + + + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/uncouptempdisps.f calculix-ccx-2.3/ccx_2.3/src/uncouptempdisps.f --- calculix-ccx-2.1/ccx_2.3/src/uncouptempdisps.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/uncouptempdisps.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,197 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine uncouptempdisps(inpc,textpart,nmethod,iperturb,isolver, + & istep,istat,n,tinc,tper,tmin,tmax,idrct,ithermal,iline,ipol, + & inl,ipoinp,inp,ipoinpc,alpha,ctrl) +! +! reading the input deck: *COUPLED TEMPERATURE-DISPLACEMENT +! +! isolver=0: SPOOLES +! 2: iterative solver with diagonal scaling +! 3: iterative solver with Cholesky preconditioning +! 4: sgi solver +! 5: TAUCS +! 7: pardiso +! + implicit none +! + character*1 inpc(*) + character*20 solver + character*132 textpart(16) +! + integer nmethod,iperturb,isolver,istep,istat,n,key,i,idrct, + & ithermal,iline,ipol,inl,ipoinp(2,*),inp(3,*),ipoinpc(0:*) +! + real*8 tinc,tper,tmin,tmax,alpha,ctrl(*) +! + idrct=0 + alpha=-0.05d0 + tmin=0.d0 + tmax=0.d0 + nmethod=4 +! + if(iperturb.eq.0) then + iperturb=2 + elseif((iperturb.eq.1).and.(istep.gt.1)) then + write(*,*) '*ERROR in couptempdisps: perturbation analysis is' + write(*,*) ' not provided in a *HEAT TRANSFER step.' + stop + endif +! + if(istep.lt.1) then + write(*,*) '*ERROR in couptempdisps: *HEAT TRANSFER can only ' + write(*,*) ' be used within a STEP' + stop + endif +! +! default solver +! + solver=' ' + if(isolver.eq.0) then + solver(1:7)='SPOOLES' + elseif(isolver.eq.2) then + solver(1:16)='ITERATIVESCALING' + elseif(isolver.eq.3) then + solver(1:17)='ITERATIVECHOLESKY' + elseif(isolver.eq.4) then + solver(1:3)='SGI' + elseif(isolver.eq.5) then + solver(1:5)='TAUCS' + elseif(isolver.eq.7) then + solver(1:7)='PARDISO' + endif +! + do i=2,n + if(textpart(i)(1:6).eq.'ALPHA=') then + read(textpart(i)(7:26),'(f20.0)',iostat=istat) alpha + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + if(alpha.lt.-1.d0/3.d0) then + write(*,*) '*WARNING in dynamics: alpha is smaller' + write(*,*) ' than -1/3 and is reset to -1/3' + alpha=-1.d0/3.d0 + elseif(alpha.gt.0.d0) then + write(*,*) '*WARNING in dynamics: alpha is greater' + write(*,*) ' than 0 and is reset to 0' + alpha=0.d0 + endif + elseif(textpart(i)(1:7).eq.'SOLVER=') then + read(textpart(i)(8:27),'(a20)') solver + elseif((textpart(i)(1:6).eq.'DIRECT').and. + & (textpart(i)(1:9).ne.'DIRECT=NO')) then + idrct=1 + elseif(textpart(i)(1:11).eq.'STEADYSTATE') then + nmethod=1 + elseif(textpart(i)(1:7).eq.'DELTMX=') then + read(textpart(i)(8:27),'(f20.0)',iostat=istat) ctrl(27) + else + write(*,*) + & '*WARNING in uncouptempdisps: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo + if(nmethod.eq.1) ctrl(27)=1.d30 +! + if((ithermal.eq.0).and.(nmethod.ne.1).and. + & (nmethod.ne.2).and.(iperturb.ne.0)) then + write(*,*) '*ERROR in couptempdisps: please define initial ' + write(*,*) ' conditions for the temperature' + stop + else + ithermal=4 + endif +! + if(solver(1:7).eq.'SPOOLES') then + isolver=0 + elseif(solver(1:16).eq.'ITERATIVESCALING') then + isolver=2 + elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then + isolver=3 + elseif(solver(1:3).eq.'SGI') then + isolver=4 + elseif(solver(1:5).eq.'TAUCS') then + isolver=5 + elseif(solver(1:7).eq.'PARDISO') then + isolver=7 + else + write(*,*) '*WARNING in couptempdisps: unknown solver;' + write(*,*) ' the default solver is used' + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + if(iperturb.ge.2) then + write(*,*) '*WARNING in couptempdisps: a nonlinear geometric + & analysis is requested' + write(*,*) ' but no time increment nor step is speci + &fied' + write(*,*) ' the defaults (1,1) are used' + tinc=1.d0 + tper=1.d0 + tmin=1.d-5 + tmax=1.d+30 + endif + return + endif +! + read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) tmin + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(4)(1:20),'(f20.0)',iostat=istat) tmax + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! + if(tinc.le.0.d0) then + write(*,*) '*ERROR in couptempdisps: initial increment size is + &negative' + endif + if(tper.le.0.d0) then + write(*,*) '*ERROR in couptempdisps: step size is negative' + endif + if(tinc.gt.tper) then + write(*,*) '*ERROR in couptempdisps: initial increment size exc + &eeds step size' + endif +! + if(idrct.ne.1) then + if(dabs(tmin).lt.1.d-10) then + tmin=min(tinc,1.d-5*tper) + endif + if(dabs(tmax).lt.1.d-10) then + tmax=1.d+30 + endif + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/uout.f calculix-ccx-2.3/ccx_2.3/src/uout.f --- calculix-ccx-2.1/ccx_2.3/src/uout.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/uout.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,44 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine uout(v,mi) +! +! This routine allows the user to write user-defined output +! to file. The output can be brought into the routine by commons +! (FORTRAN77) or modules (FORTRAN90). The file management must +! be taken care of by the user. +! +! INPUT: +! +! v solution vector +! mi(1) max # of integration points per element (max +! over all elements) +! mi(2) max degree of freedomm per node (max over all +! nodes) in fields like v(0:mi(2))... +! +! OUTPUT: none +! + implicit none +! + integer mi(2) +! + real*8 v(0:mi(2),*) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/updatecfd.f calculix-ccx-2.3/ccx_2.3/src/updatecfd.f --- calculix-ccx-2.1/ccx_2.3/src/updatecfd.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/updatecfd.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,239 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine updatecfd(vold,voldcon,v,nk, + & ielmat,ntmat_,shcon,nshcon,rhcon,nrhcon,iout, + & nmethod,convergence,physcon,iponoel,inoel,ithermal, + & nactdoh,iit,compressible,ismooth,voldtu,vtu,turbulent, + & inomat,nodeboun,ndirboun,nboun,mi,co,factor) +! +! calculates +! vold (temperature,velocity and pressure) +! voldcon (volumetric energy density, volumetric momentum +! density and density) +! at the nodes +! +! prints if iout=1 +! + implicit none +! + integer convergence,compressible +! + integer nrhcon(*),ntmat_,nactdoh(0:4,*),iit,turbulent, + & nshcon(*),ielmat(*),nk,ithermal,i,j,k,index,iout, + & nmethod,imat,nelem,iponoel(*),inoel(3,*),ismooth, + & inomat(*),node,nodeboun(*),ndirboun(*),nboun,mi(2) +! + real*8 v(0:mi(2),*),vold(0:mi(2),*),voldcon(0:4,*), + & rhcon(0:1,ntmat_,*),rho,c1,vmax(0:4),dummy,press, + & voldmax(0:4),cp,r,temp,temp0,c2,c3,tempnew,vel2, + & shcon(0:3,ntmat_,*),drho,dtemp,physcon(*),dpress, + & voldtu(2,*),vtu(2,*),co(3,*),factor +! + if(ismooth.eq.0) then +! +! updates the volumetric energy density (only if ithermal>1), +! the volumetric momentum density and the static pressure +! +c do j=0,4 +c vmax(j)=0.d0 +c voldmax(j)=0.d0 +c enddo +! +! volumetric energy density +! + if(ithermal.gt.1) then + do i=1,nk +c vmax(0)=vmax(0)+v(0,i)**2 +c voldmax(0)=voldmax(0)+voldcon(0,i)**2 + voldcon(0,i)=voldcon(0,i)+v(0,i) + enddo +! +! subtracting the boundary conditions +! +c do i=1,nboun +c if(ndirboun(i).eq.0) then +c vmax(0)=vmax(0)-v(0,nodeboun(i))**2 +c endif +c enddo +! + endif +! +! volumetric momentum density +! + do i=1,nk + do j=1,3 +c vmax(j)=vmax(j)+v(j,i)**2 +c voldmax(j)=voldmax(j)+voldcon(j,i)**2 + voldcon(j,i)=voldcon(j,i)+v(j,i) + enddo + enddo +! +! volumetric turbulent density +! + if(turbulent.ne.0) then + do i=1,nk + voldtu(1,i)=voldtu(1,i)+vtu(1,i) + voldtu(2,i)=voldtu(2,i)+vtu(2,i) + enddo + endif + endif +! +! calculate the static temperature and the density +! + if(ithermal.gt.1) then +! + do i=1,nk + if((compressible.eq.0).or.(ismooth.gt.0)) then + if(inomat(i).eq.0) cycle + imat=inomat(i) + temp=vold(0,i) + endif +! + if(compressible.eq.1) then +! +! gas: density was calculated +! + if(ismooth.eq.0) then +c vmax(4)=vmax(4)+v(4,i)**2 +c voldmax(4)=voldmax(4)+voldcon(4,i)**2 + voldcon(4,i)=voldcon(4,i)+v(4,i) + cycle + endif +! + else +! +! thermal liquid: pressure was calculated +! +c vmax(4)=vmax(4)+v(4,i)**2 +c voldmax(4)=voldmax(4)+vold(4,i)**2 + vold(4,i)=vold(4,i)+v(4,i) + c1=voldcon(0,i) + c2=(voldcon(1,i)**2+voldcon(2,i)**2+voldcon(3,i)**2)/2.d0 + temp0=temp + j=0 +! +! iterating to find the temperature +! + do + call materialdata_cp_sec(imat,ntmat_,temp,shcon, + & nshcon,cp,physcon) + call materialdata_rho(rhcon,nrhcon,imat,rho, + & temp,ntmat_,ithermal) + temp=(c1-c2/rho)/(rho*cp)+physcon(1) + j=j+1 + if((dabs(temp-temp0).lt.1.d-4*dabs(temp)).or. + & (dabs(temp-temp0).lt.1.d-10)) then + vold(0,i)=temp + exit + endif + if(j.gt.100) then + write(*,*) + & '*ERROR in updatecfd: too many iterations' + stop + endif + temp0=temp + enddo +! +! calculating the velocity +! + do k=1,3 + if(nactdoh(k,i).ne.0) then + vold(k,i)=voldcon(k,i)/rho + endif + enddo + endif + enddo + else +! +! athermal liquid calculation +! + do i=1,nk + if(inomat(i).eq.0) cycle + imat=inomat(i) + temp=vold(0,i) + call materialdata_rho(rhcon,nrhcon,imat,rho, + & temp,ntmat_,ithermal) +! +c vmax(4)=vmax(4)+v(4,i)**2 +c voldmax(4)=voldmax(4)+vold(4,i)**2 +c if((i.eq.321).or.(i.eq.322)) then +c write(*,*) 'updatecfd ',i,vold(4,i),v(4,i) +c endif + vold(4,i)=vold(4,i)+v(4,i) +c if((i.eq.321).or.(i.eq.322)) then +c write(*,*) 'updatecfd ',i,vold(4,i),v(4,i) +c endif + voldcon(4,i)=rho +! +! storing the density +! calculating the velocity +! + do k=1,3 + vold(k,i)=voldcon(k,i)/rho + enddo + enddo + endif +! +! for steady state calculations: check convergence +! + if(ismooth.eq.0) then +c convergence=0 +c do i=0,4 +c vmax(i)=dsqrt(vmax(i)) +c voldmax(i)=dsqrt(voldmax(i)) +c enddo +c if(nmethod.eq.1) then +c if(((dabs(vmax(0)).lt.1.d-8*dabs(voldmax(0))).or. +c & (dabs(voldmax(0)).lt.1.d-10)).and. +c & ((dabs(vmax(1)).lt.1.d-8*dabs(voldmax(1))).or. +c & (dabs(voldmax(1)).lt.1.d-10)).and. +c & ((dabs(vmax(2)).lt.1.d-8*dabs(voldmax(2))).or. +c & (dabs(voldmax(2)).lt.1.d-10)).and. +c & ((dabs(vmax(3)).lt.1.d-8*dabs(voldmax(3))).or. +c & (dabs(voldmax(3)).lt.1.d-10)).and. +c & ((dabs(vmax(4)).lt.1.d-8*dabs(voldmax(4))).or. +c & (dabs(voldmax(4)).lt.1.d-10)).and. +c & (iit.gt.1)) convergence=1 +c endif +c write(*,'(i10,10(1x,e11.4))') iit,vmax(0),voldmax(0), +c & vmax(1),voldmax(1),vmax(2),voldmax(2), +c & vmax(3),voldmax(3),vmax(4),voldmax(4) +c write(*,*) 'convergence ',convergence + +c factor=min(1.d0,1.01d0*factor) +c if(dabs(voldmax(0)).gt.1.d-3) then +c factor=min(factor,voldmax(0)/vmax(0)*0.001) +c endif +c if(dabs(voldmax(1)).gt.1.d-3) then +c factor=min(factor,voldmax(1)/vmax(1)*0.001) +c endif +c if(dabs(voldmax(2)).gt.1.d-3) then +c factor=min(factor,voldmax(2)/vmax(2)*0.001) +c endif +c if(dabs(voldmax(3)).gt.1.d-3) then +c factor=min(factor,voldmax(3)/vmax(3)*0.001) +c endif +c if(dabs(voldmax(4)).gt.1.d-3) then +c factor=min(factor,voldmax(4)/vmax(4)*0.001) +c endif + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/updatecomp.f calculix-ccx-2.3/ccx_2.3/src/updatecomp.f --- calculix-ccx-2.1/ccx_2.3/src/updatecomp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/updatecomp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,98 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine updatecomp(vold,voldcon,v,nk, + & ielmat,ntmat_,shcon,nshcon,rhcon,nrhcon,iout, + & nmethod,convergence,physcon,iponoel,inoel,ithermal, + & nactdoh,iit,compressible,ismooth,voldtu,vtu,turbulent, + & inomat,nodeboun,ndirboun,nboun,mi,co,factor) +! +! calculates +! vold (temperature,velocity and pressure) +! at the nodes from the conservative variables +! + implicit none +! + integer convergence,compressible +! + integer nrhcon(*),ntmat_,nactdoh(0:4,*),iit,turbulent, + & nshcon(*),ielmat(*),nk,ithermal,i,j,k,index,iout, + & nmethod,imat,nelem,iponoel(*),inoel(3,*),ismooth, + & inomat(*),node,nodeboun(*),ndirboun(*),nboun,mi(2) +! + real*8 v(0:mi(2),*),vold(0:mi(2),*),voldcon(0:4,*), + & rhcon(0:1,ntmat_,*),rho,c1,vmax(0:4),dummy,press, + & voldmax(0:4),cp,r,temp,temp0,c2,c3,tempnew,vel2, + & shcon(0:3,ntmat_,*),drho,dtemp,physcon(*),dpress, + & voldtu(2,*),vtu(2,*),co(3,*),factor +! +! calculate the static temperature and the density +! + do i=1,nk + if(inomat(i).eq.0) cycle + imat=inomat(i) + temp=vold(0,i) +! +! gas: density was calculated +! + rho=voldcon(4,i) + c1=(voldcon(0,i)-(voldcon(1,i)**2+voldcon(2,i)**2+ + & voldcon(3,i)**2)/(2.d0*rho))/rho +! +! temperature has to be calculated +! + temp0=temp + j=0 + do + call materialdata_cp_sec(imat,ntmat_,temp,shcon, + & nshcon,cp,physcon) + r=shcon(3,1,imat) + temp=max(c1/(cp-r),1.d-2)+physcon(1) +cstart shallow +c temp=max(c1/(cp),1.d-2)+physcon(1) +cend shallow + j=j+1 + if(dabs(temp-temp0).lt.1.d-4*temp) then + vold(0,i)=temp + exit + endif + if(j.gt.100) then + stop + endif + temp0=temp + enddo +! +! determining the pressure (gas equation) +! + vold(4,i)=rho*r*(temp-physcon(1)) +cstart shallow +c vold(4,i)=5.d0*(rho*rho-(0.005*co(1,i))**2) +cend shallow +! +! calculating the velocity +! + do k=1,3 + if(nactdoh(k,i).ne.0) then + vold(k,i)=voldcon(k,i)/rho + endif + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/updatecont.f calculix-ccx-2.3/ccx_2.3/src/updatecont.f --- calculix-ccx-2.1/ccx_2.3/src/updatecont.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/updatecont.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,59 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine updatecont(koncont,ncont,co,vold,cg,straight,mi) +! +! update geometric date of the contact master surface triangulation +! + implicit none +! + integer koncont(4,*),ncont,i,j,k,node,mi(2) +! + real*8 co(3,*),vold(0:mi(2),*),cg(3,*),straight(16,*),col(3,3) +! + do i=1,ncont + do j=1,3 + node=koncont(j,i) + do k=1,3 + col(k,j)=co(k,node)+vold(k,node) + enddo + enddo +! +! center of gravity of the triangles +! + do k=1,3 + cg(k,i)=col(k,1) + enddo + do j=2,3 + do k=1,3 + cg(k,i)=cg(k,i)+col(k,j) + enddo + enddo + do k=1,3 + cg(k,i)=cg(k,i)/3.d0 + enddo +! +! calculating the equation of the triangle plane and the planes +! perpendicular on it and through the triangle edges +! + call straighteq3d(col,straight(1,i)) +! + enddo +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/usermaterials.f calculix-ccx-2.3/ccx_2.3/src/usermaterials.f --- calculix-ccx-2.1/ccx_2.3/src/usermaterials.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/usermaterials.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,168 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine usermaterials(inpc,textpart,elcon,nelcon, + & nmat,ntmat_,ncmat_,iperturb,iumat,irstrt,istep,istat,n, + & iline,ipol,inl,ipoinp,inp,cocon,ncocon,ipoinpc) +! +! reading the input deck: *USER MATERIAL +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer nelcon(2,*),nmat,ntmat,ntmat_,istep,istat,ncocon(2,*), + & n,key,i,ncmat_,nconstants,imax,isum,j,iperturb(*),iumat, + & irstrt,iline,ipol,inl,ipoinp(2,*),inp(3,*),imech,ipoinpc(0:*) +! + real*8 elcon(0:ncmat_,ntmat_,*),cocon(0:6,ntmat_,*) +! + iperturb(1)=3 + iperturb(2)=0 + ntmat=0 + iumat=1 +! + if((istep.gt.0).and.(irstrt.ge.0)) then + write(*,*)'*ERROR in usermaterials: *USER MATERIAL should be' + write(*,*) ' placed before all step definitions' + stop + endif +! + if(nmat.eq.0) then + write(*,*) '*ERROR in usermaterials: *USER MATERIAL should be' + write(*,*) ' preceded by a *MATERIAL card' + stop + endif +! + imech=1 +! + do i=2,n + if(textpart(i)(1:10).eq.'CONSTANTS=') then + read(textpart(i)(11:20),'(i10)',iostat=istat) nconstants + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + elseif(textpart(i)(1:12).eq.'TYPE=THERMAL') then + imech=0 + else + write(*,*) + & '*WARNING in usermaterials: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(imech.eq.1) then +! +! mechanical user material +! +c if(nconstants.gt.21) then +c write(*,*) '*ERROR in usermaterials: number of' +c write(*,*) ' mechanical constants cannot exceed 21' +c write(*,*) ' change the source code or' +c write(*,*) ' contact the author' +c stop +c endif + nelcon(1,nmat)=-100-nconstants +! + do + isum=0 + do j=1,(nconstants)/8+1 + if(j.eq.1) then + call getnewline(inpc,textpart,istat,n,key,iline,ipol, + & inl,ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + nelcon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) + & '*ERROR in usermaterials: increase ntmat_' + stop + endif + else + call getnewline(inpc,textpart,istat,n,key,iline,ipol, + & inl,ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + write(*,*) + & '*ERROR in usermaterials: anisotropic definition' + write(*,*) ' is not complete. ' + call inputerror(inpc,ipoinpc,iline) + stop + endif + endif + imax=8 + if(8*j.gt.nconstants+1) then + imax=nconstants-8*j+9 + endif + do i=1,imax + if(isum+i.le.nconstants) then + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(isum+i,ntmat,nmat) + else + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & elcon(0,ntmat,nmat) + endif + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + isum=isum+imax +! + enddo + enddo +! + else +! +! thermal user material +! + if(nconstants.gt.6) then + write(*,*) '*ERROR in usermaterials: number of' + write(*,*) ' thermal constants cannot exceed 6' + write(*,*) ' change the source code or' + write(*,*) ' contact the author' + stop + endif + ncocon(1,nmat)=-100-nconstants +! + do + call getnewline(inpc,textpart,istat,n,key,iline,ipol, + & inl,ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) return + ntmat=ntmat+1 + ncocon(2,nmat)=ntmat + if(ntmat.gt.ntmat_) then + write(*,*) + & '*ERROR in usermaterials: increase ntmat_' + stop + endif +! + do i=1,nconstants+1 + if(i.le.nconstants) then + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & cocon(i,ntmat,nmat) + else + read(textpart(i)(1:20),'(f20.0)',iostat=istat) + & cocon(0,ntmat,nmat) + endif + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo + enddo +! + endif +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/usermpc.f calculix-ccx-2.3/ccx_2.3/src/usermpc.f --- calculix-ccx-2.1/ccx_2.3/src/usermpc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/usermpc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,307 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine usermpc(ipompc,nodempc,coefmpc, + & labmpc,nmpc,nmpc_,mpcfree,ikmpc,ilmpc,nk,nk_,nodeboun,ndirboun, + & ikboun,ilboun,nboun,nboun_,inode,node,co,label,typeboun, + & iperturb) +! +! initializes mpc fields for a user MPC +! + implicit none +! + character*1 typeboun(*) + character*20 labmpc(*),label +! + integer ipompc(*),nodempc(3,*),nmpc,nmpc_,mpcfree,nk,nk_,ikmpc(*), + & ilmpc(*),node,id,mpcfreeold,idof,l,nodeboun(*),iperturb(2), + & ndirboun(*),ikboun(*),ilboun(*),nboun,nboun_,inode,nodevector, + & index,index1,node1,i,j,imax,nkn,idofrem,idofins +! + real*8 coefmpc(*),co(3,*),aa(3),dd,cgx(3),pi(3),c1,c4,c9, + & c10,a(3),a1,amax +! + save nodevector +! + if(node.ne.0) then + if(inode.eq.1) then +! +! define a new MPC +! default for the dependent DOF direction is 1 +! + idof=8*(node-1)+1 +! + call nident(ikmpc,idof,nmpc,id) + if(id.gt.0) then + if(ikmpc(id).eq.idof) then + write(*,*) '*WARNING in usermpc: DOF for node ',node + write(*,*) ' in direction 1 has been used' + write(*,*) ' on the dependent side of another' + write(*,*) ' MPC. ',label + write(*,*) ' constraint cannot be applied' + return + endif + endif + nmpc=nmpc+1 + if(nmpc.gt.nmpc_) then + write(*,*) '*ERROR in usermpc: increase nmpc_' + stop + endif +! + ipompc(nmpc)=mpcfree + labmpc(nmpc)=label +! + do l=nmpc,id+2,-1 + ikmpc(l)=ikmpc(l-1) + ilmpc(l)=ilmpc(l-1) + enddo + ikmpc(id+1)=idof + ilmpc(id+1)=nmpc + endif +! +! general case: add a term to the MPC +! + nodempc(1,mpcfree)=node +! +! nodevector: additional node such that: +! - the coordinates of this node are the axis direction +! - the 1st DOF is reserved for the mean rotation value +! + if((labmpc(nmpc)(1:7).eq.'MEANROT').or. + & (labmpc(nmpc)(1:1).eq.'1')) then + nodevector=node + labmpc(nmpc)(1:7)='MEANROT' + endif +! + if(inode.eq.1) then + nodempc(2,mpcfree)=1 + else + nodempc(2,mpcfree)=0 + endif + mpcfree=nodempc(3,mpcfree) + else +! +! MPC definition finished: add a nonhomogeneous term +! + nk=nk+1 + if(nk.gt.nk_) then + write(*,*) '*ERROR in usermpc: increase nk_' + stop + endif +! + nodempc(1,mpcfree)=nk + nodempc(2,mpcfree)=1 +c + coefmpc(mpcfree)=1.d0 +c + mpcfreeold=mpcfree + mpcfree=nodempc(3,mpcfree) + nodempc(3,mpcfreeold)=0 + idof=8*(nk-1)+1 + call nident(ikboun,idof,nboun,id) + nboun=nboun+1 + if(nboun.gt.nboun_) then + write(*,*) '*ERROR in usermpc: increase nboun_' + stop + endif + nodeboun(nboun)=nk + ndirboun(nboun)=1 + typeboun(nboun)='U' + do l=nboun,id+2,-1 + ikboun(l)=ikboun(l-1) + ilboun(l)=ilboun(l-1) + enddo + ikboun(id+1)=idof + ilboun(id+1)=nboun +! +! calculating the MPC coefficients for linear applications +! + if((labmpc(nmpc)(1:7).eq.'MEANROT').or. + & (labmpc(nmpc)(1:1).eq.'1')) then + nkn=(inode-1)/3 + if(3*nkn.ne.inode-1) then + write(*,*) + & '*ERROR in usermpc: MPC has wrong number of terms' + stop + endif +! +! normal along the rotation axis +! + dd=0.d0 + do i=1,3 + aa(i)=co(i,nodevector) + dd=dd+aa(i)**2 + enddo + dd=dsqrt(dd) + if(dd.lt.1.d-10) then + write(*,*) + & '*ERROR in usermpc: rotation vector has zero length' + stop + endif + do i=1,3 + aa(i)=aa(i)/dd + enddo +! +! finding the center of gravity of the position and the +! displacements of the nodes involved in the MPC +! + do i=1,3 + cgx(i)=0.d0 + enddo +! + index=ipompc(nmpc) + do + node=nodempc(1,index) + if(node.eq.nodevector) exit + do j=1,3 + cgx(j)=cgx(j)+co(j,node) + enddo + index=nodempc(3,nodempc(3,nodempc(3,index))) + enddo +! + do i=1,3 + cgx(i)=cgx(i)/nkn + enddo +! +! calculating the derivatives +! + index=ipompc(nmpc) + do + node=nodempc(1,index) + if(node.eq.nodevector) exit +! +! relative positions +! + do j=1,3 + pi(j)=co(j,node)-cgx(j) + enddo + c1=pi(1)*pi(1)+pi(2)*pi(2)+pi(3)*pi(3) + if(c1.lt.1.d-20) then + write(*,*)'*WARNING in usermpc: node on rotation axis' + index=nodempc(3,nodempc(3,nodempc(3,index))) + cycle + endif +! + do j=1,3 + if(j.eq.1) then + c4=aa(2)*pi(3)-aa(3)*pi(2) + elseif(j.eq.2) then + c4=aa(3)*pi(1)-aa(1)*pi(3) + else + c4=aa(1)*pi(2)-aa(2)*pi(1) + endif + c9=c4/c1 +! + index1=ipompc(nmpc) + do + node1=nodempc(1,index1) + if(node1.eq.nodevector) exit + if(node1.eq.node) then + c10=c9*(1.d0-1.d0/real(nkn)) + else + c10=-c9/real(nkn) + endif + if(j.eq.1) then + coefmpc(index1)=coefmpc(index1)+c10 + elseif(j.eq.2) then + coefmpc(nodempc(3,index1))= + & coefmpc(nodempc(3,index1))+c10 + else + coefmpc(nodempc(3,nodempc(3,index1)))= + & coefmpc(nodempc(3,nodempc(3,index1)))+c10 + endif + index1=nodempc(3,nodempc(3,nodempc(3,index1))) + enddo + enddo + index=nodempc(3,nodempc(3,nodempc(3,index))) + enddo + coefmpc(index)=-nkn +! +! assigning the degrees of freedom +! + j=0 + index=ipompc(nmpc) + do + j=j+1 + if(j.gt.3) j=1 + nodempc(2,index)=j + index=nodempc(3,index) + if(nodempc(1,index).eq.nk) exit + enddo +! +! looking for the maximum tangent to decide which DOF should be +! taken to be the dependent one +! + index=ipompc(nmpc) + if(dabs(coefmpc(index)).lt.1.d-5) then +! +! changing the DOF of the dependent degree of freedom +! + amax=dabs(coefmpc(index)) + imax=1 + a(1)=coefmpc(index) + do i=2,3 + index=nodempc(3,index) + a(i)=coefmpc(index) + if(dabs(a(i)).gt.amax) then + amax=dabs(a(i)) + imax=i + endif + enddo +! + index=ipompc(nmpc) + nodempc(2,index)=imax + a1=a(1) + coefmpc(index)=a(imax) + do i=2,3 + index=nodempc(3,index) + if(i.eq.imax) then + nodempc(2,index)=1 + coefmpc(index)=a1 + else + nodempc(2,index)=i + endif + enddo +! +! updating ikmpc and ilmpc +! + index=ipompc(nmpc) + idofrem=8*(nodempc(1,index)-1)+1 + idofins=8*(nodempc(1,index)-1)+imax + call changedepterm(ikmpc,ilmpc,nmpc,nmpc,idofrem,idofins) + endif + elseif(labmpc(nmpc)(1:4).eq.'DIST') then + iperturb(2)=1 + if(iperturb(1).eq.0) iperturb(1)=2 + elseif(labmpc(nmpc)(1:3).eq.'GAP') then + iperturb(2)=1 + if(iperturb(1).eq.0) iperturb(1)=2 + elseif(labmpc(nmpc)(1:4).eq.'USER') then + iperturb(2)=1 + if(iperturb(1).eq.0) iperturb(1)=2 + else + write(*,*) '*ERROR in usermpc: mpc of type',labmpc(nmpc) + write(*,*) ' is unknown' + stop + endif + endif +! + return + end + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/utemp.f calculix-ccx-2.3/ccx_2.3/src/utemp.f --- calculix-ccx-2.1/ccx_2.3/src/utemp.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/utemp.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,58 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine utemp(temp,msecpt,kstep,kinc,time,node,coords,vold, + & mi) +! +! user subroutine utemp +! +! +! INPUT: +! +! msecpt number of temperature values (for volume elements:1) +! kstep step number +! kinc increment number +! time(1) current step time +! time(2) current total time +! node node number +! coords(1..3) global coordinates of the node +! vold(0..4,1..nk) solution field in all nodes +! 0: temperature +! 1: displacement in global x-direction +! 2: displacement in global y-direction +! 3: displacement in global z-direction +! 4: static pressure +! mi(1) max # of integration points per element (max +! over all elements) +! mi(2) max degree of freedomm per node (max over all +! nodes) in fields like v(0:mi(2))... +! +! OUTPUT: +! +! temp(1..msecpt) temperature in the node +! + implicit none +! + integer msecpt,kstep,kinc,node,mi(2) + real*8 temp(msecpt),time(2),coords(3),vold(0:mi(2),*) +! + temp(1)=293.d0 +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/valuesatinf.f calculix-ccx-2.3/ccx_2.3/src/valuesatinf.f --- calculix-ccx-2.1/ccx_2.3/src/valuesatinf.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/valuesatinf.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,67 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine valuesatinf(inpc,textpart,physcon, + & istep,istat,n,iline,ipol,inl,ipoinp,inp,ipoinpc) +! +! reading the input deck: *VALUES AT INFINITY +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16) +! + integer i,istep,istat,n,key,iline,ipol,inl,ipoinp(2,*),inp(3,*), + & ipoinpc(0:*) +! + real*8 physcon(*) +! + if(istep.gt.0) then + write(*,*) '*ERROR in valuesatinf: *VALUES AT INFINITY' + write(*,*) ' should only be used before the first STEP' + stop + endif +! + do i=2,n + write(*,*) + & '*WARNING in valuesatinf: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + do i=1,5 + read(textpart(i),'(f20.0)',iostat=istat) physcon(3+i) + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/variables.txt calculix-ccx-2.3/ccx_2.3/src/variables.txt --- calculix-ccx-2.1/ccx_2.3/src/variables.txt 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/variables.txt 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,547 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + This file describes the variables used in CalculiX and their meaning + +REARRANGEMENT OF THE ORDER IN THE INPUT DECK + + ifreeinp: next blank line in field inp + + ipoinp(1,i): index of the first column in field inp + containing information on a block of lines in + the input deck corresponding to fundamental key i; + a fundamental key is a key for which the order + in the input file matters + (the fundamental keys are listed in file keystart.f) + ipoinp(2,i): index of the last column in field inp + containing information on a block of lines in + the input deck corresopnding to fundamental key i; + + inp: a column i in field inp (i.e. inp(1..3,i)) + corresponds to a uninterupted block of lines + assigned to one and the same fundamental key + in the input deck. inp(1,i) is its first line + in the input deck, inp(2,i) its last line and + inp(3,i) the next column in inp corresponding + to the same fundamental key; it takes the value + 0 if none other exists. + +MATERIAL DESCRIPTION + + nmat: # materials + + matname(i): name of material i + + nelcon(1,i): # (hyper)elastic constants for material i + (negative kode for nonlinear elastic constants) + nelcon(2,i): # temperature data points for the elastic constants + of material i + elcon(0,j,i): temperature at (hyper)elastic temperature point j of + material i + elcon(k,j,i): (hyper)elastic constant k at elastic temperature point j + of material i + + nrhcon(i): # temperature data points for the density of + material i + rhcon(0,j,i): temperature at density temperature point j of + material i + rhcon(1,j,i): density at the density temperature point j of + material i + + nshcon(i): # temperature data points for the specific heat of + material i + shcon(0,j,i): temperature at specific heat temperature point j of + material i + shcon(1,j,i): specific heat at the specific heat temperature point j of + material i + + nalcon(1,i): # of expansion constants for material i + nalcon(2,i): # of temperature data points for the expansion + coefficients of material i + alcon(0,j,i): temperature at expansion temperature point j + of material i + alcon(k,j,i): expansion coefficient k at expansion temperature + point j of material i + + ncocon(1,i): # of conductivity constants for material i + ncocon(2,i): # of temperature data points for the conductivity + coefficients of material i + cocon(0,j,i): temperature at conductivity temperature point j + of material i + cocon(k,j,i): conductivity coefficient k at conductivity temperature + point j of material i + + orname(i): name of orientation i + orab(1..6,i): coordinates of points a and b defining the new + orientation + norien: # orientations + + isotropic hardening: + + nplicon(0,i): # temperature data points for the isotropic hardening + curve of material i + nplicon(j,i): # of stress - plastic strain data points at temperature + j for material i + plicon(0,j,i): temperature data point j of material i + plicon(2*k-1,j,i): stress corresponding to stress-plastic strain data + point + k at temperature data point j of material i + plicon(2*k,j,i): plastic strain corresponding to stress-plastic strain + data point k at temperature data point j of material i + + kinematic hardening: + + nplkcon(0,i): # temperature data points for the kinematic hardening + curve of material i + nplkcon(j,i): # of stress - plastic strain data points at + temperature j for material i + plkcon(0,j,i): temperature data point j of material i + plkcon(2*k-1,j,i): stress corresponding to stress-plastic strain data + point k at temperature data point j of material i + plkcon(2*k,j,i): plastic strain corresponding to stress-plastic strain + data point + k at temperature data point j of material i + + kode=-1: Arrudy-Boyce + -2: Mooney-Rivlin + -3: Neo-Hooke + -4: Ogden (N=1) + -5: Ogden (N=2) + -6: Ogden (N=3) + -7: Polynomial (N=1) + -8: Polynomial (N=2) + -9: Polynomial (N=3) + -10: Reduced Polynomial (N=1) + -11: Reduced Polynomial (N=2) + -12: Reduced Polynomial (N=3) + -13: Van der Waals (not implemented yet) + -14: Yeoh + -15: Hyperfoam (N=1) + -16: Hyperfoam (N=2) + -17: Hyperfoam (N=3) + -50: deformation plasticity + -51: incremental plasticity (no viscosity) + -52: viscoplasticity + < -100: user material routine with -kode-100 user + defined constants with keyword *USER MATERIAL + + +PROCEDURE DESCRIPTION + + iperturb: 0: linear + 1: second order theory + 2: nonlinear geometric + 3: nonlinear elastic material (and nonlinear geometric) + + nmethod: 1: static (linear or nonlinear) + 2: frequency(linear) + 3: buckling (linear) + 4: dynamic (linear or nonlinear) + +GEOMETRY DESCRIPTION + + nk: highest node number + co(i,j): coordinate i of node j + intr(1,j): transformation number applicable in node j + intr(2,j): a SPC in a node j in which a transformation + applies corresponds to a MPC. intr(2,j) contains + the number of a new node generated for the + inhomogeneous part of the MPC + + +TOPOLOGY DESCRIPTION + + ne: highest element number + mint_: max # of integration points per element (max over all + elements) + kon(i): field containing the connectivity lists of the + elements in successive order + + For element i: + + ipkon(i): (location in kon of the first node in the element + connectivity list of element i)-1 + lakon(i): element label + ielorien(i): orientation number + ielmat(i): material number + +SHELL (2-D) AND BEAM (1-D) VARIABLES (INCLUDING PLANE STRAIN, PLANE + STRESS AND AXISYMMETRIC ELEMENTS) + + iponor(2,i): two pointers for entry i of kon. The first + pointer points to the location in xnor preceding + the normals of entry i, the second points to the + location in knor of the newly generated + dependent nodes of entry i. + xnor(i): field containing the normals in nodes on the + elements they belong to + knor(i): field containing the extra nodes needed to + expand the shell and beam elements to volume + elements + thickn(2,i): thicknesses (one for shells, two for beams) in + node i + thicke(2,i): thicknesses (one for shells, two for beams) in + element nodes. The entries correspond to the + nodal entries in field kon + offset(2,i): offsets (one for shells, two for beams) in + element i + iponoel(i): pointer for node i into field inoel, which + stores the 1-D and 2-D elements belonging to the + node. + inoel(3,i): field containing an element number, a local node + number within this element and a pointer to + another entry (or zero if there is no + other). + inoelfree: next free field in inoel + rig(i): character*1 field indicating whether node i is a + rigid node ('R') or not (' '). In a rigid node + or knot all expansion nodes except the ones not + in the midface of plane stress, plane strain and + axisymmetric elements are connected with a rigid + body MPC + +AMPLITUDES + + nam: # amplitude definitions + + amta(1,j): time of (time,amplitude) pair j + amta(2,j): amplitude of (time,amplitude) pair j + namtot: total # of (time,amplitude) pairs + + For amplitude i: + + amname(i): name of the amplitude + namta(1,i): location of first (time,amplitude) pair in + field amta + namta(2,i): location of last (time,amplitude) pair in + field amta + +TRANSFORMS + + ntrans # transform definitions + trab(1..6,i) coordinates of two points defining the transform + trab(7,i) =1 for rectangular transformations + =2 for cylindrical transformations + +SINGLE POINT CONSTRAINTS + + nboun # SPC's + + For SPC (single point constraint) i: + + nodeboun(i): SPC node + ndirboun(i): SPC direction + typeboun(i): SPC type (SPCs can contain the nonhomogeneous + part of MPCs): + B=prescribed boundary condition + M=midplane + P=planempc + R=rigidbody + S=straigthmpc + U=usermpc + xboun(i): magnitude of constraint at end of a step + xbounold(i): magnitude of constraint at beginning of a step + xbounact(i): magnitude of constraint at the end of the present + increment + xbounini(i): magnitude of constraint at the start of the + present increment + iamboun(i): amplitude number + ikboun(i): ordered array of the DOFs corresponding to the + SPC's (DOF=3*(nodeboun(i)-1)+ndirboun(i)) + ilboun(i): original SPC number for ikboun(i) + +MULTIPLE POINT CONSTRAINTS + + ipompc(i): starting location in nodempc and coefmpc of MPC i + + nodempc(1,ipompc(i)),nodempc(1,nodempc(3,ipompc(i))), + nodempc(1,nodempc(3,nodempc(3,nodempc(3,ipompc(i)))),... + until nodempc(3,nodempc(3,......))))))=0: + nodes belonging to MPC i + + nodempc(2,ipompc(i)),nodempc(2,nodempc(3,ipompc(i))), + nodempc(2,nodempc(3,nodempc(3,nodempc(3,ipompc(i)))),... + until nodempc(3,nodempc(3,......))))))=0: + directions belonging to MPC i + + xbounmpc(ipompc(i)),xbounmpc(nodempc(3,ipompc(i))), + xbounmpc(nodempc(3,nodempc(3,nodempc(3,ipompc(i)))),... + until nodempc(3,nodempc(3,......))))))=0: + coefficients belonging to MPC i + ikmpc (i): ordered array of the dependent DOFs + corresponding to the MPC's + DOF=3*(nodempc(1,ipompc(i))-1)+nodempc(2,ipompc(i)) + ilmpc (i): original SPC number for ikmpc(i) + + icascade: 0: MPC's did not change since the last iteration + 1: MPC's changed since last iteration: + dependency check in cascade.c necessary + 2: at least one nonlinear MPC had DOFs in common + with a linear MPC or another nonlinear MPC. + dependency check is necessary in each iteration + +POINT LOADS + + nforc: # of point loads + + For point load i: + + nodeforc(i): node in which force is applied + ndirforc(i): direction of force + xforc(i): magnitude of force at end of a step + xforcold(i): magnitude of force at start of a step + xforcact(i): actual magnitude + iamforc(i): amplitude number + ikforc(i): ordered array of the DOFs corresponding to the + point loads (DOF=3*(nodeboun(i)-1)+ndirboun(i)) + ilforc(i): original SPC number for ikforc(i) + +DISTRIBUTED LOADS + + nload: # of facial distributed loads + + For distributed load i: + + nelemload(1,i): element to which distributed load is applied + nelemload(2,i): node for the environment temperature (only for + heat transfer analyses) + sideload(i): load label; indicated element side to which load + is applied + xload(1,i): magnitude of load at end of a step or, for heat + transfer analyses, the convection (*FILM) or the + radiation coefficient (*RADIATE) + xload(2,i): the environment temperature (only for heat + transfer analyses + xloadold(1..2,i):magnitude of load at start of a step + xloadact(1..2,i):actual magnitude of load + iamload(1,i): amplitude number for xload(1,i) + iamload(2,i): amplitude number for xload(2,i) + +MASS FLOW RATE + + nflow: # of mass flow rates + + For mass flow rate i: + + nodeflow(1,i): node from which the mass flows + nodeflow(2,i): node to which the mass flows + xflow(i): magnitude of the mass flow rate + xflowold(i): magnitude of the mass flow rate at start of a step + xflowact(i): actual magnitude of the mass flow rate + iamflow(i): amplitude number for xflow(i) + +TEMPERATURE LOADS + + t0(i): initial temperature in node i at the start of the + calculation + t1(i): temperature at the end of a step in node i + t1old(i): temperature at the start of a step in node i + t1act(i): actual temperature in node i + iamt1(i): amplitude number + +CENTRIFUGAL LOADING + + om: square of the rotational speed at the end of a step + omold: square of the rotational speed at the start of a step + omact: actual value of the square of the rotational speed + iamom: amplitude number + p1(i): coordinate i of a first point on the rotation axis + p2(i): coordinate i of a second point on the rotation axis + +GRAVITY LOADING + + bodyf(i): coordinate i of the body force at the end of a step + bodyfold(i): coordinate i of the body force at the start of a step + bodyfact(i): coordinate i of the actual body force + iambodyf: amplitude number + +STRESS AND STRAIN FIELDS + + eei(i,j,k): in general: + Lagrange strain component i in integration point j + of element k (linear strain in linear elastic + calculations) + + for elements with *DEFORMATION PLASTICITY property: + Eulerian strain component i in integration point j + of element k (linear strain in linear elastic + calculations) + + eeiini(i,j,k): Lagrange strain component i in integration point + of element k at the start of an increment + + een(i,j): Lagrange strain component i in node j (mean over all + adjacent elements linear strain in linear elastic + calculations) + + stx(i,j,k): Cauchy or PK2 + stress component i in integration point j + of element k at the end of an iteration + (linear stress in linear elastic calculations) + + sti(i,j,k): PK2 stress component i in integration point j + of element k at the start of an iteration + (linear stress in linear elastic calculations) + + stiini(i,j,k): PK2 stress component i in integration point j + of element k at the start of an increment + + stn(i,j): Cauchy stress component i in node j (mean over all + adjacent elements; "linear" stress in linear elastic + calculations) + +THERMAL ANALYSIS + + ithermal: 0: no temperatures involved in the calculation + 1: stress analysis with given temperature field + 2: thermal analysis (no displacements) + 3: coupled thermal-mechanical analysis: + temperatures and displacements are solved for + simultaneously + + v(0,j): temperature of node j at the end of + an iteration (for ithermal > 1) + vold(0,j): temperature of node j at the start + of an iteration (for ithermal > 1) + vini(0,j): temperature of node j at the start + of an increment (for ithermal > 1) + + fn(0,j): actual temperature at node j (for ithermal > 1) + + qfx(i,j,k): heat flux component i in integration point j + of element k at the end of an iteration + + qfn(i,j): heat flux component i in node j (mean over all + adjacent elements) + + +DISPLACEMENTS AND SPATIAL/TIME DERIVATIVES + + v(i,j): displacement of node j in direction i at the end of + an iteration + vold(i,j): displacement of node j in direction i at the start + of an iteration + vini(i,j): displacement of node j in direction i at the start + of an increment + + ve(i,j): velocity of node j in direction i at the end of + an iteration + veold(i,j): velocity of node j in direction i at the start + of an iteration + veini(i,j): velocity of node j in direction i at the start + of an increment + + accold(i,j): acceleration of node j in direction i at the start + of an iteration + accini(i,j): acceleration of node j in direction i at the start + of an increment + + vkl(i,j): (i,j) component of the displacement gradient tensor + at the end of an iteration + + xkl(i,j): (i,j) component of the deformation gradient tensor + at the end of an iteration + + xikl(i,j): (i,j) component of the deformation gradient tensor + at the start of an increment + + ckl(i,j): (i,j) component of the inverse of the deformation + gradient tensor + +LINEAR EQUATION SYSTEM + + ad(i): element i on diagonal of stiffness matrix + au(i): element i in upper triangle of stiffness matrix + adb(i): element i on diagonal of mass matrix, or, for + buckling, of the incremental stiffness matrix + (only nonzero elements are stored) + aub(i): element i in upper triangle of mass matrix, or, for + buckling, of the incremental stiffness matrix + (only nonzero elements are stored) + neq[0]: # of mechanical equations + neq[1]: sum of mechanical and thermal equations + nzl: number of the column such that all columns with + a higher column number do not contain any + (projected) nonzero off-diagonal terms (<= neq[1]) + nzs: sum of projected nonzero off-diagonal terms + nactdof(i,j): actual degree of freedom (in the system of equations) + of DOF i of node j (0 if not active) + +INTERNAL AND EXTERNAL FORCES + + fext(i): external mechanical forces in DOF i (due to point + loads and distributed loads, including centrifugal and + gravity loads, but excluding temperature loading and + displacement loading) + + fextini(i): external mechanical forces in DOF i (due to point + loads and distributed loads, including centrifugal and + gravity loads, but excluding temperature loading and + displacement loading) at the end of the last increment + + finc(i): external mechanical forces in DOF i augmented by + contributions due to temperature loading and prescribed + displacements; used in linear calculations only + + f(i): actual internal forces in DOF i due to: + actual displacements in the independent nodes; + prescribed displacements at the end of the increment + in the dependent nodes; + temperatures at the end of the increment in all nodes + + fini(i): internal forces in DOF i at the end of the last + increment + + b(i): right hand side of the equation system: difference + between fext and f in nonlinear calcultions; for linear + calculations, b=finc. + + fn(i,j): actual force at node j in direction i + +INCREMENT PARAMETERS + + tinc: user given increment size (can be modified by the + program if the parameter DIRECT is not activated) + tper: user given step size + + dtheta: normalized (by tper) increment size + theta: normalized (by tper) size of all previous increments (not + including the present increment) + reltime: theta+dtheta + + dtime: real time increment size + time: real time size of all previous increments INCLUDING + the present increment + +DIRECT INTEGRATION DYNAMICS + + alpha,bet,gam: parameter in the alpha-method of Hilber, Hughes and + Taylor + iexpl: =0: implicit dynamics + =1: explicit dynamics + +FREQUENCY CALCULATIONS + + mei(0) number of requested eigenvalues + mei(1) number of Lanczos vectors + mei(2) maximum number of iterations + fei(0) tolerance (accuracy) + fei(1) lower value of requested frequency range + fei(2) upper value of requested frequency range + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/viewfactors.f calculix-ccx-2.3/ccx_2.3/src/viewfactors.f --- calculix-ccx-2.1/ccx_2.3/src/viewfactors.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/viewfactors.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,99 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine viewfactors(textpart,iviewfile,istep,inpc, + & istat,n,key,iline,ipol,inl,ipoinp,inp,jobnamec,ipoinpc) +! +! reading the input deck: *VIEWFACTOR +! + implicit none +! + character*1 inpc(*) + character*132 textpart(16),jobnamec(*) +! + integer i,iviewfile,istep,n,istat,iline,ipol,inl,ipoinp(2,*), + & inp(3,*),key,j,k,l,ipoinpc(0:*) +! + if(istep.lt.1) then + write(*,*) '*ERROR in viscos: *VISCO can only be used' + write(*,*) ' within a STEP' + stop + endif +! + do i=2,n + if(textpart(i)(1:4).eq.'READ') then + if(iviewfile.eq.0) then + iviewfile=-1 + else + iviewfile=-abs(iviewfile) + endif + elseif(textpart(i)(1:5).eq.'WRITE') then + if(iviewfile.eq.0) then + iviewfile=2 + else + iviewfile=2*iviewfile/abs(iviewfile) + endif + elseif(textpart(i)(1:6).eq.'INPUT=') then + jobnamec(2)(1:126)=textpart(i)(7:132) + jobnamec(2)(127:132)=' ' + loop1: do j=1,126 + if(jobnamec(2)(j:j).eq.'"') then + do k=j+1,126 + if(jobnamec(2)(k:k).eq.'"') then + do l=k-1,126 + jobnamec(2)(l:l)=' ' + exit loop1 + enddo + endif + jobnamec(2)(k-1:k-1)=jobnamec(2)(k:k) + enddo + jobnamec(2)(126:126)=' ' + endif + enddo loop1 + elseif(textpart(i)(1:7).eq.'OUTPUT=') then + jobnamec(3)(1:125)=textpart(i)(8:132) + jobnamec(3)(126:132)=' ' + loop2: do j=1,125 + if(jobnamec(3)(j:j).eq.'"') then + do k=j+1,125 + if(jobnamec(3)(k:k).eq.'"') then + do l=k-1,125 + jobnamec(3)(l:l)=' ' + exit loop2 + enddo + endif + jobnamec(3)(k-1:k-1)=jobnamec(3)(k:k) + enddo + jobnamec(3)(125:125)=' ' + endif + enddo loop2 + else + write(*,*) + & '*WARNING in viewfactors: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/viscos.f calculix-ccx-2.3/ccx_2.3/src/viscos.f --- calculix-ccx-2.1/ccx_2.3/src/viscos.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/viscos.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,165 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine viscos(inpc,textpart,nmethod,iperturb,isolver,istep, + & istat,n,tinc,tper,tmin,tmax,idrct,iline,ipol,inl,ipoinp, + & inp,ipoinpc) +! +! reading the input deck: *VISCO (provided for compatibility +! reasons with ABAQUS) +! +! isolver=0: SPOOLES +! 2: iterative solver with diagonal scaling +! 3: iterative solver with Cholesky preconditioning +! 4: sgi solver +! 5: TAUCS +! 7: pardiso +! + implicit none +! + character*1 inpc(*) + character*20 solver + character*132 textpart(16) +! + integer nmethod,iperturb,isolver,istep,istat,n,key,i,idrct, + & iline,ipol,inl,ipoinp(2,*),inp(3,*),ipoinpc(0:*) +! + real*8 tinc,tper,tmin,tmax +! + idrct=0 + tmin=0.d0 + tmax=0.d0 +! + if((iperturb.eq.1).and.(istep.gt.1)) then + write(*,*) '*ERROR in viscos: perturbation analysis is' + write(*,*) ' not provided in a *VISCO step. Perform' + write(*,*) ' a genuine nonlinear geometric calculation' + write(*,*) ' instead (parameter NLGEOM)' + stop + endif +! + if(istep.lt.1) then + write(*,*) '*ERROR in viscos: *VISCO can only be used' + write(*,*) ' within a STEP' + stop + endif +! +! default solver +! + solver=' ' + if(isolver.eq.0) then + solver(1:7)='SPOOLES' + elseif(isolver.eq.2) then + solver(1:16)='ITERATIVESCALING' + elseif(isolver.eq.3) then + solver(1:17)='ITERATIVECHOLESKY' + elseif(isolver.eq.4) then + solver(1:3)='SGI' + elseif(isolver.eq.5) then + solver(1:5)='TAUCS' + elseif(isolver.eq.7) then + solver(1:7)='PARDISO' + endif +! + do i=2,n + if(textpart(i)(1:7).eq.'SOLVER=') then + read(textpart(i)(8:27),'(a20)') solver + elseif((textpart(i)(1:6).eq.'DIRECT').and. + & (textpart(i)(1:9).ne.'DIRECT=NO')) then + idrct=1 + else + write(*,*) + & '*WARNING in viscos: parameter not recognized:' + write(*,*) ' ', + & textpart(i)(1:index(textpart(i),' ')-1) + call inputwarning(inpc,ipoinpc,iline) + endif + enddo +! + if(solver(1:7).eq.'SPOOLES') then + isolver=0 + elseif(solver(1:16).eq.'ITERATIVESCALING') then + isolver=2 + elseif(solver(1:17).eq.'ITERATIVECHOLESKY') then + isolver=3 + elseif(solver(1:3).eq.'SGI') then + isolver=4 + elseif(solver(1:5).eq.'TAUCS') then + isolver=5 + elseif(solver(1:7).eq.'PARDISO') then + isolver=7 + else + write(*,*) '*WARNING in viscos: unknown solver;' + write(*,*) ' the default solver is used' + endif +! + nmethod=1 +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) + if((istat.lt.0).or.(key.eq.1)) then + if(iperturb.ge.2) then + write(*,*) '*WARNING in viscos: a nonlinear geometric analys + &is is requested' + write(*,*) ' but no time increment nor step is speci + &fied' + write(*,*) ' the defaults (1,1) are used' + tinc=1.d0 + tper=1.d0 + tmin=1.d-5 + tmax=1.d+30 + endif + return + endif +! + read(textpart(1)(1:20),'(f20.0)',iostat=istat) tinc + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(2)(1:20),'(f20.0)',iostat=istat) tper + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(3)(1:20),'(f20.0)',iostat=istat) tmin + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) + read(textpart(4)(1:20),'(f20.0)',iostat=istat) tmax + if(istat.gt.0) call inputerror(inpc,ipoinpc,iline) +! + if(tinc.le.0.d0) then + write(*,*) '*ERROR in viscos: initial increment size is negativ + &e' + endif + if(tper.le.0.d0) then + write(*,*) '*ERROR in viscos: step size is negative' + endif + if(tinc.gt.tper) then + write(*,*) '*ERROR in viscos: initial increment size exceeds st + &ep size' + endif +! + if(idrct.ne.1) then + if(dabs(tmin).lt.1.d-10) then + tmin=min(tinc,1.d-5*tper) + endif + if(dabs(tmax).lt.1.d-10) then + tmax=1.d+30 + endif + endif +! + call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl, + & ipoinp,inp,ipoinpc) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/vortex.f calculix-ccx-2.3/ccx_2.3/src/vortex.f --- calculix-ccx-2.1/ccx_2.3/src/vortex.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/vortex.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,607 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine vortex(node1,node2,nodem,nelem,lakon,kon,ipkon, + & nactdog,identity,ielprop,prop,iflag,v,xflow,f, + & nodef,idirf,df,cp,R,numf,set,mi) +! +! orifice element +! + implicit none +! + logical identity + character*8 lakon(*) + character*81 set(*) +! + integer nelem,nactdog(0:3,*),node1,node2,nodem,numf, + & ielprop(*),nodef(4),idirf(4),index,iflag, + & inv,ipkon(*),kon(*),t_chang,nelemswirl,mi(2) +! + real*8 prop(*),v(0:mi(2),*),xflow,f,df(4),kappa,r,cp, + & p1,p2,T1,T2,km1,pi, + & r2d,r1d,eta,U1, + & c1u,c2u, cinput, r1, r2, omega, K1, rpm,ciu,expon, + & Ui,Kr,cte1,cte2,qred_crit,A,xflow_oil +! + if (iflag.eq.0) then + identity=.true. +! + if(nactdog(2,node1).ne.0)then + identity=.false. + elseif(nactdog(2,node2).ne.0)then + identity=.false. + elseif(nactdog(1,nodem).ne.0)then + identity=.false. + endif +! + elseif (iflag.eq.1)then +! + kappa=(cp/(cp-R)) + pi=4.d0*datan(1.d0) + index=ielprop(nelem) + qred_crit=dsqrt(kappa/R)* + & (1+0.5d0*(kappa-1))**(-0.5*(kappa+1)/(kappa-1)) +! +! Because there is no explicit expression relating massflow +! with to pressure loss for vortices +! For FREE as well as for FORCED VORTICES +! initial mass flow is set to Qred_crit/2 = 0.02021518917 +! with consideration to flow direction +! + node1=kon(ipkon(nelem)+1) + node2=kon(ipkon(nelem)+3) + p1=v(2,node1) + p2=v(2,node2) + T1=v(0,node1) + T2=v(0,node2) +! +! abstract cross section + A=10E-6 +! + if(p1.gt.p2) then + xflow=0.5/dsqrt(T1)*A*P1*qred_crit + else + xflow=-0.5/dsqrt(T1)*A*P1*qred_crit + endif +! + elseif (iflag.eq.2)then +! + numf=4 + index=ielprop(nelem) + kappa=(cp/(cp-R)) + km1=kappa-1 + pi=4.d0*datan(1.d0) +! +! radius downstream + r2d=prop(index+1) +! +! radius upstream + r1d=prop(index+2) +! +! pressure correction factor + eta=prop(index+3) +! + p1=v(2,node1) + p2=v(2,node2) +! + xflow=v(1,nodem) +! + if(xflow.gt.0.d0) then + inv=1.d0 + p1=v(2,node1) + p2=v(2,node2) + T1=v(0,node1) + T2=v(0,node2) + R1=r1d + R2=r2d +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! + elseif(xflow.lt.0.d0) then + inv=-1.d0 + R1=r2d + R2=r1d + p1=v(2,node2) + p2=v(2,node1) + T1=v(0,node2) + T2=v(0,node1) + xflow=-v(1,nodem) +! + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 +! + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 +! + kappa=(cp/(cp-R)) +! +! FREE VORTEX +! + if(lakon(nelem)(4:5).eq.'FR')then +! +! rotation induced loss (correction factor) + K1= prop(index+4) +! +! tangential velocity of the disk at vortex entry + U1=prop(index+5) +! +! number of the element generating the upstream swirl + nelemswirl=int(prop(index+6)) +! +! rotation speed (revolution per minutes) + rpm=prop(index+7) +! +! Temperature change + t_chang=prop(index+8) +! + if(rpm.gt.0) then +! +! rotation speed is given (rpm) if the swirl comes from a rotating part +! typically the blade of a coverplate +! + omega=pi/30d0*rpm + +! C_u is given by radius r1d (see definition of the flow direction) +! C_u related to radius r2d is a function of r1d +! + if(inv.gt.0) then + c1u=omega*r1 +! +! flow rotation at outlet + c2u=c1u*r1/r2 +! + elseif(inv.lt.0) then + c2u=omega*r2 +! + c1u=c2u*r2/r1 + endif +! + elseif(nelemswirl.gt.0) then + if(lakon(nelemswirl)(2:5).eq.'ORPN') then + cinput=prop(ielprop(nelemswirl)+5) + elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then + cinput=prop(ielprop(nelemswirl)+9) + elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then + cinput=prop(ielprop(nelemswirl)+7) + endif +! + cinput=U1+K1*(cinput-U1) +! + if(inv.gt.0) then + c1u=cinput + c2u=c1u*R1/R2 + elseif(inv.lt.0) then + c2u=cinput + c1u=c2u*R2/R1 + endif + endif +! +! storing the tengential velocity for later use (wirbel cascade) + if(inv.gt.0) then + prop(index+9)=c2u + elseif(inv.lt.0) then + prop(index+9)=c1u + endif +! +! inner rotation +! + if(R1.lt.R2) then + ciu=c1u + elseif(R1.ge.R2) then + ciu=c2u + endif +! + expon=kappa/km1 +! + if(R2.ge.R1) then +! + cte1=c1u**2/(2*Cp*T1) + cte2=1-(R1/R2)**2 + + f=P2/P1-1d0-eta*((1+cte1*cte2)**expon-1d0) +! + df(1)=-p2/p1**2 +! + df(2)=eta*expon*cte1/T1*cte2* + & (1+cte1*cte2)**(expon-1) +! + df(3)=0 +! + df(4)=1/p1 +! + elseif(R2.lt.R1) then +! + cte1=c2u**2/(2*Cp*T2) + cte2=1-(R2/R1)**2 +! + f=P1/P2-1d0-eta*((1+cte1*cte2)**expon-1d0) +! + df(1)=1/p2 +! + df(2)=eta*expon*cte1/T1*cte2* + & (1+cte1*cte2)**(expon-1) +! + df(3)=0 +! + df(4)=-p1/p2**2 +! + endif +! +! FORCED VORTEX +! + elseif(lakon(nelem)(4:5).eq.'FO') then +! +! core swirl ratio + Kr=prop(index+4) +! +! rotation speed (revolution per minutes) of the rotating part +! responsible for the swirl + rpm=prop(index+5) +! +! Temperature change + t_chang=prop(index+6) +! +! rotation speed + omega=pi/30*rpm +! + if(R2.ge.R1) then + Ui=omega*R1 + c1u=Ui*kr + c2u=c1u*R2/R1 + elseif(R2.lt.R1) then + Ui=omega*R2 + c2u=Ui*kr + c1u=c2u*R1/R2 + endif +! +! storing the tengential velocity for later use (wirbel cascade) + if(inv.gt.0) then + prop(index+7)=c2u + elseif(inv.lt.0) then + prop(index+7)=c1u + endif +! + expon=kappa/km1 +! + if(((R2.ge.R1).and.(xflow.gt.0d0)) + & .or.((R2.lt.R1).and.(xflow.lt.0d0)))then +! + cte1=(c1u)**2/(2*Cp*T1) + cte2=(R2/R1)**2-1 +! + f=p2/p1-1-eta*((1+cte1*cte2)**expon-1) +! +! pressure node1 + df(1)=-p2/p1**2 +! +! temperature node1 + df(2)=eta*expon*cte1/T1*cte2*(1+cte1*cte2)**(expon-1) +! +! massflow nodem + df(3)=0 +! +! pressure node2 + df(4)=1/p1 +! + elseif(((R2.lt.R1).and.(xflow.gt.0d0)) + & .or.((R2.gt.R1).and.(xflow.lt.0d0)))then + cte1=(c2u)**2/(2*Cp*T2) + cte2=(R1/R2)**2-1 +! + f=p1/p2-1-eta*((1+cte1*cte2)**expon-1) +! +! pressure node1 + df(1)=1/p2 +! +! temperature node1 + df(2)=eta*expon*cte1/T2*cte2*(1+cte1*cte2)**(expon-1) +! +! massflow nodem + df(3)=0 +! +! pressure node2 + df(4)=-p1/p2**2 +! + endif + endif +! +! outpout +! + elseif(iflag.eq.3) then +! + index=ielprop(nelem) + kappa=(cp/(cp-R)) + km1=kappa-1 + pi=4.d0*datan(1.d0) +! +! radius downstream + r2d=prop(index+1) +! +! radius upstream + r1d=prop(index+2) +! +! pressure correction factor + eta=prop(index+3) +! + p1=v(2,node1) + p2=v(2,node2) +! + xflow=v(1,nodem) +! + if(xflow.gt.0.d0) then + inv=1.d0 + p1=v(2,node1) + p2=v(2,node2) + T1=v(0,node1) + T2=v(0,node2) + R1=r1d + R2=r2d +! + nodef(1)=node1 + nodef(2)=node1 + nodef(3)=nodem + nodef(4)=node2 +! + elseif(xflow.lt.0.d0) then + inv=-1.d0 + R1=r2d + R2=r1d + p1=v(2,node2) + p2=v(2,node1) + T1=v(0,node2) + T2=v(0,node1) + xflow=v(1,nodem) +! + nodef(1)=node2 + nodef(2)=node2 + nodef(3)=nodem + nodef(4)=node1 +! + endif +! + idirf(1)=2 + idirf(2)=0 + idirf(3)=1 + idirf(4)=2 +! + kappa=(cp/(cp-R)) +! +! FREE VORTEX +! + if(lakon(nelem)(4:5).eq.'FR')then +! +! rotation induced loss (correction factor) + K1= prop(index+4) +! +! tengential velocity of the disk at vortex entry + U1=prop(index+5) +! +! number of the element generating the upstream swirl + nelemswirl=int(prop(index+6)) +! +! rotation speed (revolution per minutes) + rpm=prop(index+7) +! +! Temperature change + t_chang=prop(index+8) +! + if(rpm.gt.0) then +! +! rotation speed is given (rpm) if the swirl comes from a rotating part +! typically the blade of a coverplate +! + omega=pi/30d0*rpm + +! C_u is given by radius r1d (see definition of the flow direction) +! C_u related to radius r2d is a function of r1d +! + if(inv.gt.0) then + c1u=omega*r1 +! +! flow rotation at outlet + c2u=c1u*r1/r2 +! + elseif(inv.lt.0) then + c2u=omega*r2 +! + c1u=c2u*r2/r1 + endif +! + elseif(nelemswirl.gt.0) then + if(lakon(nelemswirl)(2:5).eq.'ORPN') then + cinput=prop(ielprop(nelemswirl)+5) + elseif(lakon(nelemswirl)(2:5).eq.'VOFR') then + cinput=prop(ielprop(nelemswirl)+9) + elseif(lakon(nelemswirl)(2:5).eq.'VOFO') then + cinput=prop(ielprop(nelemswirl)+7) + endif +! + cinput=U1+K1*(cinput-U1) +! + if(inv.gt.0) then + c1u=cinput + c2u=c1u*R1/R2 + elseif(inv.lt.0) then + c2u=cinput + c1u=c2u*R2/R1 + endif + endif +! +! storing the tengential velocity for later use (wirbel cascade) + if(inv.gt.0) then + prop(index+9)=c2u + elseif(inv.lt.0) then + prop(index+9)=c1u + endif +! +! inner rotation +! + if(R1.lt.R2) then + ciu=c1u + elseif(R1.ge.R2) then + ciu=c2u + endif +! + expon=kappa/km1 +! + if(R2.ge.R1) then +! + cte1=c1u**2/(2*Cp*T1) + cte2=1-(R1/R2)**2 + + f=P2/P1-1d0-eta*((1+cte1*cte2)**expon-1d0) +! + df(1)=-p2/p1**2 +! + df(2)=eta*expon*cte1/T1*cte2* + & (1+cte1*cte2)**(expon-1) +! + df(3)=0 +! + df(4)=1/p1 +! + elseif(R2.lt.R1) then +! + cte1=c2u**2/(2*Cp*T2) + cte2=1-(R2/R1)**2 +! + f=P1/P2-1d0-eta*((1+cte1*cte2)**expon-1d0) +! + df(1)=1/p2 +! + df(2)=eta*expon*cte1/T1*cte2* + & (1+cte1*cte2)**(expon-1) +! + df(3)=0 +! + df(4)=-p1/p2**2 +! + endif +! +! FORCED VORTEX +! + elseif(lakon(nelem)(4:5).eq.'FO') then +! +! core swirl ratio + Kr=prop(index+4) +! +! rotation speed (revolution per minutes) of the rotating part +! responsible for the swirl + rpm=prop(index+5) +! +! Temperature change + t_chang=prop(index+6) +! +! no element generating the upstream swirl + nelemswirl=0 +! +! rotation speed + omega=pi/30*rpm +! + if(R2.ge.R1) then + Ui=omega*R1 + c1u=Ui*kr + c2u=c1u*R2/R1 + elseif(R2.lt.R1) then + Ui=omega*R2 + c2u=Ui*kr + c1u=c2u*R1/R2 + endif +! +! storing the tengential velocity for later use (wirbel cascade) + if(inv.gt.0) then + prop(index+7)=c2u + elseif(inv.lt.0) then + prop(index+7)=c1u + endif +! + expon=kappa/km1 + endif +! + xflow_oil=0.d0 +! + write(1,*) '' + write(1,55) 'In line',int(nodem/1000),' from node',node1, + &' to node', node2,': air massflow rate=',xflow,'kg/s', + &', oil massflow rate=',xflow_oil,'kg/s' + 55 FORMAT(1X,A,I6.3,A,I6.3,A,I6.3,A,F9.5,A,A,F9.5,A) + + if(inv.eq.1) then + write(1,56)' Inlet node ',node1,': Tt1= ',T1, + & 'K, Ts1= ',T1,'K, Pt1= ',P1/1E5, + & 'Bar' + write(1,*)' element V ',set(numf)(1:20) + write(1,57)' C1u= ',C1u,'m/s ,C2u= ',C2u,'m/s' + write(1,56)' Outlet node ',node2,': Tt2= ',T2, + & 'K, Ts2= ',T2,'K, Pt2= ',P2/1e5, + & 'Bar' +! + else if(inv.eq.-1) then + write(1,56)' Inlet node ',node2,': Tt1= ',T1, + & 'K, Ts1= ',T1,'K, Pt1= ',P1/1E5, + & 'Bar' + write(1,*)' element V ',set(numf)(1:20) + write(1,57)' C1u= ',C1u,'m/s ,C2u= ',C2u,'m/s' + write(1,56)' Outlet node ',node1,' Tt2= ', + & T2,'K, Ts2= ',T2,'K, Pt2= ',P2/1e5, + & 'Bar' + endif + 56 FORMAT(1X,A,I6.3,A,f6.1,A,f6.1,A,f9.5,A,f9.5) + 57 FORMAT(1X,A,f6.2,A,f6.2,A) + endif +! + return + end + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff -Nru calculix-ccx-2.1/ccx_2.3/src/wcoef.f calculix-ccx-2.3/ccx_2.3/src/wcoef.f --- calculix-ccx-2.1/ccx_2.3/src/wcoef.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/wcoef.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,146 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine wcoef(v,vo,al,um) +! +! computation of the coefficients of w in the derivation of the +! second order element stiffness matrix +! + implicit none +! + real*8 v(3,3,3,3),vo(3,3) +! + real*8 a2u,al,um,au,p1,p2,p3 +! + a2u=al+2.d0*um + au=al+um +! + p1=vo(1,1)+1.d0 + p2=vo(2,2)+1.d0 + p3=vo(3,3)+1.d0 +! + v(1,1,1,1)=a2u*p1*p1+um*(vo(1,2)**2+vo(1,3)**2) + v(2,1,1,1)=au*vo(1,2)*p1 + v(3,1,1,1)=au*vo(1,3)*p1 + v(1,2,1,1)=v(2,1,1,1) + v(2,2,1,1)=a2u*vo(1,2)**2+um*(p1*p1+vo(1,3)**2) + v(3,2,1,1)=au*vo(1,2)*vo(1,3) + v(1,3,1,1)=v(3,1,1,1) + v(2,3,1,1)=v(3,2,1,1) + v(3,3,1,1)=a2u*vo(1,3)**2+um*(p1*p1+vo(1,2)**2) +! + v(1,1,2,1)=al*vo(2,1)*p1+ + & um*(2.d0*vo(2,1)*p1+vo(1,2)*p2+vo(2,3)*vo(1,3)) + v(2,1,2,1)=al*p1*p2+um*vo(2,1)*vo(1,2) + v(3,1,2,1)=al*vo(2,3)*p1+um*vo(2,1)*vo(1,3) + v(1,2,2,1)=al*vo(2,1)*vo(1,2)+um*p1*p2 + v(2,2,2,1)=al*vo(1,2)*p2+ + & um*(vo(2,1)*p1+2.d0*vo(1,2)*p2+vo(2,3)*vo(1,3)) + v(3,2,2,1)=al*vo(2,3)*vo(1,2)+um*vo(1,3)*p2 + v(1,3,2,1)=al*vo(2,1)*vo(1,3)+um*vo(2,3)*p1 + v(2,3,2,1)=al*vo(1,3)*p2+um*vo(2,3)*vo(1,2) + v(3,3,2,1)=a2u*vo(2,3)*vo(1,3)+ + & um*(vo(2,1)*p1+vo(1,2)*p2) +! + v(1,1,3,1)=al*vo(3,1)*p1+ + & um*(vo(1,3)*p3+2.d0*vo(3,1)*p1+vo(3,2)*vo(1,2)) + v(2,1,3,1)=al*vo(3,2)*p1+um*vo(3,1)*vo(1,2) + v(3,1,3,1)=al*p1*p3+um*vo(3,1)*vo(1,3) + v(1,2,3,1)=al*vo(3,1)*vo(1,2)+um*vo(3,2)*p1 + v(2,2,3,1)=a2u*vo(3,2)*vo(1,2)+ + & um*(vo(1,3)*p3+vo(3,1)*p1) + v(3,2,3,1)=al*vo(1,2)*p3+um*vo(3,2)*vo(1,3) + v(1,3,3,1)=al*vo(3,1)*vo(1,3)+um*p1*p3 + v(2,3,3,1)=al*vo(3,2)*vo(1,3)+um*vo(1,2)*p3 + v(3,3,3,1)=al*vo(1,3)*p3+ + & um*(2.d0*vo(1,3)*p3+vo(3,1)*p1+vo(3,2)*vo(1,2)) +! + v(1,1,1,2)=al*vo(2,1)*p1+ + & um*(vo(1,2)*p2+2.d0*vo(2,1)*p1+vo(1,3)*vo(2,3)) + v(2,1,1,2)=al*vo(1,2)*vo(2,1)+um*p1*p2 + v(3,1,1,2)=al*vo(1,3)*vo(2,1)+um*vo(2,3)*p1 + v(1,2,1,2)=al*p1*p2+um*vo(1,2)*vo(2,1) + v(2,2,1,2)=al*vo(1,2)*p2+ + & um*(2.d0*vo(1,2)*p2+vo(2,1)*p1+vo(1,3)*vo(2,3)) + v(3,2,1,2)=al*vo(1,3)*p2+um*vo(1,2)*vo(2,3) + v(1,3,1,2)=al*vo(2,3)*p1+um*vo(1,3)*vo(2,1) + v(2,3,1,2)=al*vo(1,2)*vo(2,3)+um*vo(1,3)*p2 + v(3,3,1,2)=a2u*vo(1,3)*vo(2,3)+ + & um*(vo(1,2)*p2+vo(2,1)*p1) +! + v(1,1,2,2)=a2u*vo(2,1)**2+um*(p2*p2+vo(2,3)**2) + v(2,1,2,2)=au*vo(2,1)*p2 + v(3,1,2,2)=au*vo(2,3)*vo(2,1) + v(1,2,2,2)=v(2,1,2,2) + v(2,2,2,2)=a2u*p2*p2+um*(vo(2,1)**2+vo(2,3)**2) + v(3,2,2,2)=au*vo(2,3)*p2 + v(1,3,2,2)=v(3,1,2,2) + v(2,3,2,2)=v(3,2,2,2) + v(3,3,2,2)=a2u*vo(2,3)**2+um*(p2*p2+vo(2,1)**2) +! + v(1,1,3,2)=a2u*vo(3,1)*vo(2,1)+ + & um*(vo(3,2)*p2+vo(2,3)*p3) + v(2,1,3,2)=al*vo(3,2)*vo(2,1)+um*vo(3,1)*p2 + v(3,1,3,2)=al*vo(2,1)*p3+um*vo(3,1)*vo(2,3) + v(1,2,3,2)=al*vo(3,1)*p2+um*vo(3,2)*vo(2,1) + v(2,2,3,2)=al*vo(3,2)*p2+ + & um*(2.d0*vo(3,2)*p2+vo(2,3)*p3+vo(3,1)*vo(2,1)) + v(3,2,3,2)=al*p2*p3+um*vo(3,2)*vo(2,3) + v(1,3,3,2)=al*vo(3,1)*vo(2,3)+um*vo(2,1)*p3 + v(2,3,3,2)=al*vo(3,2)*vo(2,3)+um*p2*p3 + v(3,3,3,2)=al*vo(2,3)*p3+ + & um*(vo(3,2)*p2+2.d0*vo(2,3)*p3+vo(3,1)*vo(2,1)) +! + v(1,1,1,3)=al*vo(3,1)*p1+ + & um*(vo(1,3)*p3+2.d0*vo(3,1)*p1+vo(1,2)*vo(3,2)) + v(2,1,1,3)=al*vo(1,2)*vo(3,1)+um*vo(3,2)*p1 + v(3,1,1,3)=al*vo(1,3)*vo(3,1)+um*p1*p3 + v(1,2,1,3)=al*vo(3,2)*p1+um*vo(1,2)*vo(3,1) + v(2,2,1,3)=a2u*vo(1,2)*vo(3,2)+ + & um*(vo(1,3)*p3+vo(3,1)*p1) + v(3,2,1,3)=al*vo(1,3)*vo(3,2)+um*vo(1,2)*p3 + v(1,3,1,3)=al*p1*p3+um*vo(1,3)*vo(3,1) + v(2,3,1,3)=al*vo(1,2)*p3+um*vo(1,3)*vo(3,2) + v(3,3,1,3)=al*vo(1,3)*p3+ + & um*(2.d0*vo(1,3)*p3+vo(3,1)*p1+vo(1,2)*vo(3,2)) +! + v(1,1,2,3)=a2u*vo(2,1)*vo(3,1)+ + & um*(vo(2,3)*p3+vo(3,2)*p2) + v(2,1,2,3)=al*vo(3,1)*p2+um*vo(2,1)*vo(3,2) + v(3,1,2,3)=al*vo(2,3)*vo(3,1)+um*vo(2,1)*p3 + v(1,2,2,3)=al*vo(2,1)*vo(3,2)+um*vo(3,1)*p2 + v(2,2,2,3)=al*vo(3,2)*p2+ + & um*(vo(2,3)*p3+2.d0*vo(3,2)*p2+vo(2,1)*vo(3,1)) + v(3,2,2,3)=al*vo(2,3)*vo(3,2)+um*p2*p3 + v(1,3,2,3)=al*vo(2,1)*p3+um*vo(2,3)*vo(3,1) + v(2,3,2,3)=al*p2*p3+um*vo(2,3)*vo(3,2) + v(3,3,2,3)=al*vo(2,3)*p3+ + & um*(2.d0*vo(2,3)*p3+vo(3,2)*p2+vo(2,1)*vo(3,1)) +! + v(1,1,3,3)=a2u*vo(3,1)**2+um*(p3*p3+vo(3,2)**2) + v(2,1,3,3)=au*vo(3,2)*vo(3,1) + v(3,1,3,3)=au*vo(3,1)*p3 + v(1,2,3,3)=v(2,1,3,3) + v(2,2,3,3)=a2u*vo(3,2)**2+um*(p3*p3+vo(3,1)**2) + v(3,2,3,3)=au*vo(3,2)*p3 + v(1,3,3,3)=v(3,1,3,3) + v(2,3,3,3)=v(3,2,3,3) + v(3,3,3,3)=a2u*p3*p3+um*(vo(3,1)**2+vo(3,2)**2) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/writeboun.f calculix-ccx-2.3/ccx_2.3/src/writeboun.f --- calculix-ccx-2.1/ccx_2.3/src/writeboun.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writeboun.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,38 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writeboun(nodeboun,ndirboun,xboun,typeboun,nboun) +! +! writes an MPC to standard output (for debugging purposes) +! + implicit none +! + character*1 typeboun(*) + integer nodeboun(*),ndirboun(*),nboun,i + real*8 xboun(*) +! + write(*,*) + write(*,'(''SPC '')') + do i=1,nboun + write(*,'(i5,1x,i10,1x,i5,1x,e11.4,1x,a1)') i,nodeboun(i), + & ndirboun(i),xboun(i),typeboun(i) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writebv.f calculix-ccx-2.3/ccx_2.3/src/writebv.f --- calculix-ccx-2.1/ccx_2.3/src/writebv.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writebv.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,42 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writebv(x,nx) +! +! writes the buckling force factor to unit 3 +! + implicit none +! + integer j,nx + real*8 x(nx),pi +! + pi=4.d0*datan(1.d0) +! + write(5,*) + write(5,*) ' B U C K L I N G F A C T O R O U T P U T' + write(5,*) + write(5,*) 'MODE NO BUCKLING' + write(5,*) ' FACTOR' + write(5,*) + do j=1,nx + write(5,'(i7,2x,e14.7)') j,x(j) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writeevcs.f calculix-ccx-2.3/ccx_2.3/src/writeevcs.f --- calculix-ccx-2.1/ccx_2.3/src/writeevcs.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writeevcs.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,53 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writeevcs(x,nx,nm,xmin,xmax) +! +! writes the eigenvalues to unit 3 and replaces the +! eigenvalue by its square root = frequency (in rad/time) +! +! nm is the nodal diameter +! + implicit none +! + integer j,nx,nm + real*8 x(nx),pi,xmin,xmax +! + pi=4.d0*datan(1.d0) +! + write(5,*) + write(5,*) ' E I G E N V A L U E O U T P U T' + write(5,*) + write(5,*) ' NODAL MODE NO EIGENVALUE FREQUENCY' + write(5,*) 'DIAMETER (RAD/TIME) (CY + &CLES/TIME)' + write(5,*) + do j=1,nx + if(x(j).lt.0.d0) x(j)=0.d0 + x(j)=dsqrt(x(j)) + if(xmin.gt.x(j)) cycle + if(xmax.gt.0.d0) then + if(xmax.lt.x(j)) exit + endif + write(5,'(i5,4x,i7,3(2x,e14.7))') nm,j,x(j)*x(j),x(j), + & x(j)/(2.d0*pi) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writeev.f calculix-ccx-2.3/ccx_2.3/src/writeev.f --- calculix-ccx-2.1/ccx_2.3/src/writeev.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writeev.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,51 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writeev(x,nx,xmin,xmax) +! +! writes the eigenvalues to unit 3 and replaces the +! eigenvalue by its square root = frequency (in rad/time) +! + implicit none +! + integer j,nx + real*8 x(nx),pi,xmin,xmax +! + pi=4.d0*datan(1.d0) +! + write(5,*) + write(5,*) ' E I G E N V A L U E O U T P U T' + write(5,*) + write(5,*) 'MODE NO EIGENVALUE FREQUENCY' + write(5,*) ' (RAD/TIME) (CYCLES/TIME + &)' + write(5,*) + do j=1,nx + if(x(j).lt.0.d0) x(j)=0.d0 + x(j)=dsqrt(x(j)) + if(xmin.gt.x(j)) cycle + if(xmax.gt.0.d0) then + if(xmax.lt.x(j)) exit + endif + write(5,'(i7,3(2x,e14.7))') j,x(j)*x(j),x(j), + & x(j)/(2.d0*pi) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writehe.f calculix-ccx-2.3/ccx_2.3/src/writehe.f --- calculix-ccx-2.1/ccx_2.3/src/writehe.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writehe.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,35 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writehe(j) +! +! writes a header for each eigenfrequency in the .dat file +! + implicit none +! + integer j +! + write(5,*) + write(5,100) j+1 + 100 format + & (' E I G E N V A L U E N U M B E R ',i5) + write(5,*) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writeim.f calculix-ccx-2.3/ccx_2.3/src/writeim.f --- calculix-ccx-2.1/ccx_2.3/src/writeim.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writeim.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,33 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writeim() +! +! writes a header for each eigenfrequency in the .dat file +! + implicit none +! + write(5,*) + write(5,100) + 100 format + & (' I M A G I N A R Y P A R T') + write(5,*) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writeinput.f calculix-ccx-2.3/ccx_2.3/src/writeinput.f --- calculix-ccx-2.1/ccx_2.3/src/writeinput.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writeinput.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,65 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writeinput(inpc,ipoinp,inp,nline,ninp,ipoinpc) +! + implicit none +! + integer nentries + parameter(nentries=14) +! + character*1 inpc(*) + character*20 nameref(nentries) +! + integer nline,i,j,ninp,ipoinp(2,nentries),inp(3,ninp),ipoinpc(0:*) +! + data nameref /'RESTART,READ','NODE','ELEMENT','NSET', + & 'ELSET','TRANSFORM','MATERIAL','ORIENTATION', + & 'SURFACE','TIE','SURFACEINTERACTION', + & 'INITIALCONDITIONS','AMPLITUDE','REST'/ +! + open(16,file='input.inpc',status='unknown',err=161) + do i=1,nline + write(16,'(1x,i6,1x,1320a1)') i, + & (inpc(j),j=ipoinpc(i-1)+1,ipoinpc(i)) + enddo + close(16) +! + open(16,file='input.ipoinp',status='unknown',err=162) + do i=1,nentries + write(16,'(1x,a20,1x,i6,1x,i6)') nameref(i),(ipoinp(j,i),j=1,2) + enddo + close(16) +! + open(16,file='input.inp',status='unknown',err=163) + do i=1,ninp + write(16,'(1x,i3,1x,i6,1x,i6,1x,i6)') i,(inp(j,i),j=1,3) + enddo + close(16) +! + return +! + 161 write(*,*) '*ERROR in writeinput: could not open file input.inpc' + stop +! + 162 write(*,*) + & '*ERROR in writeinput: could not open file input.ipoinp' + stop +! + 163 write(*,*) '*ERROR in writeinput: could not open file input.inp' + stop + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/writematrix.f calculix-ccx-2.3/ccx_2.3/src/writematrix.f --- calculix-ccx-2.1/ccx_2.3/src/writematrix.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writematrix.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,42 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writematrix(au,ad,irow,jq,neq,number) +! +! writes an MPC to standard output (for debugging purposes) +! + implicit none +! + integer irow(*),jq(*),neq,i,j,number + real*8 au(*),ad(*) +! + write(*,*) 'matrix number ',number +! + do i=1,neq + write(*,*) 'row ',i,' value ',ad(i) + enddo +! + do i=1,neq + do j=jq(i),jq(i+1)-1 + write(*,*) 'colomn ',i,' row ',irow(j),' value ',au(j) + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writempc.f calculix-ccx-2.3/ccx_2.3/src/writempc.f --- calculix-ccx-2.1/ccx_2.3/src/writempc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writempc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,44 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writempc(ipompc,nodempc,coefmpc,labmpc,mpc) +! +! writes an MPC to standard output (for debugging purposes) +! + implicit none +! + character*20 labmpc(*) + integer ipompc(*),nodempc(3,*),mpc,index,node,idir + real*8 coefmpc(*),coef +! + write(*,*) + write(*,'(''MPC '',i10,1x,a20)') mpc,labmpc(mpc) + index=ipompc(mpc) + do + node=nodempc(1,index) + idir=nodempc(2,index) + coef=coefmpc(index) + write(*,'(i10,1x,i5,1x,e11.4)') node,idir,coef +c write(*,'(i10,1x,i10,1x,i5,1x,e11.4)') index,node,idir,coef + index=nodempc(3,index) + if(index.eq.0) exit + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writepf.f calculix-ccx-2.3/ccx_2.3/src/writepf.f --- calculix-ccx-2.1/ccx_2.3/src/writepf.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writepf.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,44 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writepf(d,bjr,bji,freq,nev) +! +! writes the participation factors to unit 5 +! + implicit none +! + integer j,nev + real*8 d(*),bjr(*),bji(*),freq,pi +! + pi=4.d0*datan(1.d0) +! + write(5,*) + write(5,100) freq + 100 format('P A R T I C I P A T I O N F A C T O R S F O R', + &' F R E Q U E N C Y ',e11.4,' (CYCLES/TIME)') + write(5,*) + write(5,*) 'MODE NO FREQUENCY FACTOR' + write(5,*) ' (CYCLES/TIME) REAL IMAGINARY' + write(5,*) + do j=1,nev + write(5,'(i7,3(2x,e14.7))') j,d(j)/(2.d0*pi),bjr(j),bji(j) + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writere.f calculix-ccx-2.3/ccx_2.3/src/writere.f --- calculix-ccx-2.1/ccx_2.3/src/writere.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writere.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,33 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writere() +! +! writes a header for each eigenfrequency in the .dat file +! + implicit none +! + write(5,*) + write(5,100) + 100 format + & (' R E A L P A R T') + write(5,*) +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writeset.f calculix-ccx-2.3/ccx_2.3/src/writeset.f --- calculix-ccx-2.1/ccx_2.3/src/writeset.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writeset.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,37 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writeset(nset,set,istartset,iendset,ialset) +! +! writes an MPC to standard output (for debugging purposes) +! + implicit none +! + character*81 set(*) + integer nset,istartset(*),iendset(*),ialset(*),i,j +! + do i=1,nset + write(*,'(''SET '',i10,1x,a81)') i,set(i) + do j=istartset(i),iendset(i) + write(*,'(i10)') ialset(j) + enddo + enddo +! + return + end + diff -Nru calculix-ccx-2.1/ccx_2.3/src/writesummary.f calculix-ccx-2.3/ccx_2.3/src/writesummary.f --- calculix-ccx-2.1/ccx_2.3/src/writesummary.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/writesummary.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,46 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2007 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! + subroutine writesummary(istep,j,icutb,l,ttime,time,dtime) + implicit none +! +! writes increment statistics in the .sta file +! the close and open guarantees that the computer buffer is +! emptied each time a new line is written. That way the file +! is always up to data (also during the calculation) +! + integer istep,j,icutb,l +! integer iostat + real*8 ttime,time,dtime +! + write(8,100) istep,j,icutb+1,l,ttime,time,dtime +c call flush(8) + flush(8) +! +! for some unix systems flush has two arguments +! +! call flush(8,iostat) +! if(iostat.lt.0) then +! write(*,*) '*ERROR in writesummary: cannot flush buffer' +! stop +! endif +! + 100 format(1x,i5,1x,i10,2(1x,i5),3(1x,e13.6)) +! + return + end diff -Nru calculix-ccx-2.1/ccx_2.3/src/xlocal.f calculix-ccx-2.3/ccx_2.3/src/xlocal.f --- calculix-ccx-2.1/ccx_2.3/src/xlocal.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/xlocal.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,151 @@ +! +! 3D local of the gauss points within the faces of +! the elements +! +! xlocal8r: C3D8R element +! xlocal8: C3D8 and C3D20R element +! xlocal20: C3D20 element +! xlocal4: C3D4 element +! xlocal10: C3D10 element +! xlocal6: C3D6 element +! xlocal15: C3D15 element +! + data xlocal8r / + & 0.000000000000000D+0, 0.000000000000000D+0,-0.100000000000000D+1 + &, 0.000000000000000D+0, 0.000000000000000D+0, 0.100000000000000D+1 + &, 0.000000000000000D+0,-0.100000000000000D+1, 0.000000000000000D+0 + &, 0.100000000000000D+1, 0.000000000000000D+0, 0.000000000000000D+0 + &, 0.000000000000000D+0, 0.100000000000000D+1, 0.000000000000000D+0 + &,-0.100000000000000D+1, 0.000000000000000D+0,0.000000000000000D+0/ +! + data xlocal8 / + &-0.577350269189626D+0, 0.577350269189626D+0,-0.100000000000000D+1 + &, 0.577350269189626D+0, 0.577350269189626D+0,-0.100000000000000D+1 + &,-0.577350269189626D+0,-0.577350269189626D+0,-0.100000000000000D+1 + &, 0.577350269189626D+0,-0.577350269189626D+0,-0.100000000000000D+1 + &,-0.577350269189626D+0,-0.577350269189626D+0, 0.100000000000000D+1 + &, 0.577350269189626D+0,-0.577350269189626D+0, 0.100000000000000D+1 + &,-0.577350269189626D+0, 0.577350269189626D+0, 0.100000000000000D+1 + &, 0.577350269189626D+0, 0.577350269189626D+0, 0.100000000000000D+1 + &,-0.577350269189626D+0,-0.100000000000000D+1,-0.577350269189626D+0 + &, 0.577350269189626D+0,-0.100000000000000D+1,-0.577350269189626D+0 + &,-0.577350269189626D+0,-0.100000000000000D+1, 0.577350269189626D+0 + &, 0.577350269189626D+0,-0.100000000000000D+1, 0.577350269189626D+0 + &, 0.100000000000000D+1,-0.577350269189626D+0,-0.577350269189626D+0 + &, 0.100000000000000D+1, 0.577350269189626D+0,-0.577350269189626D+0 + &, 0.100000000000000D+1,-0.577350269189626D+0, 0.577350269189626D+0 + &, 0.100000000000000D+1, 0.577350269189626D+0, 0.577350269189626D+0 + &, 0.577350269189626D+0, 0.100000000000000D+1,-0.577350269189626D+0 + &,-0.577350269189626D+0, 0.100000000000000D+1,-0.577350269189626D+0 + &, 0.577350269189626D+0, 0.100000000000000D+1, 0.577350269189626D+0 + &,-0.577350269189626D+0, 0.100000000000000D+1, 0.577350269189626D+0 + &,-0.100000000000000D+1, 0.577350269189626D+0,-0.577350269189626D+0 + &,-0.100000000000000D+1,-0.577350269189626D+0,-0.577350269189626D+0 + &,-0.100000000000000D+1, 0.577350269189626D+0, 0.577350269189626D+0 + &,-0.100000000000000D+1,-0.577350269189626D+0,0.577350269189626D+0/ +! + data xlocal20 / + &-0.774596669241483D+0, 0.774596669241483D+0,-0.100000000000000D+1 + &, 0.000000000000000D+0, 0.774596669241483D+0,-0.100000000000000D+1 + &, 0.774596669241483D+0, 0.774596669241483D+0,-0.100000000000000D+1 + &,-0.774596669241483D+0, 0.000000000000000D+0,-0.100000000000000D+1 + &, 0.000000000000000D+0, 0.000000000000000D+0,-0.100000000000000D+1 + &, 0.774596669241483D+0, 0.000000000000000D+0,-0.100000000000000D+1 + &,-0.774596669241483D+0,-0.774596669241483D+0,-0.100000000000000D+1 + &, 0.000000000000000D+0,-0.774596669241483D+0,-0.100000000000000D+1 + &, 0.774596669241483D+0,-0.774596669241483D+0,-0.100000000000000D+1 + &,-0.774596669241483D+0,-0.774596669241483D+0, 0.100000000000000D+1 + &, 0.000000000000000D+0,-0.774596669241483D+0, 0.100000000000000D+1 + &, 0.774596669241483D+0,-0.774596669241483D+0, 0.100000000000000D+1 + &,-0.774596669241483D+0, 0.000000000000000D+0, 0.100000000000000D+1 + &, 0.000000000000000D+0, 0.000000000000000D+0, 0.100000000000000D+1 + &, 0.774596669241483D+0, 0.000000000000000D+0, 0.100000000000000D+1 + &,-0.774596669241483D+0, 0.774596669241483D+0, 0.100000000000000D+1 + &, 0.000000000000000D+0, 0.774596669241483D+0, 0.100000000000000D+1 + &, 0.774596669241483D+0, 0.774596669241483D+0, 0.100000000000000D+1 + &,-0.774596669241483D+0,-0.100000000000000D+1,-0.774596669241483D+0 + &, 0.000000000000000D+0,-0.100000000000000D+1,-0.774596669241483D+0 + &, 0.774596669241483D+0,-0.100000000000000D+1,-0.774596669241483D+0 + &,-0.774596669241483D+0,-0.100000000000000D+1, 0.000000000000000D+0 + &, 0.000000000000000D+0,-0.100000000000000D+1, 0.000000000000000D+0 + &, 0.774596669241483D+0,-0.100000000000000D+1, 0.000000000000000D+0 + &,-0.774596669241483D+0,-0.100000000000000D+1, 0.774596669241483D+0 + &, 0.000000000000000D+0,-0.100000000000000D+1, 0.774596669241483D+0 + &, 0.774596669241483D+0,-0.100000000000000D+1, 0.774596669241483D+0 + &, 0.100000000000000D+1,-0.774596669241483D+0,-0.774596669241483D+0 + &, 0.100000000000000D+1, 0.000000000000000D+0,-0.774596669241483D+0 + &, 0.100000000000000D+1, 0.774596669241483D+0,-0.774596669241483D+0 + &, 0.100000000000000D+1,-0.774596669241483D+0, 0.000000000000000D+0 + &, 0.100000000000000D+1, 0.000000000000000D+0, 0.000000000000000D+0 + &, 0.100000000000000D+1, 0.774596669241483D+0, 0.000000000000000D+0 + &, 0.100000000000000D+1,-0.774596669241483D+0, 0.774596669241483D+0 + &, 0.100000000000000D+1, 0.000000000000000D+0, 0.774596669241483D+0 + &, 0.100000000000000D+1, 0.774596669241483D+0, 0.774596669241483D+0 + &, 0.774596669241483D+0, 0.100000000000000D+1,-0.774596669241483D+0 + &, 0.000000000000000D+0, 0.100000000000000D+1,-0.774596669241483D+0 + &,-0.774596669241483D+0, 0.100000000000000D+1,-0.774596669241483D+0 + &, 0.774596669241483D+0, 0.100000000000000D+1, 0.000000000000000D+0 + &, 0.000000000000000D+0, 0.100000000000000D+1, 0.000000000000000D+0 + &,-0.774596669241483D+0, 0.100000000000000D+1, 0.000000000000000D+0 + &, 0.774596669241483D+0, 0.100000000000000D+1, 0.774596669241483D+0 + &, 0.000000000000000D+0, 0.100000000000000D+1, 0.774596669241483D+0 + &,-0.774596669241483D+0, 0.100000000000000D+1, 0.774596669241483D+0 + &,-0.100000000000000D+1, 0.774596669241483D+0,-0.774596669241483D+0 + &,-0.100000000000000D+1, 0.000000000000000D+0,-0.774596669241483D+0 + &,-0.100000000000000D+1,-0.774596669241483D+0,-0.774596669241483D+0 + &,-0.100000000000000D+1, 0.774596669241483D+0, 0.000000000000000D+0 + &,-0.100000000000000D+1, 0.000000000000000D+0, 0.000000000000000D+0 + &,-0.100000000000000D+1,-0.774596669241483D+0, 0.000000000000000D+0 + &,-0.100000000000000D+1, 0.774596669241483D+0, 0.774596669241483D+0 + &,-0.100000000000000D+1, 0.000000000000000D+0, 0.774596669241483D+0 + &,-0.100000000000000D+1,-0.774596669241483D+0,0.774596669241483D+0/ +! + data xlocal4 / + & 0.333333333333333D+0, 0.333333333333333D+0, 0.000000000000000D+0 + &, 0.333333333333333D+0, 0.000000000000000D+0, 0.333333333333333D+0 + &, 0.333333333333334D+0, 0.333333333333333D+0, 0.333333333333333D+0 + &, 0.000000000000000D+0, 0.333333333333333D+0,0.333333333333333D+0/ +! + data xlocal10 / + & 0.166666666666667D+0, 0.166666666666667D+0, 0.000000000000000D+0 + &, 0.166666666666667D+0, 0.666666666666667D+0, 0.000000000000000D+0 + &, 0.666666666666667D+0, 0.166666666666667D+0, 0.000000000000000D+0 + &, 0.166666666666667D+0, 0.000000000000000D+0, 0.166666666666667D+0 + &, 0.666666666666667D+0, 0.000000000000000D+0, 0.166666666666667D+0 + &, 0.166666666666667D+0, 0.000000000000000D+0, 0.666666666666667D+0 + &, 0.666666666666666D+0, 0.166666666666667D+0, 0.166666666666667D+0 + &, 0.166666666666666D+0, 0.666666666666667D+0, 0.166666666666667D+0 + &, 0.166666666666666D+0, 0.166666666666667D+0, 0.666666666666667D+0 + &, 0.000000000000000D+0, 0.166666666666667D+0, 0.166666666666667D+0 + &, 0.000000000000000D+0, 0.166666666666667D+0, 0.666666666666667D+0 + &, 0.000000000000000D+0, 0.666666666666667D+0,0.166666666666667D+0/ +! + data xlocal6 / + & 0.333333333333333D+0, 0.333333333333333D+0,-0.100000000000000D+1 + &, 0.333333333333333D+0, 0.333333333333333D+0, 0.100000000000000D+1 + &, 0.500000000000000D+0, 0.000000000000000D+0, 0.000000000000000D+0 + &, 0.500000000000000D+0, 0.500000000000000D+0, 0.000000000000000D+0 + &, 0.000000000000000D+0, 0.500000000000000D+0,0.000000000000000D+0/ +! + data xlocal15 / + & 0.166666666666667D+0, 0.166666666666667D+0,-0.100000000000000D+1 + &, 0.166666666666667D+0, 0.666666666666667D+0,-0.100000000000000D+1 + &, 0.666666666666667D+0, 0.166666666666667D+0,-0.100000000000000D+1 + &, 0.,0.,0. + &, 0.166666666666667D+0, 0.166666666666667D+0, 0.100000000000000D+1 + &, 0.666666666666667D+0, 0.166666666666667D+0, 0.100000000000000D+1 + &, 0.166666666666667D+0, 0.666666666666667D+0, 0.100000000000000D+1 + &, 0.,0.,0. + &, 0.211324865405187D+0, 0.000000000000000D+0,-0.577350269189626D+0 + &, 0.788675134594813D+0, 0.000000000000000D+0,-0.577350269189626D+0 + &, 0.211324865405187D+0, 0.000000000000000D+0, 0.577350269189626D+0 + &, 0.788675134594813D+0, 0.000000000000000D+0, 0.577350269189626D+0 + &, 0.788675134594813D+0, 0.211324865405187D+0,-0.577350269189626D+0 + &, 0.211324865405187D+0, 0.788675134594813D+0,-0.577350269189626D+0 + &, 0.788675134594813D+0, 0.211324865405187D+0, 0.577350269189626D+0 + &, 0.211324865405187D+0, 0.788675134594813D+0, 0.577350269189626D+0 + &, 0.000000000000000D+0, 0.211324865405187D+0, 0.577350269189626D+0 + &, 0.000000000000000D+0, 0.788675134594813D+0, 0.577350269189626D+0 + &, 0.000000000000000D+0, 0.211324865405187D+0,-0.577350269189626D+0 + &, 0.000000000000000D+0,0.788675134594813D+0,-0.577350269189626D+0/ +! diff -Nru calculix-ccx-2.1/ccx_2.3/src/zeta_calc.f calculix-ccx-2.3/ccx_2.3/src/zeta_calc.f --- calculix-ccx-2.1/ccx_2.3/src/zeta_calc.f 1970-01-01 00:00:00.000000000 +0000 +++ calculix-ccx-2.3/ccx_2.3/src/zeta_calc.f 2011-03-26 17:19:21.000000000 +0000 @@ -0,0 +1,1379 @@ +! +! CalculiX - A 3-dimensional finite element program +! Copyright (C) 1998-2005 Guido Dhondt +! +! This program is free software; you can redistribute it and/or +! modify it under the terms of the GNU General Public License as +! published by the Free Software Foundation(version 2); +! +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +! This subroutine enable to compuite the different zeta exponents for +! the different partial total head loss restrictors. The values of the +! 'zetas' have been found in the following published works +! +! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' +! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. +! ISBN 0-899116-284-4 +! +! D.S. MILLER 'INTERNAL FLOW SYSTEMS' +! 1978,vol.5 B.H.R.A FLUID ENGINEERING +! ISBN 0-900983-78-7 +! + subroutine zeta_calc(nelem,prop,ielprop,lakon,reynolds,zeta, + & isothermal,kon,ipkon,R,kappa,v,mi) +! + implicit none +! + logical isothermal +! + character*8 lakon(*) +! + integer ielprop(*),nelem,iexp(2),i,j,ier,write1,iexp3(2), + & write2,nelem_ref,ipkon(*),kon(*),nelem0,nelem1,nelem2,node10, + & node20,nodem0,node11,node21,nodem1,node12,node22,nodem2, + & iexpbr1(2) /11,11/,icase,node0,node1,node2,mi(2) +! + real*8 zeta,prop(*),lzd,reynolds,ereo,fa2za1,zetap,zeta0, + & lambda,thau,a1,a2,dh,l,a2za1,ldumm,dhdumm,ks, + & form_fact,zeta01,zeta02,alpha,rad,delta,a0,b0,azb,rzdh, + & A,C,rei,lam,ai,b1,c1,b2,c2,zeta1,re_val,k,ldre, + & zetah,cd,cdu,km,Tt0,Ts0,Tt1,Ts1,Tt2,Ts2, + & rho0,rho1,rho2,V0,V1,v2,a0a1,a0a2,zetlin,lam10,lam20,pi, + & alpha1,alpha2,R,kappa,ang1s,ang2s,cang1s,cang2s, + & v(0:mi(2),*),V1V0,V2V0,z1_60,z1_90, + & z2_60,z2_90,afakt,V2V0L,kb,ks2,a2a0,Z90LIM11,Z90LIM51, + & lam11,lam12,lam21,lam22,W2W0,W1W0,dh0,dh2,hq,z2d390, + & z1p090,z90,z60,pt0,pt2,pt1,M0,M1,M2,W0W1,W0W2, + & xflow0,xflow1,xflow2,Qred_0, Qred_1, Qred_2,Qred_crit +! +! THICK EDGED ORIFICE IN STRAIGHT CONDUIT (L/DH > 0.015) +! I.E. IDEL' CHIK (SECTION III PAGE 140) +! +! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' +! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. +! ISBN 0-899116-284-4 +! +! ***** long orifice ***** +! +! DIAGRAMS 4-19 p 175 - Reynolds R:epsilon^-_oRe +! + real*8 XRE (14), YERE (14) + data XRE / 25.,40.,60.0,100.,200.,400.,1000.,2000.,4000., + & 10000.,20000.,100000.,200000.,1000000./ + data YERE/ 0.34,0.36,0.37,0.40,0.42,0.46,0.53,0.59, + & 0.64,0.74,0.81,0.94,0.95,0.98/ +! +! Diagram 4-19 p 175 - Reynolds | A1/A2 R: zeta_phi +! + real*8 zzeta (15,11) + data ((zzeta(i,j),i=1,15),j=1,11) + & /15.011 ,25.0,40.0,60.0,100.0,200.0,400.0,1000.0,2000.0, + & 4000.0,10000.0,20000.0,100000.0,200000.0,1000000.0, + & 0.00 ,1.94,1.38,1.14,0.89,0.69,0.64,0.39,0.30,0.22,0.15, + & 0.11,0.04,0.01,0.00, + & 0.20 ,1.78,1.36,1.05,0.85,0.67,0.57,0.36,0.26,0.20,0.13, + & 0.09,0.03,0.01,0.00, + & 0.30 ,1.57,1.16,0.88,0.75,0.57,0.43,0.30,0.22,0.17,0.10, + & 0.07,0.02,0.01,0.00, + & 0.40 ,1.35,0.99,0.79,0.57,0.40,0.28,0.19,0.14,0.10,0.06, + & 0.04,0.02,0.01,0.00, + & 0.50 ,1.10,0.75,0.55,0.34,0.19,0.12,0.07,0.05,0.03,0.02, + & 0.01,0.01,0.01,0.00, + & 0.60 ,0.85,0.56,0.30,0.19,0.10,0.06,0.03,0.02,0.01,0.01, + & 0.00,0.00,0.00,0.00, + & 0.70 ,0.58,0.37,0.23,0.11,0.06,0.03,0.02,0.01,0.00,0.00, + & 0.00,0.00,0.00,0.00, + & 0.80 ,0.40,0.24,0.13,0.06,0.03,0.02,0.01,0.00,0.00,0.00, + & 0.00,0.00,0.00,0.00, + & 0.90 ,0.20,0.13,0.08,0.03,0.01,0.00,0.00,0.00,0.00,0.00, + & 0.00,0.00,0.00,0.00, + & 0.95 ,0.03,0.03,0.02,0.00,0.00,0.00,0.00,0.00,0.00,0.00, + & 0.00,0.00,0.00,0.00/ +! +! Diagram 4-12 p 169 - l/Dh R: tau +! + real*8 XLZD (10), YTOR (10) + data XLZD / 0.0,0.2,0.4,0.6,0.8,1.0,1.2,1.6,2.0,2.4/ + data YTOR / 1.35,1.22,1.10,0.84,0.42,0.24,0.16,0.07,0.02,0.0/ + data IEXP / 10, 1/ +! +! ***** wall orifice ***** +! +! THICK-WALLED ORIFICE IN LARGE WALL (L/DH > 0.015) +! I.E. IDL'CHIK (page 174) +! +! DIAGRAM 4-18 A - l/Dh R: zeta_o +! + real*8 XLQD(12) + DATA XLQD / + & 0.,0.2,0.4,0.6,0.8,1.0,1.2,1.4,1.6,1.8,2.0,10.0/ + real*8 YZETA1(12) + DATA YZETA1 / + & 2.85,2.72,2.6,2.34,1.95,1.76,1.67,1.62,1.6,1.58,1.55,1.55/ +! +! DIAGRAM 4-19 p175 first line - Re (A1/A2=0) R: zeta_phi +! + real*8 XRE2(14) + DATA XRE2 / + & 25.,40.,60.,100.,200.,400.,1000.,2000.,4000.,10000., + & 20000.,50000.,100000.,1000000./ + real*8 YZETA2(14) + DATA YZETA2 / + & 1.94,1.38,1.14,.89,.69,.54,.39,.3,.22,.15,.11,.04,.01,0./ +! +! Diagram 4-18 p174 first case * (=multiplication) epsilon^-_oRe p 175 +! + real*8 YERE2(14) + DATA YERE2 / + & 1.,1.05,1.09,1.15,1.23,1.37,1.56,1.71,1.88,2.17,2.38,2.56, + & 2.72,2.85/ +! +! ***** expansion ***** +! +! SUDDEN EXPANSION OF A STREAM WITH UNIFORM VELOCITY DISTRIBUTION +! I.E. IDL'CHIK (page 160) +! +! DIAGRAM 4-1 - Re | A1/A2 R:zeta +! + real*8 ZZETA3(14,8) + DATA ZZETA3 / + & 14.008, 10.000,15.0,20.0,30.0,40.0,50.0,100.0,200.0,500.0, + & 1000.0,2000.0,3000.0,3500.0, + & .01 ,3.10,3.20,3.00,2.40,2.15,1.95,1.70,1.65,1.70,2.00, + & 1.60,1.00,1.00, + & 0.1 ,3.10,3.20,3.00,2.40,2.15,1.95,1.70,1.65,1.70,2.00, + & 1.60,1.00,0.81, + & 0.2 ,3.10,3.20,2.80,2.20,1.85,1.65,1.40,1.30,1.30,1.60, + & 1.25,0.70,0.64, + & 0.3 ,3.10,3.10,2.60,2.00,1.60,1.40,1.20,1.10,1.10,1.30, + & 0.95,0.60,0.50, + & 0.4 ,3.10,3.00,2.40,1.80,1.50,1.30,1.10,1.00,0.85,1.05, + & 0.80,0.40,0.36, + & 0.5 ,3.10,2.80,2.30,1.65,1.35,1.15,0.90,0.75,0.65,0.90, + & 0.65,0.30,0.25, + & 0.6 ,3.10,2.70,2.15,1.55,1.25,1.05,0.80,0.60,0.40,0.60, + & 0.50,0.20,0.16/ +! + DATA IEXP3 /0,0/ +! +! ***** contraction ***** +! +! SUDDEN CONTRACTION WITH & WITHOUT CONICAL BELLMOUTH ENTRY +! I.E. IDL'CHIK p 168 +! +! DIAGRAM 4-10 - Re | A1/A2 R: zeta +! + real*8 ZZETA41(14,7) + DATA ZZETA41 / + & 14.007 ,10.0,20.0,30.0,40.0,50.0,100.0,200.0,500.0,1000.0, + & 2000.0,4000.0,5000.0,10000.0, + &0.1 ,5.00,3.20,2.40,2.00,1.80,1.30,1.04,0.82,0.64,0.50, + & 0.80,0.75,0.50, + &0.2 ,5.00,3.10,2.30,1.84,1.62,1.20,0.95,0.70,0.50,0.40, + & 0.60,0.60,0.40, + &0.3 ,5.00,2.95,2.15,1.70,1.50,1.10,0.85,0.60,0.44,0.30, + & 0.55,0.55,0.35, + &0.4 ,5.00,2.80,2.00,1.60,1.40,1.00,0.78,0.50,0.35,0.25, + & 0.45,0.50,0.30, + &0.5 ,5.00,2.70,1.80,1.46,1.30,0.90,0.65,0.42,0.30,0.20, + & 0.40,0.42,0.25, + &0.6 ,5.00,2.60,1.70,1.35,1.20,0.80,0.56,0.35,0.24,0.15, + & 0.35,0.35,0.20/ +! +! Diagram 3-7 p128 - alpha | l/Dh R: zeta +! + real*8 ZZETA42(10,7) + DATA ZZETA42 / + & 10.007 ,0.,10.0,20.0,30.0,40.0,60.0,100.0,140.0,180.0, + & 0.025 ,0.50,0.47,0.45,0.43,0.41,0.40,0.42,0.45,0.50, + & 0.050 ,0.50,0.45,0.41,0.36,0.33,0.30,0.35,0.42,0.50, + & 0.075 ,0.50,0.42,0.35,0.30,0.26,0.23,0.30,0.40,0.50, + & 0.100 ,0.50,0.39,0.32,0.25,0.22,0.18,0.27,0.38,0.50, + & 0.150 ,0.50,0.37,0.27,0.20,0.16,0.15,0.25,0.37,0.50, + & 0.600 ,0.50,0.27,0.18,0.13,0.11,0.12,0.23,0.36,0.50/ +! +! ***** bends ***** +! +! SHARP ELBOW (R/DH = 0) AT 0 < DELTA < 180 +! I.E. IDL'CHIK page 294 +! DIAGRAM 6-5 - a0/b0 R: C1 +! + real*8 XAQB(12) + DATA XAQB / + & 0 .25,0.50,0.75,1.00,1.50,2.00,3.00,4.00,5.00,6.00,7.00,8.00/ +! + real*8 YC(12) + DATA YC / + & 1.10,1.07,1.04,1.00,0.95,0.90,0.83,0.78,0.75,0.72,0.71,0.70/ +! +! DIAGRAM 6-5 - delta R: A +! + real*8 XDELTA(10) + DATA XDELTA / + & 20.0,30.0,45.0,60.0,75.0,90.0,110.,130.,150.,180./ +! + real*8 YA(10) + DATA YA / + & 2.50,2.22,1.87,1.50,1.28,1.20,1.20,1.20,1.20,1.20/ +! +! SHARP BENDS 0.5 < R/DH < 1.5 AND 0 < DELTA < 180 +! I.E. IDL'CHIK page 289-290 +! DIAGRAM 6-1 (- delta from diagram 6-5) R: A1 +! + real*8 YA1(10) + DATA YA1 / + & 0.31,0.45,0.60,0.78,0.90,1.00,1.13,1.20,1.28,1.40/ +! +! DIAGRAM 6-1 - R0/D0 R: B1 +! + real*8 XRQDH(8) + DATA XRQDH / + & 0.50,0.60,0.70,0.80,0.90,1.00,1.25,1.50/ +! + real*8 YB1(8) + DATA YB1 / + & 1.18,0.77,0.51,0.37,0.28,0.21,0.19,0.17/ +! +! DIAGRAM 6-1 (- a0/b0 from diagram 6-5) R: C1 +! + real*8 YC1(12) + DATA YC1 / + & 1.30,1.17,1.09,1.00,0.90,0.85,0.85,0.90,095,0.98,1.00,1.00/ +! +! SMOOTH BENDS (R/DH > 1.5) AT 0 < DELTA < 180 +! I.E. IDL'CHIK +! +! DIAGRAM 6-1 - R0/D0 R: B1 (continuation of XRQDH) +! + real*8 XRZDH(14) + DATA XRZDH/ + & 1.00,2.00,4.00,6.00,8.00,10.0,15.0,20.0,25.0,30.0,35.0,40.0, + & 45.0,50.0/ +! + real*8 YB2(14) + DATA YB2 / + & 0.21,0.15,0.11,0.09,0.07,0.07,0.06,0.05,0.05,0.04,0.04,0.03, + & 0.03,0.03/ +! +! (- a0/b0 from Diagram 6-5) R: C2 +! + real*8 YC2(12) + DATA YC2 / + & 1.80,1.45,1.20,1.00,0.68,0.45,0.40,0.43,0.48,0.55,0.58,0.60/ +! +! D.S. MILLER 'INTERNAL FLOW SYSTEMS' +! 1978,vol.5 B.H.R.A FLUID ENGINEERING SERIES +! ISBN 0-900983-78-7 +! +! SMOOTH BENDS B.H.R.A HANDBOOK P.141 +! + REAL*8 ZZETAO(14,15) + DATA((ZZETAO(I,J),I=1,14),J=1,8) / + & 14.015,0.5,0.6,0.8,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10., + & 10.00, 0.030,0.025,0.021,0.016,0.022,0.030,0.034,0.036,0.040, + & 0.042,0.043,0.044,0.044, + & 15.00, 0.036,0.035,0.025,0.025,0.033,0.042,0.045,0.050,0.055, + & 0.055,0.058,0.060,0.063, + & 20.00, 0.056,0.046,0.034,0.034,0.045,0.054,0.056,0.062,0.066, + & 0.067,0.072,0.075,0.080, + & 30.00, 0.122,0.094,0.063,0.056,0.063,0.071,0.075,0.082,0.087, + & 0.089,0.097,0.101,0.110, + & 40.00, 0.220,0.160,0.100,0.085,0.080,0.086,0.092,0.100,0.106, + & 0.122,0.121,0.126,0.136, + & 50.00, 0.340,0.245,0.148,0.117,0.097,0.100,0.108,0.116,0.123, + & 0.133,0.144,0.150,0.159, + & 60.00, 0.480,0.350,0.196,0.150,0.115,0.116,0.122,0.131,0.140, + & 0.153,0.164,0.171,0.181/ + DATA((ZZETAO(I,J),I=1,14),J=9,15) / + & 70.00, 0.645,0.466,0.243,0.186,0.132,0.130,0.136,0.148,0.160, + & 0.172,0.185,0.191,0.200, + & 80.00, 0.827,0.600,0.288,0.220,0.147,0.142,0.150,0.166,0.180, + & 0.191,0.203,0.209,0.218, + & 90.00, 1.000,0.755,0.333,0.247,0.159,0.155,0.166,0.185,0.197, + & 0.209,0.220,0.227,0.236, + & 100.0, 1.125,0.863,0.375,0.264,0.167,0.166,0.183,0.202,0.214, + & 0.225,0.238,0.245,0.255, + & 120.0, 1.260,0.983,0.450,0.281,0.180,0.188,0.215,0.234,0.247, + & 0.260,0.273,0.282,0.291, + & 150.0, 1.335,1.060,0.536,0.289,0.189,0.214,0.251,0.272,0.297, + & 0.312,0.325,0.336,0.346, + & 180.0, 1.350,1.100,0.600,0.290,0.190,0.225,0.280,0.305,0.347, + & 0.364,0.378,0.390,0.400/ +! + REAL*8 KRE(22,4) + DATA KRE / + & 22.004,1.E+3,2.E+3,3.E+3,4.E+3,5.E+3,6.E+3,7.E+3,8.E+3,9.E+3, + & 1.E+4,2.E+4,3.E+4,4.E+4,6.E+4,8.E+4,1.E+5,2.E+5,3.E+5, + & 5.E+5,7.E+5,1.E+6, + & 1.0, 3.88,3.06,2.77,2.60,2.49,2.40,2.33,2.27,2.22,2.18, + & 1.86,1.69,1.57,1.41,1.30,1.22,5*1.00, + & 1.5, 3.88,3.06,2.77,2.60,2.49,2.40,2.33,2.27,2.22,2.18, + & 1.90,1.76,1.67,1.54,1.46,1.40,1.22,1.12,3*1.00, + & 2.0, 3.88,3.06,2.77,2.60,2.49,2.40,2.33,2.27,2.22,2.18, + & 1.93,1.80,1.71,1.60,1.53,1.47,1.32,1.23,1.13,1.06,1.00/ +! + integer iexp6(2) + DATA iexp6 /0,0/ +! +! Campbell, Slattery +! "Flow in the entrance of a tube" +! Journal of Basic Engineering, 1963 +! +! EXIT LOSS COEFFICIENT FOR LAMINAR FLOWS DEPENDING ON THE +! ACTUAL VELOCITY DISTRIBUTION AT THE EXIT +! + real*8 XDRE(12) + DATA XDRE / + & 0.000,0.001,0.0035,0.0065,0.010,0.0150,0.020, + & 0.025,0.035,0.045,0.056,0.065/ +! + real*8 ZETAEX(12) + DATA ZETAEX / + & 1.00,1.200,1.40,1.54,1.63,1.73,1.80,1.85,1.93, + & 1.97,2.00,2.00/ +! +! Branch Joint Genium +! Branching Flow Part IV - TEES +! Fluid Flow Division +! Section 404.2 page 4 December 1986 +! Genium Publishing (see www.genium.com) +! +! n.b: the values of this table have been scaled by a factor 64. +! + real*8 XANG(11),YANG(11) + data (XANG(i),YANG(i),i=1,11) + & /0.0d0,62.d0, + & 15.d0,62.d0, + & 30.d0,61.d0, + & 45.d0,61.d0, + & 60.d0,58.d0, + & 75.d0,52.d0, + & 90.d0,40.d0, + & 105.d0,36.d0, + & 120.d0,34.d0, + & 135.d0,33.d0, + & 150.d0,32.5d0/ +! +! Branch Joint Idelchik 1 +! Diagrams of resistance coefficients +! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' +! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. +! ISBN 0-899116-284-4 +! + real*8 TA2A0(12),TAFAKT(12) + data (TA2A0(i),TAFAKT(i),i=1,12) + & /0.d0 ,1.d0 , + & 0.16d0 ,1.d0 , + & 0.20d0 ,0.99d0, + & 0.25d0 ,0.95d0, + & 0.29d0 ,0.90d0, + & 0.31d0 ,0.85d0, + & 0.33d0 ,0.80d0, + & 0.35d0 ,0.78d0, + & 0.4d0 ,0.75d0, + & 0.6d0 ,0.70d0, + & 0.8d0 ,0.65d0, + & 1.d0 ,0.60d0/ +! +! Branch Joint Idelchik 2 +! Diagrams of resistance coefficients p348-351 section VII +! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' +! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. +! ISBN 0-899116-284-4 +! +! page 352 diagram 7-9 - alpha | Fs/Fc +! + real*8 KBTAB(6,7),KSTAB(6,6) + data ((KBTAB(i,j),j=1,7),i=1,6) + & /6.007d0 ,0.d0,15.d0,30.d0,45.d0,60.d0 ,90.d0 , + & 0.d0 ,0.d0, 0.d0, 0.d0, 0.d0, 0.d0 , 0.d0 , + & 0.1d0 ,0.d0, 0.d0, 0.d0, 0.d0, 0.d0 , 0.d0 , + & 0.2d0 ,0.d0, 0.d0, 0.d0, 0.d0, 0.d0 , 0.1d0 , + & 0.33d0,0.d0, 0.d0, 0.d0, 0.d0, 0.d0 , 0.2d0 , + & 0.5d0 ,0.d0, 0.d0, 0.d0, 0.d0, 0.1d0 , 0.25d0/ +! +! page 348-351 diagrams 7-5 to 7-8 - alpha | Fs/Fc +! + data ((KSTAB(i,j),j=1,6),i=1,6) + & /6.006d0 ,0.d0,15.d0 ,30.d0 ,45.d0 , 60.d0 , + & 0.d0 ,0.d0, 0.d0 , 0.d0 , 0.d0 , 0.d0 , + & 0.1d0 ,0.d0, 0.d0 , 0.d0 , 0.05d0, 0.d0 , + & 0.2d0 ,0.d0, 0.d0 , 0.d0 , 0.14d0, 0.d0 , + & 0.33d0,0.d0, 0.14d0, 0.17d0, 0.14d0, 0.1d0 , + & 0.5d0 ,0.d0, 0.4d0 , 0.4d0 , 0.3d0 , 0.25d0/ +! +! page 352 diagram 7-9 R: zeta_c,st +! + real*8 Z90TAB(6,13) + data ((Z90TAB(i,j),j=1,13),i=1,6)/ + &6.013,0. ,0.03,0.05,0.1 ,0.2 ,0.3 ,0.4 ,0.5 ,0.6 ,0.7 ,0.8 ,1.0 , + & .06, .02, .05, .08, .08, .07, .01,-.15,1.E9,1.E9,1.E9,1.E9,1.E9, + & .10, .04, .08, .10, .20, .26, .20, .05,-.13,1.E9,1.E9,1.E9,1.E9, + & .20, .08, .12, .18, .25, .34, .32, .26, .16, .02,-.14,1.E9,1.E9, + & .33, .45, .50, .52, .59, .66, .64, .62, .58, .44, .27, .08,-.34, + & .50,1.00,1.04,1.06,1.16,1.25,1.25,1.22,1.10, .88, .70, .45,0. / +! +! table to check the location of V2V0 in Z90TAB +! + real*8 Z90LIMX (5),Z90LIMY(5) + data Z90LIMX + & /0.06d0,0.1d0,0.2d0,0.33,0.5d0 / +! + data Z90LIMY + & / 0.1d0,0.1d0,0.3d0,0.5d0,0.7d0/ +! + pi=4.d0*datan(1.d0) +! + if ((lakon(nelem)(2:5).eq.'REUS').or. + & (lakon(nelem)(2:5).eq.'LPUS')) then +! +! user defined zeta +! + zeta=prop(ielprop(nelem)+4) +! + return +! + elseif((lakon(nelem)(2:5).eq.'REEN').or. + & (lakon(nelem)(2:5).eq.'LPEN')) then +! +! entrance +! + zeta=prop(ielprop(nelem)+4) +! + return +! + elseif((lakon(nelem)(2:7).eq.'RELOID').or. + & (lakon(nelem)(2:7).eq.'LPLOID')) then +! +! THICK EDGED ORIFICE IN STRAIGHT CONDUIT (L/DH > 0.015) +! I.E. IDEL'CHIK p175 +! +! Input parameters +! +! Inlet/outlet sections + a1=prop(ielprop(nelem)+1) + a2=prop(ielprop(nelem)+2) +! Hydraulic diameter + dh=prop(ielprop(nelem)+3) + if((dh.eq.0).and.(A1.le.A2)) then + dh=dsqrt(4d0*A1/Pi) + elseif((dh.eq.0).and.(A1.gt.A2)) then + dh=dsqrt(4d0*A2/Pi) + endif +! Length + l=prop(ielprop(nelem)+4) +! + lzd=l/dh + a2za1=min (a1/a2, 1.) +! + fa2za1=1.d0-a2za1 +! + write1= 0 + if ( lzd .gt. 2.4 ) write1= 1 +! + ldumm=1.D0 + dhdumm=-1.D0 + ks=0.d0 + form_fact=1.d0 +! + call friction_coefficient(ldumm,dhdumm,ks,reynolds, + & form_fact,lambda) +! + call onedint(XLZD,YTOR,10,lzd,thau,1,1,0,ier) + zeta0 = ((0.5+thau*dsqrt(fa2za1))+fa2za1) * fa2za1 +! + if(reynolds .gt. 1.E+05 ) then + zeta=zeta0 + lambda * dabs(lzd) + else + call onedint(XRE,YERE,14,reynolds,ereo,1,1,0,ier) +! + call twodint(zzeta,15,11,reynolds, + & a2za1,zetap,1,IEXP,IER) + zeta = zetap + ereo * zeta0 + lambda * dabs(lzd) + IF ( a2za1 .gt. 0.95 ) WRITE1=1 + endif +! + if(dabs(lzd) .le. 0.015 )then + write(*,*) '*WARNING in zeta_calc: L/DH outside valid' + write(*,*) ' range ie less than 0.015 !' + endif +! + if( write1 .eq. 1 ) then + write(*,*) + & 'WARNING in zeta_calc: geometry data outside valid range' + write(*,*) + & ' l/dh greater than 2.4- extrapolated value(s) !' + endif +! + elseif((lakon(nelem)(2:7).eq.'REWAOR').or. + & (lakon(nelem)(2:7).eq.'LPWAOR'))then +! +! THICK-WALLED ORIFICE IN LARGE WALL (L/DH > 0.015) +! I.E. IDL'CHIK page 174 +! +! Input parameters +! +! Inlet/outlet sections + a1=prop(ielprop(nelem)+1) + a2=prop(ielprop(nelem)+2) +! Hydraulic diameter + dh=prop(ielprop(nelem)+3) + if((dh.eq.0).and.(A1.le.A2)) then + dh=dsqrt(4d0*A1/Pi) + elseif((dh.eq.0).and.(A1.gt.A2)) then + dh=dsqrt(4d0*A2/Pi) + endif +! Length + l=prop(ielprop(nelem)+4) +! + lzd=l/dh + ldumm=1.D0 + dhdumm=-1.D0 + ks=0.d0 + form_fact=1.d0 +! + call friction_coefficient(ldumm,dhdumm,ks,reynolds, + & form_fact,lambda) + call onedint (XLQD,YZETA1,12,lzd,zeta01,1,1,0,IER) +! + write1=0 + if (lzd.gt.10.) write1=1 +! + if(reynolds.le.1.E+05) then +! + call onedint (XRE2,YZETA2,14,reynolds,zeta02,1,1,10,IER) + call onedint (XRE2,YERE2,14,reynolds,EREO,1,1,0,IER) +! + zeta=zeta02+0.342*ereo*zeta01+lambda*lzd +! + elseif(reynolds.gt.1.E+05) then + zeta=zeta01+lambda*lzd + endif + if(lzd.le.0.015) then + write(*,*) '*WARNING in zeta_calc' + write(*,*) + & ' l/dh outside valid range i.e. less than 0.015 !' + endif + if(write1.eq.1) then + write(*,*) '*WARNING in zeta_calc :extrapolated value(s)!' + endif +! + return +! + elseif((lakon(nelem)(2:7).eq.'REEL').or. + & (lakon(nelem)(2:7).eq.'LPEL')) then +! +! SUDDEN EXPANSION OF A STREAM WITH UNIFORM VELOCITY DISTRIBUTION +! I.E. IDL'CHIK page 160 +! +! Input parameters +! +! Inlet/outlet sections + a1=prop(ielprop(nelem)+1) + a2=prop(ielprop(nelem)+2) +c! Hydraulic diameter +c dh=prop(ielprop(nelem)+3) +c if((dh.eq.0).and.(A1.le.A2)) then +c dh=dsqrt(4d0*A1/Pi) +c elseif((dh.eq.0).and.(A1.gt.A2)) then +c dh=dsqrt(4d0*A2/Pi) +c endif +! + a2za1=a1/a2 + write1=0 +! + if (reynolds.LE.10.) then + zeta=26.0/reynolds + elseif (reynolds.gt.10.and.reynolds.le.3.5E+03) then + call twodint(zzeta3,14,11,reynolds,a2za1,zeta,1,IEXP3,IER) + if (a2za1.lt.0.01.or.a2za1.gt.0.6) write1=1 + else + zeta=(1.-a2za1)**2 + endif +! + if(write1 .eq. 1) then + write(*,*) '*WARNING in zeta_calc: extrapolated value(s)!' + endif + return +! + elseif((lakon(nelem)(2:7).eq.'RECO').or. + & (lakon(nelem)(2:7).eq.'LPCO'))then +! +! SUDDEN CONTRACTION WITH & WITHOUT CONICAL BELLMOUTH ENTRY +! I.E. IDL'CHIK p 168 +! +! Input parameters +! +! Inlet/outlet sections + a1=prop(ielprop(nelem)+1) + a2=prop(ielprop(nelem)+2) +! Hydraulic diameter + dh=prop(ielprop(nelem)+3) + if((dh.eq.0).and.(A1.le.A2)) then + dh=dsqrt(4d0*A1/Pi) + elseif((dh.eq.0).and.(A1.gt.A2)) then + dh=dsqrt(4d0*A2/Pi) + endif +! Length + l=prop(ielprop(nelem)+4) +! Angle + alpha=prop(ielprop(nelem)+5) +! + a2za1=a2/a1 + write1=0 + l=abs(l) + lzd=l/dh +! + if (l.eq.0.) then + if (reynolds.le.10.) then + zeta=27.0/reynolds + elseif(reynolds.gt.10.and.reynolds.le.1.E+04) then + call twodint(ZZETA41,14,11,reynolds,a2za1,zeta,1,IEXP,IER) + if (a2za1.le.0.1.or.a2za1.gt.0.6) write1=1 + elseif (reynolds.gt.1.E+04) then + zeta=0.5*(1.-a2za1) + endif + elseif(l.gt.0.) then + call twodint(ZZETA42,10,0,alpha,lzd,zeta0,1,IEXP,IER) + zeta=zeta0*(1.-a2za1) + if (lzd .lt. 0.025 .or. lzd .gt. 0.6) write1=1 + if (reynolds .le. 1.E+04) then + write(*,*) '*WARNING in zeta_calc: reynolds outside valid + & range i.e. < 10 000 !' + endif + endif +! + if ( write1 .eq. 1 ) then + WRITE(*,*) '*WARNING in zeta_calc: extrapolierte Werte!' + endif +! + return +! + elseif((lakon(nelem)(2:7).eq.'REBEID').or. + & (lakon(nelem)(2:7).eq.'LPBEID')) then +! +! +! SHARP ELBOW (R/DH = 0) AT 0 < DELTA < 180 +! I.E. IDL'CHIK page 294 +! +! SHARP BENDS 0.5 < R/DH < 1.5 AND 0 < DELTA < 180 +! I.E. IDL'CHIK page 289-290 +! +! SMOOTH BENDS (R/DH > 1.5) AT 0 < DELTA < 180 +! I.E. IDL'CHIK page 289-290 +! +! Input parameters +! +! Inlet/outlet sections + a1=prop(ielprop(nelem)+1) + a2=prop(ielprop(nelem)+2) +! Hydraulic diameter + dh=prop(ielprop(nelem)+3) + if((dh.eq.0).and.(A1.le.A2)) then + dh=dsqrt(4d0*A1/Pi) + elseif((dh.eq.0).and.(A1.gt.A2)) then + dh=dsqrt(4d0*A2/Pi) + endif +! radius + rad=prop(ielprop(nelem)+4) +! angle + delta=prop(ielprop(nelem)+5) +! heigth/width (square section) + a0=prop(ielprop(nelem)+6) + b0=prop(ielprop(nelem)+7) +! + write1=0 + write2=0 + rzdh=rad/dh + if(a0.eq.0.) azb=1.0 + if(a0.gt.0.) azb=a0/b0 +! + if (rzdh.le.0.5) then + call onedint(XAQB,YC,12,azb,C,1,1,0,IER) + zeta1=0.95*(SIN(delta*0.0087))**2+2.05*(SIN(delta*0.0087))**4 + call onedint(XDELTA,YA,10,delta,A,1,1,10,IER) + zeta=c*a*zeta1 + if (azb.le.0.25.or.azb.gt.8.0) write2=1 + if (reynolds.lt.4.E+04) then + if (reynolds.le.3.E+03) write1=1 + REI=MAX(2999.,reynolds) + ldumm=1.D0 + dhdumm=-1.D0 + ks=0.d0 + form_fact=1.d0 + call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact + & ,lambda) + re_val=4.E+04 + call friction_coefficient(ldumm,dhdumm,ks,re_val,form_fact + & , lam) + zeta=zeta*lambda/lam + endif +! + elseif (rzdh.gt.0.5.and.rzdh.lt.1.5) then + call onedint(XDELTA,YA1,10,delta,AI,1,1,10,IER) + call onedint(XRQDH,YB1,8,rzdh,B1,1,1,10,IER) + call onedint(XAQB,YC1,12,azb,C1,1,1,10,IER) + REI=MAX(2.E5,reynolds) + ldumm=1.D0 + dhdumm=-1.D0 + ks=0.d0 + form_fact=1.d0 + call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact + & , lambda) + zeta=AI*B1*C1+0.0175*delta*rzdh*lambda + if (azb.lt.0.25.or.azb.gt.8.0) write2=1 + if (reynolds.lt.2.E+05) then + IF (reynolds.lt.3.E+03) write1=1 + REI=MAX(2999.,reynolds) + call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact + & ,lambda) + re_val=2.E+05 + call friction_coefficient(ldumm,dhdumm,ks,re_val,form_fact + & , lam) + zeta=zeta*lambda/lam + endif +! + elseif (rzdh.ge.1.5.and.rzdh.lt.50.) then + call onedint(XDELTA,YA1,10,delta,AI,1,1,10,IER) + call onedint(XAQB,YC2,12,azb,C2,1,1,10,IER) + call onedint(XRZDH,YB2,8,rzdh,B2,1,1,0,IER) + REI=MAX(2.E5,reynolds) + ldumm=1.D0 + dhdumm=-1.D0 + ks=0.d0 + form_fact=1.d0 + call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact + & ,lambda) + zeta=AI*B2*C2+0.0175*delta*rzdh*lambda + if (azb.lt.0.25.or.azb.gt.8.0) write2=1 + if (reynolds.lt.2.E+05) then + if (reynolds.lt.3.E+03) write1=1 + REI=MAX(2999.,reynolds) + call friction_coefficient(ldumm,dhdumm,ks,REI,form_fact + & ,lambda) + re_val=2.E+05 + call friction_coefficient(ldumm,dhdumm,ks,re_val,form_fact + & , lam) + zeta=zeta*lambda/lam + endif +! + elseif(rzdh.ge.50.) then + zeta=0.0175*rzdh*delta*lambda + if (reynolds .lt. 2.E+04) then + write (*,*)'Reynolds outside valid range i.e. < 20 000!' + endif + endif +! + if (write1 .eq. 1) then +! + write (*,*) 'Reynolds outside valid range i.e. < 3 000!' + endif +! + if(write2 .eq. 1) then + write(*,*) '*WARNING in zeta_calc: extrapolated value(s)!' + endif + return +! + elseif((lakon(nelem)(2:7).eq.'REBEMI').or. + & (lakon(nelem)(2:7).eq.'LPBEMI')) then +! +! SMOOTH BENDS B.H.R.A HANDBOOK +! +! Input parameters +! +! Inlet/outlet sections + a1=prop(ielprop(nelem)+1) + a2=prop(ielprop(nelem)+2) +! Hydraulic diameter + dh=prop(ielprop(nelem)+3) +! Radius: + rad=prop(ielprop(nelem)+4) +! angle delta: + delta=prop(ielprop(nelem)+5) +! + rzdh = Rad / DH +! + write1 = 0 + if ( delta .lt. 10. .or. delta .gt. 180. .or. + & rzdh .lt. 0.5 .or. rzdh. gt. 10. ) write1 = 1 +! + call twodint(ZZETAO,14,11,rzdh,delta,zeta0,1,IEXP6,IER) + call twodint(KRE, 22,11,reynolds,rzdh, k,1,IEXP6,IER) + zeta = zeta0 * k +! + if ( reynolds .lt. 1.E+3 .or. reynolds .gt. 1.E+6 ) then + write (*,*)'Reynolds outside valid range <1.E+3 or >1.0E+6' + endif +! + if ( write1 .eq. 1 ) then + write (*,*)': geometry data outside valid range ' + write (*,*)' - extrapolated value(s)!' + endif + RETURN +! + elseif((lakon(nelem)(2:7).eq.'REBEMA').or. + & (lakon(nelem)(2:7).eq.'LPBEMA')) then +! +! Own tables and formula to be included +! + Write(*,*) '*WARNING in zeta_calc: ZETA implicitly equal 1' + zeta=1.d0 + + RETURN +! + elseif((lakon(nelem)(2:7).eq.'REEX').or. + & (lakon(nelem)(2:7).eq.'LPEX')) then +! +! EXIT LOSS COEFFICIENT FOR LAMINAR FLOWS DEPENDING ON THE +! ACTUAL VELOCITY DISTRIBUTION AT THE EXIT +! +! Input parameters +! +! Inlet/outlet sections + a1=prop(ielprop(nelem)+1) + a2=prop(ielprop(nelem)+2) +! Hydraulic diameter + dh=prop(ielprop(nelem)+3) + if((dh.eq.0).and.(A1.le.A2)) then + dh=dsqrt(4d0*A1/Pi) + elseif((dh.eq.0).and.(A1.gt.A2)) then + dh=dsqrt(4d0*A2/Pi) + endif +! Reference element + nelem_ref=int(prop(ielprop(nelem)+4)) +! + if (lakon(nelem_ref)(2:5).ne.'GAPF') then + write(*,*) '*ERROR in zeta_calc :the reference element is no + &t of type GASPIPE' + stop + endif +! + if(lakon(nelem_ref)(2:6).eq.'GAPFI') then + isothermal=.true. + endif +! Length of the previous pipe element + l=abs(prop(ielprop(nelem_ref)+3)) +! + if (reynolds .le. 2300.) then +! (LAMINAR FLOW) + ldre=l/dh/reynolds + call onedint (XDRE,ZETAEX,12,ldre,zeta,1,1,0,IER) + elseif ((reynolds .gt. 2300) .and. (reynolds .lt. 3000)) then +! (TRANSITION LAMINAR-TURBULENT) + ldre=l/DH/2300. + call onedint (XDRE,ZETAEX,12,ldre,zetah,1,1,0,IER) + zeta=zetah-(zetah-1.)*((reynolds-2300.)/700.) + else +! (TURBULENT FLOW, RE .GT. 3000) + zeta=1. + endif +! + RETURN +! + elseif((lakon(nelem)(2:7).eq.'RELOLI').or. + & (lakon(nelem)(2:7).eq.'LPLOLI')) then +! +! 'METHOD OF LICHTAROWICZ' +! "Discharge coeffcients for incompressible non-cavitating +! flow through long orifices" +! A. Lichtarowicz, R.K duggins and E. Markland +! Journal Mechanical Engineering Science , vol 7, No. 2, 1965 +! +! TOTAL PRESSURE LOSS COEFFICIENT FOR LONG ORIFICES AND LOW REYNOLDS +! NUMBERS ( RE < 2.E04 ) +! +! Input parameters +! +! Inlet/outlet sections + a1=prop(ielprop(nelem)+1) + a2=prop(ielprop(nelem)+2) +! Hydraulic diameter + dh=prop(ielprop(nelem)+3) + if((dh.eq.0).and.(A1.le.A2)) then + dh=dsqrt(4d0*A1/Pi) + elseif((dh.eq.0).and.(A1.gt.A2)) then + dh=dsqrt(4d0*A2/Pi) + endif +! Length + l=prop(ielprop(nelem)+4) +! Isotermal +! + lzd=dabs(l)/dh +! + cdu=0.827-0.0085*lzd + km=a1/a2 + call cd_lichtarowicz(cd,cdu,reynolds,km,lzd) + if (reynolds .gt. 2.E04) then + write(*,*) + & '*WARNING in zeta_calc: range of application exceeded !' + endif +! + zeta=1./cd**2 +! + return +! +! Branch +! + elseif((lakon(nelem)(2:5).eq.'REBR').or. + & (lakon(nelem)(2:5).eq.'LPBR')) then + nelem0=prop(ielprop(nelem)+1) + nelem1=prop(ielprop(nelem)+2) + nelem2=prop(ielprop(nelem)+3) + A0=prop(ielprop(nelem)+4) + A1=prop(ielprop(nelem)+5) + A2=prop(ielprop(nelem)+6) + alpha1=prop(ielprop(nelem)+7) + alpha2=prop(ielprop(nelem)+8) +! +! node definition +! + node10=kon(ipkon(nelem0)+1) + node20=kon(ipkon(nelem0)+3) + nodem0=kon(ipkon(nelem0)+2) +! + node11=kon(ipkon(nelem1)+1) + node21=kon(ipkon(nelem1)+3) + nodem1=kon(ipkon(nelem1)+2) +! + node12=kon(ipkon(nelem2)+1) + node22=kon(ipkon(nelem2)+3) + nodem2=kon(ipkon(nelem2)+2) +! +! determining the nodes which are not in common +! + if(node10.eq.node11) then + node0=node10 + node1=node21 + if(node11.eq.node12) then + node2=node22 + elseif(node11.eq.node22) then + node2=node12 + endif + elseif(node10.eq.node21) then + node0=node10 + node1=node11 + if(node21.eq.node12) then + node0=node22 + elseif(node21.eq.node22) then + node2=node12 + endif + elseif(node20.eq.node11) then + node0=node20 + node1=node21 + if(node11.eq.node12) then + node2=node22 + elseif(node11.eq.node22) then + node2=node12 + endif + elseif(node20.eq.node21) then + node0=node20 + node1=node11 + if(node11.eq.node21) then + node2=node22 + elseif(node21.eq.node22) then + node2=node12 + endif + endif +! +! density +! + if(lakon(nelem)(2:3).eq.'RE') then +! +! for gases +! + qred_crit=dsqrt(kappa/R)* + & (1+0.5d0*(kappa-1))**(-0.5d0*(kappa+1)/(kappa-1)) +! + icase=0 +! + Tt0=v(0,node0) + xflow0=v(1,nodem0) + pt0=v(2,node0) +! + Qred_0=dabs(xflow0)*dsqrt(Tt0)/(A0*pt0) + if(Qred_0.gt.qred_crit) + & then + xflow0=qred_crit*(A0*pt0)/dsqrt(Tt0) + endif +! + call ts_calc(xflow0,Tt0,Pt0,kappa,r,a0,Ts0,icase) + M0=dsqrt(2/(kappa-1)*(Tt0/Ts0-1)) +! + rho0=pt0/(R*Tt0)*(Tt0/Ts0)**(-1/(kappa-1)) +! + Tt1=v(0,node1) + xflow1=v(1,nodem1) + pt1=v(2,node0) +! + Qred_1=dabs(xflow1)*dsqrt(Tt1)/(A1*pt1) + if(Qred_1.gt.qred_crit) + & then + xflow1=qred_crit*(A1*pt1)/dsqrt(Tt1) + endif +! + call ts_calc(xflow1,Tt1,Pt1,kappa,r,a1,Ts1,icase) + M1=dsqrt(2/(kappa-1)*(Tt1/Ts1-1)) +! + rho1=pt1/(R*Tt1)*(Tt1/Ts1)**(-1/(kappa-1)) +! + Tt2=v(0,node2) + xflow2=v(1,nodem2) + pt2=v(2,node0) +! + Qred_2=dabs(xflow2)*dsqrt(Tt2)/(A2*pt2) + if(Qred_2.gt.qred_crit) then + xflow2=qred_crit*(A2*pt2)/dsqrt(Tt2) + endif +! + call ts_calc(xflow2,Tt2,Pt2,kappa,r,a2,Ts2,icase) + M2=dsqrt(2/(kappa-1)*(Tt2/Ts2-1)) + rho2=pt2/(R*Tt2)*(Tt2/Ts2)**(-1/(kappa-1)) + else +! +! for liquids the density is supposed to be constant +! across the element +! + rho0=1.d0 + rho1=1.d0 + rho2=1.d0 + endif +! +! volumic flows (positive) +! + V0=dabs(v(1,nodem0)/rho0) + V1=dabs(v(1,nodem1)/rho1) + V2=dabs(v(1,nodem2)/rho2) +! + V1V0=V1/V0 + V2V0=V2/V0 +! + a0a1=a0/a1 + a0a2=a0/a2 + a2a0=1/a0a2 +! + W0W1=1/(V1V0*a0a1) + W0W2=1/(V2V0*a0a2) +! +! Branch Joint Genium +! Branching Flow Part IV - TEES +! Fluid Flow Division +! Section 404.2 page 4 December 1986 +! Genium Publishing (see www.genium.com) +! + if((lakon(nelem)(2:7).eq.'REBRJG').or. + & (lakon(nelem)(2:7).eq.'LPBRJG')) then +! + ang1s=(1.41d0-0.00594*alpha1)*alpha1*pi/180 + ang2s=(1.41d0-0.00594*alpha2)*alpha2*pi/180 +! + cang1s=dcos(ang1s) + cang2s=dcos(ang2s) +! +! linear part +! + zetlin=2.d0*(V1V0**2*a0a1*cang1s+V2V0**2*a0a2*cang2s) +! + if(nelem.eq.nelem1) then + call onedint(XANG,YANG,11,alpha1,lam10,1,2,22,ier) + zeta=lam10/64*(V1V0*a0a1)**2-zetlin+1d0 + zeta=zeta*(W0W1)**2 +! + elseif(nelem.eq.nelem2) then + call onedint(XANG,YANG,11,alpha2,lam20,1,2,22,ier) + zeta=lam20/64*(V2V0*a0a2)**2-zetlin+1d0 + zeta=zeta*(W0W2)**2 + endif + return +! + elseif((lakon(nelem)(2:8).eq.'REBRJI1').or. + & (lakon(nelem)(2:8).eq.'LPBRJI1')) then +! +! Branch Joint Idelchik 1 +! Diagrams of resistance coefficients p260-p266 section VII +! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' +! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. +! ISBN 0-899116-284-4 +! + a0a2=a0/a2 + if(alpha2.lt.60.) then + if(nelem.eq.nelem1) then + zeta=1.d0-V1V0**2 + & -2.d0*a0a2*V2V0**2*dcos(alpha2*pi/180) + zeta=zeta*(W0W1)**2 + elseif(nelem.eq.nelem2) then + zeta=1.d0-V1V0**2 + & -2.d0*a0a2*V2V0**2*dcos(alpha2*pi/180) + & +(a0a2*V2V0)**2-V1V0**2 + zeta=zeta*(W0W2)**2 + endif +! + elseif(alpha2.eq.60) then +! +! proceeding as for alpha2<60 with cos(alpha2)=0.5 +! + if(nelem.eq.nelem1) then + zeta=1.d0-V1V0**2-a0a2*V2V0**2 + zeta=zeta*(W0W1)**2 + elseif(nelem.eq.nelem2) then + zeta=1.d0-V1V0**2-a0a2*V2V0**2 + & +(a0a2*V2V0)**2-V1V0**2 + zeta=zeta*(W0W2)**2 + endif +! + elseif(alpha2.lt.90) then +! +! linear interpolation between alpha2=60 and alpha2=90 +! + z1_60=1.d0-V1V0**2-a0a2*V2V0**2 + z1_90=(1.55d0-V2V0)*V2V0 + if(nelem.eq.nelem1) then + zeta=z1_60+(z1_90-z1_60)*(alpha2-60.d0)/30 + zeta=zeta*(W0W1)**2 + elseif(nelem.eq.nelem2) then + z2_60=z1_60+(a0a2*V2V0)**2-V1V0**2 + call onedint(TA2A0,TAFAKT,12,a2a0,afakt, + & 1,1,11,ier) + z2_90=afakt*(1.d0+(a0a2*V2V0)**2-2.d0*V1V0**2) + zeta=z2_60+(z2_90-z2_60)*(alpha2-60.d0)/30d0 + zeta=zeta*(W0W2)**2 + endif +! + elseif (alpha2.eq.90) then + if(nelem.eq.nelem1) then + zeta=(1.55d0-V2V0)*V2V0 + zeta=zeta*(W0W1)**2 + elseif(nelem.eq.nelem2) then + call onedint(TA2A0,TAFAKT,12,a2a0,afakt, + & 1,1,11,ier) + zeta=afakt*(1.d0+(a0a2*V2V0)**2-2.d0*V1V0**2) + zeta=zeta*(W0W2)**2 + endif + endif + return +! + elseif((lakon(nelem)(2:8).eq.'REBRJI2').or. + & (lakon(nelem)(2:8).eq.'LPBRJI2')) then +! +! Branch Joint Idelchik 2 +! Diagrams of resistance coefficients page 348-352 +! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' +! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. +! ISBN 0-899116-284-4 page 348-352 +! + if(alpha2.lt.60) then + if(nelem.eq.nelem1) then + zeta=1+a0a1*V1V0**2*(a0a1-2.) + & -2d0*a0a2*V2V0**2*dcos(alpha2*pi/180) +! correction term + call twodint(KSTAB,6,11,a2a0,alpha2,ks2,1 + & ,iexpbr1,ier) + zeta=zeta+ks2 + zeta=zeta*(W0W1)**2 + elseif(nelem.eq.nelem2) then + zeta=1+a0a1*V1V0**2*(a0a1-2.) + & -2d0*a0a2*V2V0**2*dcos(alpha2*pi/180) + & -(a0a1*V1V0)**2+(a0a2*V2V0)**2 + call twodint(KBTAB,6,11,a2a0,alpha2,kb,1, + & iexpbr1,ier) + zeta=zeta+kb + zeta=zeta*(W0W2)**2 + endif +! + elseif(alpha2.eq.60) then +! as for alpha2 < 60 , with dcos(alpha2)=0.5 + if(nelem.eq.nelem1) then + zeta=1+a0a1*V1V0**2*(a0a1-2.)-a0a2*V2V0**2 + call twodint(KSTAB,6,11,a2a0,alpha2,ks2,1, + & iexpbr1,ier) + zeta=zeta+ks2 + zeta=zeta*(W0W1)**2 + elseif(nelem.eq.nelem2) then + zeta=1+a0a1*V1V0**2*(a0a1-2.)-a0a2*V2V0**2 + & -(a0a1*V1V0)**2+(a0a2*V2V0)**2 + call twodint(KBTAB,6,11,a2a0,alpha2,kb,1, + & iexpbr1,ier) + zeta=zeta+kb + zeta=zeta*(W0W2)**2 + endif +! + elseif(alpha2.lt.90) then +! linear interpolation between alpha2=60 and alpha2=90 + z1_60=1+a0a1*V1V0**2*(a0a1-2.)-a0a2*V2V0**2 +! correction term + call twodint(KSTAB,6,11,a2a0,alpha2,ks2,1, + & iexpbr1,ier) + z1_60=z1_60+ks2 + if(nelem.eq.nelem1) then + call twodint(Z90TAB,6,11,a2a0,V2V0,z1_90, + & 1,iexpbr1,ier) + zeta=z1_60+(z1_90-z1_60)*(alpha2-60)/30 + zeta=zeta*(W0W1)**2 + elseif(nelem.eq.nelem2) then + z2_60=z1_60-(a0a1*V1V0)**2+(a0a2*v2v0)**2 + call twodint(KBTAB,6,11,a2a0,alpha2,kb,1, + & iexpbr1,ier) + z2_60=z2_60+kb-ks2 + z2_90=1.+(a0a2*V2V0)**2-2*a0a1*V1V0**2+kb + zeta=z2_60+(z2_90-z2_60)*(alpha2-60)/30 + zeta=zeta*(W0W2)**2 + endif + elseif(alpha2.eq.90) then + if(nelem.eq.nelem2) then + call twodint(KBTAB,6,11,a2a0,alpha2,kb,1, + & iexpbr1,ier) + zeta=1.+(a0a2*V2V0)**2-2*a0a1*V1V0**2+kb + zeta=zeta*(W0W2)**2 + elseif(nelem.eq.nelem1) then +! table interpolation + call twodint(Z90TAB,6,11,a2a0,V2V0,zeta, + & 1,iexpbr1,ier) + zeta=zeta*(W0W1)**2 +! cheching whether the table eveluation in the eptrapolated domain +! (This procedure is guessed from the original table) +! + Z90LIM11=Z90LIMX(1) + Z90LIM51=Z90LIMX(5) + if((a2a0.ge.Z90LIM11) + & .and.(a2a0.le.Z90LIM51))then + call onedint(Z90LIMX,Z90LIMY,5,A2A0, + & V2V0L,1,1,11,ier) + if(V2V0.gt.V2V0L) then + write(*,*) 'WARNING in zeta_calc: in element', + & nelem + write(*,*) + & ' V2V0 in the extrapolated domain' + write(*,*) ' for zeta table (branch 1)' + endif + endif + endif + endif + return +! + elseif((lakon(nelem)(2:7).eq.'REBRSG').or. + & (lakon(nelem)(2:7).eq.'LPBRSG')) then +! +! Branch Split Genium +! Branching Flow Part IV - TEES +! Fluid Flow Division +! Section 404.2 page 3 December 1986 +! Genium Publishing (see www.genium.com) +! + if(nelem.eq.nelem1) then +! + ang1s=(1.41d0-0.00594*alpha1)*alpha1*pi/180 +! + cang1s=dcos(ang1s) +! + if(alpha1.le.22.5) then + lam11=0.0712*alpha1**0.7041+0.37 + lam12=0.0592*alpha1**0.7029+0.37 + else + lam11=1.d0 + lam12=0.9d0 + endif + zeta=lam11+(2.d0*lam12-lam11)*(V1V0*a0a1)**2 + & -2d0*lam12*V1V0*a0a1*cang1s + zeta=zeta*(W0W1)**2 +! + elseif(nelem.eq.nelem2) then +! + ang2s=(1.41d0-0.00594*alpha2)*alpha2*pi/180 +! + cang2s=dcos(ang2s) +! + if(alpha2.le.22.5) then + lam21=0.0712*alpha2**0.7041+0.37 + lam22=0.0592*alpha2**0.7029+0.37 + else + lam21=1.d0 + lam22=0.9d0 + endif +! + zeta=lam21+(2.d0*lam22-lam21)*(V2V0*a0a2)**2 + & -2d0*lam22*V2V0*a0a2*cang2s + zeta=zeta*(W0W2)**2 +! + endif + return +! + elseif((lakon(nelem)(2:8).eq.'REBRSI1').or. + & (lakon(nelem)(2:8).eq.'LPBRSI1')) then +! +! Branch Split Idelchik 1 +! Diagrams of resistance coefficients p280,p282 section VII +! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' +! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. +! ISBN 0-899116-284-4 +! + W1W0=V1V0*a0a1 + W2W0=V2V0*a0a2 +! + if(nelem.eq.nelem1) then + zeta=0.4d0*(1-W1W0)**2 + zeta=zeta*(W0W1)**2 +! + elseif(nelem.eq.nelem2) then +! + dh0=dsqrt(A0*4d0/Pi) + if(dh0.eq.0) then + dh0=dsqrt(4d0*A0/Pi) + endif + dh2=dsqrt(A2*4d0/Pi) + if(dh2.eq.0) then + dh2=dsqrt(4d0*A2/Pi) + endif +! + hq=dh2/dh0 + if(alpha2.le.60.or.hq.le.2.d0/3.d0) then + zeta=0.95d0*((W2W0-2d0*dcos(alpha2*pi/180)) + & *W2W0+1.d0) + zeta=zeta*(W0W2)**2 + else + z2d390=0.95d0*((W2W0-2d0*dcos(90.d0*pi/180)) + & *W2W0+1.d0) + z1p090=0.95*(0.34d0+W2W0**2) + z90=z2d390+(3*hq-2.d0)*(z1p090-z2d390) + Z60=0.95d0*((W2W0-2d0*dcos(60.d0*pi/180)) + & *W2W0+1.d0) + zeta=z60+(alpha2/30.d0-2.d0)*(z90-z60) + zeta=zeta*(W0W2)**2 + endif + endif + return +! + elseif((lakon(nelem)(2:8).eq.'REBRSI2').or. + & (lakon(nelem)(2:8).eq.'LPBRSI2')) then +! +! Branch Split Idelchik 2 +! Diagrams of resistance coefficients p289,section VII +! I.E. IDEL'CHIK 'HANDBOOK OF HYDRAULIC RESISTANCE' +! 2nd edition 1986,HEMISPHERE PUBLISHING CORP. +! ISBN 0-899116-284-4 +! + if(nelem.eq.nelem1) then + W1W0=V1V0*a0a1 + W0W1=1/W1W0 + zeta=1.d0+0.3d0*W1W0**2 + zeta=zeta*(W0W1)**2 + elseif(nelem.eq.nelem2) then + W2W0=V2V0*a0a2 + W0W2=1/W2W0 + zeta=1.d0+0.3d0*W2W0**2 + zeta=zeta*(W0W2)**2 + endif + return + endif + endif +! + end + + diff -Nru calculix-ccx-2.1/debian/changelog calculix-ccx-2.3/debian/changelog --- calculix-ccx-2.1/debian/changelog 2010-05-10 15:17:43.000000000 +0000 +++ calculix-ccx-2.3/debian/changelog 2011-06-08 18:08:21.000000000 +0000 @@ -1,3 +1,9 @@ +calculix-ccx (2.3-1ppa1~lucid1ubuntu1) lucid; urgency=low + + * New upstream version + + -- Patrick Prokopczuk (Funky-Doctor) Wed, 08 Jun 2011 20:07:54 +0200 + calculix-ccx (2.1-1ppa1~lucid1) lucid; urgency=low * Upstream version bump diff -Nru calculix-ccx-2.1/debian/patches/debian-changes-2.1-1ppa1~lucid1 calculix-ccx-2.3/debian/patches/debian-changes-2.1-1ppa1~lucid1 --- calculix-ccx-2.1/debian/patches/debian-changes-2.1-1ppa1~lucid1 2010-05-10 17:48:04.000000000 +0000 +++ calculix-ccx-2.3/debian/patches/debian-changes-2.1-1ppa1~lucid1 2011-06-08 18:27:20.000000000 +0000 @@ -22,8 +22,8 @@ Reviewed-By: Last-Update: ---- calculix-ccx-2.1.orig/ccx_2.1/src/Makefile -+++ calculix-ccx-2.1/ccx_2.1/src/Makefile +--- calculix-ccx-2.3.orig/ccx_2.3/src/Makefile ++++ calculix-ccx-2.3/ccx_2.3/src/Makefile @@ -1,5 +1,5 @@ -CFLAGS = -Wall -O -I ../../../SPOOLES.2.2 -DARCH="Linux" -DSPOOLES -DARPACK -DMATRIXSTORAGE @@ -43,15 +43,8 @@ - -lm -lc +LIBS = -lspooles -lpthread -larpack -llapack -lm -lc - ccx_2.1: $(OCCXMAIN) ccx_2.1.a $(LIBS) - ./date.pl; $(CC) $(CFLAGS) -c ccx_2.1.c; $(FC) -Wall -O -o $@ $(OCCXMAIN) ccx_2.1.a -lpthread $(LIBS) ---- calculix-ccx-2.1.orig/ccx_2.1/src/Makefile.inc -+++ calculix-ccx-2.1/ccx_2.1/src/Makefile.inc -@@ -91,7 +91,6 @@ depvars.f \ - deuldlag.f \ - dflux.f \ - dfluxes.f \ --dgesv.f \ - diamtr.f \ - distattach.f \ - distributedcouplings.f \ + ccx_2.3: $(OCCXMAIN) ccx_2.3.a $(LIBS) + ./date.pl; $(CC) $(CFLAGS) -c ccx_2.3.c; $(FC) -Wall -O -o $@ $(OCCXMAIN) ccx_2.3.a -lpthread $(LIBS) + ccx_2.3: $(OCCXMAIN) ccx_2.3.a $(LIBS) + ./date.pl; $(CC) $(CFLAGS) -c ccx_2.3.c; $(FC) -Wall -O -o $@ $(OCCXMAIN) ccx_2.3.a -lpthread $(LIBS) + diff -Nru calculix-ccx-2.1/debian/rules calculix-ccx-2.3/debian/rules --- calculix-ccx-2.1/debian/rules 2010-05-10 17:40:45.000000000 +0000 +++ calculix-ccx-2.3/debian/rules 2011-06-08 18:08:40.000000000 +0000 @@ -1,7 +1,7 @@ #!/usr/bin/make -f # -*- makefile -*- -MY_PV=2.1 +MY_PV=2.3 DEB_SRCDIR = $(CURDIR)/ccx_$(MY_PV)/src include /usr/share/cdbs/1/rules/debhelper.mk