Sources Esope | Cast3M

diagne
C DIAGNE    SOURCE    PB245956  20/12/21    21:15:05     10747          
      SUBROUTINE DIAGNE
************************************************************************
*
*                             D I A G N E
*                             -----------
*
*            SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "DIAGNEG"
*
* FONCTION:
* ---------
*     DONNER LE NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA MATICE
*     DIAGONALE "D" D'UNE 'RIGIDITE' DECOMPOSEE EN L.D.LT
*
* PHRASE D'APPEL (EN GIBIANE):
* ----------------------------
*     NOMBRE = DIAGNEG RIGID ;
*
* ARGUMENTS (EN GIBIANE):
* -----------------------
*     RIGID     'RIGIDITE'  MATRICE DE RIGIDITE.
*     NOMBRE    'ENTIER  '  NOMBRE DE TERMES DIAGONAUX NEGATIFS.
*
* DICTIONNAIRE DES VARIABLES: (ORDRE ALPHABETIQUE)
* ---------------------------
*     IPRIGI  ENTIER    POINTEUR SUR "RIGID".
*     INFER0  ENTIER    CONTENU DE "NOMBRE".
*
* SOUS-PROGRAMMES APPELES: LIRE, ECRIRE, DIAGN1.
*
* CREATION: PASCAL MANIGOT, 8 OCTOBRE 1984
* MODIF : - correction bug si on utilise DIAG puis RESO (BP, 12/05/2011)
*           en utilisant syntaxe de RESOU
*         - idem mais en gardant la syntaxe d'origine (BP, 12/09/2011)
*          - grand menage: hormis la lecture des entrees, tout est
*            sous traite a diagn1 (pb, dec2020)
* LANGAGE: FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS
*
************************************************************************
*
      IMPLICIT INTEGER(I-N)
 
-INC PPARAM
-INC CCOPTIO
*-INC SMRIGID
*-INC SMELEME
 
*      INTEGER lagdu
*
*
*
cpb nov2020: variable denevue caduque
c      lagdu=0
      ICODE = 1
      CALL LIROBJ ('RIGIDITE',IPRIGI,ICODE,IRETOU)
      if (ierr.ne.0) return
 
c c bp: ancienne methode -----------------------------------------------*
c       call dbblx(iprigi,lagdu)
c       IF(IERR .NE. 0) RETURN
 
c c bp: nouvelle methode (basee sur RESOU) -----------------------------*
c       IPRIG0=IPRIGI
c       ipoiri=IPRIGI
c *  verification pas de blocage en double
c       call verlag(ipoiri)
c       if(ierr.ne.0) return
c *     y a t il des matrices de relations non unilaterales
c       ipoir0 = ipoiri
c       mrigid=ipoiri
c       segact mrigid
c       nrige= irigel(/1)
c       idepe=0
c       nbr = irigel(/2)
c       do 1000 irig = 1,nbr
c        meleme=irigel(1,irig)
c        segact meleme
c        if((irigel(6,irig).eq.0.or.nounil.eq.1).and.itypel.eq.22)
c      &    idepe=idepe+1
c        if(irigel(6,irig).ne.0) iunil=1
c        segdes meleme
c 1000  continue
c *      idepe=0
c       lagdua=0
c
c       if (idepe.ne.0) then
c
c C  on va separer les raideurs
c        if (jrcond.eq.0) then
c          call separm(mrigid,ri1,ri2,nounil,lagdua)
c          segact mrigid*mod
c          jrelim=ri1
c          jrgard=ri2
c          imlag=lagdua
c          call fusrig(ri1,ri2,ipoir0)
c          jrtot=ipoir0
c        else
c          ri1=jrelim
c          ri2=jrgard
c          ipoir0=jrtot
c          lagdua=imlag
c          ipt1=lagdua
c          if(ipt1.ne.0) segact ipt1
c        endif
c        iri1s=ri1
c        iri2s=ri2
c C
c 1010   continue
c C
c *    mrigid matrice complete
c *    ri1    dependance
c *    ri2    les autres matrices
c *    ri6    matrice de transfert
c *    ri3    matrice reduite
c *    ri5    matrice de transfert transposee
c C
c C   on va proceder  a la condensation rigidite
c        if (jrcond.eq.0) then
c          CALL DEPEN3(RI1,RI6)
c          call scnd2 (ri2,ri6,ri3)
c          segact ri3
c          if (ierr.ne.0) then
c            segsup ri1,ri2,ri6
c            return
c          endif
c          segact mrigid*mod
c          jrcond=ri3
c          JRDEPP=RI6
c C     dualisation  de la (les) matrice(s) de dependance
c          call dual00(ri6,ri5)
c          jrdepd=ri5
c          ipoiri = ri3
c        else
c          ipoiri= jrcond
c          RI6   = JRDEPP
c          ri5   = jrdepd
c        endif
c *  test si ri3 est vide
c          ri3=jrcond
c          segact ri3
c          if(ri3.irigel(/2).eq.0) imtvid=1
c C
c       segdes ri1,ri2,mrigid
c
c       noid = 1
c       endif
c
c * bp : on fournit ipoiri = jrcond de IPRIG0 a DIAGN1 qui fait le reste
c       IPRIGI=ipoiri
 
c bp: ancienne methode corrigée --------------------------------------*
*     on travaille desormais sur une copie locale du mrigid
c
c      mrigid=IPRIGI
c      segini,RI1=mrigid
c      IPRIGI=RI1
c      
*pb nov20: plus necessaire de dualiser grace a rigeli
*      segact ri1
*      imlagl = ri1.imlag
*      if (imlagl.eq.0) call dbblx(iprigi,lagdu)
*      IF(IERR .NE. 0) RETURN
*             
c bp: fin de la distinction entre methodeS ----------------------------*
*
      CALL DIAGN1 (IPRIGI,INFER0)
      IF(IERR.NE.0) RETURN
*
      CALL ECRENT (INFER0)
*
c
*     destruction objets "locaux" (version ancienne methode corrigée)
c      SEGSUP RI1
c pb aout20: plus necessaire car plus de dualisation
c      ipt1=lagdu
c      if(imlagl.eq.0.and.ipt1.ne.0) segsup,ipt1
c*
      END