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/16    21:15:05     12126          
  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.       XL=0.
  355.       YL=0.
  356.       ZL=0.
  357.       DO 5 I=1,NBNN
  358.          DO 51 J=1,NBELEM
  359.             IR=NUM(I,J)
  360.             IF (IR.EQ.0) GOTO 51
  361.             IREF=(IR-1)*IDIMP1
  362.             NPR=NPR+1
  363.             DEN1=DEN1+XCOOR(IREF+4)
  364.             IF (XCOOR(IREF+1).GT.XG) XG = XCOOR(IREF+1)
  365.             IF (XCOOR(IREF+2).GT.YG) YG = XCOOR(IREF+2)
  366.             IF (XCOOR(IREF+3).GT.ZG) ZG = XCOOR(IREF+3)
  367.             IF (XCOOR(IREF+1).LT.XL) XL = XCOOR(IREF+1)
  368.             IF (XCOOR(IREF+2).LT.YL) YL = XCOOR(IREF+2)
  369.             IF (XCOOR(IREF+3).LT.ZL) ZL = XCOOR(IREF+3)
  370.   51     CONTINUE
  371.    5  CONTINUE
  372.       DEN1=DEN1/NPR
  373.  
  374. c ... cas 'TRAN' => GOTO 6 ...
  375.       IF (ICLE.EQ.1) GOTO 6
  376. c ... cas 'ROTA' => GOTO 3 ...
  377.       IF (ICLE.EQ.2) GOTO 3
  378. c ... cas du volume entre deux surfaces ...
  379. C  COMPATIBILITE DU 2EME OBJET ET RECHERCHE DU CENTRE DE GRAVITE
  380.       SEGACT IPT2
  381.  3150 IF (IPT2.LISOUS(/1).EQ.0) GOTO 1020
  382.       IF (IDEUX.NE.2) CALL ERREUR(21)
  383.       IF (IERR.NE.0) RETURN
  384.       IF (IPT2.LISOUS(/1).NE.2) GOTO 3151
  385.       IPT5=IPT2.LISOUS(1)
  386.       IPT6=IPT2.LISOUS(2)
  387.       SEGACT IPT5,IPT6
  388.       IF (IPT5.ITYPEL.NE.IPT3.ITYPEL) GOTO 3151
  389.       IF (IPT6.ITYPEL.NE.IPT4.ITYPEL) GOTO 3151
  390.       IF (IPT5.NUM(/2).NE.IPT3.NUM(/2)) CALL ERREUR(21)
  391.       IF (IPT6.NUM(/2).NE.IPT4.NUM(/2)) CALL ERREUR(21)
  392.       IF (IPT5.NUM(/1).NE.IPT3.NUM(/1)) CALL ERREUR(21)
  393.       IF (IPT6.NUM(/1).NE.IPT4.NUM(/1)) CALL ERREUR(21)
  394.       IF (IERR.NE.0) RETURN
  395.       GOTO 1021
  396.  3151 SEGDES IPT5,IPT6
  397.  3152 IF (IPT2.LISREF(/1).LT.2) CALL ERREUR(21)
  398.       IF (IERR.NE.0) RETURN
  399.       IAUX=IPT2.LISREF(1)
  400.       ISVOL2=IPT2
  401.       SEGDES IPT2
  402.       IPT2=IAUX
  403.       SEGACT IPT2
  404.       GOTO 3150
  405. c ... les deux maillages doivent être simples ...
  406.  1020 IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 3152
  407.       IF (IDEUX.NE.1) GOTO 3152
  408.       IF (IPT2.NUM(/1).NE.IPT1.NUM(/1)) CALL ERREUR(21)
  409.       IF (IPT2.NUM(/2).NE.IPT1.NUM(/2)) CALL ERREUR(21)
  410.  1021 CONTINUE
  411. c ... calcul des densités et coordonnées moyennes de la deuxième surface ...
  412.       NPR=0
  413.       XG2=0.
  414.       YG2=0.
  415.       ZG2=0.
  416.       XL2=0.
  417.       YL2=0.
  418.       ZL2=0.
  419.       DEN2=0.
  420.       IPT7=IPT2
  421.       M1031=2
  422.       IF (IDEUX.EQ.1) M1031=1
  423.       DO 1031 M=1,M1031
  424.          IF (M1031.NE.1) IPT7=IPT2.LISOUS(M)
  425.          DO 4 I=1,IPT7.NUM(/1)
  426.             DO 41 J=1,IPT7.NUM(/2)
  427.                IREF=(IPT7.NUM(I,J)-1)*IDIMP1
  428.                DEN2=DEN2+XCOOR(IREF+4)
  429.                IF (XCOOR(IREF+1).GT.XG2) XG2 = XCOOR(IREF+1)
  430.                IF (XCOOR(IREF+2).GT.YG2) YG2 = XCOOR(IREF+2)
  431.                IF (XCOOR(IREF+3).GT.ZG2) ZG2 = XCOOR(IREF+3)
  432.                IF (XCOOR(IREF+1).LT.XL2) XL2 = XCOOR(IREF+1)
  433.                IF (XCOOR(IREF+2).LT.YL2) YL2 = XCOOR(IREF+2)
  434.                IF (XCOOR(IREF+3).LT.ZL2) ZL2 = XCOOR(IREF+3)
  435.   41        CONTINUE
  436.    4     CONTINUE
  437.          NPR=NPR+IPT7.NUM(/1)*IPT7.NUM(/2)
  438.  1031 CONTINUE
  439.       DEN2=DEN2/NPR
  440.       DLONG=SQRT((XG2-XG)**2+(YG2-YG)**2+(ZG2-ZG)**2+
  441.      &           (XL2-XL)**2+(YL2-YL)**2+(ZL2-ZL)**2)/6.**0.5
  442.       GOTO 6
  443.  
  444. c ... cas 'ROTA' ...
  445.    3  CONTINUE
  446.       XV1=XG-XPT1
  447.       YV1=YG-YPT1
  448.       ZV1=ZG-ZPT1
  449.       PV1=XV1*XVEC+YV1*YVEC+ZV1*ZVEC
  450.       XV1=XV1-PV1*XVEC
  451.       YV1=YV1-PV1*YVEC
  452.       ZV1=ZV1-PV1*ZVEC
  453.       RAY=SQRT(XV1*XV1+YV1*YV1+ZV1*ZV1)
  454.       XV1=XV1/RAY
  455.       YV1=YV1/RAY
  456.       ZV1=ZV1/RAY
  457.       XV2=YVEC*ZV1-ZVEC*YV1
  458.       YV2=ZVEC*XV1-XVEC*ZV1
  459.       ZV2=XVEC*YV1-YVEC*XV1
  460. C  RAYON MOYEN
  461. C  ANGLE EN RADIANS D'OU LONGUEUR MOYENNE
  462.       DLONG=RAY*ABS(ANGLE)
  463.  
  464. c ... partie commune, recherche du nombre de couches à créér et des densités ...
  465.    6  CONTINUE
  466.       IF (IMPOI.EQ.1) DEN1=DEN1I
  467.       IF (IMPOF.EQ.1) DEN2=DEN2I
  468. C  JE NE VOIS PAS DANS QUELS CAS CA INTERVIENT
  469.       CALL LIRENT(INBR,0,IRETOU)
  470. C     write(6,*) 'volume:DLONG,DEN1I,DEN2I =',DLONG,DEN1I,DEN2I
  471.       IPT3=MELEME
  472.       DENI=DEN1
  473.       DECA=DEN2-DEN1
  474.       DENM = ABS(MAX(DEN1,DEN2))
  475.       if (abs(dlong).lt.10.D0*XZPREC*DENM) dlong=1.d0
  476.       DEN1=DEN1/DLONG
  477.       DEN2=DEN2/DLONG
  478.       IF (MLREEL.NE.0)THEN
  479.         SEGACT,MLREEL
  480.         INBR=PROG(/1)-1
  481.         SEGDES,MLREEL
  482.       ENDIF
  483. C     write(6,*) 'volume:DLONG,DEN1, DEN2, INBR =',IMPOI,DEN1,DEN2,INBR
  484.       CALL DECOUP(INBR,DEN1,DEN2,APROG,NCOUCH,DENI,DECA,DLONG)
  485.       IF (IERR.NE.0) RETURN
  486. C     write(6,*) 'NCOUCH =',NCOUCH
  487.       NX=NCOUCH-1
  488.  
  489.       IF (IIMPI.EQ.1) WRITE(IOIMP,9000) NCOUCH,APROG
  490.  9000 FORMAT(/' COUCHES ',I6,' RAISON ',G12.5)
  491.  
  492. C ... Initialisation du nouveau maillage ...
  493. C  ON FAIT TOUJOURS COMME SI IL N'Y AVAIT QU'UN TYPE D'ELEMENT
  494.       NBSOUS=0
  495. C  MODIF POUR CONSTRUIRE TOUJOURS LE POURTOUR
  496.       NBREF=3
  497.       IF (IPT1.LISREF(/1).NE.0) NBREF=3
  498.       NBNN=2*NBNNEL+(INCR-1)*(NBNNEL/2)
  499.       NBNNV=NBNN
  500.       NBASE=NBELEM
  501.       NBELEM=NBELEM*NCOUCH
  502.       SEGINI IPT7
  503.       IF (NBNNV.EQ.6 ) IPT7.ITYPEL=16
  504.       IF (NBNNV.EQ.15) IPT7.ITYPEL=17
  505.       IF (NBNNV.EQ.8 ) IPT7.ITYPEL=14
  506.       IF (NBNNV.EQ.20) IPT7.ITYPEL=15
  507.       IPT7.LISREF(1)=IPT1
  508. C*c ... Mise à 0 des connectivités ...
  509. C*      DO 1040 I=1,NBNN
  510. C*         DO 1040 J=1,NBELEM
  511. C*            IPT7.NUM(I,J)=0
  512. C* 1040 CONTINUE
  513.       SEGINI TABPAR
  514. c ... si ce n'est ni TRAN ni ROTA on saute ...
  515.       IF (ICLE.EQ.3) GOTO 16
  516.       IF (ICLE.EQ.2) GOTO 10
  517. c ... cas TRAN, on fait appel à l'opérateur PLUS ...
  518.       IOPTG=1
  519.       CALL ECROBJ('POINT ',IVEC)
  520.       CALL ECROBJ('MAILLAGE',IPT1)
  521.       CALL PROPER(IOPTG)
  522.       GOTO 11
  523. c ... cas ROTA, on fait appel à l'opérateur TOURner ...
  524.   10  XXX=ANGLI
  525.       CALL ECRREE(XXX)
  526.       CALL ECROBJ('POINT ',IP2)
  527.       CALL ECROBJ('POINT ',IP1)
  528.       CALL ECROBJ('MAILLAGE',IPT1)
  529.       CALL TOURNE
  530.   11  CONTINUE
  531. c ... puis on lit le second MAILLAGE ...
  532.       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  533.       IF (IERR.NE.0) RETURN
  534. C  IPT3 ET IPT4 ONT ETE DESCENDU DANS L'OPERATION AINSI QUE MCOORD/REFPO
  535.   16  SEGACT IPT1,IPT2,MCOORD
  536.       IPT4=IPT2
  537. c ... si le 1er maillage est simple on suppose que le deuxième le sera aussi ...
  538.       IF (IDEUX.EQ.1) GOTO 15
  539.       IPT5=IPT2.LISOUS(1)
  540.       IPT6=IPT2.LISOUS(2)
  541.       SEGACT IPT5,IPT6
  542. C  ON FAIT COMME POUR LE BAS
  543.       NBSOUS=0
  544.       NBREF=0
  545.       NBNN=4*INCR
  546. c ... qui ont les mêmes nombres d'éléments que les sous-maillages du premier ...
  547.       NBELEM=NBELE3+NBELE4
  548.       SEGINI MELEME
  549. c ... et que l'on transvase succesivement dans une nouvelle entité (MELEME) ...
  550. C*      DO 1110 J=1,NBELEM
  551. C*         DO 1110 I=1,NBNN
  552. C*            NUM(I,J)=0
  553. C* 1110 CONTINUE
  554. c ... d'abord IPT5 ...
  555.       DO 1111 J=1,NBELE3
  556.          ICOLOR(J)=IPT5.ICOLOR(J)
  557.          DO 11111 I=1,IPT5.NUM(/1)
  558.             NUM(I,J)=IPT5.NUM(I,J)
  559. 11111    CONTINUE
  560.  1111 CONTINUE
  561. c ... puis IPT6 ...
  562.       DO 1112 J=1,NBELE4
  563.          K=J+NBELE3
  564.          ICOLOR(K)=IPT6.ICOLOR(J)
  565.          DO 11121 I=1,IPT6.NUM(/1)
  566.             NUM(I,K)=IPT6.NUM(I,J)
  567. 11121    CONTINUE
  568.  1112 CONTINUE
  569.       SEGDES IPT5,IPT6,IPT2
  570. c ... et qui remplace le maillage lu ...
  571.       IPT4=MELEME
  572.   15  IPT7.LISREF(2)=IPT2
  573.  
  574. C  CONSTRUCTION DE LA TABLE DES POINTS EFFECTIFS
  575. c ... IPT3 = maillage (parfois bâtard) contenant toutes les facettes
  576. c     de la surface initiale (?) ...
  577.       NBELEC=IPT3.NUM(/2)
  578. c ... ICPR(ligne = nombre maxi de noeuds / facette, colonne = nb facettes) ...
  579.       SEGINI ICPR
  580. C*c ... mise à 0 ...
  581. C*      DO 12 I=1,NBNNEL
  582. C*         DO 12 J=1,NBELEC
  583. C*  12        ICPR(I,J)=0
  584.  
  585. c ... on parcourt les 2 maillages ...
  586.       DO 13 J=1,NBELEC
  587.          DO 131 I=1,NBNNEL
  588. c       ... IR = N° du noeud (ou 0) du 1er ...
  589.             IR=IPT3.NUM(I,J)
  590. c       ... IR2 = N° du noeud (ou 0) equivalent du 2nd ...
  591.             IR2=IPT4.NUM(I,J)
  592. c       ... si le 1er est absent ...
  593.             IF (IR.EQ.0) GOTO 1120
  594. c       ... sinon, si son equivalent est nul => kk !!!!!!! ...
  595.             IF (IR2.EQ.0) GOTO 8833
  596.             I1=IR
  597.             I1R2=IR2
  598. c       ... si ce n'est pas le 1er élément ...
  599.             IF (J.EQ.1) GOTO 131
  600. c       ... on va vérifier que l'equivalence est la même pour
  601. c           tous les éléments précédents ...
  602.             JM1=J-1
  603.             DO 14 JJ=1,JM1
  604.                DO 141 II=1,NBNNEL
  605.                   IR=IPT3.NUM(II,JJ)
  606.                   IR2=IPT4.NUM(II,JJ)
  607.                   IF (IR.EQ.0) GOTO 141
  608.                   IF (IR.NE.I1) GOTO 8834
  609.                   IF (IR2.NE.I1R2) GOTO 8833
  610. c             ... on met dans ICPR(n° noeud,n° élt) la valeur de II+(JJ-1)*8
  611. c                 tq. le noeud II de l'élt JJ de IPT3 est le même que
  612. c                 le noeud I de l'élt J (toutefois JJ < J donc aucun noeud ne
  613. c                 pointe sur lui même) ...
  614.                   ICPR(I,J)=II+(JJ-1)*8
  615.                   GOTO 131
  616.  8834             IF (IR2.EQ.I1R2) GOTO 8833
  617.  141           CONTINUE
  618.   14        CONTINUE
  619.             GOTO 131
  620. c       ... si le 1er est absent (suite), on met ICPR correspondant à -1 ...
  621.  1120       ICPR(I,J)=-1
  622. c       ... si son equivalent est non nul => kk !!!!!!! ...
  623.             IF (IR2.NE.0) GOTO 8833
  624.  131     CONTINUE
  625.   13  CONTINUE
  626.       GOTO 8835
  627.  8833 CONTINUE
  628.  
  629. C  LES TOPOLOGIES SONT DIFFERENTES
  630.       SEGSUP ICPR
  631.       CALL ERREUR(21)
  632.       RETURN
  633.  8835 CONTINUE
  634.  
  635. C  ON FABRIQUE POUR LE MOMENT DES CUBES A 8 OU 20 NOEUDS ET DES PRISMES
  636. C  A 6 OU 15 NOEUDS
  637. C  D'ABORD LES POINTS DU BAS
  638.  
  639.       DIN=DEN1
  640.       DO 20 I=1,NBELEC
  641. c    ... On commence par donner la couleur ...
  642. c    ... Si c'est TRAN ou ROTA ce sera celle du maillage d'origine ...
  643.          IF (ICLE.NE.3) THEN
  644.             IPT7.ICOLOR(I)=IPT3.ICOLOR(I)
  645. c    ... sinon, une <<moyenne>> au sens de ITABM ...
  646.          ELSE
  647.             ICOLI=IPT3.ICOLOR(I)
  648. C       ... CORRECTION PROBLEME SAUSSAIS 29 NOVEMBRE 1985
  649.             ICOLJ=IPT4.ICOLOR(I)
  650.             IPT7.ICOLOR(I)=ITABM(ICOLI,ICOLJ)
  651.          ENDIF
  652. c    ... Puis on commence par transvaser les connectivités de la surface initiale ...
  653.          DO 201 J=1,NBNNEL
  654.             IR=IPT3.NUM(J,I)
  655.             IF (IR.EQ.0) GOTO 201
  656.             IPT7.NUM(J,I)=IR
  657.  201     CONTINUE
  658.   20  CONTINUE
  659.  
  660.       IBASE=nbpts
  661.  
  662. C  ON FABRIQUE ENSUITE LES COUCHES
  663. C  ON AFFECTE SEULEMENT LES NUMEROS DE NOEUDS
  664.  
  665. c ... IDIF = nombre de noeuds placés <<entre>> les couches ...
  666.       IDIF=(INCR-1)*(NBNNEL/2)
  667.       NX=NCOUCH-1
  668.       DO 21 ICOUCH=1,NCOUCH
  669.          DIN=DIN*APROG
  670.          TABPAR(ICOUCH)=DIN
  671.          IF (ICOUCH.EQ.NCOUCH) GOTO 21
  672.          JBASE=(ICOUCH-1)*NBELEC
  673.          IF (INCR.EQ.1) GOTO 2000
  674.  
  675. C  ON FABRIQUE D'ABORD LA COUCHE INTERMEDIAIRE
  676.  
  677.          DO 2001 J=1,NBELEC
  678.             IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
  679.             DO 20011 IA=1,(NBNNEL/2)
  680.                I=2*IA-1
  681.                IF (ICPR(I,J).EQ.-1) GOTO 20011
  682.                IF (ICPR(I,J).NE.0) GOTO 2002
  683.                IBASE=IBASE+1
  684.                IPT7.NUM(IA+NBNNEL,J+JBASE)=IBASE
  685.                GOTO 20011
  686.  2002          IAUX=ICPR(I,J)
  687.                JJ=(IAUX-1)/8+1
  688.                II=IAUX-8*JJ+8
  689.                IIA=(II+1)/2
  690.                IPT7.NUM(IA+NBNNEL,J+JBASE)=IPT7.NUM(IIA+NBNNEL,JJ+JBASE)
  691. 20011       CONTINUE
  692.  2001    CONTINUE
  693.  2000    CONTINUE
  694.          DO 22 J=1,NBELEC
  695.             IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
  696.             DO 221 I=1,NBNNEL
  697.                IF (ICPR(I,J).EQ.-1) GOTO 221
  698.                IF (ICPR(I,J).NE.0) GOTO 23
  699.                IBASE=IBASE+1
  700.                IPT7.NUM(I,J+JBASE+NBELEC)=IBASE
  701.                IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IBASE
  702.                GOTO 221
  703.   23           IAUX=ICPR(I,J)
  704.                JJ=(IAUX-1)/8+1
  705.                II=IAUX-8*JJ+8
  706.                IPT7.NUM(I,J+JBASE+NBELEC)=IPT7.NUM(II,JJ+JBASE+NBELEC)
  707.                IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IPT7.NUM(II+NBNNEL+IDIF,
  708.      &                                                  JJ+JBASE)
  709.  221        CONTINUE
  710.   22     CONTINUE
  711.   21  CONTINUE
  712.       IF (MLREEL.NE.0)THEN
  713.          SEGACT,MLREEL
  714.          DPROG=PROG(NCOUCH+1)-PROG(1)
  715.          DO 12345 ICOUCH=1,NCOUCH
  716.             TABPAR(ICOUCH)=(PROG(ICOUCH+1)-PROG(ICOUCH))/DPROG
  717. 12345    CONTINUE
  718.          SEGDES,MLREEL
  719.       ENDIF
  720.   25  CONTINUE
  721. C  ON FAIT LES POINTS DU HAUT ET EVENTUELLEMENT LA COUCHE INTERMEDIAIRE
  722. C  PRECEDENTE
  723.       JBASE=NBELEC*NX
  724.       IF (INCR.EQ.1) GOTO 2003
  725.       DO 2004 J=1,NBELEC
  726.       IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
  727.       DO 20041 IA=1,(NBNNEL/2)
  728.       I=2*IA-1
  729.       IF (ICPR(I,J).EQ.-1) GOTO 20041
  730.       IF (ICPR(I,J).NE.0) GOTO 2005
  731.       IBASE=IBASE+1
  732.       IPT7.NUM(IA+NBNNEL,J+JBASE)=IBASE
  733.       GOTO 20041
  734.  2005 IAUX=ICPR(I,J)
  735.       JJ=(IAUX-1)/8+1
  736.       II=IAUX-8*JJ+8
  737.       IIA=(II+1)/2
  738.       IPT7.NUM(IA+NBNNEL,J+JBASE)=IPT7.NUM(IIA+NBNNEL,JJ+JBASE)
  739. 20041    CONTINUE
  740.  2004 CONTINUE
  741.  2003 CONTINUE
  742.       DO 30 J=1,NBELEC
  743.       IPT7.ICOLOR(J+JBASE)=IPT7.ICOLOR(J)
  744.       DO 301 I=1,NBNNEL
  745.       IF (ICPR(I,J).EQ.-1) GOTO 301
  746.       IPT7.NUM(I+NBNNEL+IDIF,J+JBASE)=IPT4.NUM(I,J)
  747.  301  CONTINUE
  748.   30  CONTINUE
  749.       DPAR=0.
  750. C  CREATION DES POINTS
  751.       IADR=nbpts
  752.       NBPTS=IADR+NCOUCH*INCR*NBELEC*NBNNEL
  753.       SEGADJ MCOORD
  754.       DO 61 ICOUCH=1,NCOUCH
  755.       DIN=TABPAR(ICOUCH)
  756.       DO 610 IC=1,INCR
  757.       IC1=INCR+1-IC
  758.       DPAR=DPAR+DIN/INCR
  759.       UMDPAR=1.-DPAR
  760.       DEN610=DENI+DECA*DPAR
  761.       IF (ICOUCH.EQ.NCOUCH.AND.IC.EQ.INCR) GOTO 610
  762.       IF (ICLE.NE.2) GOTO 63
  763.         ANG=DPAR*DLONG/RAY
  764.         SI=SIN(ANG)
  765.         CO=COS(ANG)
  766.   63  CONTINUE
  767.       DO 620 J=1,NBELEC
  768.       DO 62 I=1,NBNNEL,IC1
  769.       IF (ICPR(I,J).NE.0) GOTO 62
  770.       IREF=4*IPT3.NUM(I,J)-4
  771. C     write(6,*) 'XCOOR(/1)=',XCOOR(/1)
  772. C     write(6,*) 'IADR,IREF,DPAR,XDIS=',IADR,IREF,DPAR,XDIS
  773.       GOTO (67,64,66),ICLE
  774.   67  XCOOR(IADR*IDIMP1+1)=XCOOR(IREF+1)+DPAR*XDIS
  775.       XCOOR(IADR*IDIMP1+2)=XCOOR(IREF+2)+DPAR*YDIS
  776.       XCOOR(IADR*IDIMP1+3)=XCOOR(IREF+3)+DPAR*ZDIS
  777.       GOTO 65
  778.   66  IREF2=4*IPT4.NUM(I,J)-4
  779.       XCOOR(IADR*IDIMP1+1)=UMDPAR*XCOOR(IREF+1)+DPAR*XCOOR(IREF2+1)
  780.       XCOOR(IADR*IDIMP1+2)=UMDPAR*XCOOR(IREF+2)+DPAR*XCOOR(IREF2+2)
  781.       XCOOR(IADR*IDIMP1+3)=UMDPAR*XCOOR(IREF+3)+DPAR*XCOOR(IREF2+3)
  782.       GOTO 65
  783.   64  X1=XCOOR(IREF+1)-XPT1
  784.       Y1=XCOOR(IREF+2)-YPT1
  785.       Z1=XCOOR(IREF+3)-ZPT1
  786.       XV=X1*XV1+Y1*YV1+Z1*ZV1
  787.       YV=X1*XV2+Y1*YV2+Z1*ZV2
  788.       ZV=X1*XVEC+Y1*YVEC+Z1*ZVEC
  789.       XD=XV*CO-YV*SI
  790.       YD=XV*SI+YV*CO
  791.       ZD=ZV
  792.       XCOOR(IADR*IDIMP1+1)=XD*XV1+YD*XV2+ZD*XVEC+XPT1
  793.       XCOOR(IADR*IDIMP1+2)=XD*YV1+YD*YV2+ZD*YVEC+YPT1
  794.       XCOOR(IADR*IDIMP1+3)=XD*ZV1+YD*ZV2+ZD*ZVEC+ZPT1
  795.       GOTO 65
  796.   65  CONTINUE
  797.       XCOOR((IADR+1)*IDIMP1)=DEN610
  798.       IADR=IADR+1
  799.   62  CONTINUE
  800.  620  CONTINUE
  801.  610  CONTINUE
  802.   61  CONTINUE
  803.       NBPTS=IADR
  804.       SEGADJ MCOORD
  805.   60  CONTINUE
  806. C  C'EST FINI
  807. C  IL RESTE DANS LE CAS OU ON A DES CUBES ET DES PRISMES A LES SEPARER
  808. C  ET A SUPPRIMER LES SEGMENTS SUPPLEMENTAIRES DE TRAVAIL
  809. C  D'ABORD FAIRE LE POURTOUR A PARTIR DU CONTOUR
  810.       IF (IPT7.LISREF(/1).EQ.2) GOTO 3000
  811.       CALL ECROBJ('MAILLAGE',IPT1)
  812.       CALL ECRCHA('NOID')
  813.       CALL PRCONT
  814.       CALL LIROBJ('MAILLAGE',IPT5,1,IRETOU)
  815.       IF (IERR.NE.0) GOTO 3000
  816. C  IPT5 LE CONTOUR  IPT6 SERA LE POURTOUR
  817.       SEGACT IPT5
  818.       NBASE=IPT5.NUM(/2)
  819.       NBNN=INCR*4
  820.       NBELEM=NBASE*NCOUCH
  821.       NBSOUS=0
  822.       NBREF=0
  823.       SEGINI IPT6
  824.       IPT6.ITYPEL=6+2*INCR
  825.       SEGACT IPT3
  826.       DO 3001 IEL=1,NBASE
  827.       DO 30011 IP=1,INCR+1
  828.       INP=IPT5.NUM(IP,IEL)
  829.       DO 3003 IELS=1,NBELEC
  830.       DO 30031 IPS=1,NBNNEL
  831.       IPSP=IPT3.NUM(IPS,IELS)
  832.       IF (IPSP.EQ.0) GOTO 30031
  833.       IF (IPSP.EQ.INP) GOTO 3002
  834. 30031 CONTINUE
  835.  3003 CONTINUE
  836.       GOTO 3000
  837.  3002 CONTINUE
  838.       DO 3004 IC=1,NCOUCH
  839.       IBASE=(IC-1)*NBASE
  840.       JBASE=(IC-1)*NBELEC
  841. C  PTS DU BAS
  842.       IPT6.NUM(IP,IEL+IBASE)=IPT7.NUM(IPS,IELS+JBASE)
  843. C  PTS DU HAUT
  844.       IPT6.NUM(NBNN+2-INCR-IP,IEL+IBASE)=
  845.      #                 IPT7.NUM(IPS+NBNNEL+IDIF,IELS+JBASE)
  846. C  EVENTUELLEMENT PTS MILIEUX
  847.       IF (INCR.EQ.1.OR.IP.EQ.2) GOTO 3004
  848.       IPT6.NUM(10-2*IP,IEL+IBASE)=IPT7.NUM((IPS+1)/2+NBNNEL,IELS+JBASE)
  849.  3004 CONTINUE
  850. 30011    CONTINUE
  851.  3001 CONTINUE
  852.       DO 3005 I=1,NCOUCH
  853.         DO 30051 J=1,NBASE
  854.               IPT6.ICOLOR(J+(I-1)*NBASE)=IPT5.ICOLOR(J)
  855. 30051   CONTINUE
  856.  3005 CONTINUE
  857.       SEGDES IPT5,IPT6
  858.       IPT7.LISREF(3)=IPT6
  859.  3000 CONTINUE
  860. *  cas ou on a saute la creation de ipt7.lisref(3) avec le goto 3000
  861.       if (ipt7.lisref(ipt7.lisref(/1)).eq.0) then
  862.        nbnn=ipt7.num(/1)
  863.        nbelem=ipt7.num(/2)
  864.        nbsous=ipt7.lisous(/1)
  865.        nbref=ipt7.lisref(/1)-1
  866.        segadj ipt7
  867.       endif
  868.       IF (IDEUX.EQ.1) GOTO 1500
  869.       SEGSUP IPT3,IPT4
  870.       MELEME=IPT7
  871.       NBSOUS=2
  872.       NBREF=LISREF(/1)
  873.       NBNN=0
  874.       NBELEM=0
  875.       SEGINI IPT7
  876.       IPT7.LISREF(1)=LISREF(1)
  877.       IPT7.LISREF(2)=LISREF(2)
  878.       IF (NBREF.EQ.3) IPT7.LISREF(3)=LISREF(3)
  879.       NBSOUS=0
  880.       NBREF=0
  881.       NBNN=6
  882.       IF (INCR.EQ.2) NBNN=15
  883.       NBELEM=NBTRI*NCOUCH
  884.       SEGINI IPT3
  885.       IPT3.ITYPEL=16
  886.       IF (INCR.EQ.2) IPT3.ITYPEL=17
  887.       IPT7.LISOUS(1)=IPT3
  888.       NBNN=8
  889.       IF (INCR.EQ.2) NBNN=20
  890.       NBELEM=NBQUA*NCOUCH
  891.       SEGINI IPT4
  892.       IPT4.ITYPEL=14
  893.       IF (INCR.EQ.2) IPT4.ITYPEL=15
  894.       IPT7.LISOUS(2)=IPT4
  895.       IT=0
  896.       IQ=0
  897.       DO 1501 J=1,NUM(/2)
  898.       IF (NUM(NBNNV,J).EQ.0) GOTO 1502
  899. C  C'EST UN CUBE
  900.       IQ=IQ+1
  901.       IPT4.ICOLOR(IQ)=ICOLOR(J)
  902.       DO 1503 K=1,IPT4.NUM(/1)
  903.       IPT4.NUM(K,IQ)=NUM(K,J)
  904.  1503 CONTINUE
  905.       GOTO 1501
  906.  1502 IT=IT+1
  907.       IPT3.ICOLOR(IT)=ICOLOR(J)
  908. C  C'EST UN PRISME
  909.       IF (INCR.EQ.2) GOTO 2020
  910.       IPT3.NUM(1,IT)=NUM(1,J)
  911.       IPT3.NUM(2,IT)=NUM(2,J)
  912.       IPT3.NUM(3,IT)=NUM(3,J)
  913.       IPT3.NUM(4,IT)=NUM(NBNNEL+1,J)
  914.       IPT3.NUM(5,IT)=NUM(NBNNEL+2,J)
  915.       IPT3.NUM(6,IT)=NUM(NBNNEL+3,J)
  916.       GOTO 1501
  917.  2020 CONTINUE
  918.       DO 2021 L=1,6
  919.       IPT3.NUM(L,IT)=NUM(L,J)
  920.  2021 CONTINUE
  921.       IPT3.NUM(7,IT)=NUM(NBNNEL+1,J)
  922.       IPT3.NUM(8,IT)=NUM(NBNNEL+2,J)
  923.       IPT3.NUM(9,IT)=NUM(NBNNEL+3,J)
  924.       DO 2022 L=1,6
  925.       IPT3.NUM(L+9,IT)=NUM(NBNNEL+IDIF+L,J)
  926.  2022 CONTINUE
  927.  1501 CONTINUE
  928.       SEGDES IPT3,IPT4
  929.       SEGSUP MELEME
  930.  1500 SEGDES IPT1,IPT2
  931.       SEGSUP ICPR,TABPAR
  932.       IF (ISVOL1.EQ.0) GOTO 3200
  933.       IPT8=ISVOL1
  934.       SEGACT IPT8
  935.       ltelq=.false.
  936.       CALL FUSE(IPT8,IPT7,IRET,ltelq)
  937.       SEGDES IPT7,IPT8
  938.       IPT7=IRET
  939.  3200 CONTINUE
  940.       IF (ISVOL2.EQ.0) GOTO 3201
  941.       IPT8=ISVOL2
  942.       SEGACT IPT8
  943.       ltelq=.false.
  944.       CALL FUSE(IPT7,IPT8,IRET,ltelq)
  945.       SEGDES IPT7,IPT8
  946.       IPT7=IRET
  947.  3201 CONTINUE
  948.       SEGDES IPT7
  949.       CALL ECROBJ('MAILLAGE',IPT7)
  950.       RETURN
  951.  
  952.  4400 CONTINUE
  953.       mchpoi=0
  954.       epai=0.d0
  955.       Call  LIRREE(EPAI,0,iretou)
  956.       if(iretou.eq.0) call lirobj('CHPOINT ' , MCHPOI,0,iretch)
  957.       if(iretou+iretch.eq.0) then
  958. C  MAILLAGE AUTOMATIQUE DE VOLUME
  959.       IF (IVERB.EQ.1) write(IOIMP,*) ' appel a demete'
  960.       CALL DEMETE(IPT1)
  961.       IF (IERR.NE.0) RETURN
  962.       IPT7=IPT1
  963.       GOTO 3201
  964.       else
  965.         call lirobj('POINT   ',ip1,1,iretpt)
  966.         if(ierr.ne.0) return
  967.         call volshb(ipt1,epai,mchpoi,ip1,ipt7)
  968.         if(ierr.ne.0) return
  969.         go to 3201
  970.       endif
  971.       END
  972.  
  973.  
  974.  
  975.  
  976.  
  977.  
  978.  
  979.  

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