C JONCT SOURCE FANDEUR 22/03/01 21:15:05 11301 SUBROUTINE JONCT C C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C FABRIQUE UN OBJET ATTACHE DECRIVANT LA LIAISON ENTRE PLUSIEURS C ELEMENTS DE STRUCTURE,LIAISON DEFINIE PAR UN NOMBRE QUELCONQUE C DE LIAISONS ELEMENTAIRES C ********************* C C SYNTAXE:(EXTENSION DE RELA) C ATT= JON ELSTR1 DDL1 PROG1 ....ELSTRN DDLN PROGN C ELSTRN+1 DDLN+1 PROGN+1...ELSTRP DDLP PROGP C (DDDD C ...... C ...........................ELSTRQ DDLQ PROGQ) C C VERSION 3 UN SEUL MSOUPO PAR RELATION ELEMENTAIRE ET PAR POINT C C C ATTENTION:LE TABLEAU DES IDEN(IP) DOIT ETRE DES I*4 C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCHAMP -INC SMELSTR -INC SMCLSTR -INC SMSTRUC -INC SMELEME -INC SMCOORD -INC SMRIGID -INC SMCHPOI -INC SMATTAC -INC SMLREEL -INC SMCHAML SEGMENT ITRA1(0) SEGMENT IWOR1(0) SEGMENT ITRA2(0) SEGMENT ITRA3(0) SEGMENT ITRA4(0) SEGMENT ITRA5(0) SEGMENT RCOEF(0) SEGMENT IGEO(0) SEGMENT IDEN(NPO) SEGMENT ICO(NPO) SEGMENT SINCO CHARACTER*(LOCOMP) INCO(ICCMAX) ENDSEGMENT SEGMENT MNOC CHARACTER*(LOCOMP) NOCO(ICCMAX,NPO) ENDSEGMENT SEGMENT/MVAL/(VALE(ICCMAX,NPO)) CHARACTER*4 MOMAS(1),IDELI(1) CHARACTER*(LOCOMP) NOMCO DATA ICCMAX/30/ DATA IDELI/'DDDD'/,MOMAS/'MASS'/ SEGACT MCOORD*MOD SEGINI ITRA1 NBRELA=0 LDD=0 LDU=0 CALL LIRMOT(MOMAS,1,IMASS,0) 5001 CONTINUE NBRELA =NBRELA+1 1 CONTINUE C C LECTURE DES MELSTR C CALL LIROBJ('ELEMSTRU',IRET,0,IRETOU) IF(IRETOU.EQ.0) GOTO 10 MELSTR=IRET CALL LIRMOT(NOMDD,LNOMDD,IMOT,0) IF(IERR.NE.0) RETURN IF(IMOT.NE.0) THEN LDD=1 NOMCO=NOMDD(IMOT) GO TO 2 ENDIF CALL LIRMOT(NOMDU,LNOMDD,IMOT,1) IF(IERR.NE.0) RETURN IF(IMOT.NE.0) THEN LDU=1 NOMCO=NOMDU(IMOT) GO TO 2 ENDIF C *** OUBLI DE LA COMPOSANTE CALL ERREUR(116) GOTO 3 2 CONTINUE CALL LIRPRO(NBVAL,IPROG) IF(IPROG.EQ.0) GOTO 3 SEGACT MELSTR NBSTRU=ISOSTU(/1) MSOSTU=ISOSTU(1) MELEME=IMELEM(1) SEGDES MELSTR IF(NBSTRU.EQ.1) GOTO 4 C *** LA SOUS-STRUCTURE N'EST PAS ELEMENTAIRE INTERR(1)=MSOSTU CALL ERREUR(90) 3 CONTINUE SEGSUP ITRA1 RETURN 4 ITRA1(**)=MSOSTU ITRA1(**)=MELEME READ (NOMCO,FMT='(A4)') IPV ITRA1(**)=IPV ITRA1(**)=IPROG C*******RECHERCHE DU SEPARATEUR D'EXPRESSIONS CALL LIRMOT(IDELI,1,IMOT,0) IF(IERR.NE.0) RETURN IF(IMOT.EQ.0) GO TO 1 READ (IDELI,FMT='(A4)') IPV ITRA1(**)=IPV GO TO 5001 10 CONTINUE NITRA1=ITRA1(/1) IF(IIMPI.EQ.2) WRITE(IOIMP,7) NITRA1 7 FORMAT(2X,'NITRA1',I4) K=0 11 K=K+1 IF(IIMPI.EQ.2) WRITE(IOIMP,12)(KK,ITRA1(KK),KK=K,K+3) 12 FORMAT(2X,2('ITRA(',I4,')=',I4,2X),'ITRA1(',I4,')=',A4,1X,'ITRA1 &(',I4,')=',I4) KS=K+4 IF(KS.LE.NITRA1)THEN READ (IDELI,FMT='(A4)') IPV IF(ITRA1(KS).EQ.IPV)THEN K=KS IF(IIMPI.EQ.2) WRITE(IOIMP,13) ITRA1(KS) 13 FORMAT(10X,A4) ELSE K=K+3 ENDIF GO TO 11 ENDIF C C TRAITEMENT DES MELSTRS C ********************** C IF(NBRELA.EQ.0) RETURN N=NBRELA M=0 SEGINI MSOUMA ITYATT='MECA' IGEOCH=0 IPHYCH=0 IDD1=0 IF(IIMPI.EQ.2 ) WRITE(IOIMP,8) NBRELA 8 FORMAT(2X,'NBRELA=',I4) C C BOUCLE SUR LES RELATIONS ELEMENTAIRES ECRITES C ********************************************* C DO 520 NNNN=1,NBRELA IF(IIMPI.EQ.2) WRITE(IOIMP,9) NNNN 9 FORMAT(2X,'NNNN=',I4) C PRISE EN COMPTE DU SEPARATEUR IDD1=IDD1+1 C MEMORISATION DE LA POSITION DANS ITRA1 DU DEBUT DE LA RELATION IT1 =IDD1 NBELST=0 C******************COMPTAGES 15 IDD1=IDD1+4 IF(IIMPI.EQ.2) WRITE(IOIMP,17) IDD1 17 FORMAT(2X,'IDD1=',I4) NBELST=NBELST+1 IF(IDD1.GE.NITRA1) GO TO 16 READ (IDELI,FMT='(A4)') IPV IF(ITRA1(IDD1).NE.IPV) GO TO 15 C ***************** 16 CONTINUE SEGINI ITRA5 C C RECHERCHE DES SOUS STRUCTURES INTERVENANT DS LA LIAISON C BOUCLE SUR L'ENSMBLE DES MELSTRS C QUAND UNE SOUS STRUCTURE EST EPUISEE ITRA1( )=0 C DO 350 NB=1,NBELST IT=(IT1-1)+4*(NB-1) MSOSTU=ITRA1(IT+1) IF(MSOSTU.EQ.0) GOTO 350 C C *********** 1 *********** C C CREATION DES TABLEAUX AUXILIAIRES : C IGEO(IP)=NUM LE IP-IEME PT A LE NUMERO NUM C ITRA2(IKI)=IP NUMERO D'ORDRE DU PT NUM DS IGEO C ITRA2(IKI+1)=NOMCO NOM DU DDL ASSOCIE AU PT C RCOEF(I)=COEF COEFFICIENT ASSOCIE AU DDL NOMCO DU IP-IEME P C SEGINI ITRA2,IGEO,RCOEF C C RECHERCHE DES MELEMES D'UNE MEME SOUS STRUCTURE C IP=0 NPO=0 DO 140 NBB=NB,NBELST IT=(IT1-1)+4*(NBB-1) IF(MSOSTU.NE.ITRA1(IT+1)) GOTO 140 MELEME=ITRA1(IT+2) MLREEL=ITRA1(IT+4) SEGACT MELEME,MLREEL NBELEM=NUM(/2) NBVAL=PROG(/1) IF(NBVAL.EQ.NBELEM) GOTO 80 C *** LE NB DE COEF N'EST PAS EGAL AU NB DE PTS CALL ERREUR(117) SEGDES MELEME SEGSUP ITRA2,ITRA5,IGEO,RCOEF GOTO 3 C C BOUCLE SUR LES PTS DU MELEME DU MELSTR C 80 DO 130 NBE=1,NBELEM IKI=NUM(1,NBE) IF(NPO.EQ.0) GOTO 100 DO 90 J=1,NPO IPP=J IF(IKI.EQ.IGEO(J)) GOTO 120 90 CONTINUE 100 IP=IP+1 IGEO(**)=IKI IPP=IP 120 ITRA2(**)=IPP ITRA2(**)=ITRA1(IT+3) RCOEF(**)=PROG(NBE) 130 CONTINUE SEGDES MELEME *PV horodatage SEGSUP MLREEL NPO=IGEO(/1) ITRA1(IT+1)=0 140 CONTINUE I2=ITRA2(/1) I21=I2-1 I3=RCOEF(/1) I4=IGEO(/1) IF(IIMPI.EQ.2) WRITE(IOIMP,1000)(I,ITRA2(I),I=1,I21,2) IF(IIMPI.EQ.2) WRITE(IOIMP,1001)(I,ITRA2(I),I=2,I2,2) IF(IIMPI.EQ.2) WRITE(IOIMP,1002)(I,RCOEF(I),I=1,I3) IF(IIMPI.EQ.2) WRITE(IOIMP,1003)(I,IGEO(I) ,I=1,I4) 1000 FORMAT(1X,' ITRA2 ',10(I4,I4,1X)) 1001 FORMAT(1X,' ITRA2 ',10(I4,1X,A4,1X)) 1002 FORMAT(1X,' RCOEF ',8(I4,1PE12.5,1X)) 1003 FORMAT(1X,' IGEO ',10(I4,I4,1X)) C C ********** 2 ********** C C RECHERCHE ET REPERAGE DES DDL C CREATION DES TABLEAUX AUXILIAIRES : C NOCO(IC,IP) NOM DU IC-IEME DDL DU PT IP C IDEN(IP) SI IDEN(IP)=IDEN(IPP) =>IP ET IPP ONT MEMES DDLS C ICO(IP) NB DE DDL DU PT IP C INCO(NUCO) NOM DU NUCO-IEME DDL C SEGACT MSOSTU IF(ISRAID.EQ.0) THEN IFOCHS = IFOCHE MCHELM=ISCHAM(1) SEGDES MSOSTU SEGACT,MCHELM NSOUS=IMACHE(/1) NDDL=0 SEGINI MNOC,IDEN,ICO,SINCO ICMA=0 C C ******** BOUCLE SUR LES POINTS DE IGEO ******** C DO 2250 IP=1,NPO NDCP=0 C C ******** BOUCLE SUR LES ZONES GEO.ELEM. DU CHAMP DE MATERIAU C DO 2240 IAB=1,NSOUS MELEME=IMACHE(IAB) MCHAML=ICHAML(IAB) SEGACT MELEME IF(ITYPEL.EQ.22) GO TO 2235 NBELEM=NUM(/2) NBPT=NUM(/1) DO 2150 NBE=1,NBELEM DO 2150 NP=1,NBPT IKI=NUM(NP,NBE) NPEL=NP IF(IKI.EQ.IGEO(IP)) GO TO 2160 2150 CONTINUE C LE POINT N'APPARTIENT PAS A LA ZONE:SORTIR GO TO 2235 2160 CONTINUE SEGACT MCHAML NNINCO=NOMCHE(/2) IC=0 ICC=0 C C ********* BOUCLE SUR TOUS LES CHAMPS POSSIBLES C DO 2225 NN=1,NNINCO C C ********* RECHERCHE DU MOT"DEPLACEMENT"OU"FORCE" C LDPROD=LDD+2*LDU IF (IIMPI.EQ.2) WRITE(IOIMP,2165) LDPROD 2165 FORMAT(5X,'LDPROD=',I2) NCP=NN DO 2220 NCP1=NCP,NCP NOMCO=NOMCHE(NCP1) C C ****LE DEGRE DE LIB NOMCO EXISTE-T-IL DEJA DANS LES DDL CREES ? C IF(NDDL.EQ.0) GO TO 2180 DO 2170 ND=1,NDDL NUCO=ND IF(NOMCO.EQ.INCO(ND)) GO TO 2190 2170 CONTINUE 2180 IC=IC+1 NUCO=NDDL+IC INCO(NUCO)=NOMCO 2190 CONTINUE C C ********LE DEGRE DE LIB NOMCO EXISTE-T-IL DANS LES DDL CREES POUR C LE POINT COURANT IGEO(IP) C IF(NDCP.EQ.0)GO TO 2210 DO 2200 NDC=1,NDCP IF(NOMCO.EQ.NOCO(NDC,IP)) GO TO 2220 2200 CONTINUE 2210 ICC=ICC+1 NDIC=NDCP+ICC IF(IIMPI.EQ.2) WRITE(IOIMP,2211) NOMCO 2211 FORMAT(5X,'NOMCO=',A) IF(IIMPI.EQ.2) WRITE(IOIMP,2214) NDIC IF(NDIC.LE.ICCMAX) GO TO 2215 C ERREUR C TROP DE COMPOSANTES,ON DEPASSE LA CAPACITE DE LA MACHINE IF(IIMPI.EQ.2) WRITE (IOIMP,2214) NDIC 2214 FORMAT(10X,'NDIC=',I4) SEGDES MELEME CALL ERREUR(119) SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MNOC,IDEN,ICO,SINCO GOTO 3 2215 NOCO(NDIC,IP)=NOMCO C *** A LA NUCO-IEME COMPOSANTE ON ASSOCIE LE NB 2**(NUCO-1) IF(NUCO.EQ.1) IDEN(IP)=IDEN(IP)+1 IF(NUCO.NE.1) IDEN(IP)=IDEN(IP)+2**(NUCO-1) 2220 CONTINUE 2225 CONTINUE 2230 CONTINUE NDDL=NDDL+IC NDCP=NDCP+ICC 2235 CONTINUE SEGDES MELEME SEGDES MCHAML 2240 CONTINUE ICO(IP)=NDCP IF(NDCP.GT.ICMA) ICMA=NDCP 2250 CONTINUE SEGDES MCHELM ELSE MRIGID=ISRAID SEGDES MSOSTU SEGACT MRIGID NRIGEL=IRIGEL(/2) IFOCHS = IFORIG NDDL=0 SEGINI MNOC,IDEN,ICO,SINCO ICMA=0 C C BOUCLE SUR LES POINTS DE LA SOUS STRUCTURE C DO 250 IP=1,NPO NDCP=0 C C BOUCLE SUR LES ZONES GEOMETRIQUES DE LA SOUS STRUCTURE C DO 240 IAA=1,NRIGEL MELEME=IRIGEL(1,IAA) SEGACT MELEME IF(ITYPEL.EQ.22) GOTO 235 NBELEM=NUM(/2) NBPT=NUM(/1) DO 150 NBE=1,NBELEM DO 150 NP=1,NBPT IKI=NUM(NP,NBE) NPEL=NP IF(IKI.EQ.IGEO(IP)) GOTO 160 150 CONTINUE GO TO 235 160 DESCR=IRIGEL(3,IAA) SEGACT DESCR NLIGRE=NOELEP(/1) IC=0 ICC=0 C C BOUCLE SUR LES INCONNUES DE LA MATRICE DE RIGIDITE DE L'ELEMENT C DO 230 I=1,NLIGRE IF(NOELEP(I).NE.NPEL) GOTO 230 NOMCO=LISINC(I) IF(NDDL.EQ.0) GOTO 180 C C BOUCLE SUR LES DDL TOTAUX DEJA CREES,ON DONNE UN NUMERO (NUCO) AU DD C DO 170 ND=1,NDDL NUCO=ND IF(NOMCO.EQ.INCO(ND)) GOTO 190 170 CONTINUE 180 IC=IC+1 NUCO=NDDL+IC INCO(NUCO)=NOMCO 190 CONTINUE IF(NDCP.EQ.0) GOTO 210 C C BOUCLE SUR LES DDL DU PT DEJA CREES C DO 200 NDC=1,NDCP IF(NOMCO.EQ.NOCO(NDC,IP)) GOTO 220 200 CONTINUE 210 ICC=ICC+1 NDIC=NDCP+ICC IF(NDIC.LE.ICCMAX) GOTO 215 C *** A LA NUCO-IEME COMPOSANTE ON ASSOCIE LE NB 2**(NUCO-1) C TROP DE COMPOSANTES,ON DEPASSE LA CAPACITE DE LA MACHINE CALL ERREUR(119) SEGDES DESCR,MELEME,MRIGID,MSOSTU SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MNOC,IDEN,ICO,SINCO GOTO 3 215 NOCO(NDIC,IP)=NOMCO IF(NUCO.EQ.1) IDEN(IP)=IDEN(IP)+1 IF(NUCO.NE.1) IDEN(IP)=IDEN(IP)+2**(NUCO-1) 220 CONTINUE 230 CONTINUE SEGDES DESCR NDDL=NDDL+IC NDCP=NDCP+ICC 235 SEGDES MELEME 240 CONTINUE ICO(IP)=NDCP IF(NDCP.GT.ICMA) ICMA=NDCP 250 CONTINUE SEGDES MRIGID ENDIF I1=NOCO(/2) I2=NOCO(/3) I3=IDEN(/1) I4=ICO(/1) I5=INCO(/2) IF(IIMPI.EQ.2) WRITE(IOIMP,1004)((J,I,NOCO(I,J),I=1,I1),J=1,I2) IF(IIMPI.EQ.2) WRITE(IOIMP,1005)(I,IDEN(I),I=1,I3) IF(IIMPI.EQ.2) WRITE(IOIMP,1006)(I,ICO(I),I=1,I4) IF(IIMPI.EQ.2) WRITE(IOIMP,1007)(I,INCO(I),I=1,I5) 1004 FORMAT(1X,' NOCO ',8(I4,1X,I4,1X,A4,1X)) 1005 FORMAT(1X,' IDEN ',10(I4,1X,I4,1X)) 1006 FORMAT(1X,' ICO ',10(I4,1X,I4,1X)) 1007 FORMAT(1X,' INCO ',10(I4,1X,A4,1X)) SEGSUP SINCO C C ********** 3 ********** C C COMPATIBILITE DES DONNEES CORRESPONDANT AUX DDL ET C CREATION DU TABLEAU AUXILLIAIRE : C VALE(IC,IP) COEF POUR LE IC-IEME DDL DU IP-IEME PT C IKIMA=ITRA2(/1)/2 ICMAX=ICMA SEGINI MVAL C C BOUCLE SUR LES POINTS DE LA SOUS-STRUCTURE C DO 290 IP=1,NPO NDCP=ICO(IP) DO 255 IC=1,ICMAX VALE(IC,IP)=0. 255 CONTINUE C C RECHERCHE DU(ES) DDL DE LIAISON DU PT C ON PARCOURS LE TABLEAU ITRA2 C DO 280 IKI=1,IKIMA IT=2*(IKI-1) IKIN=ITRA2(IT+1) IF(IKIN.NE.IP) GOTO 280 WRITE (NOMCO,FMT='(A4)') ITRA2(IT+2) C C BOUCLE SUR LES DDL DU PT C DO 260 IC=1,NDCP ICC=IC IF(NOMCO.EQ.NOCO(IC,IP)) GOTO 270 260 CONTINUE C *** LE DDL N'EXISTE PAS INTERR(1)=MSOSTU MOTERR=NOMCO CALL ERREUR(118) SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MVAL,MNOC,ICO,IDEN GOTO 3 270 VALE(ICC,IP)=RCOEF(IKI) 280 CONTINUE 290 CONTINUE SEGSUP ITRA2,RCOEF I1=VALE(/1) I2=VALE(/2) IF(IIMPI.EQ.2) WRITE(IOIMP,1008)((J,I,VALE(I,J),I=1,I1),J=1,I2) 1008 FORMAT(1X,' VALE ',5(I4,1X,I4,1X,1PE12.5,1X)) C C ********** 4 ********** C SEGINI ITRA4 DO 330 IP=1,NPO IA=IDEN(IP) IF(IA.EQ.0) GOTO 330 SEGINI ITRA3 C C CREATION DES MSOUPO DU CHAMPOINT (ITRA4) C RECHERCHE DES PTS AYANT LES MEMES DDDL (ITRA3) C DO 300 IPP=IP,NPO IF(IA.NE.IDEN(IPP)) GOTO 300 ITRA3(**)=IPP IDEN(IPP)=0 300 CONTINUE NC=ICO(IP) 305 SEGINI MSOUPO ITRA4(**)=MSOUPO NBSOUS=0 NBREF=0 NBNN=1 NBELEM=ITRA3(/1) SEGINI MELEME IGEOC=MELEME ITYPEL=1 N=NBELEM SEGINI MPOVAL IPOVAL=MPOVAL DO 310 IC=1,NC NOCOMP(IC)=NOCO(IC,IP) IF(IIMPI.EQ.2) WRITE(IOIMP,308) IC, NOCOMP(IC) 308 FORMAT(4X,'NOCOMP(',I4,')=',A8) 310 CONTINUE DO 320 NBE=1,NBELEM IPP=ITRA3(NBE) NUM(1,NBE)=IGEO(IPP) DO 320 IC=1,NC DO 315 ICC=1,NC IF(NOCO(ICC,IPP).EQ.NOCOMP(IC)) GOTO 317 315 CONTINUE 317 VPOCHA(NBE,IC)=VALE(IC,IPP) 320 CONTINUE SEGDES MELEME,MPOVAL,MSOUPO SEGSUP ITRA3 330 CONTINUE SEGSUP IDEN,ICO,IGEO,MNOC,MVAL NSOUPO=ITRA4(/1) NAT=1 SEGINI MCHPOI MCHPOI.MOCHDE = ' CHPOINT cree par JONCTION' MCHPOI.MTYPOI = ' ' MCHPOI.IFOPOI = IFOCHS DO 340 NS=1,NSOUPO IPCHP(NS)=ITRA4(NS) 340 CONTINUE SEGDES MCHPOI SEGSUP ITRA4 C C ********** ********** C ITRA5(**)=MSOSTU ITRA5(**)=MCHPOI 350 CONTINUE C C CREATION DU MJONCT C 355 N=ITRA5(/1)/2 SEGINI MJONCT IF(IMASS.EQ.1) THEN MJOTYP=MOMAS(1) ELSE MJOTYP='MECA' ENDIF MJODDL='LX' NBNO=nbpts XCOOR(**)=0. XCOOR(**)=0. IF(IDIM.EQ.3) XCOOR(**)=0. XCOOR(**)=0. nbpts=nbpts+1 NBNN=1 NBELEM=1 NBREF=0 NBSOUS=0 SEGINI MELEME ITYPEL=1 NUM(1,1)=NBNO+1 SEGDES MELEME MJOPOI=MELEME MJPOI=NBNO+1 DO 360 NN=1,N NNN=2*NN ISTRJO(NN)=ITRA5(NNN-1) IPCHJO(NN)=ITRA5(NNN) 360 CONTINUE SEGSUP ITRA5 SEGDES MJONCT C C REMPLISSAGE DU MSOUMA C IATREL(NNNN)=MJONCT IF (IIMPI.EQ.2) WRITE (IOIMP,518) NNNN,IATREL(NNNN) 518 FORMAT(5X,'IATREL(',I4,')=',I8) 520 CONTINUE SEGDES MSOUMA C C CREATION DU MATTAC C N=1 SEGINI MATTAC LISATT(1)=MSOUMA CALL ECROBJ('ATTACHE ',MATTAC) SEGDES MATTAC SEGSUP ITRA1 c RETURN END