Télécharger krot.eso

Retour à la liste

Numérotation des lignes :

  1. C KROT SOURCE CB215821 19/08/20 21:18:59 10287
  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.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC SMCOORD
  27. -INC CCGEOME
  28. -INC SMCHPOI
  29. POINTEUR IZB.MCHPOI,IZBB.MPOVAL
  30. POINTEUR IZD.MCHPOI,IZDD.MPOVAL
  31. POINTEUR IZV.MCHPOI,IZVV.MPOVAL
  32. -INC SMLENTI
  33. POINTEUR IZIPAD.MLENTI
  34. -INC SIZFFB
  35. REAL*8 HRT(24),RPGJ(9),XYZI(8)
  36. CHARACTER*8 TYPE,TYPC,NOM0
  37. C***
  38. IAXI=0
  39. IF(IFOMOD.EQ.0)IAXI=2
  40.  
  41. NC=MPOVA1.VPOCHA(/2)
  42. NPT=MPOVA1.VPOCHA(/1)
  43. IF(NC.NE.IDIM)THEN
  44. C% L'objet %m1:8 n'a pas le bon nombre de composantes
  45. MOTERR(1: 8) = 'CHPOINT '
  46. CALL ERREUR(980)
  47. RETURN
  48. ENDIF
  49.  
  50. TYPE=' '
  51. CALL ACMO(MTABD,'SOMMET',TYPE,MELEMS)
  52.  
  53. CALL KRIPAD(IGEOM1,IZIPAD)
  54. CALL VERPAD(IZIPAD,MELEMS,IRET)
  55. IF(IRET.NE.0)THEN
  56. C% L'object %m1:8 n'a pas le bon support géométrique
  57. MOTERR(1: 8) = 'CHPOINT '
  58. CALL ERREUR(981)
  59. RETURN
  60. ENDIF
  61.  
  62. TYPE=' '
  63. CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
  64. TYPE='CENTRE'
  65. NC=IDIM
  66. IF(IDIM.EQ.2)NC=1
  67. CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI)
  68. CALL LICHTM(MCHPOI,MPOVAL,TYPE,IGEOM)
  69.  
  70. TYPE=' '
  71. CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME)
  72.  
  73. SEGACT MELEME
  74. NBSOUS=LISOUS(/1)
  75. IF(NBSOUS.EQ.0)NBSOUS=1
  76.  
  77. KK=0
  78. DO 1 L=1,NBSOUS
  79. IPT1=MELEME
  80. IF(NBSOUS.NE.1)IPT1=LISOUS(L)
  81. SEGACT IPT1
  82. NP=IPT1.NUM(/1)
  83. NEL=IPT1.NUM(/2)
  84.  
  85. NOM0=NOMS(IPT1.ITYPEL)//' '
  86. CALL KALPBG(NOM0,'FONFORM0',IZFFM)
  87. IF(IZFFM.EQ.0)GO TO 90
  88. SEGACT IZFFM*MOD
  89. IZHR=KZHR(1)
  90. SEGACT IZHR*MOD
  91. NPG=FN(/2)
  92. NES=GR(/1)
  93.  
  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. IF(IDIM.EQ.2)THEN
  107. UU=0.D0
  108. DO 35 I=1,NP
  109. IU = IZIPAD.LECT(IPT1.NUM(I,K))
  110. UU = UU - ( MPOVA1.VPOCHA(IU,1)*HR(2,I,1) -
  111. & MPOVA1.VPOCHA(IU,2)*HR(1,I,1) )
  112. 35 CONTINUE
  113. IF (IAXI.EQ.0) THEN
  114. VPOCHA(KK,1)= UU
  115. ELSE
  116. VPOCHA(KK,1)=-UU
  117. ENDIF
  118. ELSE
  119. UX=0.D0
  120. UY=0.D0
  121. UZ=0.D0
  122. DO 36 I=1,NP
  123. IU = IZIPAD.LECT(IPT1.NUM(I,K))
  124. UX= UX - ( MPOVA1.VPOCHA(IU,2)*HR(3,I,1) -
  125. & MPOVA1.VPOCHA(IU,3)*HR(2,I,1) )
  126. UY= UY - ( MPOVA1.VPOCHA(IU,3)*HR(1,I,1) -
  127. & MPOVA1.VPOCHA(IU,1)*HR(3,I,1) )
  128. UZ= UZ - ( MPOVA1.VPOCHA(IU,1)*HR(2,I,1) -
  129. & MPOVA1.VPOCHA(IU,2)*HR(1,I,1) )
  130. 36 CONTINUE
  131. VPOCHA(KK,1)=UX
  132. VPOCHA(KK,2)=UY
  133. VPOCHA(KK,3)=UZ
  134. ENDIF
  135.  
  136. 10 CONTINUE
  137. 1 CONTINUE
  138. C
  139. SEGSUP IZIPAD,IZFFM,IZHR
  140. CALL ACTOBJ('CHPOINT ',MCHPOI,1)
  141. CALL ECROBJ('CHPOINT ',MCHPOI)
  142.  
  143. RETURN
  144.  
  145. 90 CONTINUE
  146. WRITE(IOIMP,*)'Interruption anormale de KOPS option GRAD '
  147. CALL ERREUR(5)
  148. RETURN
  149.  
  150. 1001 FORMAT(20(1X,I5))
  151. 1008 FORMAT(10(1X,A8))
  152. 1002 FORMAT(10(1X,1PE11.4))
  153. END
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  

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