Télécharger extrsk.eso

Retour à la liste

Numérotation des lignes :

extrsk
  1. C EXTRSK SOURCE CB215821 20/11/04 21:17:14 10766
  2. SUBROUTINE EXTRSK(IPCHE1,IPMOD1,NS,IPCHS1,IENT4,IERR1)
  3. C-----------------------------------------------------------
  4. C
  5. C EXTRSK
  6. C ------
  7. C FONCTION:
  8. C SUBROUTINE APPELEE PAR CALP1 OU CALP2 POUR LE CAS DES COQUES MINCES
  9. C AVEC INTEGRATION DANS L'EPAISSEUR
  10. C
  11. C-----------------------------------------------------------
  12. C MODULES UTILISES
  13. C ----------------
  14. C
  15. IMPLICIT INTEGER(I-N)
  16. -INC SMCHAML
  17. -INC SMMODEL
  18. -INC SMELEME
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. C
  23. C
  24. C
  25. C PARAMETRES: (E)=ENTREE (S)=SORTIE
  26. C ----------
  27. C
  28. C IPCHE1 (E) POINTEUR SUR UN MCHAML
  29. C IPMOD1 (E) POINTEUR SUR UN IMODEL (ACTIF)
  30. C NS (E) NUMERO DE LA ZONE
  31. C IPCHS1 (E) ET (S) POINTEUR SUR LE MCHAML A REMPLIR (ACTIF)
  32. C IENT4 (E) ENTIER = NUMERO DE LA COUCHE
  33. C IERR1 (E,S) PARAMETRE D'ERREUR
  34. C-----------------------------------------------------------
  35. C
  36. SEGMENT NOTYPE
  37. CHARACTER*16 TYPE(NBTYPE)
  38. ENDSEGMENT
  39. *
  40. SEGMENT MPTVAL
  41. INTEGER IPOS(NS) ,NSOF(NS)
  42. INTEGER IVAL(NCOSOU)
  43. CHARACTER*16 TYVAL(NCOSOU)
  44. ENDSEGMENT
  45. *
  46. INTEGER INFOS(3)
  47. CHARACTER*(NCONCH) CONM
  48. logical lsupde
  49. *
  50. MCHELM = IPCHE1
  51. SEGACT,MCHELM
  52. IMODEL=IPMOD1
  53. MCHEL1=IPCHS1
  54. *
  55. IPMAIL=IMAMOD
  56. CONM=CONMOD
  57. *
  58. *......INFORMATION SUR L'ELEMENT FINI..........
  59. MELE=NEFMOD
  60. * CALL ELQUOI(MELE,0,5,INFO,IMODEL)
  61. NBG=INFELE(4)/INFMOD(1)
  62. *
  63. *......CREATION DU TABLEAU INFOS.......
  64. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE1,INFOS,IRTD)
  65. IF (IRTD.EQ.0) THEN
  66. SEGDES MCHELM
  67. IERR1=1
  68. RETURN
  69. ENDIF
  70. *
  71. MCHEL1.INFCHE(NS,1)=1
  72. MCHEL1.INFCHE(NS,2)=0
  73. MCHEL1.INFCHE(NS,3)=NIFOUR
  74. MCHEL1.INFCHE(NS,4)=INFELE(11)
  75. MCHEL1.INFCHE(NS,5)=0
  76. MCHEL1.INFCHE(NS,6)=5
  77. MCHEL1.IMACHE(NS)=IMAMOD
  78. MCHEL1.CONCHE(NS)=CONMOD
  79. *
  80. *...........RECHERCHE DES NOMS COMPOSANTES...........
  81. lsupde=.false.
  82. IF (TITCHE(1:4).EQ.'DEFO') THEN
  83. if(lnomid(5).ne.0) then
  84. nomid=lnomid(5)
  85. segact nomid
  86. mocomp=nomid
  87. else
  88. lsupde=.true.
  89. CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  90. endif
  91. ELSE
  92. if(lnomid(4).ne.0) then
  93. nomid=lnomid(4)
  94. segact nomid
  95. mocomp=nomid
  96. ncomp=lesobl(/2)
  97. nfac=lesfac(/2)
  98. else
  99. lsupde=.true.
  100. CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  101. endif
  102. ENDIF
  103. *
  104. *...........VERIFICATION DE LEUR PRESENCE............
  105. NBTYPE=1
  106. SEGINI NOTYPE
  107. MOTYPE=NOTYPE
  108. TYPE(1)='REAL*8'
  109. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYPE,
  110. $ 1,INFOS,3,IVACOM)
  111. IF (IERR.NE.0) THEN
  112. SEGDES MCHELM
  113. IERR1=1
  114. RETURN
  115. ENDIF
  116. *
  117. *...........CREATION DU MCHAM DE LA SOUS ZONE...........
  118. N2=NCOMP
  119. SEGINI MCHAM1
  120. MCHEL1.ICHAML(NS)=MCHAM1
  121. *
  122. *...........RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER.....
  123. N1PTEL=0
  124. N1EL=0
  125. MPTVAL=IVACOM
  126. DO 110 ICOMP=1,NCOMP
  127. MELVAL=IVAL(ICOMP)
  128. M=MAX(N1PTEL,VELCHE(/1))
  129. IF (M.GT.1) THEN
  130. N1PTEL=M/INFMOD(1)
  131. ELSE
  132. N1PTEL=M
  133. ENDIF
  134. N1EL=MAX(N1EL,VELCHE(/2))
  135. N2PTEL=0
  136. N2EL=0
  137. SEGINI MELVA1
  138. MCHAM1.IELVAL(ICOMP)=MELVA1
  139. 110 CONTINUE
  140. *
  141. NOMID=MOCOMP
  142. SEGACT NOMID
  143. MPTVAL=IVACOM
  144. *...........BOUCLE SUR LES ELEMENTS.......
  145. DO 20 IB=1,N1EL
  146. *
  147. DO 20 IGAU=1,N1PTEL
  148. *
  149. DO 40 ICOMP=1,NCOMP
  150. MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
  151. MCHAM1.TYPCHE(ICOMP)=TYPE(1)
  152. MELVAL=IVAL(ICOMP)
  153. SEGACT MELVAL
  154. MELVA1=MCHAM1.IELVAL(ICOMP)
  155. SEGACT MELVA1*MOD
  156. IGMN=MIN(IGAU,VELCHE(/1))
  157. IBMN=MIN(IB,VELCHE(/2))
  158. IF (IGMN.EQ.VELCHE(/1)) THEN
  159. MELVA1.VELCHE(IGAU,IB)=VELCHE(IGMN,IBMN)
  160. ELSE
  161. MELVA1.VELCHE(IGAU,IB)=VELCHE(IGAU+NBG*
  162. $ (IENT4-1),IBMN)
  163. ENDIF
  164. SEGDES MELVAL,MELVA1
  165. 40 CONTINUE
  166. 20 CONTINUE
  167. SEGDES MCHAM1,nomid
  168. SEGSUP MPTVAL,NOTYPE
  169. if(lsupde)segsup nomid
  170. *
  171. IPCHS1=MCHEL1
  172. *
  173. SEGDES IMODEL,MCHELM
  174. * SEGSUP INFO
  175. RETURN
  176. END
  177.  
  178.  
  179.  
  180.  
  181.  
  182.  
  183.  
  184.  
  185.  
  186.  
  187.  
  188.  
  189.  
  190.  
  191.  
  192.  

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