Télécharger option.eso

Retour à la liste

option
C OPTION    SOURCE    OF166741  25/02/11    21:15:03     12151          
 
C=======================================================================
C  Si ICHOI=1
C    Affection d'une valeur a une variable de CCOPTIO (directive OPTION)
C  Si ICHOI=2
C    Renvoie la valeur d'une des variables de CCOPTIO (operateur VALEUR)
C=======================================================================
 
      SUBROUTINE OPTION (ICHOI)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC CCHAMP
-INC CCASSIS
-INC SMCOORD
-INC SMLREEL
-INC SMLMOTS
-INC CCFXDR
-INC CCTRACE
-INC CCREEL
 
      SEGMENT MCOORa
        REAL*8 XCoora(LCoor)
      END SEGMENT
 
C NbOpt : Nombre d'options (mot-cles) des operateurs OPTION et VALEUR
C NbMfo : Nombre d'options mot-cle 'MODE' (vecteur MFO)
C NbMsfo :   "      "      mot-cle 'MODE' 'PLAN' (vecteur MSFO)
C NbNoha :   "      "      mot-cle 'FOUR' (vecteur NOHR)
C NbUnid :   "      "      mot-cle 'UNID' (vecteur OptUnid)
C NbMod1D :  "      "      mots-cles 'UNID' 'PLAN','AXIS' (vect. Mode1D)
C NbGra :    "      "      mot-cle 'TRAC' (vecteur MGR)
C NbIso :    "      "      mot-cle 'ISOV' (vecteur MISO)
C NbReso :   "      "      mot-cle 'RESO' (vecteur MRESOL)
C NbErre :   "      "      mot-cle 'ERRE' (vecteur ERCTRL)
C NbForm :   "      "      mot-cle 'SAUV' et 'REST' (vecteur FORMAT)
C NbAuto :   "      "      mot-cle 'NORM' (vecteur NAUTO)
      PARAMETER (NbOpt=50,NbMfo=6,NbMsfo=3,NbNoha=1,NbUnid=3,NbMod1D=12,
     $           NbGra=9,NbIso=3,NbReso=2,NbErre=4,NbForm=4,NbAuto=2,
     $           NbPoli=7,NbCosc=3,NbPotr=16,Nsuit=2)
 
      EXTERNAL     LONG
      CHARACTER*4  MCLE(NbOpt)
      CHARACTER*4  MFO(NbMfo)
      CHARACTER*4  MSFO(NbMsfo)
      CHARACTER*4  OptUnid(NbUnid)
      CHARACTER*4  Mode1D(NbMod1D)
      CHARACTER*4  MGR(NbGra)
      CHARACTER*4  MISO(NbIso)
      CHARACTER*4  MRESOL(NbReso)
      CHARACTER*4  ERCTRL(NbErre)
      CHARACTER*4  FORMAT(NbForm)
      CHARACTER*4  NOHR(nbnoha)
      integer*4 iohr
      equivalence(iohr,nohr)
      CHARACTER*4  NAUTO(NbAuto),MSUIT(Nsuit)
      CHARACTER*8  MPOLI(NbPoli)
      CHARACTER*12 ICHA
      CHARACTER*4  MCOSC(NbCosc)
      CHARACTER*12 MPOTR(NbPotr)
 
      CHARACTER*8 CHARIN,CHARRE,MDIINC,MDIDUA
      CHARACTER*8 MTYP
      CHARACTER*(LOCHAI) CHA
        CHARACTER*16 MODERI(5)
      LOGICAL LOG,ZEXIS,ZOPEN
 
      DATA MCLE / 'IMPR','DIME','ELEM','SORT','TRAC','DONN','ECHO',
     $            'ERRE','LECT','EPSI','IMPI','MODE','CADR','COUL',
     $            'NIVE','NGMA','SAUV','REST','ISOV','OMBR','NBP ',
     $            'VERI','ZERO','ACQU','----','PLAC','LANG','NORM',
     $            'RESO','FTRA','OEIL','ERMA','ASSI','EPTR','NAVI',
     $            'PARA','SURV','POLI','COSC','POTR','DEBU','LOCA',
     $            'DENS','INCO','POIN','PETI','GRAN','PREC','ATTE',
     $            'SOUC'/
      DATA MFO / 'TRID','FOUR','AXIS','PLAN','UNID','FREQ' /
      DATA MSFO / 'DEFO','CONT','GENE' /
      DATA NOHR / 'NOHA' /
      DATA OptUnid / 'PLAN','AXIS','SPHE' /
      DATA Mode1D / 'DYDZ','DYCZ','CYDZ','CYCZ','GYDZ','GYCZ','DYGZ',
     .              'CYGZ','GYGZ','AXDZ','AXCZ','AXGZ' /
      DATA MGR / 'BENS','X   ','IBM ','GKS ','PHIG','OPEN','PS  ',
     .           'MIF ','PSC ' /
      DATA MISO / 'LIGN','SURF','SULI' /
      DATA MRESOL / 'DIRE','ITER' /
      DATA ERCTRL / 'FATA','NORM','IGNO','CONT' /
      DATA FORMAT / 'FORM','TAIL','XDR ','BINA' /
      DATA NAUTO / 'AUTO','ANNU' /
      DATA MODERI /'LINEAIRE       ','QUADRATIQUE     ',
     $ 'TRUESDELL       ','JAUMANN         ','UTILISATEUR     '/
      DATA MPOLI / '8_BY_13 ','9_BY_15 ','TIMES_10','TIMES_24',
     $             'HELV_10 ','HELV_12 ','HELV_18 ' /
      DATA MCOSC / 'NOIR','BLAN','JAUN' /
      DATA MPOTR / 'COURIER_12  ','COURIERB_12 ','HELVETICA_12'
     $     ,'TIMES_12    ','COURIER_14  ','COURIERB_14 ','HELVETICA_14'
     $     ,'TIMES_14    ','COURIER_16  ','COURIERB_16 ','HELVETICA_16'
     $     ,'TIMES_16    ','COURIER_18  ','COURIERB_18 ','HELVETICA_18'
     $     ,'TIMES_18    '/
      DATA MSUIT / 'NOUV','SUIT' /
 
      IF ((ICHOI.NE.1).AND.(ICHOI.NE.2)) THEN
        CALL ERREUR (5)
        RETURN
      ENDIF
      i=0
 1    CONTINUE
      CALL QUETYP(MTYP,0,IRET)
      IF (IRET.EQ.0) RETURN
      IF (MTYP.NE.'MOT') THEN
C  39 2
C On ne veut pas d'objet de type %m1:8
         MOTERR(1:8)=MTYP
         CALL ERREUR(39)
         RETURN
      ENDIF
Csg      CALL MESLIR(-218)
      CALL LIRMOT(MCLE,NBOPT,i,1)
      IF (IERR.NE.0) RETURN
 
C  Branchement vers les differentes options
C ------------------------------------------
      GOTO (101,102,103,104,105,106,107,108,109,110,111,112,113,114,
     $     115,116,117,118,119,120,121,122,123,124,125,126,127,128,
     $     129,130,131,132,133,134,135,136,137,138,139,140,141,142,
     $     143,144,145,146,147,148,149,150),i
      return
C ---------------
C  Option 'IMPR'
C ---------------
 101  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IOIMP)
        RETURN
      ENDIF
      CALL MESLIR(-217)
      CALL LIRENT(IRET,0,IRetou)
      IF (IRetou.NE.0) THEN
        IF (IRET.LE.0) CALL ERREUR(36)
        IF (IERR.NE.0) RETURN
        IOIMP=IRET
        GOTO 1
      ENDIF
      CALL MESLIR(-216)
      CALL LIRCHA(CHA,1,IRetou)
      IF (IERR.NE.0) RETURN
      IUNIT=IOIMP
      GOTO 1211
C ---------------
C  Option 'DIME' : dimension de l'espace (IDIM)
C ---------------
 102  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IDIM)
        RETURN
      ENDIF
      CALL MESLIR(-215)
      CALL LIRENT(IRET,1,IRetou)
      IF (IERR.NE.0) RETURN
      IF (IRET.LT.1 .OR. IRET.GT.3) THEN
        CALL ERREUR(832)
        IERR   = 0
        IERGLB = 0
        INTERR(1) = IRET
        CALL ERREUR(36)
        RETURN
      ENDIF
      IF (IRET.EQ.IDIM) GOTO 1
      IF (IDIM.EQ.0) THEN
        IDIM=IRET
        IF (IDIM.EQ.1) THEN
          IFOMOD=3
          IFOUR=3
          NIFOUR=0
        ELSE IF (IDIM.EQ.3) THEN
          IFOMOD=2
          IFOUR=2
          NIFOUR=0
        ENDIF
        GOTO 1
      ENDIF
C  Passage en dimension 3
      IF (IRET.EQ.3) THEN
        IFOMOD=2
        IFOUR=2
        NIFOUR=0
C  Passage en dimension 2, on met les options de calcul a PLAN DEFO.
      ELSE IF (IRET.EQ.2) THEN
        IF (IDIM.EQ.3) THEN
          IF (IFOMOD.EQ.2) IFOMOD=-1
          IF (IFOUR.EQ.2) IFOUR=-1
        ELSE IF (IDIM.EQ.1) THEN
          IFOMOD=-1
          IFOUR=-1
          NIFOUR=0
        ENDIF
C  Passage en dimension 1, on met les options de calcul a UNIDPLANDYDZ.
      ELSE IF (IRET.EQ.1) THEN
        IF (IFOMOD.NE.3.AND.IFOMOD.NE.4.AND.IFOMOD.NE.5) THEN
          IFOMOD=3
          IFOUR=3
          NIFOUR=0
        ENDIF
      ENDIF
C  Transfert des coordonnees des points dans nouveau MCOORD
      idimp1=IDIM+1
      iretp1=IRET+1
      segact mcoord*mod
      LCoor=NBPTS*iretp1
      SEGINI,MCOORa
      INF=MIN(IDIM,IRET)
      DO IP=1,NBPTS
        IRef1=(IP-1)*iretp1
        IRef =(IP-1)*idimp1
        DO j=1,INF
          XCoora(IRef1+j)=XCOOR(IRef+j)
        ENDDO
        XCoora(IRef1+iretp1)=XCOOR(IRef+idimp1)
      ENDDO
      IDIM=IRET
      SEGADJ,MCOORD
      DO j=1,XCOOR(/1)
        XCOOR(j)=XCOORa(j)
      ENDDO
      SEGSUP,MCOORa
      GOTO 1
C ---------------
C  Option 'ELEM'
C ---------------
 103  IF (ICHOI.EQ.2) THEN
        IF (ILCOUR.EQ.0) THEN
          CALL ECRCHA('    ')
        ELSE
          CALL ECRCHA(NOMS(ILCOUR))
        ENDIF
        RETURN
      ENDIF
      CALL MESLIR(-214)
      CALL LIRMOT(NOMS,NOMBR,IRET,1)
      IF (IERR.NE.0) RETURN
      ILCOUR=IRET
C*    ICHA=NOMS(ILCOUR)
      GOTO 1
C ---------------
C  Option 'SORT'
C ---------------
 104  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IOPER)
        RETURN
      ENDIF
      CALL MESLIR(-213)
      CALL LIRENT(IRET,0,IRetou)
      IF (IRetou.NE.0) THEN
        IF (IRET.LE.0) CALL ERREUR(36)
        IF (IERR.NE.0) RETURN
        IOPER=IRET
        GOTO 1
      ENDIF
      CALL MESLIR(-212)
      CALL LIRCHA(CHA,1,IRetou)
      IF (IERR.NE.0) RETURN
      IUNIT=IOPER
      GOTO 1211
C ---------------
C  Option 'TRAC'
C ---------------
 105  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA(MGR(IOGRA))
        RETURN
      ENDIF
      CALL MESLIR(-211)
      CALL LIRMOT(MGR,NbGra,ij,1)
      IF (IERR.NE.0) RETURN
      IOGRA=ij
      GOTO 1
C ---------------
C  Option 'DONN'
C ---------------
 106  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IOLEC)
        RETURN
      ENDIF
      CALL MESLIR(-210)
      CALL LIRENT(IRET,0,IRetou)
      IF (IRetou.NE.0) THEN
        IF (IRET.LE.0) CALL ERREUR(36)
        IF (IERR.NE.0) RETURN
        IOLEC=IRET
        CALL GINT2
        GOTO 1
      ENDIF
      CALL MESLIR(-209)
      CALL LIRCHA(CHA,1,IRetou)
      IF (IERR.NE.0) RETURN
C  On impose IOLEC=3 pour eviter probleme avec lecture terminal
      IOLEC=3
      CALL GINT2
      IUNIT=IOLEC
      GOTO 1201
C ---------------
C  Option 'ECHO'
C ---------------
 107  CONTINUE
      IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IECHO)
        RETURN
      ENDIF
      CALL MESLIR(-208)
      CALL LIRENT(IRET,1,IRetou)
      INTERR(1)=iret
      IF ((IRET .LT. -1) .OR. (IRET .GT. 2)) CALL ERREUR(36)
      IF (IERR.NE.0) RETURN
      IECHO=IRET
      GOTO 1
C ---------------
C  Option 'ERRE'
C ---------------
 108  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA(ERCTRL(IERPER))
        RETURN
      ENDIF
      CALL MESLIR(-207)
      CALL LIRMOT(ERCTRL,NbErre,IRET,1)
      IF (IERR.NE.0) RETURN
      IERPER=IRET
      GOTO 1
C ---------------
C  Option 'LECT'
C ---------------
 109  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IOCAR)
        RETURN
      ENDIF
      CALL MESLIR(-206)
      CALL LIRENT(IRET,0,IRetou)
      IF (IRetou.NE.0) THEN
        IF (IRET.LE.0) CALL ERREUR(36)
        IF (IERR.NE.0) RETURN
        IOCAR=IRET
        GOTO 1
      ENDIF
      CALL MESLIR(-205)
      CALL LIRCHA(CHA,1,IRetou)
      IF (IERR.NE.0) RETURN
      IUNIT=IOCAR
      GOTO 1201
C ---------------
C  Option 'EPSI' (ex-'DERI') --> utilisee dans config
C ---------------
  110  IF (ICHOI.EQ.2) THEN
         CALL ECRCHA(moderi(MEPSIL))
         RETURN
       ENDIF
       CALL MESLIR(-204)
       CALL LIRMOT(MODERI,5,iret,1)
       IF (IERR.NE.0) RETURN
       MEPSIL=IRET
       GO TO 1
*110  CONTINUE
*     IF(ICHOI.EQ.2) THEN
*       MOTERR(1:40)='VALE EPSI ;'
*     ELSE
*       MOTERR(1:40)='OPTI EPSI ... ;'
*     ENDIF
*     CALL ERREUR(1056)
*     RETURN
C ---------------
C  Option 'IMPI'
C ---------------
 111  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IIMPI)
        RETURN
      ENDIF
      CALL MESLIR(-202)
      CALL LIRENT(IRET,1,IRetou)
      IF (IERR.NE.0) RETURN
      IIMPI=IRET
      GOTO 1
C ---------------
C  Option 'MODE'
C ---------------
 112  IF (ICHOI.EQ.2) THEN
c     on a appele VALE 'MODE'
c       souhaite t'on FOUR ou le numero d'harmonique ?
        INH=0
        IF (IFOMOD.EQ.1) THEN
          CALL LIRMOT(MFO(2),1,INH,0)
        ENDIF
        IF (IFOMOD.EQ.-1) THEN
c       - PLAN
          ICHA(1:4)=MFO(4)
          ICHA(5:8)=MSFO(ABS(IFOUR))
          CALL ECRCHA(ICHA(1:8))
        ELSE IF (IFOMOD.EQ.3) THEN
c       - 1D PLAN
          ICHA(1:4)=MFO(5)
          ICHA(5:8)=OptUnid(1)
          ICHA(9:12)=Mode1D(IFOUR-2)
          CALL ECRCHA(ICHA(1:12))
        ELSE IF (IFOMOD.EQ.4) THEN
c       - 1D AXIS
          ICHA(1:4)=MFO(5)
          ICHA(5:8)=OptUnid(2)
          ICHA(9:12)=Mode1D(IFOUR-2)
          CALL ECRCHA(ICHA(1:12))
        ELSE IF (IFOMOD.EQ.5) THEN
c       - 1D SPHE
          ICHA(1:4)=MFO(5)
          ICHA(5:8)=OptUnid(3)
          ICHA(9:12)='    '
          CALL ECRCHA(ICHA(1:8))
        ELSE IF (IFOMOD.EQ.6) THEN
c       - FREQuentiel
          CALL ECRCHA(MFO(6))
        ELSE
          if (INH.eq.1) then
c         - numero d'harmonique de Fourier
            NHH=iohr
            if(NIFOUR.eq.NHH) then
              ICHA(1:4)='NOHA'
              CALL ECRCHA(ICHA(1:4))
            else
              CALL ECRENT(NIFOUR)
            endif
          else
c         - autres cas (TRID FOUR AXIS PLAN)
            CALL ECRCHA(MFO(3-IFOMOD))
          endif
        ENDIF
        RETURN
      ENDIF
c     on a appele OPTI 'MODE'
      CALL MESLIR(-201)
      CALL LIRMOT(MFO,NbMfo,IK,1)
      IF ((IERR.NE.0).OR.(IK.EQ.0)) RETURN
      IF (IK.EQ.1) THEN
c     - OPTI 'MODE' 'TRID'
        IRET=2
      ELSE IF (IK.EQ.2) THEN
c     - OPTI 'MODE' 'FOUR'
        IRET=1
      ELSE IF (IK.EQ.3) THEN
c     - OPTI 'MODE' 'AXIS'
        IRET=0
      ELSE IF (IK.EQ.4) THEN
c     - OPTI 'MODE' 'PLAN'
        IRET=-1
      ELSE IF (IK.EQ.5) THEN
c     - OPTI 'MODE' 'UNID'
        IRET=3
      ELSE IF (IK.EQ.6) THEN
c     - OPTI 'MODE' 'FREQ'
        IRET=6
      ENDIF
C  Possibilite d'imprimer une erreur si le MODE de calcul n'est pas
C  compatible avec la dimension. Debranche pour l'instant.
C**   IF ( (IDIM.EQ.2.AND.IRET.NE.-1.AND.IRET.NE.0.AND.IRET.NE.1)
C**  . .OR.(IDIM.EQ.1.AND.IRET.NE.3).OR.(IDIM.EQ.3.AND.IRET.NE.2) ) THEN
C**     MOTERR(1:4)=MFO(IK)
C**     INTERR(1)=IDIM
C**     CALL ERREUR(970)
C**     RETURN
C**   ENDIF
      IFOMOD=IRET
      if (iret.ne.6) IFOUR=IRET
cckich       NIFOUR=0
      IF (IRET.EQ.-1) THEN
        CALL LIRMOT(MSFO,NbMsfo,IKS,0)
        IF (IKS.EQ.0) THEN
          IFOUR=-1
        ELSE IF (IKS.EQ.1) THEN
          IFOUR=-1
        ELSE IF (IKS.EQ.2) THEN
          IFOUR=-2
        ELSE IF (IKS.EQ.3) THEN
          IFOUR=-3
        ENDIF
      ELSE IF (IRET.EQ.1) THEN
        CALL LIRENT(NHH,0,ICOND)
        IF (ICOND.EQ.0) THEN
          CALL LIRMOT(NOHR,NbNoha,NHH,0)
          IF (NHH.EQ.1) THEN
            nhh=iohr
          ELSE
            CALL ERREUR(287)
          ENDIF
        ENDIF
        NIFOUR=NHH
      ELSE IF (IRET.EQ.3) THEN
        CALL LIRMOT(OptUnid,NbUnid,IKS,0)
        IF (IKS.EQ.0) THEN
          IFOMOD=3
          IFOUR=3
        ELSE IF (IKS.EQ.1) THEN
          IFOMOD=3
          CALL LIRMOT(Mode1D(1),9,i,0)
          IF (i.EQ.0) i=1
          IFOUR=2+i
        ELSE IF (IKS.EQ.2) THEN
          IFOMOD=4
          CALL LIRMOT(Mode1D(10),3,i,0)
          IF (i.EQ.0) i=1
          IFOUR=11+i
        ELSE IF (IKS.EQ.3) THEN
          IFOMOD=5
          IFOUR=15
        ENDIF
      ENDIF
      GOTO 1
C ---------------
C  Option 'CADR'
C ---------------
 113  IF (ICHOI.EQ.2) THEN
        XRET=DIOCAD
        CALL ECRREE(XRET)
        RETURN
      ENDIF
      CALL MESLIR(-200)
      CALL LIRREE(XRET,1,IRetou)
      IF (IERR.NE.0) RETURN
      DIOCAD=XRET
      GOTO 1
C ---------------
C  Option 'COUL'
C ---------------
 114  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA(NCOUL(IDCOUL))
        RETURN
      ENDIF
      CALL MESLIR(-199)
      CALL LIRMOT(NCOUL(0),NBCOUL,IRET,1)
      IF (IRET.LE.0) CALL ERREUR(36)
      IF (IERR.NE.0) RETURN
      IDCOUL=IRET-1
      ICHA=NCOUL(IDCOUL)
      GOTO 1
C ---------------
C  Option 'NIVE'
C ---------------
 115  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IONIVE)
        RETURN
      ENDIF
      CALL MESLIR(-198)
      CALL LIRENT(IRET,1,IRetou)
      IF (IERR.NE.0) RETURN
      IF (IRET.LT.0) THEN
        INTERR(1)=IRET
        INTERR(2)=1
        INTERR(3)=IGRAND
        CALL ERREUR(1068)
        RETURN
      ENDIF
      IF (IRET.EQ.IONIVE) RETURN
      write(ioimp,*) 'Changement IONIVE',IONIVE,'->',IRET
      IONIVE = IRET
      GOTO 1
C ---------------
C  Option 'NGMA'
C ---------------
 116  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(NGMAXY)
        RETURN
      ENDIF
      CALL MESLIR(-197)
      CALL LIRENT(IRET,1,IRetou)
      IF (IERR.NE.0) RETURN
      INTERR(1)=IRET
      IF (IRET.LT.0) CALL ERREUR (36)
      NGMAXY=IRET
      GOTO 1
C ---------------
C  Option 'SAUV'
C ---------------
 117  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IOSAU)
        RETURN
      ENDIF
      CALL MESLIR(-196)
      IFORM=2
      IPREFI=0
      DIMATT=0.D0
      IREFOR=0
      ISAFOR=0
      IF (IPSAUV.NE.0) CALL LIBPIL(IPSAUV)
      IPSAUV=0
1171  CALL LIRMOT(FORMAT,NbForm,ICHOr,0)
      IF (ICHOr.EQ.1) THEN
        IFORM=1
        ISAFOR=1
        GOTO 1171
      ELSE IF (ICHOr.EQ.2) THEN
        CALL LIRREE(XRET,1,IRetou)
        IF (IERR.NE.0) RETURN
        DIMFIC=XRET
        GOTO 1171
      ELSE IF (ICHOr.EQ.3) THEN
        IFORM=2
        GOTO 1171
      ELSE IF (ICHOr.EQ.4) THEN
        IFORM=0
        GOTO 1171
      ENDIF
      CALL LIRENT(IRET,0,IRetou)
      IF (IRetou.NE.0) THEN
        IF (IRET.LE.0) CALL ERREUR(36)
        IF (IERR.NE.0) RETURN
        IOSAU=IRET
        IPSAUV=0
        GOTO 1
      ENDIF
      CALL MESLIR(-195)
      CALL LIRCHA(CHA,1,IRetou)
      IF (IERR.NE.0) RETURN
      lchai=long(cha)
* la longueur du fichier maximale est LOCHAI moins la longueur("_iiii")
* ou iiii designe le nombre maximal de fichiers de sauvegarde possible
* A ce jour la limite est 9999 fichiers. LONG("_9999") = 5
      IF (lchai.GT.(LOCHAI-5)) THEN
        write(ioimp,*) 'SAUV File Name is too LONG'
        CALL ERREUR(1111)
        RETURN
      ENDIF
      NOMSAU = ' '
      NOMSAU(1:lchai)=cha(1:lchai)
      IUNIT=IOSAU
      IPSAUV=0
      lcha=lchai
*  destruction des eventuels fichiers existants
      open(file=NOMSAU(1:lcha),status='OLD',iostat=istat,unit=iunit)
      if (istat.eq.0) then
       close(iunit,status='DELETE',iostat=istat)
       if (istat.ne.0) then
       endif
      else
       goto 1173
      endif
      ll=lcha+1
      NOMSAU(ll:ll+1)='_1'
      ll=ll+1
      do isuit=1,10000
      if (isuit.lt.10) then
        write (NOMSAU(ll:ll),fmt='(I1)') isuit
        lcha=ll
      elseif (isuit.lt.100) then
        write (NOMSAU(ll:ll+1),fmt='(I2)') isuit
        lcha=ll+1
      elseif (isuit.lt.1000) then
        write (NOMSAU(ll:ll+2),fmt='(I3)') isuit
        lcha=ll+2
      elseif (isuit.lt.10000) then
        write (NOMSAU(ll:ll+3),fmt='(I4)') isuit
        lcha=ll+3
      endif
      open(file=NOMSAU(1:lcha),status='OLD',iostat=istat,unit=iunit)
      if (istat.eq.0) then
       close(iunit,status='DELETE',iostat=istat)
      else
       goto 1173
      endif
      enddo
 1173 continue
      NOMSAU(lchai+1:lochai) = ' '
      IF (IFORM.EQ.1) GOTO 3201
      IF (IFORM.EQ.2) GOTO 1203
      GOTO 1202
C ---------------
C  Option 'REST'
C ---------------
 118  CONTINUE
      IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IORES)
        RETURN
      ENDIF
      IFICLE=0
      IFORM=0
      IREFOR=0
      CALL MESLIR(-193)
 1172 CALL LIRMOT(FORMAT,nbform,ichor,0)
      IF (IERR.NE.0) RETURN
      IF (ICHOr.EQ.1) THEN
       IREFOR=1
       IFORM=1
       GOTO 1172
      ELSE IF (ICHOr.EQ.2) THEN
        GOTO 1172
      ELSE IF (ICHOr.EQ.3) THEN
        IFORM=-2
        GOTO 1172
      ELSEIF (ICHOr.EQ.4) then
        IFORM=0
        GOTO 1172
      ENDIF
      CALL MESLIR(-194)
      CALL LIRENT(IRET,0,IRetou)
      IF (IRetou.NE.0) THEN
        IF (IRET.LE.0) CALL ERREUR(36)
        IF (IERR.NE.0) RETURN
        IORES=IRET
        GOTO 1
      ENDIF
      CALL LIRCHA(CHA,1,IRetou)
      IF (IERR.NE.0) RETURN
      L=LONG(CHA)
      IUNIT=IORES
      NOMRES=' '
      NOMRES(1:L)=CHA(1:L)
C  test sur le type de fichier
      CLOSE(UNIT=IUNIT,iostat=istat)
      IFORM=1
      IREFOR=1
      IFIOLD=599
      OPEN(UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
     .     IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
      IF (IOS.EQ.0) THEN
        iretou=0
        iquoi=0
        CALL LFCDES(IORES,IQUOI,IRETOU,IFORM)
C       WRITE(IOIMP,*) 'apres lfcdes-1 ',iores,iquoi,iretou,iform
        IF (IOS.EQ.0.AND.(IQUOI.GT.0.AND.IQUOI.LT.10).AND.
     .      IRETOU.EQ.0) THEN
          CALL ERREUR(-342)
          GOTO 3250
        ENDIF
      ENDIF
      IFORM=0
      IREFOR=0
      CLOSE(UNIT=IUNIT,iostat=istat)
      OPEN(UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
     .     IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
      IF (IOS.EQ.0) THEN
        iretou=0
        iquoi=0
        CALL LFCDES (IORES,IQUOI,IRETOU,IFORM)
C       WRITE (IOIMP,*) 'apres lfcdes-2 ',iores,iquoi,iretou,iform
        IF (IOS.EQ.0.AND.(IQUOI.GT.0.AND.IQUOI.LT.10).AND.
     .      IRETOU.EQ.0) THEN
          CALL ERREUR(-343)
          GOTO 3250
        ENDIF
      ENDIF
      IFORM=2
      IF (ixdrr.NE.0) IOS=IXDRCLOSE(ixdrr,.TRUE.)
      ios=initxdr(CHA(1:L),'r',.TRUE.)
      IF (ios.lt.0) GOTO 2000
      ixdrr=ios
      ios=IXDRSTRING(ixdrr,ICHA(1:10))
C     WRITE(IOIMP,*) ' option rest ',icha(1:10),ios
      IF (IOS.GE.0.AND.ICHA(1:10).EQ.'CASTEM XDR') THEN
C       WRITE (IOIMP,*) ' on va direct en 1 '
        IFORM=2
        iformx=IFORM
        CALL ERREUR(-344)
        GOTO 1
      ENDIF
      IFIOLD=424
      GOTO 2000
 3250 iformx=IFORM
      IF (IFORM.EQ.1) GOTO 2201
      IF (IFORM.EQ.-2) GOTO 2203
      GOTO 2202
C ---------------
C  Option 'ISOV'
C ---------------
 119  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA(MISO(ISOTYP+1))
        RETURN
      ENDIF
      CALL MESLIR(-192)
      CALL LIRMOT(MISO,NbIso,IRET,1)
      IF (IRET.LE.0) CALL ERREUR(36)
      IF (IERR.NE.0) RETURN
      ISOTYP=IRET-1
      ICHA=MISO(IRET)
      GOTO 1
C ---------------
C  Option 'OMBRE'
C ---------------
 120  IF (ICHOI.EQ.2) THEN
        LOG=.FALSE.
        IF (IOMBRE.EQ.1) LOG =.TRUE.
        CALL ECRLOG(LOG)
        RETURN
      ENDIF
      CALL MESLIR(-191)
      CALL LIRLOG(LOG,1,IRET)
      IF (IERR.NE.0) RETURN
      IF (LOG) THEN
        IOMBRE=1
      ELSE
        IOMBRE=0
      ENDIF
      GOTO 1
C ---------------
C  Option 'NBP '
C ---------------
 121  IF (ICHOI.EQ.2) THEN
        IRET=mcoord
        CALL ECRENT(IRET)
        RETURN
      ENDIF
      CALL MESLIR(-190)
      CALL LIRENT(IRET,1,IRetou)
      IF (IERR.NE.0) RETURN
      NBPTS=MAX(0,IRET)
      SEGADJ MCOORD
      GOTO 1
C ---------------
C  Option 'VERI'
C ---------------
 122  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IOSPI)
        RETURN
      ENDIF
      CALL MESLIR(-189)
      CALL LIRENT(IRET,1,IRetou)
      IF (IERR.NE.0) RETURN
      IOSPI=IRET
      GOTO 1
C ---------------
C  Option 'ZERO'
C ---------------
 123  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IZROSF)
        RETURN
      ENDIF
      CALL MESLIR(-188)
      CALL LIRENT(IRET,1,IRetou)
      IF (IERR.NE.0) RETURN
      IZROSF=MAX(1,IRET)
      GOTO 1
C ---------------
C  Option 'ACQU'
C ---------------
 124  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IOACQ)
        RETURN
      ENDIF
      CALL MESLIR(-187)
      CALL LIRENT(IRET,0,IRetou)
      IF (IRetou.NE.0) THEN
        IOACQ=IRET
        GOTO 1
      ENDIF
      CALL MESLIR(-186)
      CALL LIRCHA(CHA,1,IRetou)
      IF (IERR.NE.0) RETURN
      IUNIT=IOACQ
      GOTO 1201
C ---------------
C  Option '----'
C ---------------
 125  CONTINUE
      GOTO 1
C ---------------
C  Option 'PLAC'
C ---------------
 126  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IPLLB)
        RETURN
      ENDIF
      CALL MESLIR(-184)
      CALL LIRENT(IRET,1,IRetou)
      IF (IERR.NE.0) RETURN
C  Pourquoi mettre IPLLB en positif ?
C  N'etant pas sur de la valeur de IPLTOT il faut pouvoir le mettre
C  en negatif tres grand (voir T.C.)
C     IRET=MAX(1,IRET)
      IPLLB=IRET
      GOTO 1
C ---------------
C  Option 'LANG'
C ---------------
 127  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA (LANGUE)
        RETURN
      ENDIF
      CALL LIRCHA(ICHA,1,IRetou)
      IF (IERR.NE.0) RETURN
      LANGUE=ICHA
      GOTO 1
C ---------------
C  Option 'NORM'
C ---------------
 128  IF (ICHOI.EQ.2) THEN
        CALL ERREUR(758)
        RETURN
      ENDIF
C  On commence par une remise a plat : tout a 0 .
C  On devrait liberer la place occupee eventuellement par ces segments,
C  mais comme on a fait SAVSEG avant. Il faudrait aussi les enlever de
C  la liste des non-effacables, mais comment ?
      NORINC=0
      NORVAL=0
      NORIND=0
      NORVAD=0
C  Lecture des mts cles eventuels
      CALL LIRMOT(NAUTO,NbAuto,i,0)
      IF (i.EQ.2) GOTO 1
C  Normalisation automatique
      IF (i.EQ.1) THEN
        NORINC=-1
        GOTO 1
      ENDIF
      CALL LIROBJ('LISTMOTS',NORINC,1,IRetou)
      CALL LIROBJ('LISTREEL',NORVAL,1,IRetou)
      IF (IERR.NE.0) THEN
        NORINC=0
        NORVAL=0
        GOTO 1
      ENDIF
      MLREEL=NORVAL
      MLMOTS=NORINC
      SEGACT MLREEL,MLMOTS
      NRE=PROG(/1)
      NMO=MOTS(/2)
      SEGDES MLREEL,MLMOTS
      IF (NRE.NE.NMO) THEN
        CALL ERREUR(212)
        NORINC=0
        NORVAL=0
        RETURN
      ENDIF
C  Verification s'il n'y a pas de 'LX' la dedans
C  La taille de mots doit etre OK si le LISTMOTS est cree par MOTS
      SEGACT MLMOTS
      DO i=1,NMO
        IF (MOTS(i)(1:4).EQ.'LX  ') THEN
          CALL ERREUR( 759 )
          NORINC=0
          NORVAL=0
          SEGDES MLMOTS
          RETURN
        ENDIF
      ENDDO
      SEGDES MLMOTS
      CALL SAVSEG(MLREEL)
      CALL SAVSEG(MLMOTS)
      CALL LIROBJ('LISTMOTS',NORIND,0,IRetou)
      IF (IRetou.EQ.0) GOTO 1
      CALL LIROBJ('LISTREEL',NORVAD,1,IRetou)
      IF (IERR.NE.0) THEN
        NORIND=0
        NORVAD=0
      ENDIF
      MLREEL=NORVAD
      MLMOTS=NORIND
      SEGACT MLREEL,MLMOTS
      NRE=PROG(/1)
      NMO=MOTS(/2)
      SEGDES MLREEL,MLMOTS
      IF (NRE.NE.NMO) THEN
        CALL ERREUR(212)
        NORIND=0
        NORVAD=0
        RETURN
      ENDIF
      CALL SAVSEG(MLREEL)
      CALL SAVSEG(MLMOTS)
      GOTO 1
C ---------------
C  Option 'RESO'
C ---------------
 129  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA(MRESOL(NUCROU+1))
        RETURN
      ENDIF
      CALL MESLIR(-187)
      CALL LIRMOT(MRESOL,NbReso,IRetou,1)
      IF (IERR.NE.0) RETURN
       NUCROU=IRetou-1
      GOTO 1
C ---------------
C  Option 'FTRA'
C ---------------
 130  IF (ICHOI.EQ.2) THEN
        IF (iogra.ge.7.and.iogra.le.9) THEN
          IF (IOGRA.EQ.8) THEN
            IUPS=97
          ELSE
            IUPS=24
          ENDIF
          INQUIRE(UNIT=IUPS,NAME=CHA)
          CALL ECRCHA(CHA(1:LONG(CHA)))
          RETURN
        ELSE
          CALL ERREUR(758)
          RETURN
        ENDIF
      ENDIF
      IF (iogra.ge.7.and.iogra.le.9) THEN
c         ZINIPS=.TRUE.
        CALL MESLIR(-209)
        CALL LIRCHA(CHA,1,IRetou)
        IF (IERR.NE.0) RETURN
        IF (IOGRA.EQ.8) THEN
          IUPS=97
        ELSE
          IUPS=24
        ENDIF
        IUNIT=IUPS
        GOTO 1211
      ELSE
        CALL ERREUR(26)
        RETURN
      ENDIF
      GOTO 1
C ---------------
C  Option 'OEIL'
C ---------------
 131  IF (ICHOI.EQ.2) THEN
         IF (IOEIL.NE.0) THEN
            CALL ECROBJ('POINT',IOEIL)
         ELSE
C  18 2 Point non trouve
            CALL ERREUR(18)
         ENDIF
         RETURN
      ENDIF
      CALL LIROBJ('POINT',IOEIL,1,IRetou)
      IF (IERR.NE.0) RETURN
      GOTO 1
C ---------------
C  Option 'ERMA'
C ---------------
 132  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IERMAX)
        RETURN
      ELSE
         CALL ERREUR(758)
         RETURN
      ENDIF
      GOTO 1
C ---------------
C  Option 'ASSI'
C ---------------
 133  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(NBESCR)
        RETURN
      ENDIF
      IF (NBESC.NE.0) CALL ERREUR(892)
      IF (IERR.NE.0) RETURN
      CALL LIRENT(IRET,0,IRetou)
      IF (IRetou.NE.0) THEN
        IF (IRET.LT.0) CALL ERREUR(36)
        IF (IRET.GT.64) CALL ERREUR(36)
        if (nbesc.ne.0) call erreur(36)
        if (ierr.eq.0.and.nbesc.eq.0) then
         NBESCR=IRET
        endif
      ENDIF
      GOTO 1
C ---------------
C  Option 'EPTR'
C ---------------
 134  IF (ICHOI.EQ.2) THEN
        CALL ECRENT(IEPTR)
        RETURN
      ENDIF
      CALL MESLIR(-340)
      CALL LIRENT(IRET,1,IRetou)
      IF (IRetou.NE.0) THEN
        IF (IRET.LT.0) CALL ERREUR(36)
        IEPTR=IRET
      ENDIF
      GOTO 1
C ---------------
C  Option 'NAVI'
C ---------------
 135  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA(NNAVI(ILNAVI))
        RETURN
      ENDIF
      CALL MESLIR(-341)
      CALL LIRMOT(NNAVI,LNNAVI,IRET,1)
      IF (IERR.NE.0) RETURN
      IF (IRET.LE.0) CALL ERREUR(36)
      ILNAVI=IRET
      ICHA=NNAVI(ILNAVI)
      GOTO 1
C
C  option PARA
C
  136 IF( ICHOI.EQ.2) THEN
        if(lupara.eq.1) then
          call ecrlog(.TRUE.)
        else
          call ecrlog (.FALSE.)
        endif
        RETURN
      ELSE
        CALL LIRlog(log,1,iretou)
        IF (Ierr.NE.0) return
        LUPARA=0
        if(log) lupara=1
      ENDIF
      GO TO 1
C
C  option SURV
C
  137 CONTINUE
      IF (ICHOI.EQ.2) THEN
        MSURV=MSURVE
        CALL ECRENT(MSURV)
        RETURN
      ENDIF
      CALL LIRENT(msurv,1,iretou)
      if(ierr.ne.0) return
      CALL OOOSUR(MSURv)
      msurve=msurv
      GO TO 1
C ---------------
C  Option 'POLI'
C ---------------
 138  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA(MPOLI(IOPOLI))
        RETURN
      ENDIF
      CALL MESLIR(-211)
      CALL LIRMOT(MPOLI,NbPoli,ij,1)
      IF (IERR.NE.0) RETURN
      IOPOLI=ij
      GOTO 1
C ---------------
C  Option 'COSC'
C ---------------
 139  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA(MCOSC(ICOSC))
        RETURN
      ENDIF
      CALL MESLIR(-211)
      CALL LIRMOT(MCOSC,NbCosc,ij,1)
      IF (IERR.NE.0) RETURN
      ICOSC=ij
      GOTO 1
C ---------------
C  Option 'POTR'
C ---------------
 140  IF (ICHOI.EQ.2) THEN
        CALL ECRCHA(MPOTR(IOPOTR))
        RETURN
      ENDIF
      CALL MESLIR(-211)
      CALL LIRMOT(MPOTR,NbPotr,ij,1)
      IF (IERR.NE.0) RETURN
      IOPOTR=ij
      GOTO 1
C ----------------
C    option debug
C ----------------
  141 IF (ICHOI.EQ.2) THEN
         call ecrent (misaup)
         return
      ENDIF
      CALL LIRENT(MISAUP,1,iretou)
      IF(IERR.NE.0) RETURN
      GO TO 1
C ----------------
C    option 'LOCA'
C ----------------
  142 IF (ICHOI.EQ.2) THEN
         CALL ECRLOG(ZLOPRO)
         RETURN
      ENDIF
      CALL LIRLOG(ZLOPRO,1,IRETOU)
      IF (IERR.NE.0) RETURN
      GO TO 1
C ----------------
C    option 'DENS'
C ----------------
 143  IF (ICHOI.EQ.2) THEN
        XRET=DENSIT
        CALL ECRREE(XRET)
        RETURN
      ENDIF
      CALL MESLIR(-238)
      CALL LIRREE(XRET,1,IRETOU)
      IF (IERR.NE.0) RETURN
C sg: comme dans subden.eso on met ABS(XRET)
      DENSIT=ABS(XRET)
      GO TO 1
C ----------------
C    option 'INCO'
C ----------------
 144  IF (ICHOI.EQ.2) THEN
         JGN=4
         JGM=LNOMDD
         SEGINI MLMOT1
         DO IGM=1,JGM
            MLMOT1.MOTS(IGM)=NOMDD(IGM)
         ENDDO
         SEGDES MLMOT1
         JGN=4
         JGM=LNOMDU
         SEGINI MLMOT2
         DO IGM=1,JGM
            MLMOT2.MOTS(IGM)=NOMDU(IGM)
         ENDDO
         SEGDES MLMOT2
         CALL ECROBJ('LISTMOTS',MLMOT2)
         CALL ECROBJ('LISTMOTS',MLMOT1)
         RETURN
      ENDIF
      CALL LIROBJ('LISTMOTS',MLMOT1,0,IRET)
      IF (IERR.NE.0) RETURN
      IF (IRET.NE.0) THEN
         CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET)
         IF (IERR.NE.0) RETURN
         SEGACT MLMOT1,MLMOT2
      ELSE
         JGN=LEN(CHARIN)
         JGM=1
         SEGINI MLMOT1,MLMOT2
         CALL LIRCHA(CHARIN,1,IRET)
         IF (IERR.NE.0) RETURN
         MLMOT1.MOTS(1)=CHARIN
         CALL LIRCHA(CHARRE,1,IRET)
         IF (IERR.NE.0) RETURN
         MLMOT2.MOTS(1)=CHARRE
      ENDIF
Csg : copi\E9 sur modeli.eso pour le mod\E8le de diffusion
      NBM1 = MLMOT1.MOTS(/2)
      NBM2 = MLMOT2.MOTS(/2)
      IF (NBM1.LE.0) THEN
C 1027 2
C Une donn\E9e de type %M1:8 est vide
         MOTERR(1:8)='LISTMOTS'
         CALL ERREUR(1027)
         RETURN
      ENDIF
      IF (NBM1.NE.NBM2) THEN
C 854 2
C Les listes de mots doivent etre de meme longueur.
         CALL ERREUR(854)
         RETURN
      ENDIF
      DO IBM=1,NBM1
         MDIINC='        '
         MDIDUA='        '
         CHARIN='        '
         CHARRE='        '
         CHARIN=MLMOT1.MOTS(IBM)
         CHARRE=MLMOT2.MOTS(IBM)
C Tronquer les mots \E0 2 caract\E8res pour pouvoir nommer les gradients ?
C (,X...)
cbp         IRETMA = 2
         IRETMA = 4
         IRETI=LONG(CHARIN)
         IF (IRETI.GT.IRETMA) THEN
            INTERR(1)   = IRETMA
            MOTERR(1:8) = CHARIN(1:IRETI)
            CALL ERREUR(-353)
         ENDIF
         IRETI=MIN(IRETI,IRETMA)
         MDIINC(1:IRETI)=CHARIN(1:IRETI)
C Pas besoin de tronquer pour la duale
cbp          IRETMA = IRETMA + 2
         IRETMA = 4
         IRETE=LONG(CHARRE)
         IF (IRETE.GT.IRETMA) THEN
            INTERR(1)   = IRETMA
            MOTERR(1:8) = CHARRE(1:IRETE)
            CALL ERREUR(-353)
         ENDIF
         IRETE=MIN(IRETE,IRETMA)
         MDIDUA(1:IRETE)=CHARRE(1:IRETE)
c* Verification des noms de primale et duale lues
         CALL VERMDI(MDIINC,MDIDUA)
         IF (IERR.NE.0) RETURN
      ENDDO
      if(iimpi.ge.333) then
        write(ioimp,*) 'DDL PRIMAL=',(NOMDD(iou),iou=1,LNOMDD)
        write(ioimp,*) 'DDL DUAL  =',(NOMDU(iou),iou=1,LNOMDU)
      endif
      SEGDES MLMOT1,MLMOT2
      GO TO 1
C  Recuperation du pointeur
 145  if (ichoi.eq.2) then
         call cpoint
         return
      endif
      goto 1
 
 146  if (ichoi .eq. 2) then
C       Recuperation de XPETIT dans CCOPTIO
         call ecrree(XPETIT)
         return
      elseif(ichoi.eq.1) then
C       Surcharge de XPETIT dans CCOPTIO
        CALL LIRREE(XVAL, 1, IRET)
        IF (IERR .NE. 0) RETURN
        XVAL = ABS(XVAL)
        IF (XVAL/REAL(10.D0) .LT. XVAL) THEN
          XPETIT = XVAL
        ELSE
          REAERR(1)=XVAL
          CALL ERREUR(1009)
          RETURN
        ENDIF
      else
        CALL ERREUR(21)
        RETURN
      endif
      goto 1
 
 147  if (ichoi .eq. 2) then
C       Recuperation de XGRAND dans CCOPTIO
         call ecrree(XGRAND)
         return
      elseif(ichoi .eq. 1) then
C       Surcharge de XGRAND dans CCOPTIO
        CALL LIRREE(XVAL, 1, IRET)
        IF (IERR .NE. 0) RETURN
        XVAL = ABS(XVAL)
        IF (XVAL*REAL(10.D0) .GT. XVAL) THEN
          XGRAND = XVAL
        ELSE
          REAERR(1)=XVAL
          CALL ERREUR(1009)
          RETURN
        ENDIF
      else
        CALL ERREUR(21)
        RETURN
      endif
      goto 1
 
 148  if (ichoi .eq. 2) then
C       Recuperation de XZPREC dans CCOPTIO
         call ecrree(XZPREC)
         return
      elseif(ichoi .eq. 1) then
C       Surcharge de XZPREC dans CCOPTIO
        CALL LIRREE(XVAL, 1, IRET)
        IF (IERR .NE. 0) RETURN
        XVAL = ABS(XVAL)
        XTEST= REAL(1.D0) + XVAL
        IF (XTEST .LE. REAL(1.D0)) THEN
          REAERR(1)=XVAL
          CALL ERREUR(1009)
          RETURN
        ELSE
          XZPREC = XVAL
        ENDIF
      else
        CALL ERREUR(21)
        RETURN
      endif
      goto 1
C
C  option ATTE
C
  149 CONTINUE
      IF (ICHOI.EQ.2) THEN
        MATTE=MATTEN
        CALL ECRENT(MATTE)
        RETURN
      ENDIF
      CALL LIRENT(MATTE,1,iretou)
      if(ierr.ne.0) return
      CALL OOOATE(MATTE)
      MATTEN=MATTE
      GO TO 1
C
C  option SOUC
C
  150 CONTINUE
      IF (ICHOI.EQ.2) THEN
        ith=max(1,oothrd)
        mbso = imesou(ith)
        call ecrent(mbso)
        RETURN
      ENDIF
      GO TO 1
C -----------------
C  Fin des Options
C -----------------
 
C  Ouverture de fichier
C ----------------------
C  Option 'SGBD'
C 1200 CONTINUE
      IF (IERR.NE.0) RETURN
      CLOSE (UNIT=IUNIT,iostat=istat)
      L=LONG(CHA)
      IFIOLD=424
      OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L),
     .      IOSTAT=IOS,ERR=2000)
      IF (IOS.NE.0) GOTO 2000
      GOTO 1
C  Options 'DONN','LECT','ACQU'
C  Verification de l'existence du fichier lors de son ouverture
 1201 IF (IERR.NE.0) RETURN
      CLOSE (UNIT=IUNIT,iostat=istat)
      L=LONG(CHA)
      IFIOLD=599
      OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
     .      IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
      IF (IOS.NE.0) GOTO 2000
      GOTO 1
C  Options 'IMPR','FTRA','SORT'
 1211 IF (IERR.NE.0) RETURN
      isuit=0
      CALL LIRMOT(MSUIT,Nsuit,isuit,0)
c     rem : option SUIT ok pour IMPR et FTRA, mais peut ne pas fonction-
c     -ner pour SORT (ex. SORT 'EXCE' le referme et le reouvre)
      L=LONG(CHA)
      IFIOLD=424
      INQUIRE(FILE=CHA(1:L),EXIST=ZEXIS)
c    -NOUVeau (par defaut)
      IF ( isuit.le.1 .OR. .not.ZEXIS ) THEN
        IF (IUNIT.eq.97.OR.IUNIT.eq.24) ZINIPS=.TRUE.
        CLOSE (UNIT=IUNIT,iostat=istat)
        OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L),
     .        IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
c    -SUITe
      ELSE
c       est-il ouvert ?
c         CLOSE (UNIT=IUNIT,iostat=istat)
        INQUIRE(UNIT=IUNIT,OPENED=ZOPEN)
        IF (IUNIT.eq.97.OR.IUNIT.eq.24) ZINIPS=.FALSE.
        OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
     .       ACCESS = 'SEQUENTIAL',IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
        CALL FINFIC(IUNIT)
c       rem : pour utiliser SUIT entre deux appels a cast3m, il faudrait
c       recuperer le bon ipag de strini.eso et l'incrementer...
      ENDIF
      IF (IOS.NE.0) GOTO 2000
      GOTO 1
C  Option 'SAUV' 'FORMAT'
 3201 IF (IERR.NE.0) RETURN
      CLOSE (UNIT=IUNIT,iostat=istat)
      if (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
      ixdrw=0
      iformx=iform
      LCHAI=LONG(NOMSAU)
      IFIOLD=424
      OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=NOMSAU(1:LCHAI),
     &      IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
      IF (IOS.NE.0) GOTO 2000
      GOTO 1
C  Option 'REST' 'FORMAT'
 2201 IF (IERR.NE.0) RETURN
      CLOSE (UNIT=IUNIT,iostat=istat)
      if (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. )
      ixdrr=0
      iformx=iform
      L=LONG(CHA)
      IFIOLD=599
      OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
     .      IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
      IF (IOS.NE.0) GOTO 2000
      GOTO 1
C  Option 'SAUV' 'BINA' (format binaire)
 1202 IF (IERR.NE.0) RETURN
C     WRITE(IOIMP,*) ' sauv en binaire'
      CLOSE (UNIT=IUNIT,iostat=istat)
      if (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
      iformx=iform
      ixdrw=0
      LCHAI=LONG(NOMSAU)
      IFIOLD=424
      OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=NOMSAU(1:LCHAI),
     .      IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
      IF (IOS.NE.0) GOTO 2000
      GOTO 1
C  Options        'REST' ('BINA') (format binaire)
 2202 IF (IERR.NE.0) RETURN
C     WRITE(IOIMP,*) ' rest en binaire'
      CLOSE (UNIT=IUNIT,iostat=istat)
      if (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. )
      iformx=iform
      ixdrr=0
      L=LONG(CHA)
      IFIOLD=599
      OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
     .      IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
      IF (IOS.NE.0) GOTO 2000
      GOTO 1
C  Options 'SAUV' ('XDR')       (format XDR)
 1203 IF (IERR.NE.0) RETURN
      IF (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
      ixdrw=0
      L=LONG(NOMSAU)
      IFIOLD=424
      IF (iform.GT.0) THEN
        ios=initxdr(NOMSAU(1:L),'w',.TRUE.)
        if (ios.LT.0) GOTO 2000
        ixdrw=ios
        ICHA(1:10)='CASTEM XDR'
        ios=IXDRSTRING( ixdrw,ICHA(1:10))
      ENDIF
      IF (iform.LT.0) THEN
        ios=initxdr(CHA(1:L),'r',.TRUE.)
        ixdrw=ios
      ENDIF
      iform=2
      iformx=iform
      IF (IOS.LT.0) GOTO 2000
      GOTO 1
C  Options        'REST' (format XDR)
 2203 IF (IERR.NE.0) RETURN
      IF (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. )
      ixdrr=0
      L=LONG(CHA)
      IFIOLD=424
      IF (iform.GT.0) THEN
        ios=initxdr(CHA(1:L),'w',.TRUE.)
        if (ios.LT.0) GOTO 2000
        ixdrr=ios
        ICHA(1:10)='CASTEM XDR'
        ios=IXDRSTRING( ixdrr,ICHA(1:10))
      ENDIF
      IF (iform.LT.0) THEN
        IFIOLD=599
        ios=initxdr(CHA(1:L),'r',.TRUE.)
        ixdrr=ios
      ENDIF
      iform=2
      iformx=iform
      IF (IOS.LT.0) GOTO 2000
      GOTO 1
 
C Traitement des erreurs d'ouverture des fichiers
 2000 L=LONG(CHA)
      MOTERR=CHA(1:L)
      INTERR(1)=IOS
      CALL ERREUR(424)
 
      RETURN
      END