Sources Esope | Cast3M

trprof
C TRPROF    SOURCE    PV090527  25/10/15    21:15:04     12383          
      SUBROUTINE TRPROF
 
      IMPLICIT INTEGER(I-N)
-INC SMRIGID
-INC SMMATRI
-INC SMELEME
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO
 
      call lirobj('RIGIDITE',mrigi0,1,iretou)
      if (ierr.ne.0) return
* creation d'un maillage résultat
      NBNN = 2
      NBELEM = 100
      NBSOUS = 0
      NBREF = 0
      segini meleme
      ITYPEL = 2
 
      segact mcoord*mod
      inbpt = nbpts
      nb0 = 0
 
      mrigid = mrigi0
      segact mrigid
 
      do ifois=1,29
*     write(6,*) 'trprof ifois ipmatr mrigid ',ifois,ipmatr,mrigid
      if (jrcond.ne.0) then
      mrigid=jrcond
      segact mrigid
      nbr=irigel(/2)
      if (nbr.eq.0) then
       infer0 = 0
*      write(6,*) ' diagn1 nbr 0 '
       segdes mrigid
       return
      endif
      if(isupt.eq.0) isupt=isupeq
      endif
      enddo
      segact mrigid
      If ( (ichole .eq. 0) .and. (jrcond .ne. 0) ) then
        ri1 = mrigid
        mrigid =  ri1.jrcond
        segact mrigid
        segdes ri1
      endif
      MMATRI = ICHOLE
      segdes mrigid
      if (MMATRI .eq. 0) GOTO 1000
      segact MMATRI
 
      MILIGN = IILIGN
      segact MILIGN
 
      NNOE = ILIGN(/1)
 
      nbpts = nbpts + 100000
      segadj mcoord
      inumli = 0
* Boucle sur les blocs de lignes
      Do j=1,NNOE
        Lign = ilign(j)
        segact Lign
 
        NA = IMMM(/1)
* Boucle sur les lignes
        Do i0=1,NA
          inumli = inumli + 1
          ideb = ivpo(2*ippvv(i0)-1)
          ifin = ivpo(2*ippvv(i0+1)-1)
          nbterm = ifin - ideb
          ixdeb = inumli - nbterm
* Boucle sur les morceaux de lignes
          Do i1=ippvv(i0),(ippvv(i0+1)-1)
            nbt = ivpo(2*(i1+1)) - ivpo(2*i1) 
            ndeb = ivpo(2*i1-1)
            if (nbt .lt. 0) then
               print*,'nbt negatif !!!'
               nbt = 0
            endif
            if (nb0 .eq. NBELEM) then
              NBELEM = NBELEM + 100000
              segadj meleme
            endif
 
            if ((inbpt + 2) .gt. nbpts) then
              nbpts = nbpts + 100000
              segadj mcoord
            endif
 
            inbpt = inbpt + 1
            nb0 = nb0 + 1
            xx1 = ixdeb + ndeb - ideb 
            xx2 = ixdeb + ndeb - ideb + nbt
            yy = -1. * inumli
* creation du point
            xcoor((inbpt-1)*(idim+1)+1) = xx1
            xcoor((inbpt-1)*(idim+1)+2) = yy
            if (idim .eq. 3) xcoor((inbpt-1)*(idim+1)+3) = 0
            xcoor(inbpt*(idim+1)) = 1
 
            inbpt = inbpt + 1
            xcoor((inbpt-1)*(idim+1)+1) = xx2
            xcoor((inbpt-1)*(idim+1)+2) = yy
            if (idim .eq. 3) xcoor((inbpt-1)*(idim+1)+3) = 0
            xcoor(inbpt*(idim+1)) = 1
 
* affectation dans le meleme
            num(1,nb0) = inbpt - 1
            num(2,nb0) = inbpt
            icolor(nb0) = 1
          Enddo
        Enddo
 
        segdes Lign
      Enddo
 
      segdes MILIGN
 
      segdes MMATRI
 
      nbpts = inbpt
      segadj mcoord
      NBELEM = nb0
      segadj meleme
      segdes meleme
      melem0 = meleme
      call ecrobj('MAILLAGE',melem0)
      return
 1000 continue
      call erreur(990)
      segdes meleme
      melem0 = 0
      end