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

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