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