Sources Esope | Cast3M

react1
C REACT1    SOURCE    PV090527  24/11/21    21:15:12     12084          
      SUBROUTINE REACT1(MRIGID,MCHPOI,MCHPO1)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMRIGID
-INC SMELEME
-INC SMCHPOI
 
-INC PPARAM
-INC CCOPTIO
      CHARACTER*72 CTEXT
      SEGMENT IGARD(NNOL)
C
C  **  ON VERIFIE QUE LE CHPOINT CONTIENT DES MULTIPLICATEURS
C  **  EN LEUR ABSENCE ON CREE UN CHPOINT VIDE
C
      SEGACT MCHPOI
      NSOUPO = IPCHP(/1)
*      write(6,*) 'NSOUPO =',NSOUPO
      CTEXT = MOCHDE
      ITRUC = IFOPOI
      DO 500 K=1,IPCHP(/1)
      MSOUPO=IPCHP(K)
      SEGACT MSOUPO
      DO 501 J=1,NOCOMP(/2)
      IF(NOCOMP(J).EQ.'LX  ') GO TO 502
  501 CONTINUE
 500  CONTINUE
      GO TO 288
*
 502  CONTINUE
C DANS UN CHPOINT IL NE PEUT Y AVOIR Q'UNE SEULE PARTIE QUI CONTIENT
C DES MULTIPLICATEURS  , ON CREE UN CHPOIN LE CONTENANT
      NSOUPO=1
      NAT=1
      SEGINI MCHPOI
      JATTRI(1)=2
      IPCHP(1)=MSOUPO
C
C  **  TERMINE POUR LE CHPOINT ON PASSE A LA RIGIDITE . ON VEUT
C  **  MAINTENANT FABRIQUER UN OBJET RIGIDITE CONTENANT UNIQUEMENT
C  **  LES MATRICES DE BLOQUAGE.
C
      NRIGEL=0
      SEGACT MRIGID
      NNR=IRIGEL(/2)
C
C  **  BOUCLE 1 SUR LES SOUS OBJETS RIGIDITES  POUR COMPTER COMBIEN
C  **  DE MATRICES DE BLOQUAGES
C
      DO 1 I=1,NNR
      DESCR= IRIGEL(3,I)
      SEGACT DESCR
      NINC=LISINC(/2)
      DO 2 J = 1,NINC
      IF(LISINC(J).EQ.'LX  ') GO TO 3
   2  CONTINUE
      SEGDES DESCR
      GO TO 1
   3  CONTINUE
      NRIGEL=NRIGEL+1
      SEGDES DESCR
  1   CONTINUE
C
C  ** INITIALISATION DE L'OBJET RIGIDITE
C
      IF(NRIGEL.NE.0) GO TO 4
C
C  SI RIGIDITE VIDE , ON CREE UN CHPOINT VIDE
C
      SEGSUP MCHPOI
      SEGDES MRIGID
 288  NSOUPO=0
      NAT=1
      SEGINI MCHPO1
      MCHPO1.JATTRI(1)=2
      MCHPO1.IFOPOI=ITRUC
      MCHPO1.MOCHDE=CTEXT
      MCHPO1.MTYPOI='        '
      RETURN
C
   4  CONTINUE
      IA=1
      NRIGE= IRIGEL(/1)
      SEGINI RI1
      DO 10 I=1,NNR
      DESCR= IRIGEL(3,I)
      SEGACT DESCR
      NINC=LISINC(/2)
      DO 20 J = 1,NINC
      IF(LISINC(J).EQ.'LX  ') GO TO 30
  20  CONTINUE
      SEGDES DESCR
      GO TO 10
  30  CONTINUE
      DO 31 L=1,NRIGE
      RI1.IRIGEL(L,IA)=IRIGEL(L,I)
  31  CONTINUE
      RI1.COERIG(IA)=-COERIG(I)
      IA=IA+1
      SEGDES DESCR
  10  CONTINUE
      SEGDES MRIGID,RI1
      CALL MUCPRI(MCHPOI,RI1,IRET)
      IF (IERR.NE.0) return
C
C  **  IL FAUT ENLEVER DU CHPOINT LA PARTIE CONCERNANT FLX
C
C  ** ON VERIFIE AU PREALABLE QU'IL N'Y A PAS DE MULTIPLICATEURS
C  ** DE MULTIPLICATEUR
C
      SEGACT RI1
      INON=1
      DO 40 I=1,RI1.IRIGEL(/2)
      DESCR=RI1.IRIGEL(3,I)
      SEGACT DESCR
      DO 41 J=1,LISINC(/2)
      IF( LISINC(J).EQ.'LX  ') THEN
      INON=0
      SEGDES DESCR
      GO TO 45
      ENDIF
   41 CONTINUE
      SEGDES DESCR
   40 CONTINUE
   45 CONTINUE
      MCHPOI=IRET
      SEGACT MCHPOI
      NSOUPO=IPCHP(/1) -INON
      NAT=1
      SEGINI MCHPO1
      MCHPO1.IFOPOI=ITRUC
      MCHPO1.MOCHDE=CTEXT
      MCHPO1.MTYPOI='        '
      MCHPO1.JATTRI(1)=2
      IA=1
**    call ecchpo(mchpoi,1)
      DO 60 I=1,NSOUPO+INON
      MSOUPO=IPCHP(I)
      SEGACT MSOUPO
      IF(NOCOMP(1).EQ.'FLX ')  THEN
        IF(INON.EQ.0) THEN
         MELEME=IGEOC
         SEGACT MELEME
         NNOL=NUM(/2)
         SEGINI IGARD
         DO 61 J=1,RI1.IRIGEL(/2)
         DESCR= RI1.IRIGEL(3,J)
         SEGACT DESCR
         DO 62 K=3,LISINC(/2)
         IF(LISINC(K).EQ.'LX  ') THEN
          IPT1=RI1.IRIGEL(1,J)
          SEGACT IPT1
          DO 63 L=1,IPT1.NUM(/2)
          IP=IPT1.NUM(NOELEP(K),L)
          DO 64 M=1,NNOL
          IF( NUM(1,M).EQ.IP) THEN
           IGARD(M)=1
            GO TO 63
          ENDIF
   64     CONTINUE
   63     CONTINUE
         ENDIF
   62    CONTINUE
         SEGDES DESCR
   61    CONTINUE
         NBELEM=0
         DO 65 J=1,NNOL
         NBELEM=NBELEM+IGARD(J)
  65     CONTINUE
         NBNN=1
         NBSOUS=0
         NBREF=0
         SEGINI IPT2
         IGEOC=IPT2
         IB=1
         N=NBELEM
         NC=1
         SEGINI MPOVA1
         MPOVAL=IPOVAL
         SEGACT MPOVAL
         DO 66 J=1,NNOL
         IF(IGARD(J).EQ.0) GO TO 66
         IPT2.NUM(1,IB)=NUM(1,J)
         MPOVA1.VPOCHA(IB,1)=VPOCHA(J,1)
         IB=IB+1
  66     CONTINUE
         SEGSUP MPOVAL
         IPOVAL=MPOVA1
         call crech1(ipt2,1)
      IF (IERR.NE.0) return
         MCHPO1.IPCHP(IA)=MSOUPO
         IA=IA+1
         SEGSUP IGARD
        ELSE
         MELEME=IGEOC
         MPOVAL=IPOVAL
         SEGSUP MPOVAL,MSOUPO
        ENDIF
      ELSE
        MCHPO1.IPCHP(IA)=MSOUPO
        IA=IA+1
      ENDIF
  60  CONTINUE
      NSOUPO=IA-1
*      write(6,*) 'MCHPO1, NSOUPO=',MCHPO1,NSOUPO
      IF (NSOUPO.GT.0) THEN
        SEGADJ MCHPO1
        SEGSUP MCHPOI,RI1
      ELSE
        GOTO 288
      ENDIF
 
      END