C REDUMO SOURCE CHAT 11/03/16 21:30:34 6902 SUBROUTINE REDUMO (IPMODL,IMEL, IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) *______________________________________________________________________ * * REDU D'UN MODELE SUR MELEME (APPELE PAR REDU) * * ENTREES : * --------- * IPMODL MODELE A REDUIRE (TYPE MMODEL) * IMEL MAILLAGE SUR LEQUEL ON DOIT REDUIRE (TYPE MELEME) * * SORTIE : * -------- * IRET MODELE REDUIT * = 0 SI PB * * REMARQUE : ON SE LIMITE A NE POUVOIR REDUIRE UN MODELE QUE SUR * ---------- UN MAILLAGE POUR LEQUEL TOUS SES ELEMENTS "ADHERENT" * AU MODELE ET DE PLUS IL FAUT QU'A CHAQUE SOUS ZONE * DU MAILLAGE IMEL CORRESPONDE UNE SOUS ZONE DANS LE * MODELE (IE UNE SOUS ZONE DU MAILLAGE IMEL NE PEUT * ETRE "A CHEVAL" SUR PLUSIEURS SOUS ZONES DU MODELE) * * limitation levee par degay * si le maillage est a cheval sur plusieurs sous zones * on le tronconne en autant de morceaux * * PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 05 11 90 * *______________________________________________________________________ * -INC CCOPTIO * -INC SMCOORD -INC SMELEME -INC SMMODEL * SEGMENT ICPR(NPT) SEGMENT ICOM(NBEL) SEGMENT ITRA1 INTEGER ICC (IA+1) ENDSEGMENT segment itra2 INTEGER IRE(ima) ENDSEGMENT LOGICAL INIT,DEJA * IRET=0 * DEJA = .FALSE. * MMODEL = IPMODL SEGACT MMODEL SEGINI,MMODE1=MMODEL NSOUS=KMODEL(/1) * * FABRICATION DE ICPR QUI DIRA SI UN POINT DU MODELE EST TOUCHE PAR * LE MAILLAGE IMEL ET SUR COMBIEN D'ELEMENTS ON VA TRAVAILLER PAR TYPE * D'ELEMENTS * NPT = XCOOR(/1)/(IDIM+1) ICPR = 0 * * on duplique le maillage pour pouvoir le modifier si besoin est IPT1 = IMEL SEGACT,IPT1 NBSOU1=IPT1.LISOUS(/1) MELEME = IPT1 * * BOUCLE CONDITIONNNELLE SUR LES SOUS ZONES DU MAILLAGE IMEL * IBOU1 = 0 NS01 = 0 * 1 CONTINUE IBOU1 = IBOU1 + 1 IF(NBSOU1.NE.0) THEN MELEME = IPT1.LISOUS(IBOU1) ENDIF SEGACT MELEME * * NNNT :NB D'ELEMENTS DE IMEL POUR LA SOUS ZONE CONSIDEREE NNNT=NUM(/2) * * Creation ou remise a zero du segment ICPR IF (ICPR.EQ.0) THEN SEGINI,ICPR ELSE DO i = 1, NPT ICPR(i) = 0 ENDDO ENDIF * * CREATION D'UNE NUMEROTATION LOCALE * IA=0 DO 3 J=1,NNNT DO 3 K=1,NUM(/1) ID=NUM(K,J) IF(ICPR(ID).NE.0) GO TO 3 IA=IA+1 ICPR(ID)=IA 3 CONTINUE * * FABRICATION DE ITRA1 puis 2 : * ICC DONNE LE NOMBRE D'ELEMENTS touchant le i eme noeud local * SEGINI ITRA1 DO 8 J=1,NNNT DO 8 K=1,NUM(/1) ID=ICPR(NUM(K,J)) ICC(ID)=ICC(ID)+1 8 CONTINUE * * fabrication de ire stocker les elements touchant le noeud i * igt=icc(1) DO 80 j=2,ia if( igt.lt.icc(j) ) igt = icc(j) icc(j)=icc(j)+icc(j-1) 80 CONTINUE ima = icc(ia) icc(ia+1) = ima * write(6,*) 'taille de ire ', ima, ia,igt segini itra2 do 81 j=1,NNNT DO 81 k=1,num(/1) id=icpr(num(k,j)) ie = icc(id) icc(id)=icc(id)-1 ire(ie)= j 81 CONTINUE * * IL FAUT MAINTENANT REGARDER SI DANS UNE SOUS ZONE IMODEL IL * EXISTE LES ELEMENTS DE LA SOUS ZONE DU MELEME IMEL * BOUCLE SUR LES SOUS ZONES DU MODELE * IFLAG=0 IMOD1=0 DO 10 I=1,KMODEL(/1) SEGACT MELEME * write(6,*) ' boucle 10 ibou1 i', ibou1, i IMODEL=KMODEL(I) SEGACT IMODEL IPT2=IMAMOD SEGACT IPT2 * IF(ITYPEL.NE.IPT2.ITYPEL) GO TO 11 * INIT=.FALSE. NBEL = NUM(/2) SEGINI ICOM * ICO=0 NBEL2=IPT2.NUM(/1) DO 12 K=1,IPT2.NUM(/2) DO 13 L=1,NBEL2 ID=IPT2.NUM(L,K) IDD = ICPR(ID) IF(IDD.EQ.0) GO TO 12 13 CONTINUE * ID =IPT2.NUM(1,K) IDD=ICPR(ID) IDE=ICC(IDD)+1 * * OK L'ELEMENT K POSSEDE SES NOEUDS DANS IMEL * IF(ITYPEL.EQ.1) THEN IRE1=IRE(ide) GOTO 20 ENDIF * * CES NOEUDS CORRESPONDENT-T-ILS A UN MEME ELEMENT IRE1 * IDF=ICC(IDD+1) DO 14 L=IDE,IDF IRE1=IRE(L) DO 15 M=2,NBEL2 IDD2=ICPR(IPT2.NUM(M,K)) IF(IDD2.EQ.0) GO TO 12 IDE2=ICC(IDD2)+1 IDF2=ICC(IDD2+1) DO 16 N=IDE2,IDF2 IF(IRE(N).EQ.IRE1) GO TO 15 16 CONTINUE GO TO 14 15 CONTINUE * * ON A TROUVE UN ELEMENT COMMUN AUX 2 MAILLAGES * GOTO 20 14 CONTINUE * GOTO 12 * 20 CONTINUE IF (.NOT.INIT) INIT=.TRUE. IFLAG=1 ICOM(IRE1)=1 ICO=ICO+1 12 CONTINUE * IF (INIT) THEN * * LE NB D'ELEMENTS EST-IL EGAL POUR LA SOUS ZONE IMEL ET * LA SOUS ZONE DU MODELE * * print *, 'element en commun' ,'ico=',ico,'nnnt=',nnnt IF (ICO.EQ.NNNT) THEN NS01=NS01+1 IMOD1=IMOD1+1 SEGINI,IMODE1=IMODEL C Dans le cas DARCY on ignore la table de préconditionnement afin de C pouvoir la recalculer correctement par la suite NFOR=IMODE1.FORMOD(/2) 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)) & IMODE1.INFMOD(2)=0 MMODE1.KMODEL(NS01)=IMODE1 IMODE1.IMAMOD=MELEME C* Cas particulier : Elements type XFEM IF (NUMMFR(IMODE1.NEFMOD).EQ.63) & CALL PARTXR(IMODEL,0,IMODE1) * write(6,*) ' meleme imamod ' , meleme * SEGDES IMODE1 ELSE * * IL FAUT SCINDER LE SOUS MAILAGE EN DEUX * * creation des deux maillages dont l'union est le maillage meleme NBNN = NUM(/1) NBELEM = ICO NBREF = 0 NBSOUS = 0 SEGINI IPT3 NBELEM = NUM(/2) - ICO SEGINI IPT4 IPT3.ITYPEL = ITYPEL IPT4.ITYPEL = ITYPEL I3 = 0 I4 = 0 DO 25 II=1,NUM(/2) IF (ICOM(II) .EQ. 1) THEN * l'element est commun aux deux maillages I3=I3+1 IPT3.ICOLOR(I3)=ICOLOR(II) DO 23 JJ=1,NUM(/1) IPT3.NUM(JJ,I3)=NUM(JJ,II) 23 CONTINUE ELSE * l'element appartient seulement a meleme I4=I4+1 IPT4.ICOLOR(I4)=ICOLOR(II) DO 24 JJ=1,NUM(/1) IPT4.NUM(JJ,I4)=NUM(JJ,II) 24 CONTINUE ENDIF 25 CONTINUE * * modification de ipt1 * NBREF=0 NBELEM=0 NBNN=0 IF (IPT1.LISOUS(/1) .EQ. 0) THEN NBSOUS=2 SEGINI IPT5 IPT5.LISOUS(1)=IPT3 IPT5.LISOUS(2)=IPT4 SEGDES IPT1 IPT1=IPT5 ELSE IF (.NOT. DEJA) THEN SEGINI,IPT5=IPT1 SEGDES IPT1 IPT1 = IPT5 ENDIF NBSOUS=IPT1.LISOUS(/1)+1 SEGADJ IPT1 IPT1.LISOUS(IBOU1)=IPT3 IPT1.LISOUS(NBSOUS)=IPT4 SEGDES MELEME ENDIF IBOU1=IBOU1-1 NBSOU1=NBSOUS NS01=NS01-IMOD1 SEGDES IMODEL SEGSUP ICOM,ITRA1,ITRA2 GOTO 1 * ENDIF ENDIF SEGSUP ICOM 11 CONTINUE SEGDES IMODEL 10 CONTINUE * SEGSUP,ITRA1,ITRA2 SEGDES,MELEME,IPT2 IF (IFLAG.EQ.0) THEN * * ON N'A PAS TROUVE DE SOUS ZONE DANS LE MODELE QUI COR- * RESPONDENT A UNE SOUS ZONE DE IMEL * MOTERR(1:8)='MAILLAGE' MOTERR(9:16)='MODELE' CALL ERREUR(135) SEGDES,IPT1 SEGSUP MMODE1 GOTO 901 ENDIF * * FIN DE LA BOUCLE SUR LES SOUS ZONES DU MAILLAGE * * print *, 'nbsou1=' , 'ibou1=' ,ibou1 IF (IBOU1 .LT. NBSOU1 ) GOTO 1 * SEGDES IPT1 IF(NS01.NE.NSOUS) THEN N1=NS01 SEGADJ,MMODE1 ENDIF IRET=MMODE1 900 CONTINUE SEGDES,MMODE1 901 CONTINUE SEGDES,MMODEL C- Un peu de menage IF (ICPR.GT.0) SEGSUP,ICPR RETURN END