Télécharger krot.eso

Retour à la liste

Numérotation des lignes :

  1. C KROT SOURCE MAGN 17/02/24 21:15:19 9323
  2. SUBROUTINE KROT(MCHPO1,MPOVA1,IGEOM1,MTABD)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C Operateur KROT
  7. C
  8. C Objet : determine le ROTATIONNEL d'un CHAMPOINT VECT SOMMET
  9. C
  10. C SYNTAXE : CHGR =KOPS CHPS 'ROT' 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. C Correction FD : Le signe est faux en repère cartésien
  17. C Ajout dans GIBI.ERREUR des messages 980 et 981
  18. C
  19. -INC SMTABLE
  20. POINTEUR MTABD.MTABLE
  21. -INC SMELEME
  22. POINTEUR MELEMS.MELEME,MELEMC.MELEME,IGEOM1.MELEME
  23. -INC CCOPTIO
  24. -INC SMCOORD
  25. -INC CCGEOME
  26. -INC SMCHPOI
  27. POINTEUR IZB.MCHPOI,IZBB.MPOVAL
  28. POINTEUR IZD.MCHPOI,IZDD.MPOVAL
  29. POINTEUR IZV.MCHPOI,IZVV.MPOVAL
  30. -INC SMLENTI
  31. POINTEUR IZIPAD.MLENTI
  32. -INC SIZFFB
  33. REAL*8 HRT(24),RPGJ(9),XYZI(8)
  34. CHARACTER*8 TYPE,TYPC,NOM0
  35. C***
  36. IAXI=0
  37. IF(IFOMOD.EQ.0)IAXI=2
  38.  
  39. NC=MPOVA1.VPOCHA(/2)
  40. NPT=MPOVA1.VPOCHA(/1)
  41. IF(NC.NE.IDIM)THEN
  42. C% L'objet %m1:8 n'a pas le bon nombre de composantes
  43. MOTERR(1: 8) = 'CHPOINT '
  44. CALL ERREUR(980)
  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% L'object %m1:8 n'a pas le bon support géométrique
  55. MOTERR(1: 8) = 'CHPOINT '
  56. CALL ERREUR(981)
  57. RETURN
  58. ENDIF
  59.  
  60. TYPE=' '
  61. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  62. TYPE='CENTRE'
  63. NC=IDIM
  64. IF(IDIM.EQ.2)NC=1
  65. CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI)
  66. CALL LICHTM(MCHPOI,MPOVAL,TYPE,IGEOM)
  67.  
  68. TYPE=' '
  69. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  70.  
  71. SEGACT MELEME
  72. NBSOUS=LISOUS(/1)
  73. IF(NBSOUS.EQ.0)NBSOUS=1
  74.  
  75. KK=0
  76. DO 1 L=1,NBSOUS
  77. IPT1=MELEME
  78. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  79. SEGACT IPT1
  80. NP=IPT1.NUM(/1)
  81. NEL=IPT1.NUM(/2)
  82.  
  83. NOM0=NOMS(IPT1.ITYPEL)//' '
  84. CALL KALPBG(NOM0,'FONFORM0',IZFFM)
  85. IF(IZFFM.EQ.0)GO TO 90
  86. SEGACT IZFFM*MOD
  87. IZHR=KZHR(1)
  88. SEGACT IZHR*MOD
  89. NPG=FN(/2)
  90. NES=GR(/1)
  91.  
  92. DO 10 K=1,NEL
  93. KK=KK+1
  94. DO 9 I=1,NP
  95. J=IPT1.NUM(I,K)
  96. DO 12 N=1,IDIM
  97. XYZ(N,I)=XCOOR((J-1)*(IDIM+1) +N)
  98. 12 CONTINUE
  99. 9 CONTINUE
  100.  
  101. CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,
  102. *IDIM,NP,NPG,IAXI,AIRE)
  103.  
  104. IF(IDIM.EQ.2)THEN
  105. UU=0.D0
  106. DO 35 I=1,NP
  107. IU = IZIPAD.LECT(IPT1.NUM(I,K))
  108. UU = UU - ( MPOVA1.VPOCHA(IU,1)*HR(2,I,1) -
  109. & MPOVA1.VPOCHA(IU,2)*HR(1,I,1) )
  110. 35 CONTINUE
  111. IF (IAXI.EQ.0) THEN
  112. VPOCHA(KK,1)= UU
  113. ELSE
  114. VPOCHA(KK,1)=-UU
  115. ENDIF
  116. ELSE
  117. UX=0.D0
  118. UY=0.D0
  119. UZ=0.D0
  120. DO 36 I=1,NP
  121. IU = IZIPAD.LECT(IPT1.NUM(I,K))
  122. UX= UX - ( MPOVA1.VPOCHA(IU,2)*HR(3,I,1) -
  123. & MPOVA1.VPOCHA(IU,3)*HR(2,I,1) )
  124. UY= UY - ( MPOVA1.VPOCHA(IU,3)*HR(1,I,1) -
  125. & MPOVA1.VPOCHA(IU,1)*HR(3,I,1) )
  126. UZ= UZ - ( MPOVA1.VPOCHA(IU,1)*HR(2,I,1) -
  127. & MPOVA1.VPOCHA(IU,2)*HR(1,I,1) )
  128. 36 CONTINUE
  129. VPOCHA(KK,1)=UX
  130. VPOCHA(KK,2)=UY
  131. VPOCHA(KK,3)=UZ
  132. ENDIF
  133.  
  134. 10 CONTINUE
  135. SEGDES IPT1
  136. 1 CONTINUE
  137. SEGDES MPOVA1,MPOVAL
  138. SEGDES MCHPO1,MCHPOI
  139. SEGDES MELEME,IGEOM1,MELEMS
  140. C
  141. SEGSUP IZIPAD,IZFFM,IZHR
  142. CALL ECROBJ('CHPOINT ',MCHPOI)
  143.  
  144. RETURN
  145.  
  146. 90 CONTINUE
  147. WRITE(IOIMP,*)'Interruption anormale de KOPS option GRAD '
  148. CALL ERREUR(5)
  149. RETURN
  150.  
  151. 1001 FORMAT(20(1X,I5))
  152. 1008 FORMAT(10(1X,A8))
  153. 1002 FORMAT(10(1X,1PE11.4))
  154. END
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  

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