1 : C EQPR SOURCE CHAT 06/08/24 21:31:54 5529 2 : SUBROUTINE EQPR 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : -INC CCOPTIO 6 : -INC SMLENTI 7 : -INC SMLREEL 8 : -INC SMLMOTS 9 : POINTEUR MINCO.MLMOTS 10 : -INC SMTABLE 11 : POINTEUR MTABX.MTABLE,KIZL.MTABLE,KIZS.MTABLE,KIZC.MTABLE 12 : -INC SMELEME 13 : PARAMETER (NBM=5) 14 : CHARACTER*8 LMOTS(NBM),NOM,MEQUA,NOMO,NOMZ,MTYP,MOQ(2) 15 : CHARACTER*8 TYPE,TYP2,TYPS,TYPC 16 : 17 : PARAMETER (NTB=2) 18 : CHARACTER*8 LTAB(NTB) 19 : DIMENSION KTAB(NTB) 20 : DATA LMOTS /'ZONE ','OPER ','KTYPI ','BETA ', 21 : & 'PIMP '/ 22 : DATA LTAB/'DOMAINE ','EQPR '/ 23 : C*** 24 : 24 : CALL QUETYP(TYPE,0,IRET) 25 : 26 : MMODEL=0 27 : IF(TYPE.EQ.'MMODEL')THEN 27 : CALL LIROBJ('MMODEL',MMODEL,0,IRET) 27 : CALL LEKMOD(MMODEL,MTBLE,INEFMD) 28 : IF(MTBLE.EQ.0)RETURN 29 : KTAB(1)=MTBLE 30 : KTAB(2)=0 31 : 32 : ELSEIF(TYPE.EQ.'TABLE')THEN 32 : CALL LIROBJ(TYPE,MTBLE,0,IRET) 33 : TYPC=' ' 33 : CALL ACMO(MTBLE,'SOUSTYPE',TYPC,IRET) 34 : IF(TYPC.EQ.'MOT ')THEN 34 : CALL ACMM(MTBLE,'SOUSTYPE',TYPS) 35 : IF(TYPS.EQ.'DOMAINE')THEN 36 : KTAB(1)=MTBLE 37 : KTAB(2)=0 38 : ELSEIF(TYPS.EQ.'EQPR')THEN 39 : KTAB(1)=0 40 : KTAB(2)=MTBLE 41 : ELSE 42 : WRITE(IOIMP,*)' On attend une table soustype DOMAINE ou EQEX' 43 : RETURN 44 : ENDIF 45 : ENDIF 46 : ENDIF 47 : 48 : C??? 49 : C??? NTO=0 49 : C??? CALL LITABS(LTAB,KTAB,NTB,NTO,IRET) 50 : C??? IF(IRET.EQ.0)THEN 51 : C??? WRITE(6,*)' On attend une table soustype DOMAINE ou EQPR' 52 : C??? RETURN 53 : C??? ENDIF 54 : IF(KTAB(1).NE.0.AND.KTAB(2).NE.0)THEN 55 : WRITE(6,*)' On ne peut donner simultanement les deux tables' 56 : RETURN 57 : ENDIF 58 : 59 : IF(KTAB(2).NE.0)THEN 60 : MTABLE=KTAB(2) 61 : SEGACT MTABLE 62 : MTYP='LISTMOTS' 62 : CALL ACMO(MTABLE,'LISTOPER',MTYP,MLMOT1) 63 : SEGACT MLMOT1 64 : NEQUA=MLMOT1.MOTS(/2) 65 : ELSEIF(KTAB(1).NE.0)THEN 66 : MTABD=KTAB(1) 66 : CALL CRTABL(MTABLE) 67 : NEQUA=0 67 : CALL ECMM(MTABLE,'SOUSTYPE','EQPR') 67 : CALL ECMO(MTABLE,'DOMAINE','TABLE ',MTABD) 68 : 69 : TYPE=' ' 69 : CALL ACMO(MTABD,'MACRO',TYPE,IMAC) 70 : IF(TYPE.NE.'MAILLAGE')THEN 70 : CALL ECME(MTABLE,'KBETA',0) 70 : CALL ECMF(MTABLE,'BETA',0.D0) 71 : ELSE 71 : CALL ECME(MTABLE,'KBETA',1) 71 : CALL ECMF(MTABLE,'BETA',1.D0) 72 : ENDIF 73 : 73 : CALL ECME(MTABLE,'KTYPI',1) 74 : 74 : CALL ECME(MTABLE,'KPIMP',0) 74 : CALL ECMF(MTABLE,'PIMP',0.D0) 75 : JGN=8 76 : JGM=0 77 : SEGINI MLMOT1 77 : CALL ECMO(MTABLE,'LISTOPER','LISTMOTS',MLMOT1) 78 : ELSE 79 : WRITE(6,*)' On attend une table ou un objet maillage' 80 : RETURN 81 : ENDIF 82 : 83 : 1 CONTINUE 83 : CALL LIRCHA(NOM,0,IRET) 84 : IF(IRET.EQ.0)GO TO 90 85 : 2 CONTINUE 86 : C write(6,*)' EQPR : nom=',nom 86 : CALL OPTLI(IP,LMOTS,NOM,NBM) 87 : IF(IP.EQ.0)THEN 88 : WRITE(6,*)'OPTION NON TROUVE DANS LA LISTE ->',LMOTS 89 : RETURN 90 : ENDIF 91 : 92 : GO TO (10,11,12,14,15),IP 93 : 94 : 10 CONTINUE 95 : C ON LIT LA ZONE 96 : 96 : CALL LITABS(LTAB,KTAB,1,0,IRET) 97 : 98 : MMODEL=0 99 : IF(KTAB(1).EQ.0)THEN 99 : CALL LIROBJ('MMODEL',MMODEL,0,IRET2) 100 : IF(IRET2.EQ.0)THEN 101 : WRITE(IOIMP,*)' On attend un objet TABLE DOMAINE ou MODELE' 102 : RETURN 103 : ENDIF 103 : CALL LEKMOD(MMODEL,MTBLE,INEFMD) 104 : IF(MTBLE.EQ.0)RETURN 105 : KTAB(1)=MTBLE 106 : ENDIF 107 : 108 : C??? IF(IRET.EQ.0)THEN 109 : C??? WRITE(6,*)' On attend un objet TABLE DOMAINE' 110 : C??? RETURN 111 : C??? ENDIF 112 : 112 : CALL QUENOM(NOMZ) 113 : C write(6,*)' NOM de la zone ',NOMZ 114 : GO TO 1 115 : 116 : 11 CONTINUE 116 : CALL LIRCHA(NOM,1,IRET) 117 : IF(IRET.EQ.0)THEN 118 : WRITE(6,*)' ON ATTEND LE NOM DE L OPERATEUR' 119 : RETURN 120 : C write(6,*)' NOM de l opérateur ',NOM 121 : ENDIF 122 : 123 : * ECRITURE DU NOM DE L'OPERATEUR 124 : NOMO=NOM 125 : 126 : NEQUA=NEQUA+1 127 : IF(NEQUA.LT.10)THEN 128 : WRITE(MEQUA,FMT='(I1,A7)')NEQUA,NOMO(1:7) 129 : ELSEIF(NEQUA.LT.100.AND.NEQUA.GE.10)THEN 130 : WRITE(MEQUA,FMT='(I2,A6)')NEQUA,NOMO(1:6) 131 : ELSE 132 : WRITE(6,*)'PLUS DE 99 OPERATEURS : CAS NON PREVU' 133 : RETURN 134 : ENDIF 135 : JGN=8 136 : JGM=MLMOT1.MOTS(/2)+1 137 : SEGADJ MLMOT1 138 : MLMOT1.MOTS(JGM)=MEQUA 138 : CALL LENCHA(MEQUA,LC1) 138 : CALL CRTABL(MTABX) 138 : CALL ECMM(MTABX,'SOUSTYPE','KIZP') 138 : CALL ECMO(MTABLE,MEQUA(1:LC1),'TABLE',MTABX) 139 : 140 : * ECRITURE DE LA TABLE DE REFERENCE 140 : CALL ECMO(MTABX,'EQPR','TABLE',MTABLE) 141 : * ECRITURE DU NOM DE LA ZONE 141 : CALL ECMM(MTABX,'NOMZONE',NOMZ) 142 : * ECRITURE DE MELEMZ 142 : CALL ECMO(MTABX,'DOMZ','TABLE',KTAB(1)) 143 : 143 : CALL ECMM(MTABX,'NOMOPER',NOM) 144 : 145 : * ECRITURE DE LA LISTE DES ARGUMENTS 146 : IARG=0 146 : CALL ECME(MTABX,'IARG',IARG) 147 : 148 : 110 CONTINUE 148 : CALL QUETYP(MTYP,0,IRET) 149 : IF(IRET.EQ.0)GO TO 90 150 : 151 : C write(6,*)' MTYP=',mtyp 152 : IF(MTYP.EQ.'MOT ')THEN 153 : 153 : CALL LIRCHA(NOM,1,IRET) 154 : C write(6,*)' NOM=',nom 154 : CALL OPTLI(IP,LMOTS(1),NOM,NBM) 155 : C write(6,*)' IP=',ip 156 : IF(IP.EQ.0)THEN 157 : IARG=IARG+1 157 : CALL ECME(MTABX,'IARG',IARG) 158 : NOMO=NOM 158 : IF(IARG.GT.9)CALL ARRET(0) 159 : WRITE(NOM,FMT='(A3,I1)')'ARG',IARG 159 : CALL ECMM(MTABX,NOM(1:4),NOMO) 160 : GO TO 111 161 : 162 : ELSE 162 : CALL ECME(MTABX,'IARG',IARG) 163 : GO TO 2 164 : ENDIF 165 : 166 : ELSEIF(MTYP.EQ.'CHPOINT ')THEN 166 : CALL LIROBJ('CHPOINT ',IZTAB,1,IRET) 167 : IARG=IARG+1 167 : CALL ECME(MTABX,'IARG',IARG) 167 : IF(IARG.GT.9)CALL ARRET(0) 168 : WRITE(NOM,FMT='(A3,I1)')'ARG',IARG 168 : CALL ECMO(MTABX,NOM(1:4),'CHPOINT ',IZTAB) 169 : GO TO 111 170 : 171 : ELSEIF(MTYP.EQ.'FLOTTANT')THEN 171 : CALL LIRREE(XVAL,1,IRET) 172 : IARG=IARG+1 172 : CALL ECME(MTABX,'IARG',IARG) 172 : IF(IARG.GT.9)CALL ARRET(0) 173 : WRITE(NOM,FMT='(A3,I1)')'ARG',IARG 173 : CALL ECMF(MTABX,NOM(1:4),XVAL) 174 : GO TO 111 175 : 176 : ELSEIF(MTYP.EQ.'ENTIER ')THEN 176 : CALL LIRENT(IENT,1,IRET) 177 : IARG=IARG+1 177 : CALL ECME(MTABX,'IARG',IARG) 177 : IF(IARG.GT.9)CALL ARRET(0) 178 : WRITE(NOM,FMT='(A3,I1)')'ARG',IARG 179 : XVAL=FLOAT(IENT) 179 : CALL ECMF(MTABX,NOM(1:4),XVAL) 180 : GO TO 111 181 : 182 : ELSEIF(MTYP.EQ.'POINT ')THEN 182 : CALL LIROBJ('POINT',IZTAB,1,IRET) 183 : IARG=IARG+1 183 : CALL ECME(MTABX,'IARG',IARG) 183 : IF(IARG.GT.9)CALL ARRET(0) 184 : WRITE(NOM,FMT='(A3,I1)')'ARG',IARG 184 : CALL ECMO(MTABX,NOM(1:4),'POINT',IZTAB) 185 : GO TO 111 186 : 187 : ELSE 188 : WRITE(6,*)' OBJET DE TYPE INDESIRE' 189 : WRITE(6,*)' ON ATTEND UN CHAMPOINT ou un FLOTTANT ' 190 : RETURN 191 : ENDIF 192 : 193 : 111 CONTINUE 193 : CALL ECME(MTABX,'IARG',IARG) 194 : GO TO 1 195 : 196 : 197 : 12 CONTINUE 197 : CALL LIRENT(IENT,1,IRET) 198 : IF(IRET.EQ.0.OR.IENT.GT.7) GOTO 90 198 : CALL ECME(MTABLE,'KTYPI',IENT) 199 : IF(IENT.GT.1) THEN 199 : CALL CRTABL(MTAB1) 199 : CALL ECMM(MTAB1,'SOUSTYPE','METHODE') 199 : CALL ECME(MTAB1,'KTYPI',IENT) 199 : CALL ECME(MTAB1,'NITMAX',2000) 199 : CALL ECMF(MTAB1,'EPSI',1.D-05) 199 : CALL ECME(MTAB1,'NPITE',10) 199 : CALL ECME(MTAB1,'NFIMPR',0) 199 : IF(IENT.GT.1.AND.IENT.LT.5) CALL ECME(MTAB1,'KSTOCK',0) 199 : CALL ECMO(MTABLE,'METHODE','TABLE',MTAB1) 200 : ENDIF 201 : GO TO 1 202 : 203 : C BETA 204 : 14 CONTINUE 205 : TYP2='MAILLAGE' 205 : CALL ACMO(MTABD,'MACRO',TYP2,IMAC) 206 : IF(IMAC.EQ.0)THEN 207 : WRITE(6,*)' EQPR : option MACRO absente de la table domaine ' 208 : RETURN 209 : ELSE 209 : CALL LIRREE(XVAL,1,IRET) 210 : IF(IRET.EQ.0)GOTO 90 210 : CALL ECME(MTABLE,'KBETA',1) 210 : CALL ECMF(MTABLE,'BETA',XVAL) 211 : ENDIF 212 : GO TO 1 213 : 214 : C KPIMP 215 : 15 CONTINUE 215 : CALL LIRREE(XVAL,1,IRET) 216 : IF(IRET.EQ.0)GOTO 90 216 : CALL ECME(MTABLE,'KPIMP',1) 216 : CALL ECMF(MTABLE,'PIMP',XVAL) 217 : GO TO 1 218 : 219 : 220 : 221 : 222 : 90 CONTINUE 223 : SEGDES MTABLE 223 : CALL ECROBJ('TABLE',MTABLE) 224 : RETURN 225 : END 226 : 227 : 228 : 229 : 230 : 231 :
© Cast3M 2003 - All rights reserved.
Disclaimer