Télécharger la plaquette Cast3M


fr en

Télécharger pscala.eso

Retour à la liste

Numérotation des lignes : 

pscala

  1. C PSCALA    SOURCE    BP208322  20/02/24    21:15:06     10530          
  2. C=======================================================================
  3. C
  4. C   CALCULE LE PRODUIT SCALAIRE DE 2 : - VECTEURS
  5. C                                      - CHPOINTS
  6. C                                      - CHAMELEMS
  7. C                                      - TABLES DE SOUS-TYPE VECTEUR
  8. C
  9. C=======================================================================
  10.  
  11.       SUBROUTINE PSCALA
  12.       IMPLICIT INTEGER(I-N)
  13.       IMPLICIT REAL*8 (A-H,O-Z)
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC SMCOORD
  18. -INC SMTABLE
  19.       CHARACTER*8 CAUX1,CAUX2
  20.  
  21. c     Lecture d'1 point ?
  22.       CALL LIROBJ('POINT ',IP1,0,IRETOU)
  23.       IF(IRETOU.EQ.0) GO TO 10
  24. C
  25. C=======================================================================
  26. C     CAS DE 2 POINTS           
  27. C=======================================================================
  28. C
  29.       CALL LIROBJ('POINT ',IP2,1,IRETOU)
  30.       IF (IERR.NE.0) RETURN
  31.       SEGACT MCOORD
  32.       IREF1=(IDIM+1)*(IP1-1)
  33.       IREF2=(IDIM+1)*(IP2-1)
  34.       SCAL=0.D0
  35.       DO 1 I=1,IDIM
  36.       SCAL=SCAL+XCOOR(IREF1+I)*XCOOR(IREF2+I)
  37.    1  CONTINUE
  38.       CALL ECRREE(SCAL)
  39.       RETURN
  40. C
  41. C=======================================================================
  42. C     CAS DE 2 CHPOINTS
  43. C=======================================================================
  44. C
  45.   10  CONTINUE
  46.       CALL LIROBJ('CHPOINT ',MCHPO1,0,IRETOU)
  47.       IF(IRETOU.EQ.0) GOTO 20
  48.       CALL LIROBJ('CHPOINT ',MCHPO2,1,IRETOU)
  49.       CALL LIROBJ('LISTMOTS',MLMOTX,1,IRETOU)
  50.       CALL LIROBJ('LISTMOTS',MLMOTY,1,IRETOU)
  51.       IF(IERR.NE.0) RETURN
  52.       CALL PROSCA(MCHPO1,MCHPO2,MLMOTX,MLMOTY,IRET)
  53.       CALL ACTOBJ('CHPOINT ',IRET,1)
  54.       CALL ECROBJ('CHPOINT ',IRET)
  55.       RETURN
  56.  
  57. C=======================================================================
  58. C     CAS DE 2 CHAMELEMS
  59. C=======================================================================
  60. C
  61.   20  CONTINUE
  62.       CALL LIROBJ('MCHAML  ',IPCHE1,0,IRETOU)
  63.       IF(IRETOU.EQ.0) GOTO 30
  64.       CALL LIROBJ('MCHAML  ',IPCHE2,1,IRETOU)
  65.       CALL LIROBJ('LISTMOTS',MLMOTX,1,IRETOU)
  66.       CALL LIROBJ('LISTMOTS',MLMOTY,1,IRETOU)
  67.       IF(IERR.NE.0) RETURN
  68.       CALL SCACHA(IPCHE1,IPCHE2,MLMOTX,MLMOTY,IRET)
  69.       CALL ACTOBJ('MCHAML  ',IRET,1)
  70.       CALL ECROBJ('MCHAML  ',IRET)
  71.       RETURN
  72.  
  73. C=======================================================================
  74. C     CAS DE 2 TABLES 'VECTEURS'
  75. C=======================================================================
  76. c BP,TODO : cas a documenter ou table vecteur a remplacer par listreel 
  77. C
  78.  30   CONTINUE
  79.       CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU)
  80.       IF(IRETOU.EQ.0) GO TO 99
  81.       CALL LIRTAB('VECTEUR',MTAB2,1,IRETOU)
  82.       IF(IERR.NE.0) RETURN
  83. *  ON FAIT LE PRODUIT SCALAIRE DE TOUS LES REELS ISOINDICES
  84.       SEGACT MTAB1,MTAB2
  85.       SCAL=0.D0
  86.       DO 100 I=1,MTAB1.MLOTAB
  87.        CAUX1=MTAB1.MTABTV(I)
  88.        IAUX1=MTAB1.MTABIV(I)
  89.        XAUX1=MTAB1.RMTABV(I)
  90.        CAUX2=MTAB1.MTABTI(I)
  91.        IAUX2=MTAB1.MTABII(I)
  92.        XAUX2=MTAB1.RMTABI(I)
  93.        IF (CAUX1.EQ.'FLOTTANT') THEN
  94.         VAL1=XAUX1
  95.        ELSEIF (CAUX1.EQ.'ENTIER  ') THEN
  96.         VAL1=IAUX1
  97.        ELSE
  98.         GOTO 100
  99.        ENDIF
  100.        DO 110 J=1,MTAB2.MLOTAB
  101.         IF (MTAB2.MTABTI(J).NE.CAUX2) GOTO 110
  102.         IF (CAUX2.EQ.'FLOTTANT') THEN
  103.           IF (MTAB2.RMTABI(J).NE.XAUX2) GOTO 110
  104.         ELSE
  105.           IF (MTAB2.MTABII(J).NE.IAUX2) GOTO 110
  106.         ENDIF
  107.         IF (MTAB2.MTABTV(J).EQ.'FLOTTANT') THEN
  108.          VAL2=MTAB2.RMTABV(J)
  109.         ELSEIF (MTAB2.MTABTV(J).EQ.'ENTIER  ') THEN
  110.          VAL2=MTAB2.MTABIV(J)
  111.         ELSE
  112.          GOTO 100
  113.         ENDIF
  114.         SCAL=SCAL+VAL1*VAL2
  115.  110   CONTINUE
  116.  100  CONTINUE
  117.       CALL ECRREE(SCAL)
  118.       SEGDES MTAB1,MTAB2
  119.       RETURN
  120.  
  121. C=======================================================================
  122. C    PAS D OPERANDE CORRECTE TROUVE
  123. C=======================================================================
  124. C
  125.  99   CALL QUETYP(MOTERR(1:8),0,IRETOU)
  126.       IF(IRETOU.NE.0) THEN
  127.          CALL ERREUR (39)
  128.       ELSE
  129.          CALL ERREUR(533)
  130.       ENDIF
  131.  
  132.       END
  133.  
  134.  
  135.  
  136.  

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