C FPSHB8    SOURCE    CB215821  24/04/12    21:16:03     11897          
      subroutine fpshb8(mmodel,mchpo1,p,mchpoi)
      implicit real*8(a-h,o-z)
      implicit integer (i-n)
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
-INC SMMODEL
-INC SMCOORD
      character*4 moopt(2)
      segment tratra
       real *8 propel(2),out(3,8),re(1),d(1),xe(3,8),work(3)
      endsegment
      segment icpr(nbpts)
      segment icprp(nbpts)
      data moopt/'INTE','EXTE'/
*
*    verif que les surfaces interne ou externe existent
*
      icpr=0
      icprp=0
      mchpoi=0
      segact mmodel
      do  ia=1,kmodel(/1)
         imodel=kmodel(ia)
         segact imodel
         if(nefmod.ne.260) then
           call erreur (19)
           return
         endif
         meleme=imamod
         segact meleme
         if(lisref(/1).ne.2) then
           call erreur(1004)
           return
         endif
         ipt1=lisref(1)
         segact ipt1
         if(ipt1.itypel.ne.8) then
            call erreur (1004)
            return
         endif
         segdes ipt1
         ipt1=lisref(2)
         segact ipt1
         if(ipt1.itypel.ne.8) then
            call erreur (1004)
            return
         endif
         segdes ipt1
      enddo
*
*  reperage du champpointy de pression si necessaire
*
      if( mchpo1.ne.0) then
        segini icpr
        segact mchpo1
        if(mchpo1.ipchp(/1).ne.1) then
           call erreur(180)
           mchpoi=0
           return
        endif
        msoupo=mchpo1.ipchp(1)
        segact msoupo
        ipt1=igeoc
        segact ipt1
        do i=1,ipt1.num(/2)
           ia=ipt1.num(1,i)
           icpr(ia)=i
        enddo
        mpova2=ipoval
        segact mpova2
        segdes msoupo,ipt1
      endif
*
*    lecture du mot interne ou externe et debut de la
*    fabrication du chpoint résultat
*
      call lirmot(moopt,2,isur,0)
      if(isur.eq.0) then
* on a pas lu ni interne ni externe on essaye de savoir
* sur qui le chpoint de pression est appliqué
         if(mchpo1.eq.0) then
             call erreur(1005)
             return
         endif
      isur1=0
      do ia=1,kmodel(/1)
        imodel=kmodel(ia)
        meleme=imamod
        do 321 io=1,2
        ipt3=lisref(io)
        segact ipt3
        do iel=1,ipt3.num(/2)
          iell=ipt3.num(1,iel)
          if( icpr(iell).eq.0) go to 321
        enddo
        if(isur1.eq.0)  then
         isur1=io
         go to 322
        else
         if(isur1.ne.io)then
           call erreur(1006)
           return
         endif
        endif
  321   continue
  322   continue
      enddo
      if(isur1.eq.0) call erreur(286)
      isur=isur1
      endif
*
*   reperage de la surface
*
      segini icprp
      nbelem=0
      do ia=1,kmodel(/1)
         imodel=kmodel(ia)
         meleme=imamod
         ipt3=lisref(isur)
         segact ipt3
         do ib=1,ipt3.num(/2)
           do ic=1,ipt3.num(/1)
             ie=ipt3.num(ic,ib)
             if(icprp(ie).eq.0)  then
               nbelem=nbelem+1
              icprp(ie)=nbelem
             endif
           enddo
         enddo
      enddo
*
* debut de la fabrication du chpoint résultat
*
      nbnn=1
      nbref=0
      nbsous=0
      segini ipt4
      nsoupo=1
      nat=1
      segini mchpoi
      ifopoi=ifour
      mtypoi='FORCES'
      mochde='crée par fpshb8 '
      nc=3
      segini msoupo
      ipchp(1)=msoupo
      segdes mchpoi
      n=nbelem
      segini mpoval
      ipoval=mpoval
      igeoc=ipt4
      nocomp(1)='F  '
      nocomp(2)='FY '
      nocomp(3)='FZ '
      noharm(1)=nifour
      noharm(2)=nifour
      noharm(3)=nifour
      segdes msoupo
      do ib=1,icprp(/1)
        ia=icprp(ib)
        if(ia.ne.0) ipt4.num(1,ia)=ib
      enddo
      segdes ipt4
*
*     boucle sur les élements
*
      segini tratra
      idim1=idim+1
      do  ir=1,kmodel(/1)
        imodel=kmodel(ir)
        meleme=imamod
        segact meleme
        ipt3=lisref(isur)
        segact ipt3
        propel(2)=isur
        propel(1)=p
        do iel=1,num(/2)
          if( mchpo1.ne.0) then
            p=0.d0
            do j=1,ipt3.num(/1)
              ih=ipt3.num(j,iel)
              if(icpr(ih).ne.0) then
                 p=p+mpova2.vpocha(icpr(ih),1)/4
              endif
            enddo
            propel(1)=p
          endif
          do io=1,8
            ia=num(io,iel)
            xe(1,io)=xcoor((ia-1)*idim1+1)
            xe(2,io)=xcoor((ia-1)*idim1+2)
            xe(3,io)=xcoor((ia-1)*idim1+3)
          enddo
          call shb8(5,xe,D,propel,work,re,out)
* assemblage

          do io=1,8
            ia=num(io,iel)
            ib=icprp(ia)
            if(ib.ne.0) then
            vpocha(ib,1)=out(1,io)+vpocha(ib,1)
            vpocha(ib,2)=out(2,io)+vpocha(ib,2)
            vpocha(ib,3)=out(3,io)+vpocha(ib,3)
            endif
          enddo
        enddo
        segdes imodel,meleme,ipt3
      enddo
      segdes mpoval
      segdes mmodel
      segsup icprp,tratra
      if(icpr.ne.0) then
         segsup icpr
         segdes mpova2
      endif
      return
      end