Sources Esope | Cast3M

fusmod
C FUSMOD    SOURCE    OF166741  24/05/06    21:15:06     11082          
 
      SUBROUTINE FUSMOD(MODL1,MODL2,MODL)
 
*--------------------------------------------------------------------*
*                                                                    *
*     REUNION DE DEUX OBJETS MODELE                                  *
*                                                                    *
*     ENTREES/SORTIE:                                                *
*                                                                    *
*       MODL1      POINTEUR SUR LE PREMIER OBJET MODELE              *
*       MODL2      POINTEUR SUR LE SECOND OBJET MODELE               *
*       MODL       POINTEUR SUR L'OBJET MODELE RESULTAT              *
*                  = 0 SINON                                         *
*                                                                    *
*    AM   22/6/93   ON EXCLUT LA POSSIBILITE DE ZONE COMMUNE         *
*                                                                    *
*--------------------------------------------------------------------*
*
*     - UNE ZONE ELEMENTAIRE EST DITE COMMUNE AUX DEUX "MODELE" SI:
*          LES GEOMETRIES ELEMENTAIRES
*          LES NOMS DE CONSTITUANTS
*          LES NUMEROS DES TYPES D'ELEMENTS-FINIS
*          LES INFMOD
*          LES FORMULATIONS
*          LES TYPES DE MATERIAUX
*       SONT LES MEMES.
*
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
 
-INC SMMODEL
-INC SMELEME
*
C     Segment ICOPIE : indique les sous-zones (IMODEL) dupliquees
      SEGMENT ICOPIE(NCP1)
 
      CHARACTER*(LCONMO) CONM1,CONM2
      LOGICAL bXFEM, loHHO
*
*     INITIALISATION
*
      MODL=0
      MMODE1=MODL1
      MMODE2=MODL2
      SEGACT,MMODE1,MMODE2
      NMOD1=MMODE1.KMODEL(/1)
      NMOD2=MMODE2.KMODEL(/1)
*
      IF (IIMPI.EQ.666) THEN
      WRITE(IOIMP,*)'***  SOUS-PROGRAMME FUSMOD  ***'
      WRITE(IOIMP,*)'NOMBRE DE ZONES ELEMENTAIRES : ',NMOD1
      WRITE(IOIMP,*)'NOMBRE DE ZONES ELEMENTAIRES : ',NMOD2
      ENDIF
*
      DO 10 I10=1,NMOD1
*
*      BOUCLE SUR LES ZONES ELEMENTAIRES DU 1ER "MODELE"
*
       IMODE1=MMODE1.KMODEL(I10)
       SEGACT,IMODE1
       nefm1=IMODE1.NEFMOD
       ipma1=IMODE1.IMAMOD
       conm1=IMODE1.CONMOD
*
       DO 20 I20=1,NMOD2
*
*       BOUCLE SUR LES ZONES ELEMENTAIRES DU 2ND "MODELE"
*
        IMODE2=MMODE2.KMODEL(I20)
        SEGACT,IMODE2
        nefm2=IMODE2.NEFMOD
        ipma2=IMODE2.IMAMOD
        conm2=IMODE2.CONMOD
ckich quand la phase est identique et le type d element identique
c c est tout ou rien
        IF (nefm1.EQ.nefm2 .AND. conm1.EQ.conm2 .AND.
     &      imode1.formod(1).EQ.imode2.formod(1)) THEN
          iret = 0
          call interb(ipma1,ipma2,iret,iob1)
          if (iret.GT.0) goto 16
          ipt2 = ipma1
          ipt3 = ipma2
          ipt4 = iob1
          segact ipt2,ipt3,ipt4
          if (ipt2.num(/2).ne.ipt3.num(/2).or.
     &        ipt2.num(/2).ne.ipt4.num(/2)) then
             call erreur(618)
          write(6,*) ' maillages non disjoints mais phase commune '
              goto 999
          endif
        ENDIF
 16     IF (ipma1.NE.ipma2) GOTO 20
*
* ----   AM  22/6/93
*        ON VERIFIE QU'IL N'Y A PAS DE ZONE COMMUNE, C'EST A DIRE
*        QUE SI LES MAILLAGES SONT IDENTIQUES, LES CONSTITUANTS EUX
*        SONT DIFFERENTS
*
        IF (conm1.EQ.conm2) THEN
          IF (nefm1.NE.nefm2) THEN
            CALL ERREUR(618)
          ELSE
            CALL ERREUR(617)
          ENDIF
          GO TO 999
        ENDIF
* ----
 20     CONTINUE
*      END DO
 10    CONTINUE
*     END DO
*
      N1=NMOD1+NMOD2
      SEGINI,MMODEL
      MODL=MMODEL
 
c     write(6,*) ' ***** Dans FUSMOD !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!'
 
      NCP1 = N1
      SEGINI, ICOPIE
*
*     BOUCLE SUR LES ZONES GEOMETRIQUES DU 1ER "MODELE"
*
      IF (IIMPI.EQ.666) THEN
        WRITE(IOIMP,*)'***  SOUS-PROGRAMME FUSMOD  ***'
        WRITE(IOIMP,*)'BOUCLE SUR LES ZONES DU 1ER MODELE'
      ENDIF
      DO 50 IA=1,NMOD1
       IMODE1=MMODE1.KMODEL(IA)
C      SEGINI,IMODEL=imode1
       KMODEL(IA)=IMODE1
C   CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
        nfor = IMODE1.formod(/2)
c       write(6,*) ' ***** nfor =',nfor
 
        CALL PLACE (imode1.FORMOD,NFOR,IDARC,'DARCY')
        CALL PLACE (imode1.FORMOD,NFOR,IEULE,'EULER')
        CALL PLACE (imode1.FORMOD,NFOR,INAVI,'NAVIER_STOKES')
        IF ((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0)) THEN
c       write(6,*) ' ***** FUSMOD : je copie imode1' 
          SEGINI,IMODEL=imode1
          KMODEL(IA)=IMODEL
          ICOPIE(IA) = 1
          IMODEL.INFMOD(2)=0
        ENDIF
 50   CONTINUE
*     END DO
*
*     BOUCLE SUR LES ZONES GEOMETRIQUES DU 2ND "MODELE"
*
      IF (IIMPI.EQ.666) THEN
        WRITE(IOIMP,*)'***  SOUS-PROGRAMME FUSMOD  ***'
        WRITE(IOIMP,*)'BOUCLE SUR LES ZONES DU 2ND MODELE'
      ENDIF
      DO 80 IB=1,NMOD2
        IMODE2=MMODE2.KMODEL(IB)
C       SEGINI,IMODEL=imode2
        KMODEL(IB+NMOD1)=IMODE2
 
C   CAS DARCY OU NAVIER ON OUBLIE LA TABLE DE PRECONDITIONNEMENT
C   et on duplique le segment IMODE1
        nfor = IMODE2.formod(/2)
        CALL PLACE (imode2.FORMOD,NFOR,IDARC,'DARCY')
        CALL PLACE (imode2.FORMOD,NFOR,IEULE,'EULER')
        CALL PLACE (imode2.FORMOD,NFOR,INAVI,'NAVIER_STOKES')
        IF ((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0)) THEN
c       write(6,*) ' ***** FUSMOD : je copie imode2' 
          SEGINI,IMODEL=imode2
          KMODEL(IB+NMOD1)=IMODEL
          ICOPIE(IB+NMOD1) = 1
          IMODEL.INFMOD(2)=0
        ENDIF
 80   CONTINUE
*     END DO
*
999   CONTINUE
      IF (MODL.EQ.0) RETURN
*
*  on va maintenant fusionner les zones geometriques de memes caracteristiques
*
      do 100 i=1,kmodel(/1)
       imode1=kmodel(i)
c*     segact imode1
       if (imode1.eq.0) goto 100
       ipt1=imode1.imamod
       if (ipt1.eq.0) goto 100
       nefm1=imode1.nefmod
       conm1=imode1.conmod
       bXFEM = NUMMFR(nefm1).EQ.63
c*     bXFEM = imode1.infele(13).EQ.63
       segact ipt1
       ityp1=ipt1.itypel
       nbnn1=ipt1.num(/1)
       CALL HHONOB(imode1,nobhh1,iret)
       if (nobhh1.LT.0) CALL ERREUR(iret)
       loHHO = nobhh1.GT.0
c* test equivalent :       loHHO = nefm1.EQ.HHO_NUM_ELEMENT (include CHHOPA)
c* test equivalent :       loHHO = nummfr(nefm1).EQ.HHO_MFR_ELEMENT (include CHHOPA)
       do 110 j=i+1,kmodel(/1)
        imode2=kmodel(j)
        if (imode2.eq.0) goto 110
c*      segact imode2
        if (imode2.nefmod.ne.nefm1) goto 110
        if (imode2.conmod.ne.conm1) goto 110
        ipt2=imode2.imamod
        segact ipt2
        if (ipt2.itypel.ne.ityp1) goto 110
c* En cas de polygones, le itypel est le meme (32) c'est le nombre de sommets(=faces) qui va les distinguer.
        if (ipt2.num(/1).ne.nbnn1) goto 110
        if (imode2.cmatee.ne.imode1.cmatee) goto 110
**      if (imode2.infmod(/1).ne.imode1.infmod(/1)) goto 110
**      do k=1,imode1.infmod(/1)
**       if (imode2.infmod(k).ne.imode1.infmod(k)) goto 110
**      enddo
        if (imode2.formod(/2).ne.imode1.formod(/2)) goto 110
        do k=1,imode1.formod(/2)
         if (imode2.formod(k).ne.imode1.formod(k)) goto 110
        enddo
        if (imode2.matmod(/2).ne.imode1.matmod(/2)) goto 110
        do k=1,imode1.matmod(/2)
         if (imode2.matmod(k).ne.imode1.matmod(k)) goto 110
        enddo
        ipdpg1 = imode1.ipdpge
        ipdpg2 = imode2.ipdpge
        if (ipdpg2.ne.ipdpg1) then
          if (iptpoi(ipdpg2).ne.iptpoi(ipdpg1)) goto 110
        endif
        if (imode2.inatuu.ne.imode1.inatuu) goto 110
        if (imode2.lnomid(/1).ne.imode1.lnomid(/1)) goto 110
*       BP, 2016-03-25 : ajout test car en sortie de RAFF
*       on a 2 ou 3 sous modeles identiques aux noms de composantes pres
 
        IF (nefm1.eq.22) THEN
          do k=1,imode1.lnomid(/1)
           if (imode2.lnomid(k).ne.imode1.lnomid(k)) goto 110
          enddo
        ENDIF
*       GG : si deux sure de couleurs differentes pas de fusion
        IF (nefm1.eq.259) THEN
          if (ipt1.ICOLOR(1).ne.ipt2.ICOLOR(1)) goto 110
        ENDIF
        if (imode2.infele(/1).ne.imode1.infele(/1)) goto 110
        do k=1,imode1.infele(/1)
         if (imode2.infele(k).ne.imode1.infele(k)) goto 110
        enddo
        if (loHHO) then
          CALL HHONOB(imode2,nobhh2,iret)
          IF (nobhh2.LE.0) THEN
            CALL ERREUR(iret)
            RETURN
          ENDIF
          if (imode2.ivamod(nobhh2).ne.imode1.ivamod(nobhh1)) goto 110
c-dbg on pourrait verifier que contenus listenti(nobhh1+1)=listenti(nobhh2+1) sinon incoherence !
        end if
         if (.NOT. bXFEM .and. .not.loHHO) then
        if (imode2.tymode(/2).ne.imode1.tymode(/2)) goto 110
        do k=1,imode1.tymode(/2)
         if (imode2.tymode(k).ne.imode1.tymode(k)) goto 110
        enddo
        if (imode2.ivamod(/1).ne.imode1.ivamod(/1)) goto 110
        do k=1,imode1.ivamod(/1)
         if (imode2.ivamod(k).ne.imode1.ivamod(k)) goto 110
        enddo
         endif
 
*  fusion des meleme : on duplique le segment IMODE1
        IF (ICOPIE(i).EQ.0) THEN
c       write(6,*) ' ***** FUSMOD : je copie car fusion meleme ' 
          SEGINI, IMODEL = IMODE1
          KMODEL(i) = IMODEL
          IMODE1 = IMODEL
        ENDIF
        nbnn =ipt1.num(/1)
        nbel1=ipt1.num(/2)
        nbel2=ipt2.num(/2)
        nbelem=nbel1+nbel2
        nbref=0
        nbsous=0
        segini meleme
        itypel=ityp1
        do iel= 1,nbel1
          do ino=1,nbnn
            num(ino,iel)=ipt1.num(ino,iel)
          enddo
          icolor(iel)=ipt1.icolor(iel)
        enddo
        do iel =1,nbel2
          jel = iel+nbel1
          do ino =1,nbnn
            num(ino,jel)=ipt2.num(ino,iel)
          enddo
          icolor(jel)=ipt2.icolor(iel)
        enddo
        ipt1=meleme
c*      segact imode1*mod,imode2*mod
        imode1.imamod=ipt1
        IF (bXFEM) CALL FUCHXR(imode1,imode2,0)
c*      imode2.imamod=0
c*      segsup,imode2
        kmodel(j)=0
 110  continue
      IF (bXFEM) CALL PARTXR(0,ipt1,imode1)
      IF (loHHO) THEN
        CALL HHOPAR(imode1,iret)
        if (iret.ne.0) return
      END IF
 100  continue
*  desactivation & compactage du modele
      idec=0
      do 130 i=1,kmodel(/1)
        imode1=kmodel(i)
        if (imode1.eq.0) then
          idec=idec+1
        else
          kmodel(i-idec)=imode1
        endif
 130  continue
      if (idec.gt.0) then
        n1=kmodel(/1)-idec
        segadj mmodel
      endif
 
      SEGSUP,ICOPIE
 
      END