Télécharger la plaquette Cast3M


fr en

Télécharger raff.eso

Retour à la liste

Numérotation des lignes : 

raff

  1. C RAFF      SOURCE    CB215821  24/04/12    21:17:02     11897          
  2.       SUBROUTINE RAFF
  3. C----------------------------------------------------------------------C
  4. C                            Operateur RAFF                            C
  5. C----------------------------------------------------------------------C
  6. C
  7. C Syntaxe 1 : GEO2 = RAFF GEO1 CHPO1 ;
  8. C
  9. C Syntaxe 2 : LRE2 = RAFF LRE1 ENT1 ;
  10. C   
  11. C----------------------------------------------------------------------C
  12.       IMPLICIT REAL*8(A-H,O-Z)
  13.       IMPLICIT INTEGER(I-N)
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMCOORD
  18. -INC CCGEOME
  19. -INC SMELEME
  20. -INC SMCHPOI
  21. -INC SMMODEL
  22. -INC SMCHAML
  23. c-INC CCREEL
  24. C
  25.       INTEGER MCOL,NCOL
  26. C--------------------------------
  27. C B) VARIABLES RELATIVES A LA 2D !
  28. C--------------------------------
  29.       SEGMENT KARETE(NBNDS,NCOL)
  30.       SEGMENT KARET2(NBNDS,NCOL)
  31.       SEGMENT KMILIE(NBNDS,NCOL)
  32.       SEGMENT KARPOS(NBNDS)
  33. C
  34. C--------------------------------
  35. C C) VARIABLES RELATIVES A LA 3D !
  36. C--------------------------------
  37.       SEGMENT IRELA(NBNDS)
  38.       SEGMENT JPLANS(JPLA1,JPLA2)
  39.       SEGMENT JPLAN2(JPLA1,JPLA2)
  40.       SEGMENT JPLAN3(JPLA1,JPLA2)
  41.       SEGMENT JPLCOM(JPLA1)
  42.       SEGMENT JNOEFA(JNBFA,5)
  43.       SEGMENT IWORK2(JNBSOM)
  44.       SEGMENT JFARAF(JNBFA,LLLL)
  45.       SEGMENT IWORK1(IJKLMN)
  46. C--------------------------
  47. C A) VARIABLES 'GENERALES' !
  48. C--------------------------
  49.       SEGMENT ICPR(nbpts,2)
  50.       SEGMENT LTYPE(NBLIS,2)
  51.       SEGMENT LTYPE2(NBLIS2,4)
  52.       SEGMENT LTYPE3(NBLIS3,2)
  53.       SEGMENT LTYPE4(NBLIS3,2)
  54. c       SEGMENT ICHPO
  55. c         REAL*8 XR(NBPTCH),YR(NBPTCH),ZR(NBPTCH),DEN(NBPTCH)
  56. c       ENDSEGMENT
  57.       SEGMENT IDENSI
  58.         REAL*8 DENSI(NBNDS)
  59.       ENDSEGMENT
  60.       SEGMENT XDEN(nbpts)
  61.       XPETI= 1E-30
  62. C
  63. C---------------------------------------------------
  64. C D) VARIABLES RELATIVES AUX MAILLAGES DE RELATIONS !
  65. C---------------------------------------------------
  66.       POINTEUR IPT10.MELEME
  67.       POINTEUR IPT11.MELEME
  68.       POINTEUR IPT12.MELEME
  69.       POINTEUR IPT13.MELEME
  70.  
  71.       POINTEUR IPT14.MELEME
  72.       POINTEUR IPT15.MELEME
  73.       POINTEUR IPT16.MELEME
  74.       SEGMENT MAIREL(NBMAIL)
  75. C=======================================================================
  76. C                  Lecture des donnees utilisateurs
  77. C=======================================================================
  78. C
  79. C     SYNTAXE 2 : cas du LISTREEL 
  80. C     ---------------------------
  81.       CALL LIROBJ('LISTREEL',ILRE1,0,IRETOU)
  82.       IF (IERR.NE.0) RETURN
  83. C
  84.       IF (IRETOU.NE.0) THEN
  85.         ICAS = 0 
  86.         CALL LIRENT(KR1,0,IRETOU)
  87.         IF (IERR.NE.0) RETURN
  88.         IF (IRETOU.EQ.0) THEN
  89.           CALL LIRREE(XR1,1,IRETOU)
  90.           IF (IERR.NE.0) RETURN
  91.           ICAS = 2 
  92.         ELSE
  93.           ICAS = 1
  94.         ENDIF
  95.         CALL RAFLRE(ILRE1,KR1,XR1,ICAS,ILRE2)
  96.         IF (IERR.NE.0) RETURN
  97.         IF (ILRE2.NE.0) THEN
  98.           CALL ECROBJ('LISTREEL',ILRE2)
  99.         ELSE
  100.           CALL ERREUR(5)
  101.         ENDIF
  102.         RETURN
  103.       ENDIF
  104. C
  105. C     SYNTAXE 1 : cas du MAILLAGE
  106. C     ---------------------------
  107. C On lit le maillage a raffiner et le champoint de densite a affecter
  108. c ipt1 : maillage initial à raffiner
  109. c mchpo1 : chapoint de densité voulu(que devrai être définit sur ipt1)
  110.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  111.       CALL ACTOBJ('MAILLAGE',IPT1,1)
  112.       IF (IERR.NE.0) RETURN
  113.       CALL LIROBJ('CHPOINT',MCHPO1,1,IRETOU)
  114.       CALL ACTOBJ('CHPOINT',MCHPO1,1)
  115.       IF (IERR.NE.0) RETURN
  116. C
  117. C=======================================================================
  118. C                   Initialisations - Declarations
  119. C=======================================================================
  120.       NCOL=0
  121.       MCOL=0
  122.       NBOUCL=0
  123.       NPTINI=nbpts
  124.       SEGACT IPT1
  125.  
  126.       IJKLMN=4
  127.       SEGINI IWORK1
  128.       IWORK1(1)=4
  129.       IWORK1(2)=8
  130.       IWORK1(3)=6
  131.       IWORK1(4)=10
  132.  
  133.       SEGINI,XDEN
  134.  
  135. C
  136. C=======================================================================
  137. C                       Tests sur les donnees
  138. C=======================================================================
  139. C On teste pour savoir si le maillage IPT1 (maillage 1) a un type
  140. C d'elements implemante.
  141. c TRI3 TRI6 QUA4 QUA8 CUB8 CUB26 PRY6 PR15 TET4 TET10 SURE
  142. C les pyramides 5 et 13 ont été débranchés
  143. c création du tableau 
  144.       NBLIS=MAX(1,IPT1.LISOUS(/1))
  145.       NSURE=0
  146.       SEGINI LTYPE
  147.       DO  1 INB=1,MAX(1,IPT1.LISOUS(/1))
  148.         IF (IPT1.LISOUS(/1).EQ.0) THEN
  149.           IPT2=IPT1
  150.         ELSE
  151.           IPT2=IPT1.LISOUS(INB)
  152.           SEGACT IPT2
  153.         ENDIF
  154.         NT=IPT2.ITYPEL
  155.         IF (NT.EQ.48) NSURE=NSURE+1
  156.         LTYPE(INB,1)=INB
  157.         LTYPE(INB,2)=NT
  158.         IF (NT.EQ.16) THEN
  159.           write (*,*) 'Attention le raffinement PRI6 a debrancher !'
  160.         ENDIF 
  161.         IF (NT.EQ.23) THEN
  162.           write (*,*) 'Attention le raffinement TET4 a debrancher !'
  163.         ENDIF 
  164.         IF ((NT.NE.4).AND.(NT.NE.6).AND.(NT.NE.8).AND.(NT.NE.10).AND.
  165.      +   (NT.NE.14).AND.(NT.NE.15).AND.(NT.NE.16).AND.(NT.NE.17).AND.
  166.      +   (NT.NE.23).AND.(NT.NE.24).AND.(NT.NE.48)) THEN
  167.           WRITE(*,*) 'Erreur, type d element non pris en compte'
  168.           RETURN
  169.         ENDIF
  170. c        write(*,*) 'type d elem du maillage de depart', LTYPE(INB,1), 
  171. c     +  LTYPE(INB,2)
  172.  
  173. C        IF ((NT.NE.4).AND.(NT.NE.6).AND.(NT.NE.8).AND.(NT.NE.10).AND.
  174. C     +   (NT.NE.14).AND.(NT.NE.15).AND.(NT.NE.16).AND.(NT.NE.17).AND.
  175. C     +   (NT.NE.23).AND.(NT.NE.24).AND.(NT.NE.48).AND.(NT.NE.25).AND.
  176. C     +   (NT.NE.26)) RETURN
  177.         IF ((IPT1.LISOUS(/1).EQ.0).AND.(NT.EQ.48)) RETURN
  178.    1  CONTINUE
  179.  
  180. C
  181. C=======================================================================
  182. C                  Separation du maillage initial
  183. C=======================================================================
  184. C Si le maillage initial comporte des lisous de type 48, on le separe
  185. C en deux maillages dont un ne sera compose que des lisous de type 48.
  186. C Maillage d'elements de type 48 : IPT6
  187. C Maillage sans elements de type 48 : IPT5
  188. C IPT1 reste le maillage initial complet
  189.       LCONF2=0
  190.       IF (NSURE.EQ.0) GOTO 7
  191.       LCONF2=1
  192.    7  CONTINUE
  193. C-------------------------------
  194. C A) Creation du maillage IPT6 !
  195. C-------------------------------
  196. C  A.1/** Cas ou il n'y a qu'un lisous de type 48
  197.       IF (NSURE.EQ.1) THEN
  198.         DO 2 K=1,LTYPE(/1)
  199.           IF (LTYPE(K,2).EQ.48) IPT6=IPT1.LISOUS(LTYPE(K,1))
  200.    2    CONTINUE
  201.       ENDIF
  202. C
  203. C  A.2/** Cas ou il y a plusieurs lisous de type 48
  204.       IF (NSURE.GT.1) THEN
  205.         NBREF=0
  206.         NBSOUS=NSURE
  207.         NBNN=0
  208.         NBELEM=0
  209.         SEGINI IPT6
  210.         KLISOU=0
  211.         DO 3 K=1,LTYPE(/1)
  212.           IF (LTYPE(K,2).EQ.48) THEN
  213.             KLISOU=KLISOU+1
  214.             IPT6.LISOUS(KLISOU)=IPT1.LISOUS(LTYPE(K,1))
  215.           ENDIF
  216.    3    CONTINUE
  217.       ENDIF
  218.       IF (NSURE.EQ.0) THEN
  219.         NBREF=0
  220.         NBSOUS=NSURE
  221.         NBNN=0
  222.         NBELEM=0
  223.         SEGINI IPT6
  224.       ENDIF
  225. C
  226. C------------------------------
  227. C B) Creation de IPT5 !
  228. C------------------------------
  229. C
  230.       NBSOUS=LTYPE(/1)-NSURE
  231.       NBREF=0
  232.       NBNN=0
  233.       NBELEM=0
  234. C B.0/** Cas ou il n'y a qu'un lisous en tout
  235.       IF ((NBSOUS.EQ.1).AND.(NSURE.EQ.0)) THEN
  236.         NBSOUS=0
  237.         SEGINI IPT5
  238.         IPT5=IPT1
  239.       ENDIF
  240. C B.1/** Cas ou il n'y a qu'un lisous de type different de 48
  241.       IF ((NBSOUS.EQ.1).AND.(NSURE.NE.0)) THEN
  242.         SEGINI IPT5
  243.         DO 4 K=1,LTYPE(/1)
  244.           IF (LTYPE(K,2).NE.48) IPT5=IPT1.LISOUS(LTYPE(K,1))
  245.    4    CONTINUE
  246.       ENDIF
  247. C
  248. C B.2/** Cas ou il y a plusieurs lisous de types differents de 48
  249.       IF (NBSOUS.GT.1) THEN
  250.         SEGINI IPT5
  251.         KLISOU=0
  252.         DO 5 K=1,LTYPE(/1)
  253.           IF (LTYPE(K,2).NE.48) THEN
  254.             KLISOU=KLISOU+1
  255.             IPT5.LISOUS(KLISOU)=IPT1.LISOUS(LTYPE(K,1))
  256.           ENDIF
  257.    5    CONTINUE
  258.       ENDIF
  259.  
  260. c compteur de relaton globale
  261.       LCONF3=LCONF2
  262. C=======================================================================
  263. C         Debut de la boucle sur les itérations de Raffinement
  264. C=======================================================================
  265.    9  CONTINUE
  266.  
  267. c       write(*,*) 'RAFF: ITERATION boucle 9',NBOUCL
  268. c       write(*,*) 'ipt5 : ', ipt5
  269. c       write(*,*) 'ipt6 : ', ipt6
  270. c       write(*,*) 'lconf3 : ', lconf3
  271. C
  272. C=======================================================================
  273. C         Renumerotation locale des noeuds du maillage
  274. C=======================================================================
  275. C ICPR(I,1)=J : Le Ieme noeud global est le Jeme local
  276. C ICPR(I,2)=J : Le Ieme noeud global appartient a J elements
  277.  
  278.       SEGACT IPT5
  279.  
  280.       NBOUCL=NBOUCL+1
  281.       SEGINI ICPR
  282.       NBNDS=0
  283.       NCOL=0
  284.       DO 11 INB=1,MAX(1,IPT5.LISOUS(/1))
  285.         IF (IPT5.LISOUS(/1).EQ.0) THEN
  286.           IPT2=IPT5
  287.         ELSE
  288.           IPT2=IPT5.LISOUS(INB)
  289.           SEGACT IPT2
  290.         ENDIF
  291.         IF (IPT2.ITYPEL.EQ.48) GOTO 11
  292.         DO 10 J=1,IPT2.NUM(/2)
  293.         DO 110 I=1,IPT2.NUM(/1)
  294.           ITMP=IPT2.NUM(I,J)
  295.           IF (ICPR(ITMP,1).NE.0) THEN
  296.             ICPR(ITMP,2)=ICPR(ITMP,2)+1
  297.             NCOL=MAX(NCOL,ICPR(ITMP,2))
  298.           ELSE
  299.             NBNDS=NBNDS+1
  300.             ICPR(ITMP,1)=NBNDS
  301.             ICPR(ITMP,2)=1
  302.             NCOL=MAX(NCOL,ICPR(ITMP,2))
  303.           ENDIF
  304.  110    CONTINUE
  305.   10    CONTINUE
  306.   11  CONTINUE
  307.       IF (IDIM.EQ.2) NCOL=NCOL*2
  308.       IF (IDIM.EQ.3) NCOL=NCOL*4
  309. C
  310. C
  311. C
  312. C
  313. C=======================================================================
  314. C           Prise en compte des noeuds de relations
  315. C=======================================================================
  316. C IRELA(I,1) = 1 si le noeud I (en numerotation locale) est un noeud 
  317. C                   de relation ("hanging node")
  318. C IRELA(I,1) = 0 sinon
  319.       SEGINI IRELA
  320.       IF (LCONF3.EQ.0) GOTO 1200
  321.       SEGACT IPT6
  322.       DO 1218 LAA=1,MAX(1,IPT6.LISOUS(/1))
  323.         IF (IPT6.LISOUS(/1).EQ.0) THEN
  324.           IPT2=IPT6
  325.         ELSE
  326.           IPT2=IPT6.LISOUS(LAA)
  327.         ENDIF
  328.         SEGACT IPT2
  329.         IF (IPT2.ITYPEL.NE.48) GOTO 1218
  330.         DO 1220 J=1,IPT2.NUM(/2)
  331.           IRELA(ICPR(IPT2.NUM(1,J),1))=1
  332.  1220   CONTINUE
  333.  1218 CONTINUE
  334.  1200 CONTINUE
  335.  
  336. C
  337. C=======================================================================
  338. C           Prise en compte du champoint de densite
  339. C=======================================================================
  340. C On affecte une densite a chacun des noeuds du maillage. On calcule
  341. C cette densite a partir des densites existantes dans le champoint, a
  342. C l'aide de la fonction RAFDEN.
  343. C Remarque : on ne prend pas en compte les densites qui pourraient
  344. C exister dans le tableau XCOOR.
  345. C
  346.  
  347. C------------------------------------------
  348. C A) Recuperation des valeurs du champoint !
  349. C------------------------------------------
  350. C XDEN(I,1) = densite affectee au noeud I (en numerotation globale)
  351.       IF (NBOUCL.EQ.1) THEN
  352.       SEGACT MCHPO1
  353.       IF (MCHPO1.IPCHP(/1).NE.1) RETURN
  354.       MSOUPO=MCHPO1.IPCHP(1)
  355.       SEGACT MSOUPO
  356.       IPT3=IGEOC
  357.       MPOVA1=IPOVAL
  358.       SEGACT IPT3
  359.       SEGACT MPOVA1
  360.       IF (MPOVA1.VPOCHA(/2).NE.1) RETURN
  361.       NBPTCH=IPT3.NUM(/2)
  362. c       SEGINI ICHPO
  363.       DO 13 I=1,NBPTCH
  364.         J=IPT3.NUM(1,I)
  365. c         XR(I)=XCOOR((J-1)*(IDIM+1)+1)
  366. c         YR(I)=XCOOR((J-1)*(IDIM+1)+2)
  367. c         IF (IDIM.EQ.3) ZR(I)=XCOOR((J-1)*(IDIM+1)+3)
  368. c         DEN(I)=MPOVA1.VPOCHA(I,1)
  369. c           if(J.eq.115.or.J.eq.321.or.
  370. c      .       J.eq.6261.or.J.eq.5815) then
  371. C             write(*,*) 'RAFF: #',J,'DEN(',I,'/',NBPTCH,')=',DEN(I)
  372. c           endif
  373.         XDEN(J)=MPOVA1.VPOCHA(I,1)
  374.   13  CONTINUE
  375. C     Rem ;seulement pour les noeud "peres",
  376. C     pour les "fils" raff2d remplit XDEN
  377.       ENDIF
  378. C
  379. C--------------------------------------------------------------
  380. C B) Affectation d'une densite a chacun des noeuds du maillage !
  381. C--------------------------------------------------------------
  382. C IDENSI(I,1) = densite affectee au noeud I (en numerotation locale)
  383.       SEGINI IDENSI
  384.       DO 15 INB=1,MAX(1,IPT5.LISOUS(/1))
  385.         IF (IPT5.LISOUS(/1).EQ.0) THEN
  386.           IPT2=IPT5
  387.         ELSE
  388.           IPT2=IPT5.LISOUS(INB)
  389.           SEGACT IPT2
  390.         ENDIF
  391. c        write(*,*) 'ipt2 : ', ipt2, 'type', IPT2.ITYPEL
  392. c        write(*,*)  IPT2.NUM(/2), IPT2.NUM(/1)
  393. c        IF (IPT2.ITYPEL.EQ.48) GOTO 15
  394.         DO 14 J=1,IPT2.NUM(/2)
  395.         DO 114 I=1,IPT2.NUM(/1)
  396.           NGLOB=IPT2.NUM(I,J)
  397.           NLOC=ICPR(NGLOB,1)
  398. c           XPT=XCOOR((NGLOB-1)*(IDIM+1)+1)
  399. c           YPT=XCOOR((NGLOB-1)*(IDIM+1)+2)
  400. c           ZPT=0
  401. c           IF (IDIM.EQ.3) ZPT=XCOOR((NGLOB-1)*(IDIM+1)+3)
  402. c           CALL RAFDEN(ICHPO,XPT,YPT,ZPT,IDIM,DENPT)
  403. c           DENSI(NLOC)=DENPT
  404.           DENSI(NLOC)=XDEN(NGLOB)
  405. c          WRITE (*,*) 'densite au pt', NGLOB, XDEN(NGLOB), XPETI
  406.           IF (XDEN(NGLOB).LT.XPETI) THEN
  407.               WRITE (*,*) 'Champ de densité en entrée nul au point',
  408.      +   NGLOB, 'impossible de raffiner'
  409.               RETURN              
  410.           ENDIF
  411.  114    CONTINUE
  412.   14    CONTINUE
  413.   15  CONTINUE
  414. C
  415. C=======================================================================
  416. C                Remplissage du tableau KARETE
  417. C=======================================================================
  418. C On remplit le tableau KARETE avec les donnees provenant de l'analyse
  419. C du maillage.
  420. C KARETE(i,j)=k : le ieme noeud local forme une arete
  421. C   avec le keme noeud local (k>i)
  422. C KARPOS(i)=k : compteur de position (k=nb d'aretes touchant i)
  423. C KARET2(i,j)=k : l'arete i-j appartient a k elements
  424.       JPLA1=NBNDS
  425.       JPLA2=NCOL
  426.       SEGINI KARETE,KARPOS,KARET2
  427.       NBARET=0
  428.       NCOL=1
  429.       DO 18 INB=1,MAX(1,IPT5.LISOUS(/1))
  430.         IF (IPT5.LISOUS(/1).EQ.0) THEN
  431.           IPT2=IPT5
  432.         ELSE
  433.           IPT2=IPT5.LISOUS(INB)
  434.           SEGACT IPT2
  435.         ENDIF
  436. c        IF (IPT2.ITYPEL.EQ.48) GOTO 18
  437.         ILPL=LPL(IPT2.ITYPEL)
  438.         ILPT=LPT(IPT2.ITYPEL)
  439.         DO 17 J=1,IPT2.NUM(/2)
  440.         DO 117 K=1,ILPL*2-1,2
  441.           NPTA=IPT2.NUM(KSEGM(ILPT+K-1),J)
  442.           NPTB=IPT2.NUM(KSEGM(ILPT+K),J)
  443.           NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  444.           NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  445.           NEXIST=0
  446.           DO 16 I=1,MAX(1,KARPOS(NMIN))
  447.             IF (KARETE(NMIN,I).EQ.NMAX) NEXIST=I
  448.   16      CONTINUE
  449. c création d'une nouvelle arrète
  450.           IF (NEXIST.EQ.0) THEN
  451.             IF ((KARPOS(NMIN)+1).GT.NCOL) THEN
  452.               NCOL=KARPOS(NMIN)+1
  453.               SEGADJ KARETE, KARET2
  454.             ENDIF
  455.             KARPOS(NMIN)=KARPOS(NMIN)+1
  456.             KARETE(NMIN,KARPOS(NMIN))=NMAX
  457.             KARET2(NMIN,KARPOS(NMIN))=1
  458.             NBARET=NBARET+1
  459. c            NCOL=MAX(NCOL,KARPOS(NMIN))
  460.           ENDIF
  461.           IF (NEXIST.NE.0) THEN
  462.             KARET2(NMIN,NEXIST)=KARET2(NMIN,NEXIST)+1
  463.           ENDIF
  464.  117    CONTINUE
  465.   17    CONTINUE
  466.   18  CONTINUE
  467. c      SEGADJ KARETE,KARET2
  468.       SEGDES KARETE,KARPOS,KARET2
  469. C
  470. C=======================================================================
  471. C          Remplissage des tableaux JPLANS et JNOEFA
  472. C=======================================================================
  473. C On remplit les tableaux de description des faces dans le cas 3D.
  474. C JPLANS(i,j)=k : la jeme face dont le plus petit sommet en
  475. C                 numerotation locale est le sommet i est la face k
  476. C JNOEFA(i,1-3)=j-k-l : Les 3 plus petits sommets en numerotation
  477. C                       locale de la face i sont les noeuds j,k et l
  478. C JNOEFA(i,4-5)=j-k : La face identifiee par les 3 sommets precedents
  479. C                     appartient aux lisous de type j et k
  480. C JPLCOM(i)=k : compteur de position (k=nb de faces touchant i)
  481.       IF (IDIM.NE.3) GOTO 40
  482. C----------------------------------------------------
  483. C A) Comptage du nombre d'elements total du maillage !
  484. C----------------------------------------------------
  485.       NELTOT=0
  486.       DO 50 INB=1,MAX(1,IPT5.LISOUS(/1))
  487.         IF (IPT5.LISOUS(/1).EQ.0) THEN
  488.           IPT2=IPT5
  489.         ELSE
  490.           IPT2=IPT5.LISOUS(INB)
  491.           SEGACT IPT2
  492.         ENDIF
  493.         NELTOT=NELTOT+IPT2.NUM(/2)
  494.   50  CONTINUE
  495. C
  496. C-------------------------------------------------
  497. C B) Initialisation des tableaux JPLANS et JNOEFA !
  498. C-------------------------------------------------
  499.       JNBFA=NELTOT*6
  500.       JMAXPL=0
  501.       JNUMFA=0
  502.       SEGINI JPLANS,JPLCOM,JNOEFA
  503. C
  504. C-----------------------------------------------
  505. C C)  Remplissage des tableaux JPLANS et JNOEFA !
  506. C-----------------------------------------------
  507.       DO 51 INB=1,MAX(1,IPT5.LISOUS(/1))
  508.         IF (IPT5.LISOUS(/1).EQ.0) THEN
  509.           IPT2=IPT5
  510.         ELSE
  511.           IPT2=IPT5.LISOUS(INB)
  512.           SEGACT IPT2
  513.         ENDIF
  514. C        IF (IPT2.ITYPEL.EQ.48) GOTO 51
  515.         DO 52 KELEM=1,IPT2.NUM(/2)
  516.           JTYPEL=IPT2.ITYPEL
  517.           JLTEL1=LTEL(1,JTYPEL)
  518.           JLTEL2=LTEL(2,JTYPEL)
  519.           DO 53 IBB=1,JLTEL1
  520.             JLDEL1=LDEL(1,JLTEL2-1+IBB)
  521.             JTYFAC=IWORK1(JLDEL1)
  522.             JLDEL2=LDEL(2,JLTEL2-1+IBB)
  523.             JNBSOM=NBSOM(JTYFAC)
  524.             JSPOS=NSPOS(JTYFAC)
  525.             SEGINI IWORK2
  526.             DO 54 IAA=1,JNBSOM
  527.               NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),KELEM)
  528.               IWORK2(IAA)=NGLOBA
  529.   54        CONTINUE
  530. C
  531. C----------------------------------------------------
  532. C D)  Tri des sommets de la face par ordre croissant !
  533. C----------------------------------------------------
  534. C On va ranger les 3 plus petits sommets de la face (en numerotation
  535. C globale) dans les variables NPTA, NPTB, NPTC. On les classe par ordre
  536. C croissant.
  537. C
  538. C 1/ Classement des 3 sommets par ordre croissant (num globale)
  539.             NPTA=nbpts+1
  540.             NPTB=NPTA+1
  541.             NPTC=NPTB+1
  542.             DO 55 ICC=1,JNBSOM
  543.               IF (IWORK2(ICC).LT.NPTA) THEN
  544.                 NPTC=NPTB
  545.                 NPTB=NPTA
  546.                 NPTA=IWORK2(ICC)
  547.               ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  548.                 NPTC=NPTB
  549.                 NPTB=IWORK2(ICC)
  550.               ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  551.                 NPTC=IWORK2(ICC)
  552.               ENDIF
  553.   55        CONTINUE
  554. C
  555. C 2/ Classement des 3 sommets par ordre croissant (num locale)
  556.             NPTA2=ICPR(NPTA,1)
  557.             NPTB2=ICPR(NPTB,1)
  558.             NPTC2=ICPR(NPTC,1)
  559.             IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  560.               NPTA=NPTA2
  561.               NPTB=MIN(NPTB2,NPTC2)
  562.               NPTC=MAX(NPTB2,NPTC2)
  563.             ENDIF
  564.             IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  565.               NPTA=NPTB2
  566.               NPTB=MIN(NPTA2,NPTC2)
  567.               NPTC=MAX(NPTA2,NPTC2)
  568.             ENDIF
  569.             IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  570.               NPTA=NPTC2
  571.               NPTB=MIN(NPTA2,NPTB2)
  572.               NPTC=MAX(NPTA2,NPTB2)
  573.             ENDIF
  574. C
  575. C----------------------------------------
  576. C E)  Renseignement des nouvelles faces  !
  577. C----------------------------------------
  578.             SEGACT LTYPE
  579. c            IHERED=0
  580. c            DO 1022 MOI=1,IPT2.NUM(/1)
  581. c              IHERED=IHERED+IRELA(ICPR(IPT2.NUM(MOI,KELEM),1))
  582. c 1022       CONTINUE
  583.  
  584. C Si NPTA Ne correspond a aucune face : On cree une face
  585.             IF (JPLCOM(NPTA).EQ.0) THEN
  586.               JNUMFA=JNUMFA+1
  587.               JPLCOM(NPTA)=JPLCOM(NPTA)+1
  588.               JPLANS(NPTA,JPLCOM(NPTA))=JNUMFA
  589.               JNOEFA(JNUMFA,1)=NPTA
  590.               JNOEFA(JNUMFA,2)=NPTB
  591.               JNOEFA(JNUMFA,3)=NPTC
  592.               JNOEFA(JNUMFA,4)=LTYPE(INB,2)
  593. c              IF (IHERED.NE.0) JNOEFA(JNUMFA,5)=LTYPE(INB,2)
  594. C On signale les sous face de faces supportant un sure 
  595. C JNOEFA(JNUMFA,5)= 48
  596.               IF (LCONF3.NE.0) THEN
  597.                 SEGACT IPT6
  598.                 DO 501 LAA1=1,MAX(1,IPT6.LISOUS(/1))
  599.                   IF (IPT6.LISOUS(/1).EQ.0) THEN
  600.                     IPT4=IPT6
  601.                   ELSE
  602.                     IPT4=IPT6.LISOUS(LAA1)
  603.                   ENDIF
  604.                   SEGACT IPT4
  605.                   IF (IPT4.ITYPEL.NE.48) GOTO 501
  606.                   IF (IPT4.ICOLOR(1).NE.3) GOTO 501
  607.                   DO 502,MAA1=1,IPT4.NUM(/2)
  608.                     NEXI1=0
  609.                     NEXI2=0
  610.                     DO 503 ICC1=1,JNBSOM
  611.                       IF (IWORK2(ICC1).EQ.IPT4.NUM(1, MAA1)) THEN
  612.                         NEXI1=NEXI1+1
  613.                       ENDIF
  614.   503               CONTINUE
  615.                     IF (NEXI1.GT.0) THEN
  616.                       DO 504 ICC2=1,JNBSOM
  617.                       DO 1504 INN2=2,IPT4.NUM(/1)
  618.                         IF (IWORK2(ICC2).EQ.IPT4.NUM(INN2,MAA1)) THEN
  619.                           NEXI2=NEXI2+1
  620.                         ENDIF
  621.  1504                 CONTINUE 
  622.   504                 CONTINUE 
  623.                       IF (NEXI2.GT.0) JNOEFA(JNUMFA,5)= 48
  624.                     ENDIF
  625.   502             CONTINUE
  626.   501           CONTINUE
  627.               ENDIF
  628.  
  629.  
  630. C Si NPTA  correspond a aumoins une face 
  631.             ELSE
  632.               NEXIST=0
  633.               DO 56 IDD=1,JPLCOM(NPTA)
  634.                 ITEMP1=JPLANS(NPTA,IDD)
  635.                 NAA=JNOEFA(ITEMP1,1)
  636.                 NBB=JNOEFA(ITEMP1,2)
  637.                 NCC=JNOEFA(ITEMP1,3)
  638. C Si la face que actuelle existe déja : on renseigne JNOEFA(NEXIST,5) 
  639.                 IF (NAA.EQ.NPTA.AND.NBB.EQ.NPTB.AND.NCC.EQ.NPTC) THEN
  640.                   NEXIST=ITEMP1
  641.                   JNOEFA(NEXIST,5)=LTYPE(INB,2)
  642.                 ENDIF
  643.  
  644.  
  645.   56          CONTINUE
  646. C Si la face que actuelle n'existe pas :  On cree une face 
  647.               IF (NEXIST.EQ.0) THEN
  648.                 JNUMFA=JNUMFA+1
  649.                 JPLCOM(NPTA)=JPLCOM(NPTA)+1
  650.                 JPLANS(NPTA,JPLCOM(NPTA))=JNUMFA
  651.                 JNOEFA(JNUMFA,1)=NPTA
  652.                 JNOEFA(JNUMFA,2)=NPTB
  653.                 JNOEFA(JNUMFA,3)=NPTC
  654.                 JNOEFA(JNUMFA,4)=LTYPE(INB,2)
  655. c                IF (IHERED.NE.0) JNOEFA(JNUMFA,5)=LTYPE(INB,2)
  656.  
  657. C On signale les sous face de faces supportant un sure 
  658. C JNOEFA(JNUMFA,5)= 48
  659.                 IF (LCONF3.NE.0) THEN
  660.                   SEGACT IPT6
  661.                   DO 505 LAA1=1,MAX(1,IPT6.LISOUS(/1))
  662.                     IF (IPT6.LISOUS(/1).EQ.0) THEN
  663.                       IPT4=IPT6
  664.                     ELSE
  665.                       IPT4=IPT6.LISOUS(LAA1)
  666.                     ENDIF
  667.                     SEGACT IPT4
  668.                     IF (IPT4.ITYPEL.NE.48) GOTO 505
  669.                     IF (IPT4.ICOLOR(1).NE.3) GOTO 505
  670.                     DO 506,MAA1=1,IPT4.NUM(/2)
  671.                       NEXI1=0
  672.                       NEXI2=0
  673.                       DO 507 ICC1=1,JNBSOM
  674.                         IF (IWORK2(ICC1).EQ.IPT4.NUM(1, MAA1)) THEN
  675.                           NEXI1=NEXI1+1
  676.                         ENDIF
  677.   507                 CONTINUE
  678.                       IF (NEXI1.GT.0) THEN
  679.                         DO 508 ICC2=1,JNBSOM
  680.                         DO 1508 INN2=2,IPT4.NUM(/1)
  681.                           IF (IWORK2(ICC2).EQ.IPT4.NUM(INN2,MAA1)) THEN 
  682.                             NEXI2=NEXI2+1
  683.                           ENDIF
  684.  1508                   CONTINUE 
  685.   508                   CONTINUE 
  686.                         IF (NEXI2.GT.0) JNOEFA(JNUMFA,5)= 48
  687.                       ENDIF
  688.   506               CONTINUE
  689.   505             CONTINUE
  690.                 ENDIF
  691.               ENDIF
  692.             ENDIF
  693.  
  694.             JMAXPL=MAX(JMAXPL,JPLCOM(NPTA))
  695.   53      CONTINUE
  696.   52    CONTINUE
  697.   51  CONTINUE
  698.       JPLA2=JMAXPL
  699.       JNBFA=JNUMFA
  700.       SEGADJ JPLANS,JPLCOM,JNOEFA
  701.       SEGDES LTYPE
  702. C
  703. C=======================================================================
  704. C                  Pre-remplissage du tableau KMILIE
  705. C=======================================================================
  706. C On remplit le tableau lorsqu'il y a des maillages de relations de
  707. C type 48 (IPT6, LCONF3 non nul)
  708. C KARETE(i,j)=k ET KMILIE(i,j)=n : le noeud global n est situe
  709. C au milieu de l'arete [i,k]
  710.   40  CONTINUE
  711.       SEGINI KMILIE
  712.       SEGACT KARETE*MOD,KARPOS*MOD,KARET2*MOD
  713.       IF (LCONF3.EQ.0) THEN
  714.         GOTO 28
  715.       ENDIF
  716.   22  CONTINUE
  717.       NBRELA=0
  718.       SEGACT IPT6
  719.       DO 218 LAA=1,MAX(1,IPT6.LISOUS(/1))
  720.         IF (IPT6.LISOUS(/1).EQ.0) THEN
  721.           IPT2=IPT6
  722.         ELSE
  723.           IPT2=IPT6.LISOUS(LAA)
  724.         ENDIF
  725.         SEGACT IPT2
  726.         IF (IPT2.ITYPEL.NE.48) GOTO 218
  727.         IF ((IPT2.ICOLOR(1).NE.1).AND.(IPT2.ICOLOR(1).NE.2)) GOTO 218
  728.         DO 220 J=1,IPT2.NUM(/2)
  729.  
  730.           NPTA=IPT2.NUM(2,J)
  731.           NPTB=IPT2.NUM(3,J)
  732.           NPTC=IPT2.NUM(1,J)
  733.           NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  734.           NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  735.           NEXIST=0
  736.           DO 219 I=1,MAX(1,KARPOS(NMIN))
  737.             IF (KARETE(NMIN,I).EQ.NMAX) NEXIST=I
  738.  219      CONTINUE
  739.  
  740.           IF (NEXIST.NE.0) then 
  741.               KMILIE(NMIN,NEXIST)=NPTC
  742. c              WRITE (*,*) 'REPORT ANCIENNE RELA AU NOEUD:', NPTC 
  743. c              write (*,*) 'karret2(nmin nexist)', KARET2(NMIN,NEXIST)
  744.               KARET2(NMIN,NEXIST)=2
  745.           ELSE
  746.               IF (IDIM.EQ.2) goto 27
  747.               IF ((KARPOS(NMIN)+1).GT.NCOL) THEN
  748.                 NCOL=KARPOS(NMIN)+1
  749.                 SEGADJ KARETE, KARET2, KMILIE
  750.               ENDIF
  751.               JPOSI = KARPOS(NMIN)
  752.               KARPOS(NMIN)=JPOSI+1
  753.               KARETE(NMIN,JPOSI+1)=NMAX
  754.               KARET2(NMIN,JPOSI+1)=2
  755.               KMILIE(NMIN,JPOSI+1)=NPTC
  756. c              WRITE (*,*) 'création de l arrete:', NMIN, NMAX
  757.           ENDIF
  758. C
  759. C-----------------------------------------------
  760. C Prise en compte des relations "hereditaires" !
  761. C-----------------------------------------------
  762. C Cette partie sert a traiter le cas ou un element serait raffine
  763. C plusieurs fois alors qu'a sa frontiere les autres elements ne le
  764. C seraient pas. Il y aurait donc plusieurs points sur une arete ayant
  765. C des relations de conformite et plus seulement le noeud milieu.
  766. C
  767. c dans l'exenple ci dessous où les noeuds C et D sont des hanging nodes
  768. c L'arette [C B] n'a pas encore été créée c'est ce qui est fait ici.
  769. c
  770. c |                   |
  771. c |                   |
  772. c |A        C    D    |B
  773. c x---------X----X----X
  774. c |         |    |    |
  775. c |         |    |    |
  776.    27     CONTINUE
  777.           IF (IDIM.EQ.2) THEN
  778. C 1/ Test sur la premiere arete : NMIN-NPTC
  779.             IF (NEXIST.NE.0) THEN
  780.               NEXIS2=0
  781.               NMIN2=MIN(NMIN,ICPR(NPTC,1))
  782.               NMAX2=MAX(NMIN,ICPR(NPTC,1))
  783.               DO 24 I=1,MAX(1,KARPOS(NMIN2))
  784.                 IF (KARETE(NMIN2,I).EQ.NMAX2) NEXIS2=I
  785.    24         CONTINUE
  786.               IF (NEXIS2.EQ.0) THEN
  787.                 NBRELA=NBRELA+1
  788.                 JNBCOL=KARETE(/2)
  789.                 JPOSI=KARPOS(NMIN2)
  790.                 IF (JNBCOL.GT.JPOSI) THEN
  791.                   KARPOS(NMIN2)=JPOSI+1
  792.                   KARETE(NMIN2,JPOSI+1)=NMAX2
  793.                   KARET2(NMIN2,JPOSI+1)=2
  794.                 ELSEIF (JNBCOL.EQ.JPOSI) THEN
  795.                   NCOL=JNBCOL+1
  796.                   SEGADJ KARETE,KMILIE,KARET2
  797.                   KARETE(NMIN2,JPOSI+1)=NMAX2
  798.                   KARPOS(NMIN2)=JPOSI+1
  799.                   KARET2(NMIN2,JPOSI+1)=2
  800.                 ENDIF
  801. c              WRITE (*,*) 'création de l arrete:', NMIN2, NMAX2 
  802.               ELSE
  803.                 KARET2(NMIN2,NEXIS2)=2
  804.               ENDIF
  805. C
  806. C 2/ Test sur la deuxieme arete : NMAX-NPTC
  807.               NEXIS2=0
  808.               NMIN2=MIN(NMAX,ICPR(NPTC,1))
  809.               NMAX2=MAX(NMAX,ICPR(NPTC,1))
  810.               DO 25 I=1,MAX(1,KARPOS(NMIN2))
  811.                 IF (KARETE(NMIN2,I).EQ.NMAX2) NEXIS2=I
  812.   25          CONTINUE
  813.               IF (NEXIS2.EQ.0) THEN
  814.                 NBRELA=NBRELA+1
  815.                 JNBCOL=KARETE(/2)
  816.                 JPOSI=KARPOS(NMIN2)
  817.                 IF (JNBCOL.GT.JPOSI) THEN
  818.                   KARPOS(NMIN2)=JPOSI+1
  819.                   KARETE(NMIN2,JPOSI+1)=NMAX2
  820.                   KARET2(NMIN2,JPOSI+1)=2
  821.                 ELSEIF (JNBCOL.EQ.JPOSI) THEN
  822.                   NCOL=JNBCOL+1
  823.                   SEGADJ KARETE,KMILIE,KARET2
  824.                   KARETE(NMIN2,JPOSI+1)=NMAX2
  825.                   KARPOS(NMIN2)=JPOSI+1
  826.                   KARET2(NMIN2,JPOSI+1)=2
  827.                 ENDIF
  828. c              WRITE (*,*) 'création de l arrete:', NMIN2, NMAX2 
  829.               ELSE
  830.                 KARET2(NMIN2,NEXIS2)=2
  831.               ENDIF
  832.             ENDIF
  833.           ENDIF
  834.  220    CONTINUE
  835.  218  CONTINUE
  836.       IF (NBRELA.NE.0) GOTO 22
  837.   28  CONTINUE
  838.  
  839. C
  840. C
  841. C=======================================================================
  842. C                  Pre-remplissage du tableau JFARAF
  843. C=======================================================================
  844. C On remplit le tableau JFARAF et JPLAN3 lorsqu'il y a des maillages de 
  845. C relations de type 48 (IPT6, LCONF3 non nul).
  846. c
  847. C Si JPLANS(i,j)=k et JFARAF(k , (l-1)*2+1)= n  : le noeud n (en 
  848. C numérotation globale) est le hanging node au centre de la jieme face 
  849. C dont le plus petit sommet en numerotation locale est le sommet i.
  850. C
  851. C Si de plus la face en question est un TRI6 et JFARAF(k , l*2)=m :
  852. C le noeud m (en numérotation globale) est le 4ieme noeud de l'element 
  853. C 48 coul 4 
  854. C
  855. C Si de plus la face en question est un QUA8-1 et JFARAF(k , l*2)=m :
  856. C le noeud m (en numérotation globale) est le 5eme noeud de l'element 
  857. c 48 coul 4 
  858. C 
  859. C si JPLAN3(i,j)=k il y a k relation de compatibilité de faces associé a
  860. C la jieme face dont le plus petit sommet en numerotation locale est le 
  861. C sommet i. 
  862.  
  863.       IF (IDIM.NE.3) GOTO 711
  864.       JNBFA=JNOEFA(/1)
  865.       LLLL=10
  866.       SEGINI JFARAF
  867.       SEGINI JPLAN2,JPLAN3
  868.       IF (LCONF3.EQ.0) GOTO 711
  869.       MPOS25=0
  870.       JNBSOM=0
  871.  1287 CONTINUE
  872.       NBRELA=0
  873.       DO 670 MIE=1,MAX(1,IPT6.LISOUS(/1))
  874.         IF (IPT6.LISOUS(/1).EQ.0) THEN
  875.           IPT2=IPT6
  876.         ELSE
  877.           IPT2=IPT6.LISOUS(MIE)
  878.         ENDIF
  879.         SEGACT IPT2
  880.         IF (IPT2.ITYPEL.NE.48) GOTO 670
  881.         IF ((IPT2.ICOLOR(1).EQ.1).OR.(IPT2.ICOLOR(1).EQ.2)) GOTO 670
  882.         LIGNUM=IPT2.NUM(/1)
  883.         IF (IPT2.ICOLOR(1).EQ.4) MPOS25=4
  884.         IF (IPT2.ICOLOR(1).EQ.5) MPOS25=5
  885.         IF (IPT2.ICOLOR(1).EQ.3) JNBSOM=4
  886.         IF (IPT2.ICOLOR(1).EQ.4) JNBSOM=3
  887.         IF (IPT2.ICOLOR(1).EQ.5) JNBSOM=4
  888.         IF (IPT2.ICOLOR(1).EQ.6) JNBSOM=4
  889.         SEGINI IWORK2
  890. C
  891. C-------------------------
  892. C A) Recherche de la face !
  893. C-------------------------
  894. C 1/ Classement des 3 sommets par ordre croissant (num globale)
  895.         DO 671,MAA=1,IPT2.NUM(/2)
  896.           DO 673 MBB=1,JNBSOM
  897.             IWORK2(MBB)=IPT2.NUM(LIGNUM-JNBSOM+MBB,MAA)
  898.  673      CONTINUE
  899.           NPTA=nbpts+1
  900.           NPTB=NPTA+1
  901.           NPTC=NPTB+1
  902.           DO 672 ICC=1,JNBSOM
  903.             IF (IWORK2(ICC).LT.NPTA) THEN
  904.               NPTC=NPTB
  905.               NPTB=NPTA
  906.               NPTA=IWORK2(ICC)
  907.             ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  908.               NPTC=NPTB
  909.               NPTB=IWORK2(ICC)
  910.             ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  911.               NPTC=IWORK2(ICC)
  912.             ENDIF
  913.  672      CONTINUE
  914. C
  915. C 2/ Classement des 3 sommets par ordre croissant (num locale)
  916.           NPTA1=NPTA
  917.           NPTB1=NPTB
  918.           NPTC1=NPTC
  919.           NPTA2=ICPR(NPTA,1)
  920.           NPTB2=ICPR(NPTB,1)
  921.           NPTC2=ICPR(NPTC,1)
  922.           IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  923.             NPTA=NPTA2
  924.             NPTB=MIN(NPTB2,NPTC2)
  925.             NPTC=MAX(NPTB2,NPTC2)
  926.           ENDIF
  927.           IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  928.             NPTA=NPTB2
  929.             NPTB=MIN(NPTA2,NPTC2)
  930.             NPTC=MAX(NPTA2,NPTC2)
  931.           ENDIF
  932.           IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  933.             NPTA=NPTC2
  934.             NPTB=MIN(NPTA2,NPTB2)
  935.             NPTC=MAX(NPTA2,NPTB2)
  936.           ENDIF
  937. C
  938. C 3/ Recherche du numero de la face
  939.           NEXIS2=0
  940.           DO 674 IEE=1,JPLCOM(NPTA)
  941.             MTMP=JPLANS(NPTA,IEE)
  942.             JJ1=JNOEFA(MTMP,1)
  943.             JJ2=JNOEFA(MTMP,2)
  944.             JJ3=JNOEFA(MTMP,3)
  945.             IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN
  946.               NEXIS2=IEE
  947.             ENDIF
  948.  674      CONTINUE
  949. c 3.1/ si la face en question n'existe pas, dans le cas général on 
  950. c      s'arrète
  951.           IF ((NEXIS2.EQ.0).AND.(IPT2.ICOLOR(1).NE.3)) THEN
  952. c            WRITE (*,*) 'IPT2.ICOLOR(1)', IPT2.ICOLOR(1)
  953.             WRITE (*,*) 'Raffinement impossible, le champ de densite
  954.      + presente des variations trop brusques'
  955.             WRITE (*,*) 'sure concerne', MAA
  956.             WRITE (*,*) 'premier nd du sure concerne', IPT2.NUM(1,MAA)
  957.             WRITE (*,*) 'numero du 1er nd de la face concernee', NPTA
  958.             KARAF2=0
  959. c            GOTO 679
  960.           ENDIF
  961. c 3.2/ si la face en question n'existe pas dans le cas d'une relation  
  962. c de face QUA4 il suffie de la créer
  963.  
  964.           IF ((NEXIS2.EQ.0).AND.(IPT2.ICOLOR(1).EQ.3)) THEN      
  965.             JPLCOM(NPTA)= JPLCOM(NPTA)+1
  966.             JNUMFA=JNUMFA+1
  967.             JNUMFS=JNUMFA
  968.             JNUMF1=JPLCOM(NPTA)
  969.             JMAXPL=MAX(JMAXPL,JPLCOM(NPTA))
  970. c 3.2.1/ ajustement des segments             
  971.             JPLA2=JMAXPL
  972.             JNBFA=JNUMFA
  973.             SEGADJ JPLANS
  974.             SEGADJ JNOEFA
  975.             SEGADJ JPLAN3
  976.             SEGADJ JFARAF
  977. C 3.2.1 Renseignement des iformation de la nouvelle face dans JPLANS et
  978. c JNOEFA, initialisation de  JPLAN3
  979.             JPLANS(NPTA,JNUMF1)=JNUMFA
  980.             JPLAN3(NPTA,JNUMF1)=0
  981.             JNOEFA(JNUMFA,1)= NPTA
  982.             JNOEFA(JNUMFA,2)= NPTB
  983.             JNOEFA(JNUMFA,3)= NPTC
  984.             JNOEFA(JNUMFA,4)= 48
  985.             JNOEFA(JNUMFA,5)= 48
  986.           ENDIF
  987.  
  988.           IF (NEXIS2.NE.0) THEN
  989.             JNUMFS=JPLANS(NPTA,NEXIS2)
  990.           ENDIF
  991. C
  992. C 4/ Recherche de la position de la face dans JPLANS
  993.           NEXIS2=0
  994.           DO 675 MAC=1,JPLCOM(NPTA)
  995.             IF (JPLANS(NPTA,MAC).EQ.JNUMFS) NEXIS2=MAC
  996.  675      CONTINUE
  997. C
  998. C-------------------------------------
  999. C B) Renseignement de JFARAF et JPLAN3!
  1000. C-------------------------------------
  1001.  
  1002.  
  1003.           JPLAN3(NPTA,NEXIS2)=JPLAN3(NPTA,NEXIS2)+1
  1004.           LTEMPO=(JPLAN3(NPTA,NEXIS2)-1)*2+1
  1005.           JFARAF(JNUMFS,LTEMPO)=IPT2.NUM(1,MAA)
  1006.           IF (MPOS25.NE.0) JFARAF(JNUMFS,LTEMPO+1)=IPT2.NUM(MPOS25,MAA)
  1007.           IF (JNOEFA(JNUMFS,5).EQ.0) JNOEFA(JNUMFS,5)=48
  1008.  
  1009.  
  1010.  671    CONTINUE
  1011.  670  CONTINUE
  1012. C      IF (NBRELA.NE.0) GOTO 1287
  1013.  711  CONTINUE
  1014. C
  1015. C=======================================================================
  1016. C           Calcul du critere et raffinement si necessaire
  1017. C=======================================================================
  1018. C Pour calculer le critere, on a besoin d'un modele et d'un chamelem
  1019. C constant egal a 1.
  1020. C
  1021. C------------------------------------------
  1022. C A) Creation d'un modele simple : MMODE1 !
  1023. C------------------------------------------
  1024.       MN3=0
  1025.       NFOR=1
  1026.       NMAT=2
  1027.       NPARMO=0
  1028.       NOBMOD=0
  1029.       N1=1
  1030.       SEGINI MMODE1
  1031.       SEGINI IMODE1
  1032.       MMODE1.KMODEL(1)=IMODE1
  1033.       IMODE1.FORMOD(1)='MECANIQUE'
  1034.       IMODE1.MATMOD(1)='ELASTIQUE'
  1035.       IMODE1.MATMOD(2)='ISOTROPE'
  1036.  
  1037. C
  1038.       KARAF2=0
  1039. C=======================================================================
  1040. C           Boucle sur les eventuels sous-domaines de IPT5
  1041. C=======================================================================
  1042.  
  1043. c-----------------------------------------------------------------------
  1044. c      initialisation de LTYPE3 qui va contenir les tableau LTYP2
  1045. c      correspondant à chaque sous domaine de IPT5. Ces tableau LTYP2
  1046. c      contiendront eux même les maillages raffinés issue des 
  1047. c      différents sous domaine de IPT5.
  1048. c      LTYPE3(I,1)=LTYP2 pour le sous domaine I de IPT5
  1049. c      LTYPE3(I,2)=IRR le permier indice d'un maillage 48 dans LTYP2
  1050. c-----------------------------------------------------------------------  
  1051.       NBLIS3=MAX(1,IPT5.LISOUS(/1))
  1052.       SEGINI LTYPE3
  1053.       MCONF=0
  1054.       NSUR = 0
  1055.       DO 33 INB=1,MAX(1,IPT5.LISOUS(/1))
  1056.         NBNN=0
  1057.         NBELEM=0
  1058.         NBREF=0
  1059.         NBSOUS=0
  1060.         SEGINI IPT2
  1061.         IF (IPT5.LISOUS(/1).EQ.0) THEN
  1062.           IPT2=IPT5
  1063.         ELSE
  1064.           IPT2=IPT5.LISOUS(INB)
  1065.           SEGACT IPT2
  1066.         ENDIF
  1067.  
  1068.         IMODE1.IMAMOD=IPT2
  1069.         IMODE1.NEFMOD=IPT2.ITYPEL
  1070. C
  1071. C-------------------------------------------------------
  1072. C B) Creation d'un chamelem constant egal a 1 : MCHEL1 !
  1073. C-------------------------------------------------------
  1074.         CALL ZEROP(MMODE1,'NOEUD   ',MCHEL1)
  1075.         SEGACT MCHEL1*MOD
  1076.         MCHEL1.IMACHE(1)=IPT2
  1077.         IF (IDIM.EQ.2) MCHEL1.IFOCHE=-1
  1078.         IF (IDIM.EQ.3) MCHEL1.IFOCHE=2
  1079.         MCHAM1=MCHEL1.ICHAML(1)
  1080.         SEGACT MCHAM1
  1081.         MELVA1=MCHAM1.IELVAL(1)
  1082.         SEGACT MELVA1*MOD
  1083. c        DO 399 J=1,IPT2.NUM(/2)          
  1084. c          MELVA1.VELCHE(1,J)=1.0 
  1085. c  399   CONTINUE
  1086.         MELVA1.VELCHE(1,1)=1.D0
  1087. C
  1088. C-------------------------------------------------------------
  1089. C C) Calcul de la surface ou du volume des elements : MCHEL2 !
  1090. C-------------------------------------------------------------
  1091.         CALL INTGCA(MMODE1,MCHEL1,0,1,IRET,XRET,MCHEL2)
  1092.         IF (XRET.LT.XPETI) THEN
  1093.             WRITE (*,*) 'Volume(resp surf) de la zone a raffiner nul'
  1094.             RETURN              
  1095.         ENDIF
  1096.         SEGACT IPT2
  1097.  
  1098. C
  1099. C---------------------------------------------------------------------
  1100. C D) Creation d'un chamelem indiquant les elements a raffiner MCHAM2 !
  1101. C---------------------------------------------------------------------
  1102.         SEGACT KMILIE*MOD
  1103.         SEGACT MCHEL2
  1104.         MCHAM2=MCHEL2.ICHAML(1)
  1105.         SEGACT MCHAM2
  1106.         MELVA2=MCHAM2.IELVAL(1)
  1107.         SEGACT MELVA2*MOD
  1108.         NACREE=0
  1109.         KARAF=0
  1110.  
  1111.  
  1112.         SEGACT MELVA1
  1113. c       boucles sur les éléments de ipt2
  1114.         DO 32 J=1,IPT2.NUM(/2)
  1115.  
  1116.           XMOY=0
  1117.           DO 29 I=1,IPT2.NUM(/1)
  1118.             NGLOB=IPT2.NUM(I,J)
  1119.             NLOC=ICPR(NGLOB,1)
  1120.             DENPT=DENSI(NLOC)
  1121.             XMOY=XMOY+DENPT/(IPT2.NUM(/1))
  1122.   29      CONTINUE
  1123.  
  1124.           XINT=MELVA2.VELCHE(1,J)
  1125.           XDIM=IDIM*1.0
  1126. C Un element est a raffiner si la moyenne des densites affectees a 
  1127. C l'ensemble de ses noeuds est inférieure a la racine carree de sa 
  1128. C surface (en 2D) ou a la racine cubique de son volume (en 3D)
  1129. C          WRITE (*,*) 'XMOY', XMOY, '(XINT**(1/XDIM))',(XINT**(1/XDIM))
  1130.           IF ((XMOY-(XINT**(1/XDIM))).LT.0) THEN
  1131. c c         y a t'il des +epsilon...?
  1132. c           XDIFF = XMOY-(XINT**(1/XDIM))
  1133. c           if(XDIFF.ge.0.and.XDIFF.lt.0.001*XMOY) then
  1134. c             write(*,*) 'RAFF : XMOY,XDIFF=',XMOY,XDIFF,
  1135. c      &     'pour l EF',J,(IPT2.NUM(iou,J),iou=1,IPT2.NUM(/1))
  1136. c           endif
  1137. c           IF (XDIFF.LT.0) THEN
  1138.             MELVA2.VELCHE(1,J)=1
  1139. c KARAF nombre d'éléments à rafiner dans le sous domaine
  1140.             KARAF=KARAF+1
  1141.             ILPT=LPT(IPT2.ITYPEL)
  1142.             ILPL=LPL(IPT2.ITYPEL)
  1143.  
  1144. c boucle sur les segments de l'élément à raffiner
  1145.             DO 31 K=1,ILPL*2-1,2
  1146.               NPTA=IPT2.NUM(KSEGM(ILPT+K-1),J)
  1147.               NPTB=IPT2.NUM(KSEGM(ILPT+K),J)
  1148.               NMIN=MIN(ICPR(NPTA,1),ICPR(NPTB,1))
  1149.               NMAX=MAX(ICPR(NPTA,1),ICPR(NPTB,1))
  1150.               NEXIST=0
  1151.               DO 30 I=1,MAX(1,KARPOS(NMIN))
  1152.                 IF (KARETE(NMIN,I).EQ.NMAX) NEXIST=I
  1153.   30          CONTINUE
  1154. c On met dans kmilie les arêtes où il faudra mettre un nouveau noeud
  1155. c On leur associe la valeur -1
  1156.               IF (KMILIE(NMIN,NEXIST).EQ.0) THEN
  1157.                 NACREE=NACREE+1
  1158.                 KMILIE(NMIN,NEXIST)=-1
  1159.               ENDIF
  1160.   31        CONTINUE
  1161. C
  1162. C-------------------------------------------
  1163. C E) Comptage du nombre de faces a raffiner !
  1164. C-------------------------------------------
  1165. C 1/ Initialisations
  1166.             IF (IDIM.NE.3) GOTO 32
  1167.             JTYPEL=IPT2.ITYPEL
  1168.             JLTEL1=LTEL(1,JTYPEL)
  1169.             JLTEL2=LTEL(2,JTYPEL)
  1170.             DO 73 IBB=1,JLTEL1
  1171.               JLDEL1=LDEL(1,JLTEL2-1+IBB)
  1172.               JTYFAC=IWORK1(JLDEL1)
  1173.               JLDEL2=LDEL(2,JLTEL2-1+IBB)
  1174. C             JNBPTS=NBNNE(JTYFAC)
  1175.               JNBSOM=NBSOM(JTYFAC)
  1176.               JSPOS=NSPOS(JTYFAC)
  1177.               SEGINI IWORK2
  1178.               DO 74 IAA=1,JNBSOM
  1179.                 NGLOBA=IPT2.NUM(LFAC(JLDEL2-1+IBSOM(JSPOS-1+IAA)),J)
  1180.                 IWORK2(IAA)=NGLOBA
  1181.   74          CONTINUE
  1182. C
  1183. C 2/ Classement des 3 sommets par ordre croissant (num globale)
  1184.               NPTA=nbpts+1
  1185.               NPTB=NPTA+1
  1186.               NPTC=NPTB+1
  1187.               DO 75 ICC=1,JNBSOM
  1188.                 IF (IWORK2(ICC).LT.NPTA) THEN
  1189.                   NPTC=NPTB
  1190.                   NPTB=NPTA
  1191.                   NPTA=IWORK2(ICC)
  1192.                 ELSEIF (IWORK2(ICC).LT.NPTB) THEN
  1193.                   NPTC=NPTB
  1194.                   NPTB=IWORK2(ICC)
  1195.                 ELSEIF (IWORK2(ICC).LT.NPTC) THEN
  1196.                   NPTC=IWORK2(ICC)
  1197.                 ENDIF
  1198.   75          CONTINUE
  1199. C
  1200. C 3/ Classement des 3 sommets par ordre croissant (num locale)
  1201.               NPTA2=ICPR(NPTA,1)
  1202.               NPTB2=ICPR(NPTB,1)
  1203.               NPTC2=ICPR(NPTC,1)
  1204.               IF ((NPTA2.LT.NPTB2).AND.(NPTA2.LT.NPTC2)) THEN
  1205.                 NPTA=NPTA2
  1206.                 NPTB=MIN(NPTB2,NPTC2)
  1207.                 NPTC=MAX(NPTB2,NPTC2)
  1208.               ENDIF
  1209.               IF ((NPTB2.LT.NPTA2).AND.(NPTB2.LT.NPTC2)) THEN
  1210.                 NPTA=NPTB2
  1211.                 NPTB=MIN(NPTA2,NPTC2)
  1212.                 NPTC=MAX(NPTA2,NPTC2)
  1213.               ENDIF
  1214.               IF ((NPTC2.LT.NPTA2).AND.(NPTC2.LT.NPTB2)) THEN
  1215.                 NPTA=NPTC2
  1216.                 NPTB=MIN(NPTA2,NPTB2)
  1217.                 NPTC=MAX(NPTA2,NPTB2)
  1218.               ENDIF
  1219. C
  1220. C 4/ Calcul du nombre de points a creer pour raffiner la face
  1221.               NEXIS2=0
  1222.               DO 76 IEE=1,JPLCOM(NPTA)
  1223.                 MTMP=JPLANS(NPTA,IEE)
  1224.                 JJ1=JNOEFA(MTMP,1)
  1225.                 JJ2=JNOEFA(MTMP,2)
  1226.                 JJ3=JNOEFA(MTMP,3)
  1227.                 IF(JJ1.EQ.NPTA.AND.JJ2.EQ.NPTB.AND.JJ3.EQ.NPTC) THEN
  1228.                   NEXIS2=IEE
  1229.                 ENDIF
  1230.   76          CONTINUE
  1231.               IF (NEXIS2.NE.0) THEN
  1232.                 KFARAF=JPLAN2(NPTA,NEXIS2)
  1233.                 IF (KFARAF.EQ.0) THEN
  1234.                   NACREE=NACREE+NBINTE(JTYFAC)
  1235.                   JPLAN2(NPTA,NEXIS2)=JPLAN2(NPTA,NEXIS2)+1
  1236.                 ENDIF
  1237.               ENDIF
  1238.   73        CONTINUE
  1239.           ELSE
  1240.  
  1241.             MELVA2.VELCHE(1,J)=0
  1242.           ENDIF
  1243.   32    CONTINUE
  1244.  
  1245. c KARAF2 nombre d'éléments à rafiner sur tout les sous domaines
  1246.         KARAF2=KARAF2+KARAF
  1247. c si aucun élément à raffiner on stoque directement IPT2 dans LTYPE3
  1248. c on stoque également les anciennes relations et on passe au 
  1249. c sous-domaine suivant.
  1250.  
  1251. c ATTENTION SI NBOUCL=1 il est possible que des relations surabondantes        
  1252.  
  1253. c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1254. c   forcage  : nb max itération de raff
  1255. c       IF (NBOUCL.EQ.3) THEN
  1256. c           KARAF2=0
  1257. c           KARAF=0
  1258. c       ENDIF
  1259. c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1260.         IF (KARAF.EQ.0) THEN
  1261.             IF (NBOUCL.EQ.1) THEN
  1262.                 IF (LCONF3.GT.0) THEN
  1263.                     SEGACT IPT6
  1264.                     NBLIS2=1+MAX(1,IPT6.LISOUS(/1))
  1265.                     SEGINI LTYPE2
  1266.                     LTYPE2(1,1)=1
  1267.                     LTYPE2(1,2)=IPT2.ITYPEL
  1268.                     LTYPE2(1,3)=IPT2
  1269.                     LTYPE2(1,4)=IPT2.ICOLOR(1)
  1270.                     LTYPE3(INB,2)=0
  1271.                     DO 676 MIE=1,MAX(1,IPT6.LISOUS(/1))
  1272.                         IF (IPT6.LISOUS(/1).EQ.0) THEN
  1273.                             IPT4=IPT6
  1274.                         ELSE
  1275.                             IPT4=IPT6.LISOUS(MIE)
  1276.                         ENDIF
  1277.                         NSUR=1 
  1278.                        SEGACT IPT4
  1279.                        LTYPE2(1+MIE,1)=1+MIE
  1280.                        LTYPE2(1+MIE,2)=IPT4.ITYPEL
  1281.                        LTYPE2(1+MIE,3)=IPT4
  1282.                        LTYPE2(1+MIE,4)=IPT4.ICOLOR(1)
  1283.                        LTYPE3(INB,2)=2
  1284.   676               CONTINUE
  1285.                 ELSE
  1286.                     NBLIS2=1
  1287.                     SEGINI LTYPE2
  1288.                     LTYPE2(1,1)=1
  1289.                     LTYPE2(1,2)=IPT2.ITYPEL
  1290.                     LTYPE2(1,3)=IPT2
  1291.                     LTYPE2(1,4)=IPT2.ICOLOR(1)
  1292.                     LTYPE3(INB,2)=0
  1293.                 ENDIF
  1294.                 LTYPE3(INB,1)=LTYPE2
  1295.             ELSE
  1296.                 SEGACT LTYPE4 
  1297.                 LTYPE3(INB,1)=LTYPE4(INB,1)
  1298.                 LTYPE3(INB,2)=LTYPE4(INB,2)               
  1299.             ENDIF
  1300.             GOTO 33 
  1301.         ENDIF
  1302. C
  1303. C----------------------------
  1304. C F) Raffinement du maillage !
  1305. C----------------------------
  1306.         NML=2
  1307. C
  1308. C 1/ Raffinement d'un maillage 2D
  1309. C On recupere dans MELEME le maillage raffine sans ses relations de 
  1310. C conformite et dans IPT8 les relations de ce maillage 
  1311. C (IPT8 encore incomplet en sortie de RAFF2D)
  1312. c entrees de raff2D:
  1313. c           - IPT2:   maillage élémentaire à raffiner 
  1314. c                     (ici sous domaine de ipt5) 
  1315. c           - ICPR:   tableau de passage noeuds local/global
  1316. c                     (ici à partir de ipt5 interne à la boucle 9)
  1317. c           - KARPOS: tableau du nb d'arretes par noeuds
  1318. c                     (ici à partir de ipt5, mis a jour avec ipt6)
  1319. c           - KARETE: tableau des d'arretes KARETE(i,j)=k 
  1320. c                     (ici à partir de ipt5, mis a jour avec ipt6)
  1321. c           - KMILIE: tableau des hanging nodes associés au arrètes 
  1322. c                     en entrée: à partir des relations de ipt6 et
  1323. c                     des nouveau noeuds à construires
  1324. c                     si relation issue de ipt6
  1325. c                        KMILIE(i,j)=n : le noeud global n est situe
  1326. c                        au milieu de l'arete [i,k]
  1327. c                     si nouvelle relation
  1328. c                        KMILIE(i,j)=-1 : il faut construire un noeud
  1329. c                        au milieu de l'arete [i,k]
  1330. c           - MELVA2: champ par elem valait 1 pour les élem à raffiner
  1331. c                     et 0 pour les autres 
  1332. c                     (ici à partir de ipt2 et de densi)
  1333. c           - NACREE: nombre de noeuds à créer dans ipt2
  1334. c           - KARAF:  nombre d'élément à raffiner dans ipt2
  1335. c           - IDCP :  ??? variable non utilisé ???
  1336. c           - XDEN :  densité aux noeuds en notation globale
  1337. c                     (ici à partir de mchpo1)
  1338. c           - KARET2: tableau du nombre d'éléments touchant les arretes 
  1339. c                     (ici à partir de ipt5, mis a jour avec ipt6)
  1340. csorties de raff2D : 
  1341. c           - KMILIE: tableau des hanging nodes associés au arrètes 
  1342. c                     en sortie: à partir des relations donnée en 
  1343. c                     entrée et de celles crées
  1344. c                     si anciene relation à garder
  1345. c                       KMILIE(i,j)=n : le noeud global n est situe
  1346. c                       au milieu de l'arete [i,k]
  1347. c                     si anciene relation à suprimer
  1348. c                       KMILIE(i,j)=0 : 
  1349. c                     si nouvelle relation
  1350. c                       KMILIE(i,j)=n : le noeud n à été construit au
  1351. c                       milieu de l'arete [i,k]
  1352. c           - MELEME: Maillage élémentaire raffiné à partir de ipt2
  1353. c                     sans relations
  1354. c           - IPT8 :  Maillage de relation incomplet 
  1355. c                     si J nouvel élément 48:
  1356. c                       IPT8.NUM(1,j) = nouveau hanging node
  1357. c                       IPT8.NUM(2:4,j) = autres noeuds de la relation
  1358. c                       IPT8.NUM(5,j) = 1 si arête a 2 noeuds
  1359. c                                       2 si arête a 3 noeuds
  1360. c                     si J nouvel élément 48:
  1361. c                       IPT8.NUM(1,j) = nouveau hanging node
  1362. c                       IPT8.NUM(2:5,j) = 0
  1363. c           - XDEN :  densité aux noeuds en notation globale
  1364. c                     interpolé aux nouveaux noeuds.
  1365.         IF (IDIM.EQ.2) CALL RAFF2D(IPT2,ICPR,KARPOS,KARETE,KMILIE,
  1366.      +   MELVA2,NACREE,KARAF,MELEME,IDCP,IPT8,KARET2,XDEN)
  1367. C
  1368. C 2/ Raffinement d'un maillage 3D
  1369.         IF (IDIM.EQ.3) THEN
  1370.           NML=0
  1371.           IF ((IPT2.ITYPEL.EQ.25).OR.(IPT2.ITYPEL.EQ.26)) NML=1
  1372.         ENDIF
  1373. C   a) Maillage 3D contenant des pyramides
  1374.         IPT9=0
  1375.         IF (NML.EQ.1) CALL RAFPYR(IPT2,ICPR,KARPOS,KARETE,KMILIE,
  1376.      +    MELVA2,NACREE,KARAF,MELEME,JPLANS,JPLAN3,JPLCOM,JNOEFA,
  1377.      +    IPT8,JFARAF,KARET2,IPT9,XDEN)
  1378. C   b) Maillage 3D sans pyramides
  1379.         IF (NML.EQ.0) CALL RAFF3D(IPT2,IPT6,ICPR,KARPOS,KARETE,KMILIE,
  1380.      +    MELVA2,NACREE,KARAF,MELEME,JPLANS,JPLAN3,JPLCOM,JNOEFA,
  1381.      +    IPT8,JFARAF,KARET2,XDEN)
  1382. C
  1383. C=======================================================================
  1384. C          Creation du maillage de relations de conformite
  1385. C=======================================================================
  1386. C--------------------
  1387. C A) Initialisations !
  1388. C--------------------
  1389.       IPT10=0
  1390.       IPT11=0
  1391.       IPT12=0
  1392.       IPT13=0
  1393.       IPT14=0
  1394.       IPT15=0
  1395.       IPT16=0
  1396.       MCONF=0
  1397. c      IF (KARAF2.EQ.0) GOTO 33
  1398.       IF (IPT8.NE.0) THEN
  1399. C
  1400. C---------------------------------------
  1401. C B) Traitement des anciennes relations !
  1402. C---------------------------------------
  1403. C A ce stade, IPT8 contient les relations crees lors du dernier 
  1404. C raffinement (noeud de relation + noeuds formant la relation) et les 
  1405. C anciennes relations a reporter (noeud de relation seulement)
  1406.  
  1407. C 1/ Recherche de l'existence d'anciennes relations a reporter
  1408.         NB10=0
  1409.         MLONG=IPT8.NUM(/1)
  1410.         DO 775 MM=1,IPT8.NUM(/2)
  1411.           IF (IPT8.NUM(MLONG,MM).EQ.0) NB10=NB10+1
  1412.  775    CONTINUE
  1413.  
  1414.         IF (NB10.NE.0) THEN
  1415. C
  1416. C 2/ Creation de IPT10 
  1417. c          MCOL=0
  1418. c          NBNN=9
  1419. c          NBELEM=NB10
  1420. c          NBREF=0
  1421. c          NBSOUS=0
  1422. c          SEGINI IPT10
  1423. c          IPT10.ITYPEL=48
  1424. C
  1425. C 3/ Recherche des anciennes relations a reporter
  1426. C Cette partie permet de compléter IPT8 avec les noeuds formant les 
  1427. C relations, pour les anciennes relations à reporter
  1428.           DO 628 MM11=1,IPT8.NUM(/2)
  1429.             IF (IPT8.NUM(MLONG,MM11).NE.0) GOTO 628
  1430.             INRELA=IPT8.NUM(1,MM11)
  1431. c On active pous le cas ou IPT6=IPT2.
  1432.             SEGACT IPT6
  1433.             DO 625 KOU=1,MAX(1,IPT6.LISOUS(/1))
  1434.               IF (IPT6.LISOUS(/1).EQ.0) THEN
  1435.                 IPT2=IPT6
  1436.               ELSE
  1437.                 IPT2=IPT6.LISOUS(KOU)
  1438.               ENDIF
  1439.               SEGACT IPT2
  1440.               IF (IPT2.ITYPEL.NE.48) GOTO 625
  1441.               DO 626 JKG=1,IPT2.NUM(/2)
  1442.                 INOEGL=IPT2.NUM(1,JKG)
  1443.                 IF (INOEGL.NE.INRELA) GOTO 626
  1444.                 MCOL=MCOL+1
  1445.                 DO 627 MTMP=1,IPT2.NUM(/1)
  1446.                   IPT8.NUM(MTMP,MM11)=IPT2.NUM(MTMP,JKG)
  1447.                   IPT8.NUM(MLONG,MM11)= IPT2.ICOLOR(JKG)
  1448.  627            CONTINUE
  1449.                 GOTO 628
  1450.  626          CONTINUE
  1451.  625        CONTINUE
  1452.  628      CONTINUE
  1453.         ENDIF
  1454. c à ce stade le maillage de relation ipt8 est complet
  1455. C
  1456. C---------------------------------------
  1457. C C) Traitement des nouvelles relations !
  1458. C---------------------------------------
  1459. C Ici, IPT8 contient toutes les relations du nouveau maillage
  1460. C On les trie par type de relations
  1461.  
  1462. C 1/ Recherche de l'existence de nouvelles relations
  1463.       NB11=0
  1464.       NB12=0
  1465.       NB13=0
  1466.       NB14=0
  1467.       NB15=0
  1468.       NB16=0
  1469.       MLONG=IPT8.NUM(/1)
  1470.       DO 776 MM=1,IPT8.NUM(/2)
  1471.         IF (IPT8.NUM(MLONG,MM).EQ.1) NB11=NB11+1
  1472.         IF (IPT8.NUM(MLONG,MM).EQ.2) NB12=NB12+1
  1473.         IF (IPT8.NUM(MLONG,MM).EQ.3) NB13=NB13+1
  1474.         IF (IPT8.NUM(MLONG,MM).EQ.4) NB14=NB14+1
  1475.         IF (IPT8.NUM(MLONG,MM).EQ.5) NB15=NB15+1
  1476.         IF (IPT8.NUM(MLONG,MM).EQ.6) NB16=NB16+1
  1477.  776  CONTINUE
  1478. C
  1479. C 2/ Cas des relations 'aretes a 2 noeuds'
  1480.         IF (NB11.NE.0) THEN
  1481.           MCONF=MCONF+1
  1482.           MCOL=0
  1483.           NBNN=3
  1484.           NBELEM=NB11
  1485.           NBREF=0
  1486.           NBSOUS=0
  1487.           SEGINI IPT11
  1488.           IPT11.ITYPEL=48
  1489.           DO 778 MM11=1,IPT8.NUM(/2)
  1490.             IF (IPT8.NUM(MLONG,MM11).NE.1) GOTO 778
  1491.             MCOL=MCOL+1
  1492.             DO 777 MTMP=1,3
  1493.               IPT11.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1494.               IPT11.ICOLOR(MCOL)=1
  1495.  777        CONTINUE
  1496.  778      CONTINUE
  1497.         ENDIF
  1498. C
  1499. C 3/ Cas des relations 'aretes a 3 noeuds'
  1500.         IF (NB12.NE.0) THEN
  1501.           MCONF=MCONF+1
  1502.           MCOL=0
  1503.           NBNN=4
  1504.           NBELEM=NB12
  1505.           NBREF=0
  1506.           NBSOUS=0
  1507.           SEGINI IPT12
  1508.           IPT12.ITYPEL=48
  1509.           DO 668 MM11=1,IPT8.NUM(/2)
  1510.             IF (IPT8.NUM(MLONG,MM11).NE.2) GOTO 668
  1511.             MCOL=MCOL+1
  1512.             DO 667 MTMP=1,4
  1513.               IPT12.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1514.               IPT12.ICOLOR(MCOL)=2
  1515.  667        CONTINUE
  1516.  668      CONTINUE
  1517.         ENDIF
  1518. C
  1519. C 4/ Cas des relations 'face QUA4'
  1520.         IF (NB13.NE.0) THEN
  1521.           MCONF=MCONF+1
  1522.           MCOL=0
  1523.           NBNN=5
  1524.           NBELEM=NB13
  1525.           NBREF=0
  1526.           NBSOUS=0
  1527.           SEGINI IPT13
  1528.           IPT13.ITYPEL=48
  1529.           DO 658 MM11=1,IPT8.NUM(/2)
  1530.             IF (IPT8.NUM(MLONG,MM11).NE.3) GOTO 658
  1531.             MCOL=MCOL+1
  1532.             DO 657 MTMP=1,5
  1533.               IPT13.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1534.               IPT13.ICOLOR(MCOL)=3
  1535.  657        CONTINUE
  1536.  658      CONTINUE
  1537.         ENDIF
  1538. C
  1539. C 5/ Cas des relations 'face TRI6'
  1540.         IF (NB14.NE.0) THEN
  1541.           MCONF=MCONF+1
  1542.           MCOL=0
  1543.           NBNN=7
  1544.           NBELEM=NB14
  1545.           NBREF=0
  1546.           NBSOUS=0
  1547.           SEGINI IPT14
  1548.           IPT14.ITYPEL=48
  1549.           DO 648 MM11=1,IPT8.NUM(/2)
  1550.             IF (IPT8.NUM(MLONG,MM11).NE.4) GOTO 648
  1551.             MCOL=MCOL+1
  1552.             DO 647 MTMP=1,7
  1553.               IPT14.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1554.               IPT14.ICOLOR(MCOL)=4
  1555.  647        CONTINUE
  1556.  648      CONTINUE
  1557.         ENDIF
  1558. C
  1559. C 6/ Cas des relations 'face QUA8-1'
  1560.         IF (NB15.NE.0) THEN
  1561.           MCONF=MCONF+1
  1562.           MCOL=0
  1563.           NBNN=9
  1564.           NBELEM=NB15
  1565.           NBREF=0
  1566.           NBSOUS=0
  1567.           SEGINI IPT15
  1568.           IPT15.ITYPEL=48
  1569.           DO 638 MM11=1,IPT8.NUM(/2)
  1570.             IF (IPT8.NUM(MLONG,MM11).NE.5) GOTO 638
  1571.             MCOL=MCOL+1
  1572.             DO 637 MTMP=1,9
  1573.               IPT15.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1574.               IPT15.ICOLOR(MCOL)=5
  1575.  637        CONTINUE
  1576.  638      CONTINUE
  1577.         ENDIF
  1578. C
  1579. C 7/ Cas des relations 'face QUA8-2'
  1580.         IF (NB16.NE.0) THEN
  1581.           MCONF=MCONF+1
  1582.           MCOL=0
  1583.           NBNN=9
  1584.           NBELEM=NB16
  1585.           NBREF=0
  1586.           NBSOUS=0
  1587.           SEGINI IPT16
  1588.           IPT16.ITYPEL=48
  1589.           DO 678 MM11=1,IPT8.NUM(/2)
  1590.             IF (IPT8.NUM(MLONG,MM11).NE.6) GOTO 678
  1591.             MCOL=MCOL+1
  1592.             DO 677 MTMP=1,9
  1593.               IPT16.NUM(MTMP,MCOL)=IPT8.NUM(MTMP,MM11)
  1594.               IPT16.ICOLOR(MCOL)=6
  1595.  677        CONTINUE
  1596.  678      CONTINUE
  1597.         ENDIF
  1598. C
  1599.       ENDIF
  1600. C
  1601. C--------------------------------------
  1602. C D) Creation du maillage de relations !
  1603. C--------------------------------------
  1604. C 1/ Initialisation de MAIREL
  1605. C MAIREL contient tous les maillages de relations, certains étant vides 
  1606. C car il n'y a aucune relation du type considéré dans le nveau maillage
  1607.       NBMAIL=6
  1608.       SEGINI MAIREL
  1609.       MAIREL(1)=IPT11
  1610.       MAIREL(2)=IPT12
  1611.       MAIREL(3)=IPT13
  1612.       MAIREL(4)=IPT14
  1613.       MAIREL(5)=IPT15
  1614.       MAIREL(6)=IPT16
  1615. C
  1616. C 2/ Initialisation de LTYPE2
  1617. C LTYPE2 va contenir tous les sous-objets du nouveau maillage, 
  1618. C relations et non relations
  1619.       NBLIS2=MCONF+MAX(1,MELEME.LISOUS(/1))
  1620.       SEGINI LTYPE2
  1621. C
  1622. C 3/ Renseignement des lisous non 48 dans LTYPE2
  1623. C S'il y a N sous-objets de non-relations dans le nouveau maillage, 
  1624. C les N-ièmes premières colonnes de LTYPE2 contiennent ces sous-objets
  1625.       DO 685 IZZ=1,MAX(1,MELEME.LISOUS(/1))
  1626.         IF (MELEME.LISOUS(/1).EQ.0) THEN
  1627.           IPT2=MELEME
  1628.         ELSE
  1629.           IPT2=MELEME.LISOUS(IZZ)
  1630.           SEGACT IPT2
  1631.         ENDIF
  1632.         LTYPE2(IZZ,1)=IZZ
  1633.         LTYPE2(IZZ,2)=IPT2.ITYPEL
  1634.         LTYPE2(IZZ,3)=IPT2
  1635.         LTYPE2(IZZ,4)=0
  1636.  685  CONTINUE
  1637. C
  1638. C 4/ Renseignement des lisous 48 dans LTYPE2
  1639. C Les colonnes suivantes contiennent les sous-objets de relations, 
  1640. C chaque sous-objet correspondant a un type de relations de conformité
  1641.       IZZ=NBLIS2-MCONF
  1642.       DO 686 IXX=1,6
  1643.         IF (MAIREL(IXX).EQ.0) GOTO 686
  1644.         IPT2=MAIREL(IXX)
  1645.         IZZ=IZZ+1
  1646.         LTYPE2(IZZ,1)=IZZ
  1647.         LTYPE2(IZZ,2)=IPT2.ITYPEL
  1648.         LTYPE2(IZZ,3)=IPT2
  1649.         LTYPE2(IZZ,4)=IPT2.ICOLOR(1)
  1650.  686  CONTINUE
  1651. C--------------------------------------
  1652. C E)  Renseignement de LTYPE2 interne a 
  1653. c    la boucle 33 dans LTYPE3 externe a
  1654. c     la boucle 33
  1655. C--------------------------------------C
  1656. C
  1657.  
  1658.       LTYPE3(INB,1)=LTYPE2
  1659.       IF (MCONF.EQ.0) THEN
  1660.          LTYPE3(INB,2)=0
  1661.       ELSE
  1662.          LTYPE3(INB,2)=NBLIS2-MCONF+1
  1663.       ENDIF
  1664. c fin de boucle sur les sous domaines d'ipt5
  1665.   33  CONTINUE
  1666. c      SEGSUP IPT2
  1667.  
  1668.  
  1669. C          Mise a jour des maillages en entrée sortie de la boucle 9
  1670. C          IPT5, IPT6, IPT7
  1671. C=======================================================================
  1672.  679  CONTINUE
  1673. C--------------------------------------C
  1674. C A)  initialisation
  1675. C--------------------------------------C
  1676.  
  1677. c 1/ initialisaton de IPT7 maillage stockant tout les sous maillage 
  1678. c à la fin d'une itération de la boucle 9
  1679.       NBS7=0
  1680.       DO 331 I3=1,LTYPE3(/1)
  1681.         LTYPE2=LTYPE3(I3, 1)
  1682.         SEGACT LTYPE2
  1683.         NBS7=NBS7+LTYPE2(/1)+1
  1684.  331  CONTINUE
  1685.       IF (NBS7.EQ.1) NBS7=0
  1686.       NBNN=0
  1687.       NBELEM=0
  1688.       NBREF=0
  1689.       NBSOUS=NBS7
  1690.       SEGINI IPT7
  1691.  
  1692. c 2/ initialisaton de IPT6 maillage stockant tout les sous maillage 
  1693. c de relation à la fin d'une itération de la boucle 9
  1694.       NBS6=0
  1695.  
  1696.       DO 332 I3=1,LTYPE3(/1)
  1697.         LTYPE2=LTYPE3(I3, 1)
  1698.         SEGACT LTYPE2
  1699.         IF (LTYPE3(I3,2).NE.0) NBS6=NBS6+(LTYPE2(/1)-LTYPE3(I3,2)+1)
  1700.  332  CONTINUE
  1701.       IF (NBS6.EQ.1) NBS6=0
  1702.       NBNN=0
  1703.       NBELEM=0
  1704.       NBREF=0
  1705.       NBSOUS=NBS6
  1706.       SEGINI IPT6
  1707. c 3/ initialisaton de IPT5 maillage stockant tout les sous maillage 
  1708. c non relation à la fin d'une itération de la boucle 9
  1709.       NBS5=0
  1710.       DO 333 I3=1,LTYPE3(/1)
  1711.         LTYPE2=LTYPE3(I3, 1)
  1712.         SEGACT LTYPE2
  1713.         IF (LTYPE3(I3,2).EQ.0) THEN
  1714.           NBS5=NBS5+LTYPE2(/1)
  1715.         ELSE
  1716.           NBS5=NBS5+(LTYPE3(I3,2)-1)
  1717.         ENDIF
  1718.  333  CONTINUE
  1719.       IF (NBS5.EQ.1) NBS5=0
  1720.       NBNN=0
  1721.       NBELEM=0
  1722.       NBREF=0
  1723.       NBSOUS=NBS5
  1724.       SEGINI IPT5
  1725. C--------------------------------------C
  1726. C B)  assemblage des nouveaux maillage à 
  1727. c     partir des sous maillages stockés
  1728. c     dans LTYP3
  1729. C--------------------------------------C
  1730.       IND5=0
  1731.       IND6=0
  1732.       IND7=0
  1733. c 1/assemblage des nouveaux maillage non relation à partir des sous 
  1734. c  maillages stockés dans LTYP3
  1735.  
  1736.       DO 35 I3=1,LTYPE3(/1)
  1737. c extraction d'un LTYPE2 de LTYPE3      
  1738.         LTYPE2=LTYPE3(I3, 1)
  1739.         SEGACT LTYPE2
  1740. c        NBNN=0
  1741. c        NBELEM=0
  1742. c        NBREF=0
  1743. c        NBSOUS=0
  1744.         DO 613 I2=1,MAX(1,(LTYPE3(I3,2)-1))
  1745. c extraction d'un MAILLAGE non relation de LTYPE2
  1746.           IPT2=LTYPE2(I2,3)
  1747.           SEGACT IPT2
  1748.           IND5=IND5+1
  1749.           IF (NBS5.EQ.0) THEN
  1750.             IPT5=IPT2
  1751. c            write (*,*) 'IPT5.' , IPT5
  1752. c            write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1753.           ELSE  
  1754.             IPT5.LISOUS(IND5)=IPT2
  1755. c            write (*,*) 'IPT5.LISOUS(',IND5,')' , IPT5.LISOUS(IND5)
  1756. c            write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1757.           ENDIF
  1758.           IND7=IND7+1
  1759.           IF (NBS7.EQ.0) THEN
  1760.             IPT7=IPT2
  1761.           ELSE
  1762.             IPT7.LISOUS(IND7)=IPT2
  1763. c            write (*,*) 'IPT7.LISOUS(',IND7,')' , IPT7.LISOUS(IND7)
  1764. c            write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1765.           ENDIF
  1766.  613    CONTINUE
  1767.  35   CONTINUE
  1768.  
  1769. c 2/assemblage des nouveaux maillage de relation à partir des derniers  
  1770. c  sous maillages stockés dans LTYPE3
  1771.  
  1772.       DO 36 I3=1,LTYPE3(/1)
  1773. c extraction d'un LTYPE2 de LTYPE3
  1774. c        write (*,*) 'I3', I3
  1775. c        write (*,*) 'LTYPE3(I3,2)', LTYPE3(I3,2)
  1776.           IF (LTYPE3(I3,2).EQ.0) GOTO 36
  1777.           SEGACT LTYPE2      
  1778.           LTYPE2=LTYPE3(I3, 1)
  1779.           NBNN=0
  1780.           NBELEM=0
  1781.           NBREF=0
  1782.           NBSOUS=0
  1783.           DO 614 I2=LTYPE3(I3,2), LTYPE2(/1)
  1784. c extraction d'un MAILLAGE de relation de LTYPE2
  1785. c            write (*,*) 'I2', I2
  1786.             SEGINI IPT2
  1787.             IPT2=LTYPE2(I2,3)
  1788.             SEGACT IPT2
  1789. c            write (*,*) 'IPT2: Type', IPT2.ITYPEL,'nbelem', IPT2.NUM(/2)
  1790. c            write (*,*) 'coul IPT2' , IPT2.ICOLOR(1)
  1791.             IND6=IND6+1
  1792.             IF (NBS6.EQ.0) THEN
  1793.               IPT6=IPT2
  1794. c              write (*,*) 'IPT6' , IPT6
  1795. c              write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1796.            ELSE  
  1797.               IPT6.LISOUS(IND6)=IPT2
  1798.  
  1799. c          write (*,*) 'IPT6.LISOUS(',IND6,')' , IPT6.LISOUS(IND6)
  1800. c          write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1801.         ENDIF
  1802.  614    CONTINUE
  1803.  36   CONTINUE
  1804.  
  1805. c 3/ Concatenation des sous maillages de relation de même couleur
  1806.  
  1807. c  GG 11 juin 2018 : attention il peut encore y avoir des probleme a la
  1808. c jonctions entre deux sous zones dans le cas ou on raffine plusieurs 
  1809. c types d'elments  différents (passer cette etape de concaténation dans 
  1810. c la boucle 33 ?
  1811.  
  1812.       IF (NBS6.EQ.0) then
  1813.          IND7=IND7+1
  1814.          IPT7.LISOUS(IND7) = IPT6
  1815. c          write (*,*) 'IPT7.LISOUS(',IND7,')' , IPT7.LISOUS(IND7)
  1816. c          write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1817.  
  1818.          goto 370
  1819.       ENDIF
  1820.       NBS60 = 0
  1821.       SEGACT IPT6
  1822.  
  1823. c boucle sur les couleurs
  1824.       NBELEM = 0
  1825.       NBNN= 0
  1826.       NBREF= 0
  1827.       NBSOUS=6
  1828.       SEGINI IPT4
  1829.       DO 37 ICOUL = 1, 6        
  1830. c boucle sur les sous maillages de ipt6
  1831.           NCOl = 0
  1832.           DO 38 I6 = 1, NBS6
  1833.                 IPT3 = IPT6.LISOUS(I6)
  1834.                 SEGACT IPT3
  1835.                 IF ((IPT3.icolor(1)).EQ.ICOUL) then
  1836.                    NCOL = NCOL+1
  1837.                    IF (NCOL.EQ.1) THEN
  1838.                       SEGINI IPT2
  1839.                       IPT2 = IPT6.LISOUS(I6)
  1840.  
  1841.                    ENDIF
  1842.                    IF (NCOL.GE.2) THEN
  1843.  
  1844. c                      IPT3 = IPT6.LISOUS(I6)
  1845. c                      SEGACT IPT3
  1846. c Plusieurs sous maillages de même couleur on concatene IPT2 et IPT3
  1847.                       NBELEM = IPT2.NUM(/2)
  1848.                       NBNN= IPT2.NUM(/1)
  1849.                       NBREF=0
  1850.                       NBSOUS=0
  1851.                       NBELE0 = NBELEM
  1852.                       DO 381 IE3 = 1, IPT3.NUM(/2)
  1853.                       DO 382  IE2 = 1, NBELE0
  1854.                     IF ((IPT3.NUM(1,IE3)).EQ.(IPT2.NUM(1,IE2))) GOTO 381
  1855.  382                  CONTINUE
  1856.                       NBELEM = NBELEM +1
  1857.                       SEGADJ IPT2 
  1858.                       DO IN2 = 1, NBNN
  1859.                          IPT2.NUM(IN2 , NBELEM) = IPT3.NUM(IN2, IE3)
  1860.                          IPT2.icolor(NBELEM) = IPT3.icolor(IE3)
  1861.                       ENDDO                           
  1862.  381                  CONTINUE                    
  1863.                    ENDIF
  1864.                 ENDIF
  1865.  38        CONTINUE 
  1866.           IF (NCOL.GE.1) THEN
  1867.               IPT4.LISOUS(ICOUL) = IPT2
  1868.               NBS60= NBS60+1
  1869.           ENDIF
  1870.  
  1871.  37   CONTINUE
  1872.  
  1873. c mise a jour de ipt6 et ipt7      
  1874.       IF (NBS60.EQ.1) then
  1875.          IPT6 = IPT2
  1876.          segact ipt6
  1877.  
  1878. c         write (*,*) 'IPT6' , IPT6
  1879. c         write (*,*) 'type', IPT6.ITYPEL, 'Nbel' , IPT6.num(/2)
  1880.          IND7=IND7+1
  1881.          IPT7.LISOUS(IND7) = IPT2
  1882. c          write (*,*) 'IPT7.LISOUS(',IND7,')' , IPT7.LISOUS(IND7)
  1883. c          write (*,*) 'type', IPT2.ITYPEL, 'Nbel' , IPT2.num(/2)
  1884.       ELSE
  1885.         SEGACT IPT4
  1886.         NBELEM = 0
  1887.         NBNN = 0
  1888.         NBREF = 0
  1889.         NBSOUS = NBS60
  1890.         SEGINI IPT6
  1891.         IS6=0
  1892.         DO ICOUL = 1, 6
  1893.           IF ((IPT4.LISOUS(ICOUL)).NE.0) THEN
  1894.             IS6 = IS6+1
  1895.             IPT6.LISOUS(IS6)= IPT4.LISOUS(ICOUL)
  1896. c            write (*,*) 'IPT6.LISOUS(',IND6,')' , IPT6.LISOUS(IND6)
  1897. c            write (*,*) 'type', IPT4.ITYPEL, 'Nbel' , IPT4.num(/2)
  1898.  
  1899.             IND7=IND7+1
  1900.             IPT7.LISOUS(IND7) = IPT4.LISOUS(ICOUL)
  1901.           ENDIF
  1902.         ENDDO
  1903.       ENDIF
  1904.  370   CONTINUE
  1905.       NBELEM = 0
  1906.       NBNN = 0
  1907.       NBREF = 0
  1908.       NBSOUS = IND7
  1909.  
  1910.       SEGADJ IPT7
  1911.  
  1912.       SEGINI LTYPE4
  1913.       LTYPE4 = LTYPE3
  1914.  
  1915. c  mise a jour du nombre global de relations
  1916.       LCONF3 = MCONF    
  1917.  
  1918.  
  1919. C
  1920. C=======================================================================
  1921. C              Test sur la progression du raffinement
  1922. C=======================================================================
  1923. C
  1924. C
  1925. C     CB215821 Retrait du caractere *MOD le cas echeant
  1926.       SEGACT IPT5,MCHPO1,MSOUPO,MPOVA1,IPT3,KMILIE
  1927. c      SEGSUP ICPR,KARETE,KARPOS,KARET2,ICHPO,IDENSI
  1928. c      SEGSUP ICPR,KARETE,KARPOS,KARET2,IDENSI
  1929.       SEGSUP KARETE,KARPOS,KARET2
  1930.       SEGSUP MCHAM1,MELVA1,MCHAM2,MELVA2,IMODE1
  1931.       SEGSUP MMODE1,MCHEL1,MCHEL2
  1932.  
  1933.       IF ((IDIM.EQ.3).AND.(NBOUCL.NE.1)) SEGSUP JPLANS,JPLAN2,JPLAN3,
  1934.      +JPLCOM,JNOEFA,IWORK2,JFARAF, IPT9
  1935.  
  1936.  
  1937. C S'il y a eu a raffiner des elements lors de l'iteration courante, 
  1938. C on passe a l'iteration suivante
  1939. C
  1940. c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1941. c   forcage  : nb max itération de raff
  1942. c      IF (NBOUCL.EQ.3) THEN
  1943. c           KARAF2=0
  1944. c           KARAF=0
  1945. c      ENDIF
  1946. c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  1947.       IF (KARAF2.NE.0) GOTO 9
  1948.  
  1949.  
  1950.  
  1951. C
  1952. C ### SORTIE TEMPORAIRE DU PROGRAMME ###
  1953. C Si on est a la premiere iteration de RAFF et qu'il n'y a pas 
  1954. C d'elements a raffiner, on retourne en sortie le maillage de depart, 
  1955. C donné en entree
  1956.       IF ((KARAF2.EQ.0).AND.(NBOUCL.EQ.1)) THEN
  1957.         WRITE(*,*) 'il n est pas necessaire de raffiner le maillage'
  1958.         MELEME=IPT1
  1959.         GOTO 998
  1960.  
  1961.       ENDIF
  1962.  
  1963.  
  1964. C
  1965. C
  1966. C=======================================================================
  1967. C                     Mises a jour diverses
  1968. C=======================================================================
  1969. C **  On affecte une densite a chaque noeud que l'on a cree      
  1970. c      DO 37 I=NPTINI+1,XCOOR(/1)/(IDIM+1)
  1971. c        XCOOR(I*(IDIM+1))=DENSI(ICPR(I,1))
  1972. c  37  CONTINUE
  1973.  
  1974. C
  1975. C=======================================================================
  1976. C                      Fin du programme
  1977. C=======================================================================
  1978.  
  1979.       MELEME=IPT7
  1980.  
  1981.       SEGSUP XDEN
  1982.  998  CONTINUE
  1983.  
  1984.       CALL ACTOBJ('MAILLAGE',MELEME,1)
  1985.       CALL ECROBJ('MAILLAGE',MELEME)
  1986.  
  1987.       END
  1988.  
  1989.  
  1990.  
  1991.  
  1992.  
  1993.  
  1994.  
  1995.  
  1996.  
  1997.  

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