Télécharger etalch.eso

Retour à la liste

Numérotation des lignes :

  1. C ETALCH SOURCE CB215821 19/07/30 21:16:07 10273
  2. SUBROUTINE ETALCH(MCHPOI,IINC,ICPR,ICONTR,MVA,IPB,NPR2,ICODE)
  3. C
  4. C=======================================================================
  5. C CE SUBROUTINE ETALE LE CHPOINT DANS LE TABLEAU MVA
  6. C
  7. C ***** ENTREES *****
  8. C IINC : LISTE DES COMPOSANTES DU TABLEAU
  9. C ICPR(I)=KI : LE NOEUD I EST LE KI^IEME POINT DU TABLEAU MVA
  10. C si ICODE=1, ON VERIFIE QUE LES POINTS DE MCHPOI MUNIS DE LEUR
  11. C COMPOSANTES (indice K) SONT CONTENUS DANS MVA,
  12. C C.A.D. QUE MCONTR(K,KI)=1 POUR CES POINTS
  13. C
  14. C ***** SORTIES *****
  15. C LES VALEURS DE MVA DANS LE CHPOINT
  16. C EVENTUELLEMENT IPB LE TABLEAU DE CORRESPONDANCE DES POINTS
  17. C IPB(I)=IK LE IEME POINT DU CHPOINT EST A LA PLACE IK DANS MVA
  18. C NPR2 = NOMBRE DE POINTS TOTAL DU MCHPOI
  19. C
  20. C ATTENTION : SEGACT MVA,IPB ET MISE A ZERO DE CES 2 TABLEAUX AVANT
  21. C UTILISATION.
  22. C=======================================================================
  23. IMPLICIT INTEGER(I-N)
  24. -INC CCOPTIO
  25. -INC SMCHPOI
  26. -INC SMELEME
  27. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  28. SEGMENT IINC
  29. CHARACTER*4 CIINC(0)
  30. ENDSEGMENT
  31. SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA
  32. SEGMENT/ICONTR/(MCONTR(NNI1,IPR1))
  33. SEGMENT IPB(IPR1)
  34.  
  35. C---- Activation des segments utiles ----
  36.  
  37. NNI1=VA(/1)
  38. IPR1=VA(/2)
  39. NPR2=0
  40.  
  41. C---- Mise a 0 de VA et de IPB----
  42.  
  43. DO 1 J=1,IPR1
  44. DO 1 K=1,NNI1
  45. VA(K,J)=0.D0
  46. 1 CONTINUE
  47. C
  48. IF(IPB.EQ.0) GOTO 2
  49. DO 3 J=1,IPR1
  50. IPB(J)=0
  51. 3 CONTINUE
  52. 2 CONTINUE
  53.  
  54. C---- Boucle sur les zones du CHPOINT ----
  55.  
  56. NSOUP=IPCHP(/1)
  57. DO 60 ISOUP=1,NSOUP
  58.  
  59. MSOUPO=IPCHP(ISOUP)
  60. MELEME=IGEOC
  61. N2=NUM(/2)
  62. MPOVAL=IPOVAL
  63.  
  64. C ---- Boucle sur les composantes du CHPOINT ----
  65.  
  66. DO 61 J=1,NOCOMP(/2)
  67.  
  68. DO 62 K=1,NNI1
  69. IF(NOCOMP(J).EQ.CIINC(K)) GOTO 63
  70. 62 CONTINUE
  71. c si on n'a pas trouvé la J eme composante dans CIINC,
  72. c -> on essaie la prochaine
  73. IF(ICODE.EQ.0) GOTO 61
  74. c -> ou erreur
  75. WRITE(IOIMP,*) 'NOCOMP(',J,')=',NOCOMP(J),'n existe pas dans:'
  76. WRITE(IOIMP,*) 'CIINC=',(CIINC(iou),iou=1,NNI1)
  77. IJ=1
  78. GOTO 66
  79. c J eme composante dans CIINC(K)
  80. 63 CONTINUE
  81.  
  82. IF(IPB.NE.0) GOTO 65
  83.  
  84. c - si IPB n'existe pas, on verifie que MCONTR=1 et on remplit VA
  85. DO 64 IJ=1,N2
  86. KI=ICPR(NUM(1,IJ))
  87. IF(KI.EQ.0) THEN
  88. IF(ICODE.EQ.0) GOTO 64
  89. WRITE(IOIMP,*) IJ,'ieme NOEUD #',NUM(1,IJ),'n existe pas',
  90. & ' dans l ICPR'
  91. GOTO 66
  92. ENDIF
  93. IF(MCONTR(K,KI).NE.1) THEN
  94. IF(ICODE.EQ.0) GOTO 64
  95. GOTO 66
  96. ENDIF
  97. VA(K,KI)=VPOCHA(IJ,J)
  98. 64 CONTINUE
  99. GOTO 61
  100.  
  101. c - si IPB existe, on le remplit aussi
  102. 65 CONTINUE
  103. c boucle 74 = copie de la boucle 64 avec remplissage de IPB en +
  104. DO 74 IJ=1,N2
  105. KI=ICPR(NUM(1,IJ))
  106. IF(KI.EQ.0) THEN
  107. IF(ICODE.EQ.0) GOTO 74
  108. WRITE(IOIMP,*) IJ,'ieme NOEUD #',NUM(1,IJ),'n existe pas',
  109. & ' dans l ICPR'
  110. GOTO 66
  111. ENDIF
  112. IF(MCONTR(K,KI).NE.1) THEN
  113. IF(ICODE.EQ.0) GOTO 74
  114. GOTO 66
  115. ENDIF
  116. IF(J.EQ.1) IPB(NPR2+IJ)=KI
  117. VA(K,KI)=VPOCHA(IJ,J)
  118. 74 CONTINUE
  119. GOTO 61
  120.  
  121. c - ERREUR -
  122. 66 CONTINUE
  123. MOTERR(1:4)=NOCOMP(J)
  124. INTERR(1)=NUM(1,IJ)
  125. CALL ERREUR(140)
  126. C INCOMPATIBILITE ENTRE LES POINTS ET COMPOSANTES DES 2 CHPOINTS
  127. GOTO 5000
  128.  
  129. 61 CONTINUE
  130. C ---- Fin de Boucle sur les comosantes du CHPOINT ----
  131. NPR2=NPR2+N2
  132.  
  133. 60 CONTINUE
  134. C---- Fin de Boucle sur les zones du CHPOINT ----
  135. C
  136. C---- DesActivation des segments utiles et return ----
  137. 5000 CONTINUE
  138. END
  139.  
  140.  
  141.  

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