Télécharger la plaquette Cast3M


fr en

Télécharger tria.eso

Retour à la liste

Numérotation des lignes : 

tria

  1. C TRIA      SOURCE    GOUNAND   21/04/13    21:15:17     10956          
  2.       SUBROUTINE TRIA
  3. C     ******************************************************************
  4. C     INTERFACE CASTEM 2000
  5. C
  6. C
  7. C     (1) SURF1 = TRIANGULATION LIG1 (N1) ;
  8. C
  9. C     (2) MAIL2 = TRIANGULATION MAIL1 ('CONV') (FLOT1) ;
  10. C
  11. C     (3) MAIL2 = TRIANGULATION MAIL1 (FLOT1) ;
  12. C
  13. C     OBJET :
  14. C     _______
  15. C
  16. C     (1) L'OPERATEUR TRIANGULATION CONSTRUIT UN MAILLAGE D'UN DOMAINE
  17. C     PLAN DEFINI PAR SA FRONTIERE (OBJET LIG1). LES ELEMENTS SONT DES
  18. C     TRIANGLES LINEAIRES QUELLES QUE SOIENT LES DIRECTIVES  D'OPTION.
  19. C     LE NOMBRE DE NOEUDS GENERES  EST  MINIMUM,  IL  PEUT ETRE ENCORE
  20. C     LIMITE EN FIXANT LA VALEUR DE N1.
  21. C
  22. C
  23. C     (2) L'OPERATEUR TRIANGULATION CONSTRUIT LE MAILLAGE (OBJET MAIL2)
  24. C     DE LA TRIANGULATION DE DELAUNAY D'UN MAILLAGE DE POINTS (OBJET
  25. C     MAIL1).
  26. C     - LE MOT CLEF 'CONV' IMPOSE DE VERIFIER LA CONVEXITE DE MAIL2
  27. C       (APPEL A VERCON), LA TAILLE DE LA BOITE EST AUGMENTEE SI BESOIN.
  28. C     - FLOT1 EST UNE TAILLE DE MAILLE CIBLE A RESPECTER POUR MAIL2:
  29. C       APRES UNE TRIANGULATION, UN NOEUD EST AJOUTE AU MILIEU DE CHAQUE
  30. C       LIGNE DONT LA LONGEUR EXCEDE (4/3)*FLOT1, LE NOUVEL ENSEMBLE DE
  31. C       POINTS EST ALORS RE-TRIANGULE.
  32. C
  33. C     (3) L'OPERATEUR TRIANGULATION CONSTRUIT LE MAILLAGE (OBJET MAIL2)
  34. C     DE L'INTERIEUR D'UNE SURFACE (D'UN VOLUME) EN DIMENSION 2 (3)
  35. C     DEFINIE PAR UN CONTOUR (UNE ENVELOPPE) MAIL1 PAR TRIANGULATION.
  36. C     MAIL1 PEUT EGALEMENT ETRE UNE SURFACE (UN VOLUME), DANS CE CAS LES
  37. C     NOEUDS SITUES A L'INTERIEURS SERONT PRIS EN COMPTE DANS LA
  38. C     TRIANGULATION.
  39. C     - FLOT1 EST UNE TAILLE DE MAILLE CIBLE A RESPECTER POUR MAIL2:
  40. C       APRES UNE TRIANGULATION, UN NOEUD EST AJOUTE AU MILIEU DE CHAQUE
  41. C       LIGNE DONT LA LONGEUR EXCEDE (4/3)*FLOT1, LE NOUVEL ENSEMBLE DE
  42. C       POINTS EST ALORS RE-TRIANGULE.
  43. C
  44. C     DATE : 10.04.96 / 03.05.96 / 04.04.97 / 17.02.12
  45. C     ______
  46. C
  47. C     AUTEURS : T. CHARRAS ET O. STAB
  48. C     _________
  49. C
  50. C     ******************************************************************
  51.       IMPLICIT INTEGER(I-N)
  52.       IMPLICIT REAL*8 (A-H,O-Z)
  53. C
  54. -INC SMCHPOI
  55. -INC PPARAM
  56. -INC CCOPTIO
  57. -INC SMELEME
  58. -INC SMCOORD
  59. -INC CCGEOME
  60. -INC SMLENTI
  61. -INC SMTEXTE
  62.       SEGMENT ITRAVX
  63.        INTEGER ITVL (ITOTAI)
  64.       ENDSEGMENT
  65.       SEGMENT RTRAV
  66.        REAL*8 RTVL (ITOTAR)
  67.       ENDSEGMENT
  68.       SEGMENT ICPR (nbpts)
  69.       SEGMENT ICPP (nbpts)
  70.       INTEGER NITMAX,NRTMAX,NPONEW,ITRACE,IERRDS
  71. C
  72. C     --- VARIABLES INTERNES ---
  73.       INTEGER NBN,NBE,IDIMC,NBNMAX,NBCMAX,IDE,NBPMAX,NBEMAX,ITRNOE
  74.       INTEGER ITRTRI,NOETRI,ITRAV,IRTRAV,NITMX2,NRTMX2,ICOORD
  75.       INTEGER NMT,I,NBNARE, IARETE
  76.       INTEGER IMAT,IFRL,NBFRL,IMATE,NOEMAX,MAT
  77.       INTEGER ITRIRG,NMTCC,IRGREF,IMATCC
  78.       INTEGER NCC,NBENEW
  79. C
  80. C     (S. PASCAL)
  81.       CHARACTER*4 MOT1
  82.       CHARACTER*4 MOTOPO(1)
  83.       DATA MOTOPO/'TOPO'/ 
  84. C
  85. C Lecture du mot-cle particulier TOPO  (S. GOUNAND 2021)
  86. C      
  87.       CALL LIRMOT(MOTOPO,1,itopo,0)
  88.       if (ierr.ne.0) return
  89.       if (itopo.EQ.1) then
  90.          SEGINI MTEXTE
  91.          LTT=13
  92.          MTEXT(1:LTT) ='MAILTOPO TRIA'
  93.          NCART=13
  94.          SEGDES MTEXTE
  95.          CALL ECROBJ('TEXTE',MTEXTE)
  96.          return
  97.       endif
  98. C     
  99. C     --- CONSTANTES DE DIMENSIONNEMENT ---
  100. C     POUR LE RESPECT DE LA FRONTIERE :
  101. C     --------------------------------
  102. C     NCMAX : LE NOMBRE MAXIMUM DE COTE DU POLYGONE
  103. C     NPMAX : LE NOMBRE MAXIMUM DE POLYGONES EMPILES
  104. C     EN ENTIER => ((2*(2*NCMAX+1))* NPMAX) + 3*(NCMAX-2)
  105. C     EN REELS  => 2 * NPMAX
  106. C     NPMAX = 1000, NCMAX = 20 => 82054 ENTIERS
  107. C                              =>  2000 REELS
  108. C     --- CONSTANTES ---
  109.       IDIMC = 2
  110.       CALL DSINIT
  111. C
  112. C        =======================
  113. C     --- 1.LECTURE DES DONNEES ---
  114. C        =======================
  115. *
  116. *     LECTURE DES OBJETS COURANTS (ENTREES)
  117. *     =====================================
  118.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  119.       IF (IERR.NE.0) THEN
  120. C        ON A PAS TROUVE LE MAILLAGE
  121.          CALL ERREUR(503)
  122.          GOTO 999
  123.       ENDIF
  124.       CALL ACTOBJ('MAILLAGE',IPT1,1)
  125.       NBSZ=IPT1.LISOUS(/1)
  126.       NTYP=IPT1.ITYPEL
  127. C
  128. C---- SI PRESENCE D'UN ENTIER, SYNTAXE PREMIERE (O. STAB) --------------
  129. C
  130.       CALL LIRENT(IVAL,0,IRETOU)
  131.       IF (IRETOU.EQ.1) GOTO 100
  132. C
  133. C---- SI MAILLAGE DE POI1 : TRIANGULATION DE POINTS (S. PASCAL) --------
  134. C
  135.       IF ((IDIM.NE.1).AND.(IDIM.NE.2).AND.(IDIM.NE.3)) THEN
  136.          INTERR(1)=IDIM
  137. C        FONCTION INDISPONIBLE EN DIMENSION %I1
  138.          CALL ERREUR(709)
  139.          GOTO 999
  140.       ENDIF
  141.       IF ((NBSZ.EQ.0).AND.(NTYP.EQ.1)) THEN
  142.  
  143.          IF(IPT1.NUM(/2) .LT. IDIM+1) THEN
  144. C          Cas du MAILLAGE VIDE en sortie si moins de IDIM+1 POI1 a trianguler
  145.            NBELEM=0
  146.            NBREF =0
  147.            NBSOUS=0
  148.            NBNN  =IDIM+1
  149.            SEGINI,IPT2
  150.            IF    (IDIM.EQ.1)THEN
  151.              IPT2.ITYPEL=2             
  152.            ELSEIF(IDIM.EQ.2)THEN
  153.              IPT2.ITYPEL=4             
  154.            ELSEIF(IDIM.EQ.3)THEN
  155.              IPT2.ITYPEL=23
  156.            ENDIF
  157.  
  158.          ELSE
  159. C          Parametre optionnel : mot-clef CONV pour verifier la convexite
  160.            IVC=0
  161.            CALL LIRCHA(MOT1,0,IRETOU)
  162.            IF (IRETOU.NE.0) THEN
  163.               IF (MOT1(1:4).EQ.'CONV') IVC=1
  164.            ENDIF
  165. C          Parametre optionnel : taille de maille pour re-maillage
  166.            CALL LIRREE(XDEN,0,IRETOU)
  167.            IF (IRETOU.EQ.0) XDEN=0.D0
  168.            XDEN43=XDEN*4.D0/3.D0
  169. C          
  170.            MPOVAL = 0
  171.            CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETOU)
  172.            IF(IRETOU.EQ.1) THEN
  173.              CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  174.               MSOUPO=IPCHP(1)
  175.               MPOVAL=IPOVAL
  176.            ENDIF
  177. C          
  178. C          Appel a TRIA1 pour le calcul de la triangulation de Delaunay
  179.            CALL TRIA1(MPOVAL,IPT1,IVC,XDEN43,IPT2)
  180.          ENDIF
  181.  
  182.          IF (IERR.NE.0) RETURN
  183. C
  184.          CALL ACTOBJ('MAILLAGE',IPT2,1)
  185.          CALL ECROBJ('MAILLAGE',IPT2)
  186.          GOTO 999
  187.       ENDIF
  188. C
  189. C---- AUTRES DISTINCTIONS ----------------------------------------------
  190. C
  191. C     Parametre optionnel : taille de maille pour re-maillage
  192.       CALL LIRREE(XDEN,0,IRETOU)
  193.       IF (IRETOU.EQ.0) XDEN=0.
  194.       XDEN43=XDEN*4./3.
  195. C
  196. C---- SI DIMENSION 2 ET PAS DE FLOTTANT : SYNTAXE PREMIERE (O. STAB) ---
  197. C
  198.       IF ((IDIM.EQ.2).AND.(XDEN.EQ.0.))  GOTO 100
  199. C
  200. C---- MAILLAGE DE L'INTERIEUR D'UN CONTOUR EN DIMENSION 2 OU BIEN DE ---
  201. C     L'INTERIEUR D'UN VOLUME EN DIMENSION 3 (S. PASCAL)
  202. C
  203.       IF (NBSZ.NE.0) THEN
  204. C        Operation interdite sur un objet complexe
  205.          CALL ERREUR(25)
  206.          GOTO 999
  207.       ENDIF
  208.       IF (((IDIM.EQ.2).AND.(NTYP.NE.2).AND.(NTYP.NE.4)).OR.
  209.      &    ((IDIM.EQ.3).AND.(NTYP.NE.4).AND.(NTYP.NE.23))) THEN
  210. C        Type d'element incorrect
  211.          CALL ERREUR(16)
  212.          GOTO 999
  213.       ENDIF
  214. C     Appel a TRIA2 pour la construction du maillage par triangulation
  215.       CALL TRIA2(IPT1,XDEN43,IPT2)
  216.       IF (IERR.NE.0) RETURN
  217. C     Ecriture sortie/fin
  218.       CALL ACTOBJ('MAILLAGE',IPT2,1)
  219.       CALL ECROBJ('MAILLAGE',IPT2)
  220.       GOTO 999
  221. C
  222. C---- DANS LES AUTRES CAS : TRIANGULATION CONTRAINTE D'UN CONTOUR ------
  223. C     (O. STAB)
  224. C
  225. 100   CONTINUE
  226.       IF(IDIM.NE.2) THEN
  227.         INTERR(1)=IDIM
  228. C       FONCTION INDISPONIBLE EN DIMENSION %I1
  229.         CALL ERREUR(709)
  230.         GOTO 999
  231.       ENDIF
  232. C
  233.       NBNARE = IPT1.NUM(/2)
  234.       NBNTOT =  -1
  235.       IF(IRETOU.NE.0) THEN
  236.           IF( IVAL.LT.NBNARE )THEN
  237. C           Le nombre de noeuds ne peut ètre inférieur à %i1
  238. C           (nombre d'arètes)
  239.             INTERR(1) = NBNARE
  240.             CALL ERREUR(849)
  241.             GOTO 999
  242.           ENDIF
  243.           NBNTOT = IVAL
  244.       ENDIF
  245. C
  246.       IF((IPT1.LISOUS(/1).NE.0).OR.
  247.      >   (IPT1.ITYPEL.NE.2).OR.
  248.      >   (NBNARE.LT.3))THEN
  249. C         DONNEES INCOMPATIBLES
  250.           CALL ERREUR(21)
  251.           GOTO 999
  252.       ENDIF
  253. *
  254. *     ALLOCATION DE LA MEMOIRE
  255. *     =====================================
  256.       ICMEMO = 1
  257. C      NBNREL = (NBNARE**2 ) / 2
  258. C
  259.       NBNREL = NBNARE * 3
  260. C     --- POUR TESTER LES MESSAGE D'ERREUR ET LA REALLOCATION :
  261. C      NBNREL = NBNARE + 50
  262.       NBNABS = 20000
  263.     5 CONTINUE
  264.       ICOORD  = 1
  265.       IARETE = 1
  266.       NMT=1
  267.       NBN= NBNARE
  268.       IF(NBNTOT.NE.-1) THEN
  269.           NBPTMX = NBNTOT*ICMEMO + 50
  270.           NPONEW = NBNTOT*ICMEMO -NBN
  271.       ELSE
  272.           NBPTMX = NBNREL*ICMEMO + 50
  273.           NPONEW = NBNREL*ICMEMO - NBN
  274.       ENDIF
  275.       NITMAX =  20 * NBPTMX + 288 + 310 + 82054
  276.       NRTMAX =  12 * (NBPTMX + 12) + 2000
  277. *
  278. *     TRANSFERT DANS LA STRUCTURE DE L'ALGO
  279. *     =====================================
  280. *
  281. *  REMPLISSAGE DU TABLEAU DE CONNEXION
  282. *  ===================================
  283.       ITOTAI= NITMAX
  284.       SEGINI ITRAVX
  285.       segact mcoord*mod
  286.       NBANC = nbpts
  287.       SEGINI,ICPR,ICPP
  288.       ITOTAR = NRTMAX
  289.       SEGINI RTRAV
  290.       INO = 0
  291.       DO 7764 I=1,NBNARE
  292.         DO 7765 J=1,2
  293.           IA = IPT1.NUM(J,I)
  294.           IF( ICPR(IA).EQ.0) THEN
  295.              INO = INO+1
  296.              ICPR(IA) = INO
  297.              ICPP(INO)=IA
  298.              RTVL((INO-1)*2 +1) = XCOOR( ( IA-1) * 3 +1)
  299.              RTVL((INO-1)*2 +2) = XCOOR( ( IA-1) * 3 +2)
  300.           ENDIF
  301.           ITVL ((I-1)*2 +J) = ICPR(IA)
  302.  7765   CONTINUE
  303.  7764 CONTINUE
  304.       NBN=INO
  305. C
  306. C     --- IL FAUT ANTICIPER LE NOMBRE DE NOEUDS GENERES ---
  307. C         NBPMAX SERT A DIMENSIONNER NOETRI, COORD
  308. C         NBEMAX SERT A DIMENSIONNER ITRNOE, ITRTRI
  309. C
  310.       NBPMAX = NBN + MAX(NPONEW,50)
  311.       NBEMAX = 2 * NBN + 2 * MAX(NPONEW,50) - 2
  312. C
  313. C         ==============================
  314. C     --- 2. CALCUL DE LA TRIANGULATION ---
  315. C         ==============================
  316. C
  317.       NBNMAX = 3
  318.       NBCMAX = 3
  319.       NBE = 0
  320.       IDE = 2
  321. C
  322. C        ----------------
  323. C     --- 2.1 ALLOCATION ---
  324. C        ----------------
  325. C     ITVL = |IARETE|IMAT| ITRNOE | ITRTRI | NOETRI | ITRAV
  326. C                             NBEMAX*3  NBEMAX*3  NBPMAX    310
  327. C                                                         TNUPOT
  328. C
  329. C     =========== BUG 1 ============
  330.       ITRNOE = (NBNARE * 2) + 1
  331.       ITRTRI = ITRNOE + (NBEMAX * NBNMAX)
  332.       NOETRI  = ITRTRI + (NBEMAX * NBCMAX)
  333.       ITRAV = NOETRI + NBPMAX
  334.       NITMX2 = NITMAX - ITRAV
  335.       IRTRAV = NBPMAX * IDIMC + 1
  336.       NRTMX2 = NRTMAX - IRTRAV
  337. C
  338. C        --------------------------------------------
  339. C     --- 2.2 CALCUL DE LA TRIANGULATION DE DELAUNAY ---
  340. C        --------------------------------------------
  341. C
  342.       CALL TNUPOT(RTVL(ICOORD),NBN,ITVL(ITRNOE),
  343.      >     NBNMAX,ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),NBE,
  344.      >     ITVL(ITRAV),NITMX2,RTVL(IRTRAV),IERRDS)
  345.       NCC = 1
  346. C
  347.       IF(IERRDS.NE.0)THEN
  348.         IF(IERRDS.EQ.-2)THEN
  349.           IERRDS = 0
  350.           ICMEMO = ICMEMO + 1
  351.           SEGSUP ITRAVX,ICPR,ICPP,RTRAV
  352. C         Patience on reprend avec plus de mémoire...
  353.           CALL ERREUR(850)
  354.           GOTO 5
  355.         ENDIF
  356. C      Erreur de triangulation : vérifiez qu'il n'y a pas de points
  357. C      confondus
  358.         CALL ERREUR(846)
  359. C     ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
  360. C        CALL ERREUR(27)
  361.         IERRDS = 0
  362.         GOTO 40
  363.       ENDIF
  364. C
  365. C
  366. C         ==================================
  367. C     ---  3.  FORCAGE DES ARETES FRONTIERES
  368. C              DANS LA TRIANGULATION          ---
  369. C         ==================================
  370. C
  371.       IRTRAV = NBPMAX * IDIMC + 1
  372.       NRTMX2 = NRTMAX - IRTRAV
  373.       DO 10 I=1,NBNARE
  374.         CALL RF2RAR(ITVL((I-1)*2+IARETE),
  375.      >             ITVL(ITRNOE),NBNMAX,
  376.      >             ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),NBE,
  377.      >             RTVL(ICOORD),ITVL(ITRAV),NITMX2,
  378.      >             RTVL(IRTRAV),NRTMX2,
  379.      >             NBENEW,IERRDS)
  380. C
  381.       IF( IERRDS .NE. 0 )THEN
  382.         IF(IERRDS.EQ.-2)THEN
  383.           IERRDS = 0
  384.           ICMEMO = ICMEMO + 1
  385.           SEGSUP ITRAVX,ICPR,ICPP,RTRAV
  386. C         Patience on reprend avec plus de mémoire...
  387.           CALL ERREUR(850)
  388.           GOTO 5
  389.         ELSE
  390. C       Erreur de frontière : Vérifiez que le contour n'est pas croisée
  391.         CALL ERREUR(847)
  392. C     ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
  393. C        CALL ERREUR(27)
  394.         IERRDS = 0
  395.         GOTO 40
  396.         ENDIF
  397.       ENDIF
  398. C
  399.    10 CONTINUE
  400. C
  401. C         ==================================
  402. C     ---  4. DESTRUCTION DES ELEMENTS
  403. C             EXTERIEURS : SCULPT         ---
  404. C         ==================================
  405. C
  406. C        ----------------
  407. C     --- 4.1 ALLOCATION ---
  408. C        ----------------
  409. C     ITVL = ...ITRTRI|NOETRI| IFRL    | ITRAV
  410. C                                   NBFRL*2   2*NBE+PILE
  411. C                                                SCULPT
  412. C
  413.       IFRL  = IARETE
  414.       NBFRL = NBNARE
  415.       NITMX2 = NITMAX - ITRAV
  416.       IF(NBNARE.NE.0)
  417.      > CALL SCULPT(ITVL(IFRL),2,NBFRL,
  418.      >             IDE,ITVL(ITRNOE),NBNMAX,
  419.      >             ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),
  420.      >             NBE,ITVL(ITRAV),NITMX2,NCC,IERRDS)
  421. C
  422.       IF( IERRDS .NE. 0 )THEN
  423.        IF(IERRDS.EQ.-2)THEN
  424.           IERRDS = 0
  425.           ICMEMO = ICMEMO + 1
  426.           SEGSUP ITRAVX,ICPR,ICPP,RTRAV
  427. C         Patience on reprend avec plus de mémoire...
  428.           CALL ERREUR(850)
  429.           GOTO 5
  430.        ELSE
  431. C      Erreur de frontière : Vérifiez que le contour est fermé
  432.        CALL ERREUR(848)
  433. C      ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
  434. C       CALL ERREUR(27)
  435.        IERRDS = 0
  436.        GOTO 40
  437.        ENDIF
  438.       ENDIF
  439. C
  440. C        ==================================
  441. C     --- 5. CALCUL DES NOEUDS INTERIEURS  ---
  442. C        ==================================
  443. C
  444. C        ----------------
  445. C     --- 5.1 ALLOCATION ---
  446. C        ----------------
  447. C     ITVL = ...ITRTRI|NOETRI| ITRAV
  448. C                                    310 (DELAJOUTPT)
  449. C
  450.       NBPMAX = NBN + NPONEW
  451.       ITRAV = NOETRI + NBPMAX
  452.       NITMX2 = NITMAX - ITRAV
  453.       IRTRAV = NBPMAX * IDIMC + 1
  454.       NRTMX2 = NRTMAX - IRTRAV
  455.       NOEMAX = NBPMAX
  456. C
  457.       CALL R2RAF(ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI),NBCMAX,
  458.      >     ITVL(NOETRI),NOEMAX,
  459.      >     RTVL(ICOORD),NBN,NBE,NBPMAX,NBEMAX,
  460.      >     ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,
  461.      >     IERRDS)
  462. C
  463.       IF(IERRDS.NE.0)THEN
  464.         IF(IERRDS.EQ.-2)THEN
  465.           IF(NBNTOT.EQ.-1)THEN
  466. C           PAS DE LIMITATION SUR LES NOEUDS, LA MEMOIRE EVALUEE
  467. C           EST INSUFFISANTE
  468. C           Patience on reprend avec plus de mémoire...
  469.             IERRDS = 0
  470.             ICMEMO = ICMEMO + 1
  471.             SEGSUP ITRAVX,ICPR,ICPP,RTRAV
  472.             CALL ERREUR(850)
  473.             GOTO 5
  474.           ENDIF
  475. C         LIMITATION SUR LES NOEUDS DONNE PAR L'UTILISATEUR
  476.           IERRDS = 0
  477.           GOTO 40
  478.         ENDIF
  479. C       IERRDS = -1 ...
  480.         CALL ERREUR(848)
  481. C     ERREUR GENERATION DE MAILLAGE. IL EST NEANMOINS CREE POUR CONTROLE
  482. C        CALL ERREUR(27)
  483.         IERRDS = 0
  484.         GOTO 40
  485.       ENDIF
  486. *
  487. *   REMPLISSAGE NOUVEL OBJET MAILLAGE ET TABLEAU DES COORDONNEES
  488. *   ============================================================
  489.   40  CONTINUE
  490.       NBELEM=NBE
  491.       NBNN=3
  492.       NBREF=0
  493.       NBSOUS=0
  494.       SEGINI MELEME
  495.       NBPTS = NBN-INO+NBANC
  496.       SEGADJ MCOORD
  497.       DO 7781 I=1,NBN-INO
  498.       XCOOR((NBANC +I-1)*(IDIM+1) +1) = RTVL((INO+I-1)*2+1)
  499.       XCOOR((NBANC +I-1)*(IDIM+1) +2) = RTVL((INO+I-1)*2+2)
  500. *     ---- POUR LA DENSITE : DENSITE COURANTE ----
  501.       XCOOR((NBANC +I-1)*(IDIM+1) +3) = DENSIT
  502.  7781 CONTINUE
  503. *
  504.       DO 7782 I=1,NBE
  505.        DO 7783 J=1,3
  506.        IA=ITVL( (I-1)*3+J-1+ITRNOE)
  507. C
  508. C       III = ITVL( (I-1)*3+J-1+ITRTRI)
  509. C       IF( III.LT. 0 )THEN
  510. C         WRITE(6,*) ' ARETE ',J,' DU TRIANGLE ',I,' NEGATIVE ', III
  511. C       ENDIF
  512. C
  513.        IF ( IA .LE.INO) THEN
  514.         IB = ICPP(IA)
  515.       ELSE
  516.         IB = IA -INO +NBANC
  517.       ENDIF
  518.       NUM(J,I)=IB
  519.  7783 CONTINUE
  520.       ICOLOR(I) = IDCOUL
  521.  7782 CONTINUE
  522.       ITYPEL=4
  523.       CALL ACTOBJ('MAILLAGE',MELEME,1)
  524.       CALL ECROBJ('MAILLAGE',MELEME)
  525. C
  526. C     ---- DESALLOCATION ET FIN SUR ERREUR ----
  527.  9990 SEGSUP ITRAVX,RTRAV,ICPR,ICPP
  528. C
  529.   999 END
  530.  
  531.  
  532.  
  533.  
  534.  
  535.  
  536.  
  537.  
  538.  
  539.  
  540.  

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