Télécharger kgra.eso

Retour à la liste

Numérotation des lignes :

  1. C KGRA SOURCE MAGN 17/02/24 21:15:12 9323
  2. SUBROUTINE KGRA(MCHPO1,MPOVA1,IGEOM1,MTABD)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C Operateur KGRA
  7. C
  8. C Objet : determine le GRADIENT d un CHAMPOINT SOMMET
  9. C
  10. C SYNTAXE : CHGR =KOPS CHPS 'GRAD' TABDOM ;
  11. C TABDOM : Table DOMAINE contenant le support geometrique de CHPC
  12. C CHPS : CHAMPOINT SOMMET
  13. C CHGR : CHAMPOINT CENTRE
  14. C
  15. C*************************************************************************
  16. -INC SMTABLE
  17. POINTEUR MTABD.MTABLE
  18. -INC SMELEME
  19. POINTEUR MELEMS.MELEME,MELEMC.MELEME,IGEOM1.MELEME
  20. -INC CCOPTIO
  21. -INC SMCOORD
  22. -INC CCGEOME
  23. -INC SMCHPOI
  24. POINTEUR IZB.MCHPOI,IZBB.MPOVAL
  25. POINTEUR IZD.MCHPOI,IZDD.MPOVAL
  26. POINTEUR IZV.MCHPOI,IZVV.MPOVAL
  27. -INC SMLENTI
  28. POINTEUR IZIPAD.MLENTI
  29. -INC SIZFFB
  30. REAL*8 HRT(24),RPGJ(9),XYZI(8)
  31. CHARACTER*8 TYPE,TYPC,NOM0
  32. C***
  33. C write(6,*)' On est dans KGRA '
  34. IAXI=0
  35. IF(IFOMOD.EQ.0)IAXI=2
  36.  
  37. NC=MPOVA1.VPOCHA(/2)
  38. NPT=MPOVA1.VPOCHA(/1)
  39.  
  40. IF(NC.NE.1)THEN
  41. WRITE(6,*)' Opérateur KOPS option GRAD '
  42. WRITE(6,*)' Le Champoint a plus d''une composante ',nc
  43. RETURN
  44. ENDIF
  45.  
  46. TYPE=' '
  47. CALL ACMO(MTABD,'SOMMET',TYPE,MELEMS)
  48.  
  49. CALL KRIPAD(IGEOM1,IZIPAD)
  50. CALL VERPAD(IZIPAD,MELEMS,IRET)
  51. IF(IRET.NE.0)THEN
  52. C% Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique
  53. MOTERR(1: 8) = 'TETA1'
  54. MOTERR(9:16) = 'CHPOINT '
  55. WRITE(IOIMP,*)'Operateur : KOPS GRAD'
  56. CALL ERREUR(788)
  57. RETURN
  58. ENDIF
  59.  
  60. TYPE=' '
  61. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  62. TYPE='CENTRE'
  63. CALL CRCHPT(TYPE,MELEMC,IDIM,MCHPOI)
  64. CALL LICHTM(MCHPOI,MPOVAL,TYPE,IGEOM)
  65.  
  66. TYPE=' '
  67. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  68.  
  69. SEGACT MELEME
  70. NBSOUS=LISOUS(/1)
  71. IF(NBSOUS.EQ.0)NBSOUS=1
  72.  
  73. KK=0
  74. DO 1 L=1,NBSOUS
  75. IPT1=MELEME
  76. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  77. SEGACT IPT1
  78. NP=IPT1.NUM(/1)
  79. NEL=IPT1.NUM(/2)
  80.  
  81. NOM0=NOMS(IPT1.ITYPEL)//' '
  82. CALL KALPBG(NOM0,'FONFORM0',IZFFM)
  83. IF(IZFFM.EQ.0)GO TO 90
  84. SEGACT IZFFM*MOD
  85. IZHR=KZHR(1)
  86. SEGACT IZHR*MOD
  87. NPG=FN(/2)
  88. NES=GR(/1)
  89.  
  90. DO 10 K=1,NEL
  91. KK=KK+1
  92. DO 9 I=1,NP
  93. J=IPT1.NUM(I,K)
  94. DO 12 N=1,IDIM
  95. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  96. 12 CONTINUE
  97. 9 CONTINUE
  98.  
  99. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
  100. *IDIM,NP,NPG,IAXI,AIRE)
  101.  
  102. DO 36 N=1,IDIM
  103. UU=0.D0
  104. DO 35 I=1,NP
  105. IU = IZIPAD.LECT(IPT1.NUM(I,K))
  106. UU= UU + MPOVA1.VPOCHA(IU,1)*HR(N,I,1)
  107. 35 CONTINUE
  108. VPOCHA(KK,N)=UU
  109. 36 CONTINUE
  110.  
  111. 10 CONTINUE
  112. SEGDES IPT1
  113. 1 CONTINUE
  114. SEGDES MPOVA1,MPOVAL
  115. SEGDES MCHPO1,MCHPOI
  116. SEGDES MELEME,IGEOM1,MELEMS
  117. C
  118. SEGSUP IZIPAD,IZFFM,IZHR
  119. CALL ECROBJ('CHPOINT ',MCHPOI)
  120.  
  121. RETURN
  122.  
  123. 90 CONTINUE
  124. WRITE(6,*)'Interruption anormale de KOPS option GRAD '
  125. RETURN
  126.  
  127. 1001 FORMAT(20(1X,I5))
  128. 1008 FORMAT(10(1X,A8))
  129. 1002 FORMAT(10(1X,1PE11.4))
  130. END
  131.  
  132.  
  133.  
  134.  
  135.  
  136.  

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