Télécharger reshpt.eso

Retour à la liste

Numérotation des lignes :

  1. C RESHPT SOURCE BP208322 16/11/18 21:20:57 9177
  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. -INC CCOPTIO
  28. SEGMENT/SHXX/(SHPXXX(6,NBB)*D)
  29. DIMENSION IMIPOR(5)
  30. C
  31. DATA IMIPOR/4,8,14,23,16/
  32. C
  33. NPINT1=NPINT
  34. NNN=NNNN
  35. IRET=1
  36. NBBB=NBNNE(IELE)
  37. NBNO=NBSH
  38.  
  39. IP1C=0
  40. IF (MELE.GE.195.AND.NPINT.EQ.1) THEN
  41. IP1C=1
  42. NPINT1=0
  43. ELSEIF (MELE.GE.195.AND.NPINT.EQ.2) THEN
  44. IP1C=2
  45. NPINT1=0
  46. ENDIF
  47. C WRITE(6,*)'IP1C=',IP1C
  48.  
  49. CALL DONRED(NNN,IELE,MELE,NBNO,NPINT1,IPT1,IRT1)
  50. IF (IRT1.EQ.1) GOTO 10
  51. C
  52. C MESSAGE D ERREUR NBPGAU ET IELE NON COMPATIBLES POUR
  53. C L INSTANT
  54. C
  55. MOTERR(1:4)=NOMS(IELE)
  56. INTERR(1)=NNN
  57. CALL ERREUR(67)
  58. IRET=0
  59. GOTO 666
  60. 10 CONTINUE
  61. MINTE=IPT1
  62. SEGACT MINTE*MOD
  63. C
  64. DO 110 IA=1,NNN
  65. DO 110 IB=1,6
  66. DO 110 IC=1,NBNO
  67. SHPTOT(IB,IC,IA)=0.D0
  68. 110 CONTINUE
  69. NBB=NBNO
  70. SEGINI SHXX
  71. *
  72. * BOUCLE SUR LES POINTS
  73. *
  74. DO 100 II=1,NNN
  75. C INSERER EVENTUELLEMENT UN INDICATEUR DE SUCCES
  76. XX=QSIGAU(II)
  77. YY=ETAGAU(II)
  78. ZZ=DZEGAU(II)
  79. IF(MELE.EQ.96) THEN
  80. CALL SHAP96(XX,YY,ZZ,IELE,SHPXXX,IRT2)
  81. ELSE IF(MELE.EQ.128) THEN
  82. CALL SHROT3(XX,YY,ZZ,IELE,SHPXXX,IRT2)
  83. ELSEIF ((MELE.GE.111).AND.(MELE.LE.122)) THEN
  84. CALL SHPOLY(XX,YY,ZZ,II,MELE,SHPXXX,IRT2)
  85. ELSEIF ((MELE.GE.223).AND.(MELE.LE.236).AND.(IP1C.EQ.0)) THEN
  86. CALL SHMACR(XX,YY,ZZ,MELE,SHPXXX,IRT2)
  87. ELSEIF ((MELE.GE.195).AND.(IP1C.EQ.1)) THEN
  88. CALL SHP1CE(XX,YY,ZZ,MELE,SHPXXX,IRT2)
  89. ELSEIF(MELE.EQ.260) then
  90. CALL shSHB8(XX,shpxxx)
  91. irt2=1
  92. ELSE
  93. CALL SHAPE(XX,YY,ZZ,IELE,SHPXXX,IRT2)
  94. ENDIF
  95. C
  96. C TRAITEMENT SPECIAL MILIEU POREUX
  97. C
  98. IF(MELE.GE.79.AND.MELE.LE.83) THEN
  99. CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-78),
  100. . SHPXXX(1,NBBB+1),IRT2)
  101. *
  102. ELSE IF(MELE.GE.173.AND.MELE.LE.177) THEN
  103. CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-172),
  104. . SHPXXX(1,NBBB+1),IRT2)
  105. *
  106. ELSE IF(MELE.GE.178.AND.MELE.LE.182) THEN
  107. CALL SHAPE(XX,YY,ZZ,IMIPOR(MELE-177),
  108. . SHPXXX(1,NBBB+1),IRT2)
  109. *
  110. ENDIF
  111. C
  112. DO 200 ID=1,6
  113. DO 200 NO=1,NBNO
  114. SHPTOT(ID,NO,II)=SHPXXX(ID,NO)
  115. * WRITE(*,*) 'SHP (',ID,',',NO,') =', SHPXXX(ID,NO)
  116. 200 CONTINUE
  117. 100 CONTINUE
  118. C
  119. C ON CALCULE LES FONCTIONS D EXTRAPOLATIONS
  120. C
  121. if( mele.ne.260) CALL EXTRAP(SHPTOT,NNN,NBBB,NBNO)
  122. C
  123. SEGSUP SHXX
  124. IF (IRT2.EQ.1) GOTO 20
  125. C
  126. C ERREUR LES FONCTIONS DE FORME PAS ENCORE IMPLEMENTEES
  127. C
  128. MOTERR(1:4)=NOMS(IELE)
  129. CALL ERREUR(68)
  130. IRET=0
  131. SEGSUP MINTE
  132. GOTO 666
  133. 20 IPT=IPT1
  134. SEGDES MINTE
  135. 666 CONTINUE
  136. RETURN
  137. END
  138.  
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  
  145.  
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  
  153.  
  154.  

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