scacha
C SCACHA SOURCE CB215821 20/11/04 21:21:11 10766 ********************************************************************* * 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 IPLMO1 LISTMOTS DE COMPOSANTES ASSOCIEES AU 1-ER CHAMP C IPLMO2 LISTMOTS DE COMPOSANTES ASSOCIEES AU 2-EME CHAMP C SORTIE C IRET POINTEUR SUR LE MCHAML RESULTAT C-------------------------------------------------------------------- -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMCHAML -INC SMELEME -INC SMLMOTS C CHARACTER*(LOCOMP) NOIN C IRET=0 MCHAML=0 C C========================================================= C RECUP DES LISTMOTS + VERIF DES DIMENSIONS C========================================================= * LISTE 1 MLMOT1=IPLMO1 SEGACT MLMOT1 * LISTE 2 MLMOT2=IPLMO2 SEGACT MLMOT2 SEGDES MLMOT1,MLMOT2 MOTERR(1:4)='PSCA' MOTERR(5:12)='LISTMOTS' RETURN ENDIF 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 segdes MCHEL1,mchel2 return endif if(mchel1.ifoche.ne.mchel2.ifoche) then segdes MCHEL1,mchel2 return endif L1=11 N3=6 SEGINI MCHEL3,MCHEL4 C C on fabrique deux CHAMPS temporaires ordonnés C ipb1 = 0 c---- boucle sur les sous-zones ----------------- DO 10 ISOUS = 1,N1 in1 = 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) 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 *bp,2020 segdes 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(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 segdes melva1 *bp,2020 segdes melval goto 18 endif 19 continue 18 continue segdes mcham2 endif 12 CONTINUE c erreur 175 : supports incompatibles 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 RETURN endif C erreur : Probleme entre composantes des champs et les LISTMOTS segdes mchel1,mchel2 segsup MCHAM3,MCHAM4,MCHEL3,MCHEL4 RETURN endif 10 CONTINUE c---- fin de boucle sur les sous-zones ----------------- C if (mchel1.ne.mchel2) segdes mchel2 C========================================================= C CREATION DU MCHELM C========================================================= C L1=4 N3=6 C SEGINI MCHELM TITCHE='PSCA' 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 bp,2020: ajout du cas : MELVA1 cst * MELVA2 variable 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)) N1PTEL = max(N1PTEL,MELVA2.VELCHE(/1)) N1EL = max(N1EL ,MELVA2.VELCHE(/2)) cbp,2020 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 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 C FIN DE BOUCLE SUR LES ZONES C____________________________________________________________________ segdes mchel1 cbp,2020 segdes,mchelm RETURN END
© Cast3M 2003 - Tous droits réservés.
Mentions légales