Télécharger la plaquette Cast3M


fr en

Télécharger pvect.eso

Retour à la liste

Numérotation des lignes : 

pvect

  1. C PVECT     SOURCE    PV        20/03/24    21:21:06     10554          
  2. C=======================================================================
  3. C
  4. C   CALCULE LE PRODUIT VECTORIEL DE n-1 : - POINTS 
  5. C                                         - CHPOINTS
  6. C                                         - CHAMELEMS
  7. c   avec n : dimension (2D/3D)
  8. C
  9. C   REM : pour les CHPOINT et CHAMELEM, il faut fournir le nom 
  10. C         des n composantes !
  11. C
  12. C=======================================================================
  13. C
  14.       SUBROUTINE PVECT
  15.       IMPLICIT INTEGER(I-N)
  16.       IMPLICIT REAL*8 (A-H,O-Z)
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC CCGEOME
  21. -INC SMCOORD
  22. C
  23. C     erreur : Fonction indisponible en dimension %i1.
  24.       IF (IDIM.NE.2.AND.IDIM.NE.3) THEN
  25.          INTERR(1)=IDIM
  26.          CALL ERREUR(709)
  27.          RETURN
  28.       ENDIF
  29. C
  30. c     Lecture d'1 point ?
  31.       CALL LIROBJ('POINT ',IP1,0,IRETOU)
  32.       IF(IRETOU.EQ.0) GO TO 10
  33. C
  34. C=======================================================================
  35. C     CAS DE 1 POINT (en 2D) ou 2 POINTS (3D)
  36. C=======================================================================
  37. C
  38.       SEGACT MCOORD*mod
  39.       IREF1=(IDIM+1)*(IP1-1)
  40.       X1=XCOOR(IREF1+1)
  41.       Y1=XCOOR(IREF1+2)
  42.       IF (IDIM.EQ.2) THEN
  43. c       2D : 1 POINT (implicitement on calcule le prod vect avec Z)
  44.         NBPTS=nbpts+1
  45.         SEGADJ MCOORD
  46.         XCOOR((NBPTS-1)*3+1)=-Y1
  47.         XCOOR((NBPTS-1)*3+2)=X1
  48.         XCOOR((NBPTS-1)*3+3)=DENSIT
  49.       ELSE
  50. c       3D : 2 POINTS
  51.         CALL LIROBJ('POINT ',IP2,1,IRETOU)
  52.         IF (IERR.NE.0) RETURN
  53.         IREF2=(IDIM+1)*(IP2-1)
  54.         Z1=XCOOR(IREF1+3)
  55.         X2=XCOOR(IREF2+1)
  56.         Y2=XCOOR(IREF2+2)
  57.         Z2=XCOOR(IREF2+3)
  58.         NBPTS=nbpts+1
  59.         SEGADJ MCOORD
  60.         XCOOR((NBPTS-1)*4+1)=Y1*Z2-Z1*Y2
  61.         XCOOR((NBPTS-1)*4+2)=Z1*X2-X1*Z2
  62.         XCOOR((NBPTS-1)*4+3)=X1*Y2-Y1*X2
  63.         XCOOR((NBPTS-1)*4+4)=DENSIT
  64.       ENDIF
  65.       IR=NBPTS
  66.       CALL ECROBJ('POINT ',IR)
  67.       RETURN
  68. C
  69. C=======================================================================
  70. C     CAS CHPOINT
  71. C=======================================================================
  72. C
  73.  10   CONTINUE
  74.       CALL LIROBJ('CHPOINT ',MCHPO1,0,IRETOU)
  75.       IF(IRETOU.EQ.0) GOTO 20
  76.       CALL ACTOBJ('CHPOINT ',MCHPO1,1)
  77.       IF (IERR.NE.0) RETURN
  78.       CALL LIROBJ('LISTMOTS',MLMOT1,1,IRETOU)
  79.       IF (IERR.NE.0) RETURN
  80.       IF (IDIM.EQ.3) THEN
  81.          CALL LIROBJ('CHPOINT ',MCHPO2,1,IRETOU)
  82.          CALL ACTOBJ('CHPOINT ',MCHPO2,1)
  83.          IF (IERR.NE.0) RETURN
  84.          CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
  85.          CALL ACTOBJ('LISTMOTS',MLMOT2,1)
  86.          IF (IERR.NE.0) RETURN
  87.       ELSE
  88.         MCHPO2=0
  89.         MLMOT2=0
  90.       ENDIF
  91.       CALL LIROBJ('LISTMOTS',MLMOT3,1,IRETOU)
  92.       IF (IERR.NE.0) RETURN
  93.       CALL PROVCC(MCHPO1,MCHPO2,MLMOT1,MLMOT2,MLMOT3,MCHPO3)
  94.       IF (IERR.NE.0) RETURN
  95.       CALL ACTOBJ('CHPOINT ',MCHPO3,1)
  96.       CALL ECROBJ('CHPOINT ',MCHPO3)
  97.       RETURN
  98.  
  99.   20  CONTINUE
  100. C
  101. C=======================================================================
  102. C     CAS CHAMELEM
  103. C=======================================================================
  104. C
  105.       CALL LIROBJ('MCHAML  ',IPCHE1,0,IRETOU)
  106.       IF(IRETOU.EQ.0) GOTO 99
  107.       CALL ACTOBJ('MCHAML  ',IPCHE1,1)
  108.       CALL LIROBJ('LISTMOTS',MLMOT1,1,IRETOU)
  109.       CALL ACTOBJ('LISTMOTS',MLMOT1,1)
  110.       IF (IERR.NE.0) RETURN
  111. c     cas 2D
  112.       IF (IDIM.EQ.2) THEN   
  113.         CALL LIROBJ('LISTMOTS',MLMOT3,1,IRETOU)
  114.         CALL ACTOBJ('LISTMOTS',MLMOT3,1)
  115.         IF(IERR.NE.0) RETURN
  116. c         write(*,*) 'appel a PROVC2',IPCHE1,MLMOT1,MLMOT3
  117.         CALL PROVC2(IPCHE1,MLMOT1,MLMOT3,IPCHE3)
  118. c     cas 3D
  119.       ELSE
  120.         CALL LIROBJ('MCHAML  ',IPCHE2,1,IRETOU)
  121.         CALL ACTOBJ('MCHAML  ',IPCHE2,1)
  122.         IF(IERR.NE.0) RETURN
  123.         CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
  124.         CALL ACTOBJ('LISTMOTS',MLMOT2,1)
  125.         IF(IERR.NE.0) RETURN
  126.         CALL LIROBJ('LISTMOTS',MLMOT3,1,IRETOU)
  127.         CALL ACTOBJ('LISTMOTS',MLMOT3,1)
  128.         IF(IERR.NE.0) RETURN
  129. c         write(*,*) 'appel a PROVC3',IPCHE1,IPCHE2,MLMOT1,MLMOT2,MLMOT3
  130.         CALL PROVC3(IPCHE1,IPCHE2,MLMOT1,MLMOT2,MLMOT3,IPCHE3)
  131.       ENDIF
  132. c       write(*,*) 'PVECT: on va ecrire',IPCHE3
  133.       CALL ACTOBJ('MCHAML  ',IPCHE3,1)
  134.       CALL ECROBJ('MCHAML  ',IPCHE3)
  135.       RETURN
  136.  
  137.  
  138. C=======================================================================
  139. C    PAS D OPERANDE CORRECTE TROUVE
  140. C=======================================================================
  141. C
  142.  99   CALL QUETYP(MOTERR(1:8),0,IRETOU)
  143.       IF(IRETOU.NE.0) THEN
  144.          CALL ERREUR (39)
  145.       ELSE
  146.          CALL ERREUR(533)
  147.       ENDIF
  148.  
  149.       END
  150.  
  151.  
  152.  
  153.  
  154.  

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