Sources Esope | Cast3M

ecbase
C ECBASE    SOURCE    CHAT      05/01/12    23:20:09     5004
      SUBROUTINE ECBASE(MBASEM)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C====================================================================
C     ECRITURE D UNE BASE MODALE
C     ECRIT PAR FARVACQUE
C     N'APPELLE AUCUN SUBROUTINE
C=====================================================================
-INC SMBASEM
-INC SMELEME
-INC SMSOLUT
-INC SMATTAC
 
-INC PPARAM
-INC CCOPTIO
      DIMENSION ILIA(5)
      CHARACTER*4 MLIA(5)
      DATA MLIA/'MECA','FLUI','DEPI','CHOC','DEVE'/
      DATA NLIA/5/
      INTERR(1)=MBASEM
      CALL ERREUR(-97)
      SEGACT MBASEM
      NBASE=LISBAS(/1)
      DO 100 IB=1,NBASE
      MSOBAS=LISBAS(IB)
      SEGACT MSOBAS
      IBSTRU=IBSTRM(1)
      IBMODE=IBSTRM(2)
      IBSOLS=IBSTRM(3)
      IBMATT=IBSTRM(4)
      IBPSEU=IBSTRM(5)
      INTERR(1)=IB
      INTERR(2)=MSOBAS
      CALL ERREUR(-98)
C
      IF(IBMODE.EQ.0) GO TO 1
      INTERR(1)=IBMODE
      MOTERR(1:8)='  MODE  '
      CALL ERREUR(-99)
      MSOLUT=IBMODE
      SEGACT MSOLUT
      MSOLEN=MSOLIS(4)
      MELEME=MSOLIS(3)
      SEGACT MSOLEN, MELEME
      NMOD=ISOLEN(/1)
      DO 10 IM=1,NMOD
      MMODE=ISOLEN(IM)
      SEGACT MMODE
      IP1=NUM(1,IM)
      WRITE(IOIMP,3006) IP1,FMMODD(1)
      SEGDES MMODE
 10   CONTINUE
      SEGDES MSOLEN,MSOLUT,MELEME
      WRITE(IOIMP,3003)
C
 1    CONTINUE
      IF(IBSOLS.EQ.0) GO TO 2
      MOTERR(1:8)='SOLUSTAT'
      INTERR(1)=IBSOLS
      CALL ERREUR(-99)
      MSOLUT=IBSOLS
      SEGACT MSOLUT
      MELEME=MSOLIS(3)
      MSOLEN=MSOLIS(4)
      MSOLE1=MSOLIS(10)
      SEGACT MSOLEN, MELEME
      IF(MSOLE1.NE.0) SEGACT MSOLE1
      NMOD=ISOLEN(/1)
      DO 40 IM=1,NMOD
      MMODE=ISOLEN(IM)
      SEGACT MMODE
      IP1=NUM(1,IM)
      IF(MSOLE1.NE.0) THEN
      WRITE(IOIMP,3007) IP1,FMMODD(1),MSOLE1.ISOLEN(IM)
      ELSE
      WRITE(IOIMP,3006) IP1,FMMODD(1)
      ENDIF
      SEGDES MMODE
 40   CONTINUE
      SEGDES MSOLEN,MSOLUT,MELEME
      IF(MSOLE1.NE.0) SEGDES MSOLE1
      WRITE(IOIMP,3003)
C
 2    CONTINUE
      IF(IBPSEU.EQ.0) GO TO 3
      INTERR(1)=IBPSEU
      MOTERR(1:8)='PSEUMODE'
      CALL ERREUR(-99)
      MSOLUT=IBPSEU
      SEGACT MSOLUT
      MELEME=MSOLIS(3)
      MSOLEN=MSOLIS(4)
      MSOLE1=MSOLIS(10)
      SEGACT MSOLEN, MELEME
      IF(MSOLE1.NE.0) SEGACT MSOLE1
      NMOD=ISOLEN(/1)
      DO 50 IM=1,NMOD
      MMODE=ISOLEN(IM)
      SEGACT MMODE
      IP1=NUM(1,IM)
      IF(MSOLE1.NE.0) THEN
      WRITE(IOIMP,3007) IP1,FMMODD(1),MSOLE1.ISOLEN(IM)
      ELSE
      WRITE(IOIMP,3006) IP1,FMMODD(1)
      ENDIF
      SEGDES MMODE
 50   CONTINUE
      SEGDES MSOLEN,MSOLUT,MELEME
      IF(MSOLE1.NE.0) SEGDES MSOLE1
      WRITE(IOIMP,3003)
C
 3    CONTINUE
      IF(IBMATT.EQ.0) GO TO 4
      MATTAC=IBMATT
      INTERR(1)=IBMATT
      CALL ERREUR(-100)
      WRITE(IOIMP,3003)
      SEGACT MATTAC
      DO 33 IL=1,NLIA
      ILIA(IL)=0
 33   CONTINUE
      DO 30 ISOU=1,LISATT(/1)
      MSOUMA=LISATT(ISOU)
      SEGACT MSOUMA
      DO 31 IL=1,NLIA
      IF(ITYATT.EQ.MLIA(IL))ILIA(IL)=ILIA(IL)+1
 31   CONTINUE
      SEGDES MSOUMA
 30   CONTINUE
      DO 32 IL=1,NLIA
      IF(ILIA(IL).NE.0)  THEN
        INTERR(1)=ILIA(IL)
        MOTERR(1:4)=MLIA(IL)
        CALL ERREUR(-101)
      ENDIF
 32   CONTINUE
      SEGDES MATTAC
C
 4    CONTINUE
      SEGDES MSOBAS
  100 CONTINUE
C
      SEGDES MBASEM
      RETURN
C
 3003 FORMAT(1X,67('*'))
 3006 FORMAT(' *',10X,'*',10X,'*',10X,'* ',I5,' * ',E12.5,' *',9X,'*')
 3007 FORMAT(' *',10X,'*',10X,'*',10X,'* ',I5,' * ',E12.5,' *  ',I5,
     1'  *')
C
      END