1 : C ECBASE SOURCE CHAT 05/01/12 23:20:09 5004 2 : SUBROUTINE ECBASE(MBASEM) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : C==================================================================== 6 : C ECRITURE D UNE BASE MODALE 7 : C ECRIT PAR FARVACQUE 8 : C N'APPELLE AUCUN SUBROUTINE 9 : C===================================================================== 10 : -INC SMBASEM 11 : -INC SMELEME 12 : -INC SMSOLUT 13 : -INC SMATTAC 14 : -INC CCOPTIO 15 : DIMENSION ILIA(5) 16 : CHARACTER*4 MLIA(5) 17 : DATA MLIA/'MECA','FLUI','DEPI','CHOC','DEVE'/ 18 : DATA NLIA/5/ 19 : INTERR(1)=MBASEM 19 : CALL ERREUR(-97) 20 : SEGACT MBASEM 21 : NBASE=LISBAS(/1) 22 : DO 100 IB=1,NBASE 23 : MSOBAS=LISBAS(IB) 24 : SEGACT MSOBAS 25 : IBSTRU=IBSTRM(1) 26 : IBMODE=IBSTRM(2) 27 : IBSOLS=IBSTRM(3) 28 : IBMATT=IBSTRM(4) 29 : IBPSEU=IBSTRM(5) 30 : INTERR(1)=IB 31 : INTERR(2)=MSOBAS 31 : CALL ERREUR(-98) 32 : C 33 : IF(IBMODE.EQ.0) GO TO 1 34 : INTERR(1)=IBMODE 35 : MOTERR(1:8)=' MODE ' 35 : CALL ERREUR(-99) 36 : MSOLUT=IBMODE 37 : SEGACT MSOLUT 38 : MSOLEN=MSOLIS(4) 39 : MELEME=MSOLIS(3) 40 : SEGACT MSOLEN, MELEME 41 : NMOD=ISOLEN(/1) 42 : DO 10 IM=1,NMOD 43 : MMODE=ISOLEN(IM) 44 : SEGACT MMODE 45 : IP1=NUM(1,IM) 46 : WRITE(IOIMP,3006) IP1,FMMODD(1) 47 : SEGDES MMODE 48 : 10 CONTINUE 49 : SEGDES MSOLEN,MSOLUT,MELEME 50 : WRITE(IOIMP,3003) 51 : C 52 : 1 CONTINUE 53 : IF(IBSOLS.EQ.0) GO TO 2 54 : MOTERR(1:8)='SOLUSTAT' 55 : INTERR(1)=IBSOLS 55 : CALL ERREUR(-99) 56 : MSOLUT=IBSOLS 57 : SEGACT MSOLUT 58 : MELEME=MSOLIS(3) 59 : MSOLEN=MSOLIS(4) 60 : MSOLE1=MSOLIS(10) 61 : SEGACT MSOLEN, MELEME 62 : IF(MSOLE1.NE.0) SEGACT MSOLE1 63 : NMOD=ISOLEN(/1) 64 : DO 40 IM=1,NMOD 65 : MMODE=ISOLEN(IM) 66 : SEGACT MMODE 67 : IP1=NUM(1,IM) 68 : IF(MSOLE1.NE.0) THEN 69 : WRITE(IOIMP,3007) IP1,FMMODD(1),MSOLE1.ISOLEN(IM) 70 : ELSE 71 : WRITE(IOIMP,3006) IP1,FMMODD(1) 72 : ENDIF 73 : SEGDES MMODE 74 : 40 CONTINUE 75 : SEGDES MSOLEN,MSOLUT,MELEME 76 : IF(MSOLE1.NE.0) SEGDES MSOLE1 77 : WRITE(IOIMP,3003) 78 : C 79 : 2 CONTINUE 80 : IF(IBPSEU.EQ.0) GO TO 3 81 : INTERR(1)=IBPSEU 82 : MOTERR(1:8)='PSEUMODE' 82 : CALL ERREUR(-99) 83 : MSOLUT=IBPSEU 84 : SEGACT MSOLUT 85 : MELEME=MSOLIS(3) 86 : MSOLEN=MSOLIS(4) 87 : MSOLE1=MSOLIS(10) 88 : SEGACT MSOLEN, MELEME 89 : IF(MSOLE1.NE.0) SEGACT MSOLE1 90 : NMOD=ISOLEN(/1) 91 : DO 50 IM=1,NMOD 92 : MMODE=ISOLEN(IM) 93 : SEGACT MMODE 94 : IP1=NUM(1,IM) 95 : IF(MSOLE1.NE.0) THEN 96 : WRITE(IOIMP,3007) IP1,FMMODD(1),MSOLE1.ISOLEN(IM) 97 : ELSE 98 : WRITE(IOIMP,3006) IP1,FMMODD(1) 99 : ENDIF 100 : SEGDES MMODE 101 : 50 CONTINUE 102 : SEGDES MSOLEN,MSOLUT,MELEME 103 : IF(MSOLE1.NE.0) SEGDES MSOLE1 104 : WRITE(IOIMP,3003) 105 : C 106 : 3 CONTINUE 107 : IF(IBMATT.EQ.0) GO TO 4 108 : MATTAC=IBMATT 109 : INTERR(1)=IBMATT 109 : CALL ERREUR(-100) 110 : WRITE(IOIMP,3003) 111 : SEGACT MATTAC 112 : DO 33 IL=1,NLIA 113 : ILIA(IL)=0 114 : 33 CONTINUE 115 : DO 30 ISOU=1,LISATT(/1) 116 : MSOUMA=LISATT(ISOU) 117 : SEGACT MSOUMA 118 : DO 31 IL=1,NLIA 119 : IF(ITYATT.EQ.MLIA(IL))ILIA(IL)=ILIA(IL)+1 120 : 31 CONTINUE 121 : SEGDES MSOUMA 122 : 30 CONTINUE 123 : DO 32 IL=1,NLIA 124 : IF(ILIA(IL).NE.0) THEN 125 : INTERR(1)=ILIA(IL) 126 : MOTERR(1:4)=MLIA(IL) 126 : CALL ERREUR(-101) 127 : ENDIF 128 : 32 CONTINUE 129 : SEGDES MATTAC 130 : C 131 : 4 CONTINUE 132 : SEGDES MSOBAS 133 : 100 CONTINUE 134 : C 135 : SEGDES MBASEM 136 : RETURN 137 : C 138 : 3003 FORMAT(1X,67('*')) 139 : 3006 FORMAT(' *',10X,'*',10X,'*',10X,'* ',I5,' * ',E12.5,' *',9X,'*') 140 : 3007 FORMAT(' *',10X,'*',10X,'*',10X,'* ',I5,' * ',E12.5,' * ',I5, 141 : 1' *') 142 : C 143 : END 144 :
© Cast3M 2003 - All rights reserved.
Disclaimer