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

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