Télécharger la plaquette Cast3M


fr en

Télécharger reduic.eso

Retour à la liste

Numérotation des lignes : 

reduic

  1. C REDUIC    SOURCE    PV        20/03/26    21:16:19     10563          
  2.       SUBROUTINE REDUIC ( IPCHE,IMEL,IRET)
  3. *______________________________________________________________________
  4. *
  5. *             redu d'un chamelem sur meleme    (appele par redu)
  6. *
  7. *    entrees :
  8. *    ---------
  9. *       ipche   chamelem a reduire (type mchaml)
  10. *       imel    maillage sur lequel on doit reduire (type meleme)
  11. *
  12. *
  13. *    sortie :
  14. *    --------
  15. *       iret    chamelem reduit
  16. *               = 0 si pb
  17. *
  18. *
  19. *
  20. *______________________________________________________________________
  21. *
  22. *                declarations
  23. *
  24.       IMPLICIT INTEGER(I-N)
  25.       IMPLICIT REAL*8(A-H,O-Z)
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29.  
  30. -INC SMCHAML
  31. -INC SMELEME
  32. *
  33.       CHARACTER*(NCONCH) CONST
  34. *
  35. *                    executable
  36. *
  37.       IRET = 0
  38.       CONST = ' '
  39.  
  40.       MCHELM = IPCHE
  41.       SEGACT,MCHELM
  42.  
  43. * Cas particulier du MCHAML vide :
  44.       NZ = IMACHE(/1)
  45.       IF (NZ.EQ.0) THEN
  46.         SEGINI,MCHEL1=MCHELM
  47. **      SEGDES MCHELM,MCHEL1
  48.         IRET = MCHEL1
  49.         RETURN
  50.       ENDIF
  51.  
  52.       MELEME = IMEL
  53.       SEGACT MELEME
  54.       NBSOUS = LISOUS(/1)
  55.       IPT1 = IMEL
  56. *
  57. *    boucle sur les maillages elementaires
  58. *
  59.       DO 100 I=1,(MAX(1,NBSOUS))
  60.         IF (NBSOUS .NE. 0) THEN
  61.            IPT1 = LISOUS(I)
  62.         ENDIF
  63.         CALL TESTMA(IPCHE,IPT1,.FALSE.,CONST,IRETOU,IMODI)
  64. *
  65.         IF(IRETOU.EQ.0.AND.IERR.EQ.0) THEN
  66.            CALL ERREUR(472)
  67.         ENDIF
  68.         MCHEL1 = IRETOU
  69.         IF (IERR .NE. 0) THEN
  70.               IF (IRETOU .NE. 0) THEN
  71.                 SEGSUP MCHEL1
  72.               ENDIF
  73.               GOTO 990
  74.         ENDIF
  75. *
  76. *    concatenation du resultat
  77. *
  78.          IF (I .EQ. 1) THEN
  79.              MCHELM = IRETOU
  80.              N1 = IMACHE(/1)
  81.              N3 = INFCHE(/2)
  82.              L1 = TITCHE(/1)
  83.          ELSE
  84.              MCHEL1 = IRETOU
  85.              NN1 = MCHEL1.IMACHE(/1)
  86.              N1 = N1 + NN1
  87.              N3 = MAX(N3,MCHEL1.INFCHE(/2))
  88.              SEGADJ MCHELM
  89.              DO 10 J=1,NN1
  90.                CONCHE(J+N1-NN1) = MCHEL1.CONCHE(J)
  91.                IMACHE(J+N1-NN1) = MCHEL1.IMACHE(J)
  92.                ICHAML(J+N1-NN1) = MCHEL1.ICHAML(J)
  93.                DO 20 K=1,MCHEL1.INFCHE(/2)
  94.                   INFCHE(J+N1-NN1,K)=MCHEL1.INFCHE(J,K)
  95.   20           CONTINUE
  96.   10         CONTINUE
  97.              SEGSUP MCHEL1
  98.          ENDIF
  99. *
  100.  100   CONTINUE
  101. *
  102.        IRET = MCHELM
  103. **     SEGDES,MCHELM
  104. *
  105.  990   CONTINUE
  106. C       MELEME = IMEL
  107. C       MCHEL1 = IPCHE
  108. C       SEGDES,MELEME,MCHEL1
  109. *
  110.        RETURN
  111.        END
  112.  
  113.  
  114.  
  115.  
  116.  

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