Télécharger enerca.eso

Retour à la liste

Numérotation des lignes :

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

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