Télécharger la plaquette Cast3M


fr en

Télécharger reducp.eso

Retour à la liste

Numérotation des lignes : 

reducp

  1. C REDUCP    SOURCE    CB215821  20/11/25    13:38:51     10792          
  2.       SUBROUTINE REDUCP (MCHPOI,MCHPO1,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.  
  5. -INC PPARAM
  6. -INC CCOPTIO
  7. -INC SMCHPOI
  8. -INC SMELEME
  9. -INC TMTRAV
  10.  
  11.       REAL*8 EPS
  12.       SEGMENT NOINCO
  13.          CHARACTER*(LOCOMP) INC(NMA)
  14.          INTEGER NHA(NMA)
  15.       ENDSEGMENT
  16. *
  17. * VERIFICATION QUE LES DEUX CHPOINTS ONT EXACTEMENT LA MEME STRUCTURE
  18. *
  19.       IF (IPCHP(/1).NE.MCHPO1.IPCHP(/1)) THEN
  20.          CALL ERREUR(21)
  21.          RETURN
  22.       ENDIF
  23.       EPS=1.D-5
  24.       NMA=0
  25.       NNNOE=0
  26.       DO 1 I = 1 , IPCHP(/1)
  27.       MSOUPO=IPCHP(I)
  28.       MSOUP1=MCHPO1.IPCHP(I)
  29.       NMA=NMA+NOCOMP(/2)
  30.       IF(NOCOMP(/2).NE.MSOUP1.NOCOMP(/2)) THEN
  31.          CALL ERREUR(21)
  32.          RETURN
  33.       ENDIF
  34.       DO 2 J=1,NOCOMP(/2)
  35.       IF (NOCOMP(J).EQ.MSOUP1.NOCOMP(J)) THEN
  36.          IF (NOHARM(J).NE.MSOUP1.NOHARM(J)) THEN
  37.             CALL ERREUR (21)
  38.             RETURN
  39.           ENDIF
  40.       ELSE
  41.          CALL ERREUR (21)
  42.          RETURN
  43.       ENDIF
  44.     2 CONTINUE
  45.       MELEME=IGEOC
  46.       IPT1=MSOUP1.IGEOC
  47.       NNNOE=NNNOE+NUM(/2)
  48.       IF(NUM(/2).NE.IPT1.NUM(/2))  THEN
  49.          CALL ERREUR(21)
  50.          RETURN
  51.       ENDIF
  52.    1  CONTINUE
  53. *
  54. *  ON CHERCHE LA DIMENSION DE MTRAV
  55. *
  56.       SEGINI NOINCO
  57.       NNIN=0
  58.       DO 3 I=1,IPCHP(/1)
  59.         MSOUPO=IPCHP(I)
  60.         DO 4 J=1,NOCOMP(/2)
  61.           DO 5 K=1,NNIN
  62.             IF(INC(K).NE.NOCOMP(J)) GOTO 5
  63.             IF(NHA(K).EQ.NOHARM(J)) GOTO 4
  64.     5     CONTINUE
  65.           NNIN=NNIN+1
  66.           INC(NNIN)=NOCOMP(J)
  67.           NHA(NNIN)=NOHARM(J)
  68.     4   CONTINUE
  69.     3 CONTINUE
  70. *
  71. *  CREATION DE MTRAV ET REMPLISSAGE
  72. *
  73.       SEGINI MTRAV
  74.       DO 6 I=1,NNIN
  75.       INCO(I)=INC(I)
  76.       NHAR(I)=NHA(I)
  77.     6 CONTINUE
  78.       NDEJ=0
  79.       DO 7 I=1,IPCHP(/1)
  80.       MSOUPO=IPCHP(I)
  81.       MSOUP1=MCHPO1.IPCHP(I)
  82.       MELEME=IGEOC
  83.       DO 8 J=1,NUM(/2)
  84.       IGEO(J+NDEJ)=NUM(1,J)
  85.    8  CONTINUE
  86.       MPOVAL=IPOVAL
  87.       MPOVA1=MSOUP1.IPOVAL
  88.       DO 9 J=1,NOCOMP(/2)
  89.       DO 10 K=1,NNIN
  90.       IF(INCO(K).EQ.NOCOMP(J)) THEN
  91.          IF(NHAR(K).EQ.NOHARM(J)) THEN
  92.             NHA(J)=K
  93.             GO TO 9
  94.          ENDIF
  95.       ENDIF
  96.   10  CONTINUE
  97.       CALL ERREUR(5)
  98.       RETURN
  99.    9  CONTINUE
  100.       DO 11 J=1,NUM(/2)
  101.       DO 12 K=1,NOCOMP(/2)
  102.       NN=NHA(K)
  103.       IF(ABS(MPOVA1.VPOCHA(J,K)).GT.EPS)  THEN
  104.          BB(NN,NDEJ+J)=VPOCHA(J,K)
  105.          IBIN(NN,NDEJ+J)=1
  106.       ENDIF
  107.    12 CONTINUE
  108.    11 CONTINUE
  109.       NDEJ=NDEJ+NUM(/2)
  110.     7 CONTINUE
  111.  
  112.       CALL CRECHP(MTRAV,IRET)
  113. *
  114. *    on attribut les memes natures
  115.       MCHPO2 = IRET
  116.       NAT   = MAX(1,JATTRI(/1))
  117.       NSOUPO=MCHPO2.IPCHP(/1)
  118.       SEGADJ MCHPO2
  119.       IF ( JATTRI(/1) .NE. 0) THEN
  120.         DO 13 I=1,NAT
  121.           MCHPO2.JATTRI(I)=JATTRI(I)
  122.  13     CONTINUE
  123.       ENDIF
  124. *
  125.       SEGSUP MTRAV,NOINCO
  126.       END
  127.  
  128.  
  129.  

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