Télécharger la plaquette Cast3M


fr en

Télécharger ktaper.eso

Retour à la liste

Numérotation des lignes : 

ktaper

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

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