Télécharger reshpt.eso

Retour à la liste

Numérotation des lignes :

reshpt
  1. C RESHPT SOURCE CB215821 20/01/29 21:15:06 10510
  2. SUBROUTINE RESHPT(NNNN,NBSH,IELE,MELE,NPINT,IPT,IRET)
  3. C=======================================================
  4. C
  5. C MET LES VALEURS DES FONCTIONS DE FORMES DANS SHPTOT
  6. C ET LES COORDOONEES REDUITES LES POIDS D INTEGRATION
  7. C DANS QSIGAU ETAGAU DZEGAU POIGAU ; LE TOUT EST
  8. C MIS DANS LE POINTEUR MINTE SON POINTEUR EST IPT
  9. C NNN =NOMBRE DE POINTS DE GAUSS
  10. C NBSH =NOMBRE DE FONCTIONS D'INTERPOLATION
  11. C IELE =NUMERO DE L ELEMENT DANS NOMS (VOIR CCGEOME )
  12. C MELE =NUMERO DE L ELEMENT DANS NOMTP
  13. C NPINT=NOMBRE DE POINTS D'INTEGRATION DONS LE CAS DES
  14. C ELEMENTS COQUES INTEGRES
  15. C IPT = POINTEUR SUR MINTE
  16. C IRET=1 OU 0 SUIVANT QUE MINTE A ETE CREEE OU PAS
  17. C
  18. C CETTE ROUTINE GERE LES MESSAGES D ERREURS
  19. C PROVENANT DE L INCOMPATIBILTE ENTRE NOMS
  20. C D ELEMENTS,NOMBRE DE POINTS DE GAUSS,ET FONCTIONS DE FORME
  21. C
  22. C=======================================================
  23. IMPLICIT INTEGER(I-N)
  24. IMPLICIT REAL*8(A-H,O-Z)
  25. -INC CCGEOME
  26. -INC SMINTE
  27.  
  28. -INC PPARAM
  29. -INC CCOPTIO
  30. SEGMENT/SHXX/(SHPXXX(6,NBB)*D)
  31. DIMENSION IMIPOR(5)
  32. C
  33. DATA IMIPOR/4,8,14,23,16/
  34. C
  35. NPINT1=NPINT
  36. NNN=NNNN
  37. IRET=1
  38. NBBB=NBNNE(IELE)
  39. NBNO=NBSH
  40.  
  41. IP1C=0
  42. IF (MELE.GE.195.AND.NPINT.EQ.1) THEN
  43. IP1C=1
  44. NPINT1=0
  45. ELSEIF (MELE.GE.195.AND.NPINT.EQ.2) THEN
  46. IP1C=2
  47. NPINT1=0
  48. ENDIF
  49. C WRITE(6,*)'IP1C=',IP1C
  50.  
  51. CALL DONRED(NNN,IELE,MELE,NBNO,NPINT1,IPT1,IRT1)
  52. IF (IRT1.EQ.1) GOTO 10
  53. C
  54. C MESSAGE D ERREUR NBPGAU ET IELE NON COMPATIBLES POUR
  55. C L INSTANT
  56. C
  57. MOTERR(1:4)=NOMS(IELE)
  58. INTERR(1)=NNN
  59. CALL ERREUR(67)
  60. IRET=0
  61. GOTO 666
  62. 10 CONTINUE
  63. MINTE=IPT1
  64. SEGACT MINTE*MOD
  65. C
  66. IA=SHPTOT(/1)
  67. CALL ZERO(SHPTOT(1,1,1),IA*NBNO*NNN,1)
  68. NBB=NBNO
  69. SEGINI SHXX
  70. *
  71. * BOUCLE SUR LES POINTS
  72. *
  73. DO 100 II=1,NNN
  74. C INSERER EVENTUELLEMENT UN INDICATEUR DE SUCCES
  75. XX=QSIGAU(II)
  76. YY=ETAGAU(II)
  77. ZZ=DZEGAU(II)
  78. IF(MELE.EQ.96) THEN
  79. CALL SHAP96(XX,YY,ZZ,IELE,SHPXXX,IRT2)
  80. ELSE IF(MELE.EQ.128) THEN
  81. CALL SHROT3(XX,YY,ZZ,IELE,SHPXXX,IRT2)
  82. ELSEIF ((MELE.GE.111).AND.(MELE.LE.122)) THEN
  83. CALL SHPOLY(XX,YY,ZZ,II,MELE,SHPXXX,IRT2)
  84. ELSEIF ((MELE.GE.223).AND.(MELE.LE.236).AND.(IP1C.EQ.0)) THEN
  85. CALL SHMACR(XX,YY,ZZ,MELE,SHPXXX,IRT2)
  86. ELSEIF ((MELE.GE.195).AND.(IP1C.EQ.1)) THEN
  87. CALL SHP1CE(XX,YY,ZZ,MELE,SHPXXX,IRT2)
  88. ELSEIF(MELE.EQ.260) then
  89. CALL shSHB8(XX,shpxxx)
  90. irt2=1
  91. ELSE
  92. CALL SHAPE(XX,YY,ZZ,IELE,SHPXXX,IRT2)
  93. ENDIF
  94. C
  95. C TRAITEMENT SPECIAL MILIEU POREUX
  96. C
  97. IF(MELE.GE.79.AND.MELE.LE.83) THEN
  98. CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-78),
  99. . SHPXXX(1,NBBB+1),IRT2)
  100. *
  101. ELSE IF(MELE.GE.173.AND.MELE.LE.177) THEN
  102. CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-172),
  103. . SHPXXX(1,NBBB+1),IRT2)
  104. *
  105. ELSE IF(MELE.GE.178.AND.MELE.LE.182) THEN
  106. CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-177),
  107. . SHPXXX(1,NBBB+1),IRT2)
  108. *
  109. ENDIF
  110. C
  111. DO 200 NO=1,NBNO
  112. DO 201 ID=1,6
  113. SHPTOT(ID,NO,II)=SHPXXX(ID,NO)
  114. 201 CONTINUE
  115. 200 CONTINUE
  116. 100 CONTINUE
  117. C
  118. C ON CALCULE LES FONCTIONS D EXTRAPOLATIONS
  119. C
  120. if( mele.ne.260) CALL EXTRAP(SHPTOT,NNN,NBBB,NBNO)
  121. C
  122. SEGSUP SHXX
  123. IF (IRT2.EQ.1) GOTO 20
  124. C
  125. C ERREUR LES FONCTIONS DE FORME PAS ENCORE IMPLEMENTEES
  126. C
  127. MOTERR(1:4)=NOMS(IELE)
  128. CALL ERREUR(68)
  129. IRET=0
  130. SEGSUP MINTE
  131. GOTO 666
  132. 20 IPT=IPT1
  133. SEGACT,MINTE*NOMOD
  134. 666 CONTINUE
  135. END
  136.  
  137.  

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