Télécharger la plaquette Cast3M


fr en

Télécharger prdiff.eso

Retour à la liste

Numérotation des lignes : 

prdiff

  1. C PRDIFF    SOURCE    SP204843  24/04/26    21:15:01     11921          
  2. C    INTERFACE ENTRE LA DIRECTIVE "DIFF" (DIFFERENCE SYMETRIQUE) ET LE
  3. C    SOUS PROGRAMME OUEXCL
  4. C
  5. C    Modif : 2014 C. BERTHINIER
  6. C            Dans le cas de la DIFF de 2 MELEME SIMPLE du meme TYPE, si
  7. C            Le résultat est VIDE il est du même type que le MELEME
  8. C            SIMPLE donné en argument
  9. C
  10.       SUBROUTINE PRDIFF
  11.  
  12.       IMPLICIT INTEGER(I-N)
  13.  
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMELEME
  18. -INC SMMODEL
  19. -INC SMRIGID
  20.  
  21. C
  22. C---- OBJETS DE TYPE RIGIDITE
  23. C
  24.       CALL LIROBJ('RIGIDITE',IPRIG1,0,IRETOU)
  25.       IF (IERR.NE.0) RETURN
  26.  
  27.       IF (IRETOU.EQ.1) THEN
  28.  
  29.         CALL LIROBJ('RIGIDITE',IPRIG2,1,IRETOU)
  30.         IF (IERR.NE.0) RETURN
  31.  
  32.         CALL DIFRIG(IPRIG1,IPRIG2)
  33.         RETURN
  34.  
  35.       ENDIF
  36.  
  37. C
  38. C---- OBJETS DE TYPE MODELE
  39. C
  40.       CALL LIROBJ('MMODEL',IPMOD1,0,IRETOU)
  41.       IF (IERR.NE.0) RETURN
  42.  
  43.       IF (IRETOU.EQ.1) THEN
  44.  
  45.         CALL LIROBJ('MMODEL',IPMOD2,1,IRETOU)
  46.         IF (IERR.NE.0) RETURN
  47.  
  48.         CALL DIFMOD(IPMOD1,IPMOD2)
  49.         RETURN
  50.  
  51.       ENDIF
  52.  
  53. C
  54. C---- OBJETS DE TYPE MAILLAGE 
  55. C
  56.       NBSOUS =0
  57.  
  58.       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  59.       IF (IERR.NE.0) RETURN
  60.       CALL ACTOBJ('MAILLAGE',IPT1,1)
  61.       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  62.       IF (IERR.NE.0) RETURN
  63.       CALL ACTOBJ('MAILLAGE',IPT2,1)
  64.  
  65.       IF (IPT1.LISOUS(/1).NE.0) GOTO 10
  66.       IF (IPT2.LISOUS(/1).NE.0) GOTO 11
  67.  
  68.  
  69. C     Cas ou 1 des deux maillages est vide :
  70.       IF (IPT1.NUM(/2).EQ.0) THEN
  71.         IPT3 = IPT2
  72.         GOTO 9000
  73.       ENDIF
  74.       IF (IPT2.NUM(/2).EQ.0) THEN
  75.         IPT3 = IPT1
  76.         GOTO 9000
  77.       ENDIF
  78.  
  79.       IF ((IPT1.ITYPEL  .EQ. IPT2.ITYPEL) .AND.
  80.      &     (IPT1.NUM(/1) .EQ. IPT2.NUM(/1))     ) THEN
  81. C     Cas de deux MAILLAGES SIMPLES, de même TYPE et même NBNN
  82.  
  83.         IF (IPT1.EQ.IPT2) THEN
  84. C     Les deux maillages sont identiques : résultat vide du même type
  85.            ity=ipt1.itypel
  86.            call melvid(ity,IPT3)
  87.         ELSE
  88. C         OU Exclusif sur IPT1 et IPT2
  89.            CALL OUEXCL(IPT1,IPT2,IPT3)
  90.  
  91.            IF (IPT3.EQ.0) THEN
  92. C         le résultat est vide on lui met le même type
  93.               ity=ipt1.itypel
  94.               call melvid(ity,IPT3)
  95.            ENDIF
  96.         ENDIF
  97.       ELSE
  98. C     Cas de deux MAILLAGES SIMPLES, de TYPE ou NBNN différent
  99. C     Adjonction directe des deux sous-maillages simples de structure différente
  100. C     C'est le cas des maillages polyedriques dont NBNN peut varier pour le même ITYPEL
  101.         NBELEM =0
  102.         NBNN   =0
  103.         NBREF  =0
  104.         NBSOUS =2
  105.         SEGINI IPT3
  106.         IPT3.LISOUS(1)=IPT1
  107.         IPT3.LISOUS(2)=IPT2
  108.       ENDIF
  109.  
  110.       IF (IERR.NE.0) RETURN
  111.       GOTO 1000
  112.  
  113.  
  114.  
  115. C     Cas d'un MAILLAGE SIMPLE et l'autre COMPLEXE
  116.  
  117. C     On intervertit pour que le premier soit le MAILLAGE COMPLEXE
  118. C      IPT1 : MELEME COMPLEXE
  119. C      IPT2 : MELEME SIMPLE
  120.   10  IF (IPT2.LISOUS(/1).NE.0) GOTO 20
  121.       GOTO 12
  122.  
  123.   11  IP=IPT2
  124.       IPT2=IPT1
  125.       IPT1=IP
  126.  
  127.   12  CONTINUE
  128.       DO 13 IS=1,IPT1.LISOUS(/1)
  129.          IPT4=IPT1.LISOUS(IS)
  130.          IF (IPT2.NUM(/1).EQ.IPT4.NUM(/1)) THEN
  131.             IF (IPT2.ITYPEL.EQ.IPT4.ITYPEL) GOTO 14
  132.          ENDIF
  133.   13  CONTINUE
  134.  
  135.       NBELEM=0
  136.       NBNN  =0
  137.       NBREF =0
  138.       NBSOU1=IPT1.LISOUS(/1)
  139.       NBSOUS=NBSOU1+1
  140.       SEGINI IPT3
  141.  
  142. C     LES MELEME SIMPLES de IPT1 et IPT2 sont placés dans IPT3
  143.       DO 15 IS=1,NBSOU1
  144.          IPT3.LISOUS(IS)=IPT1.LISOUS(IS)
  145.   15  CONTINUE
  146.  
  147.       IPT3.LISOUS(NBSOUS)=IPT2
  148.       GOTO 1000
  149.  
  150.   14  IF (IPT2.EQ.IPT4) GOTO 17
  151.  
  152.       CALL OUEXCL(IPT2,IPT4,IPT5)
  153.       IF (IERR.NE.0) RETURN
  154.       IF (IPT5.EQ.0) GOTO 17
  155.  
  156.       NBSOUS=IPT1.LISOUS(/1)
  157.       NBNN=0
  158.       NBREF=0
  159.       NBELEM=0
  160.       SEGINI IPT3
  161.       DO 16 IS2=1,NBSOUS
  162.          IPT3.LISOUS(IS2)=IPT1.LISOUS(IS2)
  163.          IF (IS.EQ.IS2) IPT3.LISOUS(IS2)=IPT5
  164.   16  CONTINUE
  165.       GOTO 1000
  166.  
  167.   17  CONTINUE
  168.  
  169. C-------- Cas d'un maillage vide ---------------------------------
  170.  
  171.       NBSOUS=IPT1.LISOUS(/1)
  172.       IF (NBSOUS.EQ.0) THEN
  173.          CALL melvid(0,ipt3)
  174.       ELSE
  175.          NBNN  =0
  176.          NBREF =0
  177.          NBELEM=0
  178.          NBSOUS=IPT1.LISOUS(/1)-1
  179.          SEGINI IPT3
  180.          IS3=0
  181.          DO 18 IS2=1,(NBSOUS + 1)
  182.             IF (IS2.EQ.IS) GOTO 18
  183.             IS3=IS3+1
  184.             IPT3.LISOUS(IS3)=IPT1.LISOUS(IS2)
  185.  18      CONTINUE
  186.       ENDIF
  187.  
  188.       GOTO 1000
  189.  
  190. C---- Les deux maillages entrés sont complexes
  191.   20  CONTINUE
  192.       NBSOU1=IPT1.LISOUS(/1)
  193.       NBSOU2=IPT2.LISOUS(/1)
  194.       NBELEM=0
  195.       NBNN  =0
  196.       NBREF =0
  197.       NBSOUS=NBSOU1+NBSOU2
  198.       SEGINI IPT4
  199.       DO 21 I1=1,NBSOU1
  200.          IPT4.LISOUS(I1)=IPT1.LISOUS(I1)
  201.   21  CONTINUE
  202.       ISUP=0
  203.       DO 22 I2=1,NBSOU2
  204.          IPT5=IPT2.LISOUS(I2)
  205.          ITYP=IPT5.ITYPEL
  206.          DO 23 I1=1,NBSOU1
  207.             IPT6=IPT4.LISOUS(I1)
  208.             IF (IPT6.EQ.0) GOTO 23
  209.  
  210.             IF (IPT6.ITYPEL .NE. ITYP)        GOTO 23
  211.             IF (IPT6.NUM(/1).NE.IPT5.NUM(/1)) GOTO 23
  212.             IF (IPT5.EQ.IPT6)                 GOTO 25
  213.  
  214.             CALL OUEXCL(IPT5,IPT6,IPT7)
  215.             IF (IERR.NE.0) RETURN
  216.             IF (IPT7.EQ.0) GOTO 25
  217.             IPT4.LISOUS(I1)=IPT7
  218.             IPT4.LISOUS(NBSOU1+I2)=0
  219.             ISUP=ISUP+1
  220.             GOTO 22
  221.  
  222.   25        ISUP=ISUP+2
  223.             IPT4.LISOUS(I1)=0
  224.             IPT4.LISOUS(NBSOU1+I2)=0
  225.             GOTO 22
  226.   23     CONTINUE
  227.          IPT4.LISOUS(NBSOU1+I2)=IPT5
  228.   22  CONTINUE
  229.  
  230.       IF (ISUP.EQ.0) GOTO 30
  231.       NBSOUS=NBSOUS-ISUP
  232.  
  233. C-------- Cas d'un maillage vide ---------------------------------
  234.  
  235.       IF (NBSOUS.EQ.0) THEN
  236.          call melvid(0,ipt3)
  237.          segact ipt3
  238.          GOTO 1000
  239.       ENDIF
  240.  
  241.       SEGINI IPT3
  242.       JS=0
  243.       DO 35 IS=1,NBSOUS
  244.   36     JS=JS+1
  245.          IF (IPT4.LISOUS(JS).EQ.0) GOTO 36
  246.          IPT3.LISOUS(IS)=IPT4.LISOUS(JS)
  247.   35  CONTINUE
  248.       SEGSUP IPT4
  249.       IF (NBSOUS.NE.1) GOTO 1000
  250.  
  251.       IPT4=IPT3.LISOUS(1)
  252.       SEGSUP IPT3
  253.   30  IPT3=IPT4
  254.  
  255.  1000 CONTINUE
  256.  
  257. C
  258. C     Nettoyage du maillage dans le cas ou il contient des sous-parties vides
  259. C
  260.       NBSOUS = IPT3.LISOUS(/1)
  261.       IF (NBSOUS .NE. 0) THEN
  262. C     Cas du maillage résultat ayant plusieurs sous zones
  263.         DO 1010 I=1,IPT3.LISOUS(/1)
  264.           MELEME = IPT3.LISOUS(I)
  265.           IF (NUM(/2) .EQ. 0) THEN
  266. C         la sous partie vide est supprimée + tassement du tableau LISOUS
  267.             DO 1020 J=I+1,IPT3.LISOUS(/1)
  268.               IPT3.LISOUS(J-1)=IPT3.LISOUS(J)
  269.  1020       CONTINUE
  270.  
  271.             NBSOUS = NBSOUS - 1
  272.           ENDIF
  273.  
  274.  1010   CONTINUE
  275.  
  276.         IF ( NBSOUS .EQ. 0 ) THEN
  277.            call melvid(0,ipt3)
  278.         ELSEIF ( NBSOUS .EQ. 1 ) THEN
  279. C       Passage en MELEME SIMPLE à nouveau
  280.            IPT3 = IPT3.LISOUS(1)
  281.            IF(IPT3.NUM(/2) .EQ. 0) THEN
  282.               call melvid(0,ipt3)
  283.            ENDIF
  284.         ELSEIF ( NBSOUS .NE. IPT3.LISOUS(/1) ) THEN
  285. C     Le segment MELEME COMPLEXE est ajusté
  286.            NBNN   = 0
  287.            NBELEM = 0
  288.            NBREF  = 0
  289.            SEGADJ IPT3
  290.         ENDIF
  291.       ENDIF
  292.  
  293.  9000 CONTINUE
  294.       CALL ACTOBJ('MAILLAGE',IPT3,1)
  295.       CALL ECROBJ('MAILLAGE',IPT3)
  296.  
  297.       END
  298.  
  299.  
  300.  
  301.  
  302.  
  303.  
  304.  
  305.  

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