Télécharger la plaquette Cast3M


fr en

Télécharger j3unlo.eso

Retour à la liste

Numérotation des lignes : 

j3unlo

  1. C J3UNLO    SOURCE    PV        20/03/24    21:18:26     10554          
  2.       SUBROUTINE J3UNLO(BLOCOM,BLOCO1,MTABLE,TOL)
  3. C--------------------------------------------------------------------
  4. C
  5. C     CHARGEMENT DES POINTS AVEC ELIMINATION AVEC LES POINTS
  6. C                ORIGINAUX
  7. C
  8. C     PP /9/97
  9. C     Pierre Pegon/JRC Ispra
  10. C--------------------------------------------------------------------
  11.       IMPLICIT INTEGER(I-N)
  12.       IMPLICIT REAL*8 (A-H,O-Z)
  13. C
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMELEME
  18. -INC SMTABLE
  19. -INC SMCOORD
  20. C
  21.       SEGMENT BLOCOM
  22.         INTEGER POINT(NPOINT)
  23.         REAL*8 YCOOR(IDIM+1,NPOINT)
  24.         INTEGER MAILL(MM1)
  25.       ENDSEGMENT
  26.       POINTEUR BLOCO1.BLOCOM
  27. C
  28.       DIMENSION Y3(4)
  29. C
  30.       SEGACT,MCOORD*MOD
  31. C
  32.       TOL2=TOL**2
  33.       MM1=MLOTAB
  34. C
  35. C     BOUCLE SUR LES BLOCKS (SEULS LES INDICES ENTIERS ... IIE1)
  36. C     WARNING: IPOI DEBUT DES POINTS ORIGINAUX DANS BLOCO1
  37. C              IPOF FIN DES POINT ORIGINAUX DANS BLOCO1
  38. C
  39.       IIE1=0
  40.       IPOI=1
  41.       DO IE1=1,MM1
  42.         IF (MTABTI(IE1).EQ.'ENTIER  ')THEN
  43.           IIE1=IIE1+1
  44.           IPOF=BLOCO1.MAILL(IIE1)
  45.           MTAB1=MTABIV(IE1)
  46.           MM2=MTAB1.MLOTAB
  47. C
  48. C     BOUCLE SUR LES FACES (SEULS LES INDICES ENTIERS ... )
  49. C
  50.           DO IE2=1,MM2
  51.             IF (MTAB1.MTABTI(IE2).EQ.'ENTIER  ')THEN
  52.               MELEME=MTAB1.MTABIV(IE2)
  53.               NBELEM=ICOLOR(/1)
  54. C
  55. C     BOUCLE SUR LES ELEMENTS DES FACES EN PARTICULIER LES 1ER POINTS
  56. C
  57.               ITROU=1
  58.               DO IE3=1,NBELEM
  59.                 IPO3=NUM(1,IE3)
  60.                 DO IE4=1,IDIM+1
  61.                   Y3(IE4)=YCOOR(IE4,IPO3)
  62.                 ENDDO
  63. C
  64. C     ON REGARDE SI CE POINT PEUT ETRE CONFONDU AVEC UN POINT ORIGINAL
  65. C
  66.                 DO IE4=IPOI,IPOF
  67.                   NUME=BLOCO1.POINT(IE4)
  68.                   IREF=(NUME-1)*(IDIM+1)
  69.                   AAA=0.D0
  70.                   DO IE5=1,IDIM
  71.                     AAA=AAA+(XCOOR(IE5+IREF)-Y3(IE5))**2
  72.                   ENDDO
  73.                   IF(AAA.LT.TOL2)GOTO 1
  74.                 ENDDO
  75. C
  76. C     SI CE N'EST PAS LE CAS, ON L'AJOUTE ...
  77. C
  78.                 NBPTS=nbpts+1
  79.                 IREF=(NBPTS-1)*(IDIM+1)
  80.                 NUME=NBPTS
  81.                 SEGADJ,MCOORD
  82. C
  83. C     ... MAIS ON AJOURNE DANS TOUS LES CAS LES COORDONNEES (SURF+DISK!)
  84. C
  85.  1              CONTINUE
  86.                 DO IE4=1,IDIM+1
  87.                   XCOOR(IE4+IREF)=Y3(IE4)
  88.                 ENDDO
  89. C
  90. C     ON STOCKE LA REFERENCE AU NIVEAU DE LA FACE (ATTENTION AU TROU!)
  91. C
  92.                 NUM(1,IE3)=NUME
  93.                 IF(IE3.EQ.1)THEN
  94.                   ICAND=NBELEM
  95.                 ELSE
  96.                   ICAND=IE3-1
  97.                 ENDIF
  98.                 IF(NUM(2,ICAND).EQ.IPO3)THEN
  99.                   NUM(2,ICAND)=NUME
  100.                 ELSE
  101.                   DO IE4=ITROU,NBELEM
  102.                     IF(NUM(2,IE4).EQ.IPO3)GOTO 2
  103.                   ENDDO
  104.                   WRITE(IOIMP,*)'J3UNLO: IMPOSSIBLE !!!!'
  105.  2                CONTINUE
  106.                   ITROU=IE4+1
  107.                   NUM(2,IE4)=NUME
  108.                 ENDIF
  109. C
  110. C     FIN LOOP ELEMENT DE LA FACE
  111. C
  112.               ENDDO
  113. C
  114. C     ON RE-LOOP SUR LA FACE POUR AJOUTER DES POINTS REDONDANT (SURF!)
  115. C
  116.               DO IE3=1,NBELEM-1
  117.                 IPO3=NUM(1,IE3)
  118.                 IREF3=(IPO3-1)*(IDIM+1)
  119.                 DO IE4=IE3+1,NBELEM
  120.                   IF(NUM(1,IE4).EQ.IPO3)THEN
  121.                     NBPTS=nbpts+1
  122.                     IREF=(NBPTS-1)*(IDIM+1)
  123.                     SEGADJ,MCOORD
  124.                     DO IE5=1,IDIM+1
  125.                       XCOOR(IE5+IREF)=XCOOR(IE5+IREF3)
  126.                     ENDDO
  127.                     NUM(1,IE4)=NBPTS
  128.                     IF(NUM(2,IE4-1).NE.IPO3)THEN
  129.                       WRITE(IOIMP,*)'J3UNLO: IMPOSSIBLE (bis) !!!!'
  130.                     ENDIF
  131.                     NUM(2,IE4-1)=NBPTS
  132.                   ENDIF
  133.                 ENDDO
  134.               ENDDO
  135. C
  136. C     FIN LOOP FACE
  137. C
  138.               SEGDES,MELEME
  139.             ENDIF
  140.           ENDDO
  141. C
  142. C     FIN LOOP BLOCK
  143. C
  144.           SEGDES,MTAB1
  145.           IPOI=IPOF+1
  146.         ENDIF
  147.       ENDDO
  148.       SEGDES,MTABLE
  149. C
  150.       SEGACT,MCOORD
  151. C
  152.       RETURN
  153.       END
  154.  
  155.  
  156.  
  157.  

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