Télécharger la plaquette Cast3M


fr en

Télécharger bloque.eso

Retour à la liste

Numérotation des lignes : 

bloque

  1. C BLOQUE    SOURCE    GOUNAND   24/09/09    21:15:01     12006          
  2.  
  3. C-----------------------------------------------------------------------
  4. C  Cet operateur impose les BLOCAGES
  5. C
  6. C  Syntaxe :
  7. C
  8. C        ENC1 = BLOQUER ( DEPL ) ( ROTA )  POI1
  9. C
  10. C    ou  ENC1 = BLOQUER  RADIAL  P1  (P2)  MELEME
  11. C                        ORTHOR  P1  (P2)  MELEME
  12. C
  13. C    ou  ENC1 = BLOQUER (DEPL) (ROTA) DIRECTION V1  MELEME
  14. C
  15. C        DIM = 1        ( UX UY UZ ) ou ( UR UZ )  |
  16. C        DIM = 2 OU 3   ( UX UY UZ RX RY RZ )      | MELEME
  17. C        AXISYM         ( RX RZ RT UT )            |
  18. Clist t
  19. C        POI1   = OBJET DE TYPE POINT    (entree)
  20. C        MELEME = OBJET DE TYPE MELEME   (entree)
  21. C        ENC1   = OBJET DE TYPE RIGIDITE (sortie)
  22. C
  23. C  1) On peut imposer des BLOQUAGES UNILATERAUX en specifiant les
  24. C     mots-cles MINIMUM ou MAXIMUM.
  25. C  2) On peut imposer des BLOQUAGES de type FROTTEMENT en specifiant
  26. C     le mot-cle FROTTEMENT.
  27. C-----------------------------------------------------------------------
  28. C  Juillet 2003 : passage a un seul multiplicateur
  29. C-----------------------------------------------------------------------
  30.  
  31.       SUBROUTINE BLOQUE
  32.  
  33.       IMPLICIT INTEGER(I-N)
  34.       IMPLICIT REAL*8 (A-H,O-Z)
  35.  
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC CCGEOME
  40. -INC CCREEL
  41. -INC CCHAMP
  42.  
  43. -INC SMCHPOI
  44. -INC TMTRAV
  45. -INC SMCOORD
  46. -INC SMELEME
  47. -INC SMLMOTS
  48.       POINTEUR MDIRCP.MLMOTS
  49.       POINTEUR MDIRCD.MLMOTS
  50. -INC SMMODEL
  51. -INC SMRIGID
  52. -INC SMTABLE
  53.  
  54.       SEGMENT MSWBLO
  55.       CHARACTER*(LOCHPO) MOTDDL(0)
  56.       ENDSEGMENT
  57.  
  58.       segment lispoi
  59.         INTEGER pilpoi(mpoin),pilmul(mpoin)
  60.       endsegment
  61.  
  62.       DIMENSION XNOR(3),U1(3),U2(3)
  63.  
  64.       CHARACTER*(LOCHPO) CHADDL,BLAN
  65.       CHARACTER*8 MOTRIG
  66.       CHARACTER*4 MOTPV(3), MOTBLO(5)
  67.       CHARACTER*4 MODEPL(6),MODEDU(6), MOROTA(5),MORODU(5)
  68.       CHARACTER*4 MODE1D(2),MOFO1D(2)
  69.  
  70.       DATA EPSI / 1.D-12 /
  71.       DATA MOTRIG / 'RIGIDITE' /
  72.       DATA BLAN   / '        ' /
  73.       DATA MOTPV / 'MINI','MAXI','FROT' /
  74.       DATA MOTBLO / 'DEPL','ROTA','RADI','ORTH','DIRE' /
  75.       DATA MODEPL / 'UX  ','UY  ','UZ  ','UR  ','UZ  ','UT  ' /
  76.       DATA MODEDU / 'FX  ','FY  ','FZ  ','FR  ','FZ  ','FT  ' /
  77.       DATA MOROTA / 'RX  ','RY  ','RZ  ','RT  ','RS  ' /
  78.       DATA MORODU / 'MX  ','MY  ','MZ  ','MT  ','MS  ' /
  79. C Tableaux MODE1D et MOFO1D sont utilises pour certains modes 1D
  80.       DATA MODE1D / 'UX  ','UZ  ' /
  81.       DATA MOFO1D / 'FX  ','FZ  ' /
  82.  
  83. C  Pour ne pas avoir de verrouillage sur MCOORD en //
  84.       SEGDES,MCOORD
  85.       SEGACT,MCOORD*MOD
  86.  
  87. c lecture table liaisons statiques
  88.       CALL LIRTAB('LIAISONS_STATIQUES',ipt,0,iretou)
  89. c traitement table liaisons statiques
  90.       IF (iretou.NE.0) THEN
  91.         CALL BLOQU2(ipt)
  92.         RETURN
  93.       ENDIF
  94.  
  95. C  Est-ce une condition unilaterale ?
  96.       NILATE=0
  97.       CALL LIRMOT(MOTPV,3,IPO,0)
  98.       IF (IPO.EQ.1) NILATE=-1
  99.       IF (IPO.EQ.2) NILATE=1
  100.       IF (IPO.EQ.3) NILATE=2
  101. C  Pas de frottement en 1D
  102.       IF (IPO.EQ.3.AND.IDIM.EQ.1) THEN
  103.          INTERR(1)=IDIM
  104.          MOTERR(1:4)=MOTPV(3)
  105.          CALL ERREUR(971)
  106.          RETURN
  107.       ENDIF
  108.  
  109.       idimp1=IDIM+1
  110. C  Quelques initialisations selon le type de probleme
  111. C  Cas IDIM = 1 :
  112. C  ISPE1D = 1 si IDIM=1 et IFOUR=9 ou 10, car les noms de DDL primaux et
  113. C  variables duales ne sont pas dans l'ordre "classique" (un traitement
  114. C  specifique est alors necessaire).
  115.       ISPE1D=0
  116. C  Deformations planes ou contraintes planes ou defo. plane gene :
  117.       IF (IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3) THEN
  118.          LDEPL=2
  119.          IADEPL=0
  120.          LROTA=1
  121.          IAROTA=2
  122. C  Axisymetrique :
  123.       ELSE IF (IFOUR.EQ.0) THEN
  124.          LDEPL=2
  125.          IADEPL=3
  126.          LROTA=1
  127.          IAROTA=3
  128. C  Fourier :
  129.       ELSE IF (IFOUR.EQ.1) THEN
  130.          LDEPL=3
  131.          IADEPL=3
  132.          LROTA=1
  133.          IAROTA=3
  134. C  Tridimensionnel :
  135.       ELSE IF (IFOUR.EQ.2) THEN
  136.          LDEPL=3
  137.          IADEPL=0
  138.          LROTA=3
  139.          IAROTA=0
  140. C  Massif 1D (IDIM=1) :
  141.       ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  142.          IF (IFOUR.LE.6) THEN
  143.             LDEPL=1
  144.             IADEPL=0
  145.          ELSE IF (IFOUR.GE.7.AND.IFOUR.LE.10) THEN
  146.             LDEPL=2
  147.             IADEPL=0
  148.             IF (IFOUR.EQ.9.OR.IFOUR.EQ.10) ISPE1D=1
  149.          ELSE IF (IFOUR.EQ.11) THEN
  150.             LDEPL=3
  151.             IADEPL=0
  152.          ELSE IF (IFOUR.EQ.15) THEN
  153.             LDEPL=2
  154.             IADEPL=3
  155.          ELSE
  156.             LDEPL=1
  157.             IADEPL=3
  158.          ENDIF
  159.          LROTA=0
  160.          IAROTA=0
  161. C  Autres cas :
  162.       ELSE
  163.          LDEPL=0
  164.          IADEPL=0
  165.          LROTA=0
  166.          IAROTA=0
  167.       ENDIF
  168.  
  169. C  Initialisation de la liste des ddls MOTDDL (segment MSWBLO)
  170.       SEGINI,MSWBLO
  171.  
  172. C-----------------------------------------------------------------------
  173. C  Lecture eventuelle des MOTS autres que des DDLS
  174. C-----------------------------------------------------------------------
  175. C     Lecture eventuelle de 'RADI','ORTH'
  176.       IRADIA=0
  177.       IDIREC=0
  178.       CALL LIRMOT(MOTBLO(3),2,IMOT,0)
  179.       IF (IMOT.NE.0) THEN
  180. C  En DIMENSION 1, les mots-cles 'RADI,'ORTH' sont interdits
  181.          IF (IDIM.EQ.1) THEN
  182.             INTERR(1)=IDIM
  183.             MOTERR(1:4)=MOTBLO(2+IMOT)
  184.             CALL ERREUR(971)
  185.             GOTO 1000
  186.          ENDIF
  187.          GOTO 44803
  188.       ENDIF
  189. C     Lecture eventuelle de 'DEPL' et/ou 'ROTA'
  190. C --------------------
  191.       IDEPL=0
  192.       IROTA=0
  193.  4480 CONTINUE
  194.       CALL LIRMOT(MOTBLO,2,IMOT,0)
  195.       IF (IMOT.EQ.1) THEN
  196.          IDEPL=1
  197. C  Cas particulier pour certains modes de IDIM=1
  198.          IF (ISPE1D.EQ.1) THEN
  199.             DO i=1,LDEPL
  200.                MOTDDL(**)=MODE1D(IADEPL+i)
  201.                MOTDDL(**)=MOFO1D(IADEPL+i)
  202.             ENDDO
  203. C  Cas general
  204.          ELSE
  205.             DO i=1,LDEPL
  206.                MOTDDL(**)=MODEPL(IADEPL+i)
  207.                MOTDDL(**)=MODEDU(IADEPL+i)
  208.             ENDDO
  209.          ENDIF
  210.          GOTO 4480
  211.       ELSEIF (IMOT.EQ.2) THEN
  212.          IROTA=1
  213.          DO i=1,LROTA
  214.             MOTDDL(**)=MOROTA(IAROTA+i)
  215.             MOTDDL(**)=MORODU(IAROTA+i)
  216.          ENDDO
  217.          GOTO 4480
  218.       ENDIF
  219. C  Lecture eventuelle de 'DIRE'
  220. C     --------------------
  221.       IDIREC=0
  222.       CALL LIRMOT(MOTBLO(5),1,IMOT,0)
  223.       IF (IMOT.NE.0) THEN
  224.          GOTO 44804
  225.       ENDIF
  226.       IBDDL=MOTDDL(/2)
  227.       IF (IBDDL.NE.0) GOTO 449
  228.       IF (IBDDL.EQ.0) GOTO 445
  229. C On a trouve le mot RADial ou le mot ORTHoradial
  230. 44803 CONTINUE
  231.       IRADIA=IMOT
  232.       CALL LIROBJ('POINT',KPOINT,1,IRETOU)
  233.       IF (IRETOU.EQ.0) GOTO 1000
  234.       j=(KPOINT-1)*idimp1
  235.       DO i=1,IDIM
  236.          U1(i)=XCOOR(j+i)
  237.       ENDDO
  238.       IF (IDIM.EQ.3) THEN
  239. C  Lecture du 2nd point de l'axe (en 3D)
  240.          CALL LIROBJ('POINT',KPOINT,1,IRETOU)
  241.          IF (IRETOU.EQ.0) GOTO 1000
  242.          j=(KPOINT-1)*idimp1
  243.          YL=0.D0
  244.          DO i=1,IDIM
  245.             U2(i)=XCOOR(j+i)-U1(i)
  246.             YL=YL+U2(i)*U2(i)
  247.          ENDDO
  248. C  Calcul du vecteur directeur unitaire de l'axe (U2)
  249.          IF (YL.LT.EPSI) THEN
  250.             CALL ERREUR(237)
  251.             GOTO 1000
  252.          ENDIF
  253.          YL=1.D0/SQRT(YL)
  254.          DO i=1,IDIM
  255.             U2(i)=U2(i)*YL
  256.          ENDDO
  257.       ENDIF
  258.       GOTO 449
  259. C     On a trouve le mot DIREction
  260. 44804 CONTINUE
  261.       IDIREC=1
  262.       IF (IDEPL.NE.0.AND.IROTA.NE.0) THEN
  263.          MOTERR(1:128)='DEPL ROTA'
  264.          CALL ERREUR(-385)
  265.          MOTERR(1:8)='DIRE'
  266.          CALL ERREUR(803)
  267.          RETURN
  268.       ENDIF
  269. *
  270.       CALL LIROBJ('POINT',KPOINT,0,IRETOU)
  271.       IF (IRETOU.EQ.0) THEN
  272. *     WRITE(IOIMP,*) 'Lecture dun chpoint'
  273.          CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU)
  274.          CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  275.          IF (IERR.NE.0) GOTO 1000
  276.          IF (IDEPL.EQ.0.AND.IROTA.EQ.0) THEN
  277. * Les composantes seront donnees par le champ
  278.             IDICHP=2
  279.             CALL EXTR11(MCHPOI,MDIRCD)
  280.             SEGACT MDIRCD
  281.             NC=MDIRCD.MOTS(/2)
  282.             IF (NC.LE.0) THEN
  283.                MOTERR(1:8)='CHPOINT'
  284. * Une donnee de type %M1:8 est vide
  285.                CALL ERREUR(1027)
  286.                RETURN
  287.             ENDIF
  288.             SEGINI,MDIRCP=MDIRCD
  289.             DO IC=1,NC
  290.                IPRI=0
  291.                IDUA=0
  292.                CALL PLACE(NOMDU,LNOMDU,IDUA,MDIRCP.MOTS(IC))
  293.                IF (IDUA.NE.0) THEN
  294.                   MDIRCP.MOTS(IC)=NOMDD(IC)
  295.                ELSE
  296.                   CALL PLACE(NOMDD,LNOMDD,IPRI,MDIRCP.MOTS(IC))
  297.                ENDIF
  298.                MOTDDL(**)=MDIRCP.MOTS(IC)
  299.                IF (IDUA.NE.0) THEN
  300.                   MOTDDL(**)=NOMDU(IDUA)
  301.                ELSE
  302.                   IF (IPRI.NE.0) THEN
  303.                      MOTDDL(**)=NOMDU(IPRI)
  304.                   ELSE
  305.                      MOTDDL(**)=BLAN
  306.                   ENDIF
  307.                ENDIF
  308.             ENDDO
  309.          ELSE
  310.             IDICHP=1
  311.             JGN=LOCHPO
  312.             IBDDL=MOTDDL(/2)
  313.             JGM=IBDDL/2
  314.             SEGINI,MDIRCP,MDIRCD
  315.             DO IGM=1,JGM
  316.                IDX=((IGM-1)*2)+1
  317.                MDIRCP.MOTS(IGM)=MOTDDL(IDX)
  318.                MDIRCD.MOTS(IGM)=MOTDDL(IDX+1)
  319.             ENDDO
  320.          ENDIF
  321.          CALL NOMC2(MCHPOI,MDIRCD,MDIRCP,MCHPO1)
  322.          IF (IERR.NE.0) RETURN
  323.       ELSE
  324.          j=(KPOINT-1)*idimp1
  325.          YL=0.D0
  326.          DO i=1,IDIM
  327.             XNOR(i)=XCOOR(j+i)
  328.             YL=YL+XNOR(i)*XNOR(i)
  329.          ENDDO
  330.          IF (YL.LT.EPSI) THEN
  331.             CALL ERREUR(239)
  332.             GOTO 1000
  333.          ENDIF
  334.          YL=1.D0/SQRT(YL)
  335.          DO i=1,IDIM
  336.             XNOR(i)=XNOR(i)*YL
  337.          ENDDO
  338.          IDICHP=0
  339.       ENDIF
  340.       GOTO 449
  341. C
  342. C  Lecture eventuelle de DDLs :
  343. C ------------------------------
  344. C
  345.  445  CONTINUE
  346. C  La liste des grandeurs PRIMALEs/DDLs est un LISTMOTS.
  347. cbp,2020-11-12 : possibilite non documentee => ajout a la notice
  348. c                + ajout de qq lignes pour rendre listmot dual facultatif
  349.       CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU)
  350.       IF (IERR.NE.0) GOTO 1000
  351.       IF (IRETOU.EQ.0) GOTO 446
  352.       CALL LIROBJ('LISTMOTS',MLMOT2,0,IRETO2)
  353.       IF (IERR.NE.0) GOTO 1000
  354. C    -cas ou la liste des grandeurs DUALEs n'est pas fournie.
  355.       IF(IRETO2.EQ.0) THEN
  356.         SEGACT,MLMOT1
  357.         IMOT1 = MLMOT1.MOTS(/2)
  358.         IF (IMOT1.LE.0) THEN
  359.           CALL ERREUR(643)
  360.           SEGDES,MLMOT1
  361.           GOTO 1000
  362.         ENDIF
  363.         DO IMOT = 1, IMOT1
  364.           MOTDDL(**)=MLMOT1.MOTS(IMOT)
  365.           CALL PLACE(NOMDD,LNOMDD,idd,MLMOT1.MOTS(IMOT))
  366.           IF (IERR.NE.0) GOTO 1000
  367.           IF (idd.LE.0) THEN
  368.              MOTDDL(**)=BLAN
  369.           ELSE
  370.              MOTDDL(**)=NOMDU(idd)
  371.           ENDIF
  372.         ENDDO
  373.         SEGDES,MLMOT1
  374. C    -cas ou la liste des grandeurs DUALEs est un LISTMOTS fourni.
  375. cbp,2020-11-12 : on ne documente pas cette possibilite car pas le temps
  376.       ELSE
  377.         SEGACT,MLMOT1,MLMOT2
  378.         IMOT1 = MLMOT1.MOTS(/2)
  379.         IF (IMOT1.LE.0) THEN
  380.           CALL ERREUR(643)
  381.           SEGDES,MLMOT1,MLMOT2
  382.           GOTO 1000
  383.         ELSE IF (IMOT1.NE.MLMOT2.MOTS(/2)) THEN
  384.           CALL ERREUR(854)
  385.           SEGDES,MLMOT1,MLMOT2
  386.           GOTO 1000
  387.         ENDIF
  388.         DO IMOT = 1, IMOT1
  389.           MOTDDL(**)=MLMOT1.MOTS(IMOT)
  390.           MOTDDL(**)=MLMOT2.MOTS(IMOT)
  391.         ENDDO
  392.         SEGDES,MLMOT1,MLMOT2
  393.       ENDIF
  394.       GOTO 449
  395.  
  396.  446  CONTINUE
  397. C  La liste des grandeurs PRIMALEs/DDLs sont des MOTs.
  398. C  La liste des ddls autorises = NOMDD defini dans BDATA.ESO
  399. C  On doit lire au moins 1 ddl (car sinon MOTDDL est vide !)
  400.       CALL LIRMOT(NOMDD,LNOMDD,IMOT,0)
  401.       IF (IERR.NE.0) GOTO 1000
  402.       IF (IMOT.NE.0) THEN
  403.          MOTDDL(**)=NOMDD(IMOT)
  404.          MOTDDL(**)=NOMDU(IMOT)
  405.       ELSE
  406.          CALL LIRCHA(CHADDL,0,IMOT)
  407.          IF (IERR.NE.0) GOTO 1000
  408.          IF (IMOT.EQ.0) GOTO 447
  409.          MOTDDL(**)=CHADDL
  410.          MOTDDL(**)=BLAN
  411.       ENDIF
  412.       GOTO 446
  413.  
  414. C  Conditions aux limites via un MODELE --> non documente, non plus !
  415.  447  CONTINUE
  416.       IBDDL=MOTDDL(/2)
  417.       IPMODL = 0
  418.       CALL LIROBJ('MMODEL  ',IPMODL,0,IRETOU)
  419.       IF (IRETOU.EQ.0) GOTO 449
  420.       CALL ACTOBJ('MMODEL  ',IPMODL,1)
  421.       CALL NOVARD(IPMODL,'DEPL')
  422.       CALL LIROBJ('LISTMOTS',MLMOT1,1,IRETOU)
  423.       IF (IERR.NE.0) GOTO 1000
  424.       CALL NOVARD(IPMODL,'FORC')
  425.       CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
  426.       IF (IERR.NE.0) GOTO 1000
  427.       SEGACT,MLMOT1,MLMOT2
  428.       IMOT1 = MLMOT1.MOTS(/2)
  429.       DO i = 2, IBDDL, 2
  430.          IF (MOTDDL(i).EQ.BLAN) THEN
  431.             CALL PLACE(MLMOT1.MOTS(1),IMOT1,iplac,MOTDDL(i-1))
  432.             IF (iplac.EQ.0) THEN
  433.                MOTERR(1:4)=MOTDDL(i-1)
  434.                CALL ERREUR(197)
  435.                IF (IERR.NE.0) GOTO 1000
  436.             ELSE
  437.                MOTDDL(i)=MLMOT2.MOTS(iplac)
  438.             ENDIF
  439.          ENDIF
  440.       ENDDO
  441.       SEGSUP,MLMOT1,MLMOT2
  442.  449  CONTINUE
  443.       IBDDL=MOTDDL(/2)
  444.       DO i = 2, IBDDL, 2
  445.          IF (MOTDDL(i).EQ.BLAN) THEN
  446.             MOTERR(1:4)=MOTDDL(i-1)
  447.             CALL ERREUR(108)
  448.             IF (IERR.NE.0) GOTO 1000
  449.          ENDIF
  450.       ENDDO
  451. C  Verification que le nombre de DDLs a bloquer n'est pas nul
  452. C     IF (IBDDL.EQ.0) GOTO 1000
  453. C-----------------------------------------------------------------------
  454. C  Fin de la lecture des mots (DEPL,ROTA...) ou des DDLs
  455. C-----------------------------------------------------------------------
  456.  
  457. C  Recherche du maillage MELEME de type POINT :
  458. C ----------------------------------------------
  459.       KOBJET=0
  460.       MELEME=0
  461. C  On cherche d'abord si on a un POINT que l'on transformera en POI1
  462. C  sinon on cherche un maillage que l'on transforme en POI1 si besoin
  463.       CALL LIROBJ('POINT',KPOINT,0,IRETOU)
  464.       IF (IERR.NE.0) GOTO 1000
  465.       IF (IRETOU.EQ.0) THEN
  466.          CALL LIROBJ('MAILLAGE',KOBJET,1,IRETOU)
  467.          IF (IERR.NE.0) GOTO 1000
  468.          MELEME=KOBJET
  469.          SEGACT,MELEME
  470.          IF (ITYPEL.NE.1) CALL CHANGE(MELEME,1)
  471.          NBPOIN=NUM(/2)
  472.       ELSE
  473.          MELEME=KPOINT
  474.          CALL CRELEM(MELEME)
  475.          NBPOIN=1
  476.       ENDIF
  477. *
  478.       IF (IDICHP.GE.1) THEN
  479. * Cas ou la direction est donnee par un chpoint
  480. * On construit un segment MTRAV contenant les directions normees
  481. * (DEPL ou ROTA) ou non
  482. *         WRITE(IOIMP,*) 'Transfo du chpoint en MTRA'
  483. * 1) Recopie des composantes et valeurs pertinentes du chpoint
  484. *     dans le TMTRAV
  485.          CALL CP2TR2(MDIRCP,MELEME,MCHPO1,MTRAV)
  486.          IF (IERR.NE.0) GOTO 1000
  487.          SEGACT MELEME
  488.          SEGACT MTRAV
  489. *         segprt,MTRAV
  490. * 2) On norme la direction dans le cas DEPL ou ROTA
  491. *         WRITE(IOIMP,*) 'Calcul des normes '
  492.          IF (IDICHP.EQ.1) THEN
  493.             SEGACT MTRAV*MOD
  494.             DO IBPOIN=1,NBPOIN
  495.                YL=0.D0
  496.                DO I=1,IDIM
  497.                   XNOR(I)=BB(I,IBPOIN)
  498.                   YL=YL+XNOR(I)*XNOR(I)
  499.                ENDDO
  500.                IF (YL.LT.XPETIT) THEN
  501.                   CALL ERREUR(239)
  502.                   GOTO 1000
  503.                ENDIF
  504.                YL=1.D0/SQRT(YL)
  505.                DO I=1,IDIM
  506.                   BB(I,IBPOIN)=XNOR(I)*YL
  507.                ENDDO
  508.             ENDDO
  509.          ENDIF
  510. *         WRITE(IOIMP,*) 'Fin du calcul des normes '
  511. *         SEGPRT,MTRAV
  512.       ENDIF
  513.  
  514. C  Determination du nombre de multiplicateurs NNMAT par noeud de MELEME
  515. C  NNMAT correspond au nombre de DDLs a bloquer par noeud = nombre de
  516. C  multiplicateurs a creer par noeud (1 multiplicateur) = NRIGEL
  517. C  Dans les cas RADIal et DIREction, on a une seule matrice par noeud.
  518. C  Dans les autres cas, autant de matrices que MOTDDL(/2)/2.
  519.       IF (IDIREC.NE.0.OR.IRADIA.NE.0) THEN
  520.          NNMAT=1
  521.       ELSE
  522.          NNMAT=IBDDL/2
  523.       ENDIF
  524. C  Initialisation de l'objet RIGIDITE associe aux BLOCAGES
  525.       NRIGEL=NNMAT
  526.       SEGINI,MRIGID
  527.       MTYMAT=MOTRIG
  528.       IFORIG=IFOUR
  529.       ICHOLE=0
  530.       IMGEO1=0
  531.       IMGEO2=0
  532. C  A chaque multplicateur est associe un nouveau noeud
  533. C  NBPOIN : nombre de points du maillage MELEME a bloquer
  534.       NBNO=nbpts
  535.       NBNOI=NBNO
  536.       NBPTS=NBNO+NNMAT*NBPOIN
  537.       SEGADJ,MCOORD
  538.  
  539. C Boucle sur le nombre de DDLs a bloquer
  540.       DO IAA=1,NNMAT
  541. C  Pour chaque noeud du maillage, creation d'un noeud associe (place
  542. C  initialement a l'origine) au IAA-eme DDL
  543.          DO i=1,NBPOIN
  544.             DO j=1,idimp1
  545.                XCOOR(NBNOI*idimp1+j)=0.D0
  546.             ENDDO
  547.             NBNOI=NBNOI+1
  548.          ENDDO
  549. C  Creation du maillage MELEME de MULTiplicateurs associe aux BLOCAGES
  550.          NBSOUS=0
  551.          NBREF=0
  552.          NBNN=2
  553.          NBELEM=NBPOIN
  554.          SEGINI,IPT1
  555.          KIPT1=IPT1
  556.          IPT1.ITYPEL=22
  557.          DO i=1,NBPOIN
  558.             j=(IAA-1)*NBPOIN+i
  559.             IPT1.NUM(1,i)=NBNO+j
  560.             IPT1.NUM(2,i)=NUM(1,i)
  561.             IPT1.ICOLOR(i)=IDCOUL
  562. C  Correction : Les pts mult sont a la meme position que les noeuds
  563.             IREF3=(NUM(1,i)-1)*idimp1
  564.             IREF1=(NBNO+j-1)*idimp1
  565.             DO j=1,IDIM
  566.                XCOOR(IREF1+j)=XCOOR(IREF3+j)
  567.             ENDDO
  568.          ENDDO
  569. C  Creation des RAIDEURS associees au IAA-eme multplicateur (DDL)
  570.          IRIGEL(1,IAA)=KIPT1
  571.          IRIGEL(2,IAA)=0
  572.          IRIGEL(5,IAA)=NIFOUR
  573.          IRIGEL(6,IAA)=NILATE
  574.          IF (IDIREC.NE.0.OR.IRADIA.NE.0) THEN
  575.             IF (IDICHP.EQ.2) THEN
  576.                NCBLO=MDIRCP.MOTS(/2)
  577.             ELSE
  578.                NCBLO=LDEPL
  579.             ENDIF
  580.          ELSE
  581.             NCBLO=1
  582.          ENDIF
  583.          NLIGRP=1+NCBLO
  584.          NLIGRD=NLIGRP
  585. C  Remplissage du tableau des DESCripteurs de RIG
  586.          SEGINI,DESCR
  587.          IRIGEL(3,IAA)=DESCR
  588.          NOELEP(1)=1
  589.          NOELEP(2)=2
  590.          NOELED(1)=1
  591.          NOELED(2)=2
  592.          IF (IDIREC.NE.0.OR.IRADIA.NE.0) THEN
  593.             IF (IDICHP.EQ.2) THEN
  594.                DO i=1,NCBLO
  595.                   NOELEP(1+i)=2
  596.                   NOELED(1+i)=2
  597.                   LISINC(1+i)=MOTDDL(2*i-1)
  598.                   LISDUA(1+i)=MOTDDL(2*i)
  599.                ENDDO
  600.             ELSE
  601.                DO i=1,NCBLO
  602.                   NOELEP(1+i)=2
  603.                   NOELED(1+i)=2
  604.                   IF (IROTA.NE.1) THEN
  605.                      LISINC(1+i)=MODEPL(IADEPL+i)
  606.                      LISDUA(1+i)=MODEDU(IADEPL+i)
  607.                   ELSE
  608.                      LISINC(1+i)=MOROTA(IADEPL+i)
  609.                      LISDUA(1+i)=MORODU(IADEPL+i)
  610.                   ENDIF
  611.                ENDDO
  612.             ENDIF
  613.          ELSE
  614.             j=2*(IAA-1)
  615.             LISINC(2)=MOTDDL(j+1)
  616.             LISDUA(2)=MOTDDL(j+2)
  617.          ENDIF
  618.          LISINC(1)='LX  '
  619.          LISDUA(1)='FLX '
  620. *         SEGDES DESCR
  621.          NELRIG=NBPOIN
  622.          SEGINI,XMATRI
  623.          IRIGEL(4,IAA)=XMATRI
  624.          COERIG(IAA)=1.D0
  625. C  Remplissage de  la matrice de rigidite RE :
  626. C  Il faut distinguer les cas IRADIA, IDIREC et les autres
  627. C  IRADIA : Il faut calculer la DIREction puis identique a IDIREC
  628. C  IDIREC : La DIRECTION est stockee dans le vecteur norme XNOR
  629. C  AUTRES : La matrice est predefinie dans RIG
  630. C  Option RADIAL : Calcul prealable de la direction pour chaque noeud
  631.          IF (IRADIA.NE.0) THEN
  632.             DO IB=1,NBPOIN
  633.                j=(NUM(1,IB)-1)*idimp1
  634.                DO i=1,IDIM
  635.                   XNOR(i)=XCOOR(j+i)-U1(i)
  636.                ENDDO
  637.                IF (IDIM.EQ.2) THEN
  638.                   YL=XNOR(1)*XNOR(1)+XNOR(2)*XNOR(2)
  639.                   IF (YL.LT.EPSI) THEN
  640.                      CALL ERREUR(238)
  641.                      RETURN
  642.                   ENDIF
  643.                   YL=1.D0/SQRT(YL)
  644.                   IF (IRADIA.EQ.1) THEN
  645.                      XNOR(1)=XNOR(1)*YL
  646.                      XNOR(2)=XNOR(2)*YL
  647.                   ELSE IF (IRADIA.EQ.2) THEN
  648.                      XX=XNOR(1)
  649.                      XNOR(1)=-XNOR(2)*YL
  650.                      XNOR(2)=XX*YL
  651.                   ENDIF
  652.                ELSE
  653.                   YL=XNOR(1)*U2(1)+XNOR(2)*U2(2)+XNOR(3)*U2(3)
  654.                   XL=0.D0
  655.                   DO i=1,3
  656.                      XNOR(i)=XNOR(i)-YL*U2(i)
  657.                      XL=XL+XNOR(i)*XNOR(i)
  658.                   ENDDO
  659.                   IF (XL.LT.EPSI) THEN
  660.                      CALL ERREUR(238)
  661.                      RETURN
  662.                   ENDIF
  663.                   IF (IRADIA.EQ.1) THEN
  664.                      XL=1.D0/SQRT(XL)
  665.                      XNOR(1)=XNOR(1)*XL
  666.                      XNOR(2)=XNOR(2)*XL
  667.                      XNOR(3)=XNOR(3)*XL
  668.                   ELSE IF (IRADIA.EQ.2) THEN
  669.                      XX=XNOR(1)
  670.                      YY=XNOR(2)
  671.                      ZZ=XNOR(3)
  672.                      XNOR(1)=YY*U2(3)-ZZ*U2(2)
  673.                      XNOR(2)=ZZ*U2(1)-XX*U2(3)
  674.                      XNOR(3)=XX*U2(2)-YY*U2(1)
  675.                   ENDIF
  676.                ENDIF
  677. C  XNOR contient la direction normee
  678.                RE(1,1,IB)=0.D0
  679.                DO IC=1,IDIM
  680.                   RE(IC+1,1,IB)=XNOR(IC)
  681.                   RE(1,IC+1,IB)=XNOR(IC)
  682.                ENDDO
  683.             ENDDO
  684. C  Option DIRECTION
  685.          ELSE IF (IDIREC.EQ.1) THEN
  686.             IF (IDICHP.GE.1) THEN
  687.                DO I=1,NBPOIN
  688.                   RE(1,1,i)=0.D0
  689.                   DO IC=1,NCBLO
  690.                      RE(IC+1,1,i)=BB(IC,I)
  691.                      RE(1,IC+1,i)=BB(IC,I)
  692.                   ENDDO
  693.                ENDDO
  694.             ELSE
  695.                DO I=1,NBPOIN
  696.                   RE(1,1,i)=0.D0
  697.                   DO IC=1,IDIM
  698.                      RE(IC+1,1,i)=XNOR(IC)
  699.                      RE(1,IC+1,i)=XNOR(IC)
  700.                   ENDDO
  701.                ENDDO
  702.             ENDIF
  703. C  Autres options :
  704.          ELSE
  705.             DO i=1,NBPOIN
  706.                RE(1,1,i)=0.D0
  707.                RE(2,1,i)=1.D0
  708.                RE(2,2,i)=0.D0
  709.                RE(1,2,i)=RE(2,1,i)
  710.             ENDDO
  711.          ENDIF
  712.       ENDDO
  713. C  Fin de la boucle sur les IAA DDLs a bloquer
  714.       IF (IDICHP.GE.1) THEN
  715. *     WRITE(IOIMP,*) 'Destruction du segment de travail'
  716.          SEGSUP,MTRAV
  717.          SEGSUP MCHPO1
  718.          SEGSUP MDIRCP
  719.          SEGSUP MDIRCD
  720.       ENDIF
  721. C  Fin normale du traitement
  722.       call relasi(mrigid)
  723.       CALL ACTOBJ('RIGIDITE',MRIGID,1)
  724.       CALL ECROBJ('RIGIDITE',MRIGID)
  725.       IF (MELEME.GT.0) THEN
  726.          IF (KOBJET.EQ.0) THEN
  727.             SEGSUP,MELEME
  728.          ELSE
  729. *            SEGDES,MELEME
  730.          ENDIF
  731.       ENDIF
  732. C  Sortie du sousprogramme (normale ou en cas d'erreur)
  733.  1000 CONTINUE
  734.       SEGSUP,MSWBLO
  735. *      SEGDES,MCOORD
  736.       END
  737.  
  738.  

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