C SCACHA SOURCE BP208322 09/09/25 21:15:37 6513 SUBROUTINE SCACHA(IPCHE1,IPCHE2,MLMOTX,MLMOTY,IRET) ********************************************************************* * PRODUIT SCALAIRE DE 2 CHAMELEMS ********************************************************************* IMPLICIT INTEGER(I-N) * IMPLICIT REAL*8(A-H,O-Z) C-------------------------------------------------------------------- C ENTREE C IPCHE1 CHAMELEM C IPCHE2 CHAMELEM C MLMOTX LISTMOTS DE COMPOSANTES ASSOCIEES AU 1-ER CHAMP C MLMOTY LISTMOTS DE COMPOSANTES ASSOCIEES AU 2-EME CHAMP C SORTIE C IRET POINTEUR SUR LE MCHAML RESULTAT C-------------------------------------------------------------------- -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMELEME -INC SMLMOTS C CHARACTER*8 NOIN SEGMENT ITRAV CHARACTER*8 INCA(NINC),INCB(NINC) ENDSEGMENT C IRET=0 MCHAML=0 C C travail sur les listmots MLMOTS=MLMOTX SEGACT MLMOTS NINC= MOTS(/2) SEGINI ITRAV DO 1 I = 1, NINC INCA(I)=MOTS(I) 1 CONTINUE SEGDES MLMOTS MLMOTS=MLMOTY SEGACT MLMOTS IF(MOTS(/2).NE.NINC) THEN SEGDES MLMOTS 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 SEGDES MLMOTS C========================================================= C VERIFICATION DU LIEU SUPPORT DES MCHAML C presence des memes sous zones C presence des composantes declarées C identité des points supports C C MCHEL1=IPCHE1 MCHEL2=IPCHE2 SEGACT MCHEL1,MCHEL2 N1=MCHEL1.IMACHE(/1) NP1=MCHEL2.IMACHE(/1) C verification du nombre de sous zones geometriques if(N1.ne.NP1) then CALL ERREUR(329) segdes MCHEL1,mchel2 return endif if(mchel1.ifoche.ne.mchel2.ifoche) then call erreur(21) segdes MCHEL1,mchel2 return endif L1=11 N3=6 SEGINI MCHEL3,MCHEL4 C C on fabrique deux CHAMPS temporaires ordonnés C ipb1 = 0 DO 10 ISOUS = 1,N1 in1 = 0 in2 = 0 IPT1 = MCHEL1.IMACHE(ISOUS) MCHAM1 = MCHEL1.ICHAML(ISOUS) SEGACT MCHAM1 N2=NINC SEGINI MCHAM3,MCHAM4 do 16 j=1,ninc do 17 k=1,MCHAM1.nomche(/2) noin = MCHAM1.nomche(k) if(noin.eq.inca(j)) then in1= in1 + 1 MCHEL3.IMACHE(isous)=IPT1 MCHEL3.ICHAML(isous)=MCHAM3 inf1 = mchel1.infche(isous,3) inf2 = mchel1.infche(isous,4) melva1= MCHAM1.IELVAL(k) segini ,melval=melva1 MCHAM3.IELVAL(in1)=melval MCHAM3.NOMCHE(in1)=noin segdes melva1,melval goto 16 endif 17 continue 16 continue C segdes mcham1 C DO 12 ii = 1,N1 IPT2 = MCHEL2.IMACHE(II) if(ipt2.eq.ipt1) then MCHAM2 = MCHEL2.ICHAML(II) SEGACT MCHAM2 do 18 j=1,ninc do 19 k=1,MCHAM2.nomche(/2) noin = MCHAM2.nomche(k) if(noin.eq.incb(j)) then in2= in2 + 1 if(mchel2.infche(II,3).ne.inf1.or. & mchel2.infche(II,4).ne.inf2) then ipb1 = 1 endif MCHEL4.IMACHE(isous) = IPT2 MCHEL4.ICHAML(isous) = MCHAM4 melva1 = MCHAM2.IELVAL(k) segini , melval=melva1 MCHAM4.IELVAL(in2) = melval MCHAM4.NOMCHE(in2)=noin segdes melva1,melval goto 18 endif 19 continue 18 continue segdes mcham2 endif 12 CONTINUE if(ipb1.eq.1) then moterr(1:8) = MCHEL1.TITCHE(1:8) moterr(9:16)= MCHEL2.TITCHE(1:8) segdes mchel1,mchel2 segsup MCHAM3,MCHAM4,MCHEL3,MCHEL4,itrav call erreur(175) RETURN endif C====== if(in1.ne.ninc.or.in2.ne.ninc) then segdes mchel1,mchel2 segsup MCHAM3,MCHAM4,MCHEL3,MCHEL4,itrav C write(6,*) ' incoherence entre composantes et listmots ' call erreur(911) RETURN endif C====== 10 CONTINUE C segsup itrav if (mchel1.ne.mchel2) segdes mchel2 C---------------------------------------------------------- C C CREATION DU MCHELM C L1=11 N3=6 C SEGINI MCHELM TITCHE='PROSCAL' IFOCHE=MCHEL1.IFOCHE IRET=MCHELM C____________________________________________________________________ C C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES C____________________________________________________________________ C DO 500 ISOUS=1,N1 * * INITIALISATION * MELEME = MCHEL1.IMACHE(ISOUS) IMACHE(ISOUS)= MELEME CONCHE(ISOUS)= MCHEL1.CONCHE(ISOUS) C C INFCHE(ISOUS,1)=0 INFCHE(ISOUS,2)=0 INFCHE(ISOUS,3)=MCHEL1.INFCHE(ISOUS,3) INFCHE(ISOUS,4)=MCHEL1.INFCHE(ISOUS,4) INFCHE(ISOUS,5)=0 INFCHE(ISOUS,6)=MCHEL1.INFCHE(ISOUS,6) C C RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER C bp (septembre 2009): modif pour permettre d'avoir des zones de champs C cst et d'autres variables => differentes tailles de supports C MCHAM3=MCHEL3.ICHAML(ISOUS) MCHAM4=MCHEL4.ICHAML(ISOUS) N1PTEL = 0 N1EL = 0 DO ICOMP=1,NINC MELVA1 = MCHAM3.IELVAL(ICOMP) MELVA2 = MCHAM4.IELVAL(ICOMP) SEGACT MELVA1,MELVA2 N1PTEL = max(N1PTEL,MELVA1.VELCHE(/1)) N1EL = max(N1EL,MELVA1.VELCHE(/2)) SEGDES MELVA1,MELVA2 ENDDO C C CREATION DU MCHAML RESULTAT DE LA SOUS ZONE C N2=1 SEGINI MCHAML ICHAML(ISOUS)=MCHAML NOMCHE(1)='SCAL' TYPCHE(1)='REAL*8' N2PTEL=0 N2EL=0 SEGINI MELVAL IELVAL(1)=MELVAL c mise a 0 initiale (necessaire?) DO IE= 1,N1EL DO IB= 1,N1PTEL VELCHE(IB,IE) = 0.D0 ENDDO ENDDO C DO 110 ICOMP=1,NINC MELVA1= MCHAM3.IELVAL(ICOMP) MELVA2= MCHAM4.IELVAL(ICOMP) segact melva1,melva2 IB1MAX = MELVA1.VELCHE(/1) IE1MAX = MELVA1.VELCHE(/2) IB2MAX = MELVA2.VELCHE(/1) IE2MAX = MELVA2.VELCHE(/2) c write(6,*) 'comp',MCHAM3.NOMCHE(icomp),MCHAM4.NOMCHE(icomp) C write(6,*) 'melvals' ,melva1,melva2 DO IE= 1,N1EL DO IB= 1,N1PTEL IB1 = min(IB,IB1MAX) IB2 = min(IB,IB2MAX) IE1 = min(IE,IE1MAX) IE2 = min(IE,IE2MAX) c write(6,*) 'VELCHE(IB,IE) = ',VELCHE(IB,IE),' + ', c & (MELVA1.VELCHE(IB1,IE1)),' * ',(MELVA2.VELCHE(IB2,IE2)) VELCHE(IB,IE) = VELCHE(IB,IE) & + MELVA1.VELCHE(IB1,IE1)*MELVA2.VELCHE(IB2,IE2) ENDDO ENDDO segdes melva1,melva2 110 CONTINUE C C segsup MCHAM3,MCHAM4 segdes,MELVAL,MCHAML 500 CONTINUE call dtcham(mchel3) call dtcham(mchel4) segdes mchel1,mchelm RETURN END