Télécharger enerca.eso

Retour à la liste

Numérotation des lignes :

enerca
  1. C ENERCA SOURCE CB215821 24/04/12 21:15:45 11897
  2. SUBROUTINE ENERCA(IPMODL,IPCHE1,IPCHE2,IPCHR)
  3. *_______________________________________________________________________
  4. *
  5. * OPERATEUR DENSITE D'ENERGIE
  6. *
  7. * ENTREES :
  8. * ---------
  9. *
  10. * IPMODL POINTEUR SUR UN MMODEL
  11. * IPCHE1 POINTEUR SUR UN CHAMELEM
  12. * IPCHE2 POINTEUR SUR UN CHAMELEM
  13. *
  14. *
  15. * SORTIE :
  16. * --------
  17. *
  18. * IPCHR POINTEUR SUR LE CHAMELEM CORRESPONDANT AU PRODUIT
  19. * CONTRACTE DES DEUX PRECEDENTS.
  20. * =0 SI L'OPERATION EST IMPOSSIBLE.
  21. *
  22. * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 01/91
  23. *
  24. *_______________________________________________________________________
  25. *
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8(A-H,O-Z)
  28. *
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC CCGEOME
  33. -INC SMMODEL
  34. -INC SMCHAML
  35. -INC SMINTE
  36. *
  37. SEGMENT NOTYPE
  38. CHARACTER*16 TYPE(NBTYPE)
  39. ENDSEGMENT
  40. *
  41. SEGMENT MPTVAL
  42. INTEGER IPOS(NS) ,NSOF(NS)
  43. INTEGER IVAL(NCOSOU)
  44. CHARACTER*16 TYVAL(NCOSOU)
  45. ENDSEGMENT
  46. *
  47. PARAMETER ( NINF=3 )
  48. INTEGER INFOS(NINF)
  49. CHARACTER*72 MOT1,MOT2
  50. CHARACTER*(NCONCH) CONM
  51. LOGICAL lsupde,lsupco
  52. *
  53. IPCHR=0
  54. *
  55. NHRM=NIFOUR
  56. *
  57. MCHEL1=IPCHE1
  58. MCHEL2=IPCHE2
  59. SEGACT MCHEL1,MCHEL2
  60. MOT1=MCHEL1.TITCHE
  61. MOT2=MCHEL2.TITCHE
  62. IFO1=MCHEL1.IFOCHE
  63. *
  64. * TEST DE COMPABILITE DES CHAMPS A MULTIPLIER
  65. *
  66. IF(MOT1.EQ.'CONTRAINTES'.AND.MOT2.EQ.'DEFORMATIONS') THEN
  67. IPCHEC = IPCHE1
  68. IPCHED = IPCHE2
  69. ICAS=1
  70. ELSE IF(MOT2.EQ.'CONTRAINTES'.AND.MOT1.EQ.'DEFORMATIONS') THEN
  71. IPCHEC = IPCHE2
  72. IPCHED = IPCHE1
  73. * ERREUR LES CHAMELEM QUE L ON TENTE DE MULTIPLIER SONT INCOMPATIBLES
  74. ELSE
  75. MOTERR(1:8)=MOT1
  76. MOTERR(9:16)=MOT2
  77. CALL ERREUR(175)
  78. RETURN
  79. ENDIF
  80. *
  81. * VERIFICATION DU LIEU SUPPORT DU MCHAML DE CONTRAINTES
  82. *
  83. CALL QUESUP(IPMODL,IPCHEC,5,0,ISUPCO,IRETCO)
  84. IF (ISUPCO.GT.1) RETURN
  85. *
  86. * VERIFICATION DU LIEU SUPPORT DU MCHAML DE DEFORMATIONS
  87. *
  88. CALL QUESUP(IPMODL,IPCHED,5,0,ISUPDE,IRETDE)
  89. IF (ISUPDE.GT.1) RETURN
  90. *
  91. * ACTIVATION DU MODELE
  92. *
  93. MMODEL=IPMODL
  94. SEGACT MMODEL
  95. NSOUS=KMODEL(/1)
  96. *
  97. KEL22 = 0
  98. DO ISOUS=1,NSOUS
  99. IMODEL=KMODEL(ISOUS)
  100. SEGACT,IMODEL
  101. IF ((NEFMOD.EQ.22).OR.(NEFMOD.EQ.259)) KEL22 = KEL22+1
  102. ENDDO
  103. *
  104. * CREATION DU CHAMELEM RESULTAT
  105. *
  106. N1=NSOUS-KEL22
  107. N3=6
  108. L1=8
  109. SEGINI MCHELM
  110. TITCHE='SCALAIRE'
  111. IFOCHE=IFO1
  112. *
  113. * DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES
  114. *
  115. isouss=0
  116. DO 200 ISOUS=1,NSOUS
  117. *
  118. * QUELQUES INITIALISATIONS
  119. *
  120. IMODEL=KMODEL(ISOUS)
  121. C* SEGACT IMODEL
  122.  
  123. MELE=NEFMOD
  124. if((MELE.EQ.22).OR.(MELE.EQ.259)) go to 200
  125.  
  126. MOSTRS = 0
  127. MODEFO = 0
  128. IVADEF = 0
  129. IVASTR = 0
  130. IPMINT = 0
  131. lsupco=.false.
  132. lsupde=.false.
  133. *
  134. IPMAIL=IMAMOD
  135. CONM =CONMOD
  136. *
  137. * CREATION DU TABLEAU INFO
  138. *
  139. CALL IDENT (IPMAIL,CONM,IPCHEC,IPCHED,INFOS,IRTD)
  140. IF (IRTD.EQ.0) GOTO 9990
  141. *
  142. * INFORMATION SUR L'ELEMENT FINI
  143. *
  144. * CALL ELQUOI (MELE,0,5,IPINF,IMODEL)
  145. * IF (IERR.NE.0) GOTO 9990
  146. MFR=INFELE(13)
  147. IPPORE=0
  148. IF(MFR.EQ.33) IPPORE=NBNNE(NUMGEO(MELE))
  149. * MINTE=INFELE(11)
  150. * on saute les sous modeles n'ayant pas de fonctions de forme. Ex: contact
  151. if (infmod(/1).lt.7) goto 200
  152. minte=infmod(7)
  153. if (minte.eq.0) goto 200
  154. isouss=isouss+1
  155.  
  156. IPMINT=MINTE
  157. SEGACT,MINTE
  158. *
  159. IMACHE(ISOUSs)=IPMAIL
  160. CONCHE(ISOUSs)=CONMOD
  161. *
  162. INFCHE(ISOUSs,1)=0
  163. INFCHE(ISOUSs,2)=0
  164. INFCHE(ISOUSs,3)=NHRM
  165. INFCHE(ISOUSs,4)=MINTE
  166. INFCHE(ISOUSs,5)=0
  167. INFCHE(ISOUSs,6)=5
  168. *
  169. * RECHERCHE DES NOMS DE COMPOSANTES
  170. *
  171. NBTYPE=1
  172. SEGINI NOTYPE
  173. TYPE(1)='REAL*8'
  174. MOTYPE=NOTYPE
  175. *
  176. if(lnomid(4).ne.0) then
  177. nomid=lnomid(4)
  178. segact nomid
  179. mostrs=nomid
  180. nstr=lesobl(/2)
  181. nfac=lesfac(/2)
  182. else
  183. lsupco=.true.
  184. CALL IDCONT(IMODEL,IFOUR,MOSTRS,NSTR,NFAC)
  185. nomid=mostrs
  186. endif
  187. *
  188. CALL KOMCHA(IPCHEC,IPMAIL,CONM,MOSTRS,
  189. 1 MOTYPE,1,INFOS,3,IVASTR)
  190. IF (IERR.NE.0) THEN
  191. SEGSUP NOTYPE
  192. GOTO 9991
  193. ENDIF
  194. IF(ISUPCO.EQ.1)CALL VALCHE(IVASTR,NSTR,IPMINT,IPPORE,
  195. & MOSTRS,MELE)
  196. *
  197. if(lnomid(5) .ne.0) then
  198. nomid=lnomid(5)
  199. segact nomid
  200. ndef=lesobl(/2)
  201. modefo=nomid
  202. else
  203. lsupde=.true.
  204. CALL IDDEFO(IMODEL,IFOUR,MODEFO,NDEF,NFAC)
  205. nomid=modefo
  206. endif
  207. CALL KOMCHA(IPCHED,IPMAIL,CONM,MODEFO,MOTYPE,
  208. 1 1,INFOS,3,IVADEF)
  209. SEGSUP NOTYPE
  210. IF (IERR.NE.0) GOTO 9992
  211. IF(ISUPDE.EQ.1)CALL VALCHE(IVADEF,NDEF,IPMINT,IPPORE,
  212. & MODEFO,MELE)
  213. *
  214. * RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  215. *
  216. NSPTEL=0
  217. NSEL =0
  218. MPTVAL=IVASTR
  219. DO 1 ICOMP=1,NSTR
  220. MELVAL=IVAL(ICOMP)
  221. NSPTEL=MAX(NSPTEL,VELCHE(/1))
  222. NSEL =MAX(NSEL ,VELCHE(/2))
  223. 1 CONTINUE
  224. *
  225. NDPTEL=0
  226. NDEL =0
  227. MPTVAL=IVADEF
  228. DO 2 ICOMP=1,NDEF
  229. MELVAL=IVAL(ICOMP)
  230. NDPTEL=MAX(NDPTEL,VELCHE(/1))
  231. NDEL =MAX(NDEL ,VELCHE(/2))
  232. 2 CONTINUE
  233. *
  234. N1PTEL=MAX(NSPTEL,NDPTEL)
  235. N1EL =MAX(NSEL ,NDEL )
  236. N2PTEL=0
  237. N2EL =0
  238. *
  239. N2=1
  240. SEGINI MCHAML
  241. ICHAML(ISOUSs)=MCHAML
  242. NOMCHE(1)='SCAL'
  243. TYPCHE(1)='REAL*8'
  244. SEGINI MELVAL
  245. IELVAL(1)=MELVAL
  246. IPMELV=MELVAL
  247. *
  248. DO 310 IGAU=1,N1PTEL
  249. DO 310 IB=1,N1EL
  250. r_z=0.D0
  251. *
  252. DO 366 ICOMP=1,NDEF
  253. MPTVAL=IVASTR
  254. MELVAL=IVAL(ICOMP)
  255. IGMN=MIN(IGAU,VELCHE(/1))
  256. IBMN=MIN(IB ,VELCHE(/2))
  257. XTT1=VELCHE(IGMN,IBMN)
  258. *
  259. MPTVAL=IVADEF
  260. MELVAL=IVAL(ICOMP)
  261. IGMN=MIN(IGAU,VELCHE(/1))
  262. IBMN=MIN(IB ,VELCHE(/2))
  263. XTT2=VELCHE(IGMN,IBMN)
  264. *
  265. r_z = r_z + XTT1*XTT2
  266. 366 CONTINUE
  267. MELVAL=IPMELV
  268. VELCHE(IGAU,IB)=r_z
  269. 310 CONTINUE
  270. *
  271. * DESACTIVATION PROPRE A LA GEOMETRIE ISOUS
  272. *
  273. MELVAL=IPMELV
  274. 9992 CONTINUE
  275. NOMID=MODEFO
  276. if(lsupde)SEGSUP NOMID
  277. IF(ISUPDE.EQ.1)THEN
  278. CALL DTMVAL(IVADEF,3)
  279. ELSE
  280. CALL DTMVAL(IVADEF,1)
  281. ENDIF
  282. 9991 CONTINUE
  283. NOMID=MOSTRS
  284. if(lsupco)SEGSUP NOMID
  285. IF(ISUPCO.EQ.1)THEN
  286. CALL DTMVAL(IVASTR,3)
  287. ELSE
  288. CALL DTMVAL(IVASTR,1)
  289. ENDIF
  290. 9990 CONTINUE
  291. *
  292. * ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
  293. IF (IERR.NE.0) THEN
  294. SEGSUP MCHELM
  295. IPCHR = 0
  296. GOTO 999
  297. ENDIF
  298.  
  299. 200 CONTINUE
  300. IF (n1.ne.isouss) then
  301. n1 = isouss
  302. segadj mchelm
  303. endif
  304. * Fin du sous-programme
  305. IPCHR=MCHELM
  306. *
  307. 999 CONTINUE
  308. END
  309.  
  310.  
  311.  
  312.  
  313.  
  314.  

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