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 13 : CALL LIROBJ('POINT ',IP1,0,IRETOU) 14 : IF(IRETOU.EQ.0) GO TO 10 15 : C 16 : C CAS DE DEUX VECTEURS 17 : C 17 : CALL LIROBJ('POINT ',IP2,1,IRETOU) 18 : IF (IERR.NE.0) RETURN 19 : SEGACT MCOORD 20 : IREF1=(IDIM+1)*(IP1-1) 21 : IREF2=(IDIM+1)*(IP2-1) 22 : SCAL=0.D0 23 : DO 1 I=1,IDIM 24 : SCAL=SCAL+XCOOR(IREF1+I)*XCOOR(IREF2+I) 25 : 1 CONTINUE 25 : CALL ECRREE(SCAL) 26 : RETURN 27 : C 28 : C CAS DE DEUX CHPOINTS 29 : C 30 : 10 CONTINUE 30 : CALL LIROBJ('CHPOINT ',MCHPO1,0,IRETOU) 31 : IF(IRETOU.EQ.0) GOTO 20 31 : CALL LIROBJ('CHPOINT ',MCHPO2,1,IRETOU) 31 : CALL LIROBJ('LISTMOTS',MLMOTX,1,IRETOU) 31 : CALL LIROBJ('LISTMOTS',MLMOTY,1,IRETOU) 32 : IF(IERR.NE.0) RETURN 32 : CALL PROSCA(MCHPO1,MCHPO2,MLMOTX,MLMOTY,IRET) 32 : CALL ECROBJ('CHPOINT ',IRET) 33 : RETURN 34 : 20 CONTINUE 35 : C 36 : C CAS DE DEUX CHAMELEMS 37 : C 37 : CALL LIROBJ('MCHAML ',IPCHE1,0,IRETOU) 38 : IF(IRETOU.EQ.0) GOTO 30 38 : CALL LIROBJ('MCHAML ',IPCHE2,1,IRETOU) 38 : CALL LIROBJ('LISTMOTS',MLMOTX,1,IRETOU) 38 : CALL LIROBJ('LISTMOTS',MLMOTY,1,IRETOU) 39 : IF(IERR.NE.0) RETURN 39 : CALL SCACHA(IPCHE1,IPCHE2,MLMOTX,MLMOTY,IRET) 39 : CALL ECROBJ('MCHAML',IRET) 40 : RETURN 41 : 30 CONTINUE 41 : CALL LIRTAB('VECTEUR',MTAB1,0,IRETOU) 42 : IF(IRETOU.EQ.0) GO TO 40 42 : CALL LIRTAB('VECTEUR',MTAB2,1,IRETOU) 43 : IF(IERR.NE.0) RETURN 44 : * ON FAIT LE PRODUIT SCALAIRE DE TOUS LES REELS ISOINDICES 45 : SEGACT MTAB1,MTAB2 46 : SCAL=0.D0 47 : DO 100 I=1,MTAB1.MLOTAB 48 : CAUX1=MTAB1.MTABTV(I) 49 : IAUX1=MTAB1.MTABIV(I) 50 : XAUX1=MTAB1.RMTABV(I) 51 : CAUX2=MTAB1.MTABTI(I) 52 : IAUX2=MTAB1.MTABII(I) 53 : XAUX2=MTAB1.RMTABI(I) 54 : IF (CAUX1.EQ.'FLOTTANT') THEN 55 : VAL1=XAUX1 56 : ELSEIF (CAUX1.EQ.'ENTIER ') THEN 57 : VAL1=IAUX1 58 : ELSE 59 : GOTO 100 60 : ENDIF 61 : DO 110 J=1,MTAB2.MLOTAB 62 : IF (MTAB2.MTABTI(J).NE.CAUX2) GOTO 110 63 : IF (CAUX2.EQ.'FLOTTANT') THEN 64 : IF (MTAB2.RMTABI(J).NE.XAUX2) GOTO 110 65 : ELSE 66 : IF (MTAB2.MTABII(J).NE.IAUX2) GOTO 110 67 : ENDIF 68 : IF (MTAB2.MTABTV(J).EQ.'FLOTTANT') THEN 69 : VAL2=MTAB2.RMTABV(J) 70 : ELSEIF (MTAB2.MTABTV(J).EQ.'ENTIER ') THEN 71 : VAL2=MTAB2.MTABIV(J) 72 : ELSE 73 : GOTO 100 74 : ENDIF 75 : SCAL=SCAL+VAL1*VAL2 76 : 110 CONTINUE 77 : 100 CONTINUE 77 : CALL ECRREE(SCAL) 78 : SEGDES MTAB1,MTAB2 79 : RETURN 80 : 81 : 82 : C PAS D OPERANDE CORRECTE TROUVE 83 : C 83 : 40 CALL QUETYP(MOTERR(1:8),0,IRETOU) 84 : IF(IRETOU.NE.0) THEN 84 : CALL ERREUR (39) 85 : ELSE 85 : CALL ERREUR(533) 86 : ENDIF 87 : RETURN 88 : END 89 : 90 :
© Cast3M 2003 - All rights reserved.
Disclaimer