Télécharger la plaquette Cast3M


fr en

Télécharger combl2.eso

Retour à la liste

Numérotation des lignes : 

combl2

  1. C COMBL2    SOURCE    PV        20/03/24    21:16:00     10554          
  2.       SUBROUTINE COMBL2
  3. C--------------------------------------------------------------------
  4. C
  5. C     TABL1 = COMB TABL2 FLOT1;
  6. C
  7. C     FLOT1 : TOLERANCE
  8. C
  9. C     Pierre Pegon/JRC Ispra (??96 et 12/98)
  10. C--------------------------------------------------------------------
  11.       IMPLICIT INTEGER(I-N)
  12.       IMPLICIT REAL*8 (A-H,O-Z)
  13. C
  14. -INC PPARAM
  15. -INC CCOPTIO
  16. -INC SMTABLE
  17. -INC SMELEME
  18. -INC SMCOORD
  19. -INC CCNOYAU
  20. -INC CCASSIS
  21. C
  22. C2002 SEGMENT,BLOCOM
  23. C2002   INTEGER POINT(NPOINT)
  24. C2002   REAL*8  XX(NPOINT),YY(NPOINT),DD(NPOINT)
  25. C2002   INTEGER MAILL(MM1)
  26. C2002 ENDSEGMENT
  27. C
  28.       SEGMENT BLOCOM
  29.         INTEGER POINT(NPOINT)
  30.         REAL*8 YCOOR(IDIM+1,NPOINT)
  31.         INTEGER MAILL(MM1)
  32.       ENDSEGMENT
  33. C
  34.       CALL LIROBJ('TABLE',MTABLE,1,IRETOU)
  35.       IF(IERR.NE.0) RETURN
  36.       CALL LIRREE(XTOL,1,IRETOU)
  37.       IF(IERR.NE.0) RETURN
  38.       XTOL2=XTOL**2
  39. C
  40. C     VERIFICATION DE LA DIMENSION
  41. C
  42.       IF (IDIM.NE.2)THEN
  43.         WRITE(IOIMP,*)'GENJOI: on n"est pas en 2D'
  44.         RETURN
  45.       ENDIF
  46. C
  47. C     VERIFICATIONS DIVERSES
  48. C     - SOUS TYPE DE LA TABLE
  49. C     - NATURE DES MAILLAGE DE LA TABLE (SIMPLE, POI1 OU SEG2)
  50. C     ET CALCUL DU NOMBRE DE POINT
  51. C
  52.       NPOINT=0
  53.       SEGACT, MTABLE
  54.       MM=MLOTAB
  55.       if(nbesc.ne.0) segact ipiloc
  56.       DO IE1=1,MM
  57.         IF (MTABTI(IE1).EQ.'MOT     ')THEN
  58. C
  59. C     ON VERIFIE LA VALEUR DE L'INDICE MOT ET LE CONTENU
  60. C
  61.           JF=IPCHAR(MTABII(IE1)+1)
  62.           ID=IPCHAR(MTABII(IE1))
  63.           IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN
  64.             WRITE(IOIMP,*)'COMB: un indice de type mot est errone'
  65.             GOTO 9999
  66.           ENDIF
  67.           IF (MTABTV(IE1).NE.'MOT     ')THEN
  68.             WRITE(IOIMP,*)'COMB: le SOUSTYPE doit etre un MOT'
  69.             GOTO 9999
  70.           ENDIF
  71.           JF=IPCHAR(MTABIV(IE1)+1)
  72.           ID=IPCHAR(MTABIV(IE1))
  73.           IF (ICHARA(ID:JF-1).NE.'LISTE_DE_BLOCS')THEN
  74.             WRITE(IOIMP,*)'COMB: le SOUSTYPE doit etre LISTE_DE_BLOCS'
  75.             GOTO 9999
  76.           ENDIF
  77.         ELSEIF (MTABTI(IE1).EQ.'ENTIER  ')THEN
  78. C
  79. C     ON VERIFIE LE CONTENU DES INDICES ENTIERS
  80. C
  81.           IF (MTABTV(IE1).NE.'MAILLAGE')THEN
  82.           ENDIF
  83.           MELEME=MTABIV(IE1)
  84.           SEGACT,MELEME
  85.           IF(LISOUS(/1).NE.0.OR.(ITYPEL.NE.1.AND.ITYPEL.NE.2))THEN
  86.             WRITE(IOIMP,*)'COMB: un maillage est errone'
  87.             SEGDES,MELEME
  88.             GOTO 9999
  89.           ENDIF
  90.           NPOINT=NPOINT+ICOLOR(/1)
  91.           SEGDES,MELEME
  92.         ELSE
  93.           WRITE(IOIMP,*)'COMB: un type d"indice est errone'
  94.           GOTO 9999
  95.         ENDIF
  96.       ENDDO
  97.       if(nbesc.ne.0) SEGDES,IPILOC
  98. C
  99. C     ON CHARGE LE NUMERO DES POINTS ...
  100. C
  101.       IPOINT=0
  102.       IMAILL=0
  103.       MM1=MM-1
  104.       SEGINI,BLOCOM
  105.       DO IE1=1,MM
  106.         IF (MTABTI(IE1).EQ.'ENTIER  ')THEN
  107.           IMAILL=IMAILL+1
  108.           MELEME=MTABIV(IE1)
  109.           MAILL(IMAILL)=MELEME
  110.           SEGACT,MELEME
  111.           DO IE2=1,ICOLOR(/1)
  112.             IPOINT=IPOINT+1
  113.             POINT(IPOINT)=NUM(1,IE2)
  114.           ENDDO
  115.           SEGDES,MELEME
  116.         ENDIF
  117.       ENDDO
  118. C
  119. C     ... ON LES ORDONNE ...
  120. C
  121.       CALL ORDO02(POINT,NPOINT,.TRUE.)
  122. C
  123. C     ... ET ON VERIFIE QU'ILS SONT TOUS 2 A 2 DIFFERENT
  124. C
  125.       IPOINT=POINT(1)
  126.       DO IE1=2,NPOINT
  127.         IPOIN1=POINT(IE1)
  128.         IF(IPOIN1.EQ.IPOINT)THEN
  129.           WRITE(IOIMP,*)'COMB: deux points sont identiques'
  130.           GOTO 9998
  131.         ENDIF
  132.         IPOINT=IPOIN1
  133.       ENDDO
  134. C
  135. C     ON CHARGES LES COORDONNES ET LA DENSITE DE TOUS LES POINTS
  136. C
  137.       DO IE1=1,NPOINT
  138.         IREF=(POINT(IE1)-1)*(IDIM+1)
  139. C2002   XX(IE1)=XCOOR(IREF+1)
  140. C2002   YY(IE1)=XCOOR(IREF+2)
  141. C2002   DD(IE1)=XCOOR(IREF+3)
  142.         DO IE2=1,IDIM+1
  143.           YCOOR(IE2,IE1)=XCOOR(IREF+IE2)
  144.         ENDDO
  145.       ENDDO
  146. C+2002
  147. C
  148. C     ON VERIFIE QUE LES POINTS EN VIS A VIS ONT LA MEME DENSITE
  149. C        ET ON REND LES COORDONNES IDENTIQUES
  150. C
  151.       IRETOU=0
  152.       CALL J3DISK(BLOCOM,XTOL,IRETOU)
  153.       IF(IRETOU.NE.0)THEN
  154.         WRITE(IOIMP,*)'COMBL2: Pbs de pt en vis-a-vis'
  155.         GOTO 9998
  156.       ENDIF
  157. C
  158.       SEGACT MCOORD*MOD
  159.       DO IE1=1,NPOINT
  160.         IREF=(POINT(IE1)-1)*(IDIM+1)
  161.         DO IE2=1,IDIM+1
  162.           XCOOR(IREF+IE2)=YCOOR(IE2,IE1)
  163.         ENDDO
  164.       ENDDO
  165. C+2002
  166. C
  167. C     ON BOUCLE MAINTENANT SUR TOUS LES BLOCS ...
  168. C
  169.       NBSOUS=0
  170.       DO IE1=1,MM1
  171.         MELEME=MAILL(IE1)
  172.         SEGACT,MELEME
  173.         NBNN=ITYPEL
  174.         NBELEM=ICOLOR(/1)
  175.         NBREF=LISREF(/1)
  176. C
  177. C     ... ET SUR TOUS LEURS COTES
  178. C     (ON SIMULE "DO 3 IE2=1,NBELEM" AVEC IE2 ET NBELEM EVENTUELLEMENT CH
  179. C
  180.         IE2=0
  181.  1      IE2=IE2+1
  182.         IF(IE2.GT.NBELEM)GOTO 3
  183. C       DO 3 IE2=1,NBELEM
  184.           IREF=(NUM(1,IE2)-1)*(IDIM+1)
  185.           XX1=XCOOR(IREF+1)
  186.           YY1=XCOOR(IREF+2)
  187.           IF(IE2.EQ.NBELEM)THEN
  188.             IREF=(NUM(1,1)-1)*(IDIM+1)
  189.           ELSE
  190.             IREF=(NUM(1,IE2+1)-1)*(IDIM+1)
  191.           ENDIF
  192.           XX2=XCOOR(IREF+1)
  193.           YY2=XCOOR(IREF+2)
  194.           D12=(XX1-XX2)**2+(YY1-YY2)**2
  195. C
  196. C     ON BOUCLE SUR TOUS LES POINTS ...
  197. C
  198.           DO 2 IE3=1,NPOINT
  199. C2002       XXI=XX(IE3)
  200. C2002       YYI=YY(IE3)
  201.             XXI=YCOOR(1,IE3)
  202.             YYI=YCOOR(2,IE3)
  203.             DI1=(XXI-XX1)**2+(YYI-YY1)**2
  204.             DI2=(XXI-XX2)**2+(YYI-YY2)**2
  205. C
  206. C     ... ON ELIMINE CEUX QUI SONT TROP LOIN ...
  207. C
  208.             IF((DI1.GT.D12+XTOL2).OR.(DI2.GT.D12+XTOL2))GOTO 2
  209. C
  210. C     ... ON ELIMINE CEUX QUI SONT TROP PRES ...
  211. C
  212.             IF((DI1.LT.XTOL2).OR.(DI2.LT.XTOL2))GOTO 2
  213. C
  214. C     ... CEUX QUI NE SONT PAS ENTRE ...
  215. C
  216.             AAA=((XXI-XX1)*(XX2-XX1)+(YYI-YY1)*(YY2-YY1))/D12
  217.             IF(AAA.LT.0.D0.OR.AAA.GT.1.D0)GOTO 2
  218. C
  219. C     ... ET CEUX QUI SONT TROP LOIN DU SEGMENT
  220. C
  221.             BBB=((XXI-XX1)-AAA*(XX2-XX1))**2
  222.      >         +((YYI-YY1)-AAA*(YY2-YY1))**2
  223.             IF(BBB.GT.XTOL2)GOTO 2
  224. C
  225. C     ON INCERE LES POINT RESTANT DANS LE MAILLAGE APRES DUPLICATION
  226. C     EVENTUELLE ...
  227. C
  228. C     PP 2001: On change un peu la filosophie: on incere le point du segm
  229. C              le plus proche du point conside. Cela ne change rien si le
  230. C              sont sans epaisseurs...
  231. C
  232. C
  233.            segact mcoord*mod
  234.            NBPTS=nbpts+1
  235.            SEGADJ MCOORD
  236.            IREF=(NBPTS-1)*(IDIM+1)
  237. C PP20001  XCOOR(IREF+1)=XXI
  238. C PP20001  XCOOR(IREF+2)=YYI
  239.            XCOOR(IREF+1)=XX1+AAA*(XX2-XX1)
  240.            XCOOR(IREF+2)=YY1+AAA*(YY2-YY1)
  241. C PP20001
  242. C 2002     XCOOR(IREF+3)=DD(IE3)
  243.            XCOOR(IREF+3)=YCOOR(IDIM+1,IE3)
  244.            IF(MELEME.EQ.MAILL(IE1))THEN
  245.              IPT1=MELEME
  246.              SEGINI,MELEME=IPT1
  247.              SEGDES,IPT1
  248.            ENDIF
  249.            NBELEM=NBELEM+1
  250.            SEGADJ, MELEME
  251.            ICOLOR(NBELEM)=ICOLOR(NBELEM-1)
  252.            IF(ITYPEL.EQ.1)THEN
  253.              IF(IE2.LT.NBELEM-1)THEN
  254.                DO IE4=NBELEM,IE2+2,-1
  255.                  NUM(1,IE4)=NUM(1,IE4-1)
  256.                ENDDO
  257.              ENDIF
  258.              NUM(1,IE2+1)=NBPTS
  259.            ELSE
  260.              DO IE4=NBELEM,IE2+1,-1
  261.                NUM(1,IE4)=NUM(1,IE4-1)
  262.                NUM(2,IE4)=NUM(2,IE4-1)
  263.              ENDDO
  264.              NUM(1,IE2+1)=NBPTS
  265.              NUM(2,IE2)=NBPTS
  266.            ENDIF
  267.  
  268. C
  269. C     ... ET ON REPASSE PAR LE NOUVEAU SEGMENT EN SORTANT DE LA BOUCLE PO
  270. C
  271.            IE2=IE2-1
  272.            GOTO 1
  273. C
  274. C     FIN BOUCLE POINT
  275. C
  276.  2        CONTINUE
  277. C
  278. C     FIN BOUCLE COTE
  279. C
  280.           GOTO 1
  281.  3      CONTINUE
  282.         IF(MELEME.EQ.MAILL(IE1))THEN
  283.           SEGDES,MELEME
  284.         ELSE
  285.           MAILL(IE1)=MELEME
  286.           SEGDES,MELEME
  287.         ENDIF
  288. C
  289. C     FIN BOUCLE BLOC
  290. C
  291.       ENDDO
  292. C
  293. C     ON CREE ET ON REMPLIT LA TABLE DE SORTIE
  294. C
  295.       IMAILL=0
  296.       MTAB1=MTABLE
  297.       SEGINI,MTABLE=MTAB1
  298.       SEGDES,MTAB1
  299.       DO IE1=1,MM
  300.         IF (MTABTI(IE1).EQ.'ENTIER  ')THEN
  301.           IMAILL=IMAILL+1
  302.           MTABIV(IE1)=MAILL(IMAILL)
  303.         ENDIF
  304.       ENDDO
  305. C
  306. C     ON REND LA MAIN A GIBIANE
  307. C
  308.       SEGSUP,BLOCOM
  309.       SEGDES,MTABLE
  310.       CALL ECROBJ('TABLE',MTABLE)
  311. C
  312.       RETURN
  313. C
  314. C     ERREURS
  315. C
  316. 9998  SEGSUP,BLOCOM
  317. 9999  SEGDES,MTABLE
  318.       RETURN
  319.       END
  320.  
  321.  
  322.  
  323.  
  324.  

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