Télécharger la plaquette Cast3M


fr en

Télécharger rdscr1.eso

Retour à la liste

Numérotation des lignes : 

rdscr1

  1. C RDSCR1    SOURCE    GOUNAND   25/06/11    21:15:09     12278          
  2.       SUBROUTINE RDSCR1(IPT1,DES1,ISYM,IPT2,DES2)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : RDSCR1
  7. C DESCRIPTION :
  8. C     Quelquefois, les points de IPT1 (meleme simple) ne sont pas
  9. C     tous references par le segment DES1 (cas des QUAFs notamment).
  10. C     Dans ce cas, on fait une reduction de IPT1 et on le stocke dans
  11. C     IPT2. Si les points sont tous references IPT2=IPT1.
  12. C
  13. C
  14. C
  15. C LANGAGE     : ESOPE
  16. C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
  17. C               mel : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C VERSION    : v1, 22/05/2025, version initiale
  20. C HISTORIQUE : v1, 22/05/2025, creation
  21. C HISTORIQUE :
  22. C HISTORIQUE :
  23. C***********************************************************************
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC SMRIGID
  27. -INC SMELEME
  28.       SEGMENT ICNN(NBNN)
  29.       SEGMENT IBNN(NCNN)
  30. *
  31. * Executable statements
  32. *
  33.       segact ipt1
  34.       nbnn=ipt1.num(/1)
  35.       segini icnn
  36.       ncnn=0
  37.       segact des1
  38.       nligrp=des1.noelep(/1)
  39.       ncnn=0
  40.       do iligrp=1,nligrp
  41.          if (icnn(des1.noelep(iligrp)).eq.0) then
  42.             ncnn=ncnn+1
  43.             icnn(des1.noelep(iligrp))=1
  44.          endif
  45.       enddo
  46.       nligrd=des1.noeled(/1)
  47.       if (isym.ge.2) then
  48.          do iligrd=1,nligrd
  49.             if (icnn(des1.noeled(iligrd)).eq.0) then
  50.                icnn(des1.noeled(iligrd))=1
  51.                ncnn=ncnn+1
  52.             endif
  53.          enddo
  54.       endif
  55. *      write(ioimp,*) 'ncnn,nbnn=',ncnn,nbnn
  56.       if (ncnn.NE.nbnn) then
  57.          segini ibnn
  58.          ic=0
  59.          do ib=1,nbnn
  60.             if (icnn(ib).ne.0) then
  61.                ic=ic+1
  62.                ibnn(ic)=ib
  63.                icnn(ib)=ic
  64.             endif
  65.          enddo
  66.          nbnn=ncnn
  67.          nbelem=ipt1.num(/2)
  68.          nbref=0
  69.          nbsous=0
  70.          segini ipt2
  71.          ipt2.itypel=32
  72.          do ibelem=1,nbelem
  73.             do ic=1,ncnn
  74.                ipt2.num(ic,ibelem)=ipt1.num(ibnn(ic),ibelem)
  75.             enddo
  76.          enddo
  77.          segini,des2
  78.          do iligrp=1,nligrp
  79.             des2.lisinc(iligrp)=des1.lisinc(iligrp)
  80.             des2.noelep(iligrp)=icnn(des1.noelep(iligrp))
  81.          enddo
  82.          if (isym.ge.2) then
  83.             do iligrd=1,nligrd
  84.                des2.lisdua(iligrd)=des1.lisdua(iligrd)
  85.                des2.noeled(iligrd)=icnn(des1.noeled(iligrd))
  86.             enddo
  87.          else
  88.             do iligrp=1,nligrp
  89.                des2.lisdua(iligrp)=des1.lisdua(iligrp)
  90.                des2.noeled(iligrp)=des2.noelep(iligrp)
  91.             enddo
  92.          endif
  93.          segsup ibnn
  94.       else
  95.          ipt2=ipt1
  96.          des2=des1
  97.       endif
  98.       segsup icnn
  99. *
  100. * Normal termination
  101. *
  102.       RETURN
  103. *
  104. * Format handling
  105. *
  106. *
  107. * Error handling
  108. *
  109. *
  110. * End of subroutine RDSCR1
  111. *
  112.       END
  113.  
  114.  

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