Télécharger config.eso

Retour à la liste

Numérotation des lignes :

config
  1. C CONFIG SOURCE PV090527 25/04/12 21:15:01 12234
  2. SUBROUTINE CONFIG
  3. C=======================================================================
  4. C OPERATEUR TRANSFORMANT DES CHAMPS DE CONTRAINTES/DEFORMATIONS SUR
  5. C LA CONFIGURATION COURANTE OU ACTUALISANT DES CHAMPS DE
  6. C CARACTERISTIQUES
  7. C
  8. C MCHAMA (MCHAMB ...) = 'CONF' MOD1 MCHAM1 (MCHAM2 ...) ;
  9. C
  10. C Entrees :
  11. C ---------
  12. C MOD1 : OBJET MODELE (TYPE MMODEL)
  13. C MCHAM1 : OBJET MCHAML DE CONTRAINTES OU DE DEFORMATIONS
  14. C MCHAM2 : OBJET MCHAML DE CONTRAINTES OU DE DEFORMATIONS
  15. C ... : OBJET MCHAML DE CONTRAINTES OU DE DEFORMATIONS
  16. C
  17. C Sorties :
  18. C ---------
  19. C MCHAMA : OBJET MCHAML TRANSFORME DE MCHAM1
  20. C MCHAMB : OBJET MCHAML TRANSFORME DE MCHAM2
  21. C ... : OBJET MCHAML TRANSFORME DE ...
  22. C
  23. C Remarque : la configuration courante est celle du MCOORD et la
  24. C configuration associee au MCHAML est celle stockee
  25. C a l'indice mclcnf
  26. C=======================================================================
  27. IMPLICIT INTEGER(I-N)
  28. IMPLICIT REAL*8(A-H,O-Z)
  29.  
  30. -INC PPARAM
  31. -INC CCOPTIO
  32. -INC SMMODEL
  33. -INC SMCHAML
  34. -INC SMCOORD
  35. -INC SMCHPOI
  36. -INC SMELEME
  37. POINTEUR MCHEX1.MCHELM
  38. C
  39. PARAMETER(NDERI=7)
  40. CHARACTER*4 MODERI(NDERI)
  41. DATA MODERI/'LINE','QUAD','I ','II ','TRUE','JAUM','UTIL'/
  42. c -> IDERI = 1 2 1 2 3 4 5
  43. c traitement particulier uniquement si IDERI = 4 ou 5
  44. C
  45. LOGICAL CARACT
  46. SEGMENT IRESUL(0)
  47. C
  48. CHARACTER*(LOCOMP) NODEF(3),NODEG(3)
  49. CHARACTER*(LOCOMP) RODEF(3),RODEG(3)
  50. DATA NODEF / 'UX ','UY ','UZ ' /
  51. DATA NODEG / 'UR ','UZ ','UT ' /
  52. DATA RODEF / 'RX ','RY ','RZ ' /
  53. DATA RODEG / 'RR ','RZ ','RT ' /
  54. C-----------------------------------------------------------------------
  55. IPMODL=0
  56. IPCHE1=0
  57. IPCHE2=0
  58. IPCHP1=0
  59. *as xfem 2010_01_13
  60. IPCHP0=0
  61. ICHAX1=0
  62. IDERI=MEPSIL
  63. C
  64. C LECTURE DU MMODEL
  65. C
  66. CALL LIROBJ('MMODEL ',IPMODL,1,IRT1)
  67. IF(IERR.NE.0) RETURN
  68. CALL ACTOBJ('MMODEL ',IPMODL,2)
  69. IF(IERR.NE.0)RETURN
  70. C
  71. MMODEL = IPMODL
  72. NBPART = KMODEL(/1)
  73. IPICA = 0
  74. DO 4 IPART=1,NBPART
  75. IMODEL = KMODEL(IPART)
  76. C Pour certains modeles (OTTOSEN, UO2), les operateurs PICA et CAPI ne
  77. C doivent pas modifier les champs !
  78. * septembre 2019: cette restriction est enlevee
  79. ** IF ( INATUU.EQ.42 .OR. INATUU.EQ.108 ) IPICA = IPICA+1
  80. C Pour les modeles utilisateur UMAT, les contraintes sont deja de Cauchy
  81. C et ne doivent donc pas etre transportees !
  82. IF ( INATUU.EQ.-1) IPICA = IPICA+1
  83. C Verification presence XFEM
  84. *as xfem 2010_01_13
  85. NOBMO1=IVAMOD(/1)
  86. if (NOBMO1.ne.0) then
  87. Do iobmo1=1,NOBMO1
  88. if (TYMODE(iobmo1).eq.'MCHAML') then
  89. MCHEX1=IVAMOD(iobmo1)
  90. if (MCHEX1.TITCHE .eq. 'ENRICHIS') then
  91. ICHAX1 = MCHEX1.ICHAML(1)
  92. goto 3
  93. endif
  94. endif
  95. Enddo
  96. endif
  97. 3 CONTINUE
  98. *fin as xfem 2010_01_13
  99. 4 CONTINUE
  100. IPICA = 0
  101.  
  102. C Presence XFEM -> pointeur ICHAX1 non nul
  103. *as xfem 2010_01_13
  104. if (ichax1.ne.0 .and. ipchp0.EQ.0) then
  105. write(ioimp,*) 'pr un deplacement enrichi, on a besoin du ',
  106. & 'deplacement entre la config. 0 et la config. de reference'
  107. CALL ERREUR(21)
  108. return
  109. endif
  110. C
  111. C LECTURE DU(DES) MCHAML(S) A TRANSFORMER
  112. C
  113. SEGINI,IRESUL
  114. ICODE=1
  115. C ------------------------------------------------------------------
  116. 10 CONTINUE
  117. CALL LIROBJ('MCHAML ',IPIN,ICODE,IRT1)
  118. C
  119. IF (IERR.NE.0) RETURN
  120. IF (IRT1.EQ.0) GOTO 20
  121. C
  122. C sauver les configuration et passage dans mclcnf pour le reduaf
  123. MCHELM=IPIN
  124. SEGACT MCHELM
  125. if(mclcnf.eq.0.or.mclcnf.eq.mcoord) then
  126. IPCHE2=IPIN
  127. GOTO 11
  128. endif
  129. CALL ACTOBJ('MCHAML ',IPIN,2)
  130. IF(IERR.NE.0) RETURN
  131. mcoor1=mclcnf
  132. segact,mcoord,mcoor1
  133. ** write (6,*) 'mclcnf mcoord avant reduag',mclcnf,mcoord
  134. * ici faire quelque chose pour que reduaf ne plante pas sur une erreur de configuration
  135. CALL REDUAG(IPIN,IPMODL,IPCHE1,0,IR,KER)
  136. C
  137. IF (IERR.NE.0) RETURN
  138. IF (IR .NE.1) CALL ERREUR(KER)
  139.  
  140. C IPICA = NBPART -> Le modele entier contient des modeles UMAT
  141. C Recopie MCHAML IPCHE1 tel quel et on quitte
  142. IF (IPICA.EQ.NBPART) THEN
  143. CALL COPIE8(IPCHE1,IPCHE2)
  144. GOTO 11
  145. ENDIF
  146. C
  147. C Presence de caracteristiques a actualiser
  148. MCHELM=IPCHE1
  149. caract=(titche.eq.'CARACTERISTIQUES')
  150. C-----------------------------------------------------------------------
  151. C LECTURE D'UN CHPOINT DE DEPLACEMENTS
  152. C-----------------------------------------------------------------------
  153. CALL LIROBJ('CHPOINT ',IPCHP1,0,IRETOU)
  154. C
  155. IF (IRETOU.NE.0) THEN
  156. mchpoi=ipchp1
  157. call actobj('CHPOINT',mchpoi,2)
  158. ELSE
  159. C Construire le chpoint de deplacements permettant de passer de la
  160. C configuration associee au MCHAML (mcoor1) a celle courante (mcoord)
  161. NAT=2
  162. NSOUPO=1
  163. SEGINI MCHPOI
  164. ipchp1=mchpoi
  165. mtypoi='config'
  166. ifopoi=ifour
  167. jattri(1)=1
  168. C
  169. mrotat=mrota
  170. mrota1=mcoor1.mrota
  171. if(mrotat.ne.0) segact mrotat
  172. if(mrota1.ne.0) segact mrota1
  173. idimr=idim
  174. if (mrotat.ne.0) then
  175. if (xrota(/1).ne.idimr.or.xrota(/2).ne.nbpts) segadj mrotat
  176. endif
  177. if (mrota1.ne.0) then
  178. if (mrota1.xrota(/1).ne.idimr.or.mrota1.xrota(/2).ne.nbpts)
  179. > segadj mrota1
  180. endif
  181. C
  182. nct=3
  183. ncr=3
  184. nc=nct+ncr
  185. SEGINI MSOUPO
  186. ipchp(1)=msoupo
  187. if (ifour.ne.0.and.ifour.ne.1) then
  188. do i=1,nct
  189. nocomp(i)=nodef(i)
  190. enddo
  191. do i=nct+1,nc
  192. nocomp(i)=rodef(i-nct)
  193. enddo
  194. else
  195. do i=1,nct
  196. nocomp(i)=nodeg(i)
  197. enddo
  198. do i=nct+1,nc
  199. nocomp(i)=rodeg(i-nct)
  200. enddo
  201. endif
  202. C
  203. N=nbpts
  204. segini mpoval
  205. ipoval=mpoval
  206. nbpts1=mcoor1.xcoor(/1)/(idim+1)
  207. ** write(6,*) 'config nbpts nbpts1',nbpts,nbpts1
  208. do i=1,min(nbpts,nbpts1)
  209. do j=1,nct
  210. ij=(i-1)*(idim+1)+j
  211. vpocha(i,j)=xcoor(ij)-mcoor1.xcoor(ij)
  212. enddo
  213. do j=1,ncr
  214. jj=j+nct
  215. if(mrota.ne.0.and.mrota1.ne.0) then
  216. vpocha(i,jj)=xrota(j,i)-mrota1.xrota(j,i)
  217. elseif(mrota.ne.0.and.mrota1.eq.0) then
  218. vpocha(i,jj)=xrota(j,i)
  219. elseif(mrota.eq.0.and.mrota1.ne.0) then
  220. vpocha(i,jj)= -mrota1.xrota(j,i)
  221. endif
  222. enddo
  223. enddo
  224. do i=min(nbpts,nbpts1)+1,nbpts
  225. do j=1,nct
  226. ij=(i-1)*(idim+1)+j
  227. vpocha(i,j)=xcoor(ij)
  228. enddo
  229. enddo
  230. if(mrota.ne.0) then
  231. do i=min(nbpts,nbpts1)+1,nbpts
  232. do j=1,ncr
  233. jj=j+nct
  234. vpocha(i,jj)=xrota(j,i)
  235. enddo
  236. enddo
  237. endif
  238. C
  239. if (.not.caract) then
  240. do i=1,nbpts
  241. do j=1,nc
  242. vpocha(i,j)=-vpocha(i,j)
  243. enddo
  244. enddo
  245. endif
  246. C
  247. nbnn=1
  248. nbelem=nbpts
  249. nbsous=0
  250. nbref=0
  251. segini meleme
  252. itypel=1
  253. do i=1,nbelem
  254. num(1,i)=i
  255. enddo
  256. igeoc=meleme
  257. endif
  258. ** segact mchpoi
  259. ** call ecchpo(mchpoi,0)
  260. C
  261. segact mchelm*mod
  262. IF (.NOT.CARACT) THEN
  263. ** write (6,*) 'mcoors mcoord avant piocap',mcoors,mcoord,mchelm
  264. mclcnf=mcoord
  265. ** segact mcoord
  266. nbpts=xcoor(/1)/(idim+1)
  267. CALL PIOCAP(IPMODL,IPCHE1,IPCHP1,IPCHP0,ICHAX1,1,IDERI,
  268. & IPCHE2,IRET)
  269. mchelm=ipche2
  270. ** write (6,*) 'mclcnf mcoord apres piocap',mclcnf,mcoord,mchelm
  271. ELSE
  272. C Mise a jour des caracteristiques materielles
  273. ** write (6,*) 'mclcnf mcoord avant formch',mclcnf,mcoord,mchelm
  274.  
  275. CALL FORMCH(IPMODL,IPCHE1,IPCHP1,iret,IPCHE2,mcoor1)
  276. mchelm=ipche2
  277. segact mchelm*mod
  278. mclcnf=mcoord
  279. ** write (6,*) 'mclcnf mcoord apres formch',mclcnf,mcoord,mchelm
  280. ENDIF
  281. segact mcoord
  282. nbpts=xcoor(/1)/(idim+1)
  283. segdes,mcoord,mcoor1
  284. ** call verrou(3)
  285. C
  286. 11 CONTINUE
  287. IRESUL(**)=IPCHE2
  288. C
  289. ICODE = 0
  290. GOTO 10
  291. C ------------------------------------------------------------------
  292. C Ecriture du(des) objet(s) resultat(s)
  293. 20 CONTINUE
  294. C
  295. INBC=IRESUL(/1)
  296. DO IE=1,INBC
  297. IPCHE3=IRESUL(INBC+1-IE)
  298. CALL ACTOBJ('MCHAML ',IPCHE3,2)
  299. CALL ECROBJ('MCHAML ',IPCHE3)
  300. ENDDO
  301. SEGSUP,IRESUL
  302. C
  303. C Suppression du chpoint cree
  304. if (iretou.eq.0) then
  305. do isp=1,ipchp(/1)
  306. msoupo=ipchp(isp)
  307. mpoval=ipoval
  308. segsup mpoval
  309. meleme=igeoc
  310. segsup meleme
  311. segsup msoupo
  312. enddo
  313. segsup mchpoi
  314. endif
  315. END
  316.  
  317.  
  318.  

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