Sources Esope | Cast3M

fusolu
C FUSOLU    SOURCE    CHAT      05/01/13    00:13:02     5004
      SUBROUTINE FUSOLU(MSO1,MSO2,IRET)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C REUNION DE 2 OBJETS SOLUTION DE MEME TYPE. OPTION VALABLE ACTUELLEMENT
C POUR LES MODES ET LES SOLUTIONS STATIQUES ET LES PSEUDO MODES.
C LES CHPOINTS DE DEPLACEMENT (QUAND IL Y EN A) DOIVENT S APPUYER SUR
C LES MEMES POINTS MUNIS DES MEMES COMPOSANTES. LA VERIF EST FAITE
C DANS COCHPO
C SI 2 INDICES SONT IDENTIQUES ON N EN CONSERVE QU UN.
C
C  ECRIT PAR FARVACQUE
C  APPELE PAR PRFUSE
C  APPELLE COCHPO,ERREUR(82,83)
C=======================================================================
 
-INC PPARAM
-INC CCOPTIO
-INC SMSOLUT
-INC SMELEME
      SEGMENT ITRAV(NNN2)
C
      SEGACT MSO1,MSO2
      IF(MSO1.ITYSOL.NE.MSO2.ITYSOL) GOTO 1000
      NIPO=MSO1.MSOLIS(/1)
      IF(MSO1.ITYSOL.NE.'MODE    ') GOTO 1
      ITY=1
      GOTO 20
 1    IF(MSO1.ITYSOL.NE.'SOLUSTAT'.AND.
     C   MSO1.ITYSOL.NE.'PSEUMODE') GOTO 2
      ITY=2
      GOTO 20
 2    CONTINUE
 1001 CONTINUE
      MOTERR(1:8)=MSO1.ITYSOL
      CALL ERREUR(82)
      GOTO 5000
C     OPERATION NON PROGRAMMEE POUR CE TYPE DE SOLUTION
C
  20  CONTINUE
      SEGINI MSOLUT
      IRET=MSOLUT
      ITYSOL=MSO1.ITYSOL
      DO 40 I=1,NIPO
      MSOLIS(I)=0
      MSOLIT(I)=0
 40   CONTINUE
      GOTO (21,21),ITY
C *********** OPERATION SUR LES MODES ET LES SOLUSTAT ****************
 21   CONTINUE
      MSOLEN=MSO1.MSOLIS(4)
      SEGACT MSOLEN
      MMODE=ISOLEN(1)
      SEGACT MMODE
      IP1=IMMODD(3)
      SEGDES MMODE,MSOLEN
      MSOLEN=MSO2.MSOLIS(4)
      SEGACT MSOLEN
      MMODE=ISOLEN(1)
      SEGACT MMODE
      IP2=IMMODD(3)
      SEGDES MMODE,MSOLEN
      IF(IP2.NE.IP1) GOTO 1000
C     IF(IP2.EQ.3) GOTO 1001
      IPT1=MSO1.MSOLIS(3)
      IPT2=MSO2.MSOLIS(3)
      SEGACT IPT1,IPT2
      NNN1=IPT1.NUM(/2)
      NNN2=IPT2.NUM(/2)
      SEGINI ITRAV
      IMEL=0
      DO 22 I2=1,NNN2
      IPOIN=IPT2.NUM(1,I2)
      DO 23 I1=1,NNN1
      IF(IPOIN.NE.IPT1.NUM(1,I2)) GOTO 23
      GOTO 22
  23  CONTINUE
      IMEL=IMEL+1
      ITRAV(IMEL)=I2
  22  CONTINUE
C
      NBSOUS=0
      NBREF=0
      NBNN=1
      NBELEM=NNN1+IMEL
      SEGINI MELEME
      ITYPEL=1
      DO 24 I1=1,NNN1
      NUM(1,I1)=IPT1.NUM(1,I1)
  24  CONTINUE
      DO 25 I1=1,IMEL
      NUM(1,NNN1+I1)=IPT2.NUM(1,ITRAV(I1))
  25  CONTINUE
      SEGDES IPT1,IPT2,MELEME
      MSOLIS(3)=MELEME
      N=NBELEM
      GOTO 200
C
C  ***** POUR TOUS LES TYPES DE SOLUTION *************
C
  200 CONTINUE
      DO 127 I=4,NIPO
      MSOLE1=MSO1.MSOLIS(I)
      MSOLE2=MSO2.MSOLIS(I)
      IF(MSOLE1.EQ.0.AND.MSOLE2.EQ.0) GOTO 127
      SEGINI MSOLEN
      IBO=MSOLEN
      IF(MSOLE1.EQ.0)GOTO 110
      SEGACT MSOLE1
      DO 129 I1=1,NNN1
      ISOLEN(I1)=MSOLE1.ISOLEN(I1)
 129  CONTINUE
      IF(MSOLE2.EQ.0) GOTO 111
C
C  **** ON VERIFIE QUE LES CHPOINTS CONTENUS DANS LES MSOLEN ONT BIEN
C  **** DES FORMES IDENTIQUES
C
      IF(MSO1.MSOLIT(I).NE.2) GOTO 6
      DO 60 I1=1,NNN1
      IF(MSOLE1.ISOLEN(I1).EQ.0) GOTO 60
      II1=MSOLE1.ISOLEN(I1)
      GOTO 61
   60 CONTINUE
   61 CONTINUE
      SEGACT MSOLE2
      DO 62 I2=1,NNN2
      IF(MSOLE2.ISOLEN(I2).EQ.0) GOTO 62
      II2=MSOLE2.ISOLEN(I2)
      GOTO 63
   62 CONTINUE
   63 ITAI=MSOLE2
      CALL COCHPO(II1,II2,ITAI,ITAF)
      IF(IERR.NE.0) GOTO 5000
      MSOLEN=IBO
      MSOLE2=ITAF
C
   6  CONTINUE
      SEGACT MSOLEN*MOD
      SEGACT MSOLE2
      DO 126 I2=1,IMEL
      ISOLEN(NNN1+I2)=MSOLE2.ISOLEN(ITRAV(I2))
 126  CONTINUE
      GOTO 132
C
 111  CONTINUE
      DO 128 I2=1,IMEL
      ISOLEN(NNN1+I2)=0
 128  CONTINUE
      GOTO 132
C
 110  CONTINUE
      SEGACT MSOLE2
      DO 130 I1=1,NNN1
      ISOLEN(I1)=0
 130  CONTINUE
      DO 131 I2=1,IMEL
      ISOLEN(NNN1+I2)=MSOLE2.ISOLEN(ITRAV(I2))
 131  CONTINUE
 132  MSOLIS(I)=MSOLEN
      SEGDES MSOLE1
      SEGDES MSOLE2
      SEGDES MSOLEN
      IF(MSO1.MSOLIT(I).NE.0) THEN
         MSOLIT(I)=MSO1.MSOLIT(I)
      ELSE
         MSOLIT(I)=MSO2.MSOLIT(I)
      ENDIF
 127  CONTINUE
C
      SEGSUP ITRAV
      SEGDES MSOLUT
      GOTO 5000
 1000 CONTINUE
      MOTERR(1:8)='SOLUTION'
      CALL ERREUR(83)
C     LES 2 OBJETS DOIVENT ETRE DE MEME TYPE
 5000 CONTINUE
      SEGDES MSO1,MSO2
      RETURN
      END