Télécharger propg.eso

Retour à la liste

Numérotation des lignes :

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

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