C PROSCA SOURCE CB215821 20/11/25 13:37:31 10792 SUBROUTINE PROSCA(MCHPO1,MCHPO2,MLMOTX,MLMOTY,IRET) C----------------------------------------------------------------------- C PRODUIT SCALAIRE DE 2 CHPOINTS C----------------------------------------------------------------------- C EN STANDARD LE CHPOINT RESULTAT A POUR NUMERO D'HARMONIQUE 0 C EN SERIE DE FOURIER , IL EST TYPE NOHARM C----------------------------------------------------------------------- C ENTREE C IPOI1 CHPOINT C IPOI2 CHPOINT C MLMOTX LISTMOTS DE COMPOSANTES ASSOCIEES AU 1-ER CHPOINT C MLMOTY LISTMOTS DE COMPOSANTES ASSOCIEES AU 2-EME CHPOINT C SORTIE C IRET POINTEUR SUR LE CHPOINT RESULTAT C----------------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMCHPOI -INC SMLMOTS -INC SMELEME -INC SMCOORD -INC TMTRAV CHARACTER*(LOCOMP) NOIN CHARACTER*4 NOMIL integer*4 iomil equivalence (nomil,iomil) DATA NOMIL/'NOHA'/ SEGMENT ITRAV REAL*8 IVAA(NINC,NPOI),IVAB(NINC,NPOI) INTEGER IPOS(NINC),ICPRA(NPOI),ICPRB(NPOI) CHARACTER*(LOCOMP) INCA(NINC),INCB(NINC) ENDSEGMENT NPOI=nbpts MLMOTS=MLMOTX SEGACT MLMOTS NINC= MOTS(/2) SEGINI ITRAV DO 1 I = 1, NINC INCA(I)=MOTS(I) 1 CONTINUE MLMOTS=MLMOTY SEGACT MLMOTS IF(MOTS(/2).NE.NINC) THEN SEGSUP ITRAV MOTERR(1:4)='PSCA' MOTERR(5:12)='LISTMOTS' CALL ERREUR(125) RETURN ENDIF DO 21 I = 1, NINC INCB(I)=MOTS(I) 21 CONTINUE C C ********* IVAA CONTIENDRA LES VALEURS A MULTIPLIER PAR IVAB C ********* CREATION D'ABORD DE IVAA PUIS DE IVAB C MCHPOI=MCHPO1 SEGACT MCHPOI NSOUPO = IPCHP(/1) DO 2 M = 1,NSOUPO MSOUPO = IPCHP(M) SEGACT MSOUPO NC=NOCOMP(/2) DO 10 I = 1,NINC 10 IPOS(I)=0 DO 4 K = 1, NINC DO 3 J = 1, NC NOIN= NOCOMP (J) IF(INCA(K). EQ . NOIN) THEN IPOS(K)=J GO TO 4 ENDIF 3 CONTINUE 4 CONTINUE DO 5 I = 1,NINC IF(IPOS(I). NE . 0) GO TO 6 5 CONTINUE GO TO 8 6 CONTINUE MELEME=IGEOC SEGACT MELEME NBELEM=NUM(/2) MPOVAL=IPOVAL SEGACT MPOVAL DO 9 LI = 1,NINC KL = IPOS(LI) IF(KL.EQ.0) GO TO 9 DO 7 I = 1,NBELEM I1 = NUM(1,I) IVAA(LI,I1)=VPOCHA(I,KL) ICPRA(I1)=1 7 CONTINUE 9 CONTINUE 8 CONTINUE 2 CONTINUE C C TRAITEMENT DU 2-EME CHPOINT C IA=0 MCHPOI=MCHPO2 SEGACT MCHPOI NSOUPO = IPCHP(/1) DO 12 M = 1,NSOUPO MSOUPO = IPCHP(M) SEGACT MSOUPO NC=NOCOMP(/2) DO 11 I = 1,NINC 11 IPOS(I)=0 DO 14 K= 1,NINC DO 13 J = 1, NC NOIN= NOCOMP (J) IF(INCB(K). EQ . NOIN) THEN IPOS(K)=J GO TO 14 ENDIF 13 CONTINUE 14 CONTINUE DO 15 I = 1,NINC IF(IPOS(I). NE . 0) GO TO 16 15 CONTINUE GO TO 18 16 CONTINUE MELEME=IGEOC SEGACT MELEME NBELEM=NUM(/2) MPOVAL=IPOVAL SEGACT MPOVAL DO 19 LI = 1,NINC KL = IPOS(LI) IF(KL.EQ.0) GO TO 19 DO 17 I = 1,NBELEM I1 = NUM(1,I) IVAB(LI,I1)=VPOCHA(I,KL) IF(ICPRA(I1).NE.0) THEN IA=IA+1 ICPRB(I1)=IA ENDIF 17 CONTINUE 19 CONTINUE 18 CONTINUE 12 CONTINUE IF(IA.EQ.0) THEN C C CHPOINT VIDE C SEGSUP ITRAV NSOUPO=0 NAT=1 SEGINI MCHPOI IFOPOI=IFOUR IRET=MCHPOI RETURN ENDIF C C ON EFFECTUE LE CALCUL C NNIN=1 NNNOE=IA SEGINI MTRAV INCO(1)='SCAL' * * MODIF MILL LE 18 / 7 / 90 * REMPLISSAGE DE L'HARMONIQUE : NOHARM SI FOURIER , 0 SINON * NHMIL=iomil IF(IFOPOI.EQ.1) THEN NHAR(1)=NHMIL ELSE NHAR(1)=0 ENDIF * MCHPOI=MCHPO1 SEGACT MCHPOI NSOUPO=IPCHP(/1) DO 22 M=1,NSOUPO MSOUPO=IPCHP(M) SEGACT MSOUPO MELEME=IGEOC SEGACT MELEME DO 27 J=1,NUM(/2) I1=NUM(1,J) IB=ICPRB(I1) IF(IB.EQ.0) GO TO 27 IF(IGEO(IB).NE.0) GO TO 27 IGEO(IB)=I1 IBIN(1,IB)=1 DO 28 LI=1,NINC BB(1,IB)=BB(1,IB)+IVAA(LI,I1)*IVAB(LI,I1) 28 CONTINUE 27 CONTINUE 22 CONTINUE SEGSUP ITRAV CALL CRECHP(MTRAV,IRET) SEGSUP MTRAV END