Esope source files

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