Télécharger kgras.eso

Retour à la liste

Numérotation des lignes :

kgras
  1. C KGRAS SOURCE CB215821 23/01/25 21:15:25 11573
  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.  
  21. -INC PPARAM
  22. -INC CCOPTIO
  23. -INC SMCOORD
  24. -INC CCGEOME
  25. -INC SMCHPOI
  26. POINTEUR IZB.MCHPOI,IZBB.MPOVAL
  27. POINTEUR IZD.MCHPOI,IZDD.MPOVAL
  28. POINTEUR IZV.MCHPOI,IZVV.MPOVAL
  29. -INC SMLENTI
  30. POINTEUR IZIPAD.MLENTI
  31. -INC SIZFFB
  32. REAL*8 HRT(24),RPGJ(9),XYZI(8)
  33. CHARACTER*8 TYPE,TYPC,NOM0
  34. C***
  35.  
  36. IAXI=0
  37. IF(IFOMOD.EQ.0)IAXI=2
  38.  
  39. NC=MPOVA1.VPOCHA(/2)
  40. NPT=MPOVA1.VPOCHA(/1)
  41.  
  42. IF(NC.NE.1)THEN
  43. WRITE(6,*)' Opérateur KOPS option GRAD '
  44. WRITE(6,*)' Le Champoint a plus d''une composante ',nc
  45. RETURN
  46. ENDIF
  47.  
  48. TYPE=' '
  49. CALL ACMO(MTABD,'SOMMET',TYPE,MELEMS)
  50.  
  51. CALL KRIPAD(IGEOM1,IZIPAD)
  52. CALL VERPAD(IZIPAD,MELEMS,IRET)
  53. IF(IRET.NE.0)THEN
  54. C% Indice %m1:8 : L'objet %m9:16 n'a pas le bon support géométrique
  55. MOTERR(1: 8) = 'TETA1'
  56. MOTERR(9:16) = 'CHPOINT '
  57. WRITE(IOIMP,*)'Operateur : KOPS GRADS'
  58. CALL ERREUR(788)
  59. RETURN
  60. ENDIF
  61.  
  62. CALL LEKTAB(MTABD,'XXDIAGSI',MCHPO2)
  63. CALL LICHTL(MCHPO2,MPOVA2,TYPE,IGEOM)
  64. CALL KRIPAD(MELEMS,MLENT2)
  65. TYPE='SOMMET'
  66. CALL CRCHPT(TYPE,MELEMS,IDIM,MCHPOI)
  67. CALL LICHTM(MCHPOI,MPOVAL,TYPE,IGEOM)
  68.  
  69. TYPE=' '
  70. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  71.  
  72. SEGACT MELEME
  73. NBSOUS=LISOUS(/1)
  74. IF(NBSOUS.EQ.0)NBSOUS=1
  75.  
  76. KK=0
  77. DO 1 L=1,NBSOUS
  78. IPT1=MELEME
  79. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  80. SEGACT IPT1
  81. NP=IPT1.NUM(/1)
  82. NEL=IPT1.NUM(/2)
  83.  
  84. NOM0=NOMS(IPT1.ITYPEL)//' '
  85. CALL KALPBG(NOM0,'FONFORM ',IZFFM)
  86. IF(IZFFM.EQ.0)GO TO 90
  87. SEGACT IZFFM*MOD
  88. IZHR=KZHR(1)
  89. SEGACT IZHR*MOD
  90. NPG=FN(/2)
  91. NES=GR(/1)
  92.  
  93. SEGACT,MCOORD
  94. DO 10 K=1,NEL
  95. KK=KK+1
  96. DO 9 I=1,NP
  97. J=IPT1.NUM(I,K)
  98. DO 12 N=1,IDIM
  99. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  100. 12 CONTINUE
  101. 9 CONTINUE
  102.  
  103. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
  104. * IDIM,NP,NPG,IAXI,AIRE)
  105.  
  106. DO 35 I=1,NP
  107. I2 = MLENT2.LECT(IPT1.NUM(I,K))
  108.  
  109. DO 36 N=1,IDIM
  110. UU=0.D0
  111. DO 37 LG=1,NPG
  112. GNUL=0.D0
  113. DO 38 J=1,NP
  114. J1 = IZIPAD.LECT(IPT1.NUM(J,K))
  115. GNUL = GNUL + MPOVA1.VPOCHA(J1,1)*HR(N,J,LG)
  116. 38 CONTINUE
  117. UU= UU + FN(I,LG)*PGSQ(LG)*GNUL
  118. 37 CONTINUE
  119. VPOCHA(I2,N)=VPOCHA(I2,N)+UU
  120. 36 CONTINUE
  121. 35 CONTINUE
  122.  
  123. 10 CONTINUE
  124.  
  125. 1 CONTINUE
  126. NPT=VPOCHA(/1)
  127. DO 2 I=1,NPT
  128. DO 2 N=1,IDIM
  129. VPOCHA(I,N)=VPOCHA(I,N)/MPOVA2.VPOCHA(I,1)
  130. 2 CONTINUE
  131. C
  132. SEGSUP IZIPAD,IZFFM,IZHR,MLENT2
  133. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  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.  
  153.  
  154.  

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