Télécharger excoc1.eso

Retour à la liste

Numérotation des lignes :

  1. C EXCOC1 SOURCE PV 11/04/08 21:15:52 6936
  2. SUBROUTINE EXCOC1(IPCH1,MOT,IPCH2,MOT2,IVID)
  3. *-----------------------------------------------------------------------
  4. * EXTRACTION D UNE COMPOSANTE D UN NOUVEAU CHAMELEM
  5. * ROUTINE APPELLEE PAR L OPERATEUR EXCOMP
  6. * ENTREE
  7. * IPCH1= POINTEUR SUR UN CHAMELEM
  8. * MOT = NOM DE LA COMPOSANTE A EXTRAIRE
  9. * MOT2 = NOM DE LA COMPOSANTE
  10. * IVID = 1 SI ON A LU LE MOT 'NOID', 0 SINON
  11. * SORTIE
  12. * IPCH2= POINTEUR SUR LE CHPOINT CONTENANT UNIQUEMENT LA
  13. * COMPOSANTE MOT2
  14. *-----------------------------------------------------------------------
  15. IMPLICIT INTEGER(I-N)
  16. IMPLICIT REAL*8(A-H,O-Z)
  17. CHARACTER*4 MOT,MOT2
  18. CHARACTER*8 LEMOT
  19. -INC SMCHAML
  20. -INC CCOPTIO
  21. *
  22. SEGMENT MTRI
  23. INTEGER IPOI(n1l)
  24. ENDSEGMENT
  25. SEGMENT MTRA
  26. INTEGER LRAN(n1l)
  27. ENDSEGMENT
  28. SEGMENT MTRB
  29. CHARACTER*16 TYPT(n1l)
  30. ENDSEGMENT
  31. *
  32. MCHEL1=IPCH1
  33. SEGACT MCHEL1
  34. NZON1=MCHEL1.ICHAML(/1)
  35. *
  36. * INITIALISATION DES SEGMENTS DE TRAVAIL
  37. *
  38. n1=0
  39. n1l=500
  40. SEGINI MTRI,MTRA,MTRB
  41. *
  42. * BOUCLE SUR LES ZONES
  43. *
  44. DO 100 IA=1,NZON1
  45. MCHAM1=MCHEL1.ICHAML(IA)
  46. SEGACT MCHAM1
  47. NCP=MCHAM1.NOMCHE(/2)
  48. DO 110 IB=1,NCP
  49. LEMOT=MCHAM1.NOMCHE(IB)
  50. IF (MOT.EQ.LEMOT(1:4)) THEN
  51. IBCOM=IB
  52. GOTO 120
  53. ENDIF
  54. 110 CONTINUE
  55. *pv SEGDES MCHAM1
  56. GOTO 100
  57. *
  58. 120 CONTINUE
  59. MELVA1=MCHAM1.IELVAL(IBCOM)
  60. SEGACT MELVA1
  61. SEGINI,MELVAL=MELVA1
  62. *pv SEGDES MELVA1
  63. n1=n1+1
  64. if (n1.gt.n1l) then
  65. n1l=n1l+500
  66. segadj mtri,mtra,mtrb
  67. endif
  68. IPOI(n1)=MELVAL
  69. LRAN(n1)=IA
  70. TYPT(n1)=MCHAM1.TYPCHE(IBCOM)
  71. *pv SEGDES MELVAL,MCHAM1
  72. SEGDES MELVAL
  73. 100 CONTINUE
  74. *
  75. * ON REMPLIT LE CHAMELEM
  76. *
  77. L1=mchel1.titche(/1)
  78. *** N1=IPOI(/1)
  79. N3=MCHEL1.INFCHE(/2)
  80. N2=1
  81. *
  82. IF (N1.EQ.0) THEN
  83. IF (IVID.EQ.1) THEN
  84. SEGINI MCHELM
  85. IPCH2 = MCHELM
  86. TITCHE= mchel1.titche
  87. IFOCHE=MCHEL1.IFOCHE
  88. *pv SEGDES MCHELM
  89. SEGDES MCHELM
  90. ELSE
  91. MOTERR(1:4)=MOT
  92. CALL ERREUR(236)
  93. ENDIF
  94. GOTO 666
  95. ENDIF
  96. *
  97. * CREATION DU CHAPEAU DU CHAMELEM
  98. *
  99. SEGINI MCHELM
  100. IPCH2=MCHELM
  101. TITCHE=mchel1.titche
  102. IFOCHE=MCHEL1.IFOCHE
  103. *
  104. * BOUCLE SUR LES ZONES
  105. *
  106. DO 400 IA=1,N1
  107. IACON=LRAN(IA)
  108. DO 401 IAA=1,N3
  109. INFCHE(IA,IAA)=MCHEL1.INFCHE(IACON,IAA)
  110. 401 CONTINUE
  111. IMACHE(IA)=MCHEL1.IMACHE(IACON)
  112. CONCHE(IA)=MCHEL1.CONCHE(IACON)
  113. SEGINI,MCHAML
  114. ICHAML(IA)=MCHAML
  115. LEMOT(1:4)=MOT2
  116. NOMCHE(1)=LEMOT
  117. TYPCHE(1)=TYPT(IA)
  118. IELVAL(1) = IPOI(IA)
  119. *pv SEGDES,MCHAML
  120. SEGDES,MCHAML
  121. 400 CONTINUE
  122. *pv SEGDES MCHELM
  123. SEGDES MCHELM
  124. *
  125. 666 CONTINUE
  126. *
  127. * SUPPRESSION DES SEGMENTS DE TRAVAIL
  128. *
  129. SEGSUP MTRI,MTRA,MTRB
  130. *pv SEGDES MCHEL1
  131. RETURN
  132. END
  133.  
  134.  
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141.  
  142.  

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