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

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