Télécharger ktaper.eso

Retour à la liste

Numérotation des lignes :

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

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