Télécharger actich.eso

Retour à la liste

Numérotation des lignes :

  1. C ACTICH SOURCE PV 09/03/12 21:15:07 6325
  2. SUBROUTINE ACTICH(FLOT,IPCH1,IPCH2,IPCH3,MACOMP,IPCH4)
  3.  
  4. C--------------------------------------------------------------------
  5. C ACCELERATION SUR UNE COMPOSANTE D'UN CHAMELEM
  6. C--------------------------------------------------------------------
  7. IMPLICIT INTEGER(I-N)
  8. IMPLICIT REAL*8(A-H,O-Z)
  9. -INC SMCHAML
  10. -INC CCOPTIO
  11. *
  12. SEGMENT NOMID
  13. CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC)
  14. ENDSEGMENT
  15. *
  16. SEGMENT NOTYPE
  17.  
  18. CHARACTER*16 TYPE(NBTYPE)
  19. ENDSEGMENT
  20. *
  21. SEGMENT MPTVAL
  22. INTEGER IPOS(NS) ,NSOF(NS)
  23. INTEGER IVAL(NCOSOU)
  24. CHARACTER*16 TYVAL(NCOSOU)
  25. ENDSEGMENT
  26. *
  27. PARAMETER ( NINF=3 )
  28. INTEGER INFOS(NINF)
  29. CHARACTER*4 MACOMP
  30. CHARACTER*16 MOT1,MOT2,MOT3
  31. CHARACTER*(nconch) CONM
  32. *
  33. *
  34. * Verification du lieu support des MCHAMLs
  35. *
  36. CALL QUESUP (0,IPCH1,0,0,ISUP1,IRET1)
  37. IF(IERR.NE.0)RETURN
  38. CALL QUESUP (0,IPCH2,0,0,ISUP2,IRET2)
  39. IF(IERR.NE.0)RETURN
  40. CALL QUESUP (0,IPCH3,0,0,ISUP3,IRET3)
  41. IF(IERR.NE.0)RETURN
  42. IF((ISUP1.EQ.ISUP2.AND.ISUP1.EQ.ISUP3)
  43. 1 .OR.
  44. 1 ((ISUP1.EQ.0.AND.ISUP2.EQ.0).OR.
  45. 1 (ISUP2.EQ.0.AND.ISUP3.EQ.0).OR.
  46. 1 (ISUP3.EQ.0.AND.ISUP1.EQ.0))
  47. 1 .OR.
  48. 1 ((ISUP1.EQ.0.AND.ISUP2.EQ.ISUP3).OR.
  49. 1 (ISUP2.EQ.0.AND.ISUP3.EQ.ISUP1).OR.
  50. 1 (ISUP3.EQ.0.AND.ISUP1.EQ.ISUP2)))THEN
  51. IOK=1
  52. ELSE
  53. IOK=0
  54. ENDIF
  55. IF(IOK.EQ.0)THEN
  56. MCHELM=IPCH1
  57. SEGACT MCHELM
  58. MOTERR(1:8)=TITCHE
  59. CALL ERREUR(124)
  60. SEGDES MCHELM
  61. RETURN
  62. ENDIF
  63. C
  64. C ON COPIE LE TROISIEME MCHAML
  65. C
  66.  
  67. CALL COPIE8(IPCH3,IPCH4)
  68. MCHEL1=IPCH1
  69. MCHEL2=IPCH2
  70. MCHEL3=IPCH3
  71. SEGACT,MCHEL1,MCHEL2,MCHEL3
  72. MOT1=MCHEL1.TITCHE
  73. MOT2=MCHEL2.TITCHE
  74. MOT3=MCHEL3.TITCHE
  75. IF(MOT1.NE.MOT2.OR.MOT1.NE.MOT3)THEN
  76. CALL ERREUR(253)
  77. CALL DTCHAM(IPCH4)
  78. GOTO 666
  79. ENDIF
  80. MCHEL4=IPCH4
  81. SEGACT MCHEL4
  82. NSOU4=MCHEL4.IMACHE(/1)
  83. C
  84. C BOUCLE SUR LES ZONES
  85. C
  86. DO 500 ISOUS=1,NSOU4
  87. C
  88. IPMAIL=MCHEL4.IMACHE(ISOUS)
  89. CONM=MCHEL4.CONCHE(ISOUS)
  90. C
  91. C CREATION DU TABLEAU INFOS
  92. C
  93. CALL IDENT(IPMAIL,CONM,IPCH1,IPCH2,INFOS,IRTD)
  94. IF (IRTD.EQ.0) THEN
  95. SEGDES MCHEL4
  96. CALL DTCHAM(IPCH4)
  97. GOTO 666
  98. ENDIF
  99. C
  100. MCHAML=MCHEL4.ICHAML(ISOUS)
  101. SEGACT MCHAML
  102. NCOMP=IELVAL(/1)
  103. NBRFAC=0
  104. NBTYPE=NCOMP
  105. SEGINI NOTYPE
  106. MOTYPE=NOTYPE
  107. NBROBL=NCOMP
  108. SEGINI NOMID
  109. MONOM=NOMID
  110. DO 10 IC=1,NCOMP
  111. LESOBL(IC)=NOMCHE(IC)
  112. TYPE(IC)=TYPCHE(IC)
  113. 10 CONTINUE
  114. C
  115. NUMCO=0
  116. IF(NCOMP.EQ.1)NUMCO=1
  117. IF(NCOMP.NE.1)THEN
  118. DO 20 IC=1,NCOMP
  119. IF(MACOMP.NE.NOMCHE(IC))GOTO 20
  120. NUMCO=IC
  121. GO TO 30
  122. 20 CONTINUE
  123. 30 CONTINUE
  124. ENDIF
  125. IF(NUMCO.EQ.0)THEN
  126. MOTERR(1:4)=MACOMP
  127. CALL ERREUR(243)
  128. SEGDES MCHAML
  129. SEGDES MCHEL4
  130. CALL DTCHAM(IPCH4)
  131. GO TO 666
  132. ENDIF
  133. C
  134. C ON VERIFIE SI ON A LES MEMES COMPOSANTES SUR LES AUTRES
  135. C CHAMPS ET ON LES EXTRAIT
  136. C
  137. CALL KOMCHA(IPCH1,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH1)
  138. IF(IERR.NE.0)THEN
  139. SEGSUP NOMID,NOTYPE
  140. CALL DTMVAL(IVACH1,1)
  141. SEGDES MCHAML
  142. SEGDES MCHEL4
  143. CALL DTCHAM(IPCH4)
  144. GO TO 666
  145. ENDIF
  146. CALL KOMCHA(IPCH2,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH2)
  147. IF(IERR.NE.0)THEN
  148. SEGSUP NOMID,NOTYPE
  149. CALL DTMVAL(IVACH1,1)
  150. CALL DTMVAL(IVACH2,1)
  151. SEGDES MCHAML
  152. SEGDES MCHEL4
  153. CALL DTCHAM(IPCH4)
  154. GO TO 666
  155. ENDIF
  156. CALL KOMCHA(IPCH3,IPMAIL,CONM,MONOM,MOTYPE,1,INFOS,3,IVACH3)
  157. SEGSUP NOMID,NOTYPE
  158. C
  159. MELVAL=IELVAL(NUMCO)
  160. SEGACT,MELVAL
  161. NBPTE4=VELCHE(/1)
  162. NEL4 =VELCHE(/2)
  163. MPTVAL=IVACH1
  164. MELVAL=IVAL(NUMCO)
  165. NBPTE1=VELCHE(/1)
  166. NEL1 =VELCHE(/2)
  167. MPTVAL=IVACH2
  168. MELVAL=IVAL(NUMCO)
  169. NBPTE2=VELCHE(/1)
  170. NEL2 =VELCHE(/2)
  171. NBPTEL=MAX(MAX(NBPTE1,NBPTE2),NBPTE4)
  172. NBELEM=MAX(MAX(NEL1,NEL2),NEL4)
  173. N1PTEL=NBPTEL
  174. N1EL=NBELEM
  175. N2PTEL=0
  176. N2EL=0
  177. MELVAL=IELVAL(NUMCO)
  178. IF(N1PTEL.GT.NBPTE4.OR.N1EL.GT.NEL4)SEGADJ MELVAL
  179. C
  180. DO 100 IB=1,NBELEM
  181. DO 100 IGAU=1,NBPTEL
  182. C
  183. MPTVAL=IVACH1
  184. MELVAL=IVAL(NUMCO)
  185. IGMN=MIN(IGAU,VELCHE(/1))
  186. IBMN=MIN(IB,VELCHE(/2))
  187. V1=VELCHE(IGMN,IBMN)
  188. C
  189. MPTVAL=IVACH2
  190. MELVAL=IVAL(NUMCO)
  191. IGMN=MIN(IGAU,VELCHE(/1))
  192. IBMN=MIN(IB,VELCHE(/2))
  193. V2=VELCHE(IGMN,IBMN)
  194. C
  195. MPTVAL=IVACH3
  196. MELVAL=IVAL(NUMCO)
  197. IGMN=MIN(IGAU,VELCHE(/1))
  198. IBMN=MIN(IB,VELCHE(/2))
  199. V3=VELCHE(IGMN,IBMN)
  200. C
  201. RR=V3
  202. RD=V2-V1
  203. IF(RD.EQ.0.D0) GO TO 50
  204. RAI=(V3-V2)/RD
  205. IF(ABS(RAI).GT.FLOT) GO TO 50
  206. IF(RAI.EQ.1.D0) GO TO 50
  207. RR=V3+(V3-V2)*RAI/(1.D0-RAI)
  208. 50 CONTINUE
  209. MELVAL=IELVAL(NUMCO)
  210. VELCHE(IGAU,IB)=RR
  211. 100 CONTINUE
  212. C
  213. C DESACTIVATION DES SEGMENTS
  214. C
  215. C
  216. CALL DTMVAL(IVACH1,1)
  217. C
  218. CALL DTMVAL(IVACH2,1)
  219. C
  220. CALL DTMVAL(IVACH3,1)
  221. C
  222. MELVAL=IELVAL(NUMCO)
  223. SEGDES MELVAL
  224. SEGDES MCHAML
  225. C
  226. 500 CONTINUE
  227. SEGDES MCHEL4
  228. 666 CONTINUE
  229. SEGDES MCHEL1,MCHEL2,MCHEL3
  230. RETURN
  231. END
  232.  
  233.  
  234.  
  235.  
  236.  
  237.  
  238.  

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