Télécharger la plaquette Cast3M


fr en

Télécharger fscoq4.eso

Retour à la liste

Numérotation des lignes : 

fscoq4

  1. C FSCOQ4    SOURCE    FANDEUR   12/07/18    21:15:38     7434
  2.  
  3.       SUBROUTINE FSCOQ4(IPT,IPMAIL,IPTINT,IPVECT,V,IVAFOR)
  4. *____________________________________________________________________
  5. *
  6. *   CALCULE LES FORCES SURFACIQUES SUR LES COQUES COQ4 3D
  7. *
  8. *   ENTREES :
  9. *   ---------
  10. *
  11. *    IPT      TABLEAU DE POINTEURS SUR MPTVAL CONTENANT LES FORCES
  12. *             APPLIQUEES
  13. *    IPMAIL   OBJET GEOMETRIQUE
  14. *    IPTINT   POINTEUR SUR UN MINTE CONTENANT LES POINTS D INTEGRATION
  15. *    IPVECT   POINTEUR SUR LE VECTEUR REPRESENTANT LA FORCE
  16. *    V        VECTEUR REPRESENTANT LA FORCE
  17. *    IVAFOR   POINTEUR SUR UN MPTVAL ET DES MELVALS DEVANT CONTENIR
  18. *             LES FORCES NODALES RESULTANTES
  19. *
  20. *      G. M. GIANNUZZI   SETT  86
  21. *      PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12 09 90
  22. *
  23. *____________________________________________________________________
  24. *
  25.       IMPLICIT INTEGER(I-N)
  26.       IMPLICIT REAL*8(A-H,O-Z)
  27. *
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. *
  32. -INC SMCHAML
  33. -INC SMELEME
  34. -INC SMINTE
  35. -INC SMCOORD
  36. *
  37.       SEGMENT MPTVAL
  38.         INTEGER IPOS(NS)    ,NSOF(NS)
  39.         INTEGER      IVAL(NCOSOU)
  40.         CHARACTER*16 TYVAL(NCOSOU)
  41.       ENDSEGMENT
  42. *
  43.       DIMENSION IPT(*), V(*)
  44.  
  45.       DIMENSION XE(3,4),XEL(3,4),BPSS(3,3),SHP(6,4),FTLOC(24),FTGLO(24)
  46.  
  47.       MELVA1 = IPT(1)
  48.       MELVA2 = IPT(2)
  49.       MELVA3 = IPT(3)
  50.       IF (IPVECT.EQ.0) THEN
  51.         IF (MELVA1.NE.0) THEN
  52.           SEGACT,MELVA1
  53.           IGM1 = MELVA1.VELCHE(/1)
  54.           IBM1 = MELVA1.VELCHE(/2)
  55.         ENDIF
  56.         IF (MELVA2.NE.0) THEN
  57.           SEGACT,MELVA2
  58.           IGM2 = MELVA2.VELCHE(/1)
  59.           IBM2 = MELVA2.VELCHE(/2)
  60.         ENDIF
  61.         IF (MELVA3.NE.0) THEN
  62.           SEGACT,MELVA3
  63.           IGM3 = MELVA3.VELCHE(/1)
  64.           IBM3 = MELVA3.VELCHE(/2)
  65.         ENDIF
  66.         F1 = 0.D0
  67.         F2 = 0.D0
  68.         F3 = 0.D0
  69.       ELSE
  70.         F1 = V(1)
  71.         F2 = V(2)
  72.         F3 = V(3)
  73.       ENDIF
  74. *
  75.       MINTE=IPTINT
  76. C*      SEGACT,MINTE           <- ACTIF EN E/S (NON MODIFIE)
  77.       NBPGAU=POIGAU(/1)
  78.       NBGM1 =NBPGAU-1
  79. *
  80.       MELEME=IPMAIL
  81. C*      SEGACT,MELEME           <- ACTIF EN E/S (NON MODIFIE)
  82.       NBPTEL = NUM(/1)
  83.       NBELEM = NUM(/2)
  84. *
  85. *     BOUCLE SUR LES ELEMENTS
  86. *
  87.       DO 1000 IB=1,NBELEM
  88. *
  89.         CALL DOXE(XCOOR,IDIM,NBPTEL,NUM,IB,XE)
  90. *
  91. *       MATRICE DE PASSAGE  ET COORDONNEES LOCALES
  92. *
  93.         CALL CQ4LOC(XE,XEL,BPSS,IERR,0)
  94. *
  95. *       MISE A 0 DU VECTEUR FORCE
  96. *
  97.         DO I = 1, 24
  98.           FTLOC(I)=0.D0
  99.         ENDDO
  100. *
  101. *        INTEGRATION NUMERIQUE : IGAU NUMERO DU POINT DE GAUSS
  102. *                                IA NUMERO D UN NOEUD
  103. *
  104.         IF (IPVECT.EQ.0) THEN
  105.           IF (MELVA1.NE.0) IBMN1 = MIN(IB,IBM1)
  106.           IF (MELVA2.NE.0) IBMN2 = MIN(IB,IBM2)
  107.           IF (MELVA3.NE.0) IBMN3 = MIN(IB,IBM3)
  108.         ENDIF
  109.  
  110.         DO 200 IGAU=1,NBGM1
  111. *
  112.           IF (IPVECT.EQ.0) THEN
  113.             IF (MELVA1.NE.0) THEN
  114.               IGMN = MIN(IGAU,IGM1)
  115.               F1 = MELVA1.VELCHE(IGMN,IBMN1)
  116.             ENDIF
  117.             IF (MELVA2.NE.0) THEN
  118.               IGMN = MIN(IGAU,IGM2)
  119.               F2 = MELVA2.VELCHE(IGMN,IBMN2)
  120.             ENDIF
  121.             IF (MELVA3.NE.0) THEN
  122.               IGMN = MIN(IGAU,IGM3)
  123.               F3 = MELVA3.VELCHE(IGMN,IBMN3)
  124.             ENDIF
  125.           ENDIF
  126. *
  127. *   chgt de repere des forces appliquees
  128. *
  129.           F1L = BPSS(1,1)*F1 + BPSS(1,2)*F2 + BPSS(1,3)*F3
  130.           F2L = BPSS(2,1)*F1 + BPSS(2,2)*F2 + BPSS(2,3)*F3
  131.           F3L = BPSS(3,1)*F1 + BPSS(3,2)*F2 + BPSS(3,3)*F3
  132. *
  133.           DO 210 NP = 1, NBPTEL
  134.             SHP(1,NP) = SHPTOT(1,NP,IGAU)
  135.             SHP(2,NP) = SHPTOT(2,NP,IGAU)
  136.             SHP(3,NP) = SHPTOT(3,NP,IGAU)
  137.  210      CONTINUE
  138.           CALL JACOBI(XEL,SHP,2,NBPTEL,DJAC)
  139.           DJAC = DJAC*POIGAU(IGAU)
  140. *
  141.           DJAC1 = DJAC*F1L
  142.           DJAC2 = DJAC*F2L
  143.           DJAC3 = DJAC*F3L
  144. *
  145.           DO 250 NP = 1, NBPTEL
  146.             IC1=(NP-1)*6+1
  147.             IC2=IC1 + 1
  148.             IC3=IC2 + 1
  149.             FTLOC(IC1)=FTLOC(IC1)+SHP(1,NP)*DJAC1
  150.             FTLOC(IC2)=FTLOC(IC2)+SHP(1,NP)*DJAC2
  151.             FTLOC(IC3)=FTLOC(IC3)+SHP(1,NP)*DJAC3
  152.  250      CONTINUE
  153.  200    CONTINUE
  154. *
  155. *     CHANGEMENT DE REPERE
  156. *
  157.         CALL TRPOSE(BPSS)
  158.         CALL MATVEC(FTLOC,FTGLO,BPSS,8)
  159. *
  160.         MPTVAL=IVAFOR
  161.         IE=0
  162.         DO 560 IC=1,4
  163.           DO 560 ID=1,6
  164.             IE=IE+1
  165.             MELVAL=IVAL(ID)
  166.             VELCHE(IC,IB)=FTGLO(IE)
  167.  560    CONTINUE
  168.  
  169.  1000 CONTINUE
  170.  
  171.       IF (IPVECT.EQ.0) THEN
  172.         IF (MELVA1.NE.0) SEGDES,MELVA1
  173.         IF (MELVA2.NE.0) SEGDES,MELVA2
  174.         IF (MELVA3.NE.0) SEGDES,MELVA3
  175.       ENDIF
  176. C*      SEGDES,MINTE
  177. C*      SEGDES,MELEME
  178.  
  179.       RETURN
  180.       END
  181.  
  182.  
  183.  

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