Télécharger ktaper.eso

Retour à la liste

Numérotation des lignes :

  1. C KTAPER SOURCE CB215821 17/01/16 21:16:13 9279
  2.  
  3. SUBROUTINE KTAPER(IPMOD0,IPCHE1,IPCHE2,C1,C2,IKTSYM, IPRIGI)
  4.  
  5. ************************************************************************
  6. * Entrees :
  7. * ---------
  8. * IPMODL pointeur sur un MMODEL
  9. * IPCHE1 pointeur sur le MCHAML decrivant l etat a t
  10. * IPCHE2 pointeur sur le MCHAML decrivant l etat a t+dt
  11. * C1 flottant
  12. * coefficient de perturbation de l increment de deformation
  13. * C2 flottant
  14. * perturbation minimale
  15. * IKTSYM =1 si matrice symetrique en sortie, =0 sinon
  16. *
  17. * Sortie :
  18. * --------
  19. * IPRIGI pointeur sur l'objet de type RIGIDITE
  20. * =0 en cas d'erreur
  21. ************************************************************************
  22. *
  23. IMPLICIT INTEGER(I-N)
  24. IMPLICIT REAL*8(A-H,O-Z)
  25. *
  26. -INC CCOPTIO
  27. -INC CCHAMP
  28.  
  29. -INC SMCHAML
  30. -INC SMCOORD
  31. -INC SMELEME
  32. -INC SMINTE
  33. -INC SMLMOTS
  34. -INC SMMODEL
  35. -INC SMRIGID
  36.  
  37. SEGMENT INFO
  38. INTEGER INFELL(JG)
  39. ENDSEGMENT
  40.  
  41. SEGMENT NOTYPE
  42. CHARACTER*16 TYPE(NBTYPE)
  43. ENDSEGMENT
  44.  
  45. SEGMENT MPTVAL
  46. INTEGER IPOS(NS) ,NSOF(NS)
  47. INTEGER IVAL(NCOSOU)
  48. CHARACTER*16 TYVAL(NCOSOU)
  49. ENDSEGMENT
  50.  
  51. SEGMENT MWRK1
  52. REAL*8 DDHOOK(LHOOK,LHOOK)
  53. REAL*8 REL(LRE,LRE), XE(3,NBBB)
  54. REAL*8 SHPWRK(6,NBBB), BGENE(LHOOK,LRE)
  55. ENDSEGMENT
  56.  
  57. * SEGMENT MWRK2
  58. * REAL*8 DDHOOK(LHOOK,LHOOK,NBPGW2,NBELW2)
  59. * ENDSEGMENT
  60.  
  61. * INTTYP definit le type de points d integration utilise
  62. PARAMETER ( INTTYP=3 )
  63.  
  64. CHARACTER*(NCONCH) CONM
  65. CHARACTER*(8) MOCOMP
  66.  
  67. PARAMETER (NINF=3)
  68. INTEGER INFOS(NINF)
  69. DIMENSION A(4,60),BB(3,60)
  70.  
  71. LOGICAL BSUPDP,BSUPFO,BSUPCO,BSUPDE,BDPGE,BDIM3
  72. LOGICAL BDEL,BDUNI,B3EL,B3UNI
  73. LOGICAL BCEL(12),BCUNI(12)
  74.  
  75. *=======================================================================
  76. *= 1 = INITIALISATIONS ET VERIFICATIONS =
  77. *=======================================================================
  78. IPRIGI = 0
  79. KERRE = 0
  80. IPMODU = 0
  81. MODEFU = 0
  82. MODIM3 = 0
  83. MOTYPE = 0
  84.  
  85. * Modele "deroule" (uniquement "MECANIQUE", "LIQUIDE" ou "POREUX")
  86. CALL PIMODL(IPMOD0,IPMODL)
  87. IF (IPMODL.EQ.0) RETURN
  88. * Reduction des champs sur le MODEL IPMOD0
  89. CALL REDUAF(IPCHE1,IPMOD0,IPCH_Z,0,IRET,KERRE)
  90. IF (IRET.NE.1) CALL ERREUR(KERRE)
  91. IF (IERR.NE.0) GOTO 9000
  92. IPCHE1=IPCH_Z
  93. CALL REDUAF(IPCHE2,IPMOD0,IPCH_Z,0,IRET,KERRE)
  94. IF (IRET.NE.1) CALL ERREUR(KERRE)
  95. IF (IERR.NE.0) GOTO 9000
  96. IPCHE2=IPCH_Z
  97.  
  98. * Activation du modele
  99. MMODEL = IPMODL
  100. SEGACT,MMODEL
  101. NSOUS = KMODEL(/1)
  102. * Initialisation de la rigidite TANGENTE
  103. NRIGEL = NSOUS
  104. SEGINI,MRIGID
  105. IPRIGI = MRIGID
  106. MTYMAT = 'RIGIDITE'
  107. ICHOLE = 0
  108. IMGEO1 = 0
  109. IMGEO2 = 0
  110. ISUPEQ = 0
  111. IFORIG = IFOUR
  112.  
  113. * Modele unitaire contenant successivement chaque sous-modele de IPMODL
  114. N1 = 1
  115. SEGINI,MMODE1
  116. IPMODU = MMODE1
  117. * Quelques segments utiles par la suite
  118. NBROBL = 1
  119. NBRFAC = 0
  120. SEGINI,NOMID
  121. MODEFU = NOMID
  122. NBROBL = 0
  123. NBRFAC = 1
  124. SEGINI,NOMID
  125. LESFAC(1) = 'DIM3'
  126. MODIM3 = NOMID
  127. NBTYPE = 1
  128. SEGINI,NOTYPE
  129. MOTYPE = NOTYPE
  130. TYPE(1) = 'REAL*8'
  131.  
  132. *=======================================================================
  133. *= 2 = BOUCLE SUR CHAQUE SOUS-MODELE A PERTURBER (Etiquette 100) =
  134. *=======================================================================
  135. DO 100 ISOUS = 1, NSOUS
  136. *
  137. SEGACT,MMODE1*MOD
  138. IMODEL = KMODEL(ISOUS)
  139. MMODE1.KMODEL(1) = IMODEL
  140. *-----------------------------------------------------------------------
  141. *- 2.1 - Initialisations associees au sous-modele ISOUS -
  142. *-----------------------------------------------------------------------
  143. IPDSCR = 0
  144. IPMADG = 0
  145. IPMATR = 0
  146. IPCONF = 0
  147. IPDIM3 = 0
  148. LISCON = 0
  149. LISDEF = 0
  150. MOCARA = 0
  151. MOCONT = 0
  152. MODEFO = 0
  153. MODEPL = 0
  154. MOFORC = 0
  155. BDIM3 = .FALSE.
  156. *-----------------------------------------------------------------------
  157. *- 2.2 - Reduction des champs sur le sous-modele ISOUS (MMODEL IPMODU) -
  158. *-----------------------------------------------------------------------
  159. * write(ioimp,*) '1er redu sur IPMODU',ISOUS,IMODEL
  160. CALL REDUAF(IPCHE1,IPMODU,IPCHE1U,0,IRET,KERRE)
  161. IF (IRET.NE.1) CALL ERREUR(KERRE)
  162. IF (IERR.NE.0) GOTO 110
  163. * write(ioimp,*) '2e redu sur IPMODU',ISOUS,IMODEL
  164. CALL REDUAF(IPCHE2,IPMODU,IPCHE2U,0,IRET,KERRE)
  165. IF (IRET.NE.1) CALL ERREUR(KERRE)
  166. IF (IERR.NE.0) GOTO 110
  167. *-----------------------------------------------------------------------
  168. *- 2.3 - Recuperation d'informations sur le sous-modele ISOUS -
  169. *-----------------------------------------------------------------------
  170. SEGACT,IMODEL
  171. IPMAIL = IMAMOD
  172. MELE = NEFMOD
  173. CONM = CONMOD
  174. IIPDPG = IPDPGE
  175. * Quelques informations liees a l'EF du sous-modele (MELE)
  176. IF (INFMOD(/1).LT.2+INTTYP) THEN
  177. CALL ELQUOI(MELE,0,INTTYP,IPINF,IMODEL)
  178. INFO = IPINF
  179. NBPGAU = INFELL(6)
  180. LRE = INFELL(9)
  181. LHOOK = INFELL(10)
  182. MFR = INFELL(13)
  183. IPMINT = INFELL(11)
  184. SEGSUP,INFO
  185. ELSE
  186. NBPGAU = INFELE(6)
  187. LRE = INFELE(9)
  188. LHOOK = INFELE(10)
  189. MFR = INFELE(13)
  190. IPMINT = INFMOD(5)
  191. ENDIF
  192. CALL INFDPG(MFR,IFOUR, BDPGE,NDPGE)
  193. MINTE = IPMINT
  194. SEGACT,MINTE
  195. * Point support des deformations planes generalisees
  196. IF (BDPGE) THEN
  197. IF (IIPDPG.LE.0) THEN
  198. CALL ERREUR(925)
  199. GOTO 110
  200. ENDIF
  201. IREF = (IIPDPG-1)*(IDIM+1)
  202. XDPGE = XCOOR(IREF+1)
  203. YDPGE = XCOOR(IREF+2)
  204. ELSE
  205. XDPGE = 0.D0
  206. YDPGE = 0.D0
  207. ENDIF
  208. * Recherche des noms d'inconnues primales
  209. IF (LNOMID(1).NE.0) THEN
  210. BSUPDP = .FALSE.
  211. MODEPL = LNOMID(1)
  212. ELSE
  213. BSUPDP = .TRUE.
  214. CALL IDPRIM(IMODEL,MFR,MODEPL,NDEPL,NFAC)
  215. ENDIF
  216. NOMID = MODEPL
  217. SEGACT,NOMID
  218. NDEPL = LESOBL(/2)
  219. * Recherche des noms d'inconnues duales
  220. IF (LNOMID(2).NE.0) THEN
  221. BSUPFO = .FALSE.
  222. MOFORC = LNOMID(2)
  223. ELSE
  224. BSUPFO = .TRUE.
  225. CALL IDDUAL(IMODEL,MFR,MOFORC,NFORC,NFAC)
  226. ENDIF
  227. NOMID = MOFORC
  228. SEGACT,NOMID
  229. NFORC = LESOBL(/2)
  230. * Recherche des composantes du champ de contraintes
  231. IF (LNOMID(4).NE.0) THEN
  232. BSUPCO = .FALSE.
  233. MOCONT = LNOMID(4)
  234. ELSE
  235. BSUPCO = .TRUE.
  236. CALL IDCONT(IMODEL,IFOUR,MOCONT,NSTRS,NFAC)
  237. ENDIF
  238. NOMID = MOCONT
  239. SEGACT,NOMID
  240. NSTRS = LESOBL(/2)
  241. NFAC = LESFAC(/2)
  242. NBCONT = NSTRS
  243. *AV cas ou NFAC non nul !
  244. *AV NBCONT = NSTRS + NFAC
  245. * Creation d'une liste de mots des composantes de contraintes
  246. JGN = LESOBL(/1)
  247. JGM = NBCONT
  248. SEGINI,MLMOTS
  249. DO i = 1, NSTRS
  250. MOTS(i) = LESOBL(i)
  251. ENDDO
  252. *AV IF (NFAC.NE.0) THEN
  253. *AV DO i = 1, NFAC
  254. *AV MOTS(NSTRS+i) = LESFAC(i)
  255. *AV ENDDO
  256. *AV ENDIF
  257. LISCON = MLMOTS
  258. * Recherche des composantes obligatoires du champ de deformations
  259. IF (LNOMID(5).NE.0) THEN
  260. BSUPDE = .FALSE.
  261. MODEFO = LNOMID(5)
  262. ELSE
  263. BSUPDE = .TRUE.
  264. CALL IDDEFO(IMODEL,IFOUR,MODEFO,NBDEFO,NFAC)
  265. ENDIF
  266. NOMID = MODEFO
  267. SEGACT,NOMID
  268. NDEFO = LESOBL(/2)
  269. NFAC = LESFAC(/2)
  270. NBDEFO = NDEFO
  271. *AV cas ou NFAC non nul !
  272. *AV NBDEFO = NDEFO + NFAC
  273. * Creation d'une liste de mots des composantes de contraintes
  274. JGN = LESOBL(/1)
  275. JGM = NBDEFO
  276. SEGINI,MLMOTS
  277. DO i = 1, NDEFO
  278. MOTS(i) = LESOBL(i)
  279. ENDDO
  280. *AV IF (NFAC.NE.0) THEN
  281. *AV DO i = 1, NFAC
  282. *AV MOTS(NDEFO+i) = LESFAC(i)
  283. *AV ENDDO
  284. *AV ENDIF
  285. LISDEF = MLMOTS
  286. * Petite verification
  287. IF ((NDEPL.EQ.0).OR.(NFORC.EQ.0).OR.(NDEPL.NE.NFORC).OR.
  288. & (NBDEFO.EQ.0).OR.(NBCONT.EQ.0).OR.(NBDEFO.NE.NBCONT)) THEN
  289. KERRE = 5
  290. GOTO 120
  291. ENDIF
  292. *-----------------------------------------------------------------------
  293. *- 2.4 - Matrice de RIGIDITE de la sous-zone ISOUS -
  294. *-----------------------------------------------------------------------
  295. * Segment DESCR
  296. MELEME=IPMAIL
  297. SEGACT,MELEME
  298. * Modification du MELEME contenu dans segment DESCRipteur
  299. IF (BDPGE) THEN
  300. IPT1 = IPMAIL
  301. NBNN = IPT1.NUM(/1)+1
  302. NBELEM = IPT1.NUM(/2)
  303. NBREF = 0
  304. NBSOUS = 0
  305. SEGINI,MELEME
  306. DO i = 1, NBELEM
  307. DO j = 1, NBNN-1
  308. NUM(j,i) = IPT1.NUM(j,i)
  309. ENDDO
  310. NUM(NBNN,i) = IIPDPG
  311. ENDDO
  312. ITYPEL = 28
  313. ICOLOR = IPT1.ICOLOR
  314. SEGDES,MELEME
  315. ELSE
  316. NBNN=NUM(/1)
  317. NBELEM=NUM(/2)
  318. ENDIF
  319. IPMADG=MELEME
  320. IF (BDPGE) THEN
  321. NCOMP = NDEPL-NDPGE
  322. NBNNS = NBNN-1
  323. ELSE
  324. NCOMP = NDEPL
  325. NBNNS = NBNN
  326. ENDIF
  327. IF (NBNNS*NCOMP .GT. LRE) THEN
  328. * Erreur dans les dimensions de DESCR
  329. KERRE = 717
  330. GOTO 120
  331. ENDIF
  332. * Remplissage du segment DESCRipteur
  333. NLIGRP = LRE
  334. NLIGRD = LRE
  335. SEGINI,DESCR
  336. IDDL = 1
  337. DO IPT = 1, NBNNS
  338. DO ICOMP = 1, NCOMP
  339. NOMID = MODEPL
  340. LISINC(IDDL) = LESOBL(ICOMP)
  341. NOMID = MOFORC
  342. LISDUA(IDDL) = LESOBL(ICOMP)
  343. NOELEP(IDDL) = IPT
  344. NOELED(IDDL) = IPT
  345. IDDL = IDDL+1
  346. ENDDO
  347. ENDDO
  348. IF (BDPGE) THEN
  349. DO ICOMP = (NDPGE-1),0,-1
  350. NOMID = MODEPL
  351. LISINC(IDDL) = LESOBL(NDEPL-ICOMP)
  352. NOMID = MOFORC
  353. LISDUA(IDDL) = LESOBL(NFORC-ICOMP)
  354. NOELEP(IDDL) = NBNN
  355. NOELED(IDDL) = NBNN
  356. IDDL = IDDL+1
  357. ENDDO
  358. ENDIF
  359. SEGDES,DESCR
  360. IPDSCR = DESCR
  361. * Initialisation du segment XMATRI
  362. NLIGRD = LRE
  363. NLIGRP = LRE
  364. NELRIG = NBELEM
  365. SEGINI,XMATRI
  366. IPMATR = XMATRI
  367. * Remplissage du segment MRIGID
  368. COERIG(ISOUS) = 1.D0
  369. IRIGEL(1,ISOUS) = IPMADG
  370. * IRIGEL(2,ISOUS) = 0
  371. IRIGEL(3,ISOUS) = IPDSCR
  372. IRIGEL(4,ISOUS) = IPMATR
  373. IRIGEL(5,ISOUS) = NIFOUR
  374. * IRIGEL(6,ISOUS) = 0
  375. * Pas de symetrie de la matrice de rigidite (sauf si demande)
  376. IRIGEL(7,ISOUS) = 2*(1-IKTSYM)
  377. * IRIGEL(8,ISOUS) = 0
  378. *-----------------------------------------------------------------------
  379. *- 2.5 - Recuperation des contraintes finales (reference) -
  380. *-----------------------------------------------------------------------
  381. CALL ECROBJ('MCHAML',IPCHE2U)
  382. CALL ECROBJ('LISTMOTS',LISCON)
  383. CALL EXCOMP
  384. IF (IERR.NE.0) GOTO 130
  385. CALL LIROBJ('MCHAML',IPCONF,1,IRET)
  386. IF (IERR.NE.0) GOTO 130
  387. * Verification du support pour les contraintes finales (IPCONF)
  388. CALL QUESUP(IPMODU,IPCONF,INTTYP,0,ISUPCH,IRET)
  389. IF (ISUPCH.GT.1) THEN
  390. KERRE = 609
  391. GOTO 130
  392. ENDIF
  393. *-----------------------------------------------------------------------
  394. *- 2.6 - Recuperation eventuelle de l'epaisseur DIM3 -
  395. *-----------------------------------------------------------------------
  396. MELVA3 = 0
  397. DIM3 = 1.
  398. MOCOMP = 'DIM3'
  399. CALL EXISCO('MCHAML ',IPCHE2U,MOCOMP,BDIM3)
  400. IF (BDIM3) THEN
  401. CALL EXCOC1(IPCHE2U,MOCOMP,IPDIM3,MOCOMP,1)
  402. * Verification du support pour DIM3 (IPDIM3)
  403. CALL QUESUP(IPMODU,IPDIM3,INTTYP,0,ISUPD3,IRET)
  404. IF (ISUPD3.GT.1) THEN
  405. KERRE = 609
  406. GOTO 130
  407. ENDIF
  408. ENDIF
  409. *-----------------------------------------------------------------------
  410. *- 2.7 - Boucle de CALCUL DE LA PERTURBATION sur chaque composante -
  411. *-----------------------------------------------------------------------
  412. DO 200 ICOMP = 1, NBDEFO
  413. *
  414. *- 2.7.1 - Recuperation de la composante de deformation a perturber
  415. MLMOTS = LISDEF
  416. MOCOMP = MOTS(ICOMP)
  417. NOMID = MODEFU
  418. SEGACT,NOMID*MOD
  419. LESOBL(1) = MOCOMP
  420. *- 2.7.2 - Quelques initialisations
  421. IPCHF2U = 0
  422. IPCHP2U = 0
  423. IPCOPE = 0
  424. IPDEFI = 0
  425. IPDEFF = 0
  426. IPPERT = 0
  427. IVACON = 0
  428. IVADEF = 0
  429. IVADM3 = 0
  430. MWRK1 = 0
  431. *- 2.7.3 - Calcul de l'increment de deformation pour la composante ICOMP
  432. CALL EXCOC1(IPCHE1U,MOCOMP,IPDEFI,MOCOMP,0)
  433. IF (IERR.NE.0) GOTO 210
  434. CALL EXCOC1(IPCHE2U,MOCOMP,IPDEFF,MOCOMP,0)
  435. IF (IERR.NE.0) GOTO 210
  436. CALL ADCHEL(IPDEFF,IPDEFI,IPPERT,-1)
  437. * Verification du support pour la perturbation
  438. CALL QUESUP(IPMODU,IPPERT,INTTYP,0,ISUPDE,IRET)
  439. IF (ISUPDE.GT.1) THEN
  440. CALL ERREUR(609)
  441. GOTO 210
  442. ENDIF
  443. *- 2.7.4 - Calcul de la perturbation sur la composante ICOMP (IPPERT)
  444. * IncDef = Def_Fin - Def_Ini
  445. * La perturbation vaut MAX(c1*ABS(IncDef),c2)*SIGNE(IncDEF)
  446. MCHELM = IPPERT
  447. N1 = ICHAML(/1)
  448. DO i1 = 1, N1
  449. MCHAML = ICHAML(i1)
  450. SEGACT,MCHAML
  451. if (ielval(/1).ne.1) then
  452. write(ioimp,*) 'nb composantes different de 1 !'
  453. call erreur(2)
  454. goto 210
  455. endif
  456. if (typche(1).ne.'REAL*8') then
  457. moterr(1:16) = typche(1)
  458. moterr(17:20) = nomche(1)(1:4)
  459. moterr(21:36) = 'DEFORMATION'
  460. call erreur(552)
  461. goto 210
  462. endif
  463. MELVAL = IELVAL(1)
  464. SEGACT,MELVAL*MOD
  465. N1PTEL = VELCHE(/1)
  466. N1EL = VELCHE(/2)
  467. DO IEL = 1, N1EL
  468. DO IPT = 1, N1PTEL
  469. V1 = C1 * VELCHE(IPT,IEL)
  470. IF (V1.GE.0.) THEN
  471. VELCHE(IPT,IEL) = MAX(V1,C2)
  472. ELSE
  473. VELCHE(IPT,IEL) = MIN(V1,-C2)
  474. ENDIF
  475. ENDDO
  476. ENDDO
  477. * SEGDES,MELVAL,MCHAML
  478. ENDDO
  479. * SEGDES,MCHELM
  480. *- 2.7.5 - Deformations finales perturbees pour appel a COMP
  481. CALL ADCHEL(IPCHE2U,IPPERT,IPCHF2U,1)
  482. *- 2.7.6 - Appel a COMP pour obtenir l'etat final perturbe
  483. CALL ECROBJ('MCHAML ',IPCHF2U)
  484. CALL ECROBJ('MCHAML ',IPCHE1U)
  485. CALL ECROBJ('MMODEL ',IPMODU)
  486. CALL COML
  487. IF (IERR.NE.0) GOTO 210
  488. CALL LIROBJ('MCHAML ',IPCHP2U,1,IRET)
  489. IF (IERR.NE.0) GOTO 210
  490. *- 2.7.7 - Recuperation du champ de contraintes finales perturbees
  491. CALL ECROBJ('MCHAML',IPCHP2U)
  492. CALL ECROBJ('LISTMOTS',LISCON)
  493. CALL EXCOMP
  494. IF (IERR.NE.0) GOTO 210
  495. CALL LIROBJ('MCHAML',IPCONP,1,IRET)
  496. IF (IERR.NE.0) GOTO 210
  497. *- 2.7.8 - Calcul de l'increment de contraintes du a la perturbation
  498. CALL ADCHEL(IPCONP,IPCONF,IPCOPE,-1)
  499. CALL QUESUP(IPMODU,IPCOPE,INTTYP,0,ISUPCO,IRET)
  500. IF (ISUPCO.GT.1) THEN
  501. CALL ERREUR(609)
  502. GOTO 210
  503. ENDIF
  504. *- 2.7.9 - Quelques informations necessaires
  505. CALL IDENT(IPMAIL,CONM,IPCOPE,IPPERT,INFOS,IRET)
  506. IF (IRET.EQ.0) GOTO 210
  507. MELEME = IPMAIL
  508. SEGACT,MELEME
  509. NBNN = NUM(/1)
  510. NBELEM = NUM(/2)
  511. *- 2.7.10 - Recuperation de l'epaisseur (fait une seule fois) (IVADM3)
  512. IF (BDIM3 .AND. ICOMP.EQ.1) THEN
  513. CALL KOMCHA(IPDIM3,IPMAIL,CONM,MODIM3,MOTYPE,0,INFOS,NINF,
  514. & IVADM3)
  515. IF (IERR.NE.0) GOTO 220
  516. IF (ISUPD3.EQ.1) THEN
  517. CALL VALCHE(IVADM3,1,IPMINT,0,MODIM3,MELE)
  518. IF (IERR.NE.0) THEN
  519. ISUPD3 = 0
  520. GOTO 220
  521. ENDIF
  522. ENDIF
  523. MPTVAL = IVADM3
  524. MELVA3 = IVAL(1)
  525. * Determination du type de champ d'epaisseur 'DIM3' :
  526. * champ constant par element (B3EL) ou uniforme (B3UNI)
  527. IF (MELVA3.NE.0) THEN
  528. B3EL = .FALSE.
  529. B3UNI = .FALSE.
  530. N1PTEL = MELVA3.VELCHE(/1)
  531. N1EL = MELVA3.VELCHE(/2)
  532. IF (N1PTEL.NE.NBPGAU) THEN
  533. IF (N1PTEL.NE.1) THEN
  534. CALL ERREUR(21)
  535. GOTO 220
  536. ENDIF
  537. B3EL = .TRUE.
  538. ENDIF
  539. IF (N1EL.NE.NBELEM) THEN
  540. IF (N1EL.NE.1) THEN
  541. CALL ERREUR(21)
  542. GOTO 220
  543. ENDIF
  544. B3UNI = .TRUE.
  545. ENDIF
  546. ENDIF
  547. ENDIF
  548. *- 2.7.11 - Recuperation de la deformation perturbee (IVADEF)
  549. CALL KOMCHA(IPPERT,IPMAIL,CONM,MODEFU,MOTYPE,1,INFOS,NINF,
  550. & IVADEF)
  551. IF (IERR.NE.0) GOTO 220
  552. IF (ISUPDE.EQ.1) THEN
  553. CALL VALCHE(IVADEF,1,IPMINT,0,MODEFU,MELE)
  554. IF (IERR.NE.0) THEN
  555. ISUPDE = 0
  556. GOTO 220
  557. ENDIF
  558. ENDIF
  559. * Determination du type de la perturbation :
  560. * champ constant par element (BDEL) ou uniforme (BDUNI)
  561. MPTVAL = IVADEF
  562. MELVA2 = IVAL(1)
  563. N1PTEL = MELVA2.VELCHE(/1)
  564. N1EL = MELVA2.VELCHE(/2)
  565. BDEL = .FALSE.
  566. BDUNI = .FALSE.
  567. IF (N1PTEL.NE.NBPGAU) THEN
  568. BDEL = .TRUE.
  569. IF (N1PTEL.NE.1) THEN
  570. CALL ERREUR(21)
  571. GOTO 220
  572. ENDIF
  573. ENDIF
  574. IF (N1EL.NE.NBELEM) THEN
  575. BDUNI = .TRUE.
  576. IF (N1EL.NE.1) THEN
  577. CALL ERREUR(21)
  578. GOTO 220
  579. ENDIF
  580. ENDIF
  581. *- 2.7.12 - Recuperation de l'increment de contraintes (IVACON)
  582. CALL KOMCHA(IPCOPE,IPMAIL,CONM,MOCONT,MOTYPE,1,INFOS,NINF,
  583. & IVACON)
  584. IF (IERR.NE.0) GOTO 220
  585. IF (ISUPCO.EQ.1) THEN
  586. CALL VALCHE(IVACON,NBCONT,IPMINT,0,MOCONT,MELE)
  587. IF (IERR.NE.0) THEN
  588. ISUPCO = 0
  589. GOTO 220
  590. ENDIF
  591. ENDIF
  592. * Determination du type de chaque composante des contraintes :
  593. * champ constant par element (BCEL(i)) ou uniforme (BCUNI(i))
  594. MPTVAL = IVACON
  595. DO i = 1, NBCONT
  596. BCEL(i) = .FALSE.
  597. BCUNI(i) = .FALSE.
  598. MELVAL = IVAL(i)
  599. N1PTEL = VELCHE(/1)
  600. N1EL = VELCHE(/2)
  601. IF (N1PTEL.NE.NBPGAU) THEN
  602. BCEL(i) = .TRUE.
  603. IF (N1PTEL.NE.1) THEN
  604. CALL ERREUR(21)
  605. GOTO 220
  606. ENDIF
  607. ENDIF
  608. IF (N1EL.NE.NBELEM) THEN
  609. BCUNI(i) = .TRUE.
  610. IF (N1EL.NE.1) THEN
  611. CALL ERREUR(21)
  612. GOTO 220
  613. ENDIF
  614. ENDIF
  615. ENDDO
  616. *- 2.7.13 - Activation & initialisation de quelques segments
  617. NHRM = NIFOUR
  618. * SEGACT,MELEME
  619. * SEGACT,MINTE
  620. NBBB = NBNN
  621. SEGINI,MWRK1
  622. * CALL ZERO(DDHOOK,LHOOK,LHOOK)
  623. MPTVAL = IVACON
  624. *
  625. *- 2.7.14 - Boucle sur les ELEMENTs : mise a jour matrice REL(.,.,IEL)
  626. *-----------------------------------------------------------------------
  627. DO 300 IEL = 1, NBELEM
  628. * Remise a zero de REL
  629. CALL ZERO(REL,LRE,LRE)
  630. * Coordonnees des noeuds de l element
  631. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  632. * Calcul des coeff de modification de la matrice B-BARRE
  633. * (Uniquement en cas d'elements incompressibles)
  634. IF (MFR.EQ.31) THEN
  635. CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU,
  636. & POIGAU,QSIGAU,ETAGAU,DZEGAU,NBCONT,LRE,
  637. & IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE)
  638. ENDIF
  639. * Champs uniformes ?
  640. IF (BDUNI) THEN
  641. IBD = 1
  642. ELSE
  643. IBD = IEL
  644. ENDIF
  645. IF (BDIM3) THEN
  646. IF (B3UNI) THEN
  647. IB3 = 1
  648. ELSE
  649. IB3 = IEL
  650. ENDIF
  651. ENDIF
  652. ISDJC=0
  653. * Boucle sur les POINTS d'INTEGRATION
  654. *-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -
  655. DO 400 IGAU = 1, NBPGAU
  656. * Calcul de B et du jacobien
  657. IF (MELVA3.NE.0) THEN
  658. IF (B3EL) THEN
  659. DIM3 = MELVA3.VELCHE(1,IB3)
  660. ELSE
  661. DIM3 = MELVA3.VELCHE(IGAU,IB3)
  662. ENDIF
  663. ENDIF
  664. IF (MELE.NE.28.AND.MELE.NE.45) THEN
  665. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  666. & MELE,MFR,NBNN,LRE,IFOUR,NBCONT,NHRM,DIM3,
  667. & XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  668. ELSE
  669. CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  670. & MELE,MFR,NBNN,LRE,IFOUR,NBCONT,NHRM,DIM3,
  671. & XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  672. ENDIF
  673. IF (DJAC.EQ.0.) THEN
  674. INTERR(1) = IEL
  675. CALL ERREUR(259)
  676. GOTO 220
  677. ENDIF
  678. IF (DJAC.LT.0.) ISDJC=ISDJC+1
  679. DJAC = ABS(DJAC)*POIGAU(IGAU)
  680. * En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  681. IF (MFR.EQ.31) THEN
  682. CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  683. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  684. ENDIF
  685. * Perturbation constante par element ou uniforme
  686. IF (BDEL) THEN
  687. IGAUD = 1
  688. ELSE
  689. IGAUD = IGAU
  690. ENDIF
  691. * Pour chaque composante des contraintes :
  692. DO i = 1, NBCONT
  693. MELVAL = IVAL(i)
  694. * Contrainte constante par element ou uniforme
  695. IF (BCEL(i)) THEN
  696. IGAUC = 1
  697. ELSE
  698. IGAUC = IGAU
  699. ENDIF
  700. IF (BCUNI(i)) THEN
  701. IBC = 1
  702. ELSE
  703. IBC = IEL
  704. ENDIF
  705. * Calcul de DDHOOK(i) = (cont pert - fin) / defo pert
  706. DDHOOK(i,ICOMP) =
  707. & VELCHE(IGAUC,IBC) / MELVA2.VELCHE(IGAUD,IBD)
  708. ENDDO
  709. * Calcul de BDB par appel a DBDSTS : cas non symetrique
  710. *AV? appel a EFFI2 dans RIGI. EFFI2 MODIFIE REL
  711. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,NBCONT,REL)
  712. *
  713. 400 CONTINUE
  714. * Fin de la Boucle sur les POINTS d'INTEGRATION (etiquette 400)
  715. *-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -
  716. * Changement de signe du jacobien dans l element ?
  717. IF ((ISDJC.NE.0).AND.(ISDJC.NE.NBPGAU)) THEN
  718. INTERR(1) = IEL
  719. CALL ERREUR(195)
  720. GOTO 220
  721. ENDIF
  722. * Mise a jour de la matrice de rigidite elementaire RE
  723. IF (IKTSYM.EQ.0) THEN
  724. DO i = 1, LRE
  725. DO j = 1, LRE
  726. RE(i,j,IEL) = RE(i,j,IEL) + REL(i,j)
  727. ENDDO
  728. ENDDO
  729. ELSE
  730. DO i = 1, LRE
  731. DO j = 1, i
  732. RE(i,j,IEL) = RE(i,j,IEL) + 0.5 * (REL(i,j)+REL(j,i))
  733. RE(j,i,IEL) = RE(i,j,IEL)
  734. ENDDO
  735. ENDDO
  736. ENDIF
  737. 300 CONTINUE
  738. *- Fin de la boucle sur les ELEMENTs (Etiquette 300)
  739. *-----------------------------------------------------------------------
  740. *- 2.7.15 - Menage : Desactivation-Destruction de segments
  741. 220 CONTINUE
  742. IF (ISUPCO.EQ.1) THEN
  743. CALL DTMVAL(IVACON,3)
  744. ELSE
  745. CALL DTMVAL(IVACON,1)
  746. ENDIF
  747. IF (ISUPDE.EQ.1) THEN
  748. CALL DTMVAL(IVADEF,3)
  749. ELSE
  750. CALL DTMVAL(IVADEF,1)
  751. ENDIF
  752. IF (BDIM3) THEN
  753. IF (ICOMP.EQ.NBDEFO .OR. IERR.NE.0) THEN
  754. IF (ISUPD3.EQ.1) THEN
  755. CALL DTMVAL(IVADM3,3)
  756. ELSE
  757. CALL DTMVAL(IVADM3,1)
  758. ENDIF
  759. ENDIF
  760. ENDIF
  761. IF (MWRK1.NE.0) SEGSUP,MWRK1
  762. MELEME = IPMAIL
  763. SEGDES,MELEME
  764. 210 CONTINUE
  765. IF (IPDEFI.NE.0) CALL DTCHAM(IPDEFI)
  766. IF (IPDEFF.NE.0) CALL DTCHAM(IPDEFF)
  767. IF (IPPERT.NE.0) CALL DTCHAM(IPPERT)
  768. IF (IPCONP.NE.0) CALL DTCHAM(IPCONP)
  769. IF (IPCOPE.NE.0) CALL DTCHAM(IPCOPE)
  770. IF (IERR.NE.0) GOTO 130
  771. *
  772. 200 CONTINUE
  773. *- Fin de la boucle de CALCUL DE LA PERTURBATION (Etiquette 200)
  774. *-----------------------------------------------------------------------
  775. *- 2.8 - Menage : Desactivation-Suppression de segments... -
  776. *-----------------------------------------------------------------------
  777. 130 CONTINUE
  778. SEGDES,DESCR
  779. SEGDES,XMATRI
  780. IF (IPCONF.NE.0) CALL DTCHAM(IPCONF)
  781. IF (IPDIM3.NE.0) CALL DTCHAM(IPDIM3)
  782. 120 CONTINUE
  783. NOMID = MODEPL
  784. IF (BSUPDP) THEN
  785. SEGSUP,NOMID
  786. ELSE
  787. SEGDES,NOMID
  788. ENDIF
  789. NOMID = MOFORC
  790. IF (BSUPFO) THEN
  791. SEGSUP,NOMID
  792. ELSE
  793. SEGDES,NOMID
  794. ENDIF
  795. NOMID = MOCONT
  796. IF (BSUPCO) THEN
  797. SEGSUP,NOMID
  798. ELSE
  799. SEGDES,NOMID
  800. ENDIF
  801. MLMOTS = LISCON
  802. SEGSUP,MLMOTS
  803. NOMID = MODEFO
  804. IF (BSUPDE) THEN
  805. SEGSUP,NOMID
  806. ELSE
  807. SEGDES,NOMID
  808. ENDIF
  809. MLMOTS = LISDEF
  810. SEGSUP,MLMOTS
  811. SEGDES,MINTE
  812. * Fin du traitement en cas d'erreur
  813. 110 CONTINUE
  814. IF (IERR.NE.0 .OR. KERRE.NE.0) THEN
  815. IF (IPDSCR.NE.0) SEGSUP,DESCR
  816. IF (IPMATR.NE.0) SEGSUP,XMATRI
  817. IF (KERRE.NE.0) CALL ERREUR(KERRE)
  818. GOTO 9000
  819. ENDIF
  820. *=======================================================================
  821. 100 CONTINUE
  822. *=======================================================================
  823.  
  824. *=======================================================================
  825. *= 3 = FIN DU TRAITEMENT (MENAGE...) =
  826. *=======================================================================
  827. 9000 CONTINUE
  828. * Suppression du modele "deroule"
  829. MMODEL = IPMODL
  830. DO i = 1, NSOUS
  831. IMODEL = KMODEL(i)
  832. SEGDES,IMODEL
  833. ENDDO
  834. SEGSUP,MMODEL
  835. * Suppresion du modele unitaire
  836. IF (IPMODU.NE.0) SEGSUP,MMODE1
  837. * Suppressions des "petits segments"
  838. IF (MODEFU.NE.0) THEN
  839. NOMID = MODEFU
  840. SEGSUP,NOMID
  841. ENDIF
  842. IF (MODIM3.NE.0) THEN
  843. NOMID = MODIM3
  844. SEGSUP,NOMID
  845. ENDIF
  846. IF (MOTYPE.NE.0) SEGSUP,NOTYPE
  847. * Envoi de la matrice de rigidite (sauf erreur)
  848. IF (IERR.NE.0) THEN
  849. IF (IPRIGI.NE.0) SEGSUP,MRIGID
  850. IPRIGI = 0
  851. ELSE
  852. ** IPRIGI = MRIGID
  853. ** SEGDES,MRIGID
  854. CALL REPART(IPRIGI)
  855. ENDIF
  856. *
  857. RETURN
  858. END
  859.  
  860.  
  861.  
  862.  
  863.  
  864.  
  865.  
  866.  

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