Sources Esope | Cast3M

prrigi
C PRRIGI    SOURCE    SP204843  23/09/21    21:15:06     11745          
c     imprime les matrices de rigidite pointeur de l objet=iret
c
      SUBROUTINE PRRIGI(IRET,JENTET)
      IMPLICIT INTEGER(I-N)
-INC SMRIGID
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
      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
          IGEO=IRIGEL(1,I)
          xMATRI=IRIGEL(4,I)
          SEGACT xMATRI
          NMA=re(/3)
          DESCR=IRIGEL(3,I)
          NNHA=IRIGEL(5,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)=NNHA
          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)
          SEGDES DESCR
          MELEME=IGEO
          SEGACT MELEME
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
c               WRITE(IOIMP,1001)(NUM(IKK,INNN),IKK=1,NBNN)
          WRITE(IOIMP,TITI) INNN,' :',(NUM(IKK,INNN),IKK=1,NBNN)
 1000     CONTINUE
c  1001     FORMAT(15I8)
 
          IF(ITYPEL.NE.22) GOTO 199
c       - Cas des multiplicateurs de Lagrange -
C ERREUR(-30): Maillage %i1 associé à la condition
          INTERR(1)=IGEO
          CALL ERREUR(-30)
          NBPOIN=NUM(/2)
          NBNN=NUM(/1)
c         option 'RESUM' : on n'affiche que les NRESU premiere elements
          nbi=nbpoin
          if( jentet.eq.1) nbi=min (NRESU,nbi)
          NBNN2=min(NBNN,NMAX)
c           WRITE(TITI,FMT='("(27X,",I3,"(1X,I8))")') NBNN2
          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)
c               WRITE (IOIMP,203) (NUM(K,J),K=2,NBNN)
c               WRITE (IOIMP,TITI) (NUM(K,J),K=2,NBNN)
              WRITE (IOIMP,TITI) 'Noeuds soumis à la condition :',
     &        (NUM(K,J),K=2,NBNN)
c  203          FORMAT(30X,10I8)
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 -
          SEGDES MELEME
 
c     --- boucle sur le matrices elementaires ---
          if(jentet.eq.1) nma=min(nma,NRESU)
          DO 196 IA=1,NMA
              IF (IERR.NE.0) RETURN
*              XMATRI=IMATTT(IA)
**              SEGACT XMATRI
              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               WRITE(IOIMP,195) ((RE(L,K,ia),K=1,NVB),L=1,NVA)
c   195         FORMAT(1X,6E12.5)
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
                WRITE(TOTO,FMT='("(",I3,"(1X,E12.5),1X,A)")') NVB
                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
                WRITE(TOTO,FMT='("(",I3,"(1X,E12.5),1X,A)")') NMAX
                nrest = NVB-(NMAX*nbloc)
c               on s assure que : NMAX >= nrest > 0
                if(nrest.eq.0) then
                  nbloc=nbloc-1
                  nrest=NMAX
                endif
                WRITE(TOTO2,FMT='("(",I3,"(1X,E12.5),1X,A)")') nrest
                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
*              SEGDES XMATRI
  196     CONTINUE
c     --- fin de boucle sur le matrices elementaires ---
          SEGDES MELEME
          SEGDES xMATRI
 
  191 CONTINUE
c --- fin de boucle sur les sous-rigidites -----------------------------
      SEGDES MRIGID
      RETURN
      END