Télécharger la plaquette Cast3M


fr en

Télécharger diagn1.eso

Retour à la liste

Numérotation des lignes : 

diagn1

  1. C DIAGN1    SOURCE    MB234859  26/08/26    21:15:12     12626          
  2.       SUBROUTINE DIAGN1 (IPRIG0,INFER0)
  3. ************************************************************************
  4. *
  5. *                             D I A G N 1
  6. *                             -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. *     EXECUTER LA FONCTION ATTRIBUEE A L'OPERATEUR "DIAGNEG".
  12. *
  13. * MODE D'APPEL:
  14. * -------------
  15. *
  16. *     CALL DIAGN1 (IPRIGI,INFER0)
  17. *
  18. * PARAMETRES:  (E)=ENTREE   (S)=SORTIE
  19. * -----------
  20. *
  21. *     IPRIGI  ENTIER    (E)  POINTEUR D'UNE 'RIGIDITE'.
  22. *     INFER0  ENTIER    (S)  NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA
  23. *                            MATRICE DIAGONALE "D" DE LA 'RIGIDITE'
  24. *                            DECOMPOSEE EN "L.D.LT"
  25. *
  26. * AUTEUR, DATE DE CREATION:
  27. * -------------------------
  28. *
  29. *     PASCAL MANIGOT     8 OCTOBRE 1984
  30. *
  31. * LANGAGE:
  32. * --------
  33. *
  34. *     ESOPE + FORTRAN77
  35. *
  36. ************************************************************************
  37. *
  38.       IMPLICIT INTEGER(I-N)
  39.       IMPLICIT REAL*8(A-H,O-Z)
  40.  
  41. -INC PPARAM
  42. -INC CCOPTIO
  43. -INC SMMATRI
  44. -INC SMRIGID
  45. -INC SMTABLE
  46. -INC CCREEL
  47. *
  48.  
  49.       SEGMENT IDEMEM(0)
  50.       SEGMENT IDEME0(IDEMEM(/1),2)
  51.       SEGMENT IDEME1(IDEMEM(/1),2)
  52.  
  53.       integer insym
  54.       xspetl = xspeti
  55.       infer0 = 0
  56.       isupt = 0
  57.       insym = 0
  58.  
  59. *-----------------------------------------------------------------------
  60. * pb dec20: condensation d'une copie de la rigidite
  61.       SEGINI IDEMEM,IDEME0,IDEME1
  62.       IBIDON=0
  63.       CALL RIGELI(IPRIG0,0,0,IPRIGI,IBIDON,IBIDON,
  64.      &                       IDEMEM,IDEME0,IDEME1,IELIM)
  65. *-----------------------------------------------------------------------
  66.  
  67.  
  68.       MRIGID = IPRIGI
  69.       SEGACT,MRIGID
  70.       isupt = isupeq
  71. **    write(6,*) ' isupt 1 dans diagn1 ',isupt
  72. *     write (6,*) ' isupeq 1 ',isupeq
  73.       ipoiri = jrcond
  74.       if (ipoiri.ne.0) then
  75.        mrigid = ipoiri
  76.        segact mrigid
  77.        if (isupt.eq.0) isupt = isupeq
  78. **    write(6,*) ' isupt 2 dans diagn1 ',isupt
  79. *     write (6,*) ' isupoq 2 ',isupeq
  80.       endif
  81.       NRG = IRIGEL(/1)
  82.       NBR = IRIGEL(/2)
  83.       if (nbr.eq.0) then
  84.        infer0 = 0
  85.        segdes mrigid
  86.        return
  87.       endif
  88.       IPMATR = ICHOLE
  89.       IF(NORINC.GT.0  .AND. NORIND.GT.0) THEN
  90.          INSYM = 1
  91.       ENDIF
  92.       IF (NRG.GE.7) THEN
  93.          DO  9 IN = 1,NBR
  94.             IANTI=IRIGEL(7,IN)
  95.             IF(IANTI.GT.0) THEN
  96.                INSYM = 1
  97.             ENDIF
  98.   9      CONTINUE
  99.       ENDIF
  100. **    SEGDES,MRIGID
  101. *
  102.       mrigid=iprigi
  103.       do ifois=1,29
  104. *     write(6,*) 'diagn1 ifois ipmatr mrigid ',ifois,ipmatr,mrigid
  105.       if (jrcond.ne.0) then
  106.       mrigid=jrcond
  107.       segact mrigid
  108.       nbr=irigel(/2)
  109.       if (nbr.eq.0) then
  110.        infer0 = 0
  111. *      write(6,*) ' diagn1 nbr 0 '
  112.        segdes mrigid
  113.        return
  114.       endif
  115.       if(isupt.eq.0) isupt=isupeq
  116.       endif
  117.       enddo
  118.       if (ichole.eq.0) then
  119.       IF (IPMATR .EQ. 0) THEN
  120.         CALL TRIANG(mrigid,xspetl,0,0,INSYM)
  121.         IF (IERR .NE. 0) RETURN
  122.         MRIGID = IPRIGI
  123.         SEGACT,MRIGID
  124.         IPMATR = ICHOLE
  125.       ENDIF
  126.       endif
  127.       if (isupt.ne.0) then
  128.        mtable = isupt
  129.        segact mtable
  130.          CALL ACCTAB(mtable,'ENTIER',13,0.d0,' ',.true.,IP0,
  131.      &                   'ENTIER',infer0,X1,CHARRE,.true.,ITMOD)
  132. *      write (6,*) ' unilateral nbneg ',infer0
  133.        segdes mtable
  134.       END IF
  135. *
  136.  
  137.       if (ichole.ne.0.and.isupt.eq.0) then
  138.       MMATRI = ichole
  139.       SEGACT,MMATRI
  140.       INFER0 = INEG
  141.       SEGDES,MMATRI
  142.       else
  143. ***   infer0=0
  144.       endif
  145. *
  146.       END
  147.  
  148.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales