Sources Esope | Cast3M

prrigi
C PRRIGI    SOURCE    MB234859  24/10/14    21:15:01     12038          
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=IMAX
 
      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)
      write(ioimp,*) 'Option de calcul',IFORIG
 
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)='&lt;'
          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)
              WRITE (IOIMP,TITI) 'Noeuds soumis à la condition :',
     &        (NUM(K,J),K=2,NBNN)
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