Télécharger la plaquette Cast3M


fr en

Télécharger ccon1.eso

Retour à la liste

Numérotation des lignes : 

ccon1

  1. C CCON1     SOURCE    CB215821  26/08/24    21:15:25     12622          
  2.       SUBROUTINE CCON1(MELEME,IRETO)
  3.       IMPLICIT INTEGER(I-N)
  4. -INC SMCOORD
  5. -INC SMELEME
  6.  
  7. -INC PPARAM
  8. -INC CCOPTIO
  9. -INC SMLENTI
  10.       REAL*8 XDE
  11.       CHARACTER*1 CHE
  12.       LOGICAL LOGE
  13.       SEGMENT ICPR(nbpts)
  14.       SEGMENT INUINV(nbpts)
  15.       SEGMENT JMEM(NODES)
  16.       SEGMENT MEMJT(NKON)
  17.       SEGMENT IPOME(NODES+1)
  18.       SEGMENT ICONC(NODES)
  19.       SEGMENT IDEJ(NODES)
  20.       SEGMENT IPRI(NODES)
  21. ***   SEGACT MELEME
  22. *
  23. *   LOGIQUE : ON PREND UN POINT PUIS TOUS LES ELEMENTS TOUCHANT
  24. * POINT PUIS ON DIT LE S NOEUDS VOISINS ET ON BOUCLE SUR LES NOEUDS
  25. * CONCERNEES NON DEJA TRAITES
  26. *
  27. * ON REGARDE L'ENSEMBLE DES NOEUDS DES NOEUDS DE MELEME ET ON CONSTRUIT
  28. * LE TABLEAU DONNANT LES ELEMENTS TOUCHANT CHAQUE NOEUD
  29. *
  30.       SEGINI ICPR,INUINV
  31.       SEGACT MELEME*MOD
  32.       IPT1=MELEME
  33.       IRETO=0
  34.       IKOU=0
  35.       DO 202 IO=1,MAX(1,LISOUS(/1))
  36.       IF (LISOUS(/1).NE.0) THEN
  37.        IPT1=LISOUS(IO)
  38.        SEGACT IPT1*MOD
  39.       ENDIF
  40.       DO 2021 I=1,IPT1.NUM(/1)
  41.       DO 203 J=1,IPT1.NUM(/2)
  42.       IJ=IPT1.NUM(I,J)
  43.       IF (ICPR(IJ).NE.0) GOTO 203
  44.        IKOU=IKOU+1
  45.       ICPR(IJ)=IKOU
  46.       INUINV(IKOU)=IJ
  47.  203  CONTINUE
  48.  2021 CONTINUE
  49.  202  CONTINUE
  50.       NODES=IKOU
  51.       SEGINI JMEM ,IPOME
  52.       IPT1=MELEME
  53.       NGRAND=0
  54.       NMAX=0
  55.       DO 3 IO=1,MAX(1,LISOUS(/1))
  56.       IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  57.       DO 2022 I=1,IPT1.NUM(/1)
  58.       DO 4 J=1,IPT1.NUM(/2)
  59.       JMEM(ICPR(IPT1.NUM(I,J)))=JMEM(ICPR(IPT1.NUM(I,J)))+1
  60.    4  CONTINUE
  61.  2022 CONTINUE
  62.       NGRAND=MAX(NGRAND,IPT1.NUM(/2))
  63.       NMAX=NMAX+IPT1.NUM(/2)
  64.    3  CONTINUE
  65.       NGRAND=NGRAND+1
  66.       IPOME(1)=0
  67.       DO 6 I=1,NODES
  68.       IPOME(I+1)=IPOME (I) + JMEM(I)
  69.    6  CONTINUE
  70.       DO 7 I=1,NODES
  71.       JMEM(I)=0
  72.    7  CONTINUE
  73.       NKON=IPOME(NODES+1)
  74.       SEGINI MEMJT
  75.       IPT1=MELEME
  76.       DO 101 IO=1,MAX(1,LISOUS(/1))
  77.       IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  78.       DO 2023 I=1,IPT1.NUM(/2)
  79.       DO 100 J=1,IPT1.NUM(/1)
  80.       IND=ICPR(IPT1.NUM(J,I))
  81.       JMEM(IND)=JMEM(IND)+1
  82.       MEMJT(IPOME(IND)+JMEM(IND))=I+NGRAND*IO
  83.  100  CONTINUE
  84.  2023 CONTINUE
  85.  101  CONTINUE
  86. *
  87. *    quelques initialisations
  88. *
  89. *      WRITE(6,FMT='(''  NODES '' ,I5)') NODES
  90.       SEGINI IDEJ,ICONC,IPRI
  91.       INDE=0
  92. *
  93. *  debut de tourner en rond.
  94. *
  95.    50 CONTINUE
  96.       DO 51 I=1,NODES
  97.       ICONC(I)=0
  98.       IPRI(I)=0
  99.    51 CONTINUE
  100.       DO 52 I=1,NODES
  101.       IF(IDEJ(I).EQ.0) GO TO 54
  102.    52 CONTINUE
  103.       GO TO 59
  104.    54 CONTINUE
  105.       IDEP=I
  106. *      WRITE(6,FMT='('' POINT DE DEPART '',I5)') IDEP
  107.       INC=1
  108.       INA=1
  109.       ICONC(INC)=IDEP
  110.       IPRI(IDEP)=1
  111.    55 CONTINUE
  112.       INO=INC
  113.       DO 57 I=INA,INO
  114.       INU=ICONC(I)
  115.       IF(IDEJ(INU).NE.0) THEN
  116.          CALL ERREUR (5)
  117.       ELSE
  118.         IDEJ(INU)=1
  119.       ENDIF
  120.       K4=JMEM(INU)
  121.       JSUB=IPOME(INU)
  122. *      WRITE(6,FMT='(''  NOEUD  NBVOIS DDEB'',3I5)')INUINV(INU),
  123. *     $  K4,JSUB
  124.       DO 40 JJ=1,K4
  125.       IND=JSUB+JJ
  126.       K6=MEMJT(IND)
  127.       IAIA= K6/NGRAND
  128.       IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  129.       SEGACT IPT1*MOD
  130.       K6=MOD(K6,NGRAND)
  131.       IF(IPT1.NUM(1,K6).LE.0)  GO TO 40
  132.       IPT1.NUM(1,K6)=-IPT1.NUM(1,K6)
  133. *      WRITE(6,FMT='(''       ELEMENT NUMERO '',I5)') K6
  134.       DO 85 L=1,IPT1.NUM(/1)
  135.       K5=ICPR(ABS(IPT1.NUM(L,K6)))
  136.       IF (IPRI(K5).GT.0) GO TO 85
  137.       INC=INC+1
  138.       ICONC(INC)=K5
  139.       IPRI(K5)=1
  140. *      WRITE(6,FMT= '('' NOEUD NUMERO '',I5)') INUINV(K5)
  141.    85 CONTINUE
  142.    40 CONTINUE
  143.    57 CONTINUE
  144.       IF(INO.NE.INC) THEN
  145. *         WRITE(6,FMT='(''  ON BOUCLE INA INO INC'',3I5)') INA,INO,INC
  146.          INA=INO+1
  147.          GO TO 55
  148.       ENDIF
  149. *
  150. *   on vient de trouver une composante connexe
  151. *
  152.    59 CONTINUE
  153. *      WRITE(6,FMT=' ('' UNE COMPOSANTE CONNEXES TROUVEE '')')
  154. *
  155. * on cree une table si pas deja fait puis remise de meleme en positif
  156. *
  157.       IF(IRETO.EQ.0) THEN
  158.         JG=1
  159.         SEGINI MLENTI
  160.         IRETO=MLENTI
  161.       ELSE
  162.         SEGACT MLENTI
  163.         JG=JG+1
  164.         SEGADJ MLENTI
  165.       ENDIF
  166.       DO 71 K=1,MAX(1,LISOUS(/1))
  167.       IF(LISOUS(/1).NE.0) IPT1=LISOUS(K)
  168.       DO 73 KI=1,IPT1.NUM(/2)
  169.       IPT1.NUM(1,KI)=ABS(IPT1.NUM(1,KI))
  170.    73 CONTINUE
  171.    71 CONTINUE
  172.       NBNN=1
  173.       NBELEM=INO
  174.       NBSOUS=0
  175.       NBREF=0
  176.       SEGINI IPT2
  177.       DO 70 I=1,INO
  178.       IPT2.NUM(1,I)=INUINV(ICONC(I))
  179.  70   CONTINUE
  180.       IPT2.ITYPEL=1
  181.        SEGDES IPT2
  182.       CALL ECRCHA('APPUYER')
  183.       CALL ECROBJ('MAILLAGE',IPT2)
  184.       CALL ECROBJ('MAILLAGE',MELEME)
  185.       CALL EXTREL (IRR,1,LIEL)
  186.       SEGSUP IPT2
  187.       CALL LIROBJ('MAILLAGE',IPT,1,IRETAY)
  188.       IF(IERR.NE.0) THEN
  189.         CALL ERREUR(5)
  190.         RETURN
  191.       ENDIF
  192.       SEGACT MELEME*MOD
  193.       DO 2020 IO=1,MAX(1,LISOUS(/1))
  194.       IF (LISOUS(/1).NE.0) THEN
  195.        IPT1=LISOUS(IO)
  196.        SEGACT IPT1*MOD
  197.       ENDIF
  198.  2020 CONTINUE
  199.       LECT(JG)=IPT
  200.       INDE=INDE+INO
  201.       IF(INDE.NE.NODES) GO TO 50
  202.  1000 CONTINUE
  203.       SEGDES MLENTI
  204.       IF(LISOUS(/1).NE.0) THEN
  205.         DO 74 K=1,LISOUS(/1)
  206.         IPT1=LISOUS(K)
  207.         SEGDES IPT1
  208.    74   CONTINUE
  209.       ENDIF
  210.       SEGDES MELEME
  211.       SEGSUP ICPR,ICONC,IDEJ,IPRI,MEMJT,JMEM,INUINV,IPOME
  212.       RETURN
  213.       END
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  

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