Sources Esope | Cast3M

rcodp1
C RCODP1    SOURCE    CB215821  20/11/25    13:38:37     10792          
      SUBROUTINE RCODP1(ICHP1,KDEPL,KMEL1,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C=======================================================================
C  APPELE PAR L OPERATEUR RECO:
C  RECOMBINE LES DEPLACEMENTS RANGES DANS LE MSOLEN KDEPL
C  LE RESULTAT EST MIS DANS IRET             ------------
C
C  PROGRAMME PAR FARVACQUE
C  APPELE PAR RECOMB
C  APPELLE :ECCHPO ERREUR(169-170)
C=======================================================================
 
-INC PPARAM
-INC CCOPTIO
-INC SMSOLUT
-INC SMCHPOI
-INC SMELEME
-INC SMCOORD
      SEGMENT ICPR(nbpts)
      SEGMENT TRAV(NPOIN)*D
      IRET=0
      MSOLEN=KDEPL
C
C  **** ON MET LES CONTRIBUTIONS MODALES ICHP1 DANS ICPR ET TRAV
C
      MCHPOI=ICHP1
      IF(MCHPOI.NE.0) GO TO 11
C     LE CHPOINT DES CONTRIBUTIONS MODALES EST NUL
      MOTERR(1:8)='RCODP1'
      CALL ERREUR(170)
      GO TO 5000
 11   CONTINUE
      SEGINI ICPR
      SEGACT MCHPOI
      NSOU=IPCHP(/1)
      IKI=0
      DO 1 ISOU=1,NSOU
      MSOUPO=IPCHP(ISOU)
      SEGACT MSOUPO
      MELEME=IGEOC
      SEGACT MELEME
      N2=NUM(/2)
      DO 2 I=1,N2
      IKI=IKI+1
      ICPR(NUM(1,I))=IKI
 2    CONTINUE
      SEGDES MELEME,MSOUPO
 1    CONTINUE
      NPOIN=IKI
      SEGINI TRAV
      IKI=0
      DO 3 ISOU=1,NSOU
      MSOUPO=IPCHP(ISOU)
      SEGACT MSOUPO
      MPOVAL=IPOVAL
      SEGACT MPOVAL
      N2=VPOCHA(/1)
      DO 4 I=1,N2
      IKI=IKI+1
      TRAV(IKI)=VPOCHA(I,1)
 4    CONTINUE
      SEGDES MPOVAL,MSOUPO
 3    CONTINUE
      SEGDES MCHPOI
C
C  **** INITIALISATION DE MCHPOI: ON PREND LA STRUCTURE DU 1ER CHPOINT
C  **** DU MSOLEN KDEPL
C
      SEGACT MSOLEN
      MCHPO1=ISOLEN(1)
      SEGACT MCHPO1
      NSOUPO=MCHPO1.IPCHP(/1)
      NAT=MCHPO1.JATTRI(/1)
      SEGINI MCHPOI
      DO 6 ISOU=1,NSOUPO
      MSOUP1=MCHPO1.IPCHP(ISOU)
      SEGACT MSOUP1
      NC=MSOUP1.NOCOMP(/2)
      SEGINI MSOUPO
      DO 7 IC=1,NC
      NOCOMP(IC)=MSOUP1.NOCOMP(IC)
 7    CONTINUE
      IGEOC=MSOUP1.IGEOC
      MELEME=IGEOC
      SEGACT MELEME
      N=NUM(/2)
      SEGDES MELEME,MSOUP1
      SEGINI MPOVAL
      SEGDES MPOVAL
      IPOVAL=MPOVAL
      SEGDES MSOUPO
      IPCHP(ISOU)=MSOUPO
 6    CONTINUE
      SEGDES MCHPO1
C
C  **** BOUCLE SUR LES DEPLACEMENTS DE DEPL
C
      MELEME=KMEL1
      SEGACT MELEME
      LDEPL=ISOLEN(/1)
      DO 20 I=1,LDEPL
      IJ=NUM(1,I)
      J=ICPR(IJ)
      IF(J.NE.0) GO TO 21
C     ON NE TROUVE PAS LA CONTRIBUTION MODALE CORRESPONDANT A L INDICE
      MOTERR(1:8)='RCODP1'
      INTERR(1)=IJ
      CALL ERREUR(169)
      GO TO 5000
 21   CONTINUE
      XVAL=TRAV(J)
      MCHPO1=ISOLEN(I)
      SEGACT MCHPO1
      DO 25 ISOU=1,NSOUPO
      MSOUP1=MCHPO1.IPCHP(ISOU)
      MSOUPO=IPCHP(ISOU)
      SEGACT MSOUP1,MSOUPO
      MPOVA1=MSOUP1.IPOVAL
      MPOVAL=IPOVAL
      SEGDES MSOUP1
      SEGACT MPOVA1
      SEGACT MPOVAL*MOD
      N=MPOVA1.VPOCHA(/1)
      NC=MPOVA1.VPOCHA(/2)
      DO 27 IC=1,NC
      DO 27 I2=1,N
      VPOCHA(I2,IC)=VPOCHA(I2,IC)+XVAL*MPOVA1.VPOCHA(I2,IC)
 27   CONTINUE
      SEGDES MPOVA1,MPOVAL
      SEGDES MSOUPO
 25   CONTINUE
      SEGDES MCHPO1
 20   CONTINUE
      SEGDES MSOLEN,MELEME
      SEGSUP TRAV
      SEGSUP ICPR
      SEGDES MCHPOI
      IRET=MCHPOI
      IF(IIMPI.EQ.3)CALL ECCHPO(IRET,0)
 5000 CONTINUE
      RETURN
      END