Télécharger enerca.eso

Retour à la liste

Numérotation des lignes :

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

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