Télécharger la plaquette Cast3M


fr en

Télécharger trprof.eso

Retour à la liste

Numérotation des lignes : 

trprof

  1. C TRPROF    SOURCE    PV        20/09/26    21:20:06     10724          
  2.       SUBROUTINE TRPROF
  3.  
  4.       IMPLICIT INTEGER(I-N)
  5. -INC SMRIGID
  6. -INC SMMATRI
  7. -INC SMELEME
  8. -INC SMCOORD
  9.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12.  
  13.       call lirobj('RIGIDITE',mrigi0,1,iretou)
  14.       if (ierr.ne.0) return
  15. * creation d'un maillage résultat
  16.       NBNN = 2
  17.       NBELEM = 100
  18.       NBSOUS = 0
  19.       NBREF = 0
  20.       segini meleme
  21.       ITYPEL = 2
  22.  
  23.       segact mcoord*mod
  24.       inbpt = nbpts
  25.       nb0 = 0
  26.  
  27.       mrigid = mrigi0
  28.  
  29.       segact mrigid
  30.       If ( (ichole .eq. 0) .and. (jrcond .ne. 0) ) then
  31.         ri1 = mrigid
  32.         mrigid =  ri1.jrcond
  33.         segact mrigid
  34.         segdes ri1
  35.       endif
  36.       MMATRI = ICHOLE
  37.       segdes mrigid
  38.       if (MMATRI .eq. 0) GOTO 1000
  39.       segact MMATRI
  40.  
  41.       MILIGN = IILIGN
  42.       segact MILIGN
  43.  
  44.       NNOE = ILIGN(/1)
  45.  
  46.       nbpts = nbpts + 100
  47.       segadj mcoord
  48.       inumli = 0
  49. * Boucle sur les blocs de lignes
  50.       Do j=1,NNOE
  51.         Lign = ilign(j)
  52.         segact Lign
  53.  
  54.         NA = IMMM(/1)
  55. * Boucle sur les lignes
  56.         Do i0=1,NA
  57.           inumli = inumli + 1
  58.           ideb = ivpo(2*ippvv(i0)-1)
  59.           ifin = ivpo(2*ippvv(i0+1)-1)
  60.           nbterm = ifin - ideb
  61.           ixdeb = inumli - nbterm
  62. * Boucle sur les morceaux de lignes
  63.           Do i1=ippvv(i0),(ippvv(i0+1)-1)
  64.             nbt = ivpo(2*(i1+1)) - ivpo(2*i1) - 1
  65.             ndeb = ivpo(2*i1-1)
  66.             if (nbt .lt. 0) then
  67.                print*,'nbt negatif !!!'
  68.                nbt = 0
  69.             endif
  70.             if (nb0 .eq. NBELEM) then
  71.               NBELEM = NBELEM + 100
  72.               segadj meleme
  73.             endif
  74.  
  75.             if ((inbpt + 2) .gt. nbpts) then
  76.               nbpts = nbpts + 100
  77.               segadj mcoord
  78.             endif
  79.  
  80.             inbpt = inbpt + 1
  81.             nb0 = nb0 + 1
  82.             xx1 = ixdeb + ndeb - ideb +  1
  83.             xx2 = ixdeb + ndeb - ideb + nbt
  84.             yy = -1. * inumli
  85. * creation du point
  86.             xcoor((inbpt-1)*(idim+1)+1) = xx1
  87.             xcoor((inbpt-1)*(idim+1)+2) = yy
  88.             if (idim .eq. 3) xcoor((inbpt-1)*(idim+1)+3) = 0
  89.             xcoor(inbpt*(idim+1)) = 1
  90.  
  91.             inbpt = inbpt + 1
  92.             xcoor((inbpt-1)*(idim+1)+1) = xx2
  93.             xcoor((inbpt-1)*(idim+1)+2) = yy
  94.             if (idim .eq. 3) xcoor((inbpt-1)*(idim+1)+3) = 0
  95.             xcoor(inbpt*(idim+1)) = 1
  96.  
  97. * affectation dans le meleme
  98.             num(1,nb0) = inbpt - 1
  99.             num(2,nb0) = inbpt
  100.             icolor(nb0) = 1
  101.           Enddo
  102.         Enddo
  103.  
  104.         segdes Lign
  105.       Enddo
  106.  
  107.       segdes MILIGN
  108.  
  109.       segdes MMATRI
  110.  
  111.       nbpts = inbpt
  112.       segadj mcoord
  113.       NBELEM = nb0
  114.       segadj meleme
  115.       segdes meleme
  116.       melem0 = meleme
  117.       call ecrobj('MAILLAGE',melem0)
  118.       return
  119.  1000 continue
  120.       call erreur(990)
  121.       segdes meleme
  122.       melem0 = 0
  123.       end
  124.  
  125.  
  126.  
  127.  
  128.  
  129.  
  130.  
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  

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