Télécharger la plaquette Cast3M


fr en

Télécharger isova3.eso

Retour à la liste

Numérotation des lignes : 

isova3

  1. C ISOVA3    SOURCE    PV        20/04/01    21:15:54     10569          
  2.       SUBROUTINE ISOVA3(XISO,VAL1,VAL2,NUM1,NUM2,MLENTI,NEWNOD)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : ISOVA3
  7. C DESCRIPTION : Construit le noeud correspondant à l'intersection
  8. C               d'une isovaleur sur un segment.
  9. C               Ajoute
  10. C
  11. C
  12. C LANGAGE     : ESOPE
  13. C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  14. C               mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C VERSION    : v1.1, 29/07/2014, modifie la pile des nouveaux noeuds
  17. C VERSION    : v1, 17/12/2008, version initiale
  18. C HISTORIQUE : v1, 17/12/2008, création
  19. C HISTORIQUE :
  20. C HISTORIQUE :
  21. C***********************************************************************
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. *-INC SMCOORD
  26. -INC CCREEL
  27. -INC SMLENTI
  28. *
  29.       SEGMENT NEWNOD
  30.       INTEGER NNOD
  31.       INTEGER NOEINF(MAXNOD)
  32.       INTEGER NOESUP(MAXNOD)
  33.       REAL*8  COEINF(MAXNOD)
  34.       ENDSEGMENT
  35. *
  36.       DVAL=VAL2-VAL1
  37.       XBAR=(XISO-VAL1)/DVAL
  38.       XMBAR=1.D0-XBAR
  39. *dbg      WRITE(IOIMP,*) '         XBAR=',XBAR,' DVAL=', DVAL
  40. * On a rajoute ce test suite a la fiche 8625
  41. * On met xzprec*10.D0 pour mimer le XTOL mis dans isoval.eso
  42.       if ((xbar.lt.-xzprec*10.D0).or.(xmbar.lt.-xzprec*10.D0)) then
  43.          MOTERR(1:8)='ISOVA3  '
  44.          CALL ERREUR(349)
  45.          RETURN
  46.       endif
  47. *
  48. * On adopte une logique différente : on ajoute des noeuds
  49. * dans la pile NEWNOD au lieu d'incrémenter directement MCOORD.
  50. * En effet, on va éliminer les noeuds de NEWNOD géométriquement
  51. * confondus avant de les ajouter à MCOORD. L'intérêt est que comme les
  52. * coefficients barycentriques sont compris entre 0. et 1., il est
  53. * plus facile de trouver un critère d'élimination pertinent
  54. * (XZPREC*10.D0 doit à peu près convenir)
  55. *
  56. * Tous les noeuds créés sont des barycentres de deux noeuds existants
  57. * Par convention, on met le noeud existant de numéro le plus petit
  58. * dans NOEINF et l'autre dans NOESUP. Ceci facilitera les recherches
  59. * pour l'élimination ultérieure
  60. *
  61. * On stocke le coefficient
  62. * barycentrique de NOEINF dans COEINF. L'autre coefficient se retrouve
  63. * en faisant 1-COEINF (on perd peut-être un peu en précision ?)
  64. *
  65.       NNOD=NNOD+1
  66.       IF (NUM1.LE.NUM2) THEN
  67.          NOEINF(NNOD)=NUM1
  68.          NOESUP(NNOD)=NUM2
  69.          COEINF(NNOD)=XMBAR
  70.       ELSE
  71.          NOEINF(NNOD)=NUM2
  72.          NOESUP(NNOD)=NUM1
  73.          COEINF(NNOD)=XBAR
  74.       ENDIF
  75. * Par convention, un noeud de la pile NEWNOD est mis en négatif dans
  76. * LECT pour le distinguer des noeuds usuels de MCOORD
  77.       LECT(**)=-NNOD
  78. *      IDIM1=IDIM+1
  79. *      NBPTS=nbpts
  80. *      NBPTS=NBPTS+1
  81. *      SEGADJ,MCOORD
  82. *      DO II=1,IDIM+1
  83. *         XCOOR((NBPTS-1)*IDIM1+II)=
  84. *     $        (XCOOR((NUM2-1)*IDIM1+II)*XBAR)+
  85. *     $        (XCOOR((NUM1-1)*IDIM1+II)*XMBAR)
  86. *      ENDDO
  87. *      LECT(**)=NBPTS
  88.       RETURN
  89. *
  90. * End of subroutine ISOVA3
  91. *
  92.       END
  93.  
  94.  
  95.  
  96.  
  97.  
  98.  
  99.  

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