C ASSEM1 SOURCE PV 09/11/16 21:15:00 6538 SUBROUTINE ASSEM1 ( IPOIRI,MMATRX,INUINY,ITOPOY,IMINIY,IPOY, 1 INCTRY,IITOPY) C C CE SUBROUTINE SERT A L'ASSEMBLAGE DE MATRICES SYMETRIQUES C EN VUE D'UNE INVERSION PAR UNE METHODE DE KROUT C C EN ENTREE: C **** IPOIRI: POINTEUR SUR OBJET MRIGIDITE,NON MODIFIE C EN SORTIE: C **** INUINV IMINI ITOPO IPOY INCTRY SONT DES POINTEURS DES SEGMENTS C DE TRAVAIL SERVANT A L'ASSEMBLAGE ILS SONT DETRUITS EN FIN C D'ASSEMBLAGE OU DE TRIANGULARISATION C **** MMATRI EST LE POINTEUR DE L'OBJET FUTUR MATRICE TRIANGULARISEE. IMPLICIT INTEGER(I-N) -INC CCOPTIO -INC SMELEME -INC SMCOORD SEGMENT,IMIN(NNOE) SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) C SEGMENT IPB(NLIGRE) C -INC SMRIGID C -INC SMMATRI C SEGMENT,INUINV(NNGLOB) SEGMENT,ITOPO(IENNO) SEGMENT,IITOP(NNOE+1) SEGMENT,IMINI(INC) SEGMENT,IPOS(NNOE1) SEGMENT,INCTRR(NIRI) SEGMENT,INCTRA(NLIGRE) C C **** CES TABLEAUX SERVENT AU REPERAGE DE LA MATRICE POUR L'ASSEMBLAG C **** IL SERONT TOUS SUPPRIMES EN FIN D'ASSEMBLAGE. C C C **** MAXINC= MAXIMUM DE COMPOSANTES CONCERNANT UN NOEUD C C C **** IITOP(K)=I LE 1ER ELEMENT TOUCHANT LE NOEUD K SE TROUVE EN C IEME POSITION DANS ITOPO C **** ITOPO(I)=L: LE 1ER ELEMENT TOUCHANT LE K EME NOEUD DE LA C ITOPO(I+1)=M MATRICE EST LE LIEME DE L'OBJET GEOMETRIE C DEFINI PAR LE POINTEUR M C **** IPOS(I)=J : LA 1 ERE INCONNUE DU NOEUD I EST EN J+1 EME C POSITION C **** IMINI(I)=J LA PLUS PETITE INCONNUE QUI EST RELIEE A LA IEME C EST L'INCONNUE J. C **** INUINV(I)=J J EST LE NOUVEAU NUMERO DU NOEUD I C * DATA MOALFA/'ALFA'/ CHARACTER*4 CNOHA DATA CNOHA/'NOHA'/ DATA IPOIN/1/ READ (CNOHA,FMT='(A4)') NOHA NNGLOB=XCOOR(/1)/(IDIM+1) MRIGID=IPOIRI SEGACT,MRIGID NNVA=IRIGEL(/2) NIRI=NNVA SEGINI,INCTRR MVA=IRIGEL(/1) MELEME=IRIGEL(1,1) SEGACT MELEME IF(ITYPEL.NE.27) GO TO 801 SEGDES MELEME C C **** ASSEMBLAGE DANS LE CAS DE L'ANALYSE MODALE. ON COMPTE LES POINTS C **** DANS ICPR C SEGINI INUINV,ICPR IKI=0 DO 700 I=1,NNVA MELEME=IRIGEL(1,I) SEGACT MELEME NBNN=NUM(/1) NBELEM=NUM(/2) DO 701 I1=1,NBELEM DO 701 I2=1,NBNN IP1=NUM(I2,I1) IF(ICPR(IP1).NE.0) GO TO 701 IKI=IKI+1 ICPR(IP1)=IKI 701 CONTINUE SEGDES MELEME 700 CONTINUE C C **** FABRICATION DU TABLEAU INUINV C **** ON MET LES POINTS QUI ONT POUR INCONNUE ALFA EN TETE C NNOE=IKI NALFA=0 NBETA=0 DO 710 I=1,NNVA MELEME=IRIGEL(1,I) DESCR =IRIGEL(3,I) SEGACT MELEME,DESCR NBNN=NUM(/1) NBELEM=NUM(/2) NLIGRE=LISINC(/2) * SEGINI IPB A QUOI CA SERT PV * DO 703 K=1,NLIGRE * IPB(NOELEP(K))=K *703 CONTINUE DO 711 I1=1,NBELEM DO 711 I2=1,NBNN IP1=NUM(I2,I1) IF(ICPR(IP1).EQ.0) GO TO 711 * IJA=IPB(I2) * IF(IJA.NE.MOALFA) GO TO 715 * NALFA=NALFA+1 * IKI=NALFA * GO TO 716 715 CONTINUE NBETA=NBETA+1 IKI=NNOE-NBETA+1 716 CONTINUE INUINV(IP1)=IKI ICPR(IP1)=0 711 CONTINUE SEGDES MELEME,DESCR * SEGSUP IPB 710 CONTINUE SEGSUP ICPR ICDOUR=NNOE GO TO 800 C C **** ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES C **** GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA OBJETS C **** GEOMETRIQUES ELEMENTAIRES. PUIS ON ENVOIE DANS NUMOPT QUI C **** FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU C **** NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR. C **** LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD C **** DE LA MATRICE, ETC... C 801 CONTINUE IKK=1 722 CONTINUE MELEME=IRIGEL(1,IKK) SEGACT,MELEME DESCR=IRIGEL(3,IKK) SEGACT,DESCR NLIGRE=LISINC(/2) DO 720 K=1,NLIGRE IF(LISINC(K).NE.'LX ') GO TO 721 720 CONTINUE SEGDES,MELEME SEGDES,DESCR IKK=IKK+1 IF(IKK.LE.NNVA) GO TO 722 DO 4862 I=1,NNVA MELEME= IRIGEL(1,I) SEGACT MELEME if (num(/2).eq.0) goto 4862 IF(ITYPEL.EQ.22) THEN DESCR=IRIGEL(3,I ) SEGACT,DESCR K = 3 if (num(/2).le.2) k=num(/2) GO TO 4863 ELSE SEGDES MELEME ENDIF 4862 CONTINUE K=1 do ir=1,nnva MELEME= IRIGEL(1,ir) segact meleme if (num(/2).ne.0.and.itypel.ne.22) goto 4864 enddo call erreur(5) 4864 continue DESCR= IRIGEL(3,ir) SEGACT MELEME,DESCR 4863 CONTINUE 721 IA=NOELEP(K) I1=NUM(IA,1) NBSOUS=0 NBNN=1 NBREF=0 NBELEM=1 SEGDES,MELEME,DESCR SEGINI,MELEME ITYPEL=1 NUM(1,1)=I1 SEGDES,MELEME IMELP=MELEME NBSOUS=NNVA+1 NBREF=0 NBNN=0 NBELEM=0 SEGINI,MELEME LISOUS(1)=IMELP DO 12 I=1,NNVA * write (6,*) ' dans assem1 ',irigel(6,i) LISOUS(I+1)=IRIGEL(1,I) * cas du frottement, on met -22 dans itypel pour le savoir dans numopt IF (IRIGEL(6,i).eq.2) then IPT8=LISOUS(I+1) segact IPT8*mod ipt8.itypel=-22 endif 12 CONTINUE SEGDES,MELEME ICDOUR=0 SEGINI,INUINV SEGDES,INUINV CALL NUMOPT(MELEME,INUINV,ICDOUR) * * deplacer les multiplicateur present dans les super elements do 50 ir=1,nnva ipt5= IRIGEL(1,ir) segact ipt5 if (ipt5.itypel.ne.28) goto 50 descr=irigel(3,ir) segact descr * recherche du plus haut noeud non mult do 51 iel=1,ipt5.num(/2) ihaut=0 do 55 il=1,lisinc(/2) * write (6,*) ' lisinc ',il,lisinc(il) if (lisinc(il).eq.'LX ') goto 55 ihaut=max(ihaut,inuinv(ipt5.num(noelep(il),iel))) 55 continue do 60 il=1,lisinc(/2) if (lisinc(il).eq.'LX ') then * un mult ! on le deplace en ihaut ipmult=inuinv(ipt5.num(noelep(il),iel)) * write (6,*) ' assem1 ipmult ihaut ',ipmult,ihaut if (ipmult.gt.ihaut) goto 60 do j=1,inuinv(/1) if (inuinv(j).gt.ipmult.and.inuinv(j).le.ihaut) > inuinv(j)=inuinv(j)-1 enddo inuinv(ipt5.num(noelep(il),iel))=ihaut endif 60 continue 51 continue 50 continue * segact meleme do i=1,lisous(/1) ipt8=lisous(i) segact ipt8 if (ipt8.itypel.eq.-22) then segact ipt8*mod ipt8.itypel=22 endif segdes ipt8 enddo segdes meleme SEGACT INUINV SEGSUP,MELEME * MELEME=IMELP * SEGSUP,MELEME C C **** CREATION D'UN OBJET GEOMETRIE QU'IL FAUDRA CHANGER EN CAS DE C **** RENUMEROTATION GENERALE.ON PROFITE DE LA BOUCLE POUR CREE LE C **** TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I(NU- C **** MEROTATION LOCALE). C 800 CONTINUE NNOE=ICDOUR SEGINI,IMIN NNOE1=NNOE+1 SEGINI,IPOS NBSOUS=0 NBREF=0 NBNN=1 NBELEM=ICDOUR SEGINI,IPT1 IPT1.ITYPEL=IPOIN DO 16 IRI=1,NNVA * DO 170 I=1,NNOE * 170 IPOS(I)=0 MELEME=IRIGEL(1,IRI) SEGACT,MELEME N1=NUM(/1) N2=NUM(/2) DO 17 I=1,N2 DO 17 J=1,N1 K=NUM(J,I) M=INUINV(K) IF(IPOS(M).NE.I) THEN IMIN(M)=IMIN(M)+1 IPT1.NUM(1,M)=K IPOS(M)=I ENDIF 17 CONTINUE DO 171 I=1,N2 DO 171 J=1,N1 K=NUM(J,I) M=INUINV(K) ipos(m)=0 171 continue SEGDES,MELEME 16 CONTINUE C C **** INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER C **** DANS ITOPO . C SEGINI,IITOP IITOP(1)=1 DO 18 I=1,NNOE IITOP(I+1)=IMIN(I)* 2 + IITOP(I) 18 CONTINUE DO 19 I=1,NNOE 19 IMIN(I)=0 IENNO=IITOP(NNOE+1) SEGINI,ITOPO DO 21 IRI=1,NNVA * DO 220 I=1,NNOE * 220 IPOS(I)=0 C DESCR=IRIGEL(3,IRI) C SEGACT,DESCR C N3=LISINC(/2) C SEGDES,DESCR MELEME=IRIGEL(1,IRI) SEGACT,MELEME N1=NUM(/1) N2=NUM(/2) DO 22 I=1,N2 DO 22 J=1,N1 M=INUINV(NUM(J,I)) IF(IPOS(M).NE.I) THEN IMIN(M)=IMIN(M)+1 IUY= 2* ( IMIN(M)-1 ) + IITOP(M) ITOPO(IUY)=I ITOPO(IUY+1)=IRI IPOS(M)=I ENDIF 22 CONTINUE DO 221 I=1,N2 DO 221 J=1,N1 M=INUINV(NUM(J,I)) IPOS(M)=0 221 CONTINUE SEGDES,MELEME 21 CONTINUE C C RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS C DE L'UTILISATION DE " OPTION MODE FOUR NOHAR " C DO 230 IRI=1,NNVA IHARIR=IRIGEL(5,IRI) IF( IHARIR . NE. NOHA) THEN IARDEF = IHARIR GO TO 231 ENDIF 230 CONTINUE CALL ERREUR ( 21) RETURN 231 CONTINUE DO 232 IRI=1,NNVA IF( IRIGEL(5,IRI) .EQ.NOHA) GO TO 232 IF( IRIGEL(5,IRI).EQ.IARDEF ) GO TO 232 CALL ERREUR (21) RETURN 232 CONTINUE C C **** RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS C SEGINI,MIDUA SEGINI,MIMIK SEGINI,MHARK DESCR=IRIGEL(3,1) SEGACT,DESCR IMIK(**)=LISINC(1) IAAR=IRIGEL(5,1) IF(IAAR.EQ.NOHA) IAAR = IARDEF IHAR(**)= IAAR IDUA(**)=LISDUA(1) MAXINC=1 DO 23 IRI=1,NNVA DESCR=IRIGEL(3,IRI) IHARIR=IRIGEL(5,IRI) IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF SEGACT,DESCR NLIGRE=LISINC(/2) DO 26 I=1,NLIGRE DO 24 J=1,MAXINC IF(IMIK(J).NE.LISINC(I)) GO TO 24 IF(IHAR(J).EQ.IHARIR) GO TO 26 24 CONTINUE MAXINC=MAXINC+1 IHAR(**)=IHARIR IMIK(**)=LISINC(I) IDUA(**)=LISDUA(I) 26 CONTINUE SEGDES,DESCR 23 CONTINUE NDUA=IDUA(/2) C C **** INITIALISATION DE INCPOS ET DE INCTRA. C MAXI=MAXINC SEGINI,MINCPO DO 29 IRI=1,NNVA DESCR=IRIGEL(3,IRI) IHARIR=IRIGEL(5,1) IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF SEGACT,DESCR MELEME=IRIGEL(1,IRI) SEGACT,MELEME NLIGRE=LISINC(/2) SEGINI,INCTRA INCTRR(IRI)=INCTRA N2=NUM(/2) IADS=XCOOR(/1)/(IDIM+1) DO 34 J=1,NLIGRE DO 33 K=1,MAXINC IF(LISINC(J).NE.IMIK(K)) GO TO 33 IF(IHAR(K).EQ.IHARIR) GO TO 32 33 CONTINUE 32 CONTINUE INCTRA(J)=K DO 31 I=1,N2 IJ=INUINV(NUM(NOELEP(J),I)) 31 INCPO(K,IJ)=1 34 CONTINUE SEGDES,DESCR SEGDES,INCTRA SEGDES,MELEME 29 CONTINUE C C **** INITIALISATION DE IPOS C IPOS(1)=0 NA=0 DO 37 I=1,NNOE DO 35 K=1,MAXINC IF(INCPO(K,I).EQ.0) GO TO 35 NA=NA+1 INCPO(K,I)=NA 35 CONTINUE IPOS(I+1)=NA 37 CONTINUE SEGDES,MIDUA,MIMIK,MHARK C C **** INITIALISATION DE IMINI C INC=NA SEGINI,IMINI INC1=INC+1 DO 38 I=1,INC IMINI(I)=INC1 38 CONTINUE DO 40 IRI=1,NNVA MELEME=IRIGEL(1,IRI) SEGACT,MELEME DESCR=IRIGEL(3,IRI) SEGACT,DESCR INCTRA=INCTRR(IRI) SEGACT,INCTRA N1=NOELEP(/1) N2=NUM(/2) N3=NUM(/1) DO 41 I=1,N2 IJ=NNOE+1 DO 42 J=1,N3 IJ1=INUINV(NUM(J,I)) IJ=MIN(IJ1,IJ) 42 CONTINUE IPR=IPOS(IJ)+1 DO 43 JJ=1,N1 IJA=INUINV(NUM(NOELEP(JJ),I)) IJB=INCTRA(JJ) IK=INCPO(IJB,IJA) IMINI(IK)=MIN(IMINI(IK),IPR) 43 CONTINUE 41 CONTINUE SEGDES,DESCR SEGDES,INCTRA SEGDES,MELEME 40 CONTINUE SEGDES,MRIGID SEGDES,IPOS SEGDES,IMINI SEGDES,ITOPO SEGDES,IITOP SEGDES,INUINV SEGDES,IPT1 SEGDES,MINCPO SEGSUP,IMIN SEGDES,INCTRR INCTRY=INCTRR SEGINI,MMATRI NENS=0 IGEOMA=IPT1 IIDUA=MIDUA IINCPO=MINCPO IIMIK=MIMIK IHARK=MHARK INUINY=INUINV ITOPOY=ITOPO IITOPY=IITOP MMATRX=MMATRI IMINIY=IMINI IPOY=IPOS SEGDES,MMATRI RETURN END