1!$Id:$ 2 subroutine pform(ul,xl,tl,ld,p,s,ie,d,id,x,ix,f,t,jp, 3 & u,ud,b,a,al,ndd,nie,ndf,ndm,nen1,nst,aufl,bfl,dfl, 4 & isw,nn1,nn2,nn3) 5 6! * * F E A P * * A Finite Element Analysis Program 7 8!.... Copyright (c) 1984-2017: Regents of the University of California 9! All rights reserved 10 11!-----[--.----+----.----+----.-----------------------------------------] 12! Purpose: Compute element arrays and assemble global arrays 13 14! Inputs: 15! ie(nie,*) - Assembly information for material set 16! d(ndd,*) - Material set parameters 17! id(ndf,*) - Equation numbers for each active dof 18! x(ndm,*) - Nodal coordinates of mesh 19! ix(nen1,*) - Element nodal connections of mesh 20! f(ndf,*,2) - Nodal force and displacement values 21! t(*) - Nodal temperature values 22! jp(*) - Pointer array for row/columns of tangent 23! u(*) - Nodal solution values 24! ud(*) - Nodal rate values 25! ndd - Dimension for d array 26! nie - Dimension for ie array 27! ndf - Number dof/node 28! ndm - Spatial dimension of mesh 29! nen1 - Dimension for ix array 30! nst - Dimension for element array 31! aufl - Flag, assemble coefficient array if true 32! bfl - Flag, assemble vector if true 33! dfl - Flag, assemble reactions if true 34! isw - Switch to control quantity computed 35! nn1 - First element number to process 36! nn2 - Last element number to process 37! nn3 - Increment to nn1 38 39! Scratch: 40! ul(ndf,*) - Element solution and rate values 41! xl(ndm,*) - Element nodal coordinates 42! tl(*) - Element nodal temperatures 43! ld(*) - Element local/global equation numbers 44! p(nst,*) - Element vector 45! s(nst,*) - Element array 46 47! Outputs: 48! b(*) - Global vector 49! a(*) - Global matrix, diagonal and upper part 50! al(*) - Global matrix, lower part 51!-----[--.----+----.----+----.-----------------------------------------] 52 53 implicit none 54 55 include 'cdata.h' 56 include 'crotas.h' 57 include 'ddata.h' 58 include 'elcount.h' 59 include 'eldata.h' 60 include 'elplot.h' 61 include 'eluser.h' 62 include 'eqsym.h' 63 include 'erotas.h' 64 include 'fdata.h' 65 include 'iofile.h' 66 include 'hdata.h' 67 include 'hdatam.h' 68 include 'mdata.h' 69 include 'modreg.h' 70 include 'p_int.h' 71 include 'pointer.h' 72 include 'prld1.h' 73 include 'prlod.h' 74 include 'prstrs.h' 75 include 'ptdat1.h' 76 include 'ptdat2.h' 77 include 'ptdat8.h' 78 include 'rdata.h' 79 include 'rdat0.h' 80 include 'region.h' 81 include 'tdata.h' 82 include 'tdatb.h' 83 include 'comblk.h' 84 85 logical aufl,bfl,dfl,efl, mdfl 86 integer isw, jsw, ksw 87 integer i, jj, nn1, nn2, nn3, nst, nl1, nneq 88 integer numnp2, ndf, ndm, nrot, ndd, nie, nen1 89 real*8 un(20), dun(20), temp, prope 90 91 integer ld(*), ie(nie,*), id(ndf,*), ix(nen1,*), jp(*) 92 real*8 xl(ndm,*), p(nst,*), s(nst,*), d(ndd,*), ul(nst,*) 93 real*8 x(ndm,*) ,f(ndf,numnp),u(ndf,*),ud(*),t(*),tl(*) 94 real*8 b(*), a(*), al(*) 95 96 save 97 98! Set element proportional loading value 99 100 prope = theta(3)*(prop - propo) + propo 101 102! Recover nh1, nh2, nh3 pointers 103 104 nh1 = np(50) 105 nh2 = np(51) 106 nh3 = np(52) 107 108! Set program and user material count parameters 109 110 do i = 1,10 111 nomats(1,i) = 0 112 nomats(2,i) = 0 113 unmats(1,i) = 0 114 unmats(2,i) = 0 115 end do ! i 116 117! Set up local arrays before calling element library 118 119 iel = 0 120 efl = .false. 121 if(.not.dfl.and.isw.eq.6) efl = .true. 122 if(bfl.and.isw.eq.3) efl = .true. 123 124 if(isw.eq.19) then 125 if(bfl) efl = .true. 126 jsw = 5 127 ksw = 5 128 else 129 jsw = isw 130 ksw = 3 131 endif 132 133! Set stiffness, damping and mass pointers 134 135 nl1 = ndf*nen + 1 136 numnp2 = numnp + numnp 137 nneq = numnp*ndf 138 nrkn = nrk*nneq - nneq 139 nrcn = nrc*nneq - nneq 140 nrmn = nrm*nneq - nneq 141 nrvn = nrt*nneq - nneq - nneq 142 143! Loop over active elements 144 145 do n = nn1,nn2,nn3 146 147! Check for active regions 148 149 if((nreg.lt.0 .and. ix(nen1-1,n).ge.0) 150 & .or. (abs(ix(nen1-1,n)).eq.nreg)) then 151 152! Set up local arrays 153 154 do ma = 1, nummat 155 156 if(ie(nie-2,ma).eq.ix(nen1,n)) then 157 158! Compute address and offset for history variables 159 160 ht1 = np(49) + ix(nen+1,n) + ie(nie-3,ma) 161 ht2 = np(49) + ix(nen+2,n) + ie(nie-3,ma) 162 ht3 = np(49) + ix(nen+3,n) + ie(nie-4,ma) 163 164! If history variables exist move into nh1,nh2 165 166 if(ie(nie,ma).gt.0) then 167 do i = 0,ie(nie,ma)-1 168 hr(nh1+i) = hr(ht1+i) 169 hr(nh2+i) = hr(ht2+i) 170 end do 171 endif 172 173! If Element variables exist move into nh3 174 175 if(ie(nie-5,ma).gt.0) then 176 do i = 0,ie(nie-5,ma)-1 177 hr(nh3+i) = hr(ht3+i) 178 end do 179 endif 180 181 if(ie(nie-1,ma).ne.iel) mct = 0 182 iel = ie(nie-1,ma) 183 rotyp = ie(nie-6,ma) 184 185! Set local arrays for element 186 187 fp(1) = ndf*nen*(ma-1) + np(240) ! iedof 188 call plocal(ld,id,mr(np(31)+nneq),ix(1,n),ie(1,ma), 189 & mr(fp(1)),xl,ul,tl,p(1,3),x,f,u,ud,t, 190 & un,dun, nrot, dfl, jsw) 191 192! Form element array - rotate parameters if necessary 193 194 if(nrot.gt.0) then 195 if(iel.gt.0) then 196 call ptrans(ia(1,iel),hr(np(46)),ul,p,s, 197 & nel,ndf,nst,1) 198 if(ir(1,iel).ne.0) then 199 call ptrans(ir(1,iel),hr(np(46)),ul,p,s, 200 & nel,ndf,nst,1) 201 endif 202 else 203 call ptrans(ea(1,-iel),hr(np(46)),ul,p,s, 204 & nel,ndf,nst,1) 205 if(er(1,-iel).ne.0) then 206 call ptrans(er(1,-iel),hr(np(46)),ul,p,s, 207 & nel,ndf,nst,1) 208 endif 209 endif 210 endif 211 if(jsw.eq.8) then 212 erav = hr(np(207)+n-1) 213 else 214 erav = 0.0d0 215 endif 216 dm = prope 217 call elmlib(d(1,ma),ul,xl,ix(1,n),tl,s,p, 218 & ndf,ndm,nst,iel,jsw) 219 220! Store time history plot data from element 221 222 if(jsw.eq.6) then 223 224! Standard element values 225 226 do i = 1,nsplts 227 if(ispl(1,i).eq.n) then 228 jj = max(ispl(2,i),1) 229 spl(i) = tt(jj) 230 endif 231 end do 232 233! Standard user element values 234 235 do i = 1,nuplts 236 if(iupl(1,i).eq.n) then 237 jj = max(iupl(2,i),1) 238 upl(i) = ut(jj) 239 endif 240 end do 241 242 endif 243 244! Modify for rotated dof's 245 246 if(nrot.gt.0) then 247 if(iel.gt.0) then 248 call ptrans(ia(1,iel),hr(np(46)),ul,p,s, 249 & nel,ndf,nst,2) 250 if(ir(1,iel).ne.0) then 251 call ptrans(ir(1,iel),hr(np(46)),ul,p,s, 252 & nel,ndf,nst,2) 253 endif 254 else 255 call ptrans(ea(1,-iel),hr(np(46)),ul,p,s, 256 & nel,ndf,nst,2) 257 if(er(1,-iel).ne.0) then 258 call ptrans(er(1,-iel),hr(np(46)),ul,p,s, 259 & nel,ndf,nst,2) 260 endif 261 endif 262 endif 263 264! Position update terms 'nt1,nt2' from 'nh1,nh2' to save 265 266 if(hflgu .and. ie(nie,ma).gt.0) then 267 do i = 0,ie(nie,ma)-1 268 temp = hr(ht1+i) 269 hr(ht1+i) = hr(nh1+i) 270 hr(nh1+i) = temp 271 temp = hr(ht2+i) 272 hr(ht2+i) = hr(nh2+i) 273 hr(nh2+i) = temp 274 end do 275 endif 276 277! Position update terms 'nt3' from 'nh3' to save 278 279 if(h3flgu .and. ie(nie-5,ma).gt.0) then 280 do i = 0,ie(nie-5,ma)-1 281 hr(ht3+i) = hr(nh3+i) 282 end do 283 endif 284 285! Modify for non-zero displacement boundary conditions 286 287 mdfl = .false. 288 do i = 1,ndf 289 if(dun(i).gt.1.0d-10*un(i)) then 290 mdfl = .true. 291 exit 292 endif 293 end do ! i 294 295 if(efl.and.mdfl) then 296 297! Get current element tangent matrix 298 299 if (.not.aufl) then 300 dm = prop 301 call elmlib(d(1,ma),ul,xl,ix(1,n),tl,s,p, 302 & ndf,ndm,nst,iel,ksw) 303 if(nrot.gt.0) then 304 if(iel.gt.0) then 305 call ptrans(ia(1,iel),hr(np(46)),ul,p,s, 306 & nel,ndf,nst,2) 307 if(ir(1,iel).ne.0) then 308 call ptrans(ir(1,iel),hr(np(46)),ul,p,s, 309 & nel,ndf,nst,2) 310 endif 311 else 312 call ptrans(ea(1,-iel),hr(np(46)),ul,p,s, 313 & nel,ndf,nst,2) 314 if(er(1,-iel).ne.0) then 315 call ptrans(er(1,-iel),hr(np(46)),ul,p,s, 316 & nel,ndf,nst,2) 317 endif 318 endif 319 endif 320 end if 321 322! Modify for displacements 323 324 do i = 1,nst 325 p(i,3) = p(i,3)*cc3 326 end do 327 call modify(p,s,p(1,3),nst,nst) 328 end if 329 330! Add to total array 331 332 if(aufl.or.bfl) then 333 call dasble(s,p,ld,jp,nst,neqs,aufl,bfl, 334 & b,al,a(neq+1),a) 335 endif 336 337 end if 338 339 end do ! ma 340 341 end if ! regions 342 343 end do ! n 344 345 end 346