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    PV        22/04/15    17:10:50     11344          
  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.         IF (INSYM .EQ. 0) THEN
  121.          CALL TRIANG (mrigid,xspetl,0)
  122.         ELSE
  123.          CALL ldmt1(mrigid,xspetl)
  124.         ENDIF
  125.          IF (IERR .NE. 0) RETURN
  126.          MRIGID = IPRIGI
  127.          SEGACT,MRIGID
  128.          IPMATR = ICHOLE
  129.       END IF
  130.       endif
  131.       if (isupt.ne.0) then
  132.        mtable = isupt
  133.        segact mtable
  134.          CALL ACCTAB(mtable,'ENTIER',13,0.d0,' ',.true.,IP0,
  135.      &                   'ENTIER',infer0,X1,CHARRE,.true.,ITMOD)
  136. *      write (6,*) ' unilateral nbneg ',infer0
  137.        segdes mtable
  138.       END IF
  139. *
  140.  
  141.       if (ichole.ne.0.and.isupt.eq.0) then
  142.       MMATRI = ichole
  143.       SEGACT,MMATRI
  144.       INFER0 = INEG
  145.       SEGDES,MMATRI
  146.       else
  147. ***   infer0=0
  148.       endif
  149. *
  150.       END
  151.  
  152.  
  153.  
  154.  
  155.  
  156.  

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