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