C EQPR SOURCE CHAT 06/08/24 21:31:54 5529 SUBROUTINE EQPR IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC CCOPTIO -INC SMLENTI -INC SMLREEL -INC SMLMOTS POINTEUR MINCO.MLMOTS -INC SMTABLE POINTEUR MTABX.MTABLE,KIZL.MTABLE,KIZS.MTABLE,KIZC.MTABLE -INC SMELEME PARAMETER (NBM=5) CHARACTER*8 LMOTS(NBM),NOM,MEQUA,NOMO,NOMZ,MTYP,MOQ(2) CHARACTER*8 TYPE,TYP2,TYPS,TYPC PARAMETER (NTB=2) CHARACTER*8 LTAB(NTB) DIMENSION KTAB(NTB) DATA LMOTS /'ZONE ','OPER ','KTYPI ','BETA ', & 'PIMP '/ DATA LTAB/'DOMAINE ','EQPR '/ C*** CALL QUETYP(TYPE,0,IRET) MMODEL=0 IF(TYPE.EQ.'MMODEL')THEN CALL LIROBJ('MMODEL',MMODEL,0,IRET) CALL LEKMOD(MMODEL,MTBLE,INEFMD) IF(MTBLE.EQ.0)RETURN KTAB(1)=MTBLE KTAB(2)=0 ELSEIF(TYPE.EQ.'TABLE')THEN CALL LIROBJ(TYPE,MTBLE,0,IRET) TYPC=' ' CALL ACMO(MTBLE,'SOUSTYPE',TYPC,IRET) IF(TYPC.EQ.'MOT ')THEN CALL ACMM(MTBLE,'SOUSTYPE',TYPS) IF(TYPS.EQ.'DOMAINE')THEN KTAB(1)=MTBLE KTAB(2)=0 ELSEIF(TYPS.EQ.'EQPR')THEN KTAB(1)=0 KTAB(2)=MTBLE ELSE WRITE(IOIMP,*)' On attend une table soustype DOMAINE ou EQEX' RETURN ENDIF ENDIF ENDIF C??? C??? NTO=0 C??? CALL LITABS(LTAB,KTAB,NTB,NTO,IRET) C??? IF(IRET.EQ.0)THEN C??? WRITE(6,*)' On attend une table soustype DOMAINE ou EQPR' C??? RETURN C??? ENDIF IF(KTAB(1).NE.0.AND.KTAB(2).NE.0)THEN WRITE(6,*)' On ne peut donner simultanement les deux tables' RETURN ENDIF IF(KTAB(2).NE.0)THEN MTABLE=KTAB(2) SEGACT MTABLE MTYP='LISTMOTS' CALL ACMO(MTABLE,'LISTOPER',MTYP,MLMOT1) SEGACT MLMOT1 NEQUA=MLMOT1.MOTS(/2) ELSEIF(KTAB(1).NE.0)THEN MTABD=KTAB(1) CALL CRTABL(MTABLE) NEQUA=0 CALL ECMM(MTABLE,'SOUSTYPE','EQPR') CALL ECMO(MTABLE,'DOMAINE','TABLE ',MTABD) TYPE=' ' CALL ACMO(MTABD,'MACRO',TYPE,IMAC) IF(TYPE.NE.'MAILLAGE')THEN CALL ECME(MTABLE,'KBETA',0) CALL ECMF(MTABLE,'BETA',0.D0) ELSE CALL ECME(MTABLE,'KBETA',1) CALL ECMF(MTABLE,'BETA',1.D0) ENDIF CALL ECME(MTABLE,'KTYPI',1) CALL ECME(MTABLE,'KPIMP',0) CALL ECMF(MTABLE,'PIMP',0.D0) JGN=8 JGM=0 SEGINI MLMOT1 CALL ECMO(MTABLE,'LISTOPER','LISTMOTS',MLMOT1) ELSE WRITE(6,*)' On attend une table ou un objet maillage' RETURN ENDIF 1 CONTINUE CALL LIRCHA(NOM,0,IRET) IF(IRET.EQ.0)GO TO 90 2 CONTINUE C write(6,*)' EQPR : nom=',nom CALL OPTLI(IP,LMOTS,NOM,NBM) IF(IP.EQ.0)THEN WRITE(6,*)'OPTION NON TROUVE DANS LA LISTE ->',LMOTS RETURN ENDIF GO TO (10,11,12,14,15),IP 10 CONTINUE C ON LIT LA ZONE CALL LITABS(LTAB,KTAB,1,0,IRET) MMODEL=0 IF(KTAB(1).EQ.0)THEN CALL LIROBJ('MMODEL',MMODEL,0,IRET2) IF(IRET2.EQ.0)THEN WRITE(IOIMP,*)' On attend un objet TABLE DOMAINE ou MODELE' RETURN ENDIF CALL LEKMOD(MMODEL,MTBLE,INEFMD) IF(MTBLE.EQ.0)RETURN KTAB(1)=MTBLE ENDIF C??? IF(IRET.EQ.0)THEN C??? WRITE(6,*)' On attend un objet TABLE DOMAINE' C??? RETURN C??? ENDIF CALL QUENOM(NOMZ) C write(6,*)' NOM de la zone ',NOMZ GO TO 1 11 CONTINUE CALL LIRCHA(NOM,1,IRET) IF(IRET.EQ.0)THEN WRITE(6,*)' ON ATTEND LE NOM DE L OPERATEUR' RETURN C write(6,*)' NOM de l opérateur ',NOM ENDIF * ECRITURE DU NOM DE L'OPERATEUR NOMO=NOM NEQUA=NEQUA+1 IF(NEQUA.LT.10)THEN WRITE(MEQUA,FMT='(I1,A7)')NEQUA,NOMO(1:7) ELSEIF(NEQUA.LT.100.AND.NEQUA.GE.10)THEN WRITE(MEQUA,FMT='(I2,A6)')NEQUA,NOMO(1:6) ELSE WRITE(6,*)'PLUS DE 99 OPERATEURS : CAS NON PREVU' RETURN ENDIF JGN=8 JGM=MLMOT1.MOTS(/2)+1 SEGADJ MLMOT1 MLMOT1.MOTS(JGM)=MEQUA CALL LENCHA(MEQUA,LC1) CALL CRTABL(MTABX) CALL ECMM(MTABX,'SOUSTYPE','KIZP') CALL ECMO(MTABLE,MEQUA(1:LC1),'TABLE',MTABX) * ECRITURE DE LA TABLE DE REFERENCE CALL ECMO(MTABX,'EQPR','TABLE',MTABLE) * ECRITURE DU NOM DE LA ZONE CALL ECMM(MTABX,'NOMZONE',NOMZ) * ECRITURE DE MELEMZ CALL ECMO(MTABX,'DOMZ','TABLE',KTAB(1)) CALL ECMM(MTABX,'NOMOPER',NOM) * ECRITURE DE LA LISTE DES ARGUMENTS IARG=0 CALL ECME(MTABX,'IARG',IARG) 110 CONTINUE CALL QUETYP(MTYP,0,IRET) IF(IRET.EQ.0)GO TO 90 C write(6,*)' MTYP=',mtyp IF(MTYP.EQ.'MOT ')THEN CALL LIRCHA(NOM,1,IRET) C write(6,*)' NOM=',nom CALL OPTLI(IP,LMOTS(1),NOM,NBM) C write(6,*)' IP=',ip IF(IP.EQ.0)THEN IARG=IARG+1 CALL ECME(MTABX,'IARG',IARG) NOMO=NOM IF(IARG.GT.9)CALL ARRET(0) WRITE(NOM,FMT='(A3,I1)')'ARG',IARG CALL ECMM(MTABX,NOM(1:4),NOMO) GO TO 111 ELSE CALL ECME(MTABX,'IARG',IARG) GO TO 2 ENDIF ELSEIF(MTYP.EQ.'CHPOINT ')THEN CALL LIROBJ('CHPOINT ',IZTAB,1,IRET) IARG=IARG+1 CALL ECME(MTABX,'IARG',IARG) IF(IARG.GT.9)CALL ARRET(0) WRITE(NOM,FMT='(A3,I1)')'ARG',IARG CALL ECMO(MTABX,NOM(1:4),'CHPOINT ',IZTAB) GO TO 111 ELSEIF(MTYP.EQ.'FLOTTANT')THEN CALL LIRREE(XVAL,1,IRET) IARG=IARG+1 CALL ECME(MTABX,'IARG',IARG) IF(IARG.GT.9)CALL ARRET(0) WRITE(NOM,FMT='(A3,I1)')'ARG',IARG CALL ECMF(MTABX,NOM(1:4),XVAL) GO TO 111 ELSEIF(MTYP.EQ.'ENTIER ')THEN CALL LIRENT(IENT,1,IRET) IARG=IARG+1 CALL ECME(MTABX,'IARG',IARG) IF(IARG.GT.9)CALL ARRET(0) WRITE(NOM,FMT='(A3,I1)')'ARG',IARG XVAL=FLOAT(IENT) CALL ECMF(MTABX,NOM(1:4),XVAL) GO TO 111 ELSEIF(MTYP.EQ.'POINT ')THEN CALL LIROBJ('POINT',IZTAB,1,IRET) IARG=IARG+1 CALL ECME(MTABX,'IARG',IARG) IF(IARG.GT.9)CALL ARRET(0) WRITE(NOM,FMT='(A3,I1)')'ARG',IARG CALL ECMO(MTABX,NOM(1:4),'POINT',IZTAB) GO TO 111 ELSE WRITE(6,*)' OBJET DE TYPE INDESIRE' WRITE(6,*)' ON ATTEND UN CHAMPOINT ou un FLOTTANT ' RETURN ENDIF 111 CONTINUE CALL ECME(MTABX,'IARG',IARG) GO TO 1 12 CONTINUE CALL LIRENT(IENT,1,IRET) IF(IRET.EQ.0.OR.IENT.GT.7) GOTO 90 CALL ECME(MTABLE,'KTYPI',IENT) IF(IENT.GT.1) THEN CALL CRTABL(MTAB1) CALL ECMM(MTAB1,'SOUSTYPE','METHODE') CALL ECME(MTAB1,'KTYPI',IENT) CALL ECME(MTAB1,'NITMAX',2000) CALL ECMF(MTAB1,'EPSI',1.D-05) CALL ECME(MTAB1,'NPITE',10) CALL ECME(MTAB1,'NFIMPR',0) IF(IENT.GT.1.AND.IENT.LT.5) CALL ECME(MTAB1,'KSTOCK',0) CALL ECMO(MTABLE,'METHODE','TABLE',MTAB1) ENDIF GO TO 1 C BETA 14 CONTINUE TYP2='MAILLAGE' CALL ACMO(MTABD,'MACRO',TYP2,IMAC) IF(IMAC.EQ.0)THEN WRITE(6,*)' EQPR : option MACRO absente de la table domaine ' RETURN ELSE CALL LIRREE(XVAL,1,IRET) IF(IRET.EQ.0)GOTO 90 CALL ECME(MTABLE,'KBETA',1) CALL ECMF(MTABLE,'BETA',XVAL) ENDIF GO TO 1 C KPIMP 15 CONTINUE CALL LIRREE(XVAL,1,IRET) IF(IRET.EQ.0)GOTO 90 CALL ECME(MTABLE,'KPIMP',1) CALL ECMF(MTABLE,'PIMP',XVAL) GO TO 1 90 CONTINUE SEGDES MTABLE CALL ECROBJ('TABLE',MTABLE) RETURN END