Sources Esope | Cast3M

resour
C RESOUR    SOURCE    FANDEUR   22/01/19    21:15:14     11256          
      SUBROUTINE RESOUR(idemem,ideme0,ideme1,mrigid,if,noen,ipt8,
     >   isouci,iverif)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C **** Reconstitution de la solution complete apres un resou sur une
C **** matrice ou les relations ont ete eliminees.
C
C      erreur ou souci  si on n'arrive pas a reconstruire
C
C      si iverif=1 verification de la solution. Pour le moment pas de verification si
C      option noid car on n'a pas ku=f 
C
-INC SMRIGID
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
      SEGMENT IDEMEM(0)
      segment ideme0(idemem(/1),30)
      segment ideme1(idemem(/1),30)
C
C
C-------------------------------------------------------
C     LA SOLUTION EST CALCULEE --> ON LA MET EN FORME
 
      SEGACT IDEMEM*mod
      N=IDEMEM(/1)
c-----boucle sur les solutions
      segact mrigid
      ri6 = jrdepp
      ri2 = jrgard
      ri1 = jrelim
      DO 3 I=1,N
         IRET=IDEMEM(I)
         MCHPOI= IRET
C-----------------------
* reintroduction des inconnues supprimees
       call mucpri(mchpoi,ri6,ichp3)
       call adchpo(mchpoi,ichp3,ichp2,1.D0,1.D0)
       mchpo1=ideme1(I,if)
       call adchpo(ichp2,mchpo1,iret,1.D0,1D0)
       call dtchpo(mchpoi)
       call dtchpo(ichp3)
       call dtchpo(ichp2)
       mchpo1=iret
       segact mchpo1*mod
       mchpo1.jattri(1)=1
C -------------     deplacements  complets   puis KU
       call mucpri(mchpo1,ri2  ,ichp5)
*  separer les conditions aux limites pour etablir la reference sans condition aux limites
        segact ri2
        nrigel=ri2.irigel(/2)
**      write(6,*) ' nrigel dans resour ',nrigel
        segini ri3
        ri3.mtymat = ri2.mtymat
        ri3.iforig = ri2.iforig
        irn=0
        do ir=1,nrigel
          meleme=ri2.irigel(1,ir)
          segact meleme
          if(itypel.eq.49) then
           irn=irn+1
           ri3.coerig(irn)=ri2.coerig(ir)
           do ii=1,ri2.irigel(/1)
            ri3.irigel(ii,irn)=ri2.irigel(ii,ir)
           enddo
          endif
        enddo
***     call prrigi(ri2,0)
        nrigel=irn
***     write(6,*) ' irn dans resour ',irn
        segadj ri3
        call mucpri(mchpo1,ri3,ichp8)
        segsup ri3
       if (ierr.ne.0) return
       mchpo4=ichp5
       segact mchpo4*mod
       mchpo4.jattri(1)=1
       ichp6= ideme0(I,if)
C -------      write(6,*) ' ---------   KU - F   '
       call adchpo(ichp5,ichp6,IRET,1D0,-1D0)
       call remplx(ri1,iret,ichp7)
*  verif on a bien l'equilibre
       if (if.eq.1.and.iverif.eq.1) then
        call mucpri(ichp7,ri1,ichp3)
        if (ierr.ne.0) return
        call adchpo(iret,ichp3,ichp4,1D0,1D0)
        call dtchpo(iret)
        iptt=0
        if(noen.eq.1) iptt=ipt8
**      write(6,*) 'ichp5 ichp6 ichp8 ichp4 ',ichp5,ichp6,ichp8,ichp4
        call vechpo(ichp5,ichp6,ichp8,ichp4,ipt8,isouci)
        call dtchpo(ichp3)
        call dtchpo(ichp4)
        call dtchpo(ichp8)
       endif
       call dtchpo(ichp5)
*      call dtchpo(ichp6)
       if (ierr.ne.0) return
 
       call fuchpo(ichp7,mchpo1,iret)
       if(ierr.ne.0) return
       mchpoi=iret
*  supression des multiplicateurs dédoublés
       lagdua=imlag
       if (lagdua.gt.0) then
**      write(6,*) ' appel a dbbcf lagdua ',lagdua
        call dbbcf(mchpoi,lagdua)
        ipt1=lagdua
       endif
*     write (6,*) ' mchpoi en fi de resour'
*     call ecchpo(mchpoi,0)
*     les champs de points qui sortent sont de nature diffuse
         SEGACT MCHPOI
         NAT = MAX(1,JATTRI(/1))
         NSOUPO=IPCHP(/1)
         SEGADJ MCHPOI
         JATTRI(1)=1
         IRET = MCHPOI
         idemem(i)=iret
   3  continue
      end