Télécharger chv2.eso

Retour à la liste

Numérotation des lignes :

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

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