Télécharger extrsk.eso

Retour à la liste

Numérotation des lignes :

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

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