C PRRIGI SOURCE PV090527 26/04/30 21:16:00 12529 c imprime les matrices de rigidite pointeur de l objet=iret c SUBROUTINE PRRIGI(IRET,JENTET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMRIGID CHARACTER*24 TITI,TOTO,TOTO2 c nombre de matrices elementaires a afficher (anciennement =10 en dur) PARAMETER(NRESU=2) c C eventuellement, on lit le nombre de valeurs de REL a afficher avant de C revenir a la ligne NMAX=39 CALL LIRENT(IMAX,0,IRETOU) IF (IRETOU.NE.0) NMAX=MIN(IMAX,999) MRIGID=IRET if (mrigid.le.0) then call erreur(26) return endif SEGACT MRIGID NRI=IRIGEL(/1) NR=IRIGEL(/2) c ERREUR(-26): Matrice de %m1:8 formée de %i1 matrice(s) élémentaire(s) MOTERR(1:8)=MTYMAT INTERR(1)=IRET INTERR(2)=NR CALL ERREUR(-26) C Option de calcul (on suppose que IFOPOI correspond a IFOUR) IF (IFORIG.LE.-1) THEN MOTERR(1:32)=' PLAN ' ELSE IF (IFORIG.EQ.0) THEN MOTERR(1:32)=' AXISYMETRIQUE ' ELSE IF (IFORIG.EQ.1) THEN MOTERR(1:32)=' SERIE DE FOURIER ' ELSE IF (IFORIG.EQ.2) THEN MOTERR(1:32)=' TRIDIMENSIONNEL ' ELSE IF (IFORIG.GE.3.AND.IFORIG.LE.11) THEN MOTERR(1:32)=' UNID PLAN ' ELSE IF (IFORIG.GE.12.AND.IFORIG.LE.14) THEN MOTERR(1:32)=' UNID AXISYMETRIQUE ' ELSE IF (IFORIG.EQ.15) THEN MOTERR(1:32)=' UNID SPHERIQUE ' ELSE IF (IFORIG.EQ.16) THEN MOTERR(1:32)=' FREQUENTIEL ' ENDIF CALL ERREUR(-23) c --- boucle sur les sous-rigidites ------------------------------------ DO 191 I=1,NR MELEME = IRIGEL(1,I) SEGACT MELEME xMATRI = IRIGEL(4,I) SEGACT xMATRI NMA=re(/3) DESCR=IRIGEL(3,I) NEGALI=IRIGEL(6,I) SEGACT DESCR NINC=LISINC(/2) NINCD=LISDUA(/2) c ERREUR(-27): Sous matrice %i1 : %i2 éléments : %i3 x %i4 inconnue(s) par matrice c Coefficient multiplicateur %r1 : Harmonique %i5 INTERR(1)=I INTERR(2)=NMA INTERR(3)=NINC INTERR(4)=NINCD REAERR(1) = COERIG(I) INTERR(5) = IRIGEL(5,I) CALL ERREUR(-27) IF (NRI.GE.7) THEN IANTI=IRIGEL(7,I) IF (IANTI.EQ.0) THEN CALL ERREUR(-274) ELSE IF (IANTI.EQ.1) THEN CALL ERREUR(-275) ELSE IF (IANTI.EQ.2) THEN CALL ERREUR(-307) ELSE IF (IANTI.EQ.3) THEN CALL ERREUR(-320) ENDIF ELSE CALL ERREUR(-274) ENDIF c ... désormais inutile ... interr(1)=negali c ERREUR(-28): Nature des matrices : "%m1:1" c Noeuds Inconnue : (les %i2 premières sont primales) IF(NEGALI.EQ.0) THEN MOTERR(1:1)='=' ELSE IF(NEGALI.EQ.-1) THEN MOTERR(1:1)='>' ELSE IF(NEGALI.EQ. 1) THEN MOTERR(1:1)='<' ELSE MOTERR(1:1)='?' ENDIF INTERR(2)=NINC CALL ERREUR(-28) c ecriture du DESCR WRITE(IOIMP,194)(NOELEP(J),LISINC(J),J=1,NINC) WRITE(IOIMP,194)(NOELED(J),LISDUA(J),J=1,NINCD) 194 FORMAT( I6,9X,A4) C ERREUR (-29): Liste des points associés aux matrices CALL ERREUR (-29) NBNN=NUM(/1) NBELEM=NUM(/2) c option 'RESUM' : on n'affiche que les NRESU premiers elements nbi=nbelem if(jentet.eq.1) nbi=min (NRESU,nbi) NBNN2=min(NBNN,NMAX) WRITE(TITI,FMT='("( A,",I3,"( A,I3))")') NBNN2 WRITE(IOIMP,TITI) ' element :',(' pt',IKK,IKK=1,NBNN) WRITE(TITI,FMT='("(I8,A,",I3,"(1X,I8))")') NBNN2 DO 1000 INNN=1,NBi WRITE(IOIMP,TITI) INNN,' :',(NUM(IKK,INNN),IKK=1,NBNN) 1000 CONTINUE IF(ITYPEL.NE.22) GOTO 199 c - Cas des multiplicateurs de Lagrange - C ERREUR(-30): Maillage %i1 associé à la condition INTERR(1)=MELEME CALL ERREUR(-30) NBPOIN=NUM(/2) NBNN=NUM(/1) c option 'RESUM' : on n'affiche que les NRESU premiers elements nbi=nbpoin if( jentet.eq.1) nbi=min (NRESU,nbi) NBNN2=min(NBNN,NMAX) WRITE(TITI,FMT='("(1X,A,1X,",I3,"(1X,I8))")') NBNN2 DO 198 J=1,nbi IF (IERR.NE.0) RETURN c C ERREUR(-31): Noeuds soumis à la condition : c CALL ERREUR(-31) c ecriture des noeuds hors LX (suppose etre en position 1) IF (LANGUE.EQ.'ANGL') THEN WRITE (IOIMP,TITI) 'Nodes subject to the condition :', & (NUM(K,J),K=2,NBNN) ELSE WRITE (IOIMP,TITI) 'Noeuds soumis a la condition :', & (NUM(K,J),K=2,NBNN) ENDIF c ecriture du noeud LX (suppose etre en position 1) c ERREUR(-32): Multiplicateurs de Lagrange : %i1 INTERR(1)=NUM(1,J) CALL ERREUR(-32) 198 CONTINUE 199 CONTINUE c - Fin du Cas des multiplicateurs de Lagrange - c --- boucle sur le matrices elementaires --- if(jentet.eq.1) nma=min(nma,NRESU) DO 196 IA=1,NMA IF (IERR.NE.0) RETURN NVA=RE(/1) NVB=RE(/2) C ERREUR(-33): Matrice élémentaire numéro : %i1 ( ligne1,ligne2,ligne3...) INTERR(1)= IA CALL ERREUR(-33) C ecriture des matrices elementaires REL c ecriture ligne par ligne c NMAX= nbre de valeurs max = (nbre caracteres max -1espace -3points) c = (512)/13 = 39 par exemple if(NVB.le.NMAX) then if (jentet.eq.1) then WRITE(TOTO,FMT='("(",I3,"(1X,E12.5),1X,A)")') NVB else WRITE(TOTO,FMT='("(",I3,"(1X,E20.13),1X,A)")') NVB endif do L=1,NVA if (nvb.ne.0) then WRITE(IOIMP,FMT=TOTO) (RE(L,jou,IA),jou=1,NVB),';' endif enddo else nbloc=NVB/NMAX if (jentet.eq.1) then WRITE(TOTO,FMT='("(",I3,"(1X,E12.5),1X,A)")') NMAX else WRITE(TOTO,FMT='("(",I3,"(1X,E20.13),1X,A)")') NMAX endif nrest = NVB-(NMAX*nbloc) c on s assure que : NMAX >= nrest > 0 if(nrest.eq.0) then nbloc=nbloc-1 nrest=NMAX endif if (jentet.eq.1) then WRITE(TOTO2,FMT='("(",I3,"(1X,E12.5),1X,A)")') nrest else WRITE(TOTO2,FMT='("(",I3,"(1X,E20.13),1X,A)")') nrest endif do L=1,NVA jdeb=1 if(nbloc.gt.0) then do jbloc=1,nbloc WRITE(IOIMP,FMT=TOTO) (RE(L,jou,IA),jou=jdeb,(jdeb+NMAX-1)),'...' jdeb=jdeb+NMAX enddo endif WRITE(IOIMP,FMT=TOTO2) (RE(L,jou,IA),jou=jdeb,NVB),';' enddo endif 196 CONTINUE c --- fin de boucle sur le matrices elementaires --- * SEGDES DESCR * SEGDES MELEME * SEGDES xMATRI 191 CONTINUE c --- fin de boucle sur les sous-rigidites ----------------------------- * SEGDES MRIGID RETURN END