Télécharger la plaquette Cast3M


fr en

Télécharger redumo.eso

Retour à la liste

Numérotation des lignes : 

redumo

  1. C REDUMO    SOURCE    CB215821  24/04/12    21:17:06     11897          
  2.  
  3.       SUBROUTINE REDUMO (IPMODL,IMEL, IRET)
  4.  
  5.       IMPLICIT INTEGER(I-N)
  6.       IMPLICIT REAL*8(A-H,O-Z)
  7. *______________________________________________________________________
  8. *
  9. *             REDU D'UN MODELE SUR MELEME    (APPELE PAR REDU)
  10. *
  11. *    ENTREES :
  12. *    ---------
  13. *       IPMODL  MODELE A REDUIRE (TYPE MMODEL)
  14. *       IMEL    MAILLAGE SUR LEQUEL ON DOIT REDUIRE (TYPE MELEME)
  15. *
  16. *    SORTIE :
  17. *    --------
  18. *       IRET    MODELE REDUIT
  19. *               = 0 SI PB
  20. *
  21. *    REMARQUE : ON SE LIMITE A NE POUVOIR REDUIRE UN MODELE QUE SUR
  22. *    ---------- UN MAILLAGE POUR LEQUEL TOUS SES ELEMENTS "ADHERENT"
  23. *               AU MODELE ET DE PLUS IL FAUT QU'A CHAQUE SOUS ZONE
  24. *               DU MAILLAGE IMEL CORRESPONDE UNE SOUS ZONE DANS LE
  25. *               MODELE (IE UNE SOUS ZONE DU MAILLAGE IMEL NE PEUT
  26. *               ETRE "A CHEVAL" SUR PLUSIEURS SOUS ZONES DU MODELE)
  27. *
  28. *               limitation levee par degay
  29. *               si le maillage est a cheval sur plusieurs sous zones
  30. *               on le tronconne en autant de morceaux
  31. *
  32. *       PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 05 11 90
  33. *
  34. *______________________________________________________________________
  35. *
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. *
  40. -INC SMCOORD
  41. -INC SMELEME
  42. -INC SMMODEL
  43. *
  44.       SEGMENT ICPR(NPT)
  45.       SEGMENT ICOM(NBEL)
  46.       SEGMENT  ITRA1
  47.          INTEGER ICC (IA+1)
  48.       ENDSEGMENT
  49.       segment itra2
  50.          INTEGER IRE(ima)
  51.       ENDSEGMENT
  52.       LOGICAL INIT,DEJA
  53. *
  54.       IRET=0
  55. *
  56.       DEJA = .FALSE.
  57.  
  58.  
  59. * on duplique le maillage pour pouvoir le modifier si besoin est
  60.       IPT1 = IMEL
  61.       SEGACT,IPT1
  62.       NBSOU1 = IPT1.LISOUS(/1)
  63.  
  64.       NBELEM = 1
  65.       IF (NBSOU1 .EQ. 0) THEN
  66. *       Un MAILLAGE VIDE normalement constitue a un NBSOUS = 0
  67.         NBELEM=IPT1.NUM(/2)
  68.       ENDIF
  69.  
  70. * CB215821 : Reduire un MMODEL sur un MAILLAGE VIDE ==> MMODEL VIDE
  71.       IF (NBELEM .EQ. 0) THEN
  72.         N1 = 0
  73.         SEGINI,MMODE1
  74.         SEGACT,MMODE1*NOMOD,IPT1*NOMOD
  75.         IRET = MMODE1
  76.         RETURN
  77.       ENDIF
  78.       NBELEM = 0
  79.  
  80. *
  81.       MMODEL = IPMODL
  82.       SEGACT MMODEL
  83.       SEGINI,MMODE1=MMODEL
  84.       NSOUS=KMODEL(/1)
  85. * CB215821 : Reduire un MMODEL VIDE sur un MAILLAGE ==> MMODEL VIDE
  86.       IF (NSOUS .EQ. 0) THEN
  87.         SEGACT,MMODE1*NOMOD,IPT1*NOMOD
  88.         IRET = MMODE1
  89.         RETURN
  90.       ENDIF
  91.  
  92. *
  93. *  FABRICATION DE ICPR QUI DIRA SI UN POINT DU MODELE EST TOUCHE PAR
  94. *  LE MAILLAGE IMEL ET SUR COMBIEN D'ELEMENTS ON VA TRAVAILLER PAR TYPE
  95. *  D'ELEMENTS
  96. *
  97.       NPT = nbpts
  98.       ICPR = 0
  99. *
  100.  
  101.  
  102.       MELEME = IPT1
  103. *
  104. *     BOUCLE CONDITIONNNELLE SUR LES SOUS ZONES DU MAILLAGE IMEL
  105. *
  106.       IBOU1 = 0
  107.       NS01  = 0
  108. *
  109.    1  CONTINUE
  110.          IBOU1 = IBOU1 + 1
  111.          IF (NBSOU1.NE.0) THEN
  112.             MELEME = IPT1.LISOUS(IBOU1)
  113.          ENDIF
  114.          SEGACT MELEME
  115. *
  116. *        NNNT :NB D'ELEMENTS DE IMEL POUR LA SOUS ZONE CONSIDEREE
  117.          NNNT=NUM(/2)
  118. *
  119. * Creation ou remise a zero du segment ICPR
  120.         IF (ICPR.EQ.0) THEN
  121.           SEGINI,ICPR
  122.         ELSE
  123.           DO i = 1, NPT
  124.             ICPR(i) = 0
  125.           ENDDO
  126.         ENDIF
  127. *
  128. *    CREATION D'UNE NUMEROTATION LOCALE
  129. *
  130.          IA=0
  131.          DO 3 J=1,NNNT
  132.             DO 3 K=1,NUM(/1)
  133.                ID=NUM(K,J)
  134.                IF(ICPR(ID).NE.0) GO TO 3
  135.                IA=IA+1
  136.                ICPR(ID)=IA
  137.    3     CONTINUE
  138. *
  139. *        FABRICATION DE ITRA1 puis 2 :
  140. *              ICC DONNE LE NOMBRE D'ELEMENTS touchant le i eme noeud local
  141. *
  142.          SEGINI ITRA1
  143.          DO 8 J=1,NNNT
  144.             DO 8 K=1,NUM(/1)
  145.                ID=ICPR(NUM(K,J))
  146.                ICC(ID)=ICC(ID)+1
  147.     8    CONTINUE
  148. *
  149. * fabrication de ire stocker les elements touchant le noeud i
  150. *
  151.          igt=icc(1)
  152.          DO 80 j=2,ia
  153.            if( igt.lt.icc(j) ) igt = icc(j)
  154.            icc(j)=icc(j)+icc(j-1)
  155.    80    CONTINUE
  156.          ima = icc(ia)
  157.          icc(ia+1) = ima
  158. *         write(6,*) 'taille de ire ', ima, ia,igt
  159.          segini itra2
  160.          do 81 j=1,NNNT
  161.             DO 81 k=1,num(/1)
  162.                id=icpr(num(k,j))
  163.                ie = icc(id)
  164.                icc(id)=icc(id)-1
  165.                ire(ie)= j
  166.    81    CONTINUE
  167. *
  168. *        IL FAUT MAINTENANT REGARDER SI DANS UNE SOUS ZONE IMODEL IL
  169. *        EXISTE LES ELEMENTS DE LA SOUS ZONE DU MELEME IMEL
  170. *        BOUCLE SUR LES SOUS ZONES DU MODELE
  171. *
  172.          IFLAG=0
  173.          IMOD1=0
  174.          DO 10 I=1,KMODEL(/1)
  175.             SEGACT MELEME
  176. *            write(6,*) ' boucle 10 ibou1 i', ibou1, i
  177.             IMODEL=KMODEL(I)
  178.             SEGACT IMODEL
  179.             IPT2=IMAMOD
  180.             SEGACT IPT2
  181. *
  182.             IF(ITYPEL.NE.IPT2.ITYPEL) GO TO 11
  183. *
  184.             INIT=.FALSE.
  185.  
  186.             NBEL = NUM(/2)
  187.             SEGINI ICOM
  188. *
  189.             ICO=0
  190.             NBEL2=IPT2.NUM(/1)
  191.             DO 12 K=1,IPT2.NUM(/2)
  192.                DO 13 L=1,NBEL2
  193.                   ID=IPT2.NUM(L,K)
  194.                   IDD = ICPR(ID)
  195.                   IF(IDD.EQ.0) GO TO 12
  196.    13          CONTINUE
  197. *
  198.                ID =IPT2.NUM(1,K)
  199.                IDD=ICPR(ID)
  200.                IDE=ICC(IDD)+1
  201. *
  202. *              OK L'ELEMENT K POSSEDE SES NOEUDS DANS IMEL
  203. *
  204.                IF(ITYPEL.EQ.1) THEN
  205.                   IRE1=IRE(ide)
  206.                   GOTO 20
  207.                ENDIF
  208. *
  209. *              CES NOEUDS CORRESPONDENT-T-ILS A UN MEME ELEMENT IRE1
  210. *
  211.                IDF=ICC(IDD+1)
  212.                DO 14 L=IDE,IDF
  213.                   IRE1=IRE(L)
  214.                   DO 15 M=2,NBEL2
  215.                      IDD2=ICPR(IPT2.NUM(M,K))
  216.                      IF(IDD2.EQ.0) GO TO 12
  217.                      IDE2=ICC(IDD2)+1
  218.                      IDF2=ICC(IDD2+1)
  219.                      DO 16 N=IDE2,IDF2
  220.                         IF(IRE(N).EQ.IRE1) GO TO 15
  221.    16                CONTINUE
  222.                      GO TO 14
  223.    15             CONTINUE
  224. *
  225. *                 ON A TROUVE UN ELEMENT COMMUN AUX 2 MAILLAGES
  226. *
  227.                   GOTO 20
  228.    14          CONTINUE
  229. *
  230.                GOTO 12
  231. *
  232.    20          CONTINUE
  233.                IF (.NOT.INIT) INIT=.TRUE.
  234.                IFLAG=1
  235.                ICOM(IRE1)=1
  236.                ICO=ICO+1
  237.    12       CONTINUE
  238. *
  239.             IF (INIT) THEN
  240. *
  241. *              LE NB D'ELEMENTS EST-IL EGAL POUR LA SOUS ZONE IMEL ET
  242. *              LA SOUS ZONE DU MODELE
  243. *
  244. *               print *, 'element en commun' ,'ico=',ico,'nnnt=',nnnt
  245.                IF (ICO.EQ.NNNT) THEN
  246.                   NS01=NS01+1
  247.                   IF (NS01.GT.MMODE1.KMODEL(/1)) THEN
  248. **                    CALL ERREUR(845)
  249.                     write(ioimp,*) 'Elements du maillage en double ?'
  250.                     MOTERR(1:8)='MAILLAGE'
  251.                     MOTERR(9:16)='MODELE'
  252.                     CALL ERREUR(135)
  253.                     SEGACT,IPT1*NOMOD
  254.                     SEGSUP MMODE1
  255.                     GOTO 901
  256.                   ENDIF
  257.                   IMOD1=IMOD1+1
  258.                   SEGINI,IMODE1=IMODEL
  259. C    Dans le cas DARCY on ignore la table de préconditionnement afin de
  260. C    pouvoir la recalculer correctement par la suite
  261.          NFOR=IMODE1.FORMOD(/2)
  262.          CALL PLACE (IMODE1.FORMOD,NFOR,IDARC,'DARCY')
  263.          CALL PLACE (IMODE1.FORMOD,NFOR,IEULE,'EULER')
  264.          CALL PLACE (IMODE1.FORMOD,NFOR,INAVI,'NAVIER_STOKES')
  265.          IF((IDARC.NE.0).OR.(INAVI.NE.0).OR.(IEULE.NE.0))
  266.      &    IMODE1.INFMOD(2)=0
  267.                   MMODE1.KMODEL(NS01)=IMODE1
  268.                   IMODE1.IMAMOD=MELEME
  269. C* Cas particulier : Elements type XFEM
  270.                   IF (NUMMFR(IMODE1.NEFMOD).EQ.63)
  271.      &              CALL PARTXR(IMODEL,0,IMODE1)
  272. *        write(6,*) ' meleme imamod ' , meleme
  273. *
  274.                   SEGACT,IMODE1*NOMOD
  275.                ELSE
  276. *
  277. *           IL FAUT SCINDER LE SOUS MAILAGE EN DEUX
  278. *
  279. *       creation des deux maillages dont l'union est le maillage meleme
  280.                   NBNN = NUM(/1)
  281.                   NBELEM = ICO
  282.                   NBREF = 0
  283.                   NBSOUS = 0
  284.                   SEGINI IPT3
  285.                   NBELEM = NUM(/2) - ICO
  286.                   SEGINI IPT4
  287.                   IPT3.ITYPEL = ITYPEL
  288.                   IPT4.ITYPEL = ITYPEL
  289.                   I3 = 0
  290.                   I4 = 0
  291.                   DO 25 II=1,NUM(/2)
  292.                     IF (ICOM(II) .EQ. 1) THEN
  293. *                    l'element est commun aux deux maillages
  294.                      I3=I3+1
  295.                      IPT3.ICOLOR(I3)=ICOLOR(II)
  296.                      DO 23 JJ=1,NUM(/1)
  297.                         IPT3.NUM(JJ,I3)=NUM(JJ,II)
  298.    23                CONTINUE
  299.                     ELSE
  300. *                    l'element appartient seulement a meleme
  301.                      I4=I4+1
  302.                      IPT4.ICOLOR(I4)=ICOLOR(II)
  303.                      DO 24 JJ=1,NUM(/1)
  304.                         IPT4.NUM(JJ,I4)=NUM(JJ,II)
  305.    24                CONTINUE
  306.                     ENDIF
  307.    25            CONTINUE
  308. *
  309. *        modification de ipt1
  310. *
  311.                  NBREF =0
  312.                  NBELEM=0
  313.                  NBNN  =0
  314.                  IF (IPT1.LISOUS(/1) .EQ. 0) THEN
  315.                      NBSOUS=2
  316.                      SEGINI IPT5
  317.                      IPT5.LISOUS(1)=IPT3
  318.                      IPT5.LISOUS(2)=IPT4
  319.                      SEGACT,IPT1*NOMOD
  320.                      IPT1=IPT5
  321.                  ELSE
  322.                      IF (.NOT. DEJA) THEN
  323.                        SEGINI,IPT5=IPT1
  324.                        SEGACT,IPT1*NOMOD
  325.                        IPT1 = IPT5
  326.                      ENDIF
  327.                      NBSOUS=IPT1.LISOUS(/1)+1
  328.                      SEGADJ IPT1
  329.                      IPT1.LISOUS(IBOU1)=IPT3
  330.                      IPT1.LISOUS(NBSOUS)=IPT4
  331.                      SEGACT,MELEME*NOMOD
  332.                  ENDIF
  333.                  IBOU1=IBOU1-1
  334.                  NBSOU1=NBSOUS
  335.                  NS01=NS01-IMOD1
  336.                  SEGACT,IMODEL*NOMOD
  337.                  SEGSUP ICOM,ITRA1,ITRA2
  338.                  GOTO 1
  339. *
  340.                ENDIF
  341.             ENDIF
  342.             SEGSUP ICOM
  343.    11       CONTINUE
  344.             SEGACT,IMODEL*NOMOD
  345.    10    CONTINUE
  346. *
  347.          SEGSUP,ITRA1,ITRA2
  348. C         SEGDES,MELEME,IPT2
  349.  
  350.          IF (IFLAG.EQ.0) THEN
  351. *
  352. *           ON N'A PAS TROUVE DE SOUS ZONE DANS LE MODELE QUI COR-
  353. *           RESPONDENT A UNE SOUS ZONE DE IMEL
  354. *
  355. *pv         MOTERR(1:8)='MAILLAGE'
  356. *pv         MOTERR(9:16)='MODELE'
  357. *pv         CALL ERREUR(135)
  358. *pv         SEGACT,IPT1*NOMOD
  359. *pv         SEGSUP MMODE1
  360. *pv         GOTO 901
  361.          ENDIF
  362. *
  363. *     FIN DE LA BOUCLE SUR LES SOUS ZONES DU MAILLAGE
  364. *
  365. **      print *, 'nbsou1=' , 'ibou1=' ,ibou1
  366.       IF (IBOU1 .LT. NBSOU1 ) GOTO 1
  367. *
  368.       SEGACT,IPT1*NOMOD
  369. **      print *,NS01,NSOUS
  370.       IF(NS01.NE.NSOUS) THEN
  371.          N1=NS01
  372.          SEGADJ,MMODE1
  373.       ENDIF
  374.       IRET=MMODE1
  375.       SEGACT,MMODE1*NOMOD
  376.  901  CONTINUE
  377.       SEGACT,MMODEL*NOMOD
  378. C- Un peu de menage
  379.       IF (ICPR.GT.0) SEGSUP,ICPR
  380.  
  381.       END
  382.  
  383.  
  384.  
  385.  
  386.  
  387.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales