C RAFF3D SOURCE CHAT 11/03/16 21:30:04 6902 SUBROUTINE RAFF3D(IPT2,ICPR,KARPOS,KARETE,KMILIE,MELVA2,NACREE, .KARAF,IPT4,JPLANS,JPLAN3,JPLCOM,JNOEFA,IPT7,JFARAF,KARET2) IMPLICIT REAL*8(A-H,O-Z) IMPLICIT INTEGER(I-N) -INC CCOPTIO -INC SMCOORD -INC CCGEOME -INC SMELEME -INC SMCHPOI -INC SMMODEL -INC SMCHAML C C====================================================================== C Declarations C====================================================================== SEGMENT ICPR((XCOOR(/1)/(IDIM+1)),2) SEGMENT KARETE(NBNDS,NCOL) SEGMENT KARET2(NBNDS,NCOL) SEGMENT KMILIE(NBNDS,NCOL) SEGMENT KARPOS(NBNDS) SEGMENT JPLANS(JPLA1,JPLA2) SEGMENT JPLAN3(JPLA1,JPLA2) SEGMENT JPLCOM(JPLA1) SEGMENT JNOEFA(JNBFA,5) SEGMENT JFARAF(JNBFA,LLLL) SEGMENT NUMNOE(INUMNO) SEGMENT IWORK2(JNBSOM) SEGMENT IWORK1(IJKLMN) REAL*8 LON68,LON510,LON47,LON29 C C====================================================================== C Initialisations C====================================================================== SEGACT JPLANS,JPLCOM,JNOEFA,JPLAN3*MOD SEGACT IPT2,ICPR,KARPOS,KARETE,KMILIE*MOD,MELVA2,JFARAF*MOD IJKLMN=4 ipt7=0 SEGINI IWORK1 IWORK1(1)=4 IWORK1(2)=8 IWORK1(3)=6 IWORK1(4)=10 C JNBFA=JNOEFA(/1) C LLLL=2 C IF (IPT2.ITYPEL.EQ.15) LLLL=10 C IF ((IPT2.ITYPEL.EQ.17).OR.(IPT2.ITYPEL.EQ.24)) LLLL=6 C LLLL=10 C SEGINI JFARAF NCOMPL=LNELM(1,(IPT2.ITYPEL-1)*2+2) IF (NCOMPL.NE.0) GOTO 999 NBNN=NBNNE(LNELM(2,(IPT2.ITYPEL-1)*2+1)) INELM=LNELM(1,(IPT2.ITYPEL-1)*2+1) C C Creation du squelette du maillage resultat NBELEM=IPT2.NUM(/2)-KARAF+INELM*KARAF NBSOUS=0 NBREF=0 SEGINI IPT4 IPT4.ITYPEL=LNELM(2,(IPT2.ITYPEL-1)*2+1) LPO2=LPOS2(IPT2.ITYPEL) NBPT0=XCOOR(/1)/(IDIM+1) NBPT1=XCOOR(/1)/(IDIM+1) NBPTS=NBPT1+NACREE+KARAF*NBINTE(IPT2.ITYPEL) SEGADJ MCOORD INUMNO=NBRAF(IPT2.ITYPEL) SEGINI NUMNOE LCOMP=1 C C====================================================================== C Phase de raffinement 3D C====================================================================== C======================================= C A) Boucle sur les elements a raffiner ! C======================================= DO 6 IARAF=1,MELVA2.VELCHE(/2) IF (MELVA2.VELCHE(1,IARAF).NE.1) THEN DO 1 IJKL=1,IPT2.NUM(/1) IPT4.NUM(IJKL,NBELEM)=IPT2.NUM(IJKL,IARAF) 1 CONTINUE NBELEM=NBELEM-1 GOTO 6 ENDIF JCOMPT=0 JPOS5=LPOS5(IPT2.ITYPEL) C C========================================================== C B) Boucle sur les noeuds a creer pour raffiner l'element ! C========================================================== DO 4 I=1,NBRAF(IPT2.ITYPEL) JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1) JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1) JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT LTYPNO=JTYPNO(JPOS5-1+I) C C------------------------------- C ** B.1 / On est sur une arete ! C------------------------------- IF (LTYPNO.EQ.0) THEN NPTA=IPT2.NUM(LISNOE(JLISN),IARAF) NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF) NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) DO 2 K=1,MAX(1,KARPOS(NMIN)) IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K 2 CONTINUE IF (KMILIE(NMIN,NEXIST).GT.0) THEN NUMNOE(I)=KMILIE(NMIN,NEXIST) JCOMPT=JCOMPT+JLONG GOTO 4 ELSE NBPT1=NBPT1+1 NUMNOE(I)=NBPT1 KMILIE(NMIN,NEXIST)=NBPT1 ENDIF C C------------------------------ C ** B.2 / On est sur une face ! C------------------------------ C Il faut identifier cette face (numero, sommets...) ELSEIF ((LTYPNO.GT.0).AND.(LTYPNO.LT.7)) THEN C => a) On initialise toutes les donnees relatives a cette face JTYPEL=IPT2.ITYPEL JLTEL2=LTEL(1,JTYPEL)-1+LTYPNO JLTEL2=LTEL(2,JTYPEL)-1+LTYPNO JLDEL1=LDEL(1,JLTEL2) JTYFAC=IWORK1(JLDEL1) JLDEL2=LDEL(2,JLTEL2) JNBSOM=NBSOM(JTYFAC) JSPOS=NSPOS(JTYFAC) C => b) On identifie les sommets de la face (n° global) SEGINI IWORK2 DO 10 IAA=1,JNBSOM NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),IARAF) IWORK2(IAA)=NGLOBA 10 CONTINUE C => c) On classe ces sommets par ordre croissant (NPTA < NPTB < NPTC) NPTA=(XCOOR(/1)/(IDIM+1))+1 NPTB=NPTA+1 NPTC=NPTB+1 DO 11 ICC=1,JNBSOM IF (IWORK2(ICC).LT.NPTA) THEN NPTC=NPTB NPTB=NPTA NPTA=IWORK2(ICC) ELSEIF (IWORK2(ICC).LT.NPTB) THEN NPTC=NPTB NPTB=IWORK2(ICC) ELSEIF (IWORK2(ICC).LT.NPTC) THEN NPTC=IWORK2(ICC) ENDIF 11 CONTINUE C => d) On passe ces sommets en n° locale NPTA2=ICPR(NPTA,1) NPTB2=ICPR(NPTB,1) NPTC2=ICPR(NPTC,1) IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN NPTA=NPTA2 NPTB=MIN(NPTB2,NPTC2) NPTC=MAX(NPTB2,NPTC2) ENDIF IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN NPTA=NPTB2 NPTB=MIN(NPTA2,NPTC2) NPTC=MAX(NPTA2,NPTC2) ENDIF IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN NPTA=NPTC2 NPTB=MIN(NPTA2,NPTB2) NPTC=MAX(NPTA2,NPTB2) ENDIF C => e) On cherche le numero de la face NEXIS2=0 DO 12 IEE=1,JPLCOM(NPTA) MTMP=JPLANS(NPTA,IEE) JJ1=JNOEFA(MTMP,1) JJ2=JNOEFA(MTMP,2) JJ3=JNOEFA(MTMP,3) IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN NEXIS2=IEE ENDIF 12 CONTINUE JNUMFA=JPLANS(NPTA,NEXIS2) C C--------------------------------- C ** B.3 / Raffinement de la face ! C--------------------------------- KTEST1=JPLAN3(NPTA,NEXIS2) KTEST2=NBINTE(JTYFAC) C => a) Si la face est de type QUA4 (un seul noeud a creer, au milieu) IF (JTYFAC.EQ.8) THEN IF (KTEST1.LT.KTEST2) THEN NBPT1=NBPT1+1 NUMNOE(I)=NBPT1 JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1 JFARAF(JNUMFA,1)=NBPT1 ELSEIF (KTEST1.EQ.KTEST2) THEN NUMNOE(I)=JFARAF(JNUMFA,1) JFARAF(JNUMFA,1)=0 JCOMPT=JCOMPT+JLONG GOTO 4 ELSE WRITE(*,*) 'ERREUR' ENDIF ENDIF C => b) Si la face n'est pas de type QUA4 (donc de type TRI6 ou QUA8) IF (JTYFAC.NE.8) THEN IF (KTEST1.LT.KTEST2) THEN NBPT1=NBPT1+1 NUMNOE(I)=NBPT1 JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1 NEXIS3=0 XCO2=0.25 DO 13 KBB=1,JLONG XCO1=XCOEFF(JPOS1-1+KBB) IF (XCO1.EQ.XCO2) NEXIS3=KBB 13 CONTINUE JFARAF(JNUMFA,2*(KTEST1)+1)=NBPT1 IF (NEXIS3.NE.0) THEN NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF) JFARAF(JNUMFA,2*(KTEST1)+2)=NGLOB ELSE JFARAF(JNUMFA,2*(KTEST1)+2)=0 ENDIF ELSEIF (KTEST1.EQ.KTEST2) THEN NEXIS3=0 NEXIS4=0 XCO2=0.25 DO 14 KBB=1,JLONG XCO1=XCOEFF(JPOS1-1+KBB) IF (XCO1.EQ.XCO2) NEXIS3=KBB 14 CONTINUE IF (NEXIS3.NE.0) THEN NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF) DO 15 KAA=2,JFARAF(/2),2 IF (JFARAF(JNUMFA,KAA).EQ.NGLOB) NEXIS4=KAA 15 CONTINUE NUMNOE(I)=JFARAF(JNUMFA,NEXIS4-1) JFARAF(JNUMFA,NEXIS4-1)=0 ELSE DO 16 KAA=2,JFARAF(/2),2 IF (JFARAF(JNUMFA,KAA).EQ.0) NEXIS4=KAA 16 CONTINUE NUMNOE(I)=JFARAF(JNUMFA,NEXIS4-1) JFARAF(JNUMFA,NEXIS4-1)=0 ENDIF JCOMPT=JCOMPT+JLONG GOTO 4 ENDIF ENDIF C C------------------------------------------------------ C ** B.4 / On est a l'interieur du volume de l'element ! C------------------------------------------------------ ELSEIF (LTYPNO.EQ.7) THEN NBPT1=NBPT1+1 NUMNOE(I)=NBPT1 ENDIF C IF (NBPT1.EQ.NBPTS) THEN NBPTS=NBPTS+200 SEGADJ MCOORD ENDIF C C============================== C C) Creation du nouveau point ! C============================== C On continue ici que lorsque l'on doit creer un nouveau point XPT=0. YPT=0. ZPT=0. DO 3 J=1,JLONG NGLOB=IPT2.NUM(LISNOE(JLISN-1+J),IARAF) XINI=XCOOR((NGLOB-1)*(IDIM+1)+1) YINI=XCOOR((NGLOB-1)*(IDIM+1)+2) ZINI=XCOOR((NGLOB-1)*(IDIM+1)+3) XPT=XPT+XINI*XCOEFF(JPOS1-1+J) YPT=YPT+YINI*XCOEFF(JPOS1-1+J) ZPT=ZPT+ZINI*XCOEFF(JPOS1-1+J) 3 CONTINUE XCOOR((NBPT1-1)*(IDIM+1)+1)=XPT XCOOR((NBPT1-1)*(IDIM+1)+2)=YPT XCOOR((NBPT1-1)*(IDIM+1)+3)=ZPT JCOMPT=JCOMPT+JLONG 4 CONTINUE JPOS4=LPOS4(IPT2.ITYPEL) C C Cas des tetraedres LONDIA=0 JTYPEL=IPT2.ITYPEL IF (JTYPEL.EQ.23) THEN LPT6=NUMNOE(6) LPT5=NUMNOE(5) LPT8=NUMNOE(8) LPT10=NUMNOE(10) XPT6=XCOOR((LPT6-1)*(IDIM+1)+1) XPT5=XCOOR((LPT5-1)*(IDIM+1)+1) XPT8=XCOOR((LPT8-1)*(IDIM+1)+1) XPT10=XCOOR((LPT10-1)*(IDIM+1)+1) YPT6=XCOOR((LPT6-1)*(IDIM+1)+2) YPT5=XCOOR((LPT5-1)*(IDIM+1)+2) YPT8=XCOOR((LPT8-1)*(IDIM+1)+2) YPT10=XCOOR((LPT10-1)*(IDIM+1)+2) ZPT6=XCOOR((LPT6-1)*(IDIM+1)+3) ZPT5=XCOOR((LPT5-1)*(IDIM+1)+3) ZPT8=XCOOR((LPT8-1)*(IDIM+1)+3) ZPT10=XCOOR((LPT10-1)*(IDIM+1)+3) LON68=SQRT((XPT8-XPT6)**2+(YPT8-YPT6)**2+(ZPT8-ZPT6)**2) LON510=SQRT((XPT10-XPT5)**2+(YPT10-YPT5)**2+(ZPT10-ZPT5)**2) IF (LON510.LT.LON68) LONDIA=4*4 ENDIF IF (JTYPEL.EQ.24) THEN LPT2=NUMNOE(2) LPT4=NUMNOE(4) LPT7=NUMNOE(7) LPT9=NUMNOE(9) XPT2=XCOOR((LPT2-1)*(IDIM+1)+1) XPT4=XCOOR((LPT4-1)*(IDIM+1)+1) XPT7=XCOOR((LPT7-1)*(IDIM+1)+1) XPT9=XCOOR((LPT9-1)*(IDIM+1)+1) YPT2=XCOOR((LPT2-1)*(IDIM+1)+2) YPT4=XCOOR((LPT4-1)*(IDIM+1)+2) YPT7=XCOOR((LPT7-1)*(IDIM+1)+2) YPT9=XCOOR((LPT9-1)*(IDIM+1)+2) ZPT2=XCOOR((LPT2-1)*(IDIM+1)+3) ZPT4=XCOOR((LPT4-1)*(IDIM+1)+3) ZPT7=XCOOR((LPT7-1)*(IDIM+1)+3) ZPT9=XCOOR((LPT9-1)*(IDIM+1)+3) LON47=SQRT((XPT7-XPT4)**2+(YPT7-YPT4)**2+(ZPT7-ZPT4)**2) LON29=SQRT((XPT9-XPT2)**2+(YPT9-YPT2)**2+(ZPT9-ZPT2)**2) IF (LON29.LT.LON47) LONDIA=4*10 ENDIF C C=================================== C D) Creation des nouveaux elements ! C=================================== C On remplit la portion de IPT4 relative aux elements crees a partir C de la division de l'element IARAF (indice de boucle 1). C Cette portion de IPT4 contient les colonnes dont la valeur s'etend C de INELM*(LCOMP-1)+1 a INELM*LCOMP. DO 5 J=1,INELM DO 5 I=1,IPT4.NUM(/1) NTEMP=LIELM(JPOS4-1+NBNN*(J-1)+I) IF (((JTYPEL.EQ.23).OR.(JTYPEL.EQ.24)).AND.(J.GT.4)) THEN NTEMP=LIELM(JPOS4-1+NBNN*(J-1)+I+LONDIA) ENDIF IF (NTEMP.GT.NBNN) THEN IPT4.NUM(I,INELM*(LCOMP-1)+J)=NUMNOE(NTEMP-NBNN) ELSE IPT4.NUM(I,INELM*(LCOMP-1)+J)=IPT2.NUM(NTEMP,IARAF) ENDIF 5 CONTINUE LCOMP=LCOMP+1 6 CONTINUE C NBPTS=NBPT1 SEGADJ MCOORD C C======================================================================= C Preparation du maillage de relations C======================================================================= C================================== C A) Relations dues aux faces (3D) ! C================================== C Tous les noeuds qui restent dans JFARAF sont a creer en tant que C relations de conformite C--------------------------------- C ** A.1 / Initialisation de IPT5 ! C--------------------------------- C 1/ Comptage du nombre de noeuds soumis a des relations NBRELA=0 DO 114 IHF=1,JFARAF(/1) IF (JNOEFA(IHF,5).EQ.0) GOTO 114 IF (JFARAF(IHF,1).EQ.0) GOTO 114 DO 113 JF=1,JFARAF(/2),2 IF (JFARAF(IHF,JF).NE.0) NBRELA=NBRELA+1 113 CONTINUE 114 CONTINUE C C 2/ Creation de IPT5 IF (NBRELA.EQ.0) THEN IPT5=0 GOTO 210 ENDIF C IF (IPT2.ITYPEL.EQ.14) NBNN=4 C IF (IPT2.ITYPEL.EQ.15) NBNN=8 C IF (IPT2.ITYPEL.EQ.17) NBNN=5 C IF (IPT2.ITYPEL.EQ.24) NBNN=5 NBNN=10 NBELEM=NBRELA NBSOUS=0 NBREF=0 SEGINI IPT5 IPT5.ITYPEL=48 C C 3/ Renseignement des noeuds support des relations NBRELA=0 DO 116 IPF=1,JFARAF(/1) IF (JNOEFA(IPF,5).EQ.0) GOTO 116 IF (JFARAF(IPF,1).EQ.0) GOTO 116 DO 115 JF=1,JFARAF(/2),2 IF (JFARAF(IPF,JF).EQ.0) GOTO 115 NBRELA=NBRELA+1 IPT5.NUM(1,NBRELA)=JFARAF(IPF,JF) 115 CONTINUE 116 CONTINUE C C----------------------------------------------------- C ** A.2 / Recherche des noeuds formant les relations ! C----------------------------------------------------- C 1/ Boucle sur l'ensemble des noeuds a creer DO 200 IARAF=1,MELVA2.VELCHE(/2) IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 200 JCOMPT=0 JPOS5=LPOS5(IPT2.ITYPEL) DO 190 I=1,NBRAF(IPT2.ITYPEL) JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1) JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1) JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT LTYPNO=JTYPNO(JPOS5-1+I) IF ((LTYPNO.EQ.0).OR.(LTYPNO.EQ.7)) GOTO 189 C C 2/ Preparation pour trouver le noeud et la face en question JTYPEL=IPT2.ITYPEL JLTEL2=LTEL(2,JTYPEL)-1+LTYPNO JLDEL1=LDEL(1,JLTEL2) JTYFAC=IWORK1(JLDEL1) JLDEL2=LDEL(2,JLTEL2) JNBSOM=NBSOM(JTYFAC) JSPOS=NSPOS(JTYFAC) SEGINI IWORK2 C C 3/ Classement des 3 sommets par ordre croissant de n° globale DO 100 IAA=1,JNBSOM NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),IARAF) IWORK2(IAA)=NGLOBA 100 CONTINUE NPTA=(XCOOR(/1)/(IDIM+1))+1 NPTB=NPTA+1 NPTC=NPTB+1 DO 110 ICC=1,JNBSOM IF (IWORK2(ICC).LT.NPTA) THEN NPTC=NPTB NPTB=NPTA NPTA=IWORK2(ICC) ELSEIF (IWORK2(ICC).LT.NPTB) THEN NPTC=NPTB NPTB=IWORK2(ICC) ELSEIF (IWORK2(ICC).LT.NPTC) THEN NPTC=IWORK2(ICC) ENDIF 110 CONTINUE C C 4/ Classement des 3 sommets par ordre croissant de n° locale NPTA2=ICPR(NPTA,1) NPTB2=ICPR(NPTB,1) NPTC2=ICPR(NPTC,1) IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN NPTA=NPTA2 NPTB=MIN(NPTB2,NPTC2) NPTC=MAX(NPTB2,NPTC2) ENDIF IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN NPTA=NPTB2 NPTB=MIN(NPTA2,NPTC2) NPTC=MAX(NPTA2,NPTC2) ENDIF IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN NPTA=NPTC2 NPTB=MIN(NPTA2,NPTB2) NPTC=MAX(NPTA2,NPTB2) ENDIF C C 5/ Recherche du numero de la face NEXIS2=0 DO 120 IEE=1,JPLCOM(NPTA) MTMP=JPLANS(NPTA,IEE) JJ1=JNOEFA(MTMP,1) JJ2=JNOEFA(MTMP,2) JJ3=JNOEFA(MTMP,3) IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN NEXIS2=IEE ENDIF 120 CONTINUE JNUMFA=JPLANS(NPTA,NEXIS2) C C 6/ Recherche du numero global du point IF (JNOEFA(JNUMFA,5).EQ.0) GOTO 189 IF (JTYFAC.EQ.8) INOEGL=JFARAF(JNUMFA,1) IF (JTYFAC.NE.8) THEN NEXIS3=0 NEXIS4=0 XCO2=0.25 DO 140 KBB=1,JLONG XCO1=XCOEFF(JPOS1-1+KBB) IF (XCO1.EQ.XCO2) NEXIS3=KBB 140 CONTINUE IF (NEXIS3.NE.0) THEN NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF) DO 150 KAA=2,JFARAF(/2),2 IF (JFARAF(JNUMFA,KAA).EQ.NGLOB) NEXIS4=KAA 150 CONTINUE INOEGL=JFARAF(JNUMFA,NEXIS4-1) ELSE DO 160 KAA=2,JFARAF(/2),2 IF (JFARAF(JNUMFA,KAA).EQ.0) NEXIS4=KAA 160 CONTINUE INOEGL=JFARAF(JNUMFA,NEXIS4-1) ENDIF ENDIF C C------------------------------ C ** A.3 / Remplissage de IPT5 ! C------------------------------ C 1/ Recherche de la position du point dans IPT5 NEXIS5=0 DO 170 IGG=1,IPT5.NUM(/2) IF (INOEGL.EQ.IPT5.NUM(1,IGG)) NEXIS5=IGG 170 CONTINUE IF (NEXIS5.EQ.0) GOTO 189 C C 2/ Renseignement des points formant les relations DO 180 IHH=1,JLONG IPT5.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF) 180 CONTINUE IF (JLONG.EQ.4) IPT5.NUM(10,NEXIS5)=3 IF (JLONG.EQ.5) IPT5.NUM(10,NEXIS5)=4 IF (JLONG.EQ.8) THEN IF (JPOS1.EQ.16) IPT5.NUM(10,NEXIS5)=5 IF (JPOS1.EQ.24) IPT5.NUM(10,NEXIS5)=6 ENDIF 189 CONTINUE JCOMPT=JCOMPT+JLONG 190 CONTINUE 200 CONTINUE 210 CONTINUE C C=================================== C B) Relations dues aux aretes (2D) ! C=================================== C On cree un maillage IPT6 contenant tous les noeuds soumis a des C relations C SEGSUP KARET2 NBNDS=KARETE(/1) NCOL=KARETE(/2) SEGINI KARET2 ILPL=LPL(IPT2.ITYPEL) ILPT=LPT(IPT2.ITYPEL) DO 317 J=1,IPT4.NUM(/2) DO 317 K=1,ILPL*2-1,2 NPTA=IPT4.NUM(KSEGM(ILPT+K-1),J) NPTB=IPT4.NUM(KSEGM(ILPT+K),J) IF((NPTA.GT.NBPT0).OR.(NPTB.GT.NBPT0)) THEN GOTO 317 ENDIF NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) NEXIST=0 DO 316 I=1,MAX(1,KARPOS(NMIN)) IF (KARETE(NMIN,I).EQ.NMAX) THEN KARET2(NMIN,I)=KARET2(NMIN,I)+1 ENDIF 316 CONTINUE 317 CONTINUE C 1/ Comptage du nombre de noeuds soumis a des relations NBELEM=0 DO 27 J=1,KMILIE(/2) DO 27 I=1,KMILIE(/1) IF (KARET2(I,J).EQ.0) GOTO 27 IF (KMILIE(I,J).GT.0) NBELEM=NBELEM+1 27 CONTINUE C C 2/ Creation de IPT6 IPT6=0 IF (NBELEM.EQ.0) GOTO 999 NBNN=5 NBREF=0 NBSOUS=0 SEGINI IPT6 IPT6.ITYPEL=48 C C 3/ Renseignement des noeuds support des relations DO 28 J=1,KMILIE(/2) DO 28 I=1,KMILIE(/1) IF (KARET2(I,J).EQ.0) GOTO 28 IF (KMILIE(I,J).GT.0) THEN NBREF=NBREF+1 IPT6.NUM(1,NBREF)=KMILIE(I,J) ENDIF 28 CONTINUE C C 4/ Recherche des noeuds formant les relations DO 24 IARAF=1,MELVA2.VELCHE(/2) IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 24 JCOMPT=0 JPOS5=LPOS5(IPT2.ITYPEL) DO 23 I=1,NBRAF(IPT2.ITYPEL) JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1) JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1) JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT LTYPNO=JTYPNO(JPOS5-1+I) IF (LTYPNO.NE.0) GOTO 22 NPTA=IPT2.NUM(LISNOE(JLISN),IARAF) NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF) NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1)) NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1)) DO 29 K=1,MAX(1,KARPOS(NMIN)) IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K 29 CONTINUE IF (KARET2(NMIN,NEXIST).EQ.0) GOTO 22 IF (KMILIE(NMIN,NEXIST).EQ.0) GOTO 22 NEXIS5=0 DO 20 MM=1,IPT6.NUM(/2) INOEGL=KMILIE(NMIN,NEXIST) INRELA=IPT6.NUM(1,MM) IF (INOEGL.EQ.INRELA) NEXIS5=MM 20 CONTINUE C C 5/ Renseignement des noeuds formant les relations DO 21 IHH=1,JLONG IPT6.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF) 21 CONTINUE IF (JLONG.EQ.2) IPT6.NUM(5,NEXIS5)=1 IF (JLONG.EQ.3) IPT6.NUM(5,NEXIS5)=2 22 CONTINUE JCOMPT=JCOMPT+JLONG 23 CONTINUE 24 CONTINUE 444 CONTINUE C C============================================ C C) Creation du maillage de relations final ! C============================================ IF (IPT5.EQ.0) THEN IPT7=IPT6 GOTO 999 ENDIF NBELEM=IPT5.NUM(/2)+IPT6.NUM(/2) C NBNN=MAX(IPT5.NUM(/1),IPT6.NUM(/1)) NBNN=10 NBREF=0 NBSOUS=0 SEGINI IPT7 IPT7.ITYPEL=48 DO 42 NEO=1,IPT5.NUM(/2) DO 42 MOR=1,10 IPT7.NUM(MOR,NEO)=IPT5.NUM(MOR,NEO) IPT7.ICOLOR(NEO)=IPT5.ICOLOR(NEO) 42 CONTINUE NN5 = IPT5.NUM(/2) DO 43 NEO=IPT5.NUM(/2)+1,IPT6.NUM(/2)+IPT5.NUM(/2) DO 43 MOR=1,IPT6.NUM(/1) IF (MOR.LT.IPT6.NUM(/1)) THEN IPT7.NUM(MOR,NEO)=IPT6.NUM(MOR,NEO-NN5) ELSE IPT7.NUM(10,NEO)=IPT6.NUM(MOR,NEO-NN5) ENDIF IPT7.ICOLOR(NEO)=IPT6.ICOLOR(NEO-NN5) 43 CONTINUE C======================================================================= C Fin du programme C======================================================================= 999 CONTINUE RETURN END