Télécharger la plaquette Cast3M


fr en

Télécharger j3fac0.eso

Retour à la liste

Numérotation des lignes : 

j3fac0

  1. C J3FAC0    SOURCE    CB215821  18/09/13    21:15:40     9917           
  2.       SUBROUTINE J3FAC0
  3. C----------------------------------------------------
  4. C     TEST POUR LES FACES
  5. C     PP 6/97
  6. C     Pierre Pegon/JRC Ispra
  7. C----------------------------------------------------
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8(A-H,O-Z)
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMTABLE
  14. -INC SMELEME
  15. -INC SMCOORD
  16. -INC CCGEOME
  17. -INC CCNOYAU
  18. -INC CCASSIS
  19. C
  20.       SEGMENT BLOCOM
  21.         INTEGER POINT(NPOINT)
  22.         REAL*8 YCOOR(IDIM+1,NPOINT)
  23.         INTEGER MAILL(MM1)
  24.       ENDSEGMENT
  25.       POINTEUR BLOCO1.BLOCOM
  26. C
  27.       SEGMENT VWORK
  28.         INTEGER FWWORK(NFACE)
  29.       ENDSEGMENT
  30.       SEGMENT VWORK1.VWORK
  31. C
  32.       SEGMENT WWORK
  33.         REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  34.         INTEGER FWORK
  35.         INTEGER TWORK(NTROU)
  36.       ENDSEGMENT
  37. C
  38.       SEGMENT WORK
  39.         REAL*8 XYC(2,NPTO)
  40.         INTEGER IST(3,NPTO)
  41.         REAL*8 DENS(NPTO)
  42.         INTEGER JUN
  43.       ENDSEGMENT
  44. C
  45. C     LECTURE DE LA TABLE ET DE LA TOLERANCE
  46. C
  47.       CALL LIROBJ('TABLE',MTABLE,1,IRETOU)
  48.       IF(IERR.NE.0) RETURN
  49.       CALL LIRREE(TOL,1,IRETOU)
  50.       IF(IERR.NE.0) RETURN
  51. C
  52. C     VERIFICATION DE LA DIMENSION
  53. C
  54.       IF (IDIM.NE.3)THEN
  55.         WRITE(IOIMP,*)'J3FAC0: on n"est pas en 3D'
  56.         RETURN
  57.       ENDIF
  58. C
  59. C     VERIFICATIONS DIVERSES
  60. C
  61.       SEGACT, MTABLE
  62.       MM=MLOTAB
  63. C
  64.       NFACE=MM-1
  65.       SEGINI,VWORK1
  66. C
  67.       NPOINT=0
  68.       MM1=NFACE
  69.       SEGINI,BLOCOM
  70. C
  71.       IIE1=0
  72.       if(nbesc.ne.0) segact ipiloc
  73.       DO IE1=1,MM
  74.         IF (MTABTI(IE1).EQ.'MOT     ')THEN
  75. C
  76. C     ON VERIFIE LA VALEUR DE L'INDICE MOT ET LE CONTENU
  77. C
  78.           JF=IPCHAR(MTABII(IE1)+1)
  79.           ID=IPCHAR(MTABII(IE1))
  80.           IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN
  81.             WRITE(IOIMP,*)'J3FAC0: un indice de type mot est errone'
  82.             GOTO 9999
  83.           ENDIF
  84.           IF (MTABTV(IE1).NE.'MOT     ')THEN
  85.             WRITE(IOIMP,*)'J3FAC0: le SOUSTYPE doit etre un MOT'
  86.             GOTO 9999
  87.           ENDIF
  88.           JF=IPCHAR(MTABIV(IE1)+1)
  89.           ID=IPCHAR(MTABIV(IE1))
  90.           IF (ICHARA(ID:JF-1).NE.'LISTE_DE_BLOCS')THEN
  91.             WRITE(IOIMP,*)'J3FAC0: le SOUSTYPE doit etre LISTE_DE_BLOCS'
  92.             GOTO 9999
  93.           ENDIF
  94.         ELSEIF (MTABTI(IE1).EQ.'ENTIER  ')THEN
  95. C
  96. C     ON VERIFIE LE CONTENU DES INDICES ENTIERS
  97. C
  98.           IF (MTABTV(IE1).NE.'TABLE')THEN
  99.             WRITE(IOIMP,*)'J3FAC0: un indice entier n"est pas une table'
  100.             GOTO 9999
  101.           ENDIF
  102.           MTAB1=MTABIV(IE1)
  103.           SEGACT,MTAB1
  104.           MM1=MTAB1.MLOTAB
  105. C
  106.           NFACE=MM1-1
  107.           SEGINI,VWORK
  108.           IIE1=IIE1+1
  109.           VWORK1.FWWORK(IIE1)=VWORK
  110. C
  111.           IIE2=0
  112.           DO IE2=1,MM1
  113.             if(nbesc.ne.0) segact ipiloc
  114.             IF (MTAB1.MTABTI(IE2).EQ.'MOT     ')THEN
  115.               IDM=MTAB1.MTABII(IE2)
  116.               JF=IPCHAR(IDM+1)
  117.               ID=IPCHAR(IDM)
  118.               IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN
  119.                 WRITE(IOIMP,*)'J3FAC0: pas de sous-type'
  120.                 GOTO 9999
  121.               ENDIF
  122.               IF (MTAB1.MTABTV(IE2).NE.'MOT     ')THEN
  123.                 WRITE(IOIMP,*)'J3FAC0: sous-type de type incorrect'
  124.                 GOTO 9999
  125.               ENDIF
  126.               IDF=MTAB1.MTABIV(IE2)
  127.               JF=IPCHAR(IDF+1)
  128.               ID=IPCHAR(IDF)
  129.               IF (ICHARA(ID:JF-1).NE.'LISTE_DE_FACES')THEN
  130.                 WRITE(IOIMP,*)'J3FAC0: sous-type incorrect'
  131.                 GOTO 9999
  132.               ENDIF
  133.             ELSEIF (MTAB1.MTABTI(IE2).EQ.'ENTIER  ')THEN
  134.               IF (MTAB1.MTABTV(IE2).NE.'MAILLAGE')THEN
  135.                 WRITE(IOIMP,*)'indice entier non maillage'
  136.                 GOTO 9999
  137.               ENDIF
  138.               MELEME=MTAB1.MTABIV(IE2)
  139.               SEGACT,MELEME
  140.               IF(ITYPEL.NE.2)THEN
  141.                 WRITE(IOIMP,*)'maillage non de seg2'
  142.                 GOTO 9999
  143.               ENDIF
  144. C
  145.               NPTO=ICOLOR(/1)
  146.               IF(NUM(1,1).NE.NUM(2,NPTO))THEN
  147.                 WRITE(IOIMP,*)'maillage non ferme'
  148.                 GOTO 9999
  149.               ENDIF
  150. C
  151.               NTROU=0
  152.               SEGINI,WWORK
  153. C
  154.               SEGINI,WORK
  155.               FWORK=WORK
  156.               IIE2=IIE2+1
  157.               FWWORK(IIE2)=WWORK
  158. C
  159.               CALL J3LOAD(NUM,WWORK,NPTO,TOL,IRET)
  160.               IF(IRET.GT.0)GOTO 9999
  161.               CALL J3ORIE(1,XYC,DENS,NPTO,1,TOL,IRET)
  162.               IF(IRET.GT.0)GOTO 9999
  163.               IF(IIMPI.EQ.1789)THEN
  164.                 WRITE(IOIMP,*)'J3FAC0:LOAD DE LA FACE ',IIE1,IIE2
  165.                 CALL J3LIWW(WWORK)
  166.               ENDIF
  167.               CALL J3LOAP(MELEME,NPTO,BLOCOM,NPOINT)
  168. C
  169.               SEGDES,MELEME*NOMOD
  170.             ELSE
  171.               GOTO 9999
  172.             ENDIF
  173.           ENDDO
  174.         ELSE
  175.           WRITE(IOIMP,*)'J3FAC0: un type d"indice est errone'
  176.           GOTO 9999
  177.         ENDIF
  178. C
  179. C       DANS MAILL SE TROUVE LE NOMBRE DE PT TOTAL CHARGE A
  180. C       LA FIN DE CHAQUE BLOC
  181. C
  182.         IF(IIE1.NE.0)MAILL(IIE1)=NPOINT
  183.       ENDDO
  184.       if(nbesc.ne.0) SEGDES,IPILOC
  185. C
  186. C     ON VERIFIE QUE LES POINTS DE CHAQUE BLOK SONT 2 A 2 DISJOINTS
  187. C
  188.       CALL J3DISJ(BLOCOM,TOL,IRET)
  189.       IF(IRET.GT.0) GOTO 9999
  190. C
  191. C     ON GENERE LA NOUVELLE ARBORESCENCE DE FACE
  192. C
  193.       CALL J3FAC1(VWORK1,TOL,IRET)
  194.       IF(IRET.GT.0) GOTO 9999
  195. C
  196. C     ON TRAITE LES CAS QUI PEUVENT DONNER DU SOUCIS A SURF
  197. C
  198.       CALL J3SURE(VWORK1,IRET,TOL)
  199.       IF(IRET.GT.0) GOTO 9999
  200.       CALL J3SURF(VWORK1,TOL)
  201. C
  202. C     ON CHARGE LE RESULTAT DANS LA TABLE DE SORTIE MAIS LES POINTS
  203. C     SONT MIS DANS UN BLOCOM
  204. C
  205.       BLOCO1=BLOCOM
  206. C
  207.       MTAB1=MTABLE
  208.       SEGINI,MTABLE=MTAB1
  209.       SEGDES,MTAB1*NOMOD
  210. C
  211.       MM1=0
  212.       NPOINT=0
  213.       SEGINI,BLOCOM
  214. C
  215.       IIE1=0
  216.       DO IE1=1,MM
  217.         IF (MTABTI(IE1).EQ.'ENTIER  ')THEN
  218.           IIE1=IIE1+1
  219.           VWORK=VWORK1.FWWORK(IIE1)
  220.           M=FWWORK(/1)+1
  221.           SEGINI,MTAB1
  222.           MTAB1.MLOTAB=M
  223.           MTABIV(IE1)=MTAB1
  224. C
  225.           IM=1
  226.           MTAB1.MTABTI(IM)='MOT     '
  227.           MTAB1.MTABII(IM)=IDM
  228.           MTAB1.MTABTV(IM)='MOT     '
  229.           MTAB1.MTABIV(IM)=IDF
  230. C
  231.           DO IE2=1,M-1
  232. C
  233.             WWORK=FWWORK(IE2)
  234.             NTROU=TWORK(/1)
  235.             WORK=FWORK
  236. C
  237.             NBNN=2
  238.             NBELEM=XYC(/2)
  239.             NBSOUS=0
  240.             NBREF=0
  241.             SEGINI,MELEME
  242.             ITYPEL=2
  243. C
  244.             NPOINT1=NPOINT
  245.             NPOINT=NPOINT+NBELEM
  246.             MM1=MM1+1
  247.             SEGADJ,BLOCOM
  248.             MAILL(MM1)=MELEME
  249. C
  250.             DO IE3=1,NBELEM
  251.               JE3=NPOINT1+IE3
  252.               DO IE4=1,3
  253.                 YCOOR(IE4,JE3)=XYC(1,IE3)*VI(IE4)+XYC(2,IE3)*VJ(IE4)
  254.      >                        +PORIG(IE4)
  255.               ENDDO
  256.               YCOOR(4  ,JE3)=DENS(IE3)
  257.               DENS(IE3)=FLOAT(JE3)
  258.               POINT(JE3)=JE3
  259.             ENDDO
  260.             DO IE3=1,NBELEM
  261.               NUM(1,IE3)=INT(DENS(IE3))
  262.               IF(IE3.EQ.NBELEM)THEN
  263.                 NUM(2,IE3)=INT(DENS(1))
  264.               ELSE
  265.                 NUM(2,IE3)=INT(DENS(IE3+1))
  266.               ENDIF
  267.               ICOLOR(IE3)=IDCOUL
  268.             ENDDO
  269. C
  270.             IF(NTROU.NE.0)THEN
  271.               DO IE3=1,NTROU
  272.                 NBELE1=NBELEM
  273.                 SEGSUP,WORK
  274.                 WORK=TWORK(IE3)
  275.                 NBELE2=XYC(/2)
  276.                 NBELEM=NBELE1+NBELE2
  277.                 SEGADJ,MELEME
  278. C
  279.                 NPOINT1=NPOINT
  280.                 NPOINT=NPOINT+NBELE2
  281.                 SEGADJ,BLOCOM
  282. C
  283.                 DO IE4=1,NBELE2
  284.                   JE4=NPOINT1+IE4
  285.                   DO IE5=1,3
  286.                     YCOOR(IE5,JE4)=XYC(1,IE4)*VI(IE5)+XYC(2,IE4)*VJ(IE5)
  287.      >                            +PORIG(IE5)
  288.                   ENDDO
  289.                   YCOOR(4  ,JE4)=DENS(IE4)
  290.                   DENS(IE4)=FLOAT(JE4)
  291.                   POINT(JE4)=JE4
  292.                 ENDDO
  293.                 DO IE4=1,NBELE2
  294.                   NUM(1,NBELE1+IE4)=INT(DENS(IE4))
  295.                   IF(IE4.EQ.NBELE2)THEN
  296.                     NUM(2,NBELE1+IE4)=INT(DENS(1))
  297.                   ELSE
  298.                     NUM(2,NBELE1+IE4)=INT(DENS(IE4+1))
  299.                   ENDIF
  300.                   ICOLOR(NBELE1+IE4)=IDCOUL
  301.                 ENDDO
  302.               ENDDO
  303.             ENDIF
  304. C
  305. C           SEGDES,MELEME
  306.             SEGSUP,WORK
  307. C
  308.             IM=IM+1
  309.             MTAB1.MTABTI(IM)='ENTIER  '
  310.             MTAB1.MTABII(IM)=IE2
  311.             MTAB1.MTABTV(IM)='MAILLAGE'
  312.             MTAB1.MTABIV(IM)=MELEME
  313.           ENDDO
  314. C         SEGDES,MTAB1
  315.           SEGSUP,VWORK
  316. C
  317.         ENDIF
  318.       ENDDO
  319. C     SEGDES,MTABLE
  320.       SEGSUP,VWORK1
  321. C
  322. C     ON AJOUTE MAINTENANT LES POINT QUI TOMBENT SUR DES SEGMENTS
  323. C
  324.       CALL J3ARET(BLOCOM,TOL)
  325. C
  326. C     ON VERIFIE QUE LES POTS EN VIS A VIS ONT LA MEME DENSITE
  327. C        ET ON REND LES COORDONNES IDENTIQUES
  328. C
  329.       CALL J3DISK(BLOCOM,TOL,IRET)
  330.       IF(IRET.NE.0)THEN
  331.         SEGSUP,BLOCOM,BLOCO1,MTABLE
  332.         GOTO 9998
  333.       ENDIF
  334. C
  335. C     ON CHARGE MAINTENANT LES POINTS DANS LA PILE DES POINTS TOUT
  336. C        EN ELIMINANT AVEC LES CAS EXISTANT ET EN TRAITANT LES CAS
  337. C        TORDUS (POUR SURF)
  338. C
  339.       CALL J3UNLO(BLOCOM,BLOCO1,MTABLE,TOL)
  340.       SEGSUP,BLOCOM,BLOCO1
  341. C
  342.       CALL ECROBJ('TABLE',MTABLE)
  343. C
  344.       RETURN
  345. C
  346. 9999  SEGSUP,BLOCOM
  347.       CALL J3DETR(VWORK1)
  348.       SEGDES,MTABLE*NOMOD
  349. 9998  CALL ERREUR(21)
  350.       RETURN
  351.       END
  352.  
  353.  
  354.  
  355.  
  356.  
  357.  
  358.  

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