Télécharger cpropg.eso

Retour à la liste

Numérotation des lignes :

  1. C CPROPG SOURCE GOUNAND 05/12/21 21:17:32 5281
  2. SUBROUTINE CPROPG(PGPRO1,PGPRO2,
  3. $ PGCOUR,
  4. $ IMPR,IRET)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. IMPLICIT INTEGER (I-N)
  7. C***********************************************************************
  8. C NOM : CPROPG
  9. C PROJET : Noyau linéaire NLIN
  10. C DESCRIPTION : Construit les coordonnées et poids pour des règles
  11. C d'intégration "produit conique" (conical product)
  12. C
  13. C LANGAGE : ESOPE
  14. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  15. C mél : gounand@semt2.smts.cea.fr
  16. C***********************************************************************
  17. C APPELES : -
  18. C APPELE PAR : INGATR, INGATE
  19. C***********************************************************************
  20. C ENTREES : PGPRO1, PGPRO2
  21. C ENTREES/SORTIES : PGCOUR (actif en *MOD)
  22. C SORTIES : -
  23. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  24. C***********************************************************************
  25. C VERSION : v1, 14/06/2000, version initiale
  26. C HISTORIQUE : v1, 14/06/2000, création
  27. C HISTORIQUE :
  28. C HISTORIQUE :
  29. C***********************************************************************
  30. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  31. C en cas de modification de ce sous-programme afin de faciliter
  32. C la maintenance !
  33. C***********************************************************************
  34. -INC CCOPTIO
  35. CBEGININCLUDE SPOGAU
  36. SEGMENT POGAU
  37. CHARACTER*(LNNPG) NOMPG
  38. CHARACTER*(LNTPG) TYPMPG
  39. CHARACTER*(LNFPG) FORLPG
  40. INTEGER NORDPG
  41. REAL*8 XCOPG(NDLPG,NBPG)
  42. REAL*8 XPOPG(NBPG)
  43. ENDSEGMENT
  44. SEGMENT POGAUS
  45. POINTEUR LISPG(0).POGAU
  46. ENDSEGMENT
  47. CENDINCLUDE SPOGAU
  48. POINTEUR PGCOUR.POGAU
  49. POINTEUR PGPRO1.POGAU
  50. POINTEUR PGPRO2.POGAU
  51. *
  52. INTEGER IMPR,IRET
  53. *
  54. INTEGER NBPG1,NBPG2,NBPGC
  55. INTEGER IBPG1,IBPG2,IBPGC
  56. INTEGER NDIML1,NDIML2,NDIMLC
  57. INTEGER IDIML1, IDIMLC
  58. *
  59. * Executable statements
  60. *
  61. IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans cpropg.eso'
  62. SEGACT PGPRO1
  63. SEGACT PGPRO2
  64. NDIML1=PGPRO1.XCOPG(/1)
  65. NBPG1 =PGPRO1.XCOPG(/2)
  66. NDIML2=PGPRO2.XCOPG(/1)
  67. NBPG2 =PGPRO2.XCOPG(/2)
  68. NDIMLC=PGCOUR.XCOPG(/1)
  69. NBPGC =PGCOUR.XCOPG(/2)
  70. IF ((NDIML1+NDIML2).NE.NDIMLC) THEN
  71. WRITE(IOIMP,*) 'Err. dim. esp.'
  72. GOTO 9999
  73. ENDIF
  74. IF ((NBPG1*NBPG2).NE.NBPGC) THEN
  75. WRITE(IOIMP,*) 'Err. nb. noeud.'
  76. GOTO 9999
  77. ENDIF
  78. IF (NDIML2.NE.1) THEN
  79. WRITE(IOIMP,*) 'On veut la règle 2 sur un segment'
  80. GOTO 9999
  81. ENDIF
  82. IBPGC=0
  83. DO 1 IBPG2=1,NBPG2
  84. DO 12 IBPG1=1,NBPG1
  85. IBPGC=IBPGC+1
  86. IDIMLC=0
  87. DO 122 IDIML1=1,NDIML1
  88. IDIMLC=IDIMLC+1
  89. PGCOUR.XCOPG(IDIMLC,IBPGC)=
  90. $ PGPRO1.XCOPG(IDIML1,IBPG1)
  91. $ *(1.D0-PGPRO2.XCOPG(1,IBPG2))
  92. 122 CONTINUE
  93. IDIMLC=IDIMLC+1
  94. PGCOUR.XCOPG(IDIMLC,IBPGC)=
  95. $ PGPRO2.XCOPG(1,IBPG2)
  96. 124 CONTINUE
  97. PGCOUR.XPOPG(IBPGC)=PGPRO1.XPOPG(IBPG1)
  98. $ *PGPRO2.XPOPG(IBPG2)
  99. 12 CONTINUE
  100. 1 CONTINUE
  101. SEGDES PGPRO2
  102. SEGDES PGPRO1
  103. *
  104. * Normal termination
  105. *
  106. IRET=0
  107. RETURN
  108. *
  109. * Format handling
  110. *
  111. *
  112. * Error handling
  113. *
  114. 9999 CONTINUE
  115. IRET=1
  116. WRITE(IOIMP,*) 'An error was detected in subroutine cpropg'
  117. RETURN
  118. *
  119. * End of subroutine CPROPG
  120. *
  121. END
  122.  
  123.  
  124.  
  125.  

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