Télécharger la plaquette Cast3M


fr en

Télécharger chv2.eso

Retour à la liste

Numérotation des lignes : 

chv2

  1. C CHV2      SOURCE    CB215821  20/11/25    13:19:40     10792          
  2.       SUBROUTINE CHV2(MMATRX,ISECO,MVECTX,NOID)
  3. C
  4. C  **** SUBROUTINE QUI A PARTIR D UN OBJET DE TYPE MATRICE ET D UN
  5. C  **** CHPOINT FABRIQUE UN VECTEUR SECOND MEMBRE
  6. C  **** LE CHPOIN EST DE TYPE SECOND MEMBRE
  7. C
  8.       IMPLICIT INTEGER(I-N)
  9. -INC SMMATRI
  10. -INC SMCHPOI
  11. -INC SMELEME
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC SMVECTD
  16. -INC SMCOORD
  17.       SEGMENT,ICPR(nbpts)
  18.       SEGMENT,ICOR(NC1)
  19. C
  20.       IF(IIMPI.EQ.3) WRITE(IOIMP,1000) MMATRX,ISECO
  21.  1000 FORMAT('  SUBROUTINE CHV2 : POINTEUR DE LA MATRICE=',I5,
  22.      1                        '   POINTEUR DE L''OBJET CHPOINT=',I5)
  23. C
  24. C  ****  ACTIVATION DES SEGMENTS
  25. C
  26.       MMATRI=MMATRX
  27.       SEGACT,MMATRI
  28.       MCHPOI=ISECO
  29.       SEGACT MCHPOI
  30.       NSOUPO=IPCHP(/1)
  31.       MELEME=IGEOMA
  32.       SEGACT,MELEME
  33.       MILIGN=IILIGN
  34.       SEGACT,MILIGN
  35.       INC=IPNO(/1)
  36.       SEGDES,MILIGN
  37.       SEGINI,MVECTD
  38.       MIDUA=IIDUA
  39.       SEGACT,MIDUA
  40.       MHARK=IHARK
  41.       SEGACT,MHARK
  42.       IDU=IDUA(/2)
  43.       MINCPO=IINCPO
  44.       SEGACT,MINCPO
  45.       N2=NUM(/2)
  46. C
  47. C  **** DANS ICPR ON COMPTE LES POINTS DE MELEME
  48. C
  49.       SEGINI ICPR
  50.       DO 25 I=1,N2
  51.       ICPR(NUM(1,I))=I
  52.  25   CONTINUE
  53. C
  54. C
  55. C  ****  FABRICATION D'UN VECTEUR SECOND MEMBRE DANS MVECTD
  56. C  ****  ON VERIFIE QUE TOUTES LES COMPOSANTES DU VECTEUR EXISTENT DANS
  57. C  ****  LA MATRICE  SI NOID=0 .
  58. C
  59.       DO 1 I=1,NSOUPO
  60.       MSOUPO=IPCHP(I)
  61.       SEGACT,MSOUPO
  62.       IPT1=IGEOC
  63.       SEGACT,IPT1
  64.       NC=NOCOMP(/2)
  65.       NC1=NC
  66.       SEGINI,ICOR
  67.       DO     KKIL = 1,NC1
  68.       ICOR(KKIL)=0
  69.       ENDDO
  70.       DO 11 KI=1,NC
  71.       DO 10 J=1,IDU
  72.       IF(NOCOMP(KI).NE.IDUA(J)) GO TO 10
  73.       IF(NOHARM(KI).NE.IHAR(J)) GO TO 10
  74.       ICOR(KI)=J
  75.       GO TO 11
  76.    10 CONTINUE
  77.    11 CONTINUE
  78.       MPOVAL=IPOVAL
  79.       SEGACT,MPOVAL
  80.       N=VPOCHA(/1)
  81.       DO 20 J=1,N
  82.       K=ICPR(IPT1.NUM(1,J))
  83.       IF(K.NE.0) GO TO 4
  84.       IF(NOID.EQ.1) GO TO 20
  85. C
  86. C  ****  LE NUMERO DU NOEUD DU VECTEUR N'EXISTAIT PAS DANS LA MATRICE
  87. C
  88.       ITYP=53
  89.       INTERR(1) = IPT1.NUM(1,J)
  90.       CALL ERREUR (ITYP)
  91.       RETURN
  92.     4 CONTINUE
  93.   40  CONTINUE
  94.       DO 2 LI=1,NC
  95.       KKIL=ICOR(LI)
  96.       IF (KKIL.EQ.0) GOTO 55
  97.       KI=INCPO(KKIL,K)
  98.       IF(KI.NE.0)  GO TO 6
  99.   55  CONTINUE
  100.       IF(NOID.EQ.1) GO TO 2
  101. C
  102. C  ****  LE TYPE D'INCONNUE N'EXISTAIT PAS DANS LA MATRICE
  103. C
  104.       ITYP      = 54
  105.       MOTERR    = NOCOMP(LI)
  106.       INTERR(1) = NOHARM (LI)
  107.       INTERR(2) = IPT1.NUM(1,J)
  108.       CALL ERREUR(ITYP)
  109.       RETURN
  110.     6 CONTINUE
  111.       VECTBB(KI)=VPOCHA(J,LI)
  112.     2 CONTINUE
  113.    20 CONTINUE
  114.       SEGDES,MPOVAL
  115.       SEGDES,MSOUPO
  116.       SEGSUP,ICOR
  117.       SEGDES,IPT1
  118.     1 CONTINUE
  119.       SEGSUP ICPR
  120.       SEGDES,MELEME
  121.       SEGDES,MCHPOI
  122.       SEGDES MMATRI
  123.       SEGDES,MIDUA
  124.       SEGDES,MHARK
  125.       SEGDES,MINCPO
  126.       MVECTX=MVECTD
  127. C
  128.       IF(IIMPI.EQ.3) WRITE(IOIMP,1002)MVECTD
  129.  1002 FORMAT('  SUBROUTINE CHV2 : POINTEUR DU VECTEUR =',I5)
  130. *      SEGDES MVECTD
  131.       RETURN
  132.       END
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  

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