1!$Id:$ 2 subroutine pblend1a(is,iblend,iside,isd) 3 4! * * F E A P * * A Finite Element Analysis Program 5 6!.... Copyright (c) 1984-2017: Regents of the University of California 7! All rights reserved 8 9!-----[--.----+----.----+----.-----------------------------------------] 10 11! Purpose: Construct one dimensional interpolation using blending 12 13! Inputs: 14! is(isd,*) - Blending side supernode lists 15! iblend(*) - Blending functions parameters/sides 16! isd - Dimension for sides array 17 18! Outputs: 19! iside - Number of side to construct 20!-----[--.----+----.----+----.-----------------------------------------] 21 implicit none 22 23 include 'cblend.h' 24 include 'cdata.h' 25 include 'iofile.h' 26 include 'pointer.h' 27 include 'region.h' 28 include 'trdata.h' 29 include 'comblk.h' 30 31 logical setvar, palloc 32 integer isd,iside(*), is(isd,*),iblend(*) 33 integer i, j, i1,i2,i3,i4 34 35 save 36 37! Set side number to use 38 39 i1 = iblend(11) 40 i2 = iblend(12) 41 do j = 1,numsd 42 i3 = is(1,j) 43 if(i3.eq.2) then 44 do i4 = 3,isd 45 if(is(i4,j).ne.0) then 46 i = i4 47 endif 48 end do ! i4 49 else 50 i = 3 51 endif 52 if((i1.eq.is(2,j) .and. i2.eq.is(i,j)) .or. 53 & (i1.eq.is(i,j) .and. i2.eq.is(2,j))) then 54 iside(1) = j 55 return 56 endif 57 end do ! j 58 59! Add new side 60 61 numsd = numsd + 1 62 setvar = palloc(162,'BSIDE',numsd*isd,1) 63 i3 = 1 64 call pblenda2(i3,i1,i2,mr(np(162)),iside,isd) 65 66 end 67 68 subroutine pblend1b(xs,is,trb,iblend,ilr,x,ix, 69 & iside,isd,ndm,nen1,prt,prth,eflag,nflag) 70 71!-----[--.----+----.----+----.-----------------------------------------] 72 73! Purpose: Construct one dimensional interpolation using blending 74 75! Inputs: 76! xs(3,*) - Blending supernode connections 77! is(isd,*) - Blending side supernode lists 78! trb - Transformation for blending coordinates 79! iblend(*) - Blending functions parameters/sides 80! ilr(*) - Material quantities for blends 81! isd - Dimension for sides array 82! ndm - Spatial dimension of mesh 83! nen1 - Dimension of ix array 84 85! Outputs: 86! x(ndm,*) - Nodal coordinates for blended patch 87! ix(nen1,*)- Element connections 88!-----[--.----+----.----+----.-----------------------------------------] 89 implicit none 90 91 include 'cblend.h' 92 include 'cdata.h' 93 include 'iofile.h' 94 include 'pointer.h' 95 include 'region.h' 96 include 'trdata.h' 97 include 'comblk.h' 98 99 logical prt,prth,eflag,nflag, setvar, palloc 100 character ctype*15, etype*5, pelabl*5 101 integer isd,ndm,nen1,nrig, nsn, iside 102 integer i, j,jj, k, ma 103 integer ne,nf,ni,nm,nn,nr,ns,nodinc,ntyp, styp, dlayer 104 integer is(isd,*),iblend(*), ix(nen1,*), ilr(*) 105 real*8 xs(3,*),trb(3,4),x(ndm,*), trdeto 106 107 save 108 109! Get edge interpolations 110 111 nr = iblend(1) 112 113 setvar = palloc (111, 'TEMP1',(nr+1)*ndm ,2) 114 setvar = palloc (112, 'TEMP2',(nr+1) ,2) 115 setvar = palloc (113, 'TEMP3',(nr+1)*3 ,2) 116 117 nreg = iblend(10) 118 nrig = iblend(20) 119 jj = abs(iside) 120 styp = is(1,jj) 121 do j = isd,2,-1 122 if(is(j,jj).ne.0) go to 110 123 end do ! j 124 write(*,3000) j 125 call plstop(.true.) 126110 nsn = j - 1 127 128 call pside1(nr, xs, trb, iside,is(2,jj), nsn,ndm, 129 & hr(np(112)),hr(np(113)), hr(np(111)),styp) 130 131 ni = iblend(3) 132 133 call pblend1x(nn,nr,ni,ndm, hr(np(111)),mr(np(190)),x, 134 & nflag,prt,prth) 135 136 setvar = palloc (113, 'TEMP3',0 ,2) 137 setvar = palloc (112, 'TEMP2',0 ,2) 138 setvar = palloc (111, 'TEMP1',0 ,2) 139 140 if(eflag) then 141 ne = iblend(4) 142 ma = iblend(5) 143 ntyp = iblend(6) 144 nm = 4 145 nodinc = 0 146 ctype = 'blen' 147 dlayer = 0 148 if(ntyp.eq.3) then 149 ns = 2 150 else 151 ns = 1 152 endif 153 nm = 2 154 nr = nr + 1 155 156 trdeto = trdet 157 trdet = trb(1,1)*(trb(2,2)*trb(3,3) - trb(2,3)*trb(3,2)) 158 & + trb(1,2)*(trb(2,3)*trb(3,1) - trb(2,1)*trb(3,3)) 159 & + trb(1,3)*(trb(2,1)*trb(3,2) - trb(2,2)*trb(3,1)) 160 161 call sblke(nr,ns,x,ix,ni,ne,nn,ndm,nen1,nodinc,ntyp,nm,ma, 162 & dlayer,ilr,ctype) 163 trdet = trdeto 164 nf = nn 165 endif 166 167! Set region numbers 168 169 if(eflag) then 170 do nn = ne,nf 171 ix(nen1-1,nn) = nreg 172 end do ! nn 173 174! Print lists if wanted 175 176 if(prt.and.ne.gt.0) then 177 do nn = ne,nf,50 178 call prtitl(prth) 179 write(iow,2000) (i,i=1,nen) 180 if(ior.lt.0) then 181 write( *,2000) (i,i=1,nen) 182 endif 183 j = min(nf,nn+49) 184 do i = nn,j 185 ma = ix(nen1,i) 186 etype = pelabl(ix(nen+7,i)) 187 write(iow,2001) i,ma,nreg,etype,(ix(k,i),k=1,nen) 188 if(ior.lt.0) then 189 write(*,2001) i,ma,nreg,etype,(ix(k,i),k=1,nen) 190 endif 191 end do ! i 192 end do ! nn 193 endif 194 endif 195 196! Formats 197 1982000 format(' E l e m e n t C o n n e c t i o n s'// 199 & ' Elmt Mat Reg Type',7(i3,'-node'):/(21x,7(i3,'-node'))) 200 2012001 format(i7,2i4,1x,a5,7i8:/(21x,7i8)) 202 2033000 format(' *ERROR* PBLEND1: No side nodes found for side',i4) 204 205 end 206 207 subroutine pblend1x(nn,nr,ni,ndm, fxim,nty,x,nflag,prt,prth) 208 209 implicit none 210 211 include 'iofile.h' 212 213 logical nflag,prt,prth 214 integer i,k, nr,ni, nn,ndm, nty(*) 215 real*8 n1i,n2i, rnr, fxim(ndm,0:nr), x(ndm,*) 216 217 save 218 219 nn = ni - 1 220 rnr = 1.d0/dble(nr) 221 222 if(prt) then 223 call prtitl(prth) 224 write(iow,2000) (i,i=1,ndm) 225 endif 226 do i = 0,nr 227 nn = nn + 1 228 if(nflag .or. nty(nn).ge.0) then 229 n2i = dble(i)*rnr 230 n1i = 1.d0 - n2i 231 nty(nn) = 0 232 do k = 1,ndm 233! x(k,nn) = fxim(k,i) - n1i*fxim(k,0) - n2i*fxim(k,nr) 234 x(k,nn) = fxim(k,i) 235 end do ! k 236 if(prt) then 237 write(iow,2001) nn,(x(k,nn),k=1,ndm) 238 endif 239 end if 240 end do ! i 241 242! Formats 243 2442000 format(' B l e n d e d C o o r d i n a t e s'// 245 & ' Node',4(i5,'-Coordinate':)) 246 2472001 format(i8,1p,4e15.5) 248 249 end 250