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

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