Esope source files

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