C ADCHEL SOURCE PV 11/04/08 21:15:00 6936 SUBROUTINE ADCHEL(IPCHE1,IPCHE2,IPCHAD,IEPS) *_______________________________________________________________________ * * ADDITION / SOUSTRACTION DE 2 CHPS PAR ELEMENTS * * ( ADDITION :IEPS=1 ; SOUSTRACTION IEPS=-1 ) * * ENTREE : * -------- * * IPCHE1 POINTEUR SUR LE PREMIER CHAMPS (TYPE MCHAML) * IPCHE2 POINTEUR SUR LE DEUXIEME CHAMPS (TYPE MCHALM) * IEPS = 1 ADDITION * =-1 SOUSTRACTION * * SORTIE : * ________ * * IPCHAD POINTEUR SUR LE CHAMPS SOMME (TYPE MCHAML) * = 0 SI L OPERATION EST IMPOSSIBLE * * MESSAGE D ERREUR DECHENCHE SI IPCHAD=0 * * LES 2 CHAM PAR ELEMENT PEUVENT AVOIR DES SUPPORTS GEOMETRIQUES * DIFFERENTS POUR PEU QUE LES OBJETS AFFECTES ELEMENTAIRES QUI LES * SOUS TENDENT FORMENT UNE PARTITION DE LA GEOMETRIE * * CODE EBERSOLT JUILLET 84 PASSAGE 4331 FEVRIER 85 * * ON PEUT ADDITIONNER A UN CHAMELEM QUELCONQUE UN CHAMELEM A UNE * COMPOSANTE * * MODIFIE SEPTEMBRE 86 * * PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 29 10 90 * +PP EXTENSION ADDITION P.PEGON 24/11/92 *_______________________________________________________________________ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC SMCHAML -INC SMLREEL -INC SMCOORD -INC CCOPTIO * SEGMENT MZONG INTEGER NZONG(0) ENDSEGMENT * SEGMENT MZON1 INTEGER NZON1(0) ENDSEGMENT * SEGMENT MZON2 INTEGER NZON2(0) ENDSEGMENT * SEGMENT ITAFF INTEGER JTAFF(0) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * PARAMETER ( NINF=3 ) INTEGER INFOS(NINF) CHARACTER*72 MOT CHARACTER*16 CONCH1,CONCH2 * IF(IEPS.EQ. 1) XX= 1 IF(IEPS.EQ.-1) XX=-1 if (ieps.eq.-1) then * write (6,*) ' adchel soustraction de chamelem ' endif IF(IPCHE1.NE.IPCHE2) GOTO 1000 * * SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL * MCHEL1=IPCHE1 MCHEL2=IPCHE2 SEGINI,MCHELM=MCHEL1 IPCHAD = MCHELM NSOUS = IMACHE(/1) IF (IEPS.EQ. 1) XX=2 IF (IEPS.EQ.-1) XX=0 * DO 110 IA=1,NSOUS MCHAM1=ICHAML(IA) SEGINI,MCHAML=MCHAM1 ICHAML(IA)=MCHAML DO 111 ICOMP=1,IELVAL(/1) MELVA1 = IELVAL(ICOMP) SEGINI,MELVAL=MELVA1 N1PTEL=VELCHE(/1) IF (N1PTEL.EQ.0) THEN N2PTEL=IELCHE(/1) N2EL =IELCHE(/2) IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN DO 1 IGAU=1,N2PTEL DO 1 IB=1,N2EL MLREE1=IELCHE(IGAU,IB) IF(MLREE1.EQ.0)THEN MLREEL=MLREE1 ELSE SEGACT MLREE1 JG=MLREE1.PROG(/1) SEGINI MLREEL DO 2 IPROG=1,JG PROG(IPROG)=XX*MLREE1.PROG(IPROG) 2 CONTINUE SEGDES MLREE1,MLREEL ENDIF IELCHE(IGAU,IB)=MLREEL 1 CONTINUE ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN DO 11 IGAU=1,N2PTEL DO 11 IB=1,N2EL MEVOL1=IELCHE(IGAU,IB) CALL ADEVOL(MEVOL1,MEVOL1,MEVOL2,IEPS) IELCHE(IGAU,IB)=MEVOL2 11 CONTINUE ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN DO 3 IGAU=1,N2PTEL DO 3 IB=1,N2EL IP=IELCHE(IGAU,IB) IF(IP.EQ.0)THEN NBPTS=IP ELSE IREF=(IP-1)*(IDIM+1) * * ON CREE UN NVX POINTS :NOEUD NBNO+1 * SEGACT MCOORD NBNO=XCOOR(/1)/(IDIM+1) NBNOI=NBNO NBPTS=NBNO+1 SEGADJ MCOORD * DO 4 IC=1,IDIM XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XX 4 CONTINUE XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1)) ENDIF IELCHE(IGAU,IB)=NBPTS 3 CONTINUE ELSE * * NOM DE COMPOSANTE NON RECONNU * MOTERR(1:4)=NOMCHE(ICOMP) CALL ERREUR(197) IPCHAD=0 SEGDES MCHEL1,MCHEL2 SEGSUP MELVAL,MCHAML,MCHELM RETURN ENDIF ELSE N1EL=VELCHE(/2) DO 5 IGAU=1,N1PTEL DO 5 IB=1,N1EL VELCHE(IGAU,IB)=XX*VELCHE(IGAU,IB) 5 CONTINUE ENDIF IELVAL(ICOMP) = MELVAL SEGDES MELVAL,melva1 111 CONTINUE SEGDES MCHAML 110 CONTINUE SEGDES MCHELM GOTO 777 * * CAS GENERAL * 1000 CONTINUE MCHEL1=IPCHE1 MCHEL2=IPCHE2 SEGACT MCHEL1 SEGACT MCHEL2 IF(MCHEL1.IFOCHE.EQ.MCHEL2.IFOCHE) GOTO 3000 * * ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS * DE SS TYPE DIFFERENTS * MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8) CALL ERREUR(99) IPCHAD=0 GOTO 666 *_______________________________________________________________________ * * CAS GENERAL *_______________________________________________________________________ * 3000 CONTINUE MOT=MCHEL1.TITCHE L1=MCHEL1.TITCHE(/1) IF (MOT.EQ.'NOEUD'.OR.MOT.EQ.'GRAVITE'.OR.MOT.EQ.'RIGIDITE'. & OR.MOT.EQ.'MASSE'.OR.MOT.EQ.'STRESSES'. & OR.MOT.EQ.'SCALAIRE') THEN MOT=MCHEL2.TITCHE L1=MCHEL2.TITCHE(/1) ENDIF N3=MCHEL1.INFCHE(/2) NSOUS1=MCHEL1.ICHAML(/1) NSOUS2=MCHEL2.ICHAML(/1) * * QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS SI OUI TRAITEMENT AMELIORE * IF(NSOUS1.NE.NSOUS2) GOTO 4000 * SEGINI ITAFF DO 17 ISOUS1=1,NSOUS1 IPMAI1 = MCHEL1.IMACHE(ISOUS1) CONCH1 = MCHEL1.CONCHE(ISOUS1) DO 18 ISOUS2=1,NSOUS2 ISOUS=ISOUS2 IPMAI2= MCHEL2.IMACHE(ISOUS) CONCH2= MCHEL2.CONCHE(ISOUS) IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN * * VERIFICATION POUR LES INFCHE * CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 18 IMINT1=0 IMINT2=0 IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) IF (IMINT1.EQ.IMINT2) GOTO 171 IMINT1=1 IMINT2=1 IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6) IF (IMINT1.EQ.0) IMINT1=1 IF (IMINT2.EQ.0) IMINT2=1 IF (IMINT1.EQ.IMINT2) GOTO 171 * * ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS * DE SS TYPE DIFFERENTS * MOTERR(1:8)=MCHEL1.TITCHE MOTERR(9:16)=MCHEL2.TITCHE CALL ERREUR(329) SEGDES MCHEL1,MCHEL2 SEGSUP ITAFF IPCHAD=0 RETURN ENDIF 18 CONTINUE SEGSUP ITAFF GOTO 4000 * 171 CONTINUE JTAFF(**)=MCHEL2.ICHAML(ISOUS) 17 CONTINUE * * ON A TROUVE UNE BIJECTION ET ON VECTORISE * N1=NSOUS1 SEGINI MCHELM TITCHE=MOT IFOCHE=IFOUR IPCHAD=MCHELM DO 400 ISOUS=1,NSOUS1 IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS) CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS) DO 401 N33=1,N3 INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33) 401 CONTINUE * MCHAM1=MCHEL1.ICHAML(ISOUS) * SEGINI,MCHAML=MCHAM1 ICHAML(ISOUS)=MCHAML IPCHA=MCHAML * MCHAM2=JTAFF(ISOUS) SEGACT MCHAM2 IPCHA2=MCHAM2 * CALL ADCHAM (IPCHA2,IPCHA,XX) IF (IPCHA.EQ.0) THEN SEGSUP ITAFF GOTO 9990 ENDIF * *pv SEGDES MCHAML,MCHAM2,MCHAM1 SEGDES MCHAML 400 CONTINUE *pv SEGDES MCHEL1,MCHEL2 SEGSUP ITAFF SEGDES MCHELM GOTO 666 *_______________________________________________________________________ * * ON A PAS TROUVE DE BIJECTION *_______________________________________________________________________ * 4000 CONTINUE SEGINI MZONG,MZON1,MZON2 DO 500 ISOUS1=1,NSOUS1 NZONG(**)=MCHEL1.IMACHE(ISOUS1) NZON1(**)=ISOUS1 NZON2(**)=0 500 CONTINUE IWRN=0 DO 510 ISOUS2=1,NSOUS2 IPMAI2 = MCHEL2.IMACHE(ISOUS2) CONCH2 = MCHEL2.CONCHE(ISOUS2) DO 520 ISOUS1=1,NSOUS1 IPMAI1= MCHEL1.IMACHE(ISOUS1) CONCH1= MCHEL1.CONCHE(ISOUS1) IF(IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) IF (IRTD.EQ.0) GOTO 520 * * VERIFICATION POUR LES MINTES * IF ( MCHEL1.INFCHE(ISOUS1,6).EQ. & MCHEL2.INFCHE(ISOUS2,6) ) GOTO 530 * * ERREUR SUR LES SUPPORTS DES MCHAML * MOTERR(1:8)=MCHEL1.TITCHE MOTERR(9:16)=MCHEL2.TITCHE CALL ERREUR(329) IPCHAD=0 SEGDES MCHEL1,MCHEL2 SEGSUP MZONG,MZON1,MZON2 RETURN * ENDIF 520 CONTINUE IWRN=1 NZONG(**)=IPMAI2 NZON1(**)=0 NZON2(**)=ISOUS2 GOTO 510 * 530 CONTINUE if (nzon2(isous1).ne.0) call erreur(329) NZON2(ISOUS1)=ISOUS2 510 CONTINUE * * WARNING LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2 * * IF(IWRN.EQ.1) CALL ERREUR(103) NSOUS=NZONG(/1) N1=NSOUS SEGINI MCHELM TITCHE=MOT IFOCHE=IFOUR IPCHAD=MCHELM * DO 540 ISOUS=1,NSOUS IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550 * IF(NZON1(ISOUS).NE.0) THEN MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) ) SEGINI,MCHAML=MCHAM1 IMACHE(ISOUS)=NZONG(ISOUS) CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) ) DO 402 N33=1,N3 INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33) 402 CONTINUE * ENDIF IF(NZON2(ISOUS).NE.0) THEN MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) ) SEGINI,MCHAML=MCHAM2 IMACHE(ISOUS)=NZONG(ISOUS) CONCHE(ISOUS)=MCHEL2.CONCHE( NZON2(ISOUS) ) DO 403 N33=1,N3 INFCHE(ISOUS,N33)=MCHEL2.INFCHE(NZON2(ISOUS),N33) 403 CONTINUE * ENDIF ICHAML(ISOUS)=MCHAML * DO 175 ICOMP=1,IELVAL(/1) MELVA1=IELVAL(ICOMP) SEGINI,MELVAL=MELVA1 IELVAL(ICOMP)=MELVAL *pv SEGDES MELVAL,melva1 SEGDES melval 175 CONTINUE SEGDES MCHAML * GOTO 540 * 550 CONTINUE MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) ) SEGINI,MCHAML=MCHAM1 IMACHE(ISOUS)=NZONG(ISOUS) CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) ) DO 404 N33=1,N3 INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33) 404 CONTINUE ICHAML(ISOUS)=MCHAML IPCHA=MCHAML MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) ) SEGACT MCHAM2 IPCHA2=MCHAM2 * CALL ADCHAM (IPCHA2,IPCHA,XX) IF (IPCHA.EQ.0) THEN SEGSUP MZONG,MZON1,MZON2 GOTO 9990 ENDIF * *pv SEGDES MCHAML,MCHAM2 SEGDES MCHAML 540 CONTINUE SEGDES MCHELM * SEGSUP MZONG,MZON1,MZON2 GOTO 666 * 9990 CONTINUE * * ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR * SEGDES MCHEL1,MCHEL2,MCHAM2 SEGSUP MCHAML,MCHELM,ITAFF IPCHAD=0 RETURN * 666 CONTINUE *pv SEGDES MCHEL1,MCHEL2 777 CONTINUE RETURN END