Télécharger la plaquette Cast3M


fr en

Télécharger ingate.eso

Retour à la liste

Numérotation des lignes : 

ingate

  1. C INGATE    SOURCE    GOUNAND   21/06/02    21:16:43     11022          
  2.       SUBROUTINE INGATE(MYPGS,IMPR,IRET)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : INGATE
  7. C PROJET      : Noyau linéaire NLIN
  8. C DESCRIPTION : Remplit le segment des méthodes d'intégration
  9. C               avec des méthodes d'intégration numérique de cubature
  10. C               type Gauss pour le tétraèdre (ordre 1 à 7).
  11. C
  12. C REFERENCES  : Le site de Cools (avec 32 chiffres sign.)
  13. C               (essentiellement Stroud et al.) dont on reprend la
  14. C               nomenclature...
  15. C LANGAGE     : ESOPE
  16. C AUTEUR      : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  17. C               mél : gounand@semt2.smts.cea.fr
  18. C***********************************************************************
  19. C APPELES          : INIPG, GTSINO, GTRO3I, GT3FS9, GT3F10,
  20. C                    FIPG, CPROPG
  21. C APPELE PAR       : INPGS
  22. C***********************************************************************
  23. C ENTREES            : -
  24. C ENTREES/SORTIES    : MYPGS (actif en *MOD)
  25. C SORTIES            : -
  26. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  27. C***********************************************************************
  28. C VERSION    : v1, 22/10/99, version initiale
  29. C HISTORIQUE : v1, 22/10/99, création
  30. C HISTORIQUE : 29/5/00 rajout ordre 6
  31. C HISTORIQUE :
  32. C***********************************************************************
  33. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  34. C en cas de modification de ce sous-programme afin de faciliter
  35. C la maintenance !
  36. C***********************************************************************
  37.  
  38. -INC PPARAM
  39. -INC CCOPTIO
  40. -INC TNLIN      
  41. *-INC SPOGAU
  42.       POINTEUR MYPGS.POGAUS
  43.       POINTEUR PGCOUR.POGAU
  44.       POINTEUR PGPRO1.POGAU
  45.       POINTEUR PGPRO2.POGAU
  46. *
  47.       INTEGER IMPR,IRET
  48. *   On travaille en coordonnées barycentriques.
  49. *   D'après le Dhatt et Touzot
  50. *   L1 = 1 - \ksi - \eta -\zeta
  51. *   L2 = \ksi
  52. *   L3 = \eta
  53. *   L4 = \zeta
  54.       INTEGER DIMSRF
  55.       PARAMETER(DIMSRF=3)
  56.       REAL*8 XCOR(DIMSRF+1)
  57. *
  58. *  Générateurs pour la cubature de degré 1 à 1 point  : GAT3-1-1 :
  59. *   - [ Fully symmetric ]
  60.       REAL*8 X1D1,Y1D1,Z1D1,P1D1
  61.       PARAMETER (X1D1=1.D0/4.D0)
  62.       PARAMETER (Y1D1=1.D0/4.D0)
  63.       PARAMETER (Z1D1=1.D0/4.D0)
  64.       PARAMETER (P1D1=1.D0/6.D0)
  65. *
  66. *  Générateurs pour la cubature de degré 2 à 4 points : GAT3-2-4B :
  67. *   - [ Fully symmetric ]
  68.       REAL*8 X1D2,Y1D2,Z1D2,P1D2
  69.       PARAMETER (X1D2=0.138196601125010515179541316563436D0)
  70.       PARAMETER (Y1D2=0.138196601125010515179541316563436D0)
  71.       PARAMETER (Z1D2=0.138196601125010515179541316563436D0)
  72.       PARAMETER (P1D2=1.D0/24.D0)
  73. *
  74. *  Générateurs pour la cubature de degré 3 à 8 points : GAT3-3-8B :
  75. *   - [ Fully symmetric ]
  76.       REAL*8 X1D3,Y1D3,Z1D3,P1D3
  77.       PARAMETER (X1D3=1.D0)
  78.       PARAMETER (Y1D3=0.D0)
  79.       PARAMETER (Z1D3=0.D0)
  80.       PARAMETER (P1D3=4.16666666666666666666666666666666D-3)
  81. *   - [ Fully symmetric ]
  82.       REAL*8 X2D3,Y2D3,Z2D3,P2D3
  83.       PARAMETER (X2D3=1.D0/3.D0)
  84.       PARAMETER (Y2D3=1.D0/3.D0)
  85.       PARAMETER (Z2D3=1.D0/3.D0)
  86.       PARAMETER (P2D3=0.0375D0)
  87. *
  88. *  Générateurs pour la cubature de degré 5 à 14 points : GAT3-5-14A :
  89. *   - [ Fully symmetric ]
  90.       REAL*8 X1D5,Y1D5,Z1D5,P1D5
  91.       PARAMETER (X1D5=0.0927352503108912264023239137370306D0)
  92.       PARAMETER (Y1D5=0.0927352503108912264023239137370306D0)
  93.       PARAMETER (Z1D5=0.0927352503108912264023239137370306D0)
  94.       PARAMETER (P1D5=0.0122488405193936582572850342477212D0)
  95. *   - [ Fully symmetric ]
  96.       REAL*8 X2D5,Y2D5,Z2D5,P2D5
  97.       PARAMETER (X2D5=0.310885919263300609797345733763457D0)
  98.       PARAMETER (Y2D5=0.310885919263300609797345733763457D0)
  99.       PARAMETER (Z2D5=0.310885919263300609797345733763457D0)
  100.       PARAMETER (P2D5=0.0187813209530026417998642753888810D0)
  101. *   - [ Fully symmetric ]
  102.       REAL*8 X3D5,Y3D5,Z3D5,P3D5
  103.       PARAMETER (X3D5=0.454496295874350350508119473720660D0)
  104.       PARAMETER (Y3D5=0.454496295874350350508119473720660D0)
  105.       PARAMETER (Z3D5=0.0455037041256496494918805262793394D0)
  106.       PARAMETER (P3D5=7.09100346284691107301157135337624D-3)
  107. *
  108. *  Générateurs pour la cubature de degré 6 à 24 points : GAT3-6-24 :
  109. *   - [ Fully symmetric ]
  110.       REAL*8 X1D6,Y1D6,Z1D6,P1D6
  111.       PARAMETER (X1D6=0.214602871259152029288839219386284D0)
  112.       PARAMETER (Y1D6=0.214602871259152029288839219386284D0)
  113.       PARAMETER (Z1D6=0.214602871259152029288839219386284D0)
  114.       PARAMETER (P1D6=6.65379170969458201661510459291332D-3)
  115. *   - [ Fully symmetric ]
  116.       REAL*8 X2D6,Y2D6,Z2D6,P2D6
  117.       PARAMETER (X2D6=0.0406739585346113531155794489564100D0)
  118.       PARAMETER (Y2D6=0.0406739585346113531155794489564100D0)
  119.       PARAMETER (Z2D6=0.0406739585346113531155794489564100D0)
  120.       PARAMETER (P2D6=1.67953517588677382466887290765614D-3)
  121. *   - [ Fully symmetric ]
  122.       REAL*8 X3D6,Y3D6,Z3D6,P3D6
  123.       PARAMETER (X3D6=0.322337890142275510343994470762492D0)
  124.       PARAMETER (Y3D6=0.322337890142275510343994470762492D0)
  125.       PARAMETER (Z3D6=0.322337890142275510343994470762492D0)
  126.       PARAMETER (P3D6=9.22619692394245368252554630895433D-3)
  127. *   - [ Fully symmetric ]
  128.       REAL*8 X4D6,Y4D6,Z4D6,P4D6
  129.       PARAMETER (X4D6=0.0636610018750175252992355276057269D0)
  130.       PARAMETER (Y4D6=0.0636610018750175252992355276057269D0)
  131.       PARAMETER (Z4D6=0.269672331458315808034097805727606D0)
  132.       PARAMETER (P4D6=8.03571428571428571428571428571428D-3)
  133. *
  134.       INTEGER NOPG
  135. *
  136. * Executable statements
  137. *
  138.       IF (IMPR.GT.6) WRITE(IOIMP,*) 'Entrée dans ingate'
  139. *
  140. * Méthode de nom : NCT3-1-4
  141. * Sur un tétraèdre : cubature d'ordre 1 à 4 points
  142. *                    espace de référence de dimension 3
  143. *
  144. * In INIPG : SEGINI PGCOUR
  145.       CALL INIPG('NCT3-1-4','NEWTON-COTES','TETRAEDRE',
  146.      $     1,4,3,
  147.      $     PGCOUR,
  148.      $     IMPR,IRET)
  149.       IF (IRET.NE.0) GOTO 9999
  150.       NOPG=0
  151.       XCOR(1)=1.D0
  152.       XCOR(2)=0.D0
  153.       XCOR(3)=0.D0
  154.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  155.       CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D2,IMPR,IRET)
  156.       IF (IRET.NE.0) GOTO 9999
  157.       SEGDES PGCOUR
  158.       MYPGS.LISPG(**)=PGCOUR
  159. *
  160. * Méthode de nom : GAT3-1-1
  161. * Sur un tétraèdre : cubature d'ordre 1 à 1 point
  162. *                    espace de référence de dimension 3
  163. *
  164. * In INIPG : SEGINI PGCOUR
  165.       CALL INIPG('GAT3-1-1','GAUSS','TETRAEDRE',
  166.      $     1,1,3,
  167.      $     PGCOUR,
  168.      $     IMPR,IRET)
  169.       IF (IRET.NE.0) GOTO 9999
  170.       NOPG=0
  171.       XCOR(1)=X1D1
  172.       XCOR(2)=Y1D1
  173.       XCOR(3)=Z1D1
  174.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  175.       CALL GTSINO(PGCOUR,NOPG,DIMSRF,XCOR,P1D1,IMPR,IRET)
  176.       IF (IRET.NE.0) GOTO 9999
  177.       SEGDES PGCOUR
  178.       MYPGS.LISPG(**)=PGCOUR
  179. *
  180. * Méthode de nom : GAT3-2-4B
  181. * Sur un tétraèdre : cubature d'ordre 2 à 4 points
  182. *                    espace de référence de dimension 3
  183. *
  184. * In INIPG : SEGINI PGCOUR
  185.       CALL INIPG('GAT3-2-4B','GAUSS','TETRAEDRE',
  186.      $     2,4,3,
  187.      $     PGCOUR,
  188.      $     IMPR,IRET)
  189.       IF (IRET.NE.0) GOTO 9999
  190.       NOPG=0
  191.       XCOR(1)=X1D2
  192.       XCOR(2)=Y1D2
  193.       XCOR(3)=Z1D2
  194.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  195.       CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D2,IMPR,IRET)
  196.       IF (IRET.NE.0) GOTO 9999
  197.       SEGDES PGCOUR
  198.       MYPGS.LISPG(**)=PGCOUR
  199. *
  200. * Méthode de nom : GAT3-3-8B
  201. * Sur un tétraèdre : cubature d'ordre 3 à 8 points
  202. *                    espace de référence de dimension 3
  203. *
  204. * In INIPG : SEGINI PGCOUR
  205.       CALL INIPG('GAT3-3-8B','GAUSS','TETRAEDRE',
  206.      $     3,8,3,
  207.      $     PGCOUR,
  208.      $     IMPR,IRET)
  209.       IF (IRET.NE.0) GOTO 9999
  210.       NOPG=0
  211.       XCOR(1)=X1D3
  212.       XCOR(2)=Y1D3
  213.       XCOR(3)=Z1D3
  214.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  215.       CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D3,IMPR,IRET)
  216.       IF (IRET.NE.0) GOTO 9999
  217.       XCOR(1)=X2D3
  218.       XCOR(2)=Y2D3
  219.       XCOR(3)=Z2D3
  220.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  221.       CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P2D3,IMPR,IRET)
  222.       IF (IRET.NE.0) GOTO 9999
  223.       SEGDES PGCOUR
  224.       MYPGS.LISPG(**)=PGCOUR
  225. *
  226. * Méthode de nom : GAT3-5-14
  227. * Sur un tétraèdre : cubature d'ordre 5 à 14 points
  228. *                    espace de référence de dimension 3
  229. *
  230. * In INIPG : SEGINI PGCOUR
  231.       CALL INIPG('GAT3-5-14','GAUSS','TETRAEDRE',
  232.      $     5,14,3,
  233.      $     PGCOUR,
  234.      $     IMPR,IRET)
  235.       IF (IRET.NE.0) GOTO 9999
  236.       NOPG=0
  237.       XCOR(1)=X1D5
  238.       XCOR(2)=Y1D5
  239.       XCOR(3)=Z1D5
  240.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  241.       CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D5,IMPR,IRET)
  242.       IF (IRET.NE.0) GOTO 9999
  243.       XCOR(1)=X2D5
  244.       XCOR(2)=Y2D5
  245.       XCOR(3)=Z2D5
  246.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  247.       CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P2D5,IMPR,IRET)
  248.       IF (IRET.NE.0) GOTO 9999
  249.       XCOR(1)=X3D5
  250.       XCOR(2)=Y3D5
  251.       XCOR(3)=Z3D5
  252.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  253.       CALL GT3FS9(PGCOUR,NOPG,DIMSRF,XCOR,P3D5,IMPR,IRET)
  254.       IF (IRET.NE.0) GOTO 9999
  255.       SEGDES PGCOUR
  256.       MYPGS.LISPG(**)=PGCOUR
  257. *
  258. * Méthode de nom : GPT3-5-21
  259. * Sur un tétraèdre : méthode gauss-produit conique d'ordre 5 à 21 points
  260. *                    espace de référence de dimension 3
  261. *
  262. * In INIPG : SEGINI PGCOUR
  263.       CALL INIPG('GPT3-5-21','GAUSS-PRODUIT','TETRAEDRE',
  264.      $     5,21,3,
  265.      $     PGCOUR,
  266.      $     IMPR,IRET)
  267.       IF (IRET.NE.0) GOTO 9999
  268.       CALL FIPG('GAT2-5-7',MYPGS,PGPRO1,IMPR,IRET)
  269.       IF (IRET.NE.0) GOTO 9999
  270.       CALL FIPG('GJ20-5-3',MYPGS,PGPRO2,IMPR,IRET)
  271.       IF (IRET.NE.0) GOTO 9999
  272.       CALL CPROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  273.       IF (IRET.NE.0) GOTO 9999
  274.       SEGDES PGCOUR
  275.       MYPGS.LISPG(**)=PGCOUR
  276. *
  277. * Méthode de nom : GPT3-5-27
  278. * Sur un tétraèdre : méthode gauss-produit conique d'ordre 5 à 27 points
  279. *                    espace de référence de dimension 3
  280. *
  281. * In INIPG : SEGINI PGCOUR
  282.       CALL INIPG('GPT3-5-27','GAUSS-PRODUIT','TETRAEDRE',
  283.      $     5,27,3,
  284.      $     PGCOUR,
  285.      $     IMPR,IRET)
  286.       IF (IRET.NE.0) GOTO 9999
  287.       CALL FIPG('GPT2-5-9',MYPGS,PGPRO1,IMPR,IRET)
  288.       IF (IRET.NE.0) GOTO 9999
  289.       CALL FIPG('GJ20-5-3',MYPGS,PGPRO2,IMPR,IRET)
  290.       IF (IRET.NE.0) GOTO 9999
  291.       CALL CPROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  292.       IF (IRET.NE.0) GOTO 9999
  293.       SEGDES PGCOUR
  294.       MYPGS.LISPG(**)=PGCOUR
  295. *
  296. * Méthode de nom : GAT3-6-24
  297. * Sur un tétraèdre : cubature d'ordre 6 à 24 points
  298. *                    espace de référence de dimension 3
  299. *
  300. * In INIPG : SEGINI PGCOUR
  301.       CALL INIPG('GAT3-6-24','GAUSS','TETRAEDRE',
  302.      $     6,24,3,
  303.      $     PGCOUR,
  304.      $     IMPR,IRET)
  305.       IF (IRET.NE.0) GOTO 9999
  306.       NOPG=0
  307.       XCOR(1)=X1D6
  308.       XCOR(2)=Y1D6
  309.       XCOR(3)=Z1D6
  310.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  311.       CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P1D6,IMPR,IRET)
  312.       IF (IRET.NE.0) GOTO 9999
  313.       XCOR(1)=X2D6
  314.       XCOR(2)=Y2D6
  315.       XCOR(3)=Z2D6
  316.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  317.       CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P2D6,IMPR,IRET)
  318.       IF (IRET.NE.0) GOTO 9999
  319.       XCOR(1)=X3D6
  320.       XCOR(2)=Y3D6
  321.       XCOR(3)=Z3D6
  322.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  323.       CALL GTRO3I(PGCOUR,NOPG,DIMSRF,XCOR,P3D6,IMPR,IRET)
  324.       IF (IRET.NE.0) GOTO 9999
  325.       XCOR(1)=X4D6
  326.       XCOR(2)=Y4D6
  327.       XCOR(3)=Z4D6
  328.       XCOR(4)=1-XCOR(1)-XCOR(2)-XCOR(3)
  329.       CALL GT3F10(PGCOUR,NOPG,DIMSRF,XCOR,P4D6,IMPR,IRET)
  330.       IF (IRET.NE.0) GOTO 9999
  331.       SEGDES PGCOUR
  332.       MYPGS.LISPG(**)=PGCOUR
  333. *
  334. * Méthode de nom : GPT3-7-64
  335. * Sur un tétraèdre : méthode gauss-produit conique d'ordre 7 à 64 points
  336. *                    espace de référence de dimension 3
  337. *
  338. * In INIPG : SEGINI PGCOUR
  339.       CALL INIPG('GPT3-7-64','GAUSS-PRODUIT','TETRAEDRE',
  340.      $     7,64,3,
  341.      $     PGCOUR,
  342.      $     IMPR,IRET)
  343.       IF (IRET.NE.0) GOTO 9999
  344.       CALL FIPG('GPT2-7-16',MYPGS,PGPRO1,IMPR,IRET)
  345.       IF (IRET.NE.0) GOTO 9999
  346.       CALL FIPG('GJ20-7-4',MYPGS,PGPRO2,IMPR,IRET)
  347.       IF (IRET.NE.0) GOTO 9999
  348.       CALL CPROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  349.       IF (IRET.NE.0) GOTO 9999
  350.       SEGDES PGCOUR
  351.       MYPGS.LISPG(**)=PGCOUR
  352. *
  353. * Normal termination
  354. *
  355.       IRET=0
  356.       RETURN
  357. *
  358. * Format handling
  359. *
  360. *
  361. * Error handling
  362. *
  363.  9999 CONTINUE
  364.       IRET=1
  365.       WRITE(IOIMP,*) 'An error was detected in subroutine ingate'
  366.       RETURN
  367. *
  368. * End of subroutine INGATE
  369. *
  370.       END
  371.  
  372.  
  373.  
  374.  
  375.  

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