Télécharger la plaquette Cast3M


fr en

Télécharger ingacu.eso

Retour à la liste

Numérotation des lignes : 

ingacu

  1. C INGACU    SOURCE    GOUNAND   21/06/02    21:16:37     11022          
  2.       SUBROUTINE INGACU(MYPGS,IMPR,IRET)
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : INGACU
  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 cube (ordre 1 à 5).
  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, GCSINO, GCFS2, GCRESY
  20. C APPELE PAR       : INPGS
  21. C***********************************************************************
  22. C ENTREES            : -
  23. C ENTREES/SORTIES    : MYPGS (actif en *MOD)
  24. C SORTIES            : -
  25. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  26. C***********************************************************************
  27. C VERSION    : v1, 11/05/00, version initiale
  28. C HISTORIQUE : v1, 11/05/00, création
  29. C HISTORIQUE :
  30. C HISTORIQUE :
  31. C***********************************************************************
  32. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  33. C en cas de modification de ce sous-programme afin de faciliter
  34. C la maintenance !
  35. C***********************************************************************
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC TNLIN      
  40. *-INC SPOGAU
  41.       POINTEUR MYPGS.POGAUS
  42.       POINTEUR PGCOUR.POGAU
  43. *
  44.       INTEGER IMPR,IRET
  45.       integer PGPRO1,PGPRO2
  46. *
  47.       INTEGER DIMSRF
  48.       PARAMETER(DIMSRF=3)
  49.       REAL*8 XCOR(DIMSRF)
  50. *
  51. *  Générateurs pour la cubature de degré 1 à 1 point  : GAC3-1-1 :
  52. *   - [ Fully symmetric ]
  53.       REAL*8 X1D1,Y1D1,Z1D1,P1D1
  54.       PARAMETER (X1D1=0.D0)
  55.       PARAMETER (Y1D1=0.D0)
  56.       PARAMETER (Z1D1=0.D0)
  57.       PARAMETER (P1D1=8.D0)
  58. *
  59. *  Générateurs pour la cubature de degré 3 à 6 points : GAC3-3-6A :
  60. *   - [ Fully symmetric ]
  61.       REAL*8 X1D3,Y1D3,Z1D3,P1D3
  62.       PARAMETER (X1D3=1.D0)
  63.       PARAMETER (Y1D3=0.D0)
  64.       PARAMETER (Z1D3=0.D0)
  65.       PARAMETER (P1D3=4.D0/3.D0)
  66. *
  67. *  Générateurs pour la cubature de degré 5 à 14 points : GAC3-5-14 :
  68. *   - [ Fully symmetric ]
  69.       REAL*8 X1D5,Y1D5,Z1D5,P1D5
  70.       PARAMETER (X1D5=0.795822425754221463264548820476135D0)
  71.       PARAMETER (Y1D5=0.D0)
  72.       PARAMETER (Z1D5=0.D0)
  73.       PARAMETER (P1D5=0.886426592797783933518005540166204D0)
  74. *   - [ Fully symmetric ]
  75.       REAL*8 X2D5,Y2D5,Z2D5,P2D5
  76.       PARAMETER (X2D5=0.758786910639328146269034278112267D0)
  77.       PARAMETER (Y2D5=0.758786910639328146269034278112267D0)
  78.       PARAMETER (Z2D5=0.758786910639328146269034278112267D0)
  79.       PARAMETER (P2D5=0.335180055401662049861495844875346D0)
  80. *
  81.       INTEGER NOPG
  82. *
  83. * Executable statements
  84. *
  85.       IF (IMPR.GT.6) WRITE(IOIMP,*) 'Entrée dans ingacu'
  86. *
  87. * Méthode de nom : NCC3-1-8
  88. * Sur un cube : cubature d'ordre 1 à 8 points
  89. *               espace de référence de dimension 3
  90. *
  91. * In INIPG : SEGINI PGCOUR
  92.       CALL INIPG('NCC3-1-8','NEWTON-COTES','CUBE',
  93.      $     1,8,3,
  94.      $     PGCOUR,
  95.      $     IMPR,IRET)
  96.       IF (IRET.NE.0) GOTO 9999
  97.       CALL FIPG('NCC2-1-4',MYPGS,PGPRO1,IMPR,IRET)
  98.       IF (IRET.NE.0) GOTO 9999
  99.       CALL FIPG('NCC1-1-2',MYPGS,PGPRO2,IMPR,IRET)
  100.       IF (IRET.NE.0) GOTO 9999
  101.       CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  102.       IF (IRET.NE.0) GOTO 9999
  103.       SEGDES PGCOUR
  104.       MYPGS.LISPG(**)=PGCOUR
  105. *
  106. * Méthode de nom : NCC3-3-27
  107. * Sur un cube : cubature d'ordre 3 à 27 points
  108. *               espace de référence de dimension 3
  109. *
  110. * In INIPG : SEGINI PGCOUR
  111.       CALL INIPG('NCC3-3-27','NEWTON-COTES','CUBE',
  112.      $     3,27,3,
  113.      $     PGCOUR,
  114.      $     IMPR,IRET)
  115.       IF (IRET.NE.0) GOTO 9999
  116.       CALL FIPG('NCC2-3-9',MYPGS,PGPRO1,IMPR,IRET)
  117.       IF (IRET.NE.0) GOTO 9999
  118.       CALL FIPG('NCC1-3-3',MYPGS,PGPRO2,IMPR,IRET)
  119.       IF (IRET.NE.0) GOTO 9999
  120.       CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  121.       IF (IRET.NE.0) GOTO 9999
  122.       SEGDES PGCOUR
  123.       MYPGS.LISPG(**)=PGCOUR
  124. *
  125. * Méthode de nom : GAC3-1-1
  126. * Sur un cube : cubature d'ordre 1 à 1 point
  127. *               espace de référence de dimension 3
  128. *
  129. * In INIPG : SEGINI PGCOUR
  130.       CALL INIPG('GAC3-1-1','GAUSS','CUBE',
  131.      $     1,1,3,
  132.      $     PGCOUR,
  133.      $     IMPR,IRET)
  134.       IF (IRET.NE.0) GOTO 9999
  135.       NOPG=0
  136.       XCOR(1)=X1D1
  137.       XCOR(2)=Y1D1
  138.       XCOR(3)=Z1D1
  139.       CALL GCSINO(PGCOUR,NOPG,DIMSRF,XCOR,P1D1,IMPR,IRET)
  140.       IF (IRET.NE.0) GOTO 9999
  141.       SEGDES PGCOUR
  142.       MYPGS.LISPG(**)=PGCOUR
  143. *
  144. * Méthode de nom : GAC3-3-6A
  145. * Sur un cube : cubature d'ordre 3 à 6 points
  146. *               espace de référence de dimension 3
  147. *
  148. * In INIPG : SEGINI PGCOUR
  149.       CALL INIPG('GAC3-3-6A','GAUSS','CUBE',
  150.      $     3,6,3,
  151.      $     PGCOUR,
  152.      $     IMPR,IRET)
  153.       IF (IRET.NE.0) GOTO 9999
  154.       NOPG=0
  155.       XCOR(1)=X1D3
  156.       XCOR(2)=Y1D3
  157.       XCOR(3)=Z1D3
  158.       CALL GCFS2(PGCOUR,NOPG,DIMSRF,XCOR,P1D3,IMPR,IRET)
  159.       IF (IRET.NE.0) GOTO 9999
  160.       SEGDES PGCOUR
  161.       MYPGS.LISPG(**)=PGCOUR
  162. *
  163. * Méthode de nom : GPC3-3-8
  164. * Sur un cube : méthode gauss-produit d'ordre 3 à 8 points
  165. *               espace de référence de dimension 3
  166. *
  167. * In INIPG : SEGINI PGCOUR
  168.       CALL INIPG('GPC3-3-8','GAUSS-PRODUIT','CUBE',
  169.      $     3,8,3,
  170.      $     PGCOUR,
  171.      $     IMPR,IRET)
  172.       IF (IRET.NE.0) GOTO 9999
  173.       CALL FIPG('GPC2-3-4',MYPGS,PGPRO1,IMPR,IRET)
  174.       IF (IRET.NE.0) GOTO 9999
  175.       CALL FIPG('GAC1-3-2',MYPGS,PGPRO2,IMPR,IRET)
  176.       IF (IRET.NE.0) GOTO 9999
  177.       CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  178.       IF (IRET.NE.0) GOTO 9999
  179.       SEGDES PGCOUR
  180.       MYPGS.LISPG(**)=PGCOUR
  181. *
  182. * Méthode de nom : GAC3-5-14
  183. * Sur un cube : cubature d'ordre 5 à 14 points
  184. *               espace de référence de dimension 3
  185. *
  186. * In INIPG : SEGINI PGCOUR
  187.       CALL INIPG('GAC3-5-14','GAUSS','CUBE',
  188.      $     5,14,3,
  189.      $     PGCOUR,
  190.      $     IMPR,IRET)
  191.       IF (IRET.NE.0) GOTO 9999
  192.       NOPG=0
  193.       XCOR(1)=X1D5
  194.       XCOR(2)=Y1D5
  195.       XCOR(3)=Z1D5
  196.       CALL GCFS2(PGCOUR,NOPG,DIMSRF,XCOR,P1D5,IMPR,IRET)
  197.       IF (IRET.NE.0) GOTO 9999
  198.       XCOR(1)=X2D5
  199.       XCOR(2)=Y2D5
  200.       XCOR(3)=Z2D5
  201.       CALL GCRESY(PGCOUR,NOPG,DIMSRF,XCOR,P2D5,IMPR,IRET)
  202.       IF (IRET.NE.0) GOTO 9999
  203.       SEGDES PGCOUR
  204.       MYPGS.LISPG(**)=PGCOUR
  205. *
  206. * Méthode de nom : GPC3-5-27
  207. * Sur un cube : méthode gauss-produit d'ordre 5 à 27 points
  208. *               espace de référence de dimension 3
  209. *
  210. * In INIPG : SEGINI PGCOUR
  211.       CALL INIPG('GPC3-5-27','GAUSS-PRODUIT','CUBE',
  212.      $     5,27,3,
  213.      $     PGCOUR,
  214.      $     IMPR,IRET)
  215.       IF (IRET.NE.0) GOTO 9999
  216.       CALL FIPG('GPC2-5-9',MYPGS,PGPRO1,IMPR,IRET)
  217.       IF (IRET.NE.0) GOTO 9999
  218.       CALL FIPG('GAC1-5-3',MYPGS,PGPRO2,IMPR,IRET)
  219.       IF (IRET.NE.0) GOTO 9999
  220.       CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  221.       IF (IRET.NE.0) GOTO 9999
  222.       SEGDES PGCOUR
  223.       MYPGS.LISPG(**)=PGCOUR
  224. *
  225. * Méthode de nom : GPC3-7-64
  226. * Sur un cube : méthode gauss-produit d'ordre 7 à 64 points
  227. *               espace de référence de dimension 3
  228. *
  229. * In INIPG : SEGINI PGCOUR
  230.       CALL INIPG('GPC3-7-64','GAUSS-PRODUIT','CUBE',
  231.      $     7,64,3,
  232.      $     PGCOUR,
  233.      $     IMPR,IRET)
  234.       IF (IRET.NE.0) GOTO 9999
  235.       CALL FIPG('GPC2-7-16',MYPGS,PGPRO1,IMPR,IRET)
  236.       IF (IRET.NE.0) GOTO 9999
  237.       CALL FIPG('GAC1-7-4',MYPGS,PGPRO2,IMPR,IRET)
  238.       IF (IRET.NE.0) GOTO 9999
  239.       CALL PROPG(PGPRO1,PGPRO2,PGCOUR,IMPR,IRET)
  240.       IF (IRET.NE.0) GOTO 9999
  241.       SEGDES PGCOUR
  242.       MYPGS.LISPG(**)=PGCOUR
  243. *
  244. * Normal termination
  245. *
  246.       IRET=0
  247.       RETURN
  248. *
  249. * Format handling
  250. *
  251. *
  252. * Error handling
  253. *
  254.  9999 CONTINUE
  255.       IRET=1
  256.       WRITE(IOIMP,*) 'An error was detected in subroutine ingacu'
  257.       RETURN
  258. *
  259. * End of subroutine INGACU
  260. *
  261.       END
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  

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