Télécharger la plaquette Cast3M


fr en

Télécharger volos.eso

Retour à la liste

Numérotation des lignes : 

volos

  1. C VOLOS     SOURCE    JK148537  24/08/05    21:15:03     11980          
  2.  
  3.       SUBROUTINE VOLOS(IPT1,IPT2,N1,N2,DEN1,DEN2,NBCOU)
  4. C     **********************************************************************
  5. C     INTERFACE CASTEM 2000
  6. C
  7. C     GEO1 = SURF1 VOLOS SURF2 PO1 PO2 (N1) ('DINI' DENS1) ('DFIN' DENS2) ;
  8. C
  9. C
  10. C     OBJET :
  11. C     _______
  12. C
  13. C         L'OPERATEUR VOLOS RACCORDE DES MAILLAGES SURFACIQUES QUI ONT
  14. C     DES STRUCTURES DE GRILLES.
  15. C
  16. C
  17. C     DATE : 24.10.96
  18. C     ______
  19. C
  20. C     AUTEURS : O. STAB
  21. C     _________
  22. C
  23. C
  24. C     **********************************************************************
  25.       IMPLICIT INTEGER(I-N)
  26.       IMPLICIT REAL*8 (A-H,O-Z)
  27. C
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC SMELEME
  32. -INC SMCOORD
  33. -INC CCGEOME
  34.       SEGMENT ITRAVX
  35.        INTEGER ITVL (ITOTAI)
  36.       ENDSEGMENT
  37.       SEGMENT RTRAVX
  38.        REAL*8 RTVL (ITOTAR)
  39.       ENDSEGMENT
  40.       SEGMENT ICPR (nbpts)
  41.       SEGMENT ICPP (nbpts)
  42. C
  43.       INTEGER  NITMAX,NRTMAX,IERRDS
  44. C     --- VARIABLES INTERNES ---
  45.       INTEGER NBN,NBE,IDIMC,NBNMAX,IDE,NBPMAX,NBEMAX,ITRNOE
  46.       INTEGER ITRVMX,ICOORD,NBCOOR
  47.       INTEGER ITRNO1,ITRNO2,NBE1,NBE2,NBN1,NBN2
  48.       INTEGER I,J,IERCOD
  49. C
  50.       INTEGER NBNL(4),ICOIN(8),NBLGMX,NBLGMN,NBCOMX,NBCOMN
  51.       INTEGER NITNEC,NBRANG,NBCOUC
  52.       INTEGER IORDR,ICODE1,ICODE2,ICODE5,INDSO(20),ISENS
  53.       INTEGER ITRNO3,NBNO3,NBE3,IDE3,NBN3
  54.       INTEGER ITRNO4,NBNO4,NBE4,IDE4,NBN4
  55.       INTEGER ITRNO5,NBNO5,NBE5,IDE5
  56.       INTEGER ITRTRI,IDEE,NBNMX,NBCMX,NOETRI,ITRAV,NITMX2,NOEMAX
  57.       REAL*8  DEN1,DEN2
  58. C
  59. c      DO 1111 I=1,50
  60. c        WRITE (6,*) I,NOMS(I)
  61. c      1111 CONTINUE
  62. c      WRITE(6,*) 'NBCOU = ',NBCOU
  63. C
  64.       IERRDS = 0
  65.       CALL DSINIT
  66.       CALL ELINIT(0)
  67. C        ============================
  68. C     --- 1.LECTURE DES DENSITES ---
  69. C        ============================
  70.       IF(DEN1.LT.0)THEN
  71.       CALL ERREUR(17)
  72.       GOTO 9999
  73.       ENDIF
  74.       IF(DEN2.LT.0)THEN
  75.       CALL ERREUR(17)
  76.       GOTO 9999
  77.       ENDIF
  78. *
  79. *     ============================
  80. *     LECTURE DES NUMEROS DES POINTS
  81. *     ============================
  82. *
  83.       segact mcoord*mod
  84.       NBANC  = nbpts
  85.       IF((N1.LE.0).OR.(N1.GT.NBANC ))THEN
  86. C        WRITE (6,*)'ERREUR IL FAUT UN POINT DE DEPART'
  87.         CALL ERREUR(824)
  88.       ENDIF
  89.       IF((N2.LE.0).OR.(N2.GT.NBANC ))THEN
  90. C        WRITE (6,*)'ERREUR IL FAUT UN POINT D ARRIVE'
  91.         CALL ERREUR(828)
  92.       ENDIF
  93. C        ============================
  94. C     --- 1.LECTURE DES MAILLAGE 2D ---
  95. C        ============================
  96. C
  97. *
  98. *     LECTURE DU MAILLAGE 1
  99. *     ===========================
  100.       IF(IDIM.NE.3) CALL ERREUR(820)
  101. C      CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  102. c      WRITE(6,*) ' LECTURE MAILLAGE ' ,IPT1
  103. C      IF(IERR.NE.0) RETURN
  104.       SEGACT IPT1
  105.       IF( IPT1.LISOUS(/1).NE.0) CALL ERREUR(816)
  106. *      WRITE(6,*) 'ITYPEL =' , IPT1.ITYPEL
  107. C     8 = QUA4, 10 = QUA8
  108.       IORDR = 1
  109.       IF( IPT1.ITYPEL.EQ.10 )IORDR = 2
  110.       IF((IPT1.ITYPEL.NE.8).AND.(IPT1.ITYPEL.NE.10))CALL ERREUR(823)
  111. *       WRITE(6,*) ' IERR ' ,IERR
  112. *       WRITE(6,*) ' MCOORD ', MCOORD
  113.       IF(IERR.NE.0) THEN
  114.           SEGDES IPT1
  115.           RETURN
  116.       ENDIF
  117. *
  118. *
  119.       NBE1 = IPT1.NUM(/2)
  120. *
  121. *     LECTURE DU MAILLAGE 2
  122. *     ===========================
  123.       IF(IDIM.NE.3) CALL ERREUR(820)
  124. C      CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  125. c      WRITE(6,*) ' LECTURE MAILLAGE ' ,IPT2
  126.       IF(IERR.NE.0) RETURN
  127.       SEGACT IPT2
  128.       IF( IPT2.LISOUS(/1).NE.0) CALL ERREUR(818)
  129. *      WRITE(6,*) 'ITYPEL =' , IPT2.ITYPEL
  130.       IF( IPT2.ITYPEL.NE.IPT1.ITYPEL)CALL ERREUR(829)
  131. *       WRITE(6,*) ' IERR ' ,IERR
  132. *       WRITE(6,*) ' MCOORD ', MCOORD
  133.       IF(IERR.NE.0) THEN
  134.           SEGDES IPT2
  135.           RETURN
  136.       ENDIF
  137. C
  138.       NBE2   = IPT2.NUM(/2)
  139.       NBNMAX = IPT1.NUM(/1)
  140.       NBANC  = nbpts
  141. C
  142.       NPOMAX = MAX(50000, NBANC)
  143.       itravx = 0
  144.    10 CONTINUE
  145.       if (itravx.ne.0) then
  146.        segsup,itravx,icpr,icpp,rtravx
  147.        npomax = 10 * npomax
  148.       endif
  149.       NITMAX = MAX((7*NPOMAX), 4*(NBE1+NBE2+NPOMAX))
  150.       IF(IORDR.EQ.2)THEN
  151.         NITMAX = NITMAX + 8*(NBE1+NBE2+npomax)
  152.       ENDIF
  153.       NRTMAX = 3 * NPOMAX
  154. *
  155. *     TRANSFERT DES MAILLAGE
  156. *     =====================================
  157.       NBNMAX = IPT1.NUM(/1)
  158.       NBCMAX = 4
  159.       IDE    = 2
  160.       IDIMC  = IDIM
  161. *
  162. *  REMPLISSAGE DU TABLEAU DE CONNEXION
  163. *  ===================================
  164.       ITOTAI= NITMAX
  165. *      WRITE(6,*) ' ITOTAI ' , ITOTAI
  166.       SEGINI ITRAVX
  167.       SEGINI,ICPR,ICPP
  168.       ITOTAR = NRTMAX
  169.       SEGINI RTRAVX
  170. C
  171. C     --- TRANSFERT MAILLAGE --- RTVL, ITVL
  172. C
  173.       ICOORD = 1
  174.       ITRNO1 = 1
  175.       INO    = 0
  176.       DO  I=1,NBE1
  177.       DO  J=1,NBNMAX
  178.       IA = IPT1.NUM(J,I)
  179.       IF( ICPR(IA).EQ.0 ) THEN
  180.         INO      = INO+1
  181.         ICPR(IA) = INO
  182.         ICPP(INO)= IA
  183.         DO   K=1,IDIMC
  184.          RTVL((INO-1)*IDIMC+K+ICOORD-1)=
  185.      >           XCOOR((IA-1)*(IDIM+1)+K)
  186.         ENDDO
  187.       ENDIF
  188.       ITVL((I-1)*NBNMAX +J+ITRNO1-1) = ICPR(IA)
  189.       enddo
  190.       enddo
  191.       NBN1 = INO
  192. C
  193. C      SEGDES IPT1
  194. C
  195. C     --- TRANSFERT MAILLAGE --- RTVL, ITVL
  196. C
  197.       ITRNO2 = NBE1*NBNMAX+1
  198. c      write (6,*)'itrno2=',itrno2,nbnmax
  199. c      segact,ipt2
  200.       DO  I=1,NBE2
  201.       DO  J=1,NBNMAX
  202.       IA = IPT2.NUM(J,I)
  203.       IF( ICPR(IA).EQ.0 ) THEN
  204.         INO      = INO+1
  205.         ICPR(IA) = INO
  206.         ICPP(INO)= IA
  207.         DO   K=1,IDIMC
  208.          RTVL((INO-1)*IDIMC+K+ICOORD-1)=
  209.      >           XCOOR((IA-1)*(IDIM+1)+K)
  210.         ENDDO
  211.       ENDIF
  212.       ITVL((I-1)*NBNMAX +J+ITRNO2-1) = ICPR(IA)
  213.       enddo
  214.       enddo
  215. C
  216.       NBN2 = INO - NBN1
  217. C
  218. C      SEGDES IPT2
  219. *
  220. C      WRITE (6,*) 'MAILLAGE LU : '
  221. C      WRITE (6,*) ' NBN1 , NBE1 ',NBN1, NBE1
  222. C      WRITE (6,*) ' NBN2 , NBE2 ',NBN2, NBE2
  223.  
  224.       N1B = ICPR(N1)
  225.       N2B = ICPR(N2)
  226.       NBCOUC = NBCOU
  227. C
  228. C      N2B = NBN1 + 1
  229. C
  230. c      WRITE (6,*) 'MAILLAGE 1 NBE1 = ',NBE1
  231. c      WRITE (6,*) (ITVL(ITRNO1+I-1),I=1,NBE1*4)
  232. c      WRITE (6,*) 'MAILLAGE 2 NBE2 = ',NBE2
  233. c      WRITE (6,*) (ITVL(ITRNO2+I-1),I=1,NBE2*4)
  234. c      WRITE (6,*) 'COORDONNEES NBCOOR = ',NBN1+NBN2
  235. c      WRITE (6,*) (RTVL(ICOORD+I-1),I=1,3*(NBN1+NBN2))
  236. c      WRITE (6,*) 'NOEUDS CONNECTE ',N1B,N2B
  237. c      WRITE (6,*) 'NOMBRE DE COUCHES = ',NBCOUC
  238.       IERRDS = 0
  239.       ITRACE = 0
  240. C
  241. C        -------------------------
  242. C     --- PASSAGE AU LINEAIRE    ---
  243. C        -------------------------
  244. C
  245.       IF(IORDR.EQ.2)THEN
  246. c        WRITE(6,*) 'QUADRATIQUE 1'
  247.         ITRNO3 = NBNMAX * (NBE1+NBE2) + 1
  248.         ICODE1 = 10
  249.         ICODE2 = 8
  250.         NBNO3  = 4
  251.         ISENS  = -1
  252.         CALL ELSOVO(ICODE1,INDSO,NBSO,NBNO1,IERRDS)
  253. c        WRITE(6,*) 'INDSO = ',(INDSO(I),I=1,NBSO)
  254.         CALL ELCREE(IDE,ITVL(ITRNO1),NBNMAX,NBE1,
  255.      >            ICODE2,INDSO,ISENS,IDE3,ITVL(ITRNO3),
  256.      >            NBNO3,NBE3,IERRDS)
  257. c        WRITE(6,*) 'NBNO3,IDE3,IERR = ',NBNO3,IDE3,IERR
  258. c        WRITE(6,*)
  259. c     >    ((ITVL((I-1)*NBNO3+J-1+ITRNO3),J=1,NBNO3)
  260. c     >   ,'/',I=1,NBE3)
  261.       IF( IERRDS.NE.0 )THEN
  262.         CALL ESERRO(1,IERRDS,'ESELEC',' APPEL ELCREE')
  263.         GOTO 9999
  264.       ENDIF
  265. C
  266.         ITRNO4 = ITRNO3 + (NBE3 * NBNO3)
  267.         NBNO4  = 4
  268.         CALL ELCREE(IDE,ITVL(ITRNO2),NBNMAX,NBE2,
  269.      >            ICODE2,INDSO,ISENS,IDE4,ITVL(ITRNO4),
  270.      >            NBNO4,NBE4,IERRDS)
  271. c        WRITE(6,*) 'NBNO4,IDE4,iIERR = ',NBNO4,IDE4,IERR
  272. c        WRITE(6,*)
  273. c     >    ((ITVL((I-1)*NBNO4+J-1+ITRNO4),J=1,NBNO4)
  274. c     >   ,'/',I=1,NBE4)
  275.       IF( IERRDS.NE.0 )THEN
  276.         CALL ESERRO(1,IERRDS,'ESELEC',' APPEL ELCREE')
  277.         GOTO 9999
  278.       ENDIF
  279.  
  280.       ELSE
  281.         ITRNO3 = ITRNO1
  282.         NBE3   = NBE1
  283.         ITRNO4 = ITRNO2
  284.         NBE4   = NBE2
  285.         ICODE1 = 8
  286.         ICODE2 = 8
  287.       ENDIF
  288.       NBN3   = NBN1
  289.       NBN4   = NBN2
  290. C
  291. C        -------------------------
  292. C     --- CALCUL DE LA STRUCTURE  ---
  293. C        -------------------------
  294. C
  295.       NBCOOR = NBN1 + NBN2
  296.       NBEMAX = 0
  297.       ITRNOE = 1
  298.       NBPMAX = 0
  299.       ITRAV  = ITRNO4 + (NBE4*4)
  300.       ITRVMX = NITMAX - ITRAV
  301.       NOSUPR = 0
  302.       raison=0.d0
  303. C
  304.       CALL HEXOS(ITVL(ITRNO3),NBE3,NBN3,ITVL(ITRNO4),NBE4,NBN4,
  305.      >           RTVL(ICOORD),NBCOOR,
  306.      >           N1B,N2B,DEN1,DEN2,NBCOUC,
  307.      >           ITVL(ITRAV),ITRVMX,NOSUPR,
  308.      >           ITVL(ITRNOE),NBE,NBEMAX,NBPMAX,
  309.      >           NBNL,ICOIN,ITRACE,IERCOD,IERRDS,raison)
  310. C
  311. c      IF(IERRDS.NE.0)
  312. c     >WRITE (6,*) 'ERREUR PREMIER APPEL HEXOS',IERRDS
  313. C
  314. C     ---- REPRISE SUR MANQUE DE MEMOIRE ----
  315. C
  316.       IF( IERRDS.EQ.-2)THEN
  317.          IERRDS = 0
  318. C         ITOTAI = 4*(NBE1+NBE2+NBCOOR)
  319. C         SEGADJ ITRAVX
  320.          GOTO 10
  321.       ENDIF
  322. C
  323. C     ---- MESSAGES D'ERREUR ----
  324. C
  325.         IF( IERRDS.EQ.-1)THEN
  326.           IMESS = -IERCOD - 90
  327.           CALL MSHEXO('HEXOS ',IMESS,IERRDS,0,0.0d0,' ')
  328.           SEGSUP ITRAVX,RTRAVX,ICPR,ICPP
  329.           GOTO 9999
  330.         ENDIF
  331. C
  332. C     ---- EVALUATION DE LA PLACE NECESSAIRE ----
  333. C
  334.       NBLGMX = MAX(NBNL(2),NBNL(4))
  335.       NBLGMN = MIN(NBNL(2),NBNL(4))
  336.       NBCOMX = MAX(NBNL(1),NBNL(3))
  337.       NBCOMN = MIN(NBNL(1),NBNL(3))
  338.       NBRANG = NBCOUC+NBLGMX+NBCOMX-NBLGMN-NBCOMN
  339.       NITNEC =  (NBE1+NBE2)*4 + NBCOOR + NBN1 + NBN2 + MAX( 3*NBCOOR,
  340.      >         NBCOOR+ 2*(3+NBRANG)*NBCOMX*NBLGMX)
  341.       IF(IORDR.EQ.2)THEN
  342.         NITNEC = NITNEC + 8*(NBE1+NBE2) +
  343.      >          (20+8+6)*(NBRANG*NBCOMX*NBLGMX)  + 7*NBCOOR
  344.       ENDIF
  345. C
  346.       IF( ITRACE.GT.0 )THEN
  347.          WRITE (6,*) 'PLACE NECESSAIRE POUR LE TRAVAIL  :',NITNEC
  348.          WRITE (6,*) 'NOMBRE MAXIMUM DE LIGNES   : ',NBLGMX
  349.          WRITE (6,*) 'NOMBRE MAXIMUM DE COLONNES : ',NBCOMX
  350.          WRITE (6,*) 'NOMBRE MAXIMUM DE RANGEES  : ',NBRANG
  351.       ENDIF
  352. C
  353.       ITRNOE = ITRNO4 + (NBE4*4)
  354.       NBEMAX = NBRANG*NBCOMX*NBLGMX
  355.       ITRAV  = ITRNOE + 8*NBEMAX
  356.       ITRVMX = NITMAX - ITRAV
  357.       NBPMAX = (NRTMAX - (NBCOOR*3)) / 3
  358.       NOSUPR = 0
  359. C
  360. C     ---- REPRISE SUR MANQUE DE MEMOIRE ----
  361. C
  362.       IF( (ITRVMX.LT.NITNEC).OR.
  363.      >    (NBPMAX.LT.((NBRANG+1)*(NBCOMX+1)*(NBLGMX+1))) )THEN
  364.          IERRDS = -2
  365. C         WRITE (6,*) 'PLACE NECESSAIRE (ENTIERS): ',
  366. C     >                (NITNEC+8*NBEMAX)
  367. C         WRITE (6,*) 'PLACE NECESSAIRE (REELS) : ',
  368. C     >                ((NBRANG+1)*(NBCOMX+1)*(NBLGMX+1))
  369.          IERDS = 0
  370. C         ITOTAI = 4*(NBE1+NBE2) + (NITNEC+8*NBEMAX)
  371. C         SEGADJ ITRAVX
  372. C         ITOTAR = (NBN1+NBN2)*3 + ((NBRANG+1)*(NBCOMX+1)*(NBLGMX+1))
  373. C         SEGADJ RTRAVX
  374.          GOTO 10
  375.       ENDIF
  376. C
  377.       CALL HEXOS(ITVL(ITRNO3),NBE3,NBN3,ITVL(ITRNO4),NBE4,NBN4,
  378.      >           RTVL(ICOORD),NBCOOR,
  379.      >           N1B,N2B,DEN1,DEN2,NBCOUC,
  380.      >           ITVL(ITRAV),ITRVMX,NOSUPR,
  381.      >           ITVL(ITRNOE),NBE,NBEMAX,NBPMAX,
  382.      >           NBNL,ICOIN,ITRACE,IERCOD,IERRDS,raison)
  383. C
  384. C
  385. C     ---- MESSAGES D'ERREUR ----
  386. C
  387.       IF( IERRDS.EQ.-1)THEN
  388.         IMESS = -IERCOD - 90
  389.         CALL MSHEXO('HEXOS ',IMESS,IERRDS,0,0.0d0,' ')
  390.         SEGSUP ITRAVX,RTRAVX,ICPR,ICPP
  391.         GOTO 9999
  392.       ENDIF
  393. c      IF( IERRDS.EQ.-2)THEN
  394. c         WRITE (6,*) 'MANQUE DE PLACE : ERREUR ANORMALE'
  395. c      ENDIF
  396. C
  397. C        -------------------------
  398. C     --- PASSAGE AU QUADRATIQUE ---
  399. C        -------------------------
  400. C
  401.       IF(IORDR.EQ.2)THEN
  402.         IDEE   = 3
  403.         NBNMX5  = 8
  404.         NBCMX5  = 6
  405.         ITRTRI = ITRNOE + (NBE*NBNMX5)
  406.         NOETRI = ITRTRI + (NBE*NBCMX5)
  407.         ITRAV  = NOETRI + NBCOOR
  408.         NITMX2 = NITMAX - ITRAV
  409. c        WRITE(6,*) 'NITMX2 = ',NITMX2
  410.         NOEMAX = NBCOOR
  411.         CALL SMACRE(IDEE,ITVL(ITRNOE),NBE,NBCOOR,
  412.      >            ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),
  413.      >            NBCMX5,ITVL(NOETRI),NOEMAX,
  414.      >            ITVL(ITRAV),NITMX2,IERRDS)
  415.         IF( IERRDS.NE.0 )THEN
  416.           CALL ESERRO(1,IERRDS,'VOLOS',' APPEL SMACRE')
  417.           GOTO 9999
  418.         ENDIF
  419. C
  420. C     --- INDICE DES SOMMETS ---------------------
  421. C
  422.         ICODE5 = 15
  423.         CALL ELSOVO(ICODE5,INDSO,NBSO5,NBNO5,IERRDS)
  424. c        WRITE(6,*) 'NBNO5 (20) = ',NBNO5
  425. C
  426. C     ---- ALLOCATION DE LA MEMOIRE --------------
  427. C
  428.         ITRNO5 = ITRAV
  429.         ITRAV  = ITRNO5 + (NBE * NBNO5)
  430.         NITMX2 = NITMAX - ITRAV
  431. C
  432. C     ---- CREATION DU MAILLAGE AVEC DES TROUS ---
  433. C
  434.         ISENS = 1
  435.         CALL ELCREE(IDEE,ITVL(ITRNOE),NBNMX5,NBE,
  436.      >            ICODE5,INDSO,ISENS,IDE5,ITVL(ITRNO5),
  437.      >            NBNO5,NBE5,IERRDS)
  438.         IF( IERRDS.NE.0 )THEN
  439.           CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELCREE')
  440.           GOTO 9999
  441.         ENDIF
  442. C
  443. C     ---- TRANSFERT DES NOEUDS MILIEU --------------
  444. C
  445. c      WRITE(6,*) 'AVANT TRANSFERT '
  446. c      WRITE(6,*)
  447. c     >    ((ITVL((I-1)*NBNO5+J-1+ITRNO5),J=1,NBNO5)
  448. c     >   ,'/',I=1,NBE5)
  449.       CALL ELTRNO(ICODE1,IDE1,ITVL(ITRNO1),NBNMAX,NBE1,
  450.      >            ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),
  451.      >            NBCMX5,ITVL(NOETRI),NOEMAX,
  452.      >            ITVL(ITRAV),NITMX2,
  453.      >            ICODE5,IDE5,ITVL(ITRNO5),NBNO5,NBE5,
  454.      >            IERRDS)
  455.       IF( IERRDS.NE.0 )THEN
  456.         CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELTRNO (1)')
  457.         GOTO 9999
  458.       ENDIF
  459.       CALL ELTRNO(ICODE1,IDE2,ITVL(ITRNO2),NBNMAX,NBE2,
  460.      >            ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),
  461.      >            NBCMX5,ITVL(NOETRI),NOEMAX,
  462.      >            ITVL(ITRAV),NITMX2,
  463.      >            ICODE5,IDE5,ITVL(ITRNO5),NBNO5,NBE5,
  464.      >            IERRDS)
  465. C
  466.       IF( IERRDS.NE.0 )THEN
  467. c        WRITE(6,*) 'LE MAILLAGE A TRANSFERER '
  468. c        WRITE(6,*)
  469. c     >    ((ITVL((I-1)*NBNMAX+J-1+ITRNO2),J=1,NBNMAX)
  470. c     >   ,'/',I=1,NBE2)
  471. c        WRITE(6,*) 'LE MAILLAGE TOPOLOGIQUE '
  472. c        WRITE(6,*)
  473. c     >    ((ITVL((I-1)*NBNMX5+J-1+ITRNOE),J=1,NBNMX5)
  474. c     >   ,'/',I=1,NBE5)
  475. C
  476.         CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELTRNO (2)')
  477.         GOTO 9999
  478.       ENDIF
  479. C
  480. c      WRITE(6,*) 'APRES TRANSFERT '
  481. c      WRITE(6,*)
  482. c     >    ((ITVL((I-1)*NBNO5+J-1+ITRNO5),J=1,NBNO5)
  483. c     >   ,'/',I=1,NBE5)
  484. C
  485. C
  486. C     ---- CALCUL DES NOEUDS MILIEU --------------
  487. C
  488. C
  489.       CALL ELCCNO(ICODE5,IDE5,ITVL(ITRNO5),NBNO5,NBE5,
  490.      >        ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),NBCMX5,
  491.      >            ITVL(ITRAV),NITMX2,
  492.      >            RTVL(ICOORD),IDIMC,NBCOOR,NBPMAX,IERRDS)
  493.       IF( IERRDS.NE.0 )THEN
  494.         CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELCCNO')
  495.         GOTO 9999
  496.       ENDIF
  497. c      WRITE(6,*) 'APRES AJOUT NOEUDS '
  498. c      WRITE(6,*)
  499. c     >    ((ITVL((I-1)*NBNO5+J-1+ITRNO5),J=1,NBNO5)
  500. c     >   ,'/',I=1,NBE5)
  501.       ELSE
  502. C        -------------------------
  503. C     --- ON RESTE EN LINEAIRE   ---
  504. C        -------------------------
  505.         ITRNO5 = ITRNOE
  506.         ICODE5 = 14
  507.         NBNO5  = 8
  508.         NBE5   = NBE
  509.       ENDIF
  510. C
  511. *
  512. *   REMPLISSAGE NOUVEL OBJET MAILLAGE ET TABLEAU DES COORDONNEES
  513. *   ============================================================
  514. C
  515.   40  CONTINUE
  516. c      WRITE (6,*) '==== ON SORT ===='
  517. C
  518. C     ---- TRANSFERT DES NOUVEAUX NOEUDS ----
  519. C         ===============================
  520. *
  521. c      WRITE (6,*) 'ECRITURE DES NOEUDS = ',NBCOOR - INO
  522.       NBPTS = NBANC + NBCOOR - INO
  523. c      WRITE(6,*) ' MCOORD NBCOOR INO ', MCOORD,NBCOOR,INO,NBANC
  524.       SEGADJ MCOORD
  525.       DO 7781 I=1,NBCOOR-INO
  526.       XCOOR((NBANC +I-1)*(IDIM+1)+1) = RTVL((INO+I-1)*IDIMC+1)
  527.       XCOOR((NBANC +I-1)*(IDIM+1)+2) = RTVL((INO+I-1)*IDIMC+2)
  528.       XCOOR((NBANC +I-1)*(IDIM+1)+3) = RTVL((INO+I-1)*IDIMC+3)
  529.       XCOOR((NBANC +I-1)*(IDIM+1)+4) = DENSIT
  530.  7781 CONTINUE
  531. C
  532. C     ---- TRANSFERT DES ELEMENTS ----
  533. C         ========================
  534. c      WRITE (6,*) 'ECRITURE DES ELEMENTS = ',NBE5
  535. c      WRITE (6,*) (ITVL(ITRNO5+I-1),I=1,NBE5*NBNO5)
  536.       NBNN   = NBNO5
  537.       NBREF  = 0
  538.       NBSOUS = 0
  539.       NBELEM = NBE5
  540.       SEGINI IPT3
  541. C     14 = CUB8, 15 = CU20
  542.       IPT3.ITYPEL = ICODE5
  543.       DO 7782 I=1,NBE5
  544.        DO 7783 J=1,NBNO5
  545.        IA=ITVL((I-1)*NBNO5 +J-1+ITRNO5)
  546. C
  547. C      ON TESTE SI LE NOEUD EXISTE DEJA POUR RETROUVER LES NUMEROS CASTEM
  548. C
  549.       IF ( IA .LE.INO) THEN
  550.         IB = ICPP(IA)
  551.       ELSE
  552.         IB = IA -INO +NBANC
  553.       ENDIF
  554.       IPT3.NUM(J,I)=IB
  555.  7783 CONTINUE
  556.       IPT3.ICOLOR(I) = IDCOUL
  557.  7782 CONTINUE
  558. C
  559. C     --- FIN ET ECRITURE ---
  560. C        =================
  561. c      WRITE (6,*) 'ECRITURE'
  562.       CALL ECROBJ('MAILLAGE',IPT3)
  563. c      WRITE (6,*) 'DESACTIVATION'
  564.       SEGDES, IPT3,ipt1,ipt2
  565.       SEGSUP ITRAVX,RTRAVX,ICPR,ICPP
  566. *      CALL ECROBJ('MAILLAGE',IPT3)
  567. C
  568. C
  569.  9999 END
  570.  
  571.  
  572.  
  573.  
  574.  
  575.  
  576.  
  577.  
  578.  
  579.  
  580.  
  581.  
  582.  
  583.  

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