Télécharger la plaquette Cast3M


fr en

Télécharger fusrig.eso

Retour à la liste

Numérotation des lignes : 

fusrig

  1. C FUSRIG    SOURCE    FANDEUR   22/01/19    21:15:07     11256          
  2.  
  3. C=======================================================================
  4. C=                           F U S R I G                               =
  5. C=                           -----------                               =
  6. C=  Ce sousprogramme realise la fusion ('ET') de deux objets RIGIDITE. =
  7. C=======================================================================
  8.  
  9.       SUBROUTINE FUSRIG (IP1,IP2,IRETOU)
  10.  
  11.       IMPLICIT INTEGER(I-N)
  12.       IMPLICIT REAL*8 (A-H,O-Z)
  13.  
  14. -INC PPARAM
  15. -INC CCOPTIO
  16. -INC SMRIGID
  17. -INC SMELEME
  18.  
  19.       PARAMETER (IVA=2)
  20.       DIMENSION ITTG(IVA)
  21.  
  22.       IRETOU = 0
  23.       if (ierr.ne.0) return
  24.  
  25.       RI1 = IP1
  26.       RI2 = IP2
  27.       SEGACT,RI1,RI2
  28.       NRIG1 = RI1.IRIGEL(/2)
  29.       NRIG2 = RI2.IRIGEL(/2)
  30.  
  31.       ITTG(1)=IP1
  32.       ITTG(2)=IP2
  33.  
  34.       NRIGEL = NRIG1 + NRIG2
  35.  
  36.       SEGINI,MRIGID
  37.       ICHOLE = 0
  38.       IMGEO1 = 0
  39.  
  40.       IC=0
  41.       DO i=1,IVA
  42.         RI4=ITTG(i)
  43.         JA=RI4.IRIGEL(/2)
  44.         JB=RI4.IRIGEL(/1)
  45.         DO k=1,JA
  46.           MELEME=RI4.IRIGEL(1,k)
  47.           SEGACT,MELEME
  48.           IF (NUM(/2).NE.0) THEN
  49.             IC=IC+1
  50.             COERIG(IC)=RI4.COERIG(k)
  51.             DO l=1,JB
  52.               IRIGEL(l,IC)=RI4.IRIGEL(l,k)
  53.             ENDDO
  54.           ENDIF
  55.         ENDDO
  56.       ENDDO
  57.  
  58.       IF (NRIGEL.NE.IC) THEN
  59.         NRIGEL=IC
  60.         SEGADJ,MRIGID
  61.       ENDIF
  62.  
  63. c*c  Les 2 matrices ne sont pas vides :
  64. c*      IF (NRIG1.NE.0 .AND. NRIG2.NE.0) THEN
  65.         IF (RI2.MTYMAT.NE.RI1.MTYMAT) THEN
  66.           IF (RI1.MTYMAT.EQ.'RIGIDITE'.OR.RI2.MTYMAT.EQ.'RIGIDITE') THEN
  67.             MTYMAT='RIGIDITE'
  68.           ELSE
  69.             MTYMAT='INDETERM'
  70.           ENDIF
  71.         ELSE
  72.           MTYMAT=RI1.MTYMAT
  73.         ENDIF
  74.         IF (RI2.IFORIG.NE.RI1.IFORIG) THEN
  75.           interr(1)=RI1.IFORIG
  76.           interr(2)=RI2.IFORIG
  77.           interr(3)=IFOUR
  78. c-dbg      write(ioimp,*) '1132 FUSRIG',ri1,ri2
  79.           call erreur(1132)
  80.           IFORIG = IFOUR
  81.         ELSE
  82.           IFORIG=RI1.IFORIG
  83.         ENDIF
  84. c  Au moins une matrice est vide, voire les 2
  85. c*      ELSE
  86. c*        IF (NRIG1.NE.0) THEN
  87. c*          MTYMAT=RI1.MTYMAT
  88. c*          IFORIG=RI1.IFORIG
  89. c*        ELSE IF (NRIG2.NE.0) THEN
  90. c*          MTYMAT=RI2.MTYMAT
  91. c*          IFORIG=RI2.IFORIG
  92. c*        ELSE
  93. c*          MTYMAT='INDETERM'
  94. c*          IFORIG=IFOUR
  95. c*        ENDIF
  96. c*      ENDIF
  97.  
  98. *  pour le frottement, combinaison de deux raideurs portant sur le meme lx
  99.       call verlag(mrigid)
  100.  
  101.       SEGDES,RI1,RI2
  102.  
  103.       SEGDES,MRIGID
  104.       IRETOU=MRIGID
  105.  
  106.       RETURN
  107.       END
  108.  
  109.  
  110.  

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