Télécharger la plaquette Cast3M


fr en

Télécharger rafpyr.eso

Retour à la liste

Numérotation des lignes : 

rafpyr

  1. C RAFPYR    SOURCE    CB215821  26/10/26    21:16:03     12682          
  2.       SUBROUTINE RAFPYR(IPT2,ICPR,KARPOS,KARETE,KMILIE,MELVA2,NACREE,
  3.      .KARAF,IPT4,JPLANS,JPLAN3,JPLCOM,JNOEFA,IPT7,JFARAF,KARET2,IPT5,
  4.      .XDEN)
  5.       IMPLICIT REAL*8(A-H,O-Z)
  6.       IMPLICIT INTEGER(I-N)
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMCOORD
  11. -INC CCGEOME
  12. -INC SMELEME
  13. -INC SMCHPOI
  14. -INC SMMODEL
  15. -INC SMCHAML
  16. C
  17. C======================================================================
  18. C                           Declarations
  19. C======================================================================
  20.       SEGMENT ICPR(nbpts,2)
  21.       SEGMENT XDEN(nbpts)
  22.       SEGMENT KARETE(NBNDS,NCOL)
  23.       SEGMENT KARET2(NBNDS,NCOL)
  24.       SEGMENT KMILIE(NBNDS,NCOL)
  25.       SEGMENT KARPOS(NBNDS)
  26.       SEGMENT JPLANS(JPLA1,JPLA2)
  27.       SEGMENT JPLAN3(JPLA1,JPLA2)
  28.       SEGMENT JPLCOM(JPLA1)
  29.       SEGMENT JNOEFA(JNBFA,5)
  30.       SEGMENT JFARAF(JNBFA,LLLL)
  31.       SEGMENT NUMNOE(INUMNO)
  32.       SEGMENT IWORK2(JNBSOM)
  33.       SEGMENT IWORK1(IJKLMN)
  34. C
  35. C====================================================================
  36. C                        Initialisations
  37. C====================================================================
  38.       SEGACT JPLANS,JPLCOM,JNOEFA,JPLAN3*MOD
  39.       SEGACT IPT2,ICPR,KARPOS,KARETE,KMILIE*MOD,MELVA2,JFARAF*MOD
  40.       IJKLMN=4
  41.       ipt7=0
  42.       SEGINI IWORK1
  43.       IWORK1(1)=4
  44.       IWORK1(2)=8
  45.       IWORK1(3)=6
  46.       IWORK1(4)=10
  47.       NCOMPL=LNELM(1,(IPT2.ITYPEL-1)*2+2)
  48. C
  49.       MBOUCL=0
  50.       NBPYR=0
  51. C 52  CONTINUE
  52.       MBOUCL=MBOUCL+1
  53. C
  54.       NBNN=NBNNE(LNELM(2,(IPT2.ITYPEL-1)*2+1))
  55.       INELM=LNELM(1,(IPT2.ITYPEL-1)*2+1)
  56. C
  57. C Creation du squelette du maillage resultat
  58.       NBELEM=IPT2.NUM(/2)-KARAF+INELM*KARAF
  59.       NBSOUS=0
  60.       NBREF=0
  61.       SEGINI IPT4
  62.       IPT4.ITYPEL=LNELM(2,(IPT2.ITYPEL-1)*2+1)
  63.       LPO2=LPOS2(IPT2.ITYPEL)
  64.       segact mcoord*mod
  65.       NBPT0=nbpts
  66.       NBPT1=nbpts
  67.       NBPTS=NBPT1+NACREE+KARAF*NBINTE(IPT2.ITYPEL)
  68.       SEGADJ MCOORD,XDEN
  69.       INUMNO=NBRAF(IPT2.ITYPEL)
  70.       SEGINI NUMNOE
  71.       LCOMP=1
  72. C
  73.       NCOMPT=0
  74.       DO 53 IARAF=1,MELVA2.VELCHE(/2)
  75.         IF (MELVA2.VELCHE(1,IARAF).EQ.1) NCOMPT=NCOMPT+1
  76.   53  CONTINUE
  77.       NUELM=1
  78.       NBNN=NBNNE(IPT2.ITYPEL-2)
  79.       NBELEM=NCOMPT*4
  80.       NBSOUS=0
  81.       NBREF=0
  82.       SEGINI IPT5
  83.       IPT5.ITYPEL=IPT2.ITYPEL-2
  84. C
  85. C
  86. C======================================================================
  87. C                   Phase de raffinement 3D
  88. C======================================================================                                                                      !
  89. C=======================================
  90. C A) Boucle sur les elements a raffiner !
  91. C=======================================
  92.       DO 6 IARAF=1,MELVA2.VELCHE(/2)
  93.         IF (MELVA2.VELCHE(1,IARAF).NE.1) THEN
  94.           DO 1 IJKL=1,IPT2.NUM(/1)
  95.             IPT4.NUM(IJKL,NBELEM)=IPT2.NUM(IJKL,IARAF)
  96.    1      CONTINUE
  97.           NBELEM=NBELEM-1
  98.           GOTO 6
  99.         ENDIF
  100.         NBPYR=NBPYR+1
  101.         JCOMPT=0
  102.         JPOS5=LPOS5(IPT2.ITYPEL)
  103. C
  104. C==========================================================
  105. C B) Boucle sur les noeuds a creer pour raffiner l'element !
  106. C==========================================================
  107.         DO 4 I=1,NBRAF(IPT2.ITYPEL)
  108.           JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1)
  109.           JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1)
  110.           JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT
  111.           LTYPNO=JTYPNO(JPOS5-1+I)
  112. C
  113. C-------------------------------
  114. C ** B.1 / On est sur une arete !
  115. C-------------------------------
  116.           IF (LTYPNO.EQ.0) THEN
  117.             NPTA=IPT2.NUM(LISNOE(JLISN),IARAF)
  118.             NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF)
  119.             NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  120.             NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  121.             DO 2 K=1,MAX(1,KARPOS(NMIN))
  122.               IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K
  123.    2        CONTINUE
  124.             IF (KMILIE(NMIN,NEXIST).GT.0) THEN
  125.               NUMNOE(I)=KMILIE(NMIN,NEXIST)
  126.               JCOMPT=JCOMPT+JLONG
  127.               GOTO 4
  128.             ELSE
  129.               NBPT1=NBPT1+1
  130.               NUMNOE(I)=NBPT1
  131.               KMILIE(NMIN,NEXIST)=NBPT1
  132.             ENDIF
  133. C
  134. C------------------------------
  135. C ** B.2 / On est sur une face !
  136. C------------------------------
  137. C Il faut identifier cette face (numero, sommets...)
  138.           ELSEIF ((LTYPNO.GT.0).AND.(LTYPNO.LT.7)) THEN
  139. C => a) On initialise toutes les donnees relatives a cette face
  140.             JTYPEL=IPT2.ITYPEL
  141.             JLTEL2=LTEL(1,JTYPEL)-1+LTYPNO
  142.             JLTEL2=LTEL(2,JTYPEL)-1+LTYPNO
  143.             JLDEL1=LDEL(1,JLTEL2)
  144.             JTYFAC=IWORK1(JLDEL1)
  145.             JLDEL2=LDEL(2,JLTEL2)
  146.             JNBSOM=NBSOM(JTYFAC)
  147.             JSPOS=NSPOS(JTYFAC)
  148. C => b) On identifie les sommets de la face (n° global)
  149.             SEGINI IWORK2
  150.             DO 10 IAA=1,JNBSOM
  151.               NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),IARAF)
  152.               IWORK2(IAA)=NGLOBA
  153.   10        CONTINUE
  154. C => c) On classe ces sommets par ordre croissant (NPTA < NPTB < NPTC)
  155.             NPTA=nbpts+1
  156.             NPTB=NPTA+1
  157.             NPTC=NPTB+1
  158.             DO 11 ICC=1,JNBSOM
  159.               IF (IWORK2(ICC).LT.NPTA) THEN
  160.                 NPTC=NPTB
  161.                 NPTB=NPTA
  162.                 NPTA=IWORK2(ICC)
  163.               ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  164.                 NPTC=NPTB
  165.                 NPTB=IWORK2(ICC)
  166.               ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  167.                 NPTC=IWORK2(ICC)
  168.               ENDIF
  169.   11        CONTINUE
  170. C => d) On passe ces sommets en n° locale
  171.             NPTA2=ICPR(NPTA,1)
  172.             NPTB2=ICPR(NPTB,1)
  173.             NPTC2=ICPR(NPTC,1)
  174.             IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  175.               NPTA=NPTA2
  176.               NPTB=MIN(NPTB2,NPTC2)
  177.               NPTC=MAX(NPTB2,NPTC2)
  178.             ENDIF
  179.             IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  180.               NPTA=NPTB2
  181.               NPTB=MIN(NPTA2,NPTC2)
  182.               NPTC=MAX(NPTA2,NPTC2)
  183.             ENDIF
  184.             IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  185.               NPTA=NPTC2
  186.               NPTB=MIN(NPTA2,NPTB2)
  187.               NPTC=MAX(NPTA2,NPTB2)
  188.             ENDIF
  189. C => e) On cherche le numero de la face
  190.             NEXIS2=0
  191.             DO 12 IEE=1,JPLCOM(NPTA)
  192.               MTMP=JPLANS(NPTA,IEE)
  193.               JJ1=JNOEFA(MTMP,1)
  194.               JJ2=JNOEFA(MTMP,2)
  195.               JJ3=JNOEFA(MTMP,3)
  196.               IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN
  197.                 NEXIS2=IEE
  198.               ENDIF
  199.   12        CONTINUE
  200.             JNUMFA=JPLANS(NPTA,NEXIS2)
  201. C
  202. C---------------------------------
  203. C ** B.3 / Raffinement de la face !
  204. C---------------------------------
  205.             KTEST1=JPLAN3(NPTA,NEXIS2)
  206.             KTEST2=NBINTE(JTYFAC)
  207. C => a) Si la face est de type QUA4 (un seul noeud a creer, au milieu)
  208.             IF (JTYFAC.EQ.8) THEN
  209.               IF (KTEST1.LT.KTEST2) THEN
  210.                 NBPT1=NBPT1+1
  211.                 NUMNOE(I)=NBPT1
  212.                 JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1
  213.                 JFARAF(JNUMFA,1)=NBPT1
  214.               ELSEIF (KTEST1.EQ.KTEST2) THEN
  215.                 NUMNOE(I)=JFARAF(JNUMFA,1)
  216.                 JFARAF(JNUMFA,1)=0
  217.                 JCOMPT=JCOMPT+JLONG
  218.                 GOTO 4
  219.               ELSE
  220.                 WRITE(*,*) 'ERREUR'
  221.               ENDIF
  222.             ENDIF
  223. C => b) Si la face n'est pas de type QUA4 (donc de type TRI6 ou QUA8)
  224.             IF (JTYFAC.NE.8) THEN
  225.               IF (KTEST1.LT.KTEST2) THEN
  226.                 NBPT1=NBPT1+1
  227.                 NUMNOE(I)=NBPT1
  228.                 JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1
  229.                 NEXIS3=0
  230.                 XCO2=0.25
  231.                 DO 13 KBB=1,JLONG
  232.                   XCO1=XCOEFF(JPOS1-1+KBB)
  233.                   IF (XCO1.EQ.XCO2) NEXIS3=KBB
  234.   13            CONTINUE
  235.                 JFARAF(JNUMFA,2*(KTEST1)+1)=NBPT1
  236.                 IF (NEXIS3.NE.0) THEN
  237.                   NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF)
  238.                   JFARAF(JNUMFA,2*(KTEST1)+2)=NGLOB
  239.                 ELSE
  240.                   JFARAF(JNUMFA,2*(KTEST1)+2)=0
  241.                 ENDIF
  242.               ELSEIF (KTEST1.EQ.KTEST2) THEN
  243.                 NEXIS3=0
  244.                 NEXIS4=0
  245.                 XCO2=0.25
  246.                 DO 14 KBB=1,JLONG
  247.                   XCO1=XCOEFF(JPOS1-1+KBB)
  248.                   IF (XCO1.EQ.XCO2) NEXIS3=KBB
  249.   14            CONTINUE
  250.                 IF (NEXIS3.NE.0) THEN
  251.                   NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF)
  252.                   DO 15 KAA=2,JFARAF(/2),2
  253.                      IF (JFARAF(JNUMFA,KAA).EQ.NGLOB) NEXIS4=KAA
  254.   15              CONTINUE
  255.                   NUMNOE(I)=JFARAF(JNUMFA,NEXIS4-1)
  256.                   JFARAF(JNUMFA,NEXIS4-1)=0
  257.                 ELSE
  258.                   DO 16 KAA=2,JFARAF(/2),2
  259.                      IF (JFARAF(JNUMFA,KAA).EQ.0) NEXIS4=KAA
  260.   16              CONTINUE
  261.                   NUMNOE(I)=JFARAF(JNUMFA,NEXIS4-1)
  262.                   JFARAF(JNUMFA,NEXIS4-1)=0
  263.                 ENDIF
  264.                 JCOMPT=JCOMPT+JLONG
  265.                 GOTO 4
  266.               ENDIF
  267.             ENDIF
  268. C
  269. C------------------------------------------------------
  270. C ** B.4 / On est a l'interieur du volume de l'element !
  271. C------------------------------------------------------
  272.           ELSEIF (LTYPNO.EQ.7) THEN
  273.             NBPT1=NBPT1+1
  274.             NUMNOE(I)=NBPT1
  275.           ENDIF
  276. C
  277.           IF (NBPT1.EQ.NBPTS) THEN
  278.             NBPTS=NBPTS+200
  279.             SEGADJ MCOORD,XDEN
  280.           ENDIF
  281. C
  282. C==============================
  283. C C) Creation du nouveau point !
  284. C==============================
  285. C On continue ici que lorsque l'on doit creer un nouveau point
  286.           XPT=0.
  287.           YPT=0.
  288.           ZPT=0.
  289.           XDEN1=0.D0
  290.           DO 3 J=1,JLONG
  291.             NGLOB=IPT2.NUM(LISNOE(JLISN-1+J),IARAF)
  292.             XINI=XCOOR((NGLOB-1)*(IDIM+1)+1)
  293.             YINI=XCOOR((NGLOB-1)*(IDIM+1)+2)
  294.             ZINI=XCOOR((NGLOB-1)*(IDIM+1)+3)
  295.             XPT=XPT+XINI*XCOEFF(JPOS1-1+J)
  296.             YPT=YPT+YINI*XCOEFF(JPOS1-1+J)
  297.             ZPT=ZPT+ZINI*XCOEFF(JPOS1-1+J)
  298.             XDEN1=XDEN1+XDEN(NGLOB)*XCOEFF(JPOS1-1+J)
  299.    3      CONTINUE
  300.           XCOOR((NBPT1-1)*(IDIM+1)+1)=XPT
  301.           XCOOR((NBPT1-1)*(IDIM+1)+2)=YPT
  302.           XCOOR((NBPT1-1)*(IDIM+1)+3)=ZPT
  303.           XDEN(NBPT1)=XDEN1
  304.           JCOMPT=JCOMPT+JLONG
  305.  
  306. C======================================================================
  307.    4    CONTINUE
  308. C======================================================================
  309.         JPOS4=LPOS4(IPT2.ITYPEL)
  310. C
  311. C===================================
  312. C D) Creation des nouveaux elements !
  313. C===================================
  314. C On remplit la portion de IPT4 relative aux elements crees a partir
  315. C de la division de l'element IARAF (indice de boucle 1).
  316. C Cette portion de IPT4 contient les colonnes dont la valeur s'etend
  317. C de INELM*(LCOMP-1)+1 a INELM*LCOMP.
  318.         KTYP=IPT2.ITYPEL
  319.         NBNN=NBNNE(LNELM(2,(KTYP-1)*2+1))
  320.         DO 1001 J=1,INELM
  321.         DO 5 I=1,IPT4.NUM(/1)
  322.           NTEMP=LIELM(JPOS4-1+NBNN*(J-1)+I)
  323.           IF (NTEMP.GT.NBNN) THEN
  324.             IPT4.NUM(I,INELM*(LCOMP-1)+J)=NUMNOE(NTEMP-NBNN)
  325.           ELSE
  326.             IPT4.NUM(I,INELM*(LCOMP-1)+J)=IPT2.NUM(NTEMP,IARAF)
  327.           ENDIF
  328.    5    CONTINUE
  329.  1001   CONTINUE
  330.         LCOMP=LCOMP+1
  331. C
  332.         IF (KTYP.EQ.25) JPOS41=561+5*6
  333.         IF (KTYP.EQ.26) JPOS41=685
  334.         DO 34 JJ=1,IPT5.NUM(/2)
  335.         DO 33 II=1,IPT5.NUM(/1)
  336.           NTEMP=LIELM(JPOS41-1+II)
  337.           IF (NTEMP.GT.NBNN) THEN
  338.             IPT5.NUM(II,NUELM)=NUMNOE(NTEMP-NBNN)
  339.           ELSE
  340.             IPT5.NUM(II,NUELM)=IPT2.NUM(NTEMP,IARAF)
  341.           ENDIF
  342.   33    CONTINUE
  343.         JPOS41=JPOS41+NBNNE(KTYP-2)
  344.         NUELM=NUELM+1
  345.   34  CONTINUE
  346. C
  347.    6  CONTINUE
  348. C
  349.       NBPTS=NBPT1
  350.       SEGADJ MCOORD,XDEN
  351. C
  352. C=======================================================================
  353. C              Preparation du maillage de relations
  354. C=======================================================================
  355. C==================================
  356. C A) Relations dues aux faces (3D) !
  357. C==================================
  358. C Tous les noeuds qui restent dans JFARAF sont a creer en tant que
  359. C relations de conformite
  360. C---------------------------------
  361. C ** A.1 / Initialisation de IPT5 !
  362. C---------------------------------
  363. C 1/ Comptage du nombre de noeuds soumis a des relations
  364.       NBRELA=0
  365.       DO 114 IHF=1,JFARAF(/1)
  366.         IF (JNOEFA(IHF,5).EQ.0) GOTO 114
  367.         IF (JFARAF(IHF,1).EQ.0) GOTO 114
  368.         DO 113 JF=1,JFARAF(/2),2
  369.           IF (JFARAF(IHF,JF).NE.0) NBRELA=NBRELA+1
  370.  113  CONTINUE
  371.  114  CONTINUE
  372. C
  373. C 2/ Creation de IPT5
  374.       IF (NBRELA.EQ.0) THEN
  375.         IPT5=0
  376.         GOTO 210
  377.       ENDIF
  378. C      IF (IPT2.ITYPEL.EQ.14) NBNN=4
  379. C      IF (IPT2.ITYPEL.EQ.15) NBNN=8
  380. C      IF (IPT2.ITYPEL.EQ.17) NBNN=5
  381. C      IF (IPT2.ITYPEL.EQ.24) NBNN=5
  382.       NBNN=10
  383.       NBELEM=NBRELA
  384.       NBSOUS=0
  385.       NBREF=0
  386.       SEGINI IPT5
  387.       IPT5.ITYPEL=48
  388. C
  389. C 3/ Renseignement des noeuds support des relations
  390.       NBRELA=0
  391.       DO 116 IPF=1,JFARAF(/1)
  392.          IF (JNOEFA(IPF,5).EQ.0) GOTO 116
  393.         IF (JFARAF(IPF,1).EQ.0) GOTO 116
  394.         DO 115 JF=1,JFARAF(/2),2
  395.           IF (JFARAF(IPF,JF).EQ.0) GOTO 115
  396.           NBRELA=NBRELA+1
  397.           IPT5.NUM(1,NBRELA)=JFARAF(IPF,JF)
  398.  115  CONTINUE
  399.  116  CONTINUE
  400. C
  401. C-----------------------------------------------------
  402. C ** A.2 / Recherche des noeuds formant les relations !
  403. C-----------------------------------------------------
  404. C 1/ Boucle sur l'ensemble des noeuds a creer
  405.       DO 200 IARAF=1,MELVA2.VELCHE(/2)
  406.         IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 200
  407.         JCOMPT=0
  408.         JPOS5=LPOS5(IPT2.ITYPEL)
  409.         DO 190 I=1,NBRAF(IPT2.ITYPEL)
  410.           JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1)
  411.           JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1)
  412.           JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT
  413.           LTYPNO=JTYPNO(JPOS5-1+I)
  414.           IF ((LTYPNO.EQ.0).OR.(LTYPNO.EQ.7)) GOTO 189
  415. C
  416. C 2/ Preparation pour trouver le noeud et la face en question
  417.           JTYPEL=IPT2.ITYPEL
  418.           JLTEL2=LTEL(2,JTYPEL)-1+LTYPNO
  419.           JLDEL1=LDEL(1,JLTEL2)
  420.           JTYFAC=IWORK1(JLDEL1)
  421.           JLDEL2=LDEL(2,JLTEL2)
  422.           JNBSOM=NBSOM(JTYFAC)
  423.           JSPOS=NSPOS(JTYFAC)
  424.           SEGINI IWORK2
  425. C
  426. C 3/ Classement des 3 sommets par ordre croissant de n° globale
  427.           DO 100 IAA=1,JNBSOM
  428.             NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),IARAF)
  429.             IWORK2(IAA)=NGLOBA
  430.  100      CONTINUE
  431.           NPTA=(nbpts)+1
  432.           NPTB=NPTA+1
  433.           NPTC=NPTB+1
  434.           DO 110 ICC=1,JNBSOM
  435.             IF (IWORK2(ICC).LT.NPTA) THEN
  436.               NPTC=NPTB
  437.               NPTB=NPTA
  438.               NPTA=IWORK2(ICC)
  439.             ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  440.               NPTC=NPTB
  441.               NPTB=IWORK2(ICC)
  442.             ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  443.               NPTC=IWORK2(ICC)
  444.             ENDIF
  445.  110      CONTINUE
  446. C
  447. C 4/ Classement des 3 sommets par ordre croissant de n° locale
  448.           NPTA2=ICPR(NPTA,1)
  449.           NPTB2=ICPR(NPTB,1)
  450.           NPTC2=ICPR(NPTC,1)
  451.           IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  452.             NPTA=NPTA2
  453.             NPTB=MIN(NPTB2,NPTC2)
  454.             NPTC=MAX(NPTB2,NPTC2)
  455.           ENDIF
  456.           IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  457.             NPTA=NPTB2
  458.             NPTB=MIN(NPTA2,NPTC2)
  459.             NPTC=MAX(NPTA2,NPTC2)
  460.           ENDIF
  461.           IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  462.             NPTA=NPTC2
  463.             NPTB=MIN(NPTA2,NPTB2)
  464.             NPTC=MAX(NPTA2,NPTB2)
  465.           ENDIF
  466. C
  467. C 5/ Recherche du numero de la face
  468.           NEXIS2=0
  469.           DO 120 IEE=1,JPLCOM(NPTA)
  470.             MTMP=JPLANS(NPTA,IEE)
  471.             JJ1=JNOEFA(MTMP,1)
  472.             JJ2=JNOEFA(MTMP,2)
  473.             JJ3=JNOEFA(MTMP,3)
  474.             IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN
  475.               NEXIS2=IEE
  476.             ENDIF
  477.  120      CONTINUE
  478.           JNUMFA=JPLANS(NPTA,NEXIS2)
  479. C
  480. C 6/ Recherche du numero global du point
  481.           IF (JNOEFA(JNUMFA,5).EQ.0) GOTO 189
  482.           IF (JTYFAC.EQ.8) INOEGL=JFARAF(JNUMFA,1)
  483.           IF (JTYFAC.NE.8) THEN
  484.             NEXIS3=0
  485.             NEXIS4=0
  486.             XCO2=0.25
  487.             DO 140 KBB=1,JLONG
  488.               XCO1=XCOEFF(JPOS1-1+KBB)
  489.               IF (XCO1.EQ.XCO2) NEXIS3=KBB
  490.  140        CONTINUE
  491.             IF (NEXIS3.NE.0) THEN
  492.               NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF)
  493.               DO 150 KAA=2,JFARAF(/2),2
  494.                 IF (JFARAF(JNUMFA,KAA).EQ.NGLOB) NEXIS4=KAA
  495.  150          CONTINUE
  496.               INOEGL=JFARAF(JNUMFA,NEXIS4-1)
  497.             ELSE
  498.               DO 160 KAA=2,JFARAF(/2),2
  499.                 IF (JFARAF(JNUMFA,KAA).EQ.0) NEXIS4=KAA
  500.  160          CONTINUE
  501.               INOEGL=JFARAF(JNUMFA,NEXIS4-1)
  502.             ENDIF
  503.           ENDIF
  504. C
  505. C------------------------------
  506. C ** A.3 / Remplissage de IPT5 !
  507. C------------------------------
  508. C 1/ Recherche de la position du point dans IPT5
  509.           NEXIS5=0
  510.           DO 170 IGG=1,IPT5.NUM(/2)
  511.             IF (INOEGL.EQ.IPT5.NUM(1,IGG)) NEXIS5=IGG
  512.  170      CONTINUE
  513.           IF (NEXIS5.EQ.0) GOTO 189
  514. C
  515. C 2/ Renseignement des points formant les relations
  516.           DO 180 IHH=1,JLONG
  517.             IPT5.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF)
  518.  180      CONTINUE
  519.           IF (JLONG.EQ.4) IPT5.NUM(10,NEXIS5)=3
  520.           IF (JLONG.EQ.5) IPT5.NUM(10,NEXIS5)=4
  521.           IF (JLONG.EQ.8) THEN
  522.             IF (JPOS1.EQ.16) IPT5.NUM(10,NEXIS5)=5
  523.             IF (JPOS1.EQ.24) IPT5.NUM(10,NEXIS5)=6
  524.           ENDIF
  525.  189      CONTINUE
  526.         JCOMPT=JCOMPT+JLONG
  527.  190    CONTINUE
  528.  200  CONTINUE
  529.  210  CONTINUE
  530. C
  531. C===================================
  532. C B) Relations dues aux aretes (2D) !
  533. C===================================
  534. C On cree un maillage IPT6 contenant tous les noeuds soumis a des
  535. C relations
  536. C
  537.       SEGSUP KARET2
  538.       NBNDS=KARETE(/1)
  539.       NCOL=KARETE(/2)
  540.       SEGINI KARET2
  541.         ILPL=LPL(IPT2.ITYPEL)
  542.         ILPT=LPT(IPT2.ITYPEL)
  543.         DO 1002 J=1,IPT4.NUM(/2)
  544.         DO 317 K=1,ILPL*2-1,2
  545.           NPTA=IPT4.NUM(KSEGM(ILPT+K-1),J)
  546.           NPTB=IPT4.NUM(KSEGM(ILPT+K),J)
  547.       IF((NPTA.GT.NBPT0).OR.(NPTB.GT.NBPT0)) THEN
  548.         GOTO 317
  549.       ENDIF
  550.           NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  551.           NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  552.           NEXIST=0
  553.           DO 316 I=1,MAX(1,KARPOS(NMIN))
  554.             IF (KARETE(NMIN,I).EQ.NMAX) THEN
  555.               KARET2(NMIN,I)=KARET2(NMIN,I)+1
  556.             ENDIF
  557.  316      CONTINUE
  558.  317    CONTINUE
  559.  1002   CONTINUE
  560.  
  561. C 1/ Comptage du nombre de noeuds soumis a des relations
  562.       NBELEM=0
  563.       DO 1003 J=1,KMILIE(/2)
  564.       DO 27 I=1,KMILIE(/1)
  565.         IF (KARET2(I,J).EQ.0) GOTO 27
  566.         IF (KMILIE(I,J).GT.0) NBELEM=NBELEM+1
  567.    27  CONTINUE
  568.  1003 CONTINUE
  569. C
  570. C 2/ Creation de IPT6
  571.       IPT6=0
  572.       IF (NBELEM.EQ.0) GOTO 999
  573.       NBNN=5
  574.       NBREF=0
  575.       NBSOUS=0
  576.       SEGINI IPT6
  577.       IPT6.ITYPEL=48
  578. C
  579. C 3/ Renseignement des noeuds support des relations
  580.       DO 1004 J=1,KMILIE(/2)
  581.       DO 28 I=1,KMILIE(/1)
  582.         IF (KARET2(I,J).EQ.0) GOTO 28
  583.         IF (KMILIE(I,J).GT.0) THEN
  584.           NBREF=NBREF+1
  585.           IPT6.NUM(1,NBREF)=KMILIE(I,J)
  586.         ENDIF
  587.    28  CONTINUE
  588.  1004 CONTINUE
  589. C
  590. C 4/ Recherche des noeuds formant les relations
  591.       DO 24 IARAF=1,MELVA2.VELCHE(/2)
  592.         IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 24
  593.         JCOMPT=0
  594.         JPOS5=LPOS5(IPT2.ITYPEL)
  595.         DO 23 I=1,NBRAF(IPT2.ITYPEL)
  596.           JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1)
  597.           JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1)
  598.           JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT
  599.           LTYPNO=JTYPNO(JPOS5-1+I)
  600.           IF (LTYPNO.NE.0) GOTO 22
  601.           NPTA=IPT2.NUM(LISNOE(JLISN),IARAF)
  602.           NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF)
  603.           NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  604.           NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  605.           DO 29 K=1,MAX(1,KARPOS(NMIN))
  606.             IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K
  607.   29      CONTINUE
  608.           IF (KARET2(NMIN,NEXIST).EQ.0) GOTO 22
  609.           IF (KMILIE(NMIN,NEXIST).EQ.0) GOTO 22
  610.           NEXIS5=0
  611.           DO 20 MM=1,IPT6.NUM(/2)
  612.             INOEGL=KMILIE(NMIN,NEXIST)
  613.             INRELA=IPT6.NUM(1,MM)
  614.             IF (INOEGL.EQ.INRELA) NEXIS5=MM
  615.   20      CONTINUE
  616. C
  617. C 5/ Renseignement des noeuds formant les relations
  618.           DO 21 IHH=1,JLONG
  619.             IPT6.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF)
  620.   21      CONTINUE
  621.           IF (JLONG.EQ.2) IPT6.NUM(5,NEXIS5)=1
  622.           IF (JLONG.EQ.3) IPT6.NUM(5,NEXIS5)=2
  623.   22      CONTINUE
  624.         JCOMPT=JCOMPT+JLONG
  625.   23    CONTINUE
  626.   24  CONTINUE
  627.  
  628. C444  CONTINUE
  629.  
  630. C
  631. C============================================
  632. C C) Creation du maillage de relations final !
  633. C============================================
  634.       IF (IPT5.EQ.0) THEN
  635.         IPT7=IPT6
  636.         GOTO 999
  637.       ENDIF
  638.       NBELEM=IPT5.NUM(/2)+IPT6.NUM(/2)
  639. C      NBNN=MAX(IPT5.NUM(/1),IPT6.NUM(/1))
  640.       NBNN=10
  641.       NBREF=0
  642.       NBSOUS=0
  643.       SEGINI IPT7
  644.       IPT7.ITYPEL=48
  645.       DO 1005 NEO=1,IPT5.NUM(/2)
  646.       DO 42 MOR=1,10
  647.         IPT7.NUM(MOR,NEO)=IPT5.NUM(MOR,NEO)
  648.         IPT7.ICOLOR(NEO)=IPT5.ICOLOR(NEO)
  649.   42  CONTINUE
  650.  1005 CONTINUE
  651.       NN5 = IPT5.NUM(/2)
  652.       DO 1006 NEO=IPT5.NUM(/2)+1,IPT6.NUM(/2)+IPT5.NUM(/2)
  653.       DO 43 MOR=1,IPT6.NUM(/1)
  654.         IF (MOR.LT.IPT6.NUM(/1)) THEN
  655.           IPT7.NUM(MOR,NEO)=IPT6.NUM(MOR,NEO-NN5)
  656.         ELSE
  657.           IPT7.NUM(10,NEO)=IPT6.NUM(MOR,NEO-NN5)
  658.         ENDIF
  659.         IPT7.ICOLOR(NEO)=IPT6.ICOLOR(NEO-NN5)
  660.   43  CONTINUE
  661. 1006  CONTINUE
  662.       WRITE(*,*) '  |-> raffinement OK'
  663. C=======================================================================
  664. C                      Fin du programme
  665. C=======================================================================
  666.       GOTO 999
  667.  
  668. C     Pour DEBUG decommenter ci-dessous
  669. C     WRITE(*,*) '****************************************************'
  670. C     WRITE(*,*) 'TABLEAU JNOEFA'
  671. C     DO 64 I=1,JNOEFA(/1)
  672. C       WRITE(*,1000) I,':',(JNOEFA(I,J), J=1,JNOEFA(/2))
  673. C 64  CONTINUE
  674. C     WRITE(*,*) '****************************************************'
  675. C     WRITE(*,*) 'TABLEAU JFARAF'
  676. C     WRITE(*,*) 'Nb colonnes = ',JFARAF(/2)
  677. C     DO 63 I=1,JFARAF(/1)
  678. C       WRITE(*,1000) I,':',(JFARAF(I,J), J=1,JFARAF(/2))
  679. C 63  CONTINUE
  680. C     GOTO 999
  681. C     
  682. C     WRITE(*,*) '****************************************************'
  683. C     WRITE(*,*) 'TABLEAU JPLANS'
  684. C     DO 61 I=1,JPLANS(/1)
  685. C       WRITE(*,1000) I,':',(JPLANS(I,J), J=1,JPLANS(/2))
  686. C 61  CONTINUE
  687. C     WRITE(*,*) '****************************************************'
  688. C     WRITE(*,*) 'TABLEAU JPLAN3'
  689. C     DO 62 I=1,JPLAN3(/1)
  690. C       WRITE(*,1000) I,':',(JPLAN3(I,J), J=1,JPLAN3(/2))
  691. C 62  CONTINUE
  692. C     WRITE(*,*) '****************************************************'
  693. C     WRITE(*,*) 'TABLEAU ICPR'
  694. C     DO 98 I=1,ICPR(/1)
  695. C       WRITE(*,*) I,': ',ICPR(I,1),' ',ICPR(I,2)
  696. C 98  CONTINUE
  697. C1000 FORMAT (1I3,A,24I4)
  698.  
  699.  999  CONTINUE
  700.       RETURN
  701.       END
  702.  
  703.  
  704.  
  705.  
  706.  
  707.  
  708.  
  709.  
  710.  
  711.  
  712.  
  713.  
  714.  
  715.  
  716.  

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