Télécharger excoc1.eso

Retour à la liste

Numérotation des lignes :

excoc1
  1. C EXCOC1 SOURCE OF166741 23/07/05 21:15:04 11699
  2.  
  3. *-----------------------------------------------------------------------
  4. * EXTRACTION D UNE COMPOSANTE D UN NOUVEAU CHAMELEM
  5. * ROUTINE APPELLEE PAR L OPERATEUR EXCOMP
  6. * ENTREE
  7. * IPCH1= POINTEUR SUR UN MCHAML (ACTIF)
  8. * MOT1 = NOM DE LA COMPOSANTE A EXTRAIRE
  9. * MOT2 = NOM DE LA COMPOSANTE A CREER
  10. * IVID = 1 SI ON A LU LE MOT 'NOID', 0 SINON
  11. * SORTIE
  12. * IPCH2= POINTEUR SUR LE MCHAML CONTENANT UNIQUEMENT LA
  13. * COMPOSANTE MOT2
  14. *-----------------------------------------------------------------------
  15. SUBROUTINE EXCOC1(IPCH1,MOT1,IPCH2,MOT2,IVID)
  16.  
  17. IMPLICIT INTEGER(I-N)
  18. IMPLICIT REAL*8(A-H,O-Z)
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22.  
  23. -INC SMCHAML
  24.  
  25. CHARACTER*(*) MOT1,MOT2
  26.  
  27. SEGMENT MTRI
  28. INTEGER IPOI(n1l)
  29. INTEGER LRAN(n1l)
  30. CHARACTER*16 TYPT(n1l)
  31. ENDSEGMENT
  32.  
  33. IPCH2 = 0
  34. *
  35. * INITIALISATION DU SEGMENT DE TRAVAIL
  36. *
  37. n1l=500
  38. SEGINI,MTRI
  39. *
  40. * BOUCLE SUR LES ZONES
  41. *
  42. MCHEL1 = IPCH1
  43.  
  44. L1 =MCHEL1.TITCHE(/1)
  45. N3 =MCHEL1.INFCHE(/2)
  46. NZON1=MCHEL1.ICHAML(/1)
  47.  
  48. N1=0
  49. DO IA = 1, NZON1
  50. MCHAM1=MCHEL1.ICHAML(IA)
  51. NCP=MCHAM1.NOMCHE(/2)
  52. CALL PLACE(MCHAM1.NOMCHE(1),NCP,IBCOM,MOT1)
  53. IF (IBCOM.NE.0) THEN
  54. N1=N1+1
  55. if (N1.gt.n1l) then
  56. n1l=n1l+500
  57. segadj mtri
  58. endif
  59. ** On ne duplique pas le melval
  60. ** melva1=MCHAM1.IELVAL(IBCOM)
  61. ** segini,melval=melva1
  62. ** IPOI(N1)=melval
  63. IPOI(N1)=MCHAM1.IELVAL(IBCOM)
  64. LRAN(N1)=IA
  65. TYPT(N1)=MCHAM1.TYPCHE(IBCOM)
  66. ENDIF
  67. ENDDO
  68.  
  69. IF (N1.EQ.0 .AND. IVID.NE.1) THEN
  70. MOTERR(1:8)=MOT1
  71. CALL ERREUR(236)
  72. GOTO 666
  73. ENDIF
  74. *
  75. * CREATION DU CHAPEAU DU MCHELM A 1 COMPOSANTE
  76. *
  77. SEGINI,MCHELM
  78. TITCHE=MCHEL1.TITCHE
  79. IFOCHE=MCHEL1.IFOCHE
  80. IPCH2 = MCHELM
  81.  
  82. N2=1
  83.  
  84. * ON REMPLIT LE MCHELM - BOUCLE SUR LES ZONES
  85. *
  86. DO IA = 1, N1
  87. SEGINI,MCHAML
  88. NOMCHE(1)=MOT2
  89. TYPCHE(1)=TYPT(IA)
  90. IELVAL(1)=IPOI(IA)
  91. IACON=LRAN(IA)
  92. DO IB = 1, N3
  93. INFCHE(IA,IB)=MCHEL1.INFCHE(IACON,IB)
  94. ENDDO
  95. IMACHE(IA)=MCHEL1.IMACHE(IACON)
  96. CONCHE(IA)=MCHEL1.CONCHE(IACON)
  97. ICHAML(IA)=MCHAML
  98. ENDDO
  99.  
  100. * SUPPRESSION DES SEGMENTS DE TRAVAIL
  101. *
  102. 666 CONTINUE
  103. SEGSUP MTRI
  104.  
  105. c RETURN
  106. END
  107.  
  108.  
  109.  

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