C BASEMD    SOURCE    PV        20/03/24    21:15:28     10554          
      SUBROUTINE BASEMD
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C
C   ==================================================================
C   C
C   C CREATION D UNE BASE MODALE
C   C SYNTAXE : B = BASE S L M U V ;
C   C   B   : OBJET DE TYPE BASE MODALE
C   C   S   : OBJET DE TYPE STRUCTURE
C   C   L   : OBJET DE TYPE MATTAC
C   C   M   : OBJET DE TYPE SOLUTION (SOUS TYPE : MODES)
C   C   U   : OBJET DE TYPE SOLUTION (SOUS TYPE : SOLUTIONS STATIQUES)
C   C   V   : OBJET DE TYPE SOLUTION (SOUS TYPE : PSEUMODE)
C   C
C   C  ECRIT PAR FARVACQUE.
C   C  APPELLE LES SUBROUTINES SUIVANTS:
C   C    LIRE,ECRIRE,SOLS1,ERREUR(61,130,131,133,134,135,173,226,227)
C   ==================================================================
C
-INC SMSOLUT
-INC SMBASEM
-INC SMSTRUC
-INC SMATTAC

-INC PPARAM
-INC CCOPTIO
-INC CCHAMP
-INC CCREEL
-INC SMCOORD
-INC SMELEME
      SEGMENT ITRAV(NJONC)
      SEGMENT ITRABB(0)
*
      PARAMETER ( LNOM1 = 2 )
      CHARACTER*4 NOMOP1(LNOM1)
      CHARACTER*8 CTYP
      DATA NOMOP1/'PLUS','ROTA'/
*
*     Nouvelle version avec les TABLEs
*
      CALL LIRMOT(NOMOP1,LNOM1,IMOT1,0)
      IF(IERR.NE.0) RETURN
      CALL QUETYP(CTYP,1,IRETOU)
      IF (CTYP(1:8).EQ.'TABLE   ') THEN
         CALL LIRTAB('BASE_MODALE',ITBAS,1,IRETOU)
         IF(IERR.NE.0) RETURN
         CALL LIRTAB('POINT',ITPTS,1,IRETOU)
         IF(IERR.NE.0) RETURN
         IPO1 = 0
         IPO2 = 0
         XANG = XZERO
         CALL LIROBJ('POINT   ',IPO1,1,IRETOU)
         IF(IERR.NE.0) RETURN
         IF (IMOT1.EQ.2) THEN
            IF (IDIM.EQ.3) THEN
               CALL LIROBJ('POINT   ',IPO2,1,IRETOU)
               IF(IERR.NE.0) RETURN
            ENDIF
            CALL LIRREE(XANG,1,IRETOU)
            IF(IERR.NE.0) RETURN
         ENDIF
         IF (IMOT1.EQ.0) THEN
            CALL ERREUR(498)
            RETURN
         ELSE
            CALL COPBAS(ITBAS,ITPTS,NOMOP1(IMOT1),IPO1,IPO2,XANG)
            RETURN
         ENDIF
      ENDIF
C
      NIBST=5
C
C  **** LECTURE DE LA STRUCTURE
C
      CALL LIROBJ('STRUCTUR',ISTRU0,1,IRETOU)
      IF(IERR.NE.0) GO TO 5000
      MSTRUC=ISTRU0
      SEGACT MSTRUC
      NSTRU=LISTRU(/1)
      IF(NSTRU.NE.1) THEN
C        ON VERIFIE QUE LA STRUCTURE EST IDENTIQUE
         MSOSTU=LISTRU(1)
         SEGACT MSOSTU
         I1=ISRAID
         I2=ISMASS
         I3=ITYSOU
         SEGDES MSOSTU
         DO 5 I=2,NSTRU
         MSOSTU=LISTRU(I)
         SEGACT MSOSTU
         IF(ISRAID.NE.I1) GOTO 6
         IF(ISMASS.NE.I2) GOTO 6
         IF(ITYSOU.NE.I3) GOTO 6
         SEGDES MSOSTU
         GOTO 5
 6       CONTINUE
         SEGDES MSOSTU
         CALL ERREUR(226)
C        LES SOUS STRUCTURES NE SONT PAS IDENTIQUES
         GOTO 5000
 5       CONTINUE
      ENDIF
      SEGDES MSTRUC
C
C  **** LECTURE DU MATTAC
C
      CALL LIROBJ('ATTACHE ',IRET,0,IRETOU)
      MATTAC=IRET
      IF(IRETOU.EQ.0) MATTAC=0
C
C  **** LECTURE DES OBJETS SOLUTION
C
      IMODE=0
      ISOLS=0
      IPSMO = 0
 1    CALL LIROBJ('SOLUTION',IRET,0,IRETOU)
      IF(IRETOU.EQ.0) GO TO 53
      MSOLUT=IRET
      SEGACT MSOLUT
C
C  **** EST CE UN MODE ?
C
      IF(ITYSOL.NE.'MODE    ') GO TO 51
      IF(IMODE.EQ.0) GO TO 52
      MOTERR(1:8)='SOLUTION'
      MOTERR(9:15)='MODE'
      CALL ERREUR(130)
C     MODES DEJA DONNES
      SEGDES MSOLUT
      GO TO 5000
 52   CONTINUE
      IMODE=MSOLUT
      SEGACT MSOLUT
      MSOLEN=MSOLIS(5)
      SEGDES MSOLUT
      IF(MSOLEN.NE.0) GO TO 304
      MOTERR(1:8)='MODE'
      CALL ERREUR(61)
      GOTO 5000
 304  CONTINUE
      IF(ISOLS.EQ.0) GO TO 1
      GO TO 53
 51   CONTINUE
C
C  **** EST CE UN SOLSTA ?
C
      IF(ITYSOL.NE.'SOLUSTAT') GO TO 54
      IF(ISOLS.EQ.0) GO TO 55
      MOTERR(1:8)='SOLUTION'
      MOTERR(9:16)='SOLUSTAT'
      CALL ERREUR(130)
C     SOLUTIONS STATIQUES DEJA DONNEES
      SEGDES MSOLUT
      GO TO 5000
 55   CONTINUE
      ISOLS=MSOLUT
      SEGDES MSOLUT
      IF(IMODE.EQ.0) GO TO 1
      GO TO 53
C
C  **** EST CE UN PSEUMOD?
C
 54   CONTINUE
      IF(ITYSOL.NE.'PSEUMODE') GO TO 954
      IF(IPSMO.EQ.0) GO TO 955
      MOTERR(1:8)='SOLUTION'
      MOTERR(9:16)='PSEUMODE'
      CALL ERREUR(130)
C     SOLUTIONS STATIQUES DEJA DONNEES
      SEGDES MSOLUT
      GO TO 5000
 955  CONTINUE
      IPSMO=MSOLUT
      SEGDES MSOLUT
      IF(IMODE.EQ.0) GO TO 1
      GO TO 53
 954  CONTINUE
      MOTERR(1:8)='SOLUTION'
      MOTERR(9:16)=ITYSOL
      CALL ERREUR(131)
C     ON N ATTEND PAS CE SOUSTYPE DE SOLUTION
      SEGDES MSOLUT
      GO TO 5000
C
C  **** VERIFICATIONS DIVERSES
C
 53   CONTINUE
      IF(IMODE.NE.0 . OR . MATTAC.NE.0) GO TO 60
      CALL ERREUR(133)
C     NI MODE NI LIAISON DANS CETTE BASE MODALE
      GO TO 5000
 60   CONTINUE
C
      SEGACT MSTRUC
C   BOUCLE SUR LES SOUS-BASES
      SEGINI ITRABB
      DO 66 IBAS=1,NSTRU
      SEGINI MSOBAS
      ITRABB(**)=MSOBAS
      IBSTRM(1)=LISTRU(IBAS)
      IBSTRM(2)=0
      IBSTRM(3)=0
      IBSTRM(4)=MATTAC
      IBSTRM(5)=IPSMO
      IF(IBAS.EQ.1) THEN
        IBSTRM(2)=IMODE
      ELSE IF(IMODE.NE.0) THEN
C
C  **** DANS LE CAS IDEN, DUPLICATION DES MODES
C
        SEGACT MCOORD*mod
        MSOLUT=IMODE
        SEGACT MSOLUT
        MELEME=MSOLIS(3)
        SEGACT MELEME
        NBELEM=NUM(/2)
        NBREF=0
        NBNN=1
        NBSOUS=0
        SEGINI IPT1
        ITYPEL=1
        MSOSTU=LISTRU(IBAS)
        IPOIN=nbpts
        NBPTS=IPOIN+NBELEM
        SEGADJ MCOORD
        DO 403 I=1,NBELEM
        XCOOR(IPOIN*(IDIM+1)+1)=0.
        XCOOR(IPOIN*(IDIM+1)+2)=0.
        IF(IDIM.EQ.3) XCOOR(IPOIN*(IDIM+1)+3)=0.
        XCOOR(IPOIN*(IDIM+1)+(IDIM+1))=0.
        IPOIN=IPOIN+1
        IPT1.NUM(1,I)=IPOIN
 403    CONTINUE
        NIPO=MSOLIS(/1)
        SEGINI MSO1
        MSO1.ITYSOL=ITYSOL
        DO 404 I=1,NIPO
        MSO1.MSOLIS(I)=MSOLIS(I)
        MSO1.MSOLIT(I)=MSOLIT(I)
 404    CONTINUE
        MSO1.MSOLIS(3)=IPT1
        SEGDES MSO1,MSOLUT,MELEME,IPT1
        IBSTRM(2)=MSO1
      ENDIF
C
C  **** BOUCLE SUR LES LIAISONS : ON CHERCHE LES LIAISONS QUI AGISSENT
C  **** SUR MSOSTU.  MECA, FLUIDE ET DEPI  :MJONCT MIS DANS MSOLE1
C  ****              AUTRES :RIEN
C
      IF(MATTAC.EQ.0) GO TO 61
      N=0
      SEGACT MATTAC
      MSOSTU=LISTRU(IBAS)
      NSOUMA=LISATT(/1)
      DO 70 IA=1,NSOUMA
      MSOUMA=LISATT(IA)
      SEGACT MSOUMA
      NL=IATREL(/1)
      DO 72 IB=1,NL
      MJONCT=IATREL(IB)
      SEGACT MJONCT
      NC=ISTRJO(/1)
      DO 73 IC=1,NC
      IF(ISTRJO(IC).NE.MSOSTU)   GO TO 73
      IF(ITYATT.NE.'MECA'.AND.ITYATT.NE.'FLUI'.AND.ITYATT.NE.'DEPI')
     & GOTO 73
      N=N+1
      IF(N.EQ.1)SEGINI MSOLE1
      IF(N.NE.1)SEGADJ MSOLE1
      MSOLE1.ISOLEN(N)=MJONCT
C     WRITE(6,4446)MJONCT
C4446 FORMAT('  ********MJONCT=',I6)
 73   CONTINUE
      SEGDES MJONCT
 72   CONTINUE
      SEGDES MSOUMA
 70   CONTINUE
      NJONC=N
C
      IF(ISOLS.NE.0) THEN
C
C  **** COMPATIBILITE ENTRE LES MJONCT ET LES SOLUTIONS STATIQUES?
C
        IF(NJONC.EQ.0) GOTO 900
C     INCOMPATIBILITE ENTRE LES SOLSTA ET LES LIAISONS
        MSOLUT=ISOLS
        SEGACT MSOLUT
        MSOLEN=MSOLIS(10)
        SEGACT MSOLEN
        LTAB=ISOLEN(/1)
        IF(LTAB.LT.NJONC) THEN
C     INCOMPATIBILITE ENTRE LES SOLSTA ET LES LIAISONS
          SEGDES MSOLEN,MSOLUT
          GO TO 900
        ENDIF
        IF(NJONC.LT.LTAB) SEGINI ITRAV
        DO 81 J=1,NJONC
        MJONCT=MSOLE1.ISOLEN(J)
        DO 80 I=1,LTAB
        IF(MJONCT.NE.ISOLEN(I)) GO TO 80
        IF(NJONC.LT.LTAB) ITRAV(J)=I
        GOTO 81
 80     CONTINUE
C     INCOMPATIBILITE ENTRE LES SOLSTA ET LES LIAISONS
        SEGDES MSOLEN,MSOLUT
        IF(NJONC.LT.LTAB) SEGSUP ITRAV
        GO TO 900
 81     CONTINUE
        SEGDES MSOLEN,MSOLUT
        IF(NJONC.LT.LTAB) THEN
C
C    CREATION DE L'OBJET SOLUTION STATIQUE REDUIT AUX LIAISONS DU MATTAC
C
          MSO1=ISOLS
          SEGACT MSO1
          MSOLE2=MSO1.MSOLIS(5)
          SEGACT MSOLE2
          N=NJONC
          SEGINI MSOLEN
          NBELEM=NJONC
          NBNN=1
          NBSOUS=0
          NBREF=0
          SEGINI MELEME
          ITYPEL=1
          DO 82 IB=1,NJONC
          MJONCT=MSOLE1.ISOLEN(IB)
          SEGACT MJONCT
          IPT1=MJOPOI
          SEGACT IPT1
          NUM(1,IB)=IPT1.NUM(1,ITRAV(IB))
          ISOLEN(IB)=MSOLE2.ISOLEN(ITRAV(IB))
          SEGDES IPT1,MJONCT
 82       CONTINUE
          SEGDES MELEME,MSOLE2,MSOLEN,MSOLE1
          SEGSUP ITRAV
          NIPO=10
          SEGINI MSOLUT
      ITYSOL='SOLUSTAT'
          DO 83 I=1,NIPO
          MSOLIS(I)=0
          MSOLIT(I)=0
  83      CONTINUE
          MSOLIS(3)=MELEME
          MSOLIS(5)=MSOLEN
          MSOLIT(5)=2
          MSOLIT(10)=14
          MSOLIS(10)=MSOLE1
          SEGDES MSOLUT
          IBSTRM(3)=MSOLUT
        ELSE
          IBSTRM(3)=ISOLS
          SEGSUP MSOLE1
        ENDIF
      ELSE
C
C  ***  IL N'Y A PAS DE SOLUTION STATIQUES. S'IL EN FAUT ON VA LES
C  ***  CALCULER EN APPELANT LE SOUS-PROGRAMME SOLS1 DE L'OPERATEUR SOLS
C
        IF(NJONC.NE.0) THEN
           KSOSTU=MSOSTU
           KSOLE1=MSOLE1
           CALL SOLS1(KSOSTU,KSOLE1,KSOLUT)
           IF(IERR.NE.0) THEN
             SEGSUP MSOLE1
             GOTO 900
           ENDIF
           IBSTRM(3)=KSOLUT
        ENDIF
      ENDIF
C
C  **** SI IL Y A D'AUTRES TYPES DE LIAISONS, ON CREE DES MODES ET DES
C  **** SOLUTIONS STATIQUES REDUITS AUX POINTS DE CES DERNIERES LIAISONS
C
      IF(IMODE.EQ.0) THEN
C  *** OUBLI DES MODES
        CALL ERREUR(227)
      ENDIF
        GOTO 62
C
  900 CONTINUE
      MOTERR(1:8)='SOLUSTAT'
      MOTERR(9:15)='ATTACHE'
      CALL ERREUR(135)
 62   CONTINUE
      SEGDES MATTAC
 61   CONTINUE
      SEGDES MSOBAS
 66   CONTINUE
      SEGDES MSTRUC
      N=ITRABB(/1)
      IF(N.NE.0) THEN
      SEGINI MBASEM
      DO 800 NN=1,N
      LISBAS(NN)=ITRABB(NN)
800   CONTINUE
      SEGDES MBASEM
      CALL ECROBJ('BASEMODA',MBASEM)
      ENDIF
      SEGSUP ITRABB
 5000 CONTINUE
      RETURN
      END