Télécharger ktaper.eso

Retour à la liste

Numérotation des lignes :

  1. C KTAPER SOURCE PV 17/09/29 21:15:32 9578
  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. xmatri.symre=irigel(7,isous)
  378. * IRIGEL(8,ISOUS) = 0
  379. *-----------------------------------------------------------------------
  380. *- 2.5 - Recuperation des contraintes finales (reference) -
  381. *-----------------------------------------------------------------------
  382. CALL ECROBJ('MCHAML',IPCHE2U)
  383. CALL ECROBJ('LISTMOTS',LISCON)
  384. CALL EXCOMP
  385. IF (IERR.NE.0) GOTO 130
  386. CALL LIROBJ('MCHAML',IPCONF,1,IRET)
  387. IF (IERR.NE.0) GOTO 130
  388. * Verification du support pour les contraintes finales (IPCONF)
  389. CALL QUESUP(IPMODU,IPCONF,INTTYP,0,ISUPCH,IRET)
  390. IF (ISUPCH.GT.1) THEN
  391. KERRE = 609
  392. GOTO 130
  393. ENDIF
  394. *-----------------------------------------------------------------------
  395. *- 2.6 - Recuperation eventuelle de l'epaisseur DIM3 -
  396. *-----------------------------------------------------------------------
  397. MELVA3 = 0
  398. DIM3 = 1.
  399. MOCOMP = 'DIM3'
  400. CALL EXISCO('MCHAML ',IPCHE2U,MOCOMP,BDIM3)
  401. IF (BDIM3) THEN
  402. CALL EXCOC1(IPCHE2U,MOCOMP,IPDIM3,MOCOMP,1)
  403. * Verification du support pour DIM3 (IPDIM3)
  404. CALL QUESUP(IPMODU,IPDIM3,INTTYP,0,ISUPD3,IRET)
  405. IF (ISUPD3.GT.1) THEN
  406. KERRE = 609
  407. GOTO 130
  408. ENDIF
  409. ENDIF
  410. *-----------------------------------------------------------------------
  411. *- 2.7 - Boucle de CALCUL DE LA PERTURBATION sur chaque composante -
  412. *-----------------------------------------------------------------------
  413. DO 200 ICOMP = 1, NBDEFO
  414. *
  415. *- 2.7.1 - Recuperation de la composante de deformation a perturber
  416. MLMOTS = LISDEF
  417. MOCOMP = MOTS(ICOMP)
  418. NOMID = MODEFU
  419. SEGACT,NOMID*MOD
  420. LESOBL(1) = MOCOMP
  421. *- 2.7.2 - Quelques initialisations
  422. IPCHF2U = 0
  423. IPCHP2U = 0
  424. IPCOPE = 0
  425. IPDEFI = 0
  426. IPDEFF = 0
  427. IPPERT = 0
  428. IVACON = 0
  429. IVADEF = 0
  430. IVADM3 = 0
  431. MWRK1 = 0
  432. *- 2.7.3 - Calcul de l'increment de deformation pour la composante ICOMP
  433. CALL EXCOC1(IPCHE1U,MOCOMP,IPDEFI,MOCOMP,0)
  434. IF (IERR.NE.0) GOTO 210
  435. CALL EXCOC1(IPCHE2U,MOCOMP,IPDEFF,MOCOMP,0)
  436. IF (IERR.NE.0) GOTO 210
  437. CALL ADCHEL(IPDEFF,IPDEFI,IPPERT,-1)
  438. * Verification du support pour la perturbation
  439. CALL QUESUP(IPMODU,IPPERT,INTTYP,0,ISUPDE,IRET)
  440. IF (ISUPDE.GT.1) THEN
  441. CALL ERREUR(609)
  442. GOTO 210
  443. ENDIF
  444. *- 2.7.4 - Calcul de la perturbation sur la composante ICOMP (IPPERT)
  445. * IncDef = Def_Fin - Def_Ini
  446. * La perturbation vaut MAX(c1*ABS(IncDef),c2)*SIGNE(IncDEF)
  447. MCHELM = IPPERT
  448. N1 = ICHAML(/1)
  449. DO i1 = 1, N1
  450. MCHAML = ICHAML(i1)
  451. SEGACT,MCHAML
  452. if (ielval(/1).ne.1) then
  453. write(ioimp,*) 'nb composantes different de 1 !'
  454. call erreur(2)
  455. goto 210
  456. endif
  457. if (typche(1).ne.'REAL*8') then
  458. moterr(1:16) = typche(1)
  459. moterr(17:20) = nomche(1)(1:4)
  460. moterr(21:36) = 'DEFORMATION'
  461. call erreur(552)
  462. goto 210
  463. endif
  464. MELVAL = IELVAL(1)
  465. SEGACT,MELVAL*MOD
  466. N1PTEL = VELCHE(/1)
  467. N1EL = VELCHE(/2)
  468. DO IEL = 1, N1EL
  469. DO IPT = 1, N1PTEL
  470. V1 = C1 * VELCHE(IPT,IEL)
  471. IF (V1.GE.0.) THEN
  472. VELCHE(IPT,IEL) = MAX(V1,C2)
  473. ELSE
  474. VELCHE(IPT,IEL) = MIN(V1,-C2)
  475. ENDIF
  476. ENDDO
  477. ENDDO
  478. * SEGDES,MELVAL,MCHAML
  479. ENDDO
  480. * SEGDES,MCHELM
  481. *- 2.7.5 - Deformations finales perturbees pour appel a COMP
  482. CALL ADCHEL(IPCHE2U,IPPERT,IPCHF2U,1)
  483. *- 2.7.6 - Appel a COMP pour obtenir l'etat final perturbe
  484. CALL ECROBJ('MCHAML ',IPCHF2U)
  485. CALL ECROBJ('MCHAML ',IPCHE1U)
  486. CALL ECROBJ('MMODEL ',IPMODU)
  487. CALL COML
  488. IF (IERR.NE.0) GOTO 210
  489. CALL LIROBJ('MCHAML ',IPCHP2U,1,IRET)
  490. IF (IERR.NE.0) GOTO 210
  491. *- 2.7.7 - Recuperation du champ de contraintes finales perturbees
  492. CALL ECROBJ('MCHAML',IPCHP2U)
  493. CALL ECROBJ('LISTMOTS',LISCON)
  494. CALL EXCOMP
  495. IF (IERR.NE.0) GOTO 210
  496. CALL LIROBJ('MCHAML',IPCONP,1,IRET)
  497. IF (IERR.NE.0) GOTO 210
  498. *- 2.7.8 - Calcul de l'increment de contraintes du a la perturbation
  499. CALL ADCHEL(IPCONP,IPCONF,IPCOPE,-1)
  500. CALL QUESUP(IPMODU,IPCOPE,INTTYP,0,ISUPCO,IRET)
  501. IF (ISUPCO.GT.1) THEN
  502. CALL ERREUR(609)
  503. GOTO 210
  504. ENDIF
  505. *- 2.7.9 - Quelques informations necessaires
  506. CALL IDENT(IPMAIL,CONM,IPCOPE,IPPERT,INFOS,IRET)
  507. IF (IRET.EQ.0) GOTO 210
  508. MELEME = IPMAIL
  509. SEGACT,MELEME
  510. NBNN = NUM(/1)
  511. NBELEM = NUM(/2)
  512. *- 2.7.10 - Recuperation de l'epaisseur (fait une seule fois) (IVADM3)
  513. IF (BDIM3 .AND. ICOMP.EQ.1) THEN
  514. CALL KOMCHA(IPDIM3,IPMAIL,CONM,MODIM3,MOTYPE,0,INFOS,NINF,
  515. & IVADM3)
  516. IF (IERR.NE.0) GOTO 220
  517. IF (ISUPD3.EQ.1) THEN
  518. CALL VALCHE(IVADM3,1,IPMINT,0,MODIM3,MELE)
  519. IF (IERR.NE.0) THEN
  520. ISUPD3 = 0
  521. GOTO 220
  522. ENDIF
  523. ENDIF
  524. MPTVAL = IVADM3
  525. MELVA3 = IVAL(1)
  526. * Determination du type de champ d'epaisseur 'DIM3' :
  527. * champ constant par element (B3EL) ou uniforme (B3UNI)
  528. IF (MELVA3.NE.0) THEN
  529. B3EL = .FALSE.
  530. B3UNI = .FALSE.
  531. N1PTEL = MELVA3.VELCHE(/1)
  532. N1EL = MELVA3.VELCHE(/2)
  533. IF (N1PTEL.NE.NBPGAU) THEN
  534. IF (N1PTEL.NE.1) THEN
  535. CALL ERREUR(21)
  536. GOTO 220
  537. ENDIF
  538. B3EL = .TRUE.
  539. ENDIF
  540. IF (N1EL.NE.NBELEM) THEN
  541. IF (N1EL.NE.1) THEN
  542. CALL ERREUR(21)
  543. GOTO 220
  544. ENDIF
  545. B3UNI = .TRUE.
  546. ENDIF
  547. ENDIF
  548. ENDIF
  549. *- 2.7.11 - Recuperation de la deformation perturbee (IVADEF)
  550. CALL KOMCHA(IPPERT,IPMAIL,CONM,MODEFU,MOTYPE,1,INFOS,NINF,
  551. & IVADEF)
  552. IF (IERR.NE.0) GOTO 220
  553. IF (ISUPDE.EQ.1) THEN
  554. CALL VALCHE(IVADEF,1,IPMINT,0,MODEFU,MELE)
  555. IF (IERR.NE.0) THEN
  556. ISUPDE = 0
  557. GOTO 220
  558. ENDIF
  559. ENDIF
  560. * Determination du type de la perturbation :
  561. * champ constant par element (BDEL) ou uniforme (BDUNI)
  562. MPTVAL = IVADEF
  563. MELVA2 = IVAL(1)
  564. N1PTEL = MELVA2.VELCHE(/1)
  565. N1EL = MELVA2.VELCHE(/2)
  566. BDEL = .FALSE.
  567. BDUNI = .FALSE.
  568. IF (N1PTEL.NE.NBPGAU) THEN
  569. BDEL = .TRUE.
  570. IF (N1PTEL.NE.1) THEN
  571. CALL ERREUR(21)
  572. GOTO 220
  573. ENDIF
  574. ENDIF
  575. IF (N1EL.NE.NBELEM) THEN
  576. BDUNI = .TRUE.
  577. IF (N1EL.NE.1) THEN
  578. CALL ERREUR(21)
  579. GOTO 220
  580. ENDIF
  581. ENDIF
  582. *- 2.7.12 - Recuperation de l'increment de contraintes (IVACON)
  583. CALL KOMCHA(IPCOPE,IPMAIL,CONM,MOCONT,MOTYPE,1,INFOS,NINF,
  584. & IVACON)
  585. IF (IERR.NE.0) GOTO 220
  586. IF (ISUPCO.EQ.1) THEN
  587. CALL VALCHE(IVACON,NBCONT,IPMINT,0,MOCONT,MELE)
  588. IF (IERR.NE.0) THEN
  589. ISUPCO = 0
  590. GOTO 220
  591. ENDIF
  592. ENDIF
  593. * Determination du type de chaque composante des contraintes :
  594. * champ constant par element (BCEL(i)) ou uniforme (BCUNI(i))
  595. MPTVAL = IVACON
  596. DO i = 1, NBCONT
  597. BCEL(i) = .FALSE.
  598. BCUNI(i) = .FALSE.
  599. MELVAL = IVAL(i)
  600. N1PTEL = VELCHE(/1)
  601. N1EL = VELCHE(/2)
  602. IF (N1PTEL.NE.NBPGAU) THEN
  603. BCEL(i) = .TRUE.
  604. IF (N1PTEL.NE.1) THEN
  605. CALL ERREUR(21)
  606. GOTO 220
  607. ENDIF
  608. ENDIF
  609. IF (N1EL.NE.NBELEM) THEN
  610. BCUNI(i) = .TRUE.
  611. IF (N1EL.NE.1) THEN
  612. CALL ERREUR(21)
  613. GOTO 220
  614. ENDIF
  615. ENDIF
  616. ENDDO
  617. *- 2.7.13 - Activation & initialisation de quelques segments
  618. NHRM = NIFOUR
  619. * SEGACT,MELEME
  620. * SEGACT,MINTE
  621. NBBB = NBNN
  622. SEGINI,MWRK1
  623. * CALL ZERO(DDHOOK,LHOOK,LHOOK)
  624. MPTVAL = IVACON
  625. *
  626. *- 2.7.14 - Boucle sur les ELEMENTs : mise a jour matrice REL(.,.,IEL)
  627. *-----------------------------------------------------------------------
  628. DO 300 IEL = 1, NBELEM
  629. * Remise a zero de REL
  630. CALL ZERO(REL,LRE,LRE)
  631. * Coordonnees des noeuds de l element
  632. CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
  633. * Calcul des coeff de modification de la matrice B-BARRE
  634. * (Uniquement en cas d'elements incompressibles)
  635. IF (MFR.EQ.31) THEN
  636. CALL BBCALC(XE,MELE,NBNN,IDIM,NBPGAU,
  637. & POIGAU,QSIGAU,ETAGAU,DZEGAU,NBCONT,LRE,
  638. & IFOUR,A,BB,NHRM,SHPTOT,SHPWRK,XDPGE,YDPGE)
  639. ENDIF
  640. * Champs uniformes ?
  641. IF (BDUNI) THEN
  642. IBD = 1
  643. ELSE
  644. IBD = IEL
  645. ENDIF
  646. IF (BDIM3) THEN
  647. IF (B3UNI) THEN
  648. IB3 = 1
  649. ELSE
  650. IB3 = IEL
  651. ENDIF
  652. ENDIF
  653. ISDJC=0
  654. * Boucle sur les POINTS d'INTEGRATION
  655. *-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -
  656. DO 400 IGAU = 1, NBPGAU
  657. * Calcul de B et du jacobien
  658. IF (MELVA3.NE.0) THEN
  659. IF (B3EL) THEN
  660. DIM3 = MELVA3.VELCHE(1,IB3)
  661. ELSE
  662. DIM3 = MELVA3.VELCHE(IGAU,IB3)
  663. ENDIF
  664. ENDIF
  665. IF (MELE.NE.28.AND.MELE.NE.45) THEN
  666. CALL BMATST(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  667. & MELE,MFR,NBNN,LRE,IFOUR,NBCONT,NHRM,DIM3,
  668. & XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  669. ELSE
  670. CALL BMAT28(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  671. & MELE,MFR,NBNN,LRE,IFOUR,NBCONT,NHRM,DIM3,
  672. & XE,SHPTOT,SHPWRK,BGENE,DJAC,XDPGE,YDPGE)
  673. ENDIF
  674. IF (DJAC.EQ.0.) THEN
  675. INTERR(1) = IEL
  676. CALL ERREUR(259)
  677. GOTO 220
  678. ENDIF
  679. IF (DJAC.LT.0.) ISDJC=ISDJC+1
  680. DJAC = ABS(DJAC)*POIGAU(IGAU)
  681. * En cas d'elements incompressibles : BGENE selon la methode B-BARRE
  682. IF (MFR.EQ.31) THEN
  683. CALL BBAR(IGAU,NBPGAU,POIGAU,QSIGAU,ETAGAU,DZEGAU,
  684. & MELE,NBNN,LRE,IFOUR,NSTRS,XE,DJAC,A,BB,BGENE)
  685. ENDIF
  686. * Perturbation constante par element ou uniforme
  687. IF (BDEL) THEN
  688. IGAUD = 1
  689. ELSE
  690. IGAUD = IGAU
  691. ENDIF
  692. * Pour chaque composante des contraintes :
  693. DO i = 1, NBCONT
  694. MELVAL = IVAL(i)
  695. * Contrainte constante par element ou uniforme
  696. IF (BCEL(i)) THEN
  697. IGAUC = 1
  698. ELSE
  699. IGAUC = IGAU
  700. ENDIF
  701. IF (BCUNI(i)) THEN
  702. IBC = 1
  703. ELSE
  704. IBC = IEL
  705. ENDIF
  706. * Calcul de DDHOOK(i) = (cont pert - fin) / defo pert
  707. DDHOOK(i,ICOMP) =
  708. & VELCHE(IGAUC,IBC) / MELVA2.VELCHE(IGAUD,IBD)
  709. ENDDO
  710. * Calcul de BDB par appel a DBDSTS : cas non symetrique
  711. *AV? appel a EFFI2 dans RIGI. EFFI2 MODIFIE REL
  712. CALL BDBSTS(BGENE,DJAC,DDHOOK,LRE,NBCONT,REL)
  713. *
  714. 400 CONTINUE
  715. * Fin de la Boucle sur les POINTS d'INTEGRATION (etiquette 400)
  716. *-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -
  717. * Changement de signe du jacobien dans l element ?
  718. IF ((ISDJC.NE.0).AND.(ISDJC.NE.NBPGAU)) THEN
  719. INTERR(1) = IEL
  720. CALL ERREUR(195)
  721. GOTO 220
  722. ENDIF
  723. * Mise a jour de la matrice de rigidite elementaire RE
  724. IF (IKTSYM.EQ.0) THEN
  725. DO i = 1, LRE
  726. DO j = 1, LRE
  727. RE(i,j,IEL) = RE(i,j,IEL) + REL(i,j)
  728. ENDDO
  729. ENDDO
  730. ELSE
  731. DO i = 1, LRE
  732. DO j = 1, i
  733. RE(i,j,IEL) = RE(i,j,IEL) + 0.5 * (REL(i,j)+REL(j,i))
  734. RE(j,i,IEL) = RE(i,j,IEL)
  735. ENDDO
  736. ENDDO
  737. ENDIF
  738. 300 CONTINUE
  739. *- Fin de la boucle sur les ELEMENTs (Etiquette 300)
  740. *-----------------------------------------------------------------------
  741. *- 2.7.15 - Menage : Desactivation-Destruction de segments
  742. 220 CONTINUE
  743. IF (ISUPCO.EQ.1) THEN
  744. CALL DTMVAL(IVACON,3)
  745. ELSE
  746. CALL DTMVAL(IVACON,1)
  747. ENDIF
  748. IF (ISUPDE.EQ.1) THEN
  749. CALL DTMVAL(IVADEF,3)
  750. ELSE
  751. CALL DTMVAL(IVADEF,1)
  752. ENDIF
  753. IF (BDIM3) THEN
  754. IF (ICOMP.EQ.NBDEFO .OR. IERR.NE.0) THEN
  755. IF (ISUPD3.EQ.1) THEN
  756. CALL DTMVAL(IVADM3,3)
  757. ELSE
  758. CALL DTMVAL(IVADM3,1)
  759. ENDIF
  760. ENDIF
  761. ENDIF
  762. IF (MWRK1.NE.0) SEGSUP,MWRK1
  763. MELEME = IPMAIL
  764. SEGDES,MELEME
  765. 210 CONTINUE
  766. IF (IPDEFI.NE.0) CALL DTCHAM(IPDEFI)
  767. IF (IPDEFF.NE.0) CALL DTCHAM(IPDEFF)
  768. IF (IPPERT.NE.0) CALL DTCHAM(IPPERT)
  769. IF (IPCONP.NE.0) CALL DTCHAM(IPCONP)
  770. IF (IPCOPE.NE.0) CALL DTCHAM(IPCOPE)
  771. IF (IERR.NE.0) GOTO 130
  772. *
  773. 200 CONTINUE
  774. *- Fin de la boucle de CALCUL DE LA PERTURBATION (Etiquette 200)
  775. *-----------------------------------------------------------------------
  776. *- 2.8 - Menage : Desactivation-Suppression de segments... -
  777. *-----------------------------------------------------------------------
  778. 130 CONTINUE
  779. SEGDES,DESCR
  780. SEGDES,XMATRI
  781. IF (IPCONF.NE.0) CALL DTCHAM(IPCONF)
  782. IF (IPDIM3.NE.0) CALL DTCHAM(IPDIM3)
  783. 120 CONTINUE
  784. NOMID = MODEPL
  785. IF (BSUPDP) THEN
  786. SEGSUP,NOMID
  787. ELSE
  788. SEGDES,NOMID
  789. ENDIF
  790. NOMID = MOFORC
  791. IF (BSUPFO) THEN
  792. SEGSUP,NOMID
  793. ELSE
  794. SEGDES,NOMID
  795. ENDIF
  796. NOMID = MOCONT
  797. IF (BSUPCO) THEN
  798. SEGSUP,NOMID
  799. ELSE
  800. SEGDES,NOMID
  801. ENDIF
  802. MLMOTS = LISCON
  803. SEGSUP,MLMOTS
  804. NOMID = MODEFO
  805. IF (BSUPDE) THEN
  806. SEGSUP,NOMID
  807. ELSE
  808. SEGDES,NOMID
  809. ENDIF
  810. MLMOTS = LISDEF
  811. SEGSUP,MLMOTS
  812. SEGDES,MINTE
  813. * Fin du traitement en cas d'erreur
  814. 110 CONTINUE
  815. IF (IERR.NE.0 .OR. KERRE.NE.0) THEN
  816. IF (IPDSCR.NE.0) SEGSUP,DESCR
  817. IF (IPMATR.NE.0) SEGSUP,XMATRI
  818. IF (KERRE.NE.0) CALL ERREUR(KERRE)
  819. GOTO 9000
  820. ENDIF
  821. *=======================================================================
  822. 100 CONTINUE
  823. *=======================================================================
  824.  
  825. *=======================================================================
  826. *= 3 = FIN DU TRAITEMENT (MENAGE...) =
  827. *=======================================================================
  828. 9000 CONTINUE
  829. * Suppression du modele "deroule"
  830. MMODEL = IPMODL
  831. DO i = 1, NSOUS
  832. IMODEL = KMODEL(i)
  833. SEGDES,IMODEL
  834. ENDDO
  835. SEGSUP,MMODEL
  836. * Suppresion du modele unitaire
  837. IF (IPMODU.NE.0) SEGSUP,MMODE1
  838. * Suppressions des "petits segments"
  839. IF (MODEFU.NE.0) THEN
  840. NOMID = MODEFU
  841. SEGSUP,NOMID
  842. ENDIF
  843. IF (MODIM3.NE.0) THEN
  844. NOMID = MODIM3
  845. SEGSUP,NOMID
  846. ENDIF
  847. IF (MOTYPE.NE.0) SEGSUP,NOTYPE
  848. * Envoi de la matrice de rigidite (sauf erreur)
  849. IF (IERR.NE.0) THEN
  850. IF (IPRIGI.NE.0) SEGSUP,MRIGID
  851. IPRIGI = 0
  852. ELSE
  853. ** IPRIGI = MRIGID
  854. ** SEGDES,MRIGID
  855. CALL REPART(IPRIGI)
  856. ENDIF
  857. *
  858. RETURN
  859. END
  860.  
  861.  
  862.  
  863.  
  864.  
  865.  
  866.  
  867.  
  868.  

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