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

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