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    PV090527  25/01/07    14:42:56     12115          
  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. -INC SMCOORD
  30.  
  31. -INC SMCHAML
  32. -INC SMELEME
  33. *
  34.       CHARACTER*(NCONCH) CONST
  35. *
  36. *                    executable
  37. *
  38.       IRET = 0
  39.       CONST = ' '
  40.  
  41.       MCHELM = IPCHE
  42.       SEGACT,MCHELM
  43.  
  44. * Cas particulier du MCHAML vide :
  45.       NZ = IMACHE(/1)
  46.       IF (NZ.EQ.0) THEN
  47.         SEGINI,MCHEL1=MCHELM
  48. **      SEGDES MCHELM,MCHEL1
  49.         IRET = MCHEL1
  50.         RETURN
  51.       ENDIF
  52.  
  53.       MELEME = IMEL
  54.       SEGACT MELEME
  55.       NBSOUS = LISOUS(/1)
  56.       IPT1 = IMEL
  57. *
  58. *    boucle sur les maillages elementaires
  59. *
  60.       DO 100 I=1,(MAX(1,NBSOUS))
  61.         IF (NBSOUS .NE. 0) THEN
  62.            IPT1 = LISOUS(I)
  63.         ENDIF
  64.         CALL TESTMA(IPCHE,IPT1,.FALSE.,CONST,IRETOU,IMODI)
  65. *
  66.         IF(IRETOU.EQ.0.AND.IERR.EQ.0) THEN
  67.            CALL ERREUR(472)
  68.         ENDIF
  69.         MCHEL1 = IRETOU
  70.         IF (IERR .NE. 0) THEN
  71.               IF (IRETOU .NE. 0) THEN
  72.                 SEGSUP MCHEL1
  73.               ENDIF
  74.               GOTO 990
  75.         ENDIF
  76. *
  77. *    concatenation du resultat
  78. *
  79.          IF (I .EQ. 1) THEN
  80.              MCHELM = IRETOU
  81.              N1 = IMACHE(/1)
  82.              N3 = INFCHE(/2)
  83.              L1 = TITCHE(/1)
  84.          ELSE
  85.              MCHEL1 = IRETOU
  86.              NN1 = MCHEL1.IMACHE(/1)
  87.              N1 = N1 + NN1
  88.              N3 = MAX(N3,MCHEL1.INFCHE(/2))
  89.              SEGADJ MCHELM
  90.              DO 10 J=1,NN1
  91.                CONCHE(J+N1-NN1) = MCHEL1.CONCHE(J)
  92.                IMACHE(J+N1-NN1) = MCHEL1.IMACHE(J)
  93.                ICHAML(J+N1-NN1) = MCHEL1.ICHAML(J)
  94.                DO 20 K=1,MCHEL1.INFCHE(/2)
  95.                   INFCHE(J+N1-NN1,K)=MCHEL1.INFCHE(J,K)
  96.   20           CONTINUE
  97.   10         CONTINUE
  98.              SEGSUP MCHEL1
  99.          ENDIF
  100. *
  101.  100   CONTINUE
  102. *
  103.        IRET = MCHELM
  104. **     SEGDES,MCHELM
  105. *
  106.  990   CONTINUE
  107. C       MELEME = IMEL
  108. C       MCHEL1 = IPCHE
  109. C       SEGDES,MELEME,MCHEL1
  110. *
  111.        RETURN
  112.        END
  113.  
  114.  
  115.  
  116.  
  117.  
  118.  

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