Télécharger eqpr.eso

Retour à la liste

eqpr
C EQPR      SOURCE    JC220346  18/12/04    21:15:22     9991           
      SUBROUTINE EQPR
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCNOYAU
-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,MTYP,MOQ(2)
      CHARACTER*(LONOM) NOMZ
      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
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales