Télécharger epsln1.eso

Retour à la liste

Numérotation des lignes :

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

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