Télécharger pscala.eso

Retour à la liste

Numérotation des lignes :

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

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