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    PV        22/04/25    21:15:14     11344          
  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.       NITMAX = MAX((7*NPOMAX), 4*(NBE1+NBE2+NPOMAX))
  144.       IF(IORDR.EQ.2)THEN
  145.         NITMAX = NITMAX + 8*(NBE1+NBE2)
  146.       ENDIF
  147.       NRTMAX = 3 * NPOMAX
  148. *
  149. *     TRANSFERT DES MAILLAGE
  150. *     =====================================
  151.       NBNMAX = IPT1.NUM(/1)
  152.       NBCMAX = 4
  153.       IDE    = 2
  154.       IDIMC  = IDIM
  155. *
  156. *  REMPLISSAGE DU TABLEAU DE CONNEXION
  157. *  ===================================
  158.       ITOTAI= NITMAX
  159. *      WRITE(6,*) ' ITOTAI ' , ITOTAI
  160.       SEGINI ITRAVX
  161.       SEGINI,ICPR,ICPP
  162.       ITOTAR = NRTMAX
  163.       SEGINI RTRAVX
  164. C
  165. C     --- TRANSFERT MAILLAGE --- RTVL, ITVL
  166. C
  167.    10 CONTINUE
  168.       ICOORD = 1
  169.       ITRNO1 = 1
  170.       INO    = 0
  171.       DO 7764 I=1,NBE1
  172.       DO 7764 J=1,NBNMAX
  173.       IA = IPT1.NUM(J,I)
  174.       IF( ICPR(IA).EQ.0 ) THEN
  175.         INO      = INO+1
  176.         ICPR(IA) = INO
  177.         ICPP(INO)= IA
  178.         DO 7763  K=1,IDIMC
  179.          RTVL((INO-1)*IDIMC+K+ICOORD-1)=
  180.      >           XCOOR((IA-1)*(IDIM+1)+K)
  181.  7763   CONTINUE
  182.       ENDIF
  183.       ITVL((I-1)*NBNMAX +J+ITRNO1-1) = ICPR(IA)
  184.  7764 CONTINUE
  185.       NBN1 = INO
  186. C
  187.       SEGDES IPT1
  188. C
  189. C     --- TRANSFERT MAILLAGE --- RTVL, ITVL
  190. C
  191.       ITRNO2 = NBE1*NBNMAX+1
  192.       DO 7766 I=1,NBE2
  193.       DO 7766 J=1,NBNMAX
  194.       IA = IPT2.NUM(J,I)
  195.       IF( ICPR(IA).EQ.0 ) THEN
  196.         INO      = INO+1
  197.         ICPR(IA) = INO
  198.         ICPP(INO)= IA
  199.         DO 7765  K=1,IDIMC
  200.          RTVL((INO-1)*IDIMC+K+ICOORD-1)=
  201.      >           XCOOR((IA-1)*(IDIM+1)+K)
  202.  7765   CONTINUE
  203.       ENDIF
  204.       ITVL((I-1)*NBNMAX +J+ITRNO2-1) = ICPR(IA)
  205.  7766 CONTINUE
  206. C
  207.       NBN2 = INO - NBN1
  208. C
  209.       SEGDES IPT2
  210. *
  211. C      WRITE (6,*) 'MAILLAGE LU : '
  212. C      WRITE (6,*) ' NBN1 , NBE1 ',NBN1, NBE1
  213. C      WRITE (6,*) ' NBN2 , NBE2 ',NBN2, NBE2
  214.  
  215.       N1B = ICPR(N1)
  216.       N2B = ICPR(N2)
  217.       NBCOUC = NBCOU
  218. C
  219. C      N2B = NBN1 + 1
  220. C
  221. c      WRITE (6,*) 'MAILLAGE 1 NBE1 = ',NBE1
  222. c      WRITE (6,*) (ITVL(ITRNO1+I-1),I=1,NBE1*4)
  223. c      WRITE (6,*) 'MAILLAGE 2 NBE2 = ',NBE2
  224. c      WRITE (6,*) (ITVL(ITRNO2+I-1),I=1,NBE2*4)
  225. c      WRITE (6,*) 'COORDONNEES NBCOOR = ',NBN1+NBN2
  226. c      WRITE (6,*) (RTVL(ICOORD+I-1),I=1,3*(NBN1+NBN2))
  227. c      WRITE (6,*) 'NOEUDS CONNECTE ',N1B,N2B
  228. c      WRITE (6,*) 'NOMBRE DE COUCHES = ',NBCOUC
  229.       IERRDS = 0
  230.       ITRACE = 0
  231. C
  232. C        -------------------------
  233. C     --- PASSAGE AU LINEAIRE    ---
  234. C        -------------------------
  235. C
  236.       IF(IORDR.EQ.2)THEN
  237. c        WRITE(6,*) 'QUADRATIQUE 1'
  238.         ITRNO3 = NBNMAX * (NBE1+NBE2) + 1
  239.         ICODE1 = 10
  240.         ICODE2 = 8
  241.         NBNO3  = 4
  242.         ISENS  = -1
  243.         CALL ELSOVO(ICODE1,INDSO,NBSO,NBNO1,IERRDS)
  244. c        WRITE(6,*) 'INDSO = ',(INDSO(I),I=1,NBSO)
  245.         CALL ELCREE(IDE,ITVL(ITRNO1),NBNMAX,NBE1,
  246.      >            ICODE2,INDSO,ISENS,IDE3,ITVL(ITRNO3),
  247.      >            NBNO3,NBE3,IERRDS)
  248. c        WRITE(6,*) 'NBNO3,IDE3,IERR = ',NBNO3,IDE3,IERR
  249. c        WRITE(6,*)
  250. c     >    ((ITVL((I-1)*NBNO3+J-1+ITRNO3),J=1,NBNO3)
  251. c     >   ,'/',I=1,NBE3)
  252.       IF( IERRDS.NE.0 )THEN
  253.         CALL ESERRO(1,IERRDS,'ESELEC',' APPEL ELCREE')
  254.         GOTO 9999
  255.       ENDIF
  256. C
  257.         ITRNO4 = ITRNO3 + (NBE3 * NBNO3)
  258.         NBNO4  = 4
  259.         CALL ELCREE(IDE,ITVL(ITRNO2),NBNMAX,NBE2,
  260.      >            ICODE2,INDSO,ISENS,IDE4,ITVL(ITRNO4),
  261.      >            NBNO4,NBE4,IERRDS)
  262. c        WRITE(6,*) 'NBNO4,IDE4,iIERR = ',NBNO4,IDE4,IERR
  263. c        WRITE(6,*)
  264. c     >    ((ITVL((I-1)*NBNO4+J-1+ITRNO4),J=1,NBNO4)
  265. c     >   ,'/',I=1,NBE4)
  266.       IF( IERRDS.NE.0 )THEN
  267.         CALL ESERRO(1,IERRDS,'ESELEC',' APPEL ELCREE')
  268.         GOTO 9999
  269.       ENDIF
  270.  
  271.       ELSE
  272.         ITRNO3 = ITRNO1
  273.         NBE3   = NBE1
  274.         ITRNO4 = ITRNO2
  275.         NBE4   = NBE2
  276.         ICODE1 = 8
  277.         ICODE2 = 8
  278.       ENDIF
  279.       NBN3   = NBN1
  280.       NBN4   = NBN2
  281. C
  282. C        -------------------------
  283. C     --- CALCUL DE LA STRUCTURE  ---
  284. C        -------------------------
  285. C
  286.       NBCOOR = NBN1 + NBN2
  287.       NBEMAX = 0
  288.       ITRNOE = 1
  289.       NBPMAX = 0
  290.       ITRAV  = ITRNO4 + (NBE4*4)
  291.       ITRVMX = NITMAX - ITRAV
  292.       NOSUPR = 0
  293.       raison=0.d0
  294. C
  295.       CALL HEXOS(ITVL(ITRNO3),NBE3,NBN3,ITVL(ITRNO4),NBE4,NBN4,
  296.      >           RTVL(ICOORD),NBCOOR,
  297.      >           N1B,N2B,DEN1,DEN2,NBCOUC,
  298.      >           ITVL(ITRAV),ITRVMX,NOSUPR,
  299.      >           ITVL(ITRNOE),NBE,NBEMAX,NBPMAX,
  300.      >           NBNL,ICOIN,ITRACE,IERCOD,IERRDS,raison)
  301. C
  302. c      IF(IERRDS.NE.0)
  303. c     >WRITE (6,*) 'ERREUR PREMIER APPEL HEXOS',IERRDS
  304. C
  305. C     ---- REPRISE SUR MANQUE DE MEMOIRE ----
  306. C
  307.       IF( IERRDS.EQ.-2)THEN
  308.          IERRDS = 0
  309.          ITOTAI = 4*(NBE1+NBE2+NBCOOR)
  310.          SEGADJ ITRAVX
  311.          GOTO 10
  312.       ENDIF
  313. C
  314. C     ---- MESSAGES D'ERREUR ----
  315. C
  316.         IF( IERRDS.EQ.-1)THEN
  317.           IMESS = -IERCOD - 90
  318.           CALL MSHEXO('HEXOS ',IMESS,IERRDS,0,0.0d0,' ')
  319.           SEGSUP ITRAVX,RTRAVX,ICPR,ICPP
  320.           GOTO 9999
  321.         ENDIF
  322. C
  323. C     ---- EVALUATION DE LA PLACE NECESSAIRE ----
  324. C
  325.       NBLGMX = MAX(NBNL(2),NBNL(4))
  326.       NBLGMN = MIN(NBNL(2),NBNL(4))
  327.       NBCOMX = MAX(NBNL(1),NBNL(3))
  328.       NBCOMN = MIN(NBNL(1),NBNL(3))
  329.       NBRANG = NBCOUC+NBLGMX+NBCOMX-NBLGMN-NBCOMN
  330.       NITNEC =  (NBE1+NBE2)*4 + NBCOOR + NBN1 + NBN2 + MAX( 3*NBCOOR,
  331.      >         NBCOOR+ 2*(3+NBRANG)*NBCOMX*NBLGMX)
  332.       IF(IORDR.EQ.2)THEN
  333.         NITNEC = NITNEC + 8*(NBE1+NBE2) +
  334.      >          (20+8+6)*(NBRANG*NBCOMX*NBLGMX)  + 7*NBCOOR
  335.       ENDIF
  336. C
  337.       IF( ITRACE.GT.0 )THEN
  338.          WRITE (6,*) 'PLACE NECESSAIRE POUR LE TRAVAIL  :',NITNEC
  339.          WRITE (6,*) 'NOMBRE MAXIMUM DE LIGNES   : ',NBLGMX
  340.          WRITE (6,*) 'NOMBRE MAXIMUM DE COLONNES : ',NBCOMX
  341.          WRITE (6,*) 'NOMBRE MAXIMUM DE RANGEES  : ',NBRANG
  342.       ENDIF
  343. C
  344.       ITRNOE = ITRNO4 + (NBE4*4)
  345.       NBEMAX = NBRANG*NBCOMX*NBLGMX
  346.       ITRAV  = ITRNOE + 8*NBEMAX
  347.       ITRVMX = NITMAX - ITRAV
  348.       NBPMAX = (NRTMAX - (NBCOOR*3)) / 3
  349.       NOSUPR = 0
  350. C
  351. C     ---- REPRISE SUR MANQUE DE MEMOIRE ----
  352. C
  353.       IF( (ITRVMX.LT.NITNEC).OR.
  354.      >    (NBPMAX.LT.((NBRANG+1)*(NBCOMX+1)*(NBLGMX+1))) )THEN
  355.          IERRDS = -2
  356. c         WRITE (6,*) 'PLACE NECESSAIRE (ENTIERS): ',
  357. c     >                (NITNEC+8*NBEMAX)
  358. c         WRITE (6,*) 'PLACE NECESSAIRE (REELS) : ',
  359. c     >                ((NBRANG+1)*(NBCOMX+1)*(NBLGMX+1))
  360.          IERDS = 0
  361.          ITOTAI = 4*(NBE1+NBE2) + (NITNEC+8*NBEMAX)
  362.          SEGADJ ITRAVX
  363.          ITOTAR = (NBN1+NBN2)*3 + ((NBRANG+1)*(NBCOMX+1)*(NBLGMX+1))
  364.          SEGADJ RTRAVX
  365.          GOTO 10
  366.       ENDIF
  367. C
  368.       CALL HEXOS(ITVL(ITRNO3),NBE3,NBN3,ITVL(ITRNO4),NBE4,NBN4,
  369.      >           RTVL(ICOORD),NBCOOR,
  370.      >           N1B,N2B,DEN1,DEN2,NBCOUC,
  371.      >           ITVL(ITRAV),ITRVMX,NOSUPR,
  372.      >           ITVL(ITRNOE),NBE,NBEMAX,NBPMAX,
  373.      >           NBNL,ICOIN,ITRACE,IERCOD,IERRDS,raison)
  374. C
  375. C
  376. C     ---- MESSAGES D'ERREUR ----
  377. C
  378.       IF( IERRDS.EQ.-1)THEN
  379.         IMESS = -IERCOD - 90
  380.         CALL MSHEXO('HEXOS ',IMESS,IERRDS,0,0.0d0,' ')
  381.         SEGSUP ITRAVX,RTRAVX,ICPR,ICPP
  382.         GOTO 9999
  383.       ENDIF
  384. c      IF( IERRDS.EQ.-2)THEN
  385. c         WRITE (6,*) 'MANQUE DE PLACE : ERREUR ANORMALE'
  386. c      ENDIF
  387. C
  388. C        -------------------------
  389. C     --- PASSAGE AU QUADRATIQUE ---
  390. C        -------------------------
  391. C
  392.       IF(IORDR.EQ.2)THEN
  393.         IDEE   = 3
  394.         NBNMX5  = 8
  395.         NBCMX5  = 6
  396.         ITRTRI = ITRNOE + (NBE*NBNMX5)
  397.         NOETRI = ITRTRI + (NBE*NBCMX5)
  398.         ITRAV  = NOETRI + NBCOOR
  399.         NITMX2 = NITMAX - ITRAV
  400. c        WRITE(6,*) 'NITMX2 = ',NITMX2
  401.         NOEMAX = NBCOOR
  402.         CALL SMACRE(IDEE,ITVL(ITRNOE),NBE,NBCOOR,
  403.      >            ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),
  404.      >            NBCMX5,ITVL(NOETRI),NOEMAX,
  405.      >            ITVL(ITRAV),NITMX2,IERRDS)
  406.         IF( IERRDS.NE.0 )THEN
  407.           CALL ESERRO(1,IERRDS,'VOLOS',' APPEL SMACRE')
  408.           GOTO 9999
  409.         ENDIF
  410. C
  411. C     --- INDICE DES SOMMETS ---------------------
  412. C
  413.         ICODE5 = 15
  414.         CALL ELSOVO(ICODE5,INDSO,NBSO5,NBNO5,IERRDS)
  415. c        WRITE(6,*) 'NBNO5 (20) = ',NBNO5
  416. C
  417. C     ---- ALLOCATION DE LA MEMOIRE --------------
  418. C
  419.         ITRNO5 = ITRAV
  420.         ITRAV  = ITRNO5 + (NBE * NBNO5)
  421.         NITMX2 = NITMAX - ITRAV
  422. C
  423. C     ---- CREATION DU MAILLAGE AVEC DES TROUS ---
  424. C
  425.         ISENS = 1
  426.         CALL ELCREE(IDEE,ITVL(ITRNOE),NBNMX5,NBE,
  427.      >            ICODE5,INDSO,ISENS,IDE5,ITVL(ITRNO5),
  428.      >            NBNO5,NBE5,IERRDS)
  429.         IF( IERRDS.NE.0 )THEN
  430.           CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELCREE')
  431.           GOTO 9999
  432.         ENDIF
  433. C
  434. C     ---- TRANSFERT DES NOEUDS MILIEU --------------
  435. C
  436. c      WRITE(6,*) 'AVANT TRANSFERT '
  437. c      WRITE(6,*)
  438. c     >    ((ITVL((I-1)*NBNO5+J-1+ITRNO5),J=1,NBNO5)
  439. c     >   ,'/',I=1,NBE5)
  440.       CALL ELTRNO(ICODE1,IDE1,ITVL(ITRNO1),NBNMAX,NBE1,
  441.      >            ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),
  442.      >            NBCMX5,ITVL(NOETRI),NOEMAX,
  443.      >            ITVL(ITRAV),NITMX2,
  444.      >            ICODE5,IDE5,ITVL(ITRNO5),NBNO5,NBE5,
  445.      >            IERRDS)
  446.       IF( IERRDS.NE.0 )THEN
  447.         CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELTRNO (1)')
  448.         GOTO 9999
  449.       ENDIF
  450.       CALL ELTRNO(ICODE1,IDE2,ITVL(ITRNO2),NBNMAX,NBE2,
  451.      >            ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),
  452.      >            NBCMX5,ITVL(NOETRI),NOEMAX,
  453.      >            ITVL(ITRAV),NITMX2,
  454.      >            ICODE5,IDE5,ITVL(ITRNO5),NBNO5,NBE5,
  455.      >            IERRDS)
  456. C
  457.       IF( IERRDS.NE.0 )THEN
  458. c        WRITE(6,*) 'LE MAILLAGE A TRANSFERER '
  459. c        WRITE(6,*)
  460. c     >    ((ITVL((I-1)*NBNMAX+J-1+ITRNO2),J=1,NBNMAX)
  461. c     >   ,'/',I=1,NBE2)
  462. c        WRITE(6,*) 'LE MAILLAGE TOPOLOGIQUE '
  463. c        WRITE(6,*)
  464. c     >    ((ITVL((I-1)*NBNMX5+J-1+ITRNOE),J=1,NBNMX5)
  465. c     >   ,'/',I=1,NBE5)
  466. C
  467.         CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELTRNO (2)')
  468.         GOTO 9999
  469.       ENDIF
  470. C
  471. c      WRITE(6,*) 'APRES TRANSFERT '
  472. c      WRITE(6,*)
  473. c     >    ((ITVL((I-1)*NBNO5+J-1+ITRNO5),J=1,NBNO5)
  474. c     >   ,'/',I=1,NBE5)
  475. C
  476. C
  477. C     ---- CALCUL DES NOEUDS MILIEU --------------
  478. C
  479. C
  480.       CALL ELCCNO(ICODE5,IDE5,ITVL(ITRNO5),NBNO5,NBE5,
  481.      >        ITVL(ITRNOE),NBNMX5,ITVL(ITRTRI),NBCMX5,
  482.      >            ITVL(ITRAV),NITMX2,
  483.      >            RTVL(ICOORD),IDIMC,NBCOOR,NBPMAX,IERRDS)
  484.       IF( IERRDS.NE.0 )THEN
  485.         CALL ESERRO(1,IERRDS,'VOLOS',' APPEL ELCCNO')
  486.         GOTO 9999
  487.       ENDIF
  488. c      WRITE(6,*) 'APRES AJOUT NOEUDS '
  489. c      WRITE(6,*)
  490. c     >    ((ITVL((I-1)*NBNO5+J-1+ITRNO5),J=1,NBNO5)
  491. c     >   ,'/',I=1,NBE5)
  492.       ELSE
  493. C        -------------------------
  494. C     --- ON RESTE EN LINEAIRE   ---
  495. C        -------------------------
  496.         ITRNO5 = ITRNOE
  497.         ICODE5 = 14
  498.         NBNO5  = 8
  499.         NBE5   = NBE
  500.       ENDIF
  501. C
  502. *
  503. *   REMPLISSAGE NOUVEL OBJET MAILLAGE ET TABLEAU DES COORDONNEES
  504. *   ============================================================
  505. C
  506.   40  CONTINUE
  507. c      WRITE (6,*) '==== ON SORT ===='
  508. C
  509. C     ---- TRANSFERT DES NOUVEAUX NOEUDS ----
  510. C         ===============================
  511. *
  512. c      WRITE (6,*) 'ECRITURE DES NOEUDS = ',NBCOOR - INO
  513.       NBPTS = NBANC + NBCOOR - INO
  514. c      WRITE(6,*) ' MCOORD NBCOOR INO ', MCOORD,NBCOOR,INO,NBANC
  515.       SEGADJ MCOORD
  516.       DO 7781 I=1,NBCOOR-INO
  517.       XCOOR((NBANC +I-1)*(IDIM+1)+1) = RTVL((INO+I-1)*IDIMC+1)
  518.       XCOOR((NBANC +I-1)*(IDIM+1)+2) = RTVL((INO+I-1)*IDIMC+2)
  519.       XCOOR((NBANC +I-1)*(IDIM+1)+3) = RTVL((INO+I-1)*IDIMC+3)
  520.       XCOOR((NBANC +I-1)*(IDIM+1)+4) = DENSIT
  521.  7781 CONTINUE
  522. C
  523. C     ---- TRANSFERT DES ELEMENTS ----
  524. C         ========================
  525. c      WRITE (6,*) 'ECRITURE DES ELEMENTS = ',NBE5
  526. c      WRITE (6,*) (ITVL(ITRNO5+I-1),I=1,NBE5*NBNO5)
  527.       NBNN   = NBNO5
  528.       NBREF  = 0
  529.       NBSOUS = 0
  530.       NBELEM = NBE5
  531.       SEGINI IPT3
  532. C     14 = CUB8, 15 = CU20
  533.       IPT3.ITYPEL = ICODE5
  534.       DO 7782 I=1,NBE5
  535.        DO 7783 J=1,NBNO5
  536.        IA=ITVL((I-1)*NBNO5 +J-1+ITRNO5)
  537. C
  538. C      ON TESTE SI LE NOEUD EXISTE DEJA POUR RETROUVER LES NUMEROS CASTEM
  539. C
  540.       IF ( IA .LE.INO) THEN
  541.         IB = ICPP(IA)
  542.       ELSE
  543.         IB = IA -INO +NBANC
  544.       ENDIF
  545.       IPT3.NUM(J,I)=IB
  546.  7783 CONTINUE
  547.       IPT3.ICOLOR(I) = IDCOUL
  548.  7782 CONTINUE
  549. C
  550. C     --- FIN ET ECRITURE ---
  551. C        =================
  552. c      WRITE (6,*) 'ECRITURE'
  553.       CALL ECROBJ('MAILLAGE',IPT3)
  554. c      WRITE (6,*) 'DESACTIVATION'
  555.       SEGDES IPT3
  556.       SEGSUP ITRAVX,RTRAVX,ICPR,ICPP
  557. *      CALL ECROBJ('MAILLAGE',IPT3)
  558. C
  559. C
  560.  9999 END
  561.  
  562.  
  563.  
  564.  
  565.  
  566.  
  567.  
  568.  
  569.  
  570.  
  571.  
  572.  
  573.  

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