C RELA1 SOURCE BP208322 12/12/17 21:15:18 7615 SUBROUTINE RELA1 C C RELAZIONE LINEARE TRA DDL C C ICONR NUMERO OGGETTI MELEME DELLA RELAZIONE C ITYESR(NBSOUS) LISTA TIPI ELEMENTI CONTENUTI IN MELEME-N C MUNESR(NBSOUS) NUMERO ELEMENTI IN OGNI SOTTOSTRUTTURA DI MELEME-N C LNODSR(NNR) LISTA NODI MELEME-N C IPOR1(N) PUNTATORE SU MWREL1 C IPOR2(N) PUNTATORE SU MWREL2 C IPOR3(N) PUNTATORE SU MWREL3 C COEFR(N) COEFFICIENTI RELAZIONE C INCREL(N) IDENTIFICATORE NOME DDL C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC SMELEME -INC SMCOORD -INC SMRIGID -INC TMTRAV -INC CCOPTIO -INC CCGEOME -INC CCHAMP SEGMENT /MWGGM1/(IPORE1(0)) SEGMENT /MWGGM2/(IPORE2(0)) SEGMENT /MWGGM3/(IPORE3(0)) SEGMENT /MWGGM4/(INCREL(0)) SEGMENT /MWGGM5/(COEFR(0)*D) SEGMENT /MWREL1/(ITYESR(0)),IEL11.MWREL1, + IEL21.MWREL1 SEGMENT /MWREL2/(MUNESR(0)),IEL12.MWREL2, + IEL22.MWREL2 SEGMENT /MWREL3/(LNODSR(0)),IEL13.MWREL3, + IEL23.MWREL3 CHARACTER*4 MOTPV(3) CHARACTER*4 MOCORI(7) CHARACTER*4 MOTPM(2) CHARACTER*4 MOTDDL(3) CHARACTER*4 MOTBLO(3) CHARACTER*4 MODEPL(8) CHARACTER*4 MOROTA(5) CHARACTER*8 MILMOT DIMENSION XNOR(3) DATA MOTPV /'MINI','MAXI','FROT'/ DATA MOTPM /'+ ','- '/ DATA MOCORI/'CORI','ENSE','ACCR','GLIS','BARY','MILI','TUYA'/ C DATA EPSI/1.D-12/ DATA MOTBLO/'DEPL','ROTA','DIRE'/ DATA MODEPL/'UX ','UY ','UZ ','UR ','UZ ','UT ', &'ALFA','BETA'/ DATA MOROTA/'RX ','RY ','RZ ','RT ','RS '/ C C EST-CE UNE RELATION DE CORPS RIGIDE ? C CALL LIRMOT(MOCORI,7,ICORI,0) IF (ICORI.NE.0) THEN c BARY if (icori.eq.5) then call relaba c MILI ELSE IF (ICORI.EQ.6) THEN CALL RELAMI c TUYA elseif(icori.eq.7) then call reltuy c CORI, ENSE, ACCRO, GLIS else CALL RELA2(MOCORI(ICORI)) endif RETURN ENDIF C C EST-CE UNE CONDITION UNILATERALE ? C NILATE=0 CALL LIRMOT (MOTPV,3,IPO,0) IF(IPO.EQ.1) NILATE=-1 IF(IPO.EQ.2) NILATE=+1 IF(IPO.EQ.3) NILATE=+2 C C INITIALISATIONS C COEX=1.D0 C C Deformations planes ou contraintes planes ou defo. plane gene : IF (IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3) THEN LDEPL=2 IADEPL=0 LROTA=1 IAROTA=2 C Axisymetrique : ELSE IF (IFOUR.EQ.0) THEN LDEPL=2 IADEPL=3 LROTA=1 IAROTA=3 C Fourier : ELSE IF (IFOUR.EQ.1) THEN LDEPL=3 IADEPL=3 LROTA=2 IAROTA=2 C Tridimensionnel : ELSE IF (IFOUR.EQ.2) THEN LDEPL=3 IADEPL=0 LROTA=3 IAROTA=0 C Massif 1D (IDIM=1) : ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN LDEPL=1 IADEPL=0 IF (IFOUR.GE.12) IADEPL=3 LROTA=0 IAROTA=0 C Autres cas : ELSE LDEPL=0 IADEPL=0 LROTA=0 IAROTA=0 ENDIF C SEGINI MWGGM1 SEGINI MWGGM2 SEGINI MWGGM3 SEGINI MWGGM4 SEGINI MWGGM5 * * LECTURE EVENTUELLE D'UN CHPOINT * CALL LIROBJ('CHPOINT',IPOCHP,0,IRECHP) IF(IRECHP.NE.0) THEN * * ON MET LE CHPOINT SOUS FORME DE TABLEAU DE TRAVAIL * CALL TRACHP(IPOCHP,MTRAV) SEGACT MTRAV DO 1990 I=1,IBIN(/1) DO 1990 J=1,IBIN(/2) IF(IBIN(I,J).EQ.0) GO TO 1990 CALL PLACE(NOMDD,LNOMDD,IPO,INCO(I)) IF(IPO.EQ.0) THEN SEGSUP MTRAV GO TO 559 ENDIF SEGINI MWREL1 SEGINI MWREL2 SEGINI MWREL3 IPORE1(**)=MWREL1 IPORE2(**)=MWREL2 IPORE3(**)=MWREL3 COEFR(**)=BB(I,J) INCREL(**)=IPO ITYESR(**)=1 MUNESR(**)=1 LNODSR(**)=IGEO(J) SEGDES MWREL1 SEGDES MWREL2 SEGDES MWREL3 1990 CONTINUE SEGSUP MTRAV GO TO 300 ENDIF 200 CONTINUE C C LETTURA OPERANDI C SEGINI MWREL1 SEGINI MWREL2 SEGINI MWREL3 IPORE1(**)=MWREL1 IPORE2(**)=MWREL2 IPORE3(**)=MWREL3 1320 CONTINUE CALL LIRREE(XR,0,IRETOF) IF(IRETOF.EQ.0) THEN CALL LIRENT(IR,0,IRETOI) XR=1.D0 IF(IRETOI.NE.0) XR=DBLE(IR) ENDIF CALL LIRMOT(NOMDD,LNOMDD,IPO,0) IF(IPO.NE.0) THEN COEFR(**)=XR*COEX INCREL(**)=IPO ELSE * * ON REGARDE SI IL Y A DEPL OU ROTA SUIVI DE DIRECTION * C En DIMENSION 1, le mot-cle 'DIRE' est interdit. IF (IDIM.EQ.1) THEN INTERR(1)=IDIM MOTERR(1:4)=MOTBLO(3) CALL ERREUR(971) GOTO 559 ENDIF CALL LIRMOT(MOTBLO,2,IMOT,1) IF (IMOT.EQ.0) GOTO 559 IF (IMOT.EQ.1) THEN IBDDL=LDEPL DO 4481 IA=1,IBDDL MOTDDL(IA)=MODEPL(IADEPL+IA) 4481 CONTINUE ENDIF IF (IMOT.EQ.2) THEN IBDDL=LROTA DO 4482 IA=1,IBDDL MOTDDL(IA)=MOROTA(IAROTA+IA) 4482 CONTINUE ENDIF CALL LIRMOT(MOTBLO(3),1,IMOT,1) IF(IMOT.EQ.0) GO TO 559 IDIREC=1 CALL LIROBJ('POINT',KPOINT,1,IRETOU) IF(IRETOU.EQ.0) GO TO 559 YL=0.D0 DO 4484 IA=1,IDIM XNOR(IA)=XCOOR((KPOINT-1)*(IDIM+1)+IA) 4484 YL=YL+XNOR(IA)*XNOR(IA) IF (YL.LT.EPSI) THEN CALL ERREUR(239) GO TO 559 ENDIF YL=1.D0/SQRT(YL) DO 4485 IA=1,IDIM 4485 XNOR(IA)=XNOR(IA)*YL * * ON LIT LE MAILLAGE * CALL LIROBJ('POINT ',MILPOI,0,IRETOU) IF(IRETOU.NE.0) THEN MILMOT='POINT ' ELSE CALL LIROBJ('MAILLAGE',MILPOI,1,IRETOU) IF(IRETOU.EQ.0) GO TO 559 MILMOT='MAILLAGE' ENDIF * * PUIS ON REMET DES OBJETS DANS LA PILE * DO 4477 IB=1,IBDDL IF(IB.GE.2.AND.COEX.EQ. 1.D0) CALL ECRCHA(MOTPM(1)) IF(IB.GE.2.AND.COEX.EQ.-1.D0) CALL ECRCHA(MOTPM(2)) CALL ECROBJ(MILMOT,MILPOI) CALL ECRCHA(MOTDDL(IB)) IF(IBDDL.EQ.1) THEN XRCOO=XR ELSE XRCOO=XR*XNOR(IB) ENDIF CALL ECRREE(XRCOO) 4477 CONTINUE GO TO 1320 ENDIF C CALL LIROBJ('POINT ',KPOINT,0,IRETOU) IF(IRETOU.NE.0) GO TO 110 CALL LIROBJ('MAILLAGE',KOBJET,1,IRETOU) IF(IRETOU.EQ.0) GO TO 559 MELEME=KOBJET SEGACT MELEME NBSOUS=LISOUS(/1) IF(NBSOUS.EQ.0) GO TO 120 C OBJET COMPLEXE NNR=1 DO 130 IS=1,NBSOUS IPT1=LISOUS(IS) SEGACT IPT1 ITYESR(**)=IPT1.ITYPEL NBNN =IPT1.NUM(/1) NBELEM =IPT1.NUM(/2) MUNESR(**)=IPT1.NUM(/2) IF(NNR.EQ.1)LNODSR(**)=IPT1.NUM(1,1) DO 140 I1=1,NBELEM DO 140 I2=1,NBNN DO 150 I3=1,NNR IF(LNODSR(I3).EQ.IPT1.NUM(I2,I1)) GO TO 140 150 CONTINUE NNR=NNR+1 LNODSR(**)=IPT1.NUM(I2,I1) 140 CONTINUE SEGDES IPT1 130 CONTINUE SEGDES MWREL1 SEGDES MWREL2 SEGDES MWREL3 SEGDES MELEME GO TO 160 C C OBJET SIMPLE C 120 CONTINUE ITYESR(**)=ITYPEL NBNN =NUM(/1) NBELEM =NUM(/2) MUNESR(**)=NUM(/2) NNR=0 DO 170 I1=1,NBELEM DO 170 I2=1,NBNN DO 180 I3=1,NNR IF(LNODSR(I3).EQ.NUM(I2,I1)) GO TO 170 180 CONTINUE NNR=NNR+1 LNODSR(**)=NUM(I2,I1) 170 CONTINUE SEGDES MWREL1 SEGDES MWREL2 SEGDES MWREL3 SEGDES MELEME GO TO 160 110 CONTINUE C C OBJET POINT C ITYESR(**)=1 MUNESR(**)=1 LNODSR(**)=KPOINT SEGDES MWREL1 SEGDES MWREL2 SEGDES MWREL3 C FINE OPERANDO RELAZIONE 160 CONTINUE ICONR=IPORE1(/1)+1 C LETTURA + O - IF(ICONR.EQ.2) CALL LIRMOT(MOTPM,2,IPO,0) IF (IPO.EQ.0) GO TO 300 *LIRMOT(MOTPM,2,IPO,1) goto 559 IF(ICONR.GT.2) CALL LIRMOT(MOTPM,2,IPO,0) IF (IPO.EQ.0) GO TO 300 COEX=1.D0 IF (IPO.EQ.2) COEX=-1.D0 C SI CERCA DI LEGGERE UN NUOVO OPERANDO DELLA RELAZIONE GO TO 200 C C VERIFICA CONGRUENZA OPERANDI C 300 CONTINUE C ICONR=IPORE1(/1) IEL11=IPORE1(1) IEL12=IPORE2(1) IEL13=IPORE3(1) SEGACT IEL11 SEGACT IEL12 SEGACT IEL13 NSOR1=IEL11.ITYESR(/1) NNR1=IEL13.LNODSR(/1) DO 310 IO=2,ICONR IEL21=IPORE1(IO) IEL22=IPORE2(IO) IEL23=IPORE3(IO) SEGACT IEL21 SEGACT IEL22 SEGACT IEL23 NSOR2=IEL21.ITYESR(/1) IF(NSOR1.NE.NSOR2) GO TO 556 DO 320 I1=1,NSOR1 IF(IEL11.ITYESR(I1).NE.IEL21.ITYESR(I1)) GO TO 556 IF(IEL12.MUNESR(I1).NE.IEL22.MUNESR(I1)) GO TO 556 320 CONTINUE NNR2=IEL23.LNODSR(/1) IF(NNR1.NE.NNR2) GO TO 556 SEGDES IEL21 SEGDES IEL22 SEGDES IEL23 310 CONTINUE NBRELA=NNR1 SEGDES IEL11 SEGDES IEL12 SEGDES IEL13 C OPERANDI CONGRUENTI FINE VERIFICA C C CARICAMENTO MATRICE RIGIDEZZA C NRIGE=8 NRIGEL=1 SEGINI MRIGID ICHOLE=0 IMGEO1=0 IMGEO2=0 ISUPEQ=0 IFORIG=IFOUR COERIG(1)=1.D0 MTYMAT='RIGIDITE' KRIGI=MRIGID C C ON INITIALISE LE SEGMENT MELEME ASSOCIE AUX BLOCAGES C SEGACT MCOORD*MOD NBNO=XCOOR(/1)/(IDIM+1) NBSOUS=0 NBREF=0 NBNN=1+ICONR NBELEM=NBRELA SEGINI IPT2 IRIGEL(1,1)=IPT2 IPT2.ITYPEL=22 DO 400 I4=1,NBRELA IPT2.ICOLOR(I4)=IDCOUL C SI CREANO DUE PUNTI PER OGNI RELAZIONE C** I5=6 C** IF(IDIM.EQ.3) I5=8 I5=(IDIM+1)*2 DO 410 I6=1,I5 XCOOR(**)=0.D0 410 CONTINUE C I7=I4-1 C PUNTI ASSOCIATI AI MOLTIPLICATORI IPT2.NUM(1,I4)=NBNO+I7+1 400 CONTINUE C CARICAMENTO NODI PSEUDO-ELEMENTI DO 420 I8=1,ICONR MWREL3=IPORE3(I8) I10=I8+1 SEGACT MWREL3 DO 430 I9=1,NBRELA NN=LNODSR(I9) NPN=(NN-1)*(IDIM+1) IPT2.NUM(I10,I9)=NN NPL1=(IPT2.NUM(1,I9)-1)*(IDIM+1) XCOOR(NPL1+1)=XCOOR(NPL1+1)+XCOOR(NPN+1) IF (IDIM.GE.2) THEN XCOOR(NPL1+2)=XCOOR(NPL1+2)+XCOOR(NPN+2) IF (IDIM.EQ.3) XCOOR(NPL1+3)=XCOOR(NPL1+3)+XCOOR(NPN+3) ENDIF 430 CONTINUE SEGDES MWREL3 420 CONTINUE C C COORDINATE DEI BARICENTRI ASSOCIATI ALLE RELAZIONI C DO 425 I4=1,NBRELA NPL1=(IPT2.NUM(1,I4)-1)*(IDIM+1) NPL2=NPL1+IDIM+1 XCOOR(NPL1+1)=XCOOR(NPL1+1)/ICONR XCOOR(NPL2+1)=XCOOR(NPL1+1) IF (IDIM.GE.2) THEN XCOOR(NPL1+2)=XCOOR(NPL1+2)/ICONR XCOOR(NPL2+2)=XCOOR(NPL1+2) IF (IDIM.EQ.3) THEN XCOOR(NPL1+3)=XCOOR(NPL1+3)/ICONR XCOOR(NPL2+3)=XCOOR(NPL1+3) ENDIF ENDIF 425 CONTINUE SEGDES IPT2 IRIGEL(2,1)=0 IRIGEL(5,1)=NIFOUR IRIGEL(6,1)=NILATE NLIGRP=ICONR+1 NLIGRD=NLIGRP SEGINI DESCR IRIGEL(3,1)=DESCR LISINC(1)='LX' LISDUA(1)='FLX' NOELEP(1)=1 NOELED(1)=1 DO 700 I1=1,ICONR I2=I1+1 I3=INCREL(I1) LISINC(I2)=NOMDD(I3) LISDUA(I2)=NOMDU(I3) NOELEP(I2)=I2 NOELED(I2)=I2 700 CONTINUE SEGDES DESCR NELRIG=NBRELA SEGINI xMATRI IRIGEL(4,1)=xMATRI * LVAL=(NBNN*NBNN+NBNN)/2 NLIGRE=NBNN NLIGRP=NBNN NLIGRD=NBNN * SEGINI XMATRI DO 740 I6=1,NELRIG * IMATTT(I1)=XMATRI *740 CONTINUE RE(1,1,i6)= 0.D0 I3=3 DO 760 I1=2,NBNN I4=I1-1 I2=1 RE(I1,I2,i6)=COEFR(I4) RE(I2,I1,i6)=COEFR(I4) 760 CONTINUE 740 continue SEGDES XMATRI * SEGDES IMATRI SEGDES MRIGID CALL ECROBJ('RIGIDITE',KRIGI) 559 ICONR=IPORE1(/1) DO 558 I1=1,ICONR MWREL1=IPORE1(I1) MWREL2=IPORE2(I1) MWREL3=IPORE3(I1) SEGSUP MWREL1 SEGSUP MWREL2 SEGSUP MWREL3 558 CONTINUE SEGSUP MWGGM1 SEGSUP MWGGM2 SEGSUP MWGGM3 SEGSUP MWGGM4 SEGSUP MWGGM5 RETURN 556 CONTINUE C SEGDES IEL11,IEL12,IEL13,IEL21,IEL22,IEL23 CALL ERREUR(324) GO TO 559 END