Sources Esope | Cast3M

rcosig
C RCOSIG    SOURCE    CB215821  20/11/25    13:38:38     10792          
      SUBROUTINE RCOSIG(ICHP1,KCON,KMEL1,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
*_______________________________________________________________________
*
*  APPELE PAR L OPERATEUR RECO:
*  RECOMBINE LES CONTRAINTES RANGEES DANS LE MSOLEN KCON
*  LE RESULTAT EST MIS DANS IRET             ------------
*
*  PROGRAMME PAR BROCHARD
*  APPELE PAR RECOMB
*  APPELLE :PRCHEL ERREUR(169-170)
*
*  PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 01/91
*_______________________________________________________________________
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMSOLUT
-INC SMCHPOI
-INC SMELEME
-INC SMCOORD
-INC SMCHAML
      SEGMENT ICPR(nbpts)
      SEGMENT ITRA1(NSOUS,4)
      SEGMENT TRAV(NPOIN)*D
      IRET=0
      MSOLEN=KCON
*
*     ON MET LES CONTRIBUTIONS MODALES ICHP1 DANS ICPR ET TRAV
*
      MCHPOI=ICHP1
      IF(MCHPOI.NE.0) GO TO 11
*
*     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
*
*      INITIALISATION DU CHAMELEM
*
      SEGACT MSOLEN
      NBCHAM=ISOLEN(/1)
      IPCHE1=ISOLEN(1)
*
      MCHEL1=IPCHE1
      SEGINI,MCHELM=MCHEL1
      NSOUS=ICHAML(/1)
      SEGINI ITRA1
      DO 120 ISOUS=1,NSOUS
         ITRA1(ISOUS,1)=IMACHE(ISOUS)
         MCHAM1=ICHAML(ISOUS)
         SEGINI,MCHAML=MCHAM1
         ICHAML(ISOUS)=MCHAML
         ITRA1(ISOUS,2)=MCHAML
 120  CONTINUE
*
      DO 200 ICHAM=1,NBCHAM
         IPCHE1=ISOLEN(ICHAM)
*
         MCHEL1=IPCHE1
         SEGACT MCHEL1
         DO 210 ISOUS=1,NSOUS
            IPMAIL=ITRA1(ISOUS,1)
            IF ( IPMAIL.NE.MCHEL1.IMACHE(ISOUS) ) THEN
               SEGDES MCHEL1
               CALL ERREUR(21)
               GOTO 9990
            ENDIF
            MCHAM1=MCHEL1.ICHAML(ISOUS)
            SEGACT MCHAM1
            MCHAML=ITRA1(ISOUS,2)
            NCOMP=IELVAL(/1)
            NCCHE=MCHAM1.NOMCHE(/2)
            DO 199 ICOMP=1,NCOMP
               CALL PLACE(MCHAM1.NOMCHE,NCCHE,IPLAC,
     &                      NOMCHE(ICOMP))
               IF (IPLAC.EQ.0) THEN
                  SEGDES MCHAM1
                  SEGDES MCHEL1
                  CALL ERREUR(21)
                  GOTO 9990
               ENDIF
               MELVA1=MCHAM1.IELVAL(IPLAC)
               SEGACT MELVA1
               N1PTEL=MELVA1.VELCHE(/1)
               N1EL  =MELVA1.VELCHE(/2)
               ITRA1(ISOUS,3)=MAX(ITRA1(ISOUS,3),N1PTEL)
               ITRA1(ISOUS,4)=MAX(ITRA1(ISOUS,4),N1EL  )
               SEGDES MELVA1
 199        CONTINUE
            SEGDES MCHAM1
 210     CONTINUE
         SEGDES MCHEL1
 200  CONTINUE
C
      DO 220 ISOUS=1,NSOUS
         MCHAML=ITRA1(ISOUS,2)
         NCOMP=IELVAL(/1)
         N1PTEL=ITRA1(ISOUS,3)
         N1EL  =ITRA1(ISOUS,4)
         N2PTEL=0
         N2EL=0
         DO 221 ICOMP=1,NCOMP
            SEGINI MELVAL
            IELVAL(ICOMP)=MELVAL
 221     CONTINUE
 220  CONTINUE
*
      IRET=MCHELM
*
*     BOUCLES SUR LES CONTRAINTES MODALES
*
      MELEME=KMEL1
      SEGACT MELEME
      LCON=ISOLEN(/1)
      DO 300 I=1,LCON
         IJ=NUM(1,I)
         J=ICPR(IJ)
         IF(J.NE.0) GOTO 310
*
*        ON NE TROUVE PAS LA CONTRIBUTION MODALE
*
         MOTERR(1:8)='RCODP1'
         INTERR(1)=IJ
         CALL ERREUR(169)
         CALL DTCHAM(IRET)
         GOTO 5000
*
310      CONTINUE
         XVAL=TRAV(J)
         IPCHE1=ISOLEN(I)
*
         MCHEL1=IPCHE1
         SEGACT MCHEL1
         DO 320 ISOUS=1,NSOUS
            MCHAML=ITRA1(ISOUS,2)
            MCHAM1=MCHEL1.ICHAML(ISOUS)
            SEGACT MCHAM1
            NCOMP=IELVAL(/1)
            NCCHE=MCHAM1.NOMCHE(/2)
            DO 301 ICOMP=1,NCOMP
               CALL PLACE(MCHAM1.NOMCHE,NCCHE,IPLAC,
     &                      NOMCHE(ICOMP))
               MELVAL=IELVAL(ICOMP)
               MELVA1=MCHAM1.IELVAL(IPLAC)
               SEGACT MELVA1
               DO 400 IGAU=1,VELCHE(/1)
                  IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
                  DO 400 IB=1,VELCHE(/2)
                     IBMN=MIN(IB,MELVA1.VELCHE(/2))
                     VELCHE(IGAU,IB)=VELCHE(IGAU,IB)+
     &                               XVAL*MELVA1.VELCHE(IGMN,IBMN)
 400           CONTINUE
               SEGDES MELVA1
 301        CONTINUE
            SEGDES MCHAM1
320      CONTINUE
         SEGDES MCHEL1
300   CONTINUE
      SEGDES MELEME,MSOLEN
      SEGSUP TRAV,ICPR
      DO 500 ISOUS=1,NSOUS
         MCHAML=ITRA1(ISOUS,2)
         NCOMP=IELVAL(/1)
         DO 501 ICOMP=1,NCOMP
            MELVAL=IELVAL(ICOMP)
            SEGDES MELVAL
 501     CONTINUE
         SEGDES MCHAML
 500  CONTINUE
      SEGSUP ITRA1
      SEGDES MCHELM
      IRET=MCHELM
*
      IF(IIMPI.EQ.3) CALL ZPCHEL(IRET,0)
*
 5000 CONTINUE
      RETURN
*
 9990 CONTINUE
      DO 600 ISOUS=1,NSOUS
         MCHAML=ITRA1(ISOUS,2)
         SEGSUP MCHAML
 600  CONTINUE
      SEGSUP MCHELM
      SEGSUP ITRA1
      RETURN
 
      END