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    PV        20/03/30    21:15:43     10567          
  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 203 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.  202  CONTINUE
  49.       NODES=IKOU
  50.       SEGINI JMEM ,IPOME
  51.       IPT1=MELEME
  52.       NGRAND=0
  53.       NMAX=0
  54.       DO 3 IO=1,MAX(1,LISOUS(/1))
  55.       IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  56.       DO 4 I=1,IPT1.NUM(/1)
  57.       DO 4 J=1,IPT1.NUM(/2)
  58.       JMEM(ICPR(IPT1.NUM(I,J)))=JMEM(ICPR(IPT1.NUM(I,J)))+1
  59.    4  CONTINUE
  60.       NGRAND=MAX(NGRAND,IPT1.NUM(/2))
  61.       NMAX=NMAX+IPT1.NUM(/2)
  62.    3  CONTINUE
  63.       NGRAND=NGRAND+1
  64.       IPOME(1)=0
  65.       DO 6 I=1,NODES
  66.       IPOME(I+1)=IPOME (I) + JMEM(I)
  67.    6  CONTINUE
  68.       DO 7 I=1,NODES
  69.       JMEM(I)=0
  70.    7  CONTINUE
  71.       NKON=IPOME(NODES+1)
  72.       SEGINI MEMJT
  73.       IPT1=MELEME
  74.       DO 101 IO=1,MAX(1,LISOUS(/1))
  75.       IF (LISOUS(/1).NE.0) IPT1=LISOUS(IO)
  76.       DO 100 I=1,IPT1.NUM(/2)
  77.       DO 100 J=1,IPT1.NUM(/1)
  78.       IND=ICPR(IPT1.NUM(J,I))
  79.       JMEM(IND)=JMEM(IND)+1
  80.       MEMJT(IPOME(IND)+JMEM(IND))=I+NGRAND*IO
  81.  100  CONTINUE
  82.  101  CONTINUE
  83. *
  84. *    quelques initialisations
  85. *
  86. *      WRITE(6,FMT='(''  NODES '' ,I5)') NODES
  87.       SEGINI IDEJ,ICONC,IPRI
  88.       INDE=0
  89. *
  90. *  debut de tourner en rond.
  91. *
  92.    50 CONTINUE
  93.       DO 51 I=1,NODES
  94.       ICONC(I)=0
  95.       IPRI(I)=0
  96.    51 CONTINUE
  97.       DO 52 I=1,NODES
  98.       IF(IDEJ(I).EQ.0) GO TO 54
  99.    52 CONTINUE
  100.       GO TO 59
  101.    54 CONTINUE
  102.       IDEP=I
  103. *      WRITE(6,FMT='('' POINT DE DEPART '',I5)') IDEP
  104.       INC=1
  105.       INA=1
  106.       ICONC(INC)=IDEP
  107.       IPRI(IDEP)=1
  108.    55 CONTINUE
  109.       INO=INC
  110.       DO 57 I=INA,INO
  111.       INU=ICONC(I)
  112.       IF(IDEJ(INU).NE.0) THEN
  113.          CALL ERREUR (5)
  114.       ELSE
  115.         IDEJ(INU)=1
  116.       ENDIF
  117.       K4=JMEM(INU)
  118.       JSUB=IPOME(INU)
  119. *      WRITE(6,FMT='(''  NOEUD  NBVOIS DDEB'',3I5)')INUINV(INU),
  120. *     $  K4,JSUB
  121.       DO 40 JJ=1,K4
  122.       IND=JSUB+JJ
  123.       K6=MEMJT(IND)
  124.       IAIA= K6/NGRAND
  125.       IF(LISOUS(/1).NE.0) IPT1=LISOUS(IAIA)
  126.       SEGACT IPT1*MOD
  127.       K6=MOD(K6,NGRAND)
  128.       IF(IPT1.NUM(1,K6).LE.0)  GO TO 40
  129.       IPT1.NUM(1,K6)=-IPT1.NUM(1,K6)
  130. *      WRITE(6,FMT='(''       ELEMENT NUMERO '',I5)') K6
  131.       DO 85 L=1,IPT1.NUM(/1)
  132.       K5=ICPR(ABS(IPT1.NUM(L,K6)))
  133.       IF (IPRI(K5).GT.0) GO TO 85
  134.       INC=INC+1
  135.       ICONC(INC)=K5
  136.       IPRI(K5)=1
  137. *      WRITE(6,FMT= '('' NOEUD NUMERO '',I5)') INUINV(K5)
  138.    85 CONTINUE
  139.    40 CONTINUE
  140.    57 CONTINUE
  141.       IF(INO.NE.INC) THEN
  142. *         WRITE(6,FMT='(''  ON BOUCLE INA INO INC'',3I5)') INA,INO,INC
  143.          INA=INO+1
  144.          GO TO 55
  145.       ENDIF
  146. *
  147. *   on vient de trouver une composante connexe
  148. *
  149.    59 CONTINUE
  150. *      WRITE(6,FMT=' ('' UNE COMPOSANTE CONNEXES TROUVEE '')')
  151. *
  152. * on cree une table si pas deja fait puis remise de meleme en positif
  153. *
  154.       IF(IRETO.EQ.0) THEN
  155.         JG=1
  156.         SEGINI MLENTI
  157.         IRETO=MLENTI
  158.       ELSE
  159.         SEGACT MLENTI
  160.         JG=JG+1
  161.         SEGADJ MLENTI
  162.       ENDIF
  163.       DO 71 K=1,MAX(1,LISOUS(/1))
  164.       IF(LISOUS(/1).NE.0) IPT1=LISOUS(K)
  165.       DO 73 KI=1,IPT1.NUM(/2)
  166.       IPT1.NUM(1,KI)=ABS(IPT1.NUM(1,KI))
  167.    73 CONTINUE
  168.    71 CONTINUE
  169.       NBNN=1
  170.       NBELEM=INO
  171.       NBSOUS=0
  172.       NBREF=0
  173.       SEGINI IPT2
  174.       DO 70 I=1,INO
  175.       IPT2.NUM(1,I)=INUINV(ICONC(I))
  176.  70   CONTINUE
  177.       IPT2.ITYPEL=1
  178.        SEGDES IPT2
  179.       CALL ECRCHA('APPUYER')
  180.       CALL ECROBJ('MAILLAGE',IPT2)
  181.       CALL ECROBJ('MAILLAGE',MELEME)
  182.       CALL EXTREL (IRR,1,LIEL)
  183.       SEGSUP IPT2
  184.       CALL LIROBJ('MAILLAGE',IPT,1,IRETAY)
  185.       IF(IERR.NE.0) THEN
  186.         CALL ERREUR(5)
  187.         RETURN
  188.       ENDIF
  189.       SEGACT MELEME*MOD
  190.       DO 2020 IO=1,MAX(1,LISOUS(/1))
  191.       IF (LISOUS(/1).NE.0) THEN
  192.        IPT1=LISOUS(IO)
  193.        SEGACT IPT1*MOD
  194.       ENDIF
  195.  2020 CONTINUE
  196.       LECT(JG)=IPT
  197.       INDE=INDE+INO
  198.       IF(INDE.NE.NODES) GO TO 50
  199.  1000 CONTINUE
  200.       SEGDES MLENTI
  201.       IF(LISOUS(/1).NE.0) THEN
  202.         DO 74 K=1,LISOUS(/1)
  203.         IPT1=LISOUS(K)
  204.         SEGDES IPT1
  205.    74   CONTINUE
  206.       ENDIF
  207.       SEGDES MELEME
  208.       SEGSUP ICPR,ICONC,IDEJ,IPRI,MEMJT,JMEM,INUINV,IPOME
  209.       RETURN
  210.       END
  211.  
  212.  
  213.  
  214.  
  215.  

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