Télécharger la plaquette Cast3M


fr en

Télécharger volume.eso

Retour à la liste

Numérotation des lignes : 

volume

  1. C VOLUME    SOURCE    SP204843  25/01/29    21:15:07     12139          
  2. C    MODIF : O.STAB / 25.03.97 / APPEL A VOLOS QUI
  3. C             AUTORISE UN RACCORD DE 2 GRILLES NON IDENTIQUE
  4. C    FABRICATION DE CUBES ET PRISMES PAR TRANSLATION ET ROTATION ET
  5. C                                ENTRE SURFACES OPPOSEES
  6. C    MODIFICATION AOUT 1984 : MAILLAGE AUTOMATIQUE A L'INTERIEUR D'UNE
  7. C    SURFACE ENVELOPPE
  8. C    DECEMBRE 1984  VERIFICATION QUE LES TOPOLOGIES DU HAUT ET DU BAS
  9. C    SONT SIMILAIRES (MEMES ICPR)
  10. C    JANVIER 1985  NOMBRE DE COUCHES IMPOSE SI INBR NEGATIF
  11. C    NOVEMBRE 1985 OPTION GENERATRICE  (APPEL VOLUMG)
  12. c    12/97 KICH modif en liaison avec evolution de PROPER
  13.  
  14.       SUBROUTINE VOLUME
  15.       IMPLICIT INTEGER(I-N)
  16.       IMPLICIT REAL*8 (A-H,O-Z)
  17. -INC SMELEME
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC SMCOORD
  22. -INC CCGEOME
  23. -INC CCREEL
  24. *-
  25. -INC SMLREEL
  26. -INC TDEMAIT
  27.       logical ltelq
  28.       SEGMENT TABPAR(NCOUCH)
  29.       SEGMENT ICPR(NBNNEL,NBELEC)
  30.       CHARACTER*4 MCLE(7)
  31.       DATA MCLE /'TRAN','ROTA','DINI','DFIN','GENE','PROG','VERB'/
  32.  
  33.       IDIMP1 = IDIM + 1
  34. c
  35.       MLREEL=0
  36.       IMPOI =0
  37.       IMPOF =0
  38.       ipt3  =0
  39.       ipt4  =0
  40.       IVERB =0
  41.  
  42. C     Pour l'optimiseur (SIGSEV parfois en DEBUG)
  43.       XDIS  =0.D0
  44.       YDIS  =0.D0
  45.       ZDIS  =0.D0
  46.  
  47.       DEN1I = 0.D0
  48.       DEN2I = 0.D0
  49. c
  50.       IF (ILCOUR.LT.14.OR.ILCOUR.GT.17) then
  51.         IF (ILCOUR.LT.23.OR.ILCOUR.GT.26) CALL ERREUR(16)
  52.       ENDIF
  53.       IF (IERR.NE.0) RETURN
  54.  
  55.       INBR=0
  56.       ICLE=3
  57.       CALL LIRENT(INBR,0,IREINB)
  58.   80  CALL LIRMOT(MCLE,7,JCLE,0)
  59.       IF (JCLE.EQ.0) GOTO 87
  60.       GOTO (81,82,83,84,79,78,75),JCLE
  61.  
  62. C---- mot-clé 'TRAN' :
  63.   81  CONTINUE
  64.       IF (ICLE.NE.3) GOTO 86
  65.       ICLE=JCLE
  66.       GOTO 80
  67.  
  68. C---- mot-clé 'ROTA' :
  69.   82  CONTINUE
  70.       IF (ICLE.NE.3) GOTO 86
  71. C LECTURE N1 AU CAS OU IL SOIT DERRIERE LE MOT CLE ROTA
  72. C L'UTILISATEUR PEUT AUSSI DONNER L'ANGLE AVEC UN ENTIER 
  73.       IF (IREINB.EQ.0) THEN
  74.         IREIN2=0
  75.         CALL LIRENT(INBR,0,IREIN2)
  76.         IF (IREIN2.EQ.1) THEN
  77.           CALL LIRREE(XXX,0,IRETOU)
  78.           IF (IRETOU.EQ.0) THEN
  79.             XXX=INBR
  80.           ELSE
  81.             IREINB = IREIN2
  82.           ENDIF
  83.         ELSE
  84.           CALL LIRREE(XXX,1,IRETOU)
  85.           IF (IERR.NE.0) RETURN
  86.         ENDIF
  87.       ELSE
  88.         CALL LIRREE(XXX,1,IRETOU)
  89.         IF (IERR.NE.0) RETURN
  90.       ENDIF
  91.       ANGLI=XXX
  92. C     write(6,*) 'ANGLI,INBR,DEN1I,DEN2I=',ANGLI,INBR,DEN1I,DEN2I
  93.       CALL LIROBJ('POINT ',IP1,1,IRETOU)
  94.       CALL LIROBJ('POINT ',IP2,1,IRETOU)
  95.       IF (IERR.NE.0) RETURN
  96.       ICLE=JCLE
  97.       GOTO 80
  98.  
  99. C---- mot-clé 'DINI' :
  100.   83  IF(IMPOI.EQ.1) GOTO 86
  101.       IMPOI=1
  102.       CALL LIRREE(XXX,1,IRETOU)
  103.       DEN1I=XXX
  104.       IF (DEN1I.LE.0.) THEN
  105.          CALL ERREUR(17)
  106.          RETURN
  107.       ENDIF
  108.       IF (IERR.NE.0) RETURN
  109.       GOTO 80
  110.  
  111. C---- mot-clé 'DFIN' :
  112.   84  IF (IMPOF.EQ.1) GOTO 86
  113.       IMPOF=1
  114.       CALL LIRREE(XXX,1,IRETOU)
  115.       DEN2I=XXX
  116.       IF (DEN2I.LE.0.) THEN
  117.          CALL ERREUR(17)
  118.          RETURN
  119.       ENDIF
  120.       IF (IERR.NE.0) RETURN
  121.       GOTO 80
  122.  
  123. C---- mot-clé 'GENE' :
  124.   79  CONTINUE
  125.       CALL VOLUMG
  126.       RETURN
  127.  
  128. C---- mot-clé 'PROG' :
  129.   78  CONTINUE
  130.       CALL LIROBJ('LISTREEL',MLREEL,1,IRETOU)
  131.       IF (IERR.NE.0) RETURN
  132.       GOTO 80
  133.  
  134. C---- mot-clé 'VERB' :
  135.   75  CONTINUE
  136.       IVERB=1
  137.       GOTO 80
  138.  
  139.   86  CONTINUE
  140.       CALL REFUS
  141.  
  142. C ... Fin de lecture des mots clés ...
  143.   87  CONTINUE
  144.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  145. C ... Si pas d'option TRAN ni ROTA on veut lire un deuxième maillage ...
  146.       IF (ICLE.EQ.3) CALL LIROBJ('MAILLAGE',IPT2,0,IRETOU)
  147. C ... S'il n'y en a pas, on va remplir l'enveloppe .(ou épaisseur)..
  148.        IF(IRETOU.EQ.0) GOTO 4400
  149. C            ==================================
  150. C     ------- DEBUT DE MODIF - O.STAB 05.12.96 --------
  151. C            ==================================
  152. C
  153. C     WRITE(IOIMP,*) ' ICLE = ',ICLE,DEN1I,DEN2I
  154.       IF((ICLE.NE.1).AND.(ICLE.NE.2).AND.(ICLE.NE.5))THEN
  155.         CALL LIROBJ('POINT ',IPO1,0,IRETOU)
  156.         IF( IRETOU.EQ.0)GOTO 871
  157.         CALL LIROBJ('POINT ',IPO2,0,IRETOU)
  158.         IF( IRETOU.EQ.0)GOTO 871
  159. C
  160. C calcul des densités moyennes si pas données
  161. C
  162.       DEN1D=1.
  163.       IF(IMPOI.EQ.0.AND.INBR.EQ.0) THEN
  164.         MELEME = IPT1
  165.         SEGACT MELEME
  166.         NBNN=NUM(/1)
  167.         NBELEM=NUM(/2)
  168.         NPR=0
  169.         DEN1=0.D0
  170.         DO 710 I=1,NBNN
  171.          DO 7101 J=1,NBELEM
  172.             IR=NUM(I,J)
  173.             IF (IR.EQ.0) GOTO 7101
  174.             IREF=(IR-1)*IDIMP1
  175.             NPR=NPR+1
  176.             DEN1=DEN1+XCOOR(IREF+4)
  177.  7101   CONTINUE
  178.  710  CONTINUE
  179.       DEN1D=DEN1/NPR
  180.       SEGDES MELEME
  181.       ENDIF
  182.       DEN2D=1.
  183.       IF(IMPOF.EQ.0.AND.INBR.EQ.0) THEN
  184.         MELEME = IPT2
  185.         SEGACT MELEME
  186.         NBNN=NUM(/1)
  187.         NBELEM=NUM(/2)
  188.         NPR=0
  189.         DEN2=0.D0
  190.         DO 711 I=1,NBNN
  191.          DO 7111 J=1,NBELEM
  192.             IR=NUM(I,J)
  193.             IF (IR.EQ.0) GOTO 7111
  194.             IREF=(IR-1)*IDIMP1
  195.             NPR=NPR+1
  196.             DEN2=DEN2+XCOOR(IREF+4)
  197.  7111   CONTINUE
  198.  711  CONTINUE
  199.       DEN2D=DEN2/NPR
  200.       SEGDES MELEME
  201.       ENDIF
  202.         CALL VOLOS(IPT1,IPT2,IPO1,IPO2,DEN1D,DEN2D,INBR)
  203.         RETURN
  204.       ENDIF
  205. C            ==================================
  206. C     ------- FIN  DE MODIF - O.STAB 05.12.96 --------
  207. C            ==================================
  208. C
  209.   871 CONTINUE
  210.  
  211. C ... Début du traitement ...
  212.       ISVOL1=0
  213.       ISVOL2=0
  214.       SEGACT IPT1
  215. C  SI IPT1 VOLUME IL FAUT EN EXTRAIRE LA FACE 1
  216. C ... dans la pratique le maillage initial soit n'a pas de
  217. C     sous-maillages, soit il en a 2 (triangles et quadrilatères),
  218. C     sinon la programmation ci-dessous poserait des problèmes :
  219. C     en cas de IPT1.LISOUS(/1) > 2 un saut immédiat vers 3101
  220. C     provoquerait SEGDES IPT3,IPT4 qui ne sont pas encore initialisés ...
  221.  3100 IF (IPT1.LISOUS(/1).EQ.0) GOTO 1000
  222.       IF (IPT1.LISOUS(/1).NE.2) GOTO 3101
  223.       IDEUX=2
  224.       IPT3=IPT1.LISOUS(1)
  225.       IPT4=IPT1.LISOUS(2)
  226.       SEGACT IPT3,IPT4
  227.       IP=IPT3.ITYPEL*IPT4.ITYPEL
  228. c ...     TRI3*QUA4    TRI6*QUA8   ...
  229.       IF (IP.NE.32.AND.IP.NE.60) GOTO 3101
  230.       IS=IPT3.ITYPEL+IPT4.ITYPEL
  231. c ...     TRI3+QUA4    TRI6+QUA8   ...
  232.       IF (IS.NE.12.AND.IS.NE.16) GOTO 3101
  233. c ... ici on a deux maillages : un composé de triangles, l'autre de quadrilatères ...
  234.       INCR=1
  235.       IF (IS.EQ.16) INCR=2
  236. c ... NBNNEL = nombre de noeuds / élément du maillage total ...
  237.       NBNNEL=4*INCR
  238. C  EN FAIT ON CREE UN SEGMENT QUI CONTIENT LES CUBES ET LES TRIANGLES
  239. C  0 DANS LA DERNIERE POSITION DU TRIANGLE
  240.       NBSOUS=0
  241.       NBREF=0
  242.       NBNN=NBNNEL
  243.       NBELE3=IPT3.NUM(/2)
  244.       IF (IPT3.ITYPEL.LE.6) NBTRI=NBELE3
  245.       IF (IPT3.ITYPEL.GE.8) NBQUA=NBELE3
  246.       NBELE4=IPT4.NUM(/2)
  247.       IF (IPT4.ITYPEL.LE.6) NBTRI=NBELE4
  248.       IF (IPT4.ITYPEL.GE.8) NBQUA=NBELE4
  249.       NBELEM=NBELE3+NBELE4
  250.       SEGINI MELEME
  251. C*C ... Initialisation du nouveau maillage à 0 (est-ce nécessaire ?) ...
  252. C*      DO 1100 I=1,NBNN
  253. C*         DO 1100 J=1,NBELEM
  254. C*            NUM(I,J)=0
  255. C* 1100 CONTINUE
  256. C ... On transvase IPT3 dans le nouveau maillage ...
  257.       DO 1101 J=1,NBELE3
  258.          ICOLOR(J)=IPT3.ICOLOR(J)
  259.          DO 11011 I=1,IPT3.NUM(/1)
  260.             NUM(I,J)=IPT3.NUM(I,J)
  261. 11011    CONTINUE
  262.  1101 CONTINUE
  263. C ... On transvase IPT4 dans le nouveau maillage ...
  264.       DO 1102 J=1,NBELE4
  265.          K=J+NBELE3
  266.          ICOLOR(K)=IPT4.ICOLOR(J)
  267.          DO 11021 I=1,IPT4.NUM(/1)
  268.             NUM(I,K)=IPT4.NUM(I,J)
  269. 11021    CONTINUE
  270.  1102 CONTINUE
  271.       GOTO 1001
  272.  
  273. C  RECHERCHE DE LA PREMIERE FACE DE IPT1
  274.  3101 if (ipt3.ne.0) segdes ipt3
  275.       if (ipt4.ne.0) segdes ipt4
  276.  3102 IF (IPT1.LISREF(/1).LT.2) CALL ERREUR(16)
  277.       IF (IERR.NE.0) RETURN
  278.       ISVOL1=IPT1
  279.       IAUX=IPT1.LISREF(2)
  280.       SEGDES IPT1
  281.       IPT1=IAUX
  282.       SEGACT IPT1
  283.       GOTO 3100
  284.  
  285. c ... On vient ici si le maillage est simple (homogène) ...
  286.  1000 CONTINUE
  287.       IDEUX=1
  288.       NBNNEL=IPT1.NUM(/1)
  289.       IF  (IPT1.ITYPEL.NE.8.AND.IPT1.ITYPEL.NE.10.AND.IPT1.ITYPEL.NE.4
  290.      #.AND.IPT1.ITYPEL.NE.6)  GOTO 3102
  291.       INCR=1
  292.       IF (KDEGRE(IPT1.ITYPEL).EQ.3) INCR=2
  293.       MELEME=IPT1
  294.  
  295. c ... ici MELEME est le maillage contanant tous les éléments de la surface initiale ...
  296.  1001 SEGACT MCOORD*mod
  297.  
  298. c ... SI c'est 'ROTA' ...
  299.       IF (ICLE.EQ.2) GOTO 1
  300.  
  301. c ... si ce n'est ni ROTA ni TRAN ...
  302.       IF (ICLE.EQ.3) GOTO 2
  303.  
  304. c---- OPTION 'TRAN'
  305. C LECTURE DES ARGUMENTS
  306.       CALL LIROBJ('POINT ',IVEC,1,IRETOU)
  307.       IF (IERR.NE.0) RETURN
  308. C AU CAS OU LE DECOUPAGE (N1) EST DERRIERE LE MOT CLE TRAN
  309.       IF (IREINB.EQ.0) CALL LIRENT(INBR,0,IREINB)
  310. C VECTEUR TRANSLATION
  311.       IREF=(IVEC-1)*IDIMP1
  312.       XTRAN=XCOOR(IREF+1)
  313.       YTRAN=XCOOR(IREF+2)
  314.       ZTRAN=XCOOR(IREF+3)
  315.       DEN2=XCOOR(IREF+4)
  316.       DLONG=SQRT(XTRAN*XTRAN+YTRAN*YTRAN+ZTRAN*ZTRAN)
  317.       XDIS=XTRAN
  318.       YDIS=YTRAN
  319.       ZDIS=ZTRAN
  320.       GOTO 2
  321.  
  322. C---- OPTION 'ROTA' ...
  323.    1  CONTINUE
  324.       ANGLE=ANGLI*XPI/180.D0
  325. c ... et des deux points définissant l'axe de rotation ...
  326.       IREF1=(IP1-1)*IDIMP1
  327.       IREF2=(IP2-1)*IDIMP1
  328.       XPT1=XCOOR(IREF1+1)
  329.       YPT1=XCOOR(IREF1+2)
  330.       ZPT1=XCOOR(IREF1+3)
  331.       XVEC=XCOOR(IREF2+1)-XCOOR(IREF1+1)
  332.       YVEC=XCOOR(IREF2+2)-XCOOR(IREF1+2)
  333.       ZVEC=XCOOR(IREF2+3)-XCOOR(IREF1+3)
  334.       DEN2=(XCOOR(IREF2+4)+XCOOR(IREF1+4))*0.5
  335.       RAY=SQRT(XVEC*XVEC+YVEC*YVEC+ZVEC*ZVEC)
  336.       XVEC=XVEC/RAY
  337.       YVEC=YVEC/RAY
  338.       ZVEC=ZVEC/RAY
  339.       IF (ANGLE.GE.0.) GOTO 2
  340.       ANGLE=-ANGLE
  341.       XVEC=-XVEC
  342.       YVEC=-YVEC
  343.       ZVEC=-ZVEC
  344.  
  345. c ... calcul des moyennes des densités et des coordonnées ...
  346.    2  CONTINUE
  347.       NBNN=NUM(/1)
  348.       NBELEM=NUM(/2)
  349.       NPR=0
  350.       DEN1=0.
  351.       XG=0.
  352.       YG=0.
  353.       ZG=0.
  354.       XG1=0.
  355.       YG1=0.
  356.       ZG1=0.
  357.       XL1=0.
  358.       YL1=0.
  359.       ZL1=0.
  360.       DO 5 I=1,NBNN
  361.          DO 51 J=1,NBELEM
  362.             IR=NUM(I,J)
  363.             IF (IR.EQ.0) GOTO 51
  364.             IREF=(IR-1)*IDIMP1
  365.             NPR=NPR+1
  366.             DEN1=DEN1+XCOOR(IREF+4)
  367.             XG=XG+XCOOR(IREF+1)
  368.             YG=YG+XCOOR(IREF+2)
  369.             ZG=ZG+XCOOR(IREF+3)
  370.             IF (XCOOR(IREF+1).GT.XG1) XG1 = XCOOR(IREF+1)
  371.             IF (XCOOR(IREF+2).GT.YG1) YG1 = XCOOR(IREF+2)
  372.             IF (XCOOR(IREF+3).GT.ZG1) ZG1 = XCOOR(IREF+3)
  373.             IF (XCOOR(IREF+1).LT.XL1) XL1 = XCOOR(IREF+1)
  374.             IF (XCOOR(IREF+2).LT.YL1) YL1 = XCOOR(IREF+2)
  375.             IF (XCOOR(IREF+3).LT.ZL1) ZL1 = XCOOR(IREF+3)
  376.   51     CONTINUE
  377.    5  CONTINUE
  378.       DEN1=DEN1/NPR
  379.       XG=XG/NPR
  380.       YG=YG/NPR
  381.       ZG=ZG/NPR
  382.  
  383. c ... cas 'TRAN' => GOTO 6 ...
  384.       IF (ICLE.EQ.1) GOTO 6
  385. c ... cas 'ROTA' => GOTO 3 ...
  386.       IF (ICLE.EQ.2) GOTO 3
  387. c ... cas du volume entre deux surfaces ...
  388. C  COMPATIBILITE DU 2EME OBJET ET RECHERCHE DU CENTRE DE GRAVITE
  389.       SEGACT IPT2
  390.  3150 IF (IPT2.LISOUS(/1).EQ.0) GOTO 1020
  391.       IF (IDEUX.NE.2) CALL ERREUR(21)
  392.       IF (IERR.NE.0) RETURN
  393.       IF (IPT2.LISOUS(/1).NE.2) GOTO 3151
  394.       IPT5=IPT2.LISOUS(1)
  395.       IPT6=IPT2.LISOUS(2)
  396.       SEGACT IPT5,IPT6
  397.       IF (IPT5.ITYPEL.NE.IPT3.ITYPEL) GOTO 3151
  398.       IF (IPT6.ITYPEL.NE.IPT4.ITYPEL) GOTO 3151
  399.       IF (IPT5.NUM(/2).NE.IPT3.NUM(/2)) CALL ERREUR(21)
  400.       IF (IPT6.NUM(/2).NE.IPT4.NUM(/2)) CALL ERREUR(21)
  401.       IF (IPT5.NUM(/1).NE.IPT3.NUM(/1)) CALL ERREUR(21)
  402.       IF (IPT6.NUM(/1).NE.IPT4.NUM(/1)) CALL ERREUR(21)
  403.       IF (IERR.NE.0) RETURN
  404.       GOTO 1021
  405.  3151 SEGDES IPT5,IPT6
  406.  3152 IF (IPT2.LISREF(/1).LT.2) CALL ERREUR(21)
  407.       IF (IERR.NE.0) RETURN
  408.       IAUX=IPT2.LISREF(1)
  409.       ISVOL2=IPT2
  410.       SEGDES IPT2
  411.       IPT2=IAUX
  412.       SEGACT IPT2
  413.       GOTO 3150
  414. c ... les deux maillages doivent être simples ...
  415.  1020 IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 3152
  416.       IF (IDEUX.NE.1) GOTO 3152
  417.       IF (IPT2.NUM(/1).NE.IPT1.NUM(/1)) CALL ERREUR(21)
  418.       IF (IPT2.NUM(/2).NE.IPT1.NUM(/2)) CALL ERREUR(21)
  419.  1021 CONTINUE
  420. c ... calcul des densités et coordonnées moyennes de la deuxième surface ...
  421.       NPR=0
  422.       XG2=0.
  423.       YG2=0.
  424.       ZG2=0.
  425.       XL2=0.
  426.       YL2=0.
  427.       ZL2=0.
  428.       DEN2=0.
  429.       IPT7=IPT2
  430.       M1031=2
  431.       IF (IDEUX.EQ.1) M1031=1
  432.       DO 1031 M=1,M1031
  433.          IF (M1031.NE.1) IPT7=IPT2.LISOUS(M)
  434.          DO 4 I=1,IPT7.NUM(/1)
  435.             DO 41 J=1,IPT7.NUM(/2)
  436.                IREF=(IPT7.NUM(I,J)-1)*IDIMP1
  437.                DEN2=DEN2+XCOOR(IREF+4)
  438.                IF (XCOOR(IREF+1).GT.XG2) XG2 = XCOOR(IREF+1)
  439.                IF (XCOOR(IREF+2).GT.YG2) YG2 = XCOOR(IREF+2)
  440.                IF (XCOOR(IREF+3).GT.ZG2) ZG2 = XCOOR(IREF+3)
  441.                IF (XCOOR(IREF+1).LT.XL2) XL2 = XCOOR(IREF+1)
  442.                IF (XCOOR(IREF+2).LT.YL2) YL2 = XCOOR(IREF+2)
  443.                IF (XCOOR(IREF+3).LT.ZL2) ZL2 = XCOOR(IREF+3)
  444.   41        CONTINUE
  445.    4     CONTINUE
  446.          NPR=NPR+IPT7.NUM(/1)*IPT7.NUM(/2)
  447.  1031 CONTINUE
  448.       DEN2=DEN2/NPR
  449.       DLONG=((XG2-XG1)**2+(YG2-YG1)**2+(ZG2-ZG1)**2+
  450.      &       (XL2-XL1)**2+(YL2-YL1)**2+(ZL2-ZL1)**2)/6.
  451.       DLONG=SQRT(DLONG)
  452.       GOTO 6
  453.  
  454. c ... cas 'ROTA' ...
  455.    3  CONTINUE
  456.       XV1=XG-XPT1
  457.       YV1=YG-YPT1
  458.       ZV1=ZG-ZPT1
  459.       PV1=XV1*XVEC+YV1*YVEC+ZV1*ZVEC
  460.       XV1=XV1-PV1*XVEC
  461.       YV1=YV1-PV1*YVEC
  462.       ZV1=ZV1-PV1*ZVEC
  463.       RAY=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1)
  464.       XV1=XV1/RAY
  465.       YV1=YV1/RAY
  466.       ZV1=ZV1/RAY
  467.       XV2=YVEC*ZV1-ZVEC*YV1
  468.       YV2=ZVEC*XV1-XVEC*ZV1
  469.       ZV2=XVEC*YV1-YVEC*XV1
  470. C  RAYON MOYEN
  471. C  ANGLE EN RADIANS D'OU LONGUEUR MOYENNE
  472.       DLONG=RAY*ABS(ANGLE)
  473.  
  474. c ... partie commune, recherche du nombre de couches à créér et des densités ...
  475.    6  CONTINUE
  476.       IF (IMPOI.EQ.1) DEN1=DEN1I
  477.       IF (IMPOF.EQ.1) DEN2=DEN2I
  478. C  JE NE VOIS PAS DANS QUELS CAS CA INTERVIENT
  479.       CALL LIRENT(INBR,0,IRETOU)
  480. C     write(6,*) 'volume:DLONG,DEN1I,DEN2I =',DLONG,DEN1I,DEN2I
  481.       IPT3=MELEME
  482.       DENI=DEN1
  483.       DECA=DEN2-DEN1
  484.       DENM = ABS(MAX(DEN1,DEN2))
  485.       if (abs(dlong).lt.10.D0*XZPREC*DENM) dlong=1.d0
  486.       DEN1=DEN1/DLONG
  487.       DEN2=DEN2/DLONG
  488.       IF (MLREEL.NE.0)THEN
  489.         SEGACT,MLREEL
  490.         INBR=PROG(/1)-1
  491.         SEGDES,MLREEL
  492.       ENDIF
  493. C     write(6,*) 'volume:DLONG,DEN1, DEN2, INBR =',IMPOI,DEN1,DEN2,INBR
  494.       CALL DECOUP(INBR,DEN1,DEN2,APROG,NCOUCH,DENI,DECA,DLONG)
  495.       IF (IERR.NE.0) RETURN
  496. C     write(6,*) 'NCOUCH =',NCOUCH
  497.       NX=NCOUCH-1
  498.  
  499.       IF (IIMPI.EQ.1) WRITE(IOIMP,9000) NCOUCH,APROG
  500.  9000 FORMAT(/' COUCHES ',I6,' RAISON ',G12.5)
  501.  
  502. C ... Initialisation du nouveau maillage ...
  503. C  ON FAIT TOUJOURS COMME SI IL N'Y AVAIT QU'UN TYPE D'ELEMENT
  504.       NBSOUS=0
  505. C  MODIF POUR CONSTRUIRE TOUJOURS LE POURTOUR
  506.       NBREF=3
  507.       IF (IPT1.LISREF(/1).NE.0) NBREF=3
  508.       NBNN=2*NBNNEL+(INCR-1)*(NBNNEL/2)
  509.       NBNNV=NBNN
  510.       NBASE=NBELEM
  511.       NBELEM=NBELEM*NCOUCH
  512.       SEGINI IPT7
  513.       IF (NBNNV.EQ.6 ) IPT7.ITYPEL=16
  514.       IF (NBNNV.EQ.15) IPT7.ITYPEL=17
  515.       IF (NBNNV.EQ.8 ) IPT7.ITYPEL=14
  516.       IF (NBNNV.EQ.20) IPT7.ITYPEL=15
  517.       IPT7.LISREF(1)=IPT1
  518. C*c ... Mise à 0 des connectivités ...
  519. C*      DO 1040 I=1,NBNN
  520. C*         DO 1040 J=1,NBELEM
  521. C*            IPT7.NUM(I,J)=0
  522. C* 1040 CONTINUE
  523.       SEGINI TABPAR
  524. c ... si ce n'est ni TRAN ni ROTA on saute ...
  525.       IF (ICLE.EQ.3) GOTO 16
  526.       IF (ICLE.EQ.2) GOTO 10
  527. c ... cas TRAN, on fait appel à l'opérateur PLUS ...
  528.       IOPTG=1
  529.       CALL ECROBJ('POINT ',IVEC)
  530.       CALL ECROBJ('MAILLAGE',IPT1)
  531.       CALL PROPER(IOPTG)
  532.       GOTO 11
  533. c ... cas ROTA, on fait appel à l'opérateur TOURner ...
  534.   10  XXX=ANGLI
  535.       CALL ECRREE(XXX)
  536.       CALL ECROBJ('POINT ',IP2)
  537.       CALL ECROBJ('POINT ',IP1)
  538.       CALL ECROBJ('MAILLAGE',IPT1)
  539.       CALL TOURNE
  540.   11  CONTINUE
  541. c ... puis on lit le second MAILLAGE ...
  542.       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  543.       IF (IERR.NE.0) RETURN
  544. C  IPT3 ET IPT4 ONT ETE DESCENDU DANS L'OPERATION AINSI QUE MCOORD/REFPO
  545.   16  SEGACT IPT1,IPT2,MCOORD
  546.       IPT4=IPT2
  547. c ... si le 1er maillage est simple on suppose que le deuxième le sera aussi ...
  548.       IF (IDEUX.EQ.1) GOTO 15
  549.       IPT5=IPT2.LISOUS(1)
  550.       IPT6=IPT2.LISOUS(2)
  551.       SEGACT IPT5,IPT6
  552. C  ON FAIT COMME POUR LE BAS
  553.       NBSOUS=0
  554.       NBREF=0
  555.       NBNN=4*INCR
  556. c ... qui ont les mêmes nombres d'éléments que les sous-maillages du premier ...
  557.       NBELEM=NBELE3+NBELE4
  558.       SEGINI MELEME
  559. c ... et que l'on transvase succesivement dans une nouvelle entité (MELEME) ...
  560. C*      DO 1110 J=1,NBELEM
  561. C*         DO 1110 I=1,NBNN
  562. C*            NUM(I,J)=0
  563. C* 1110 CONTINUE
  564. c ... d'abord IPT5 ...
  565.       DO 1111 J=1,NBELE3
  566.          ICOLOR(J)=IPT5.ICOLOR(J)
  567.          DO 11111 I=1,IPT5.NUM(/1)
  568.             NUM(I,J)=IPT5.NUM(I,J)
  569. 11111    CONTINUE
  570.  1111 CONTINUE
  571. c ... puis IPT6 ...
  572.       DO 1112 J=1,NBELE4
  573.          K=J+NBELE3
  574.          ICOLOR(K)=IPT6.ICOLOR(J)
  575.          DO 11121 I=1,IPT6.NUM(/1)
  576.             NUM(I,K)=IPT6.NUM(I,J)
  577. 11121    CONTINUE
  578.  1112 CONTINUE
  579.       SEGDES IPT5,IPT6,IPT2
  580. c ... et qui remplace le maillage lu ...
  581.       IPT4=MELEME
  582.   15  IPT7.LISREF(2)=IPT2
  583.  
  584. C  CONSTRUCTION DE LA TABLE DES POINTS EFFECTIFS
  585. c ... IPT3 = maillage (parfois bâtard) contenant toutes les facettes
  586. c     de la surface initiale (?) ...
  587.       NBELEC=IPT3.NUM(/2)
  588. c ... ICPR(ligne = nombre maxi de noeuds / facette, colonne = nb facettes) ...
  589.       SEGINI ICPR
  590. C*c ... mise à 0 ...
  591. C*      DO 12 I=1,NBNNEL
  592. C*         DO 12 J=1,NBELEC
  593. C*  12        ICPR(I,J)=0
  594.  
  595. c ... on parcourt les 2 maillages ...
  596.       DO 13 J=1,NBELEC
  597.          DO 131 I=1,NBNNEL
  598. c       ... IR = N° du noeud (ou 0) du 1er ...
  599.             IR=IPT3.NUM(I,J)
  600. c       ... IR2 = N° du noeud (ou 0) equivalent du 2nd ...
  601.             IR2=IPT4.NUM(I,J)
  602. c       ... si le 1er est absent ...
  603.             IF (IR.EQ.0) GOTO 1120
  604. c       ... sinon, si son equivalent est nul => kk !!!!!!! ...
  605.             IF (IR2.EQ.0) GOTO 8833
  606.             I1=IR
  607.             I1R2=IR2
  608. c       ... si ce n'est pas le 1er élément ...
  609.             IF (J.EQ.1) GOTO 131
  610. c       ... on va vérifier que l'equivalence est la même pour
  611. c           tous les éléments précédents ...
  612.             JM1=J-1
  613.             DO 14 JJ=1,JM1
  614.                DO 141 II=1,NBNNEL
  615.                   IR=IPT3.NUM(II,JJ)
  616.                   IR2=IPT4.NUM(II,JJ)
  617.                   IF (IR.EQ.0) GOTO 141
  618.                   IF (IR.NE.I1) GOTO 8834
  619.                   IF (IR2.NE.I1R2) GOTO 8833
  620. c             ... on met dans ICPR(n° noeud,n° élt) la valeur de II+(JJ-1)*8
  621. c                 tq. le noeud II de l'élt JJ de IPT3 est le même que
  622. c                 le noeud I de l'élt J (toutefois JJ < J donc aucun noeud ne
  623. c                 pointe sur lui même) ...
  624.                   ICPR(I,J)=II+(JJ-1)*8
  625.                   GOTO 131
  626.  8834             IF (IR2.EQ.I1R2) GOTO 8833
  627.  141           CONTINUE
  628.   14        CONTINUE
  629.             GOTO 131
  630. c       ... si le 1er est absent (suite), on met ICPR correspondant à -1 ...
  631.  1120       ICPR(I,J)=-1
  632. c       ... si son equivalent est non nul => kk !!!!!!! ...
  633.             IF (IR2.NE.0) GOTO 8833
  634.  131     CONTINUE
  635.   13  CONTINUE
  636.       GOTO 8835
  637.  8833 CONTINUE
  638.  
  639. C  LES TOPOLOGIES SONT DIFFERENTES
  640.       SEGSUP ICPR
  641.       CALL ERREUR(21)
  642.       RETURN
  643.  8835 CONTINUE
  644.  
  645. C  ON FABRIQUE POUR LE MOMENT DES CUBES A 8 OU 20 NOEUDS ET DES PRISMES
  646. C  A 6 OU 15 NOEUDS
  647. C  D'ABORD LES POINTS DU BAS
  648.  
  649.       DIN=DEN1
  650.       DO 20 I=1,NBELEC
  651. c    ... On commence par donner la couleur ...
  652. c    ... Si c'est TRAN ou ROTA ce sera celle du maillage d'origine ...
  653.          IF (ICLE.NE.3) THEN
  654.             IPT7.ICOLOR(I)=IPT3.ICOLOR(I)
  655. c    ... sinon, une <<moyenne>> au sens de ITABM ...
  656.          ELSE
  657.             ICOLI=IPT3.ICOLOR(I)
  658. C       ... CORRECTION PROBLEME SAUSSAIS 29 NOVEMBRE 1985
  659.             ICOLJ=IPT4.ICOLOR(I)
  660.             IPT7.ICOLOR(I)=ITABM(ICOLI,ICOLJ)
  661.          ENDIF
  662. c    ... Puis on commence par transvaser les connectivités de la surface initiale ...
  663.          DO 201 J=1,NBNNEL
  664.             IR=IPT3.NUM(J,I)
  665.             IF (IR.EQ.0) GOTO 201
  666.             IPT7.NUM(J,I)=IR
  667.  201     CONTINUE
  668.   20  CONTINUE
  669.  
  670.       IBASE=nbpts
  671.  
  672. C  ON FABRIQUE ENSUITE LES COUCHES
  673. C  ON AFFECTE SEULEMENT LES NUMEROS DE NOEUDS
  674.  
  675. c ... IDIF = nombre de noeuds placés <<entre>> les couches ...
  676.       IDIF=(INCR-1)*(NBNNEL/2)
  677.       NX=NCOUCH-1
  678.       DO 21 ICOUCH=1,NCOUCH
  679.          DIN=DIN*APROG
  680.          TABPAR(ICOUCH)=DIN
  681.          IF (ICOUCH.EQ.NCOUCH) GOTO 21
  682.          JBASE=(ICOUCH-1)*NBELEC
  683.          IF (INCR.EQ.1) GOTO 2000
  684.  
  685. C  ON FABRIQUE D'ABORD LA COUCHE INTERMEDIAIRE
  686.  
  687.          DO 2001 J=1,NBELEC
  688.             IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
  689.             DO 20011 IA=1,(NBNNEL/2)
  690.                I=2*IA-1
  691.                IF (ICPR(I,J).EQ.-1) GOTO 20011
  692.                IF (ICPR(I,J).NE.0) GOTO 2002
  693.                IBASE=IBASE+1
  694.                IPT7.NUM(IA+NBNNEL,J+JBASE)=IBASE
  695.                GOTO 20011
  696.  2002          IAUX=ICPR(I,J)
  697.                JJ=(IAUX-1)/8+1
  698.                II=IAUX-8*JJ+8
  699.                IIA=(II+1)/2
  700.                IPT7.NUM(IA+NBNNEL,J+JBASE)=IPT7.NUM(IIA+NBNNEL,JJ+JBASE)
  701. 20011       CONTINUE
  702.  2001    CONTINUE
  703.  2000    CONTINUE
  704.          DO 22 J=1,NBELEC
  705.             IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
  706.             DO 221 I=1,NBNNEL
  707.                IF (ICPR(I,J).EQ.-1) GOTO 221
  708.                IF (ICPR(I,J).NE.0) GOTO 23
  709.                IBASE=IBASE+1
  710.                IPT7.NUM(I,J+JBASE+NBELEC)=IBASE
  711.                IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IBASE
  712.                GOTO 221
  713.   23           IAUX=ICPR(I,J)
  714.                JJ=(IAUX-1)/8+1
  715.                II=IAUX-8*JJ+8
  716.                IPT7.NUM(I,J+JBASE+NBELEC)=IPT7.NUM(II,JJ+JBASE+NBELEC)
  717.                IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IPT7.NUM(II+NBNNEL+IDIF,
  718.      &                                                  JJ+JBASE)
  719.  221        CONTINUE
  720.   22     CONTINUE
  721.   21  CONTINUE
  722.       IF (MLREEL.NE.0)THEN
  723.          SEGACT,MLREEL
  724.          DPROG=PROG(NCOUCH+1)-PROG(1)
  725.          DO 12345 ICOUCH=1,NCOUCH
  726.             TABPAR(ICOUCH)=(PROG(ICOUCH+1)-PROG(ICOUCH))/DPROG
  727. 12345    CONTINUE
  728.          SEGDES,MLREEL
  729.       ENDIF
  730.   25  CONTINUE
  731. C  ON FAIT LES POINTS DU HAUT ET EVENTUELLEMENT LA COUCHE INTERMEDIAIRE
  732. C  PRECEDENTE
  733.       JBASE=NBELEC*NX
  734.       IF (INCR.EQ.1) GOTO 2003
  735.       DO 2004 J=1,NBELEC
  736.       IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
  737.       DO 20041 IA=1,(NBNNEL/2)
  738.       I=2*IA-1
  739.       IF (ICPR(I,J).EQ.-1) GOTO 20041
  740.       IF (ICPR(I,J).NE.0) GOTO 2005
  741.       IBASE=IBASE+1
  742.       IPT7.NUM(IA+NBNNEL,J+JBASE)=IBASE
  743.       GOTO 20041
  744.  2005 IAUX=ICPR(I,J)
  745.       JJ=(IAUX-1)/8+1
  746.       II=IAUX-8*JJ+8
  747.       IIA=(II+1)/2
  748.       IPT7.NUM(IA+NBNNEL,J+JBASE)=IPT7.NUM(IIA+NBNNEL,JJ+JBASE)
  749. 20041    CONTINUE
  750.  2004 CONTINUE
  751.  2003 CONTINUE
  752.       DO 30 J=1,NBELEC
  753.       IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
  754.       DO 301 I=1,NBNNEL
  755.       IF (ICPR(I,J).EQ.-1) GOTO 301
  756.       IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IPT4.NUM(I,J)
  757.  301  CONTINUE
  758.   30  CONTINUE
  759.       DPAR=0.
  760. C  CREATION DES POINTS
  761.       IADR=nbpts
  762.       NBPTS=IADR+NCOUCH*INCR*NBELEC*NBNNEL
  763.       SEGADJ MCOORD
  764.       DO 61 ICOUCH=1,NCOUCH
  765.       DIN=TABPAR(ICOUCH)
  766.       DO 610 IC=1,INCR
  767.       IC1=INCR+1-IC
  768.       DPAR=DPAR+DIN/INCR
  769.       UMDPAR=1.-DPAR
  770.       DEN610=DENI+DECA*DPAR
  771.       IF (ICOUCH.EQ.NCOUCH.AND.IC.EQ.INCR) GOTO 610
  772.       IF (ICLE.NE.2) GOTO 63
  773.         ANG=DPAR*DLONG/RAY
  774.         SI=SIN(ANG)
  775.         CO=COS(ANG)
  776.   63  CONTINUE
  777.       DO 620 J=1,NBELEC
  778.       DO 62 I=1,NBNNEL,IC1
  779.       IF (ICPR(I,J).NE.0) GOTO 62
  780.       IREF=4*IPT3.NUM(I,J)-4
  781. C     write(6,*) 'XCOOR(/1)=',XCOOR(/1)
  782. C     write(6,*) 'IADR,IREF,DPAR,XDIS=',IADR,IREF,DPAR,XDIS
  783.       GOTO (67,64,66),ICLE
  784.   67  XCOOR(IADR*IDIMP1+1)=XCOOR(IREF+1)+DPAR*XDIS
  785.       XCOOR(IADR*IDIMP1+2)=XCOOR(IREF+2)+DPAR*YDIS
  786.       XCOOR(IADR*IDIMP1+3)=XCOOR(IREF+3)+DPAR*ZDIS
  787.       GOTO 65
  788.   66  IREF2=4*IPT4.NUM(I,J)-4
  789.       XCOOR(IADR*IDIMP1+1)=UMDPAR*XCOOR(IREF+1)+DPAR*XCOOR(IREF2+1)
  790.       XCOOR(IADR*IDIMP1+2)=UMDPAR*XCOOR(IREF+2)+DPAR*XCOOR(IREF2+2)
  791.       XCOOR(IADR*IDIMP1+3)=UMDPAR*XCOOR(IREF+3)+DPAR*XCOOR(IREF2+3)
  792.       GOTO 65
  793.   64  X1=XCOOR(IREF+1)-XPT1
  794.       Y1=XCOOR(IREF+2)-YPT1
  795.       Z1=XCOOR(IREF+3)-ZPT1
  796.       XV=X1*XV1+Y1*YV1+Z1*ZV1
  797.       YV=X1*XV2+Y1*YV2+Z1*ZV2
  798.       ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  799.       XD=XV*CO-YV*SI
  800.       YD=XV*SI+YV*CO
  801.       ZD=ZV
  802.       XCOOR(IADR*IDIMP1+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  803.       XCOOR(IADR*IDIMP1+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  804.       XCOOR(IADR*IDIMP1+3)=XD*ZV1+YD*ZV2+ZD*ZVEC+ZPT1
  805.       GOTO 65
  806.   65  CONTINUE
  807.       XCOOR((IADR+1)*IDIMP1)=DEN610
  808.       IADR=IADR+1
  809.   62  CONTINUE
  810.  620  CONTINUE
  811.  610  CONTINUE
  812.   61  CONTINUE
  813.       NBPTS=IADR
  814.       SEGADJ MCOORD
  815.   60  CONTINUE
  816. C  C'EST FINI
  817. C  IL RESTE DANS LE CAS OU ON A DES CUBES ET DES PRISMES A LES SEPARER
  818. C  ET A SUPPRIMER LES SEGMENTS SUPPLEMENTAIRES DE TRAVAIL
  819. C  D'ABORD FAIRE LE POURTOUR A PARTIR DU CONTOUR
  820.       IF (IPT7.LISREF(/1).EQ.2) GOTO 3000
  821.       CALL ECROBJ('MAILLAGE',IPT1)
  822.       CALL ECRCHA('NOID')
  823.       CALL PRCONT
  824.       CALL LIROBJ('MAILLAGE',IPT5,1,IRETOU)
  825.       IF (IERR.NE.0) GOTO 3000
  826. C  IPT5 LE CONTOUR  IPT6 SERA LE POURTOUR
  827.       SEGACT IPT5
  828.       NBASE=IPT5.NUM(/2)
  829.       NBNN=INCR*4
  830.       NBELEM=NBASE*NCOUCH
  831.       NBSOUS=0
  832.       NBREF=0
  833.       SEGINI IPT6
  834.       IPT6.ITYPEL=6+2*INCR
  835.       SEGACT IPT3
  836.       DO 3001 IEL=1,NBASE
  837.       DO 30011 IP=1,INCR+1
  838.       INP=IPT5.NUM(IP,IEL)
  839.       DO 3003 IELS=1,NBELEC
  840.       DO 30031 IPS=1,NBNNEL
  841.       IPSP=IPT3.NUM(IPS,IELS)
  842.       IF (IPSP.EQ.0) GOTO 30031
  843.       IF (IPSP.EQ.INP) GOTO 3002
  844. 30031 CONTINUE
  845.  3003 CONTINUE
  846.       GOTO 3000
  847.  3002 CONTINUE
  848.       DO 3004 IC=1,NCOUCH
  849.       IBASE=(IC-1)*NBASE
  850.       JBASE=(IC-1)*NBELEC
  851. C  PTS DU BAS
  852.       IPT6.NUM(IP,IEL+IBASE)=IPT7.NUM(IPS,IELS+JBASE)
  853. C  PTS DU HAUT
  854.       IPT6.NUM(NBNN+2-INCR-IP,IEL+IBASE)=
  855.      #                 IPT7.NUM(IPS+NBNNEL+IDIF,IELS+JBASE)
  856. C  EVENTUELLEMENT PTS MILIEUX
  857.       IF (INCR.EQ.1.OR.IP.EQ.2) GOTO 3004
  858.       IPT6.NUM(10-2*IP,IEL+IBASE)=IPT7.NUM((IPS+1)/2+NBNNEL,IELS+JBASE)
  859.  3004 CONTINUE
  860. 30011    CONTINUE
  861.  3001 CONTINUE
  862.       DO 3005 I=1,NCOUCH
  863.         DO 30051 J=1,NBASE
  864.               IPT6.ICOLOR(J+(I-1)*NBASE)=IPT5.ICOLOR(J)
  865. 30051   CONTINUE
  866.  3005 CONTINUE
  867.       SEGDES IPT5,IPT6
  868.       IPT7.LISREF(3)=IPT6
  869.  3000 CONTINUE
  870. *  cas ou on a saute la creation de ipt7.lisref(3) avec le goto 3000
  871.       if (ipt7.lisref(ipt7.lisref(/1)).eq.0) then
  872.        nbnn=ipt7.num(/1)
  873.        nbelem=ipt7.num(/2)
  874.        nbsous=ipt7.lisous(/1)
  875.        nbref=ipt7.lisref(/1)-1
  876.        segadj ipt7
  877.       endif
  878.       IF (IDEUX.EQ.1) GOTO 1500
  879.       SEGSUP IPT3,IPT4
  880.       MELEME=IPT7
  881.       NBSOUS=2
  882.       NBREF=LISREF(/1)
  883.       NBNN=0
  884.       NBELEM=0
  885.       SEGINI IPT7
  886.       IPT7.LISREF(1)=LISREF(1)
  887.       IPT7.LISREF(2)=LISREF(2)
  888.       IF (NBREF.EQ.3) IPT7.LISREF(3)=LISREF(3)
  889.       NBSOUS=0
  890.       NBREF=0
  891.       NBNN=6
  892.       IF (INCR.EQ.2) NBNN=15
  893.       NBELEM=NBTRI*NCOUCH
  894.       SEGINI IPT3
  895.       IPT3.ITYPEL=16
  896.       IF (INCR.EQ.2) IPT3.ITYPEL=17
  897.       IPT7.LISOUS(1)=IPT3
  898.       NBNN=8
  899.       IF (INCR.EQ.2) NBNN=20
  900.       NBELEM=NBQUA*NCOUCH
  901.       SEGINI IPT4
  902.       IPT4.ITYPEL=14
  903.       IF (INCR.EQ.2) IPT4.ITYPEL=15
  904.       IPT7.LISOUS(2)=IPT4
  905.       IT=0
  906.       IQ=0
  907.       DO 1501 J=1,NUM(/2)
  908.       IF (NUM(NBNNV,J).EQ.0) GOTO 1502
  909. C  C'EST UN CUBE
  910.       IQ=IQ+1
  911.       IPT4.ICOLOR(IQ)=ICOLOR(J)
  912.       DO 1503 K=1,IPT4.NUM(/1)
  913.       IPT4.NUM(K,IQ)=NUM(K,J)
  914.  1503 CONTINUE
  915.       GOTO 1501
  916.  1502 IT=IT+1
  917.       IPT3.ICOLOR(IT)=ICOLOR(J)
  918. C  C'EST UN PRISME
  919.       IF (INCR.EQ.2) GOTO 2020
  920.       IPT3.NUM(1,IT)=NUM(1,J)
  921.       IPT3.NUM(2,IT)=NUM(2,J)
  922.       IPT3.NUM(3,IT)=NUM(3,J)
  923.       IPT3.NUM(4,IT)=NUM(NBNNEL+1,J)
  924.       IPT3.NUM(5,IT)=NUM(NBNNEL+2,J)
  925.       IPT3.NUM(6,IT)=NUM(NBNNEL+3,J)
  926.       GOTO 1501
  927.  2020 CONTINUE
  928.       DO 2021 L=1,6
  929.       IPT3.NUM(L,IT)=NUM(L,J)
  930.  2021 CONTINUE
  931.       IPT3.NUM(7,IT)=NUM(NBNNEL+1,J)
  932.       IPT3.NUM(8,IT)=NUM(NBNNEL+2,J)
  933.       IPT3.NUM(9,IT)=NUM(NBNNEL+3,J)
  934.       DO 2022 L=1,6
  935.       IPT3.NUM(L+9,IT)=NUM(NBNNEL+IDIF+L,J)
  936.  2022 CONTINUE
  937.  1501 CONTINUE
  938.       SEGDES IPT3,IPT4
  939.       SEGSUP MELEME
  940.  1500 SEGDES IPT1,IPT2
  941.       SEGSUP ICPR,TABPAR
  942.       IF (ISVOL1.EQ.0) GOTO 3200
  943.       IPT8=ISVOL1
  944.       SEGACT IPT8
  945.       ltelq=.false.
  946.       CALL FUSE(IPT8,IPT7,IRET,ltelq)
  947.       SEGDES IPT7,IPT8
  948.       IPT7=IRET
  949.  3200 CONTINUE
  950.       IF (ISVOL2.EQ.0) GOTO 3201
  951.       IPT8=ISVOL2
  952.       SEGACT IPT8
  953.       ltelq=.false.
  954.       CALL FUSE(IPT7,IPT8,IRET,ltelq)
  955.       SEGDES IPT7,IPT8
  956.       IPT7=IRET
  957.  3201 CONTINUE
  958.       SEGDES IPT7
  959.       CALL ECROBJ('MAILLAGE',IPT7)
  960.       RETURN
  961.  
  962.  4400 CONTINUE
  963.       mchpoi=0
  964.       epai=0.d0
  965.       Call  LIRREE(EPAI,0,iretou)
  966.       if(iretou.eq.0) call lirobj('CHPOINT ' , MCHPOI,0,iretch)
  967.       if(iretou+iretch.eq.0) then
  968. C  MAILLAGE AUTOMATIQUE DE VOLUME
  969.       IF (IVERB.EQ.1) write(IOIMP,*) ' appel a demete'
  970.       CALL DEMETE(IPT1)
  971.       IF (IERR.NE.0) RETURN
  972.       IPT7=IPT1
  973.       GOTO 3201
  974.       else
  975.         call lirobj('POINT   ',ip1,1,iretpt)
  976.         if(ierr.ne.0) return
  977.         call volshb(ipt1,epai,mchpoi,ip1,ipt7)
  978.         if(ierr.ne.0) return
  979.         go to 3201
  980.       endif
  981.       END
  982.  
  983.  
  984.  
  985.  
  986.  
  987.  
  988.  
  989.  
  990.  

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