Télécharger la plaquette Cast3M


fr en

Télécharger chaco2.eso

Retour à la liste

Numérotation des lignes : 

chaco2

  1. C CHACO2    SOURCE    PASCAL    19/11/19    21:15:01     10384          
  2.       SUBROUTINE CHACO2(IPSONO,IPSON1,IPSON2,IEP,IPGEOM,IPINTE,
  3.      .                  IPINT1,IPCHEQ,IPCHE1,IPCHE2)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8(A-H,O-Z)
  6. ************************************************************************
  7. *
  8. *                             C H A C O 2
  9. *                             -----------
  10. *
  11. * FONCTION:
  12. * ---------
  13. *     CAS DES SOURCES VOLUMIQUES
  14. *     COQ6 COQ8 ET COQ4
  15. *
  16. * MODULES UTILISES:
  17. * -----------------
  18. *
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC CCREEL
  23. -INC SMCHAML
  24. -INC SMELEME
  25. -INC SMINTE
  26. -INC SMCOORD
  27. *
  28. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  29. * -----------
  30. *
  31. *     IPSONO  (E)  POINTEURS SUR DES SEGMENTS MELVAL CONTENANT LES
  32. *     IPSON1     SOURCES
  33. *     IPSON2
  34. *     IEP     (E)  POINTEUR SUR UN SEGMENT MELVAL COTENANT LES EPAISSEUR
  35. *     IPGEOM  (E)  POINTEUR SUR UN OBJET MAILLAGE ELEMENTAIRE
  36. *     IPINTE  (E)  POINTEUR SUR UN SEGMENT MINTE CONTENANT LES
  37. *                  CARACTERISTIQUES D'INTEGRATION
  38. *     IPINT1  (E)  POINTEUR SUR UN SEGMENT MINTE CONTENANT LES
  39. *                  LES VALEURS DE FONCTION DE FORME AUX NOEUD
  40. *    +IDIM    (E)  VOIR CCOPTIO
  41. *    +XPI     (E)  VOIR CCREEL
  42. *     IPCHEQ  (S)  POINTEURS SUR DES SEGMENTS MELVAL CONTENANT LES
  43. *     IPCHE1      CHALEURS NODALES EQUIVALENTES
  44. *     IPCHE2
  45. *
  46. * VARIABLES:
  47. * ----------
  48. *
  49. *     XE(3,NBPTEL)  =  COORDONNEES DES ELEMENTS DANS LE REPERE GLOBAL
  50. *     DJAC          =  DETERMINANT DU JACOBIEN EN UN POINT DE GAUSS
  51. *     A ET A1       =  TABLEAUX DE TRAVAIL
  52. *
  53. *
  54.       REAL*8  XJ(3,3)
  55.       SEGMENT,MMAT1
  56.          REAL*8 XE(3,NBPTEL),A(NBE,NBE),FORME(NBNO),A1(NBNO,NBNO)
  57.          REAL*8 EXC(NBNO),EPAI(NBNO),TXR(3,3,NBNO)
  58.       ENDSEGMENT
  59. *
  60. * CONSTANTES:
  61. * -----------
  62. *
  63.       PARAMETER ( O1=1.D0,O2=2.D0)
  64.       DATA X577/.577350269189626D0/
  65. *
  66. * AUTEUR, DATE DE CREATION:
  67. * -------------------------
  68. *
  69. *     P. DOWLATYARI AOUT 90
  70. *
  71. * LANGAGE:
  72. * --------
  73. *
  74. *     ESOPE + FORTRAN77
  75. *
  76. ************************************************************************
  77. *
  78. *     ON RECUPERE LES VALEURS DES SOURCES
  79. *
  80.       MELVA1=IPSONO
  81.       SEGACT,MELVA1
  82.       NBPTE1=MELVA1.VELCHE(/1)
  83.       NEL1=MELVA1.VELCHE(/2)
  84.       MELVA2=IPSON1
  85.       SEGACT,MELVA2
  86.       MELVA3=IPSON2
  87.       SEGACT,MELVA3
  88. *
  89. *     ON RECUPERE LES CARACTERISTIQUES D'INTEGRATION
  90. *
  91.       MINTE=IPINTE
  92.       SEGACT,MINTE
  93.       NBPGAU=POIGAU(/1)
  94.       NBNO=SHPTOT(/2)
  95.       MINTE1 = IPINT1
  96.       SEGACT,MINTE1
  97. *
  98. *     ON RECUPERE UN DES MAILLAGES ELEMENTAIRES DE L'ENVELOPPE
  99. *
  100.       MELEME=IPGEOM
  101.       SEGACT,MELEME
  102.       NBPTEL=NUM(/1)
  103.       NEL=NUM(/2)
  104. *
  105. *     INITIALISATION DES MELVALS QUI CONTIENDRA LES CHALEURS EQUIVALENTE
  106. *
  107.       N1PTEL=NBPTEL
  108.       N1EL=NEL
  109.       N2PTEL=0
  110.       N2EL=0
  111.       NBE=3*NBPTEL
  112.       SEGINI,MELVAL
  113.       IPCHEQ=MELVAL
  114.       SEGINI,MELVA4
  115.       IPCHE1=MELVA4
  116.       SEGINI,MELVA5
  117.       IPCHE2=MELVA5
  118.       SEGINI,MMAT1
  119.       CALL ZERO(EXC,NBNO,1)
  120.       MELVA6=IEP
  121.       SEGACT,MELVA6
  122. *
  123. *     BOUCLE SUR LES ELEMENTS
  124. *
  125.       DO 10 IEL=1,NEL
  126. *
  127. *        ON CHERCHE LES COORDONNEES DES NOEUDS DANS LE REPERE GLOBAL
  128. *
  129.          CALL DOXE(XCOOR,IDIM,NBPTEL,NUM,IEL,XE)
  130. *
  131. *        CALCUL DES AXES LOCAUX AUX NOEUDS DE L'ELEMENT
  132. *
  133.          CALL CQ8LOC(XE,NBPTEL,MINTE1.SHPTOT,TXR,IRR)
  134. *
  135.          IF(IRR.EQ.0)THEN
  136. *
  137. *         EHEC DANS LE CALCUL DES AXES LOCAUX
  138. *
  139.            CALL ERREUR (515)
  140.            SEGSUP,MMAT1,MELVAL,MELVA4,MELVA5
  141.            RETURN
  142.           ENDIF
  143. *
  144. *
  145. *     ON CREE LE TABLEAU DES EPAISSEURS
  146. *
  147.         IBMN=MIN(IEL,MELVA6.VELCHE(/2))
  148.         DO  5  INO = 1,NBNO
  149.         INMN=MIN(INO,MELVA6.VELCHE(/1))
  150.         EPAI(INO) =MELVA6.VELCHE(INMN,IBMN)
  151.   5     CONTINUE
  152. *
  153.           CALL ZERO (A,NBE,NBE)
  154. *
  155. *         BOUCLE SUR LES POINTS DE GAUSS
  156. *
  157. *
  158.           DO 40 IGAU = 1, NBPGAU
  159. *
  160.           CALL ZERO (A1,NBNO,NBNO)
  161. *
  162.            E3=DZEGAU(IGAU)
  163. *
  164. *
  165. *         CALCUL DU JACABIEN
  166. *
  167.           CALL CQ8JCE (IGAU,NBPTEL,E3,XE,EPAI,EXC,TXR,SHPTOT,
  168.      .                  XJ,DJAC,IRR)
  169. *
  170.           IF(IRR.LT.0)THEN
  171. *
  172. *         JACOBIEN NUL DANS L'ELEMENT IEL
  173. *
  174.           INTERR(1)=IEL
  175.           CALL ERREUR (405)
  176.            SEGSUP,MMAT1,MELVAL,MELVA4,MELVA5
  177.            RETURN
  178.           ENDIF
  179. *
  180. *          CALCUL DE FORME (TRANSPOSEE)*FORME CONCERNANT LA SURFACE
  181. *          MOYENNE
  182.            DO 50  INO=1,NBNO
  183.            FORME(INO)=SHPTOT(1,INO,IGAU)
  184.   50       CONTINUE
  185. *
  186.            DJAC = DJAC*POIGAU(IGAU)
  187. *
  188.            CALL NTNST (FORME,DJAC,NBNO,1,A1)
  189. *
  190. *          ON AJOUTE L'EFFET DE L'EPAISSEUR
  191. *
  192.            C1=(E3/O2)*(E3-O1)
  193.            C2=O1-E3*E3
  194.            C3=(E3/O2)*(E3+O1)
  195. *
  196.            DO 60 I=1,NBE
  197.            DO 61 J=1,NBE
  198.            IF(I.LE.NBNO)THEN
  199.             II=I
  200.             IF(J.LE.NBNO)THEN
  201.              JJ=J
  202.              FACT=C1*C1
  203.             ELSEIF(J.GT.NBNO.AND.J.LE.(2*NBNO))THEN
  204.              JJ=J-NBNO
  205.              FACT=C1*C2
  206.             ELSE
  207.               JJ=J-2*NBNO
  208.               FACT=C1*C3
  209.             ENDIF
  210.           ELSEIF(I.GT.NBNO.AND.I.LE.(2*NBNO))THEN
  211.             II=I-NBNO
  212.             IF(J.LE.NBNO)THEN
  213.              JJ=J
  214.              FACT=C2*C1
  215.             ELSEIF(J.GT.NBNO.AND.J.LE.(2*NBNO))THEN
  216.              JJ=J-NBNO
  217.              FACT=C2*C2
  218.             ELSE
  219.              JJ=J-2*NBNO
  220.              FACT=C2*C3
  221.             ENDIF
  222.           ELSE
  223.             II=I-2*NBNO
  224.             IF(J.LE.NBNO)THEN
  225.              JJ=J
  226.              FACT=C3*C1
  227.             ELSEIF(J.GT.NBNO.AND.J.LE.(2*NBNO))THEN
  228.              JJ=J-NBNO
  229.              FACT=C3*C2
  230.             ELSE
  231.              JJ=J-2*NBNO
  232.              FACT=C3*C3
  233.             ENDIF
  234.           ENDIF
  235.           A(I,J)=A(I,J)+FACT*A1(II,JJ)
  236.   61     CONTINUE
  237.   60     CONTINUE
  238. *  FIN DE BOUCLE SUR LES POINTS D'INTEGRATION
  239.   40  CONTINUE
  240. *
  241. *           (INTEGRAL DE HTH)*VALEURS NODALES DES SOURCES
  242. *
  243.          IEMIN=MIN(NEL1,IEL)
  244.          DO 70 INO3=1,NBE
  245.          DO 71 INO4=1,NBE
  246.            IF(INO3.LE.NBPTEL)THEN
  247.               IF(INO4.LE.NBPTEL)THEN
  248.                INMIN=MIN(NBPTE1,INO4)
  249.          VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA1.VELCHE(INMIN,IEMIN)*
  250.      1                   A(INO4,INO3)
  251.               ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN
  252.                INO5=INO4-NBPTEL
  253.                INMIN=MIN(NBPTE1,INO5)
  254.          VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA2.VELCHE(INMIN,IEMIN)*
  255.      1                    A(INO4,INO3)
  256.              ELSE
  257.                INO5=INO4-2*NBPTEL
  258.                INMIN=MIN(NBPTE1,INO5)
  259.          VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA3.VELCHE(INMIN,IEMIN)*
  260.      1                    A(INO4,INO3)
  261.                ENDIF
  262.            ELSEIF(INO3.GT.NBPTEL.AND.INO3.LE.(2*NBPTEL))THEN
  263.            INO6=INO3 - NBPTEL
  264.               IF(INO4.LE.NBPTEL)THEN
  265.                INMIN=MIN(NBPTE1,INO4)
  266.                MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+
  267.      1                  MELVA1.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  268.                ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN
  269.                 INO5=INO4-NBPTEL
  270.                 INMIN=MIN(NBPTE1,INO5)
  271.                 MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+
  272.      1                  MELVA2.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  273.                ELSE
  274.                 INO5=INO4-2*NBPTEL
  275.                 INMIN=MIN(NBPTE1,INO5)
  276.                 MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+
  277.      1                  MELVA3.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  278.                 ENDIF
  279.            ELSE
  280.            INO6=INO3 -2*NBPTEL
  281.               IF(INO4.LE.NBPTEL)THEN
  282.                INMIN=MIN(NBPTE1,INO4)
  283.                MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+
  284.      1                  MELVA1.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  285.                ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN
  286.                 INO5=INO4-NBPTEL
  287.                 INMIN=MIN(NBPTE1,INO5)
  288.                 MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+
  289.      1                  MELVA2.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  290.                ELSE
  291.                 INO5=INO4-2*NBPTEL
  292.                 INMIN=MIN(NBPTE1,INO5)
  293.                 MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+
  294.      1                  MELVA3.VELCHE(INMIN,IEMIN)*A(INO4,INO3)
  295.                 ENDIF
  296.               ENDIF
  297.  71       CONTINUE
  298.  70       CONTINUE
  299. *           END DO
  300.  10      CONTINUE
  301. *     END DO
  302. *
  303.       SEGSUP,MMAT1
  304.       END
  305.  
  306.  
  307.  
  308.  

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