Télécharger pvect.eso

Retour à la liste

Numérotation des lignes :

  1. C PVECT SOURCE CB215821 19/07/31 21:17:18 10277
  2. C CALCULE LE PRODUIT VECTORIEL DE (IDIM-1) VECTEURS
  3. C
  4. SUBROUTINE PVECT
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT real*8 (a-h,o-z)
  7. -INC CCOPTIO
  8. -INC CCGEOME
  9. -INC SMCOORD
  10. C
  11. IF (IDIM.NE.2.AND.IDIM.NE.3) THEN
  12. C 709 2
  13. C Fonction indisponible en dimension %i1.
  14. INTERR(1)=IDIM
  15. CALL ERREUR(709)
  16. RETURN
  17. ENDIF
  18. C
  19. CALL LIROBJ('POINT ',IP1,0,IRETOU)
  20. IF(IRETOU.EQ.0) GO TO 30
  21. C
  22. C CAS DES VECTEURS
  23. C
  24. SEGACT MCOORD
  25. IREF1=(IDIM+1)*(IP1-1)
  26. X1=XCOOR(IREF1+1)
  27. Y1=XCOOR(IREF1+2)
  28. IF (IDIM.EQ.3) GOTO 10
  29. NBPTS=XCOOR(/1)/3+1
  30. SEGADJ MCOORD
  31. XCOOR((NBPTS-1)*3+1)=-Y1
  32. XCOOR((NBPTS-1)*3+2)=X1
  33. XCOOR((NBPTS-1)*3+3)=DENSIT
  34. GOTO 20
  35. 10 CALL LIROBJ('POINT ',IP2,1,IRETOU)
  36. IF (IERR.NE.0) RETURN
  37. IREF2=(IDIM+1)*(IP2-1)
  38. Z1=XCOOR(IREF1+3)
  39. X2=XCOOR(IREF2+1)
  40. Y2=XCOOR(IREF2+2)
  41. Z2=XCOOR(IREF2+3)
  42. NBPTS=XCOOR(/1)/4+1
  43. SEGADJ MCOORD
  44. XCOOR((NBPTS-1)*4+1)=Y1*Z2-Z1*Y2
  45. XCOOR((NBPTS-1)*4+2)=Z1*X2-X1*Z2
  46. XCOOR((NBPTS-1)*4+3)=X1*Y2-Y1*X2
  47. XCOOR((NBPTS-1)*4+4)=DENSIT
  48. 20 CONTINUE
  49. IR=NBPTS
  50. CALL ECROBJ('POINT ',IR)
  51. RETURN
  52. C
  53. C CAS DES CHPOINTS
  54. C
  55. 30 CONTINUE
  56. CALL LIROBJ('CHPOINT ',MCHPO1,1,IRETOU)
  57. CALL ACTOBJ('CHPOINT ',MCHPO1,1)
  58. IF (IERR.NE.0) RETURN
  59. CALL LIROBJ('LISTMOTS',MLMOT1,1,IRETOU)
  60. IF (IERR.NE.0) RETURN
  61. IF (IDIM.EQ.3) THEN
  62. CALL LIROBJ('CHPOINT ',MCHPO2,1,IRETOU)
  63. CALL ACTOBJ('CHPOINT ',MCHPO2,1)
  64. IF (IERR.NE.0) RETURN
  65. CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
  66. IF (IERR.NE.0) RETURN
  67. ENDIF
  68. CALL LIROBJ('LISTMOTS',MLMOT3,1,IRETOU)
  69. IF (IERR.NE.0) RETURN
  70. CALL PROVCC(MCHPO1,MCHPO2,MLMOT1,MLMOT2,MLMOT3,MCHPO3)
  71. IF (IERR.NE.0) RETURN
  72. CALL ACTOBJ('CHPOINT ',MCHPO3,1)
  73. CALL ECROBJ('CHPOINT ',MCHPO3)
  74. END
  75.  
  76.  
  77.  

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