Télécharger kgras.eso

Retour à la liste

Numérotation des lignes :

  1. C KGRAS SOURCE MAGN 17/02/24 21:15:13 9323
  2. SUBROUTINE KGRAS(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,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.  
  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 GRADS'
  56. CALL ERREUR(788)
  57. RETURN
  58. ENDIF
  59.  
  60. CALL LEKTAB(MTABD,'XXDIAGSI',MCHPO2)
  61. CALL LICHTL(MCHPO2,MPOVA2,TYPE,IGEOM)
  62. CALL KRIPAD(MELEMS,MLENT2)
  63. TYPE='SOMMET'
  64. CALL CRCHPT(TYPE,MELEMS,IDIM,MCHPOI)
  65. CALL LICHTM(MCHPOI,MPOVAL,TYPE,IGEOM)
  66.  
  67. TYPE=' '
  68. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  69.  
  70. SEGACT MELEME
  71. NBSOUS=LISOUS(/1)
  72. IF(NBSOUS.EQ.0)NBSOUS=1
  73.  
  74. KK=0
  75. DO 1 L=1,NBSOUS
  76. IPT1=MELEME
  77. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  78. SEGACT IPT1
  79. NP=IPT1.NUM(/1)
  80. NEL=IPT1.NUM(/2)
  81.  
  82. NOM0=NOMS(IPT1.ITYPEL)//' '
  83. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  84. IF(IZFFM.EQ.0)GO TO 90
  85. SEGACT IZFFM*MOD
  86. IZHR=KZHR(1)
  87. SEGACT IZHR*MOD
  88. NPG=FN(/2)
  89. NES=GR(/1)
  90.  
  91. DO 10 K=1,NEL
  92. KK=KK+1
  93. DO 9 I=1,NP
  94. J=IPT1.NUM(I,K)
  95. DO 12 N=1,IDIM
  96. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  97. 12 CONTINUE
  98. 9 CONTINUE
  99.  
  100. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
  101. *IDIM,NP,NPG,IAXI,AIRE)
  102.  
  103. DO 35 I=1,NP
  104. I2 = MLENT2.LECT(IPT1.NUM(I,K))
  105.  
  106. DO 36 N=1,IDIM
  107. UU=0.D0
  108. DO 37 LG=1,NPG
  109. GNUL=0.D0
  110. DO 38 J=1,NP
  111. J1 = IZIPAD.LECT(IPT1.NUM(J,K))
  112. GNUL = GNUL + MPOVA1.VPOCHA(J1,1)*HR(N,J,LG)
  113. 38 CONTINUE
  114. UU= UU + FN(I,LG)*PGSQ(LG)*GNUL
  115. 37 CONTINUE
  116. VPOCHA(I2,N)=VPOCHA(I2,N)+UU
  117. 36 CONTINUE
  118. 35 CONTINUE
  119.  
  120. 10 CONTINUE
  121. SEGDES IPT1
  122. 1 CONTINUE
  123. NPT=VPOCHA(/1)
  124. DO 2 I=1,NPT
  125. DO 2 N=1,IDIM
  126. VPOCHA(I,N)=VPOCHA(I,N)/MPOVA2.VPOCHA(I,1)
  127. 2 CONTINUE
  128.  
  129. SEGDES MPOVA1,MPOVAL,MPOVA2
  130. SEGDES MCHPO1,MCHPOI,MCHPO2
  131. SEGDES MELEME,IGEOM1,MELEMS
  132. C
  133. SEGSUP IZIPAD,IZFFM,IZHR,MLENT2
  134. CALL ECROBJ('CHPOINT ',MCHPOI)
  135.  
  136. RETURN
  137.  
  138. 90 CONTINUE
  139. WRITE(6,*)'Interruption anormale de KOPS option GRAD '
  140. RETURN
  141.  
  142. 1001 FORMAT(20(1X,I5))
  143. 1008 FORMAT(10(1X,A8))
  144. 1002 FORMAT(10(1X,1PE11.4))
  145. END
  146.  
  147.  
  148.  
  149.  
  150.  
  151.  
  152.  

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