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  24/04/12    21:17:02     11897          
  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.   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.         NBNN=NBNNE(LNELM(2,(KTYP-1)*2+1))
  319.         DO 5 J=1,INELM
  320.         DO 5 I=1,IPT4.NUM(/1)
  321.           NTEMP=LIELM(JPOS4-1+NBNN*(J-1)+I)
  322.           IF (NTEMP.GT.NBNN) THEN
  323.             IPT4.NUM(I,INELM*(LCOMP-1)+J)=NUMNOE(NTEMP-NBNN)
  324.           ELSE
  325.             IPT4.NUM(I,INELM*(LCOMP-1)+J)=IPT2.NUM(NTEMP,IARAF)
  326.           ENDIF
  327.    5    CONTINUE
  328.         LCOMP=LCOMP+1
  329. C
  330.         KTYP=IPT2.ITYPEL
  331.         IF (KTYP.EQ.25) JPOS41=561+5*6
  332.         IF (KTYP.EQ.26) JPOS41=685
  333.         DO 34 JJ=1,IPT5.NUM(/2)
  334.         DO 33 II=1,IPT5.NUM(/1)
  335.           NTEMP=LIELM(JPOS41-1+II)
  336.           IF (NTEMP.GT.NBNN) THEN
  337.             IPT5.NUM(II,NUELM)=NUMNOE(NTEMP-NBNN)
  338.           ELSE
  339.             IPT5.NUM(II,NUELM)=IPT2.NUM(NTEMP,IARAF)
  340.           ENDIF
  341.   33    CONTINUE
  342.         JPOS41=JPOS41+NBNNE(KTYP-2)
  343.         NUELM=NUELM+1
  344.   34  CONTINUE
  345. C
  346.    6  CONTINUE
  347. C
  348.       NBPTS=NBPT1
  349.       SEGADJ MCOORD,XDEN
  350. C
  351. C=======================================================================
  352. C              Preparation du maillage de relations
  353. C=======================================================================
  354. C==================================
  355. C A) Relations dues aux faces (3D) !
  356. C==================================
  357. C Tous les noeuds qui restent dans JFARAF sont a creer en tant que
  358. C relations de conformite
  359. C---------------------------------
  360. C ** A.1 / Initialisation de IPT5 !
  361. C---------------------------------
  362. C 1/ Comptage du nombre de noeuds soumis a des relations
  363.       NBRELA=0
  364.       DO 114 IHF=1,JFARAF(/1)
  365.         IF (JNOEFA(IHF,5).EQ.0) GOTO 114
  366.         IF (JFARAF(IHF,1).EQ.0) GOTO 114
  367.         DO 113 JF=1,JFARAF(/2),2
  368.           IF (JFARAF(IHF,JF).NE.0) NBRELA=NBRELA+1
  369.  113  CONTINUE
  370.  114  CONTINUE
  371. C
  372. C 2/ Creation de IPT5
  373.       IF (NBRELA.EQ.0) THEN
  374.         IPT5=0
  375.         GOTO 210
  376.       ENDIF
  377. C      IF (IPT2.ITYPEL.EQ.14) NBNN=4
  378. C      IF (IPT2.ITYPEL.EQ.15) NBNN=8
  379. C      IF (IPT2.ITYPEL.EQ.17) NBNN=5
  380. C      IF (IPT2.ITYPEL.EQ.24) NBNN=5
  381.       NBNN=10
  382.       NBELEM=NBRELA
  383.       NBSOUS=0
  384.       NBREF=0
  385.       SEGINI IPT5
  386.       IPT5.ITYPEL=48
  387. C
  388. C 3/ Renseignement des noeuds support des relations
  389.       NBRELA=0
  390.       DO 116 IPF=1,JFARAF(/1)
  391.          IF (JNOEFA(IPF,5).EQ.0) GOTO 116
  392.         IF (JFARAF(IPF,1).EQ.0) GOTO 116
  393.         DO 115 JF=1,JFARAF(/2),2
  394.           IF (JFARAF(IPF,JF).EQ.0) GOTO 115
  395.           NBRELA=NBRELA+1
  396.           IPT5.NUM(1,NBRELA)=JFARAF(IPF,JF)
  397.  115  CONTINUE
  398.  116  CONTINUE
  399. C
  400. C-----------------------------------------------------
  401. C ** A.2 / Recherche des noeuds formant les relations !
  402. C-----------------------------------------------------
  403. C 1/ Boucle sur l'ensemble des noeuds a creer
  404.       DO 200 IARAF=1,MELVA2.VELCHE(/2)
  405.         IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 200
  406.         JCOMPT=0
  407.         JPOS5=LPOS5(IPT2.ITYPEL)
  408.         DO 190 I=1,NBRAF(IPT2.ITYPEL)
  409.           JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1)
  410.           JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1)
  411.           JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT
  412.           LTYPNO=JTYPNO(JPOS5-1+I)
  413.           IF ((LTYPNO.EQ.0).OR.(LTYPNO.EQ.7)) GOTO 189
  414. C
  415. C 2/ Preparation pour trouver le noeud et la face en question
  416.           JTYPEL=IPT2.ITYPEL
  417.           JLTEL2=LTEL(2,JTYPEL)-1+LTYPNO
  418.           JLDEL1=LDEL(1,JLTEL2)
  419.           JTYFAC=IWORK1(JLDEL1)
  420.           JLDEL2=LDEL(2,JLTEL2)
  421.           JNBSOM=NBSOM(JTYFAC)
  422.           JSPOS=NSPOS(JTYFAC)
  423.           SEGINI IWORK2
  424. C
  425. C 3/ Classement des 3 sommets par ordre croissant de n° globale
  426.           DO 100 IAA=1,JNBSOM
  427.             NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),IARAF)
  428.             IWORK2(IAA)=NGLOBA
  429.  100      CONTINUE
  430.           NPTA=(nbpts)+1
  431.           NPTB=NPTA+1
  432.           NPTC=NPTB+1
  433.           DO 110 ICC=1,JNBSOM
  434.             IF (IWORK2(ICC).LT.NPTA) THEN
  435.               NPTC=NPTB
  436.               NPTB=NPTA
  437.               NPTA=IWORK2(ICC)
  438.             ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  439.               NPTC=NPTB
  440.               NPTB=IWORK2(ICC)
  441.             ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  442.               NPTC=IWORK2(ICC)
  443.             ENDIF
  444.  110      CONTINUE
  445. C
  446. C 4/ Classement des 3 sommets par ordre croissant de n° locale
  447.           NPTA2=ICPR(NPTA,1)
  448.           NPTB2=ICPR(NPTB,1)
  449.           NPTC2=ICPR(NPTC,1)
  450.           IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  451.             NPTA=NPTA2
  452.             NPTB=MIN(NPTB2,NPTC2)
  453.             NPTC=MAX(NPTB2,NPTC2)
  454.           ENDIF
  455.           IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  456.             NPTA=NPTB2
  457.             NPTB=MIN(NPTA2,NPTC2)
  458.             NPTC=MAX(NPTA2,NPTC2)
  459.           ENDIF
  460.           IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  461.             NPTA=NPTC2
  462.             NPTB=MIN(NPTA2,NPTB2)
  463.             NPTC=MAX(NPTA2,NPTB2)
  464.           ENDIF
  465. C
  466. C 5/ Recherche du numero de la face
  467.           NEXIS2=0
  468.           DO 120 IEE=1,JPLCOM(NPTA)
  469.             MTMP=JPLANS(NPTA,IEE)
  470.             JJ1=JNOEFA(MTMP,1)
  471.             JJ2=JNOEFA(MTMP,2)
  472.             JJ3=JNOEFA(MTMP,3)
  473.             IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN
  474.               NEXIS2=IEE
  475.             ENDIF
  476.  120      CONTINUE
  477.           JNUMFA=JPLANS(NPTA,NEXIS2)
  478. C
  479. C 6/ Recherche du numero global du point
  480.           IF (JNOEFA(JNUMFA,5).EQ.0) GOTO 189
  481.           IF (JTYFAC.EQ.8) INOEGL=JFARAF(JNUMFA,1)
  482.           IF (JTYFAC.NE.8) THEN
  483.             NEXIS3=0
  484.             NEXIS4=0
  485.             XCO2=0.25
  486.             DO 140 KBB=1,JLONG
  487.               XCO1=XCOEFF(JPOS1-1+KBB)
  488.               IF (XCO1.EQ.XCO2) NEXIS3=KBB
  489.  140        CONTINUE
  490.             IF (NEXIS3.NE.0) THEN
  491.               NGLOB=IPT2.NUM(LISNOE(JLISN-1+NEXIS3),IARAF)
  492.               DO 150 KAA=2,JFARAF(/2),2
  493.                 IF (JFARAF(JNUMFA,KAA).EQ.NGLOB) NEXIS4=KAA
  494.  150          CONTINUE
  495.               INOEGL=JFARAF(JNUMFA,NEXIS4-1)
  496.             ELSE
  497.               DO 160 KAA=2,JFARAF(/2),2
  498.                 IF (JFARAF(JNUMFA,KAA).EQ.0) NEXIS4=KAA
  499.  160          CONTINUE
  500.               INOEGL=JFARAF(JNUMFA,NEXIS4-1)
  501.             ENDIF
  502.           ENDIF
  503. C
  504. C------------------------------
  505. C ** A.3 / Remplissage de IPT5 !
  506. C------------------------------
  507. C 1/ Recherche de la position du point dans IPT5
  508.           NEXIS5=0
  509.           DO 170 IGG=1,IPT5.NUM(/2)
  510.             IF (INOEGL.EQ.IPT5.NUM(1,IGG)) NEXIS5=IGG
  511.  170      CONTINUE
  512.           IF (NEXIS5.EQ.0) GOTO 189
  513. C
  514. C 2/ Renseignement des points formant les relations
  515.           DO 180 IHH=1,JLONG
  516.             IPT5.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF)
  517.  180      CONTINUE
  518.           IF (JLONG.EQ.4) IPT5.NUM(10,NEXIS5)=3
  519.           IF (JLONG.EQ.5) IPT5.NUM(10,NEXIS5)=4
  520.           IF (JLONG.EQ.8) THEN
  521.             IF (JPOS1.EQ.16) IPT5.NUM(10,NEXIS5)=5
  522.             IF (JPOS1.EQ.24) IPT5.NUM(10,NEXIS5)=6
  523.           ENDIF
  524.  189      CONTINUE
  525.         JCOMPT=JCOMPT+JLONG
  526.  190    CONTINUE
  527.  200  CONTINUE
  528.  210  CONTINUE
  529. C
  530. C===================================
  531. C B) Relations dues aux aretes (2D) !
  532. C===================================
  533. C On cree un maillage IPT6 contenant tous les noeuds soumis a des
  534. C relations
  535. C
  536.       SEGSUP KARET2
  537.       NBNDS=KARETE(/1)
  538.       NCOL=KARETE(/2)
  539.       SEGINI KARET2
  540.         ILPL=LPL(IPT2.ITYPEL)
  541.         ILPT=LPT(IPT2.ITYPEL)
  542.         DO 317 J=1,IPT4.NUM(/2)
  543.         DO 317 K=1,ILPL*2-1,2
  544.           NPTA=IPT4.NUM(KSEGM(ILPT+K-1),J)
  545.           NPTB=IPT4.NUM(KSEGM(ILPT+K),J)
  546.       IF((NPTA.GT.NBPT0).OR.(NPTB.GT.NBPT0)) THEN
  547.         GOTO 317
  548.       ENDIF
  549.           NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  550.           NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  551.           NEXIST=0
  552.           DO 316 I=1,MAX(1,KARPOS(NMIN))
  553.             IF (KARETE(NMIN,I).EQ.NMAX) THEN
  554.               KARET2(NMIN,I)=KARET2(NMIN,I)+1
  555.             ENDIF
  556.  316      CONTINUE
  557.  317    CONTINUE
  558.  
  559. C 1/ Comptage du nombre de noeuds soumis a des relations
  560.       NBELEM=0
  561.       DO 27 J=1,KMILIE(/2)
  562.       DO 27 I=1,KMILIE(/1)
  563.         IF (KARET2(I,J).EQ.0) GOTO 27
  564.         IF (KMILIE(I,J).GT.0) NBELEM=NBELEM+1
  565.    27  CONTINUE
  566. C
  567. C 2/ Creation de IPT6
  568.       IPT6=0
  569.       IF (NBELEM.EQ.0) GOTO 999
  570.       NBNN=5
  571.       NBREF=0
  572.       NBSOUS=0
  573.       SEGINI IPT6
  574.       IPT6.ITYPEL=48
  575. C
  576. C 3/ Renseignement des noeuds support des relations
  577.       DO 28 J=1,KMILIE(/2)
  578.       DO 28 I=1,KMILIE(/1)
  579.         IF (KARET2(I,J).EQ.0) GOTO 28
  580.         IF (KMILIE(I,J).GT.0) THEN
  581.           NBREF=NBREF+1
  582.           IPT6.NUM(1,NBREF)=KMILIE(I,J)
  583.         ENDIF
  584.    28  CONTINUE
  585. C
  586. C 4/ Recherche des noeuds formant les relations
  587.       DO 24 IARAF=1,MELVA2.VELCHE(/2)
  588.         IF (MELVA2.VELCHE(1,IARAF).NE.1) GOTO 24
  589.         JCOMPT=0
  590.         JPOS5=LPOS5(IPT2.ITYPEL)
  591.         DO 23 I=1,NBRAF(IPT2.ITYPEL)
  592.           JPOS1=LPOS1(1,I+LPOS2(IPT2.ITYPEL)-1)
  593.           JLONG=LPOS1(2,I+LPOS2(IPT2.ITYPEL)-1)
  594.           JLISN=LPOS3(IPT2.ITYPEL)+JCOMPT
  595.           LTYPNO=JTYPNO(JPOS5-1+I)
  596.           IF (LTYPNO.NE.0) GOTO 22
  597.           NPTA=IPT2.NUM(LISNOE(JLISN),IARAF)
  598.           NPTB=IPT2.NUM(LISNOE(JLISN+1),IARAF)
  599.           NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  600.           NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  601.           DO 29 K=1,MAX(1,KARPOS(NMIN))
  602.             IF (KARETE(NMIN,K).EQ.NMAX) NEXIST=K
  603.   29      CONTINUE
  604.           IF (KARET2(NMIN,NEXIST).EQ.0) GOTO 22
  605.           IF (KMILIE(NMIN,NEXIST).EQ.0) GOTO 22
  606.           NEXIS5=0
  607.           DO 20 MM=1,IPT6.NUM(/2)
  608.             INOEGL=KMILIE(NMIN,NEXIST)
  609.             INRELA=IPT6.NUM(1,MM)
  610.             IF (INOEGL.EQ.INRELA) NEXIS5=MM
  611.   20      CONTINUE
  612. C
  613. C 5/ Renseignement des noeuds formant les relations
  614.           DO 21 IHH=1,JLONG
  615.             IPT6.NUM(1+IHH,NEXIS5)=IPT2.NUM(LISNOE(JLISN-1+IHH),IARAF)
  616.   21      CONTINUE
  617.           IF (JLONG.EQ.2) IPT6.NUM(5,NEXIS5)=1
  618.           IF (JLONG.EQ.3) IPT6.NUM(5,NEXIS5)=2
  619.   22      CONTINUE
  620.         JCOMPT=JCOMPT+JLONG
  621.   23    CONTINUE
  622.   24  CONTINUE
  623.  
  624.  444  CONTINUE
  625.  
  626. C
  627. C============================================
  628. C C) Creation du maillage de relations final !
  629. C============================================
  630.       IF (IPT5.EQ.0) THEN
  631.         IPT7=IPT6
  632.         GOTO 999
  633.       ENDIF
  634.       NBELEM=IPT5.NUM(/2)+IPT6.NUM(/2)
  635. C      NBNN=MAX(IPT5.NUM(/1),IPT6.NUM(/1))
  636.       NBNN=10
  637.       NBREF=0
  638.       NBSOUS=0
  639.       SEGINI IPT7
  640.       IPT7.ITYPEL=48
  641.       DO 42 NEO=1,IPT5.NUM(/2)
  642.       DO 42 MOR=1,10
  643.         IPT7.NUM(MOR,NEO)=IPT5.NUM(MOR,NEO)
  644.         IPT7.ICOLOR(NEO)=IPT5.ICOLOR(NEO)
  645.   42  CONTINUE
  646.       NN5 = IPT5.NUM(/2)
  647.       DO 43 NEO=IPT5.NUM(/2)+1,IPT6.NUM(/2)+IPT5.NUM(/2)
  648.       DO 43 MOR=1,IPT6.NUM(/1)
  649.         IF (MOR.LT.IPT6.NUM(/1)) THEN
  650.           IPT7.NUM(MOR,NEO)=IPT6.NUM(MOR,NEO-NN5)
  651.         ELSE
  652.           IPT7.NUM(10,NEO)=IPT6.NUM(MOR,NEO-NN5)
  653.         ENDIF
  654.         IPT7.ICOLOR(NEO)=IPT6.ICOLOR(NEO-NN5)
  655.   43  CONTINUE
  656.       WRITE(*,*) '  |-> raffinement OK'
  657. C=======================================================================
  658. C                      Fin du programme
  659. C=======================================================================
  660.       GOTO 999
  661.       WRITE(*,*) '****************************************************'
  662.       WRITE(*,*) 'TABLEAU JNOEFA'
  663.       DO 64 I=1,JNOEFA(/1)
  664.         WRITE(*,1000) I,':',(JNOEFA(I,J), J=1,JNOEFA(/2))
  665.   64  CONTINUE
  666.       WRITE(*,*) '****************************************************'
  667.       WRITE(*,*) 'TABLEAU JFARAF'
  668.       WRITE(*,*) 'Nb colonnes = ',JFARAF(/2)
  669.       DO 63 I=1,JFARAF(/1)
  670.         WRITE(*,1000) I,':',(JFARAF(I,J), J=1,JFARAF(/2))
  671.   63  CONTINUE
  672.       GOTO 999
  673.       WRITE(*,*) '****************************************************'
  674.       WRITE(*,*) 'TABLEAU JPLANS'
  675.       DO 61 I=1,JPLANS(/1)
  676.         WRITE(*,1000) I,':',(JPLANS(I,J), J=1,JPLANS(/2))
  677.   61  CONTINUE
  678.       WRITE(*,*) '****************************************************'
  679.       WRITE(*,*) 'TABLEAU JPLAN3'
  680.       DO 62 I=1,JPLAN3(/1)
  681.         WRITE(*,1000) I,':',(JPLAN3(I,J), J=1,JPLAN3(/2))
  682.   62  CONTINUE
  683.       WRITE(*,*) '****************************************************'
  684.       WRITE(*,*) 'TABLEAU ICPR'
  685.       DO 98 I=1,ICPR(/1)
  686.         WRITE(*,*) I,': ',ICPR(I,1),' ',ICPR(I,2)
  687.   98  CONTINUE
  688.  1000 FORMAT (1I3,A,24I4)
  689.  999  CONTINUE
  690.       RETURN
  691.       END
  692.  
  693.  
  694.  
  695.  
  696.  
  697.  
  698.  
  699.  
  700.  
  701.  
  702.  
  703.  
  704.  

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