Télécharger chv1.eso

Retour à la liste

Numérotation des lignes :

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

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