Télécharger epsln1.eso

Retour à la liste

Numérotation des lignes :

  1. C EPSLN1 SOURCE GG250959 17/09/20 21:15:23 9554
  2.  
  3. SUBROUTINE EPSLN1(IPMODL,IPCHGR,IPCHCA,IPCHDE,IMIL)
  4.  
  5. *---------------------------------------------------------------------
  6. *
  7. * CALCUL DE LA DEFORMATION LOGARITHMIQUE
  8. * (APPELE PAR EPSI)
  9. *
  10. * ENTREES:
  11. * --------
  12. *
  13. * IPMODL POINTEUR SUR UN MMODEL
  14. * IPCHGR POINTEUR SUR UN MCHAML DE GRADIENTS
  15. * IPCHCA POINTEUR SUR UN MCHAML DE CARACTERISTIQUES
  16. * --> NON UTILISE POUR LE MOMENT
  17. * IMIL ENTIER CORRESPONDANT A GEOM (=0) OU A DEPL (=1)
  18. * SI LE GRADIENT IPCHE1 EST CELUI DE LA TRANSFORMATION
  19. * OU D'UN DEPLACEMENT.
  20. *
  21. * SORTIES :
  22. * ---------
  23. *
  24. * IPCHDE POINTEUR SUR UN MCHAML DE DEFORMATIONS
  25. * = 0 EN CAS D'ERREUR
  26. *
  27. *---------------------------------------------------------------------
  28. *
  29. IMPLICIT INTEGER(I-N)
  30. IMPLICIT REAL*8(A-H,O-Z)
  31.  
  32. -INC CCOPTIO
  33. -INC CCHAMP
  34. -INC SMCHAML
  35. -INC SMMODEL
  36. -INC SMINTE
  37. *
  38. SEGMENT NOTYPE
  39. CHARACTER*16 TYPE(NBTYPE)
  40. ENDSEGMENT
  41. *
  42. SEGMENT MPTVAL
  43. INTEGER IPOS(NS) ,NSOF(NS)
  44. INTEGER IVAL(NCOSOU)
  45. CHARACTER*16 TYVAL(NCOSOU)
  46. ENDSEGMENT
  47. *
  48. * Support des MCHAML (si non exprimes aux noeuds)
  49. PARAMETER (INTYPS = 5)
  50. *
  51. PARAMETER ( NINF=3 )
  52. INTEGER INFOS(NINF)
  53. CHARACTER*(NCONCH) CONM
  54. logical lsupde,lsupgr
  55. *
  56. DIMENSION F(9), EPS(6)
  57. *
  58. IPCHDE = 0
  59. IPCHS3 = 0
  60. *
  61. * Reduction des MCHAMLs sur le modele IPMODL
  62. *
  63. kerre = 0
  64. *
  65. IPCHE1 = IPCHGR
  66. CALL REDUAF(IPCHE1,IPMODL,ipch,0,ir,kerre)
  67. IF (ir.NE.1) CALL ERREUR(kerre)
  68. IF (IERR.NE.0) RETURN
  69. IPCHE1 = ipch
  70. *
  71. IPCHE2 = IPCHCA
  72. IF (IPCHE2.NE.0) THEN
  73. CALL REDUAF(IPCHE2,IPMODL,ipch,0,ir,kerre)
  74. IF (ir.NE.1) CALL ERREUR(kerre)
  75. IF (IERR.NE.0) RETURN
  76. IPCHE2 = ipch
  77. ENDIF
  78. *
  79. * Verification sur le type de IPCHE1 (GRADIENT)
  80. *
  81. MCHELM = IPCHE1
  82. SEGACT,MCHELM
  83. IF (TITCHE.NE.'GRADIENT') THEN
  84. MOTERR(1:8)='GRADIENT'
  85. CALL ERREUR(145)
  86. GOTO 9990
  87. ENDIF
  88. *
  89. * VERIFICATION DU LIEU SUPPORT DES MCHAMLS D'ENTREE
  90. *
  91. CALL QUESUP(IPMODL,IPCHE1,INTYPS,0,ISUP1,ir)
  92. IF (ISUP1.GT.1) GOTO 9990
  93. IF (IPCHE2.NE.0) THEN
  94. CALL QUESUP(IPMODL,IPCHE2,INTYPS,0,ISUP2,ir)
  95. IF (ISUP2.GT.1) GOTO 9990
  96. ENDIF
  97. *
  98. * ACTIVATION DU MODELE
  99. *
  100. MMODEL=IPMODL
  101. SEGACT,MMODEL
  102. NSOUS = KMODEL(/1)
  103. *
  104. C ... Initialisation du MCHELM de DEFORMATIONS resultat ...
  105. *
  106. * DETERMINATION DU NOMBRE DE SOUS-ZONES DU MCHAML
  107. *
  108. N1 = 0
  109. DO ISOUS = 1, NSOUS
  110. IMODEL = KMODEL(ISOUS)
  111. SEGACT,IMODEL
  112. MELE = NEFMOD
  113. IF (MELE.NE.22.AND.FORMOD(1).NE.'CHARGEMENT') N1 = N1 + 1
  114. IF (MELE.NE.259.AND.FORMOD(1).NE.'CHARGEMENT') N1 = N1 + 1
  115. ENDDO
  116. C
  117. L1 = 12
  118. N3 = 6
  119. SEGINI,MCHEL1
  120. IPCHS3 = MCHEL1
  121. C
  122. C le MCHAML resultat est de type DEFORMATIONS
  123. C
  124. MCHEL1.IFOCHE=IFOUR
  125. MCHEL1.TITCHE='DEFORMATIONS'
  126. *
  127. * Petit segment utile (defini une fois pour toutes)
  128. *
  129. NBTYPE = 1
  130. SEGINI,NOTYPE
  131. TYPE(1)='REAL*8'
  132. MOTYPG = NOTYPE
  133.  
  134. * ===================================
  135. * ... BOUCLE SUR LES SOUS ZONES DU MODELE ...
  136. * ===================================
  137. ISOUSS = 0
  138. *
  139. DO 10 ISOUS = 1, NSOUS
  140. *
  141. * ... INITIALISATIONS ...
  142. *
  143. NGRA =0
  144. IVAGRA=0
  145. MOGRAD=0
  146. lsupgr = .false.
  147. NDEF=0
  148. IVAEPS=0
  149. MOEPSI=0
  150. lsupde = .false.
  151. IPMINT = 0
  152. *
  153. * ... TRAITEMENT DU SOUS-MODELE ...
  154. *
  155. IMODEL=KMODEL(ISOUS)
  156. c* SEGACT,IMODEL
  157. *
  158. MELE = NEFMOD
  159. IPMAIL= IMAMOD
  160. CONM = CONMOD
  161. IF (MELE.EQ.22.OR.FORMOD(1).EQ.'CHARGEMENT') GOTO 199
  162. IF (MELE.EQ.259.OR.FORMOD(1).EQ.'CHARGEMENT') GOTO 199
  163. *
  164. ISOUSS = ISOUSS + 1
  165. *
  166. * ... INFOS GENERALES ...
  167. *
  168. C ... COQUE INTEGREE OU PAS ? ...
  169. C
  170. IF (INFMOD(/1).NE.0) THEN
  171. NPINT=INFMOD(1)
  172. ELSE
  173. NPINT=0
  174. ENDIF
  175. IF (NPINT.NE.0) THEN
  176. CALL ERREUR(615)
  177. GOTO 199
  178. ENDIF
  179. *
  180. * ... INFORMATION SUR L'ELEMENT FINI ...
  181. *
  182. MFR =INFELE(13)
  183. * IPMINT =INFELE(11)
  184. IPMINT=INFMOD(2+INTYPS)
  185. IF (IPMINT.NE.0) THEN
  186. MINTE = IPMINT
  187. SEGACT,MINTE
  188. ENDIF
  189. IPPORE = 0
  190. *
  191. * TEST SUR MFR : MASSIF UNIQUEMENT POUR L'INSTANT
  192. *
  193. IF (MFR.NE.1) THEN
  194. CALL ERREUR(26)
  195. GOTO 199
  196. ENDIF
  197. *
  198. * ... Verification de compatibilité des MCHAML du point de vue des
  199. * tableaux INFCHE et remplissage du tableau INFOS pour KOMCHA ...
  200. *
  201. CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,iret)
  202. IF (iret.EQ.0) GOTO 199
  203. *
  204. * ... RECHERCHE DES NOMS de COMPOSANTES ...
  205. *
  206. IF (lnomid(3).NE.0) THEN
  207. mograd = lnomid(3)
  208. ELSE
  209. lsupgr = .true.
  210. CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRA,nfac)
  211. ENDIF
  212. nomid=MOGRAD
  213. SEGACT,nomid
  214. NGRA=lesobl(/2)
  215. C* nfac=lesfac(/2)
  216. *
  217. LADIM=0
  218. IF (NGRA.EQ.4) LADIM=2
  219. IF (NGRA.EQ.9) LADIM=3
  220. IF (LADIM.EQ.0) THEN
  221. CALL ERREUR(26)
  222. GOTO 199
  223. ENDIF
  224.  
  225. IF (lnomid(5).NE.0) THEN
  226. MOEPSI = lnomid(5)
  227. ELSE
  228. lsupde = .true.
  229. CALL IDDEFO(IMODEL,IFOUR,MOEPSI,NDEF,nfac)
  230. ENDIF
  231. nomid=MOEPSI
  232. SEGACT,nomid
  233. NDEF = lesobl(/2)
  234. C* nfac=lesfac(/2)
  235. *
  236. * ... VERIFICATION DE LEUR PRESENCE ...
  237. *
  238. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOGRAD,MOTYPG,1,INFOS,3,IVAGRA)
  239. IF (IERR.NE.0) GOTO 199
  240. *
  241. * Changement de support du gradient (NOEUDS vers INTYPS)
  242. IF (ISUP1.EQ.1) THEN
  243. CALL VALCHE(IVAGRA,NGRA,IPMINT,IPPORE,MOGRAD,MELE)
  244. IF (IERR.NE.0) THEN
  245. ISUP1 = 0
  246. GOTO 199
  247. ENDIF
  248. ENDIF
  249. *
  250. * ... RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER ...
  251. *
  252. N1PTEL=0
  253. N1EL =0
  254. MPTVAL=IVAGRA
  255. DO 110 ICOMP=1,NGRA
  256. MELVAL=IVAL(ICOMP)
  257. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  258. N1EL =MAX(N1EL ,VELCHE(/2))
  259. 110 CONTINUE
  260. N2PTEL=0
  261. N2EL=0
  262. *
  263. * ... Les attributs de chaque sous-zone ...
  264. *
  265. MCHEL1.INFCHE(ISOUSS,1)=0
  266. MCHEL1.INFCHE(ISOUSS,2)=0
  267. MCHEL1.INFCHE(ISOUSS,3)=NIFOUR
  268. MCHEL1.INFCHE(ISOUSS,4)=IPMINT
  269. MCHEL1.INFCHE(ISOUSS,5)=0
  270. MCHEL1.INFCHE(ISOUSS,6)=INTYPS
  271. MCHEL1.IMACHE(ISOUSS)=IPMAIL
  272. MCHEL1.CONCHE(ISOUSS)=CONMOD
  273. *
  274. * ... Création et stockage des MCHAML ...
  275. *
  276. N2 = NDEF
  277. SEGINI,MCHAM1
  278. MCHEL1.ICHAML(ISOUSS)=MCHAM1
  279. *
  280. C ... et des MELVAL de la zone élémentaire ...
  281. C
  282. NS=1
  283. NCOSOU=NDEF
  284. SEGINI,MPTVAL
  285. IVAEPS=MPTVAL
  286. NOMID=MOEPSI
  287. DO 111 ICOMP=1,NDEF
  288. MCHAM1.TYPCHE(ICOMP)='REAL*8'
  289. MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
  290. SEGINI,MELVAL
  291. MCHAM1.IELVAL(ICOMP)=MELVAL
  292. IVAL(ICOMP)=MELVAL
  293. 111 CONTINUE
  294. *
  295. **********************************************************************
  296. * *
  297. * BRANCHEMENT SUIVANT LA DIMENSION *
  298. * *
  299. **********************************************************************
  300. *
  301. * BOUCLE SUR LES ELEMENTS ET LES POINTS DE GAUSS
  302. *
  303. DO 31 IB=1,N1EL
  304. *
  305. DO 31 IGAU=1,N1PTEL
  306. *
  307. * ... Recherche des composantes du gradient
  308. *
  309. MPTVAL=IVAGRA
  310. DO 35 ICOMP = 1, NGRA
  311. MELVAL=IVAL(ICOMP)
  312. IGMN=MIN(IGAU,VELCHE(/1))
  313. IBMN=MIN(IB ,VELCHE(/2))
  314. F(ICOMP)=VELCHE(IGMN,IBMN)
  315. 35 CONTINUE
  316. *
  317. * ... Ajout de 1 aux termes diagonaux si mot DEPL lu
  318. *
  319. IF (IMIL.EQ.1) THEN
  320. IF (LADIM.EQ.3) THEN
  321. F(1)=F(1)+1.
  322. F(5)=F(5)+1.
  323. F(9)=F(9)+1.
  324. ELSE IF (LADIM.EQ.2) THEN
  325. F(1)=F(1)+1.
  326. F(4)=F(4)+1.
  327. ENDIF
  328. ENDIF
  329. *
  330. * ... Calcul des composantes de EPS ...
  331. *
  332. CALL EPSLN2(F,EPS,LADIM)
  333. IF (IERR.NE.0) GOTO 199
  334. *
  335. * ... et leur stockage ...
  336. *
  337. MPTVAL=IVAEPS
  338. DO 36 ICOMP=1,NDEF
  339. MELVAL=IVAL(ICOMP)
  340. VELCHE(IGAU,IB)=EPS(ICOMP)
  341. 36 CONTINUE
  342. *
  343. 31 CONTINUE
  344. *
  345. * ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ...
  346. *
  347. 199 CONTINUE
  348. *
  349. IF (IPMINT.NE.0) THEN
  350. MINTE = IPMINT
  351. SEGDES,MINTE
  352. ENDIF
  353. *
  354. IF (ISUP1.EQ.1) THEN
  355. CALL DTMVAL(IVAGRA,3)
  356. ELSE
  357. CALL DTMVAL(IVAGRA,1)
  358. ENDIF
  359. *
  360. IF (IERR.EQ.0) THEN
  361. MPTVAL=IVAEPS
  362. DO ICOMP = 1, IVAL(/1)
  363. MELVAL = IVAL(ICOMP)
  364. CALL COMRED(MELVAL)
  365. ENDDO
  366. CALL DTMVAL(IVAEPS,1)
  367. SEGDES,MCHAM1
  368. ELSE
  369. CALL DTMVAL(IVAEPS,3)
  370. SEGSUP,MCHAM1
  371. ENDIF
  372. *
  373. IF (MOGRAD.NE.0) THEN
  374. nomid=MOGRAD
  375. SEGDES,nomid
  376. IF (lsupgr) SEGSUP,nomid
  377. ENDIF
  378. *
  379. IF (MOEPSI.NE.0) THEN
  380. nomid=MOEPSI
  381. SEGDES,nomid
  382. IF (lsupde) SEGSUP,nomid
  383. ENDIF
  384. *
  385. SEGDES,IMODEL
  386. *
  387. IF (IERR.NE.0) GOTO 9991
  388. *
  389. 10 CONTINUE
  390. C ===========================================
  391. C ... FIN DE LA BOUCLE SUR LES ZONES ELEMENTAIRES ...
  392. C ===========================================
  393.  
  394. *
  395. 9991 CONTINUE
  396. SEGDES,MMODEL
  397. notype = MOTYPG
  398. SEGSUP,notype
  399. IF (IERR.NE.0) THEN
  400. SEGSUP,MCHEL1
  401. IPCHDE = 0
  402. ELSE
  403. SEGDES,MCHEL1
  404. IPCHDE = IPCHS3
  405. ENDIF
  406. 9990 CONTINUE
  407. SEGDES,MCHELM
  408.  
  409. RETURN
  410. END
  411.  
  412.  
  413.  
  414.  
  415.  
  416.  
  417.  

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