Télécharger chv3.eso

Retour à la liste

Numérotation des lignes :

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

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