Télécharger epsln1.eso

Retour à la liste

Numérotation des lignes :

  1. C EPSLN1 SOURCE MB234859 16/09/16 21:15:17 9091
  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. ENDDO
  115. C
  116. L1 = 12
  117. N3 = 6
  118. SEGINI,MCHEL1
  119. IPCHS3 = MCHEL1
  120. C
  121. C le MCHAML resultat est de type DEFORMATIONS
  122. C
  123. MCHEL1.IFOCHE=IFOUR
  124. MCHEL1.TITCHE='DEFORMATIONS'
  125. *
  126. * Petit segment utile (defini une fois pour toutes)
  127. *
  128. NBTYPE = 1
  129. SEGINI,NOTYPE
  130. TYPE(1)='REAL*8'
  131. MOTYPG = NOTYPE
  132.  
  133. * ===================================
  134. * ... BOUCLE SUR LES SOUS ZONES DU MODELE ...
  135. * ===================================
  136. ISOUSS = 0
  137. *
  138. DO 10 ISOUS = 1, NSOUS
  139. *
  140. * ... INITIALISATIONS ...
  141. *
  142. NGRA =0
  143. IVAGRA=0
  144. MOGRAD=0
  145. lsupgr = .false.
  146. NDEF=0
  147. IVAEPS=0
  148. MOEPSI=0
  149. lsupde = .false.
  150. IPMINT = 0
  151. *
  152. * ... TRAITEMENT DU SOUS-MODELE ...
  153. *
  154. IMODEL=KMODEL(ISOUS)
  155. c* SEGACT,IMODEL
  156. *
  157. MELE = NEFMOD
  158. IPMAIL= IMAMOD
  159. CONM = CONMOD
  160. IF (MELE.EQ.22.OR.FORMOD(1).EQ.'CHARGEMENT') GOTO 199
  161. *
  162. ISOUSS = ISOUSS + 1
  163. *
  164. * ... INFOS GENERALES ...
  165. *
  166. C ... COQUE INTEGREE OU PAS ? ...
  167. C
  168. IF (INFMOD(/1).NE.0) THEN
  169. NPINT=INFMOD(1)
  170. ELSE
  171. NPINT=0
  172. ENDIF
  173. IF (NPINT.NE.0) THEN
  174. CALL ERREUR(615)
  175. GOTO 199
  176. ENDIF
  177. *
  178. * ... INFORMATION SUR L'ELEMENT FINI ...
  179. *
  180. MFR =INFELE(13)
  181. * IPMINT =INFELE(11)
  182. IPMINT=INFMOD(2+INTYPS)
  183. IF (IPMINT.NE.0) THEN
  184. MINTE = IPMINT
  185. SEGACT,MINTE
  186. ENDIF
  187. IPPORE = 0
  188. *
  189. * TEST SUR MFR : MASSIF UNIQUEMENT POUR L'INSTANT
  190. *
  191. IF (MFR.NE.1) THEN
  192. CALL ERREUR(26)
  193. GOTO 199
  194. ENDIF
  195. *
  196. * ... Verification de compatibilité des MCHAML du point de vue des
  197. * tableaux INFCHE et remplissage du tableau INFOS pour KOMCHA ...
  198. *
  199. CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,iret)
  200. IF (iret.EQ.0) GOTO 199
  201. *
  202. * ... RECHERCHE DES NOMS de COMPOSANTES ...
  203. *
  204. IF (lnomid(3).NE.0) THEN
  205. mograd = lnomid(3)
  206. ELSE
  207. lsupgr = .true.
  208. CALL IDGRAD(MFR,IFOUR,MOGRAD,NGRA,nfac)
  209. ENDIF
  210. nomid=MOGRAD
  211. SEGACT,nomid
  212. NGRA=lesobl(/2)
  213. C* nfac=lesfac(/2)
  214. *
  215. LADIM=0
  216. IF (NGRA.EQ.4) LADIM=2
  217. IF (NGRA.EQ.9) LADIM=3
  218. IF (LADIM.EQ.0) THEN
  219. CALL ERREUR(26)
  220. GOTO 199
  221. ENDIF
  222.  
  223. IF (lnomid(5).NE.0) THEN
  224. MOEPSI = lnomid(5)
  225. ELSE
  226. lsupde = .true.
  227. CALL IDDEFO(IMODEL,IFOUR,MOEPSI,NDEF,nfac)
  228. ENDIF
  229. nomid=MOEPSI
  230. SEGACT,nomid
  231. NDEF = lesobl(/2)
  232. C* nfac=lesfac(/2)
  233. *
  234. * ... VERIFICATION DE LEUR PRESENCE ...
  235. *
  236. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOGRAD,MOTYPG,1,INFOS,3,IVAGRA)
  237. IF (IERR.NE.0) GOTO 199
  238. *
  239. * Changement de support du gradient (NOEUDS vers INTYPS)
  240. IF (ISUP1.EQ.1) THEN
  241. CALL VALCHE(IVAGRA,NGRA,IPMINT,IPPORE,MOGRAD,MELE)
  242. IF (IERR.NE.0) THEN
  243. ISUP1 = 0
  244. GOTO 199
  245. ENDIF
  246. ENDIF
  247. *
  248. * ... RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER ...
  249. *
  250. N1PTEL=0
  251. N1EL =0
  252. MPTVAL=IVAGRA
  253. DO 110 ICOMP=1,NGRA
  254. MELVAL=IVAL(ICOMP)
  255. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  256. N1EL =MAX(N1EL ,VELCHE(/2))
  257. 110 CONTINUE
  258. N2PTEL=0
  259. N2EL=0
  260. *
  261. * ... Les attributs de chaque sous-zone ...
  262. *
  263. MCHEL1.INFCHE(ISOUSS,1)=0
  264. MCHEL1.INFCHE(ISOUSS,2)=0
  265. MCHEL1.INFCHE(ISOUSS,3)=NIFOUR
  266. MCHEL1.INFCHE(ISOUSS,4)=IPMINT
  267. MCHEL1.INFCHE(ISOUSS,5)=0
  268. MCHEL1.INFCHE(ISOUSS,6)=INTYPS
  269. MCHEL1.IMACHE(ISOUSS)=IPMAIL
  270. MCHEL1.CONCHE(ISOUSS)=CONMOD
  271. *
  272. * ... Création et stockage des MCHAML ...
  273. *
  274. N2 = NDEF
  275. SEGINI,MCHAM1
  276. MCHEL1.ICHAML(ISOUSS)=MCHAM1
  277. *
  278. C ... et des MELVAL de la zone élémentaire ...
  279. C
  280. NS=1
  281. NCOSOU=NDEF
  282. SEGINI,MPTVAL
  283. IVAEPS=MPTVAL
  284. NOMID=MOEPSI
  285. DO 111 ICOMP=1,NDEF
  286. MCHAM1.TYPCHE(ICOMP)='REAL*8'
  287. MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP)
  288. SEGINI,MELVAL
  289. MCHAM1.IELVAL(ICOMP)=MELVAL
  290. IVAL(ICOMP)=MELVAL
  291. 111 CONTINUE
  292. *
  293. **********************************************************************
  294. * *
  295. * BRANCHEMENT SUIVANT LA DIMENSION *
  296. * *
  297. **********************************************************************
  298. *
  299. * BOUCLE SUR LES ELEMENTS ET LES POINTS DE GAUSS
  300. *
  301. DO 31 IB=1,N1EL
  302. *
  303. DO 31 IGAU=1,N1PTEL
  304. *
  305. * ... Recherche des composantes du gradient
  306. *
  307. MPTVAL=IVAGRA
  308. DO 35 ICOMP = 1, NGRA
  309. MELVAL=IVAL(ICOMP)
  310. IGMN=MIN(IGAU,VELCHE(/1))
  311. IBMN=MIN(IB ,VELCHE(/2))
  312. F(ICOMP)=VELCHE(IGMN,IBMN)
  313. 35 CONTINUE
  314. *
  315. * ... Ajout de 1 aux termes diagonaux si mot DEPL lu
  316. *
  317. IF (IMIL.EQ.1) THEN
  318. IF (LADIM.EQ.3) THEN
  319. F(1)=F(1)+1.
  320. F(5)=F(5)+1.
  321. F(9)=F(9)+1.
  322. ELSE IF (LADIM.EQ.2) THEN
  323. F(1)=F(1)+1.
  324. F(4)=F(4)+1.
  325. ENDIF
  326. ENDIF
  327. *
  328. * ... Calcul des composantes de EPS ...
  329. *
  330. CALL EPSLN2(F,EPS,LADIM)
  331. IF (IERR.NE.0) GOTO 199
  332. *
  333. * ... et leur stockage ...
  334. *
  335. MPTVAL=IVAEPS
  336. DO 36 ICOMP=1,NDEF
  337. MELVAL=IVAL(ICOMP)
  338. VELCHE(IGAU,IB)=EPS(ICOMP)
  339. 36 CONTINUE
  340. *
  341. 31 CONTINUE
  342. *
  343. * ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ...
  344. *
  345. 199 CONTINUE
  346. *
  347. IF (IPMINT.NE.0) THEN
  348. MINTE = IPMINT
  349. SEGDES,MINTE
  350. ENDIF
  351. *
  352. IF (ISUP1.EQ.1) THEN
  353. CALL DTMVAL(IVAGRA,3)
  354. ELSE
  355. CALL DTMVAL(IVAGRA,1)
  356. ENDIF
  357. *
  358. IF (IERR.EQ.0) THEN
  359. MPTVAL=IVAEPS
  360. DO ICOMP = 1, IVAL(/1)
  361. MELVAL = IVAL(ICOMP)
  362. CALL COMRED(MELVAL)
  363. ENDDO
  364. CALL DTMVAL(IVAEPS,1)
  365. SEGDES,MCHAM1
  366. ELSE
  367. CALL DTMVAL(IVAEPS,3)
  368. SEGSUP,MCHAM1
  369. ENDIF
  370. *
  371. IF (MOGRAD.NE.0) THEN
  372. nomid=MOGRAD
  373. SEGDES,nomid
  374. IF (lsupgr) SEGSUP,nomid
  375. ENDIF
  376. *
  377. IF (MOEPSI.NE.0) THEN
  378. nomid=MOEPSI
  379. SEGDES,nomid
  380. IF (lsupde) SEGSUP,nomid
  381. ENDIF
  382. *
  383. SEGDES,IMODEL
  384. *
  385. IF (IERR.NE.0) GOTO 9991
  386. *
  387. 10 CONTINUE
  388. C ===========================================
  389. C ... FIN DE LA BOUCLE SUR LES ZONES ELEMENTAIRES ...
  390. C ===========================================
  391.  
  392. *
  393. 9991 CONTINUE
  394. SEGDES,MMODEL
  395. notype = MOTYPG
  396. SEGSUP,notype
  397. IF (IERR.NE.0) THEN
  398. SEGSUP,MCHEL1
  399. IPCHDE = 0
  400. ELSE
  401. SEGDES,MCHEL1
  402. IPCHDE = IPCHS3
  403. ENDIF
  404. 9990 CONTINUE
  405. SEGDES,MCHELM
  406.  
  407. RETURN
  408. END
  409.  
  410.  
  411.  
  412.  
  413.  
  414.  

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