Télécharger reshpt.eso

Retour à la liste

Numérotation des lignes :

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

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