Télécharger option.eso

Retour à la liste

Numérotation des lignes :

option
  1. C OPTION SOURCE OF166741 25/02/11 21:15:03 12151
  2.  
  3. C=======================================================================
  4. C Si ICHOI=1
  5. C Affection d'une valeur a une variable de CCOPTIO (directive OPTION)
  6. C Si ICHOI=2
  7. C Renvoie la valeur d'une des variables de CCOPTIO (operateur VALEUR)
  8. C=======================================================================
  9.  
  10. SUBROUTINE OPTION (ICHOI)
  11.  
  12. IMPLICIT INTEGER(I-N)
  13. IMPLICIT REAL*8 (A-H,O-Z)
  14.  
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. -INC CCGEOME
  18. -INC CCHAMP
  19. -INC CCASSIS
  20. -INC SMCOORD
  21. -INC SMLREEL
  22. -INC SMLMOTS
  23. -INC CCFXDR
  24. -INC CCTRACE
  25. -INC CCREEL
  26.  
  27. SEGMENT MCOORa
  28. REAL*8 XCoora(LCoor)
  29. END SEGMENT
  30.  
  31. C NbOpt : Nombre d'options (mot-cles) des operateurs OPTION et VALEUR
  32. C NbMfo : Nombre d'options mot-cle 'MODE' (vecteur MFO)
  33. C NbMsfo : " " mot-cle 'MODE' 'PLAN' (vecteur MSFO)
  34. C NbNoha : " " mot-cle 'FOUR' (vecteur NOHR)
  35. C NbUnid : " " mot-cle 'UNID' (vecteur OptUnid)
  36. C NbMod1D : " " mots-cles 'UNID' 'PLAN','AXIS' (vect. Mode1D)
  37. C NbGra : " " mot-cle 'TRAC' (vecteur MGR)
  38. C NbIso : " " mot-cle 'ISOV' (vecteur MISO)
  39. C NbReso : " " mot-cle 'RESO' (vecteur MRESOL)
  40. C NbErre : " " mot-cle 'ERRE' (vecteur ERCTRL)
  41. C NbForm : " " mot-cle 'SAUV' et 'REST' (vecteur FORMAT)
  42. C NbAuto : " " mot-cle 'NORM' (vecteur NAUTO)
  43. PARAMETER (NbOpt=50,NbMfo=6,NbMsfo=3,NbNoha=1,NbUnid=3,NbMod1D=12,
  44. $ NbGra=9,NbIso=3,NbReso=2,NbErre=4,NbForm=4,NbAuto=2,
  45. $ NbPoli=7,NbCosc=3,NbPotr=16,Nsuit=2)
  46.  
  47. EXTERNAL LONG
  48. CHARACTER*4 MCLE(NbOpt)
  49. CHARACTER*4 MFO(NbMfo)
  50. CHARACTER*4 MSFO(NbMsfo)
  51. CHARACTER*4 OptUnid(NbUnid)
  52. CHARACTER*4 Mode1D(NbMod1D)
  53. CHARACTER*4 MGR(NbGra)
  54. CHARACTER*4 MISO(NbIso)
  55. CHARACTER*4 MRESOL(NbReso)
  56. CHARACTER*4 ERCTRL(NbErre)
  57. CHARACTER*4 FORMAT(NbForm)
  58. CHARACTER*4 NOHR(nbnoha)
  59. integer*4 iohr
  60. equivalence(iohr,nohr)
  61. CHARACTER*4 NAUTO(NbAuto),MSUIT(Nsuit)
  62. CHARACTER*8 MPOLI(NbPoli)
  63. CHARACTER*12 ICHA
  64. CHARACTER*4 MCOSC(NbCosc)
  65. CHARACTER*12 MPOTR(NbPotr)
  66.  
  67. CHARACTER*8 CHARIN,CHARRE,MDIINC,MDIDUA
  68. CHARACTER*8 MTYP
  69. CHARACTER*(LOCHAI) CHA
  70. CHARACTER*16 MODERI(5)
  71. LOGICAL LOG,ZEXIS,ZOPEN
  72.  
  73. DATA MCLE / 'IMPR','DIME','ELEM','SORT','TRAC','DONN','ECHO',
  74. $ 'ERRE','LECT','EPSI','IMPI','MODE','CADR','COUL',
  75. $ 'NIVE','NGMA','SAUV','REST','ISOV','OMBR','NBP ',
  76. $ 'VERI','ZERO','ACQU','----','PLAC','LANG','NORM',
  77. $ 'RESO','FTRA','OEIL','ERMA','ASSI','EPTR','NAVI',
  78. $ 'PARA','SURV','POLI','COSC','POTR','DEBU','LOCA',
  79. $ 'DENS','INCO','POIN','PETI','GRAN','PREC','ATTE',
  80. $ 'SOUC'/
  81. DATA MFO / 'TRID','FOUR','AXIS','PLAN','UNID','FREQ' /
  82. DATA MSFO / 'DEFO','CONT','GENE' /
  83. DATA NOHR / 'NOHA' /
  84. DATA OptUnid / 'PLAN','AXIS','SPHE' /
  85. DATA Mode1D / 'DYDZ','DYCZ','CYDZ','CYCZ','GYDZ','GYCZ','DYGZ',
  86. . 'CYGZ','GYGZ','AXDZ','AXCZ','AXGZ' /
  87. DATA MGR / 'BENS','X ','IBM ','GKS ','PHIG','OPEN','PS ',
  88. . 'MIF ','PSC ' /
  89. DATA MISO / 'LIGN','SURF','SULI' /
  90. DATA MRESOL / 'DIRE','ITER' /
  91. DATA ERCTRL / 'FATA','NORM','IGNO','CONT' /
  92. DATA FORMAT / 'FORM','TAIL','XDR ','BINA' /
  93. DATA NAUTO / 'AUTO','ANNU' /
  94. DATA MODERI /'LINEAIRE ','QUADRATIQUE ',
  95. $ 'TRUESDELL ','JAUMANN ','UTILISATEUR '/
  96. DATA MPOLI / '8_BY_13 ','9_BY_15 ','TIMES_10','TIMES_24',
  97. $ 'HELV_10 ','HELV_12 ','HELV_18 ' /
  98. DATA MCOSC / 'NOIR','BLAN','JAUN' /
  99. DATA MPOTR / 'COURIER_12 ','COURIERB_12 ','HELVETICA_12'
  100. $ ,'TIMES_12 ','COURIER_14 ','COURIERB_14 ','HELVETICA_14'
  101. $ ,'TIMES_14 ','COURIER_16 ','COURIERB_16 ','HELVETICA_16'
  102. $ ,'TIMES_16 ','COURIER_18 ','COURIERB_18 ','HELVETICA_18'
  103. $ ,'TIMES_18 '/
  104. DATA MSUIT / 'NOUV','SUIT' /
  105.  
  106. IF ((ICHOI.NE.1).AND.(ICHOI.NE.2)) THEN
  107. CALL ERREUR (5)
  108. RETURN
  109. ENDIF
  110. i=0
  111. 1 CONTINUE
  112. CALL QUETYP(MTYP,0,IRET)
  113. IF (IRET.EQ.0) RETURN
  114. IF (MTYP.NE.'MOT') THEN
  115. C 39 2
  116. C On ne veut pas d'objet de type %m1:8
  117. MOTERR(1:8)=MTYP
  118. CALL ERREUR(39)
  119. RETURN
  120. ENDIF
  121. Csg CALL MESLIR(-218)
  122. CALL LIRMOT(MCLE,NBOPT,i,1)
  123. IF (IERR.NE.0) RETURN
  124.  
  125. C Branchement vers les differentes options
  126. C ------------------------------------------
  127. GOTO (101,102,103,104,105,106,107,108,109,110,111,112,113,114,
  128. $ 115,116,117,118,119,120,121,122,123,124,125,126,127,128,
  129. $ 129,130,131,132,133,134,135,136,137,138,139,140,141,142,
  130. $ 143,144,145,146,147,148,149,150),i
  131. return
  132. C ---------------
  133. C Option 'IMPR'
  134. C ---------------
  135. 101 IF (ICHOI.EQ.2) THEN
  136. CALL ECRENT(IOIMP)
  137. RETURN
  138. ENDIF
  139. CALL MESLIR(-217)
  140. CALL LIRENT(IRET,0,IRetou)
  141. IF (IRetou.NE.0) THEN
  142. IF (IRET.LE.0) CALL ERREUR(36)
  143. IF (IERR.NE.0) RETURN
  144. IOIMP=IRET
  145. GOTO 1
  146. ENDIF
  147. CALL MESLIR(-216)
  148. CALL LIRCHA(CHA,1,IRetou)
  149. IF (IERR.NE.0) RETURN
  150. IUNIT=IOIMP
  151. GOTO 1211
  152. C ---------------
  153. C Option 'DIME' : dimension de l'espace (IDIM)
  154. C ---------------
  155. 102 IF (ICHOI.EQ.2) THEN
  156. CALL ECRENT(IDIM)
  157. RETURN
  158. ENDIF
  159. CALL MESLIR(-215)
  160. CALL LIRENT(IRET,1,IRetou)
  161. IF (IERR.NE.0) RETURN
  162. IF (IRET.LT.1 .OR. IRET.GT.3) THEN
  163. CALL ERREUR(832)
  164. IERR = 0
  165. IERGLB = 0
  166. INTERR(1) = IRET
  167. CALL ERREUR(36)
  168. RETURN
  169. ENDIF
  170. IF (IRET.EQ.IDIM) GOTO 1
  171. IF (IDIM.EQ.0) THEN
  172. IDIM=IRET
  173. IF (IDIM.EQ.1) THEN
  174. IFOMOD=3
  175. IFOUR=3
  176. NIFOUR=0
  177. ELSE IF (IDIM.EQ.3) THEN
  178. IFOMOD=2
  179. IFOUR=2
  180. NIFOUR=0
  181. ENDIF
  182. GOTO 1
  183. ENDIF
  184. C Passage en dimension 3
  185. IF (IRET.EQ.3) THEN
  186. IFOMOD=2
  187. IFOUR=2
  188. NIFOUR=0
  189. C Passage en dimension 2, on met les options de calcul a PLAN DEFO.
  190. ELSE IF (IRET.EQ.2) THEN
  191. IF (IDIM.EQ.3) THEN
  192. IF (IFOMOD.EQ.2) IFOMOD=-1
  193. IF (IFOUR.EQ.2) IFOUR=-1
  194. ELSE IF (IDIM.EQ.1) THEN
  195. IFOMOD=-1
  196. IFOUR=-1
  197. NIFOUR=0
  198. ENDIF
  199. C Passage en dimension 1, on met les options de calcul a UNIDPLANDYDZ.
  200. ELSE IF (IRET.EQ.1) THEN
  201. IF (IFOMOD.NE.3.AND.IFOMOD.NE.4.AND.IFOMOD.NE.5) THEN
  202. IFOMOD=3
  203. IFOUR=3
  204. NIFOUR=0
  205. ENDIF
  206. ENDIF
  207. C Transfert des coordonnees des points dans nouveau MCOORD
  208. idimp1=IDIM+1
  209. iretp1=IRET+1
  210. segact mcoord*mod
  211. LCoor=NBPTS*iretp1
  212. SEGINI,MCOORa
  213. INF=MIN(IDIM,IRET)
  214. DO IP=1,NBPTS
  215. IRef1=(IP-1)*iretp1
  216. IRef =(IP-1)*idimp1
  217. DO j=1,INF
  218. XCoora(IRef1+j)=XCOOR(IRef+j)
  219. ENDDO
  220. XCoora(IRef1+iretp1)=XCOOR(IRef+idimp1)
  221. ENDDO
  222. IDIM=IRET
  223. SEGADJ,MCOORD
  224. DO j=1,XCOOR(/1)
  225. XCOOR(j)=XCOORa(j)
  226. ENDDO
  227. SEGSUP,MCOORa
  228. GOTO 1
  229. C ---------------
  230. C Option 'ELEM'
  231. C ---------------
  232. 103 IF (ICHOI.EQ.2) THEN
  233. IF (ILCOUR.EQ.0) THEN
  234. CALL ECRCHA(' ')
  235. ELSE
  236. CALL ECRCHA(NOMS(ILCOUR))
  237. ENDIF
  238. RETURN
  239. ENDIF
  240. CALL MESLIR(-214)
  241. CALL LIRMOT(NOMS,NOMBR,IRET,1)
  242. IF (IERR.NE.0) RETURN
  243. ILCOUR=IRET
  244. C* ICHA=NOMS(ILCOUR)
  245. GOTO 1
  246. C ---------------
  247. C Option 'SORT'
  248. C ---------------
  249. 104 IF (ICHOI.EQ.2) THEN
  250. CALL ECRENT(IOPER)
  251. RETURN
  252. ENDIF
  253. CALL MESLIR(-213)
  254. CALL LIRENT(IRET,0,IRetou)
  255. IF (IRetou.NE.0) THEN
  256. IF (IRET.LE.0) CALL ERREUR(36)
  257. IF (IERR.NE.0) RETURN
  258. IOPER=IRET
  259. GOTO 1
  260. ENDIF
  261. CALL MESLIR(-212)
  262. CALL LIRCHA(CHA,1,IRetou)
  263. IF (IERR.NE.0) RETURN
  264. IUNIT=IOPER
  265. GOTO 1211
  266. C ---------------
  267. C Option 'TRAC'
  268. C ---------------
  269. 105 IF (ICHOI.EQ.2) THEN
  270. CALL ECRCHA(MGR(IOGRA))
  271. RETURN
  272. ENDIF
  273. CALL MESLIR(-211)
  274. CALL LIRMOT(MGR,NbGra,ij,1)
  275. IF (IERR.NE.0) RETURN
  276. IOGRA=ij
  277. GOTO 1
  278. C ---------------
  279. C Option 'DONN'
  280. C ---------------
  281. 106 IF (ICHOI.EQ.2) THEN
  282. CALL ECRENT(IOLEC)
  283. RETURN
  284. ENDIF
  285. CALL MESLIR(-210)
  286. CALL LIRENT(IRET,0,IRetou)
  287. IF (IRetou.NE.0) THEN
  288. IF (IRET.LE.0) CALL ERREUR(36)
  289. IF (IERR.NE.0) RETURN
  290. IOLEC=IRET
  291. CALL GINT2
  292. GOTO 1
  293. ENDIF
  294. CALL MESLIR(-209)
  295. CALL LIRCHA(CHA,1,IRetou)
  296. IF (IERR.NE.0) RETURN
  297. C On impose IOLEC=3 pour eviter probleme avec lecture terminal
  298. IOLEC=3
  299. CALL GINT2
  300. IUNIT=IOLEC
  301. GOTO 1201
  302. C ---------------
  303. C Option 'ECHO'
  304. C ---------------
  305. 107 CONTINUE
  306. IF (ICHOI.EQ.2) THEN
  307. CALL ECRENT(IECHO)
  308. RETURN
  309. ENDIF
  310. CALL MESLIR(-208)
  311. CALL LIRENT(IRET,1,IRetou)
  312. INTERR(1)=iret
  313. IF ((IRET .LT. -1) .OR. (IRET .GT. 2)) CALL ERREUR(36)
  314. IF (IERR.NE.0) RETURN
  315. IECHO=IRET
  316. GOTO 1
  317. C ---------------
  318. C Option 'ERRE'
  319. C ---------------
  320. 108 IF (ICHOI.EQ.2) THEN
  321. CALL ECRCHA(ERCTRL(IERPER))
  322. RETURN
  323. ENDIF
  324. CALL MESLIR(-207)
  325. CALL LIRMOT(ERCTRL,NbErre,IRET,1)
  326. IF (IERR.NE.0) RETURN
  327. IERPER=IRET
  328. GOTO 1
  329. C ---------------
  330. C Option 'LECT'
  331. C ---------------
  332. 109 IF (ICHOI.EQ.2) THEN
  333. CALL ECRENT(IOCAR)
  334. RETURN
  335. ENDIF
  336. CALL MESLIR(-206)
  337. CALL LIRENT(IRET,0,IRetou)
  338. IF (IRetou.NE.0) THEN
  339. IF (IRET.LE.0) CALL ERREUR(36)
  340. IF (IERR.NE.0) RETURN
  341. IOCAR=IRET
  342. GOTO 1
  343. ENDIF
  344. CALL MESLIR(-205)
  345. CALL LIRCHA(CHA,1,IRetou)
  346. IF (IERR.NE.0) RETURN
  347. IUNIT=IOCAR
  348. GOTO 1201
  349. C ---------------
  350. C Option 'EPSI' (ex-'DERI') --> utilisee dans config
  351. C ---------------
  352. 110 IF (ICHOI.EQ.2) THEN
  353. CALL ECRCHA(moderi(MEPSIL))
  354. RETURN
  355. ENDIF
  356. CALL MESLIR(-204)
  357. CALL LIRMOT(MODERI,5,iret,1)
  358. IF (IERR.NE.0) RETURN
  359. MEPSIL=IRET
  360. GO TO 1
  361. *110 CONTINUE
  362. * IF(ICHOI.EQ.2) THEN
  363. * MOTERR(1:40)='VALE EPSI ;'
  364. * ELSE
  365. * MOTERR(1:40)='OPTI EPSI ... ;'
  366. * ENDIF
  367. * CALL ERREUR(1056)
  368. * RETURN
  369. C ---------------
  370. C Option 'IMPI'
  371. C ---------------
  372. 111 IF (ICHOI.EQ.2) THEN
  373. CALL ECRENT(IIMPI)
  374. RETURN
  375. ENDIF
  376. CALL MESLIR(-202)
  377. CALL LIRENT(IRET,1,IRetou)
  378. IF (IERR.NE.0) RETURN
  379. IIMPI=IRET
  380. GOTO 1
  381. C ---------------
  382. C Option 'MODE'
  383. C ---------------
  384. 112 IF (ICHOI.EQ.2) THEN
  385. c on a appele VALE 'MODE'
  386. c souhaite t'on FOUR ou le numero d'harmonique ?
  387. INH=0
  388. IF (IFOMOD.EQ.1) THEN
  389. CALL LIRMOT(MFO(2),1,INH,0)
  390. ENDIF
  391. IF (IFOMOD.EQ.-1) THEN
  392. c - PLAN
  393. ICHA(1:4)=MFO(4)
  394. ICHA(5:8)=MSFO(ABS(IFOUR))
  395. CALL ECRCHA(ICHA(1:8))
  396. ELSE IF (IFOMOD.EQ.3) THEN
  397. c - 1D PLAN
  398. ICHA(1:4)=MFO(5)
  399. ICHA(5:8)=OptUnid(1)
  400. ICHA(9:12)=Mode1D(IFOUR-2)
  401. CALL ECRCHA(ICHA(1:12))
  402. ELSE IF (IFOMOD.EQ.4) THEN
  403. c - 1D AXIS
  404. ICHA(1:4)=MFO(5)
  405. ICHA(5:8)=OptUnid(2)
  406. ICHA(9:12)=Mode1D(IFOUR-2)
  407. CALL ECRCHA(ICHA(1:12))
  408. ELSE IF (IFOMOD.EQ.5) THEN
  409. c - 1D SPHE
  410. ICHA(1:4)=MFO(5)
  411. ICHA(5:8)=OptUnid(3)
  412. ICHA(9:12)=' '
  413. CALL ECRCHA(ICHA(1:8))
  414. ELSE IF (IFOMOD.EQ.6) THEN
  415. c - FREQuentiel
  416. CALL ECRCHA(MFO(6))
  417. ELSE
  418. if (INH.eq.1) then
  419. c - numero d'harmonique de Fourier
  420. NHH=iohr
  421. if(NIFOUR.eq.NHH) then
  422. ICHA(1:4)='NOHA'
  423. CALL ECRCHA(ICHA(1:4))
  424. else
  425. CALL ECRENT(NIFOUR)
  426. endif
  427. else
  428. c - autres cas (TRID FOUR AXIS PLAN)
  429. CALL ECRCHA(MFO(3-IFOMOD))
  430. endif
  431. ENDIF
  432. RETURN
  433. ENDIF
  434. c on a appele OPTI 'MODE'
  435. CALL MESLIR(-201)
  436. CALL LIRMOT(MFO,NbMfo,IK,1)
  437. IF ((IERR.NE.0).OR.(IK.EQ.0)) RETURN
  438. IF (IK.EQ.1) THEN
  439. c - OPTI 'MODE' 'TRID'
  440. IRET=2
  441. ELSE IF (IK.EQ.2) THEN
  442. c - OPTI 'MODE' 'FOUR'
  443. IRET=1
  444. ELSE IF (IK.EQ.3) THEN
  445. c - OPTI 'MODE' 'AXIS'
  446. IRET=0
  447. ELSE IF (IK.EQ.4) THEN
  448. c - OPTI 'MODE' 'PLAN'
  449. IRET=-1
  450. ELSE IF (IK.EQ.5) THEN
  451. c - OPTI 'MODE' 'UNID'
  452. IRET=3
  453. ELSE IF (IK.EQ.6) THEN
  454. c - OPTI 'MODE' 'FREQ'
  455. IRET=6
  456. ENDIF
  457. C Possibilite d'imprimer une erreur si le MODE de calcul n'est pas
  458. C compatible avec la dimension. Debranche pour l'instant.
  459. C** IF ( (IDIM.EQ.2.AND.IRET.NE.-1.AND.IRET.NE.0.AND.IRET.NE.1)
  460. C** . .OR.(IDIM.EQ.1.AND.IRET.NE.3).OR.(IDIM.EQ.3.AND.IRET.NE.2) ) THEN
  461. C** MOTERR(1:4)=MFO(IK)
  462. C** INTERR(1)=IDIM
  463. C** CALL ERREUR(970)
  464. C** RETURN
  465. C** ENDIF
  466. IFOMOD=IRET
  467. if (iret.ne.6) IFOUR=IRET
  468. cckich NIFOUR=0
  469. IF (IRET.EQ.-1) THEN
  470. CALL LIRMOT(MSFO,NbMsfo,IKS,0)
  471. IF (IKS.EQ.0) THEN
  472. IFOUR=-1
  473. ELSE IF (IKS.EQ.1) THEN
  474. IFOUR=-1
  475. ELSE IF (IKS.EQ.2) THEN
  476. IFOUR=-2
  477. ELSE IF (IKS.EQ.3) THEN
  478. IFOUR=-3
  479. ENDIF
  480. ELSE IF (IRET.EQ.1) THEN
  481. CALL LIRENT(NHH,0,ICOND)
  482. IF (ICOND.EQ.0) THEN
  483. CALL LIRMOT(NOHR,NbNoha,NHH,0)
  484. IF (NHH.EQ.1) THEN
  485. nhh=iohr
  486. ELSE
  487. CALL ERREUR(287)
  488. ENDIF
  489. ENDIF
  490. NIFOUR=NHH
  491. ELSE IF (IRET.EQ.3) THEN
  492. CALL LIRMOT(OptUnid,NbUnid,IKS,0)
  493. IF (IKS.EQ.0) THEN
  494. IFOMOD=3
  495. IFOUR=3
  496. ELSE IF (IKS.EQ.1) THEN
  497. IFOMOD=3
  498. CALL LIRMOT(Mode1D(1),9,i,0)
  499. IF (i.EQ.0) i=1
  500. IFOUR=2+i
  501. ELSE IF (IKS.EQ.2) THEN
  502. IFOMOD=4
  503. CALL LIRMOT(Mode1D(10),3,i,0)
  504. IF (i.EQ.0) i=1
  505. IFOUR=11+i
  506. ELSE IF (IKS.EQ.3) THEN
  507. IFOMOD=5
  508. IFOUR=15
  509. ENDIF
  510. ENDIF
  511. GOTO 1
  512. C ---------------
  513. C Option 'CADR'
  514. C ---------------
  515. 113 IF (ICHOI.EQ.2) THEN
  516. XRET=DIOCAD
  517. CALL ECRREE(XRET)
  518. RETURN
  519. ENDIF
  520. CALL MESLIR(-200)
  521. CALL LIRREE(XRET,1,IRetou)
  522. IF (IERR.NE.0) RETURN
  523. DIOCAD=XRET
  524. GOTO 1
  525. C ---------------
  526. C Option 'COUL'
  527. C ---------------
  528. 114 IF (ICHOI.EQ.2) THEN
  529. CALL ECRCHA(NCOUL(IDCOUL))
  530. RETURN
  531. ENDIF
  532. CALL MESLIR(-199)
  533. CALL LIRMOT(NCOUL(0),NBCOUL,IRET,1)
  534. IF (IRET.LE.0) CALL ERREUR(36)
  535. IF (IERR.NE.0) RETURN
  536. IDCOUL=IRET-1
  537. ICHA=NCOUL(IDCOUL)
  538. GOTO 1
  539. C ---------------
  540. C Option 'NIVE'
  541. C ---------------
  542. 115 IF (ICHOI.EQ.2) THEN
  543. CALL ECRENT(IONIVE)
  544. RETURN
  545. ENDIF
  546. CALL MESLIR(-198)
  547. CALL LIRENT(IRET,1,IRetou)
  548. IF (IERR.NE.0) RETURN
  549. IF (IRET.LT.0) THEN
  550. INTERR(1)=IRET
  551. INTERR(2)=1
  552. INTERR(3)=IGRAND
  553. CALL ERREUR(1068)
  554. RETURN
  555. ENDIF
  556. IF (IRET.EQ.IONIVE) RETURN
  557. write(ioimp,*) 'Changement IONIVE',IONIVE,'->',IRET
  558. IONIVE = IRET
  559. GOTO 1
  560. C ---------------
  561. C Option 'NGMA'
  562. C ---------------
  563. 116 IF (ICHOI.EQ.2) THEN
  564. CALL ECRENT(NGMAXY)
  565. RETURN
  566. ENDIF
  567. CALL MESLIR(-197)
  568. CALL LIRENT(IRET,1,IRetou)
  569. IF (IERR.NE.0) RETURN
  570. INTERR(1)=IRET
  571. IF (IRET.LT.0) CALL ERREUR (36)
  572. NGMAXY=IRET
  573. GOTO 1
  574. C ---------------
  575. C Option 'SAUV'
  576. C ---------------
  577. 117 IF (ICHOI.EQ.2) THEN
  578. CALL ECRENT(IOSAU)
  579. RETURN
  580. ENDIF
  581. CALL MESLIR(-196)
  582. IFORM=2
  583. IPREFI=0
  584. DIMATT=0.D0
  585. IREFOR=0
  586. ISAFOR=0
  587. IF (IPSAUV.NE.0) CALL LIBPIL(IPSAUV)
  588. IPSAUV=0
  589. 1171 CALL LIRMOT(FORMAT,NbForm,ICHOr,0)
  590. IF (ICHOr.EQ.1) THEN
  591. IFORM=1
  592. ISAFOR=1
  593. GOTO 1171
  594. ELSE IF (ICHOr.EQ.2) THEN
  595. CALL LIRREE(XRET,1,IRetou)
  596. IF (IERR.NE.0) RETURN
  597. DIMFIC=XRET
  598. GOTO 1171
  599. ELSE IF (ICHOr.EQ.3) THEN
  600. IFORM=2
  601. GOTO 1171
  602. ELSE IF (ICHOr.EQ.4) THEN
  603. IFORM=0
  604. GOTO 1171
  605. ENDIF
  606. CALL LIRENT(IRET,0,IRetou)
  607. IF (IRetou.NE.0) THEN
  608. IF (IRET.LE.0) CALL ERREUR(36)
  609. IF (IERR.NE.0) RETURN
  610. IOSAU=IRET
  611. IPSAUV=0
  612. GOTO 1
  613. ENDIF
  614. CALL MESLIR(-195)
  615. CALL LIRCHA(CHA,1,IRetou)
  616. IF (IERR.NE.0) RETURN
  617. lchai=long(cha)
  618. * la longueur du fichier maximale est LOCHAI moins la longueur("_iiii")
  619. * ou iiii designe le nombre maximal de fichiers de sauvegarde possible
  620. * A ce jour la limite est 9999 fichiers. LONG("_9999") = 5
  621. IF (lchai.GT.(LOCHAI-5)) THEN
  622. write(ioimp,*) 'SAUV File Name is too LONG'
  623. CALL ERREUR(1111)
  624. RETURN
  625. ENDIF
  626. NOMSAU = ' '
  627. NOMSAU(1:lchai)=cha(1:lchai)
  628. IUNIT=IOSAU
  629. IPSAUV=0
  630. lcha=lchai
  631. * destruction des eventuels fichiers existants
  632. open(file=NOMSAU(1:lcha),status='OLD',iostat=istat,unit=iunit)
  633. if (istat.eq.0) then
  634. close(iunit,status='DELETE',iostat=istat)
  635. if (istat.ne.0) then
  636. endif
  637. else
  638. goto 1173
  639. endif
  640. ll=lcha+1
  641. NOMSAU(ll:ll+1)='_1'
  642. ll=ll+1
  643. do isuit=1,10000
  644. if (isuit.lt.10) then
  645. write (NOMSAU(ll:ll),fmt='(I1)') isuit
  646. lcha=ll
  647. elseif (isuit.lt.100) then
  648. write (NOMSAU(ll:ll+1),fmt='(I2)') isuit
  649. lcha=ll+1
  650. elseif (isuit.lt.1000) then
  651. write (NOMSAU(ll:ll+2),fmt='(I3)') isuit
  652. lcha=ll+2
  653. elseif (isuit.lt.10000) then
  654. write (NOMSAU(ll:ll+3),fmt='(I4)') isuit
  655. lcha=ll+3
  656. endif
  657. open(file=NOMSAU(1:lcha),status='OLD',iostat=istat,unit=iunit)
  658. if (istat.eq.0) then
  659. close(iunit,status='DELETE',iostat=istat)
  660. else
  661. goto 1173
  662. endif
  663. enddo
  664. 1173 continue
  665. NOMSAU(lchai+1:lochai) = ' '
  666. IF (IFORM.EQ.1) GOTO 3201
  667. IF (IFORM.EQ.2) GOTO 1203
  668. GOTO 1202
  669. C ---------------
  670. C Option 'REST'
  671. C ---------------
  672. 118 CONTINUE
  673. IF (ICHOI.EQ.2) THEN
  674. CALL ECRENT(IORES)
  675. RETURN
  676. ENDIF
  677. IFICLE=0
  678. IFORM=0
  679. IREFOR=0
  680. CALL MESLIR(-193)
  681. 1172 CALL LIRMOT(FORMAT,nbform,ichor,0)
  682. IF (IERR.NE.0) RETURN
  683. IF (ICHOr.EQ.1) THEN
  684. IREFOR=1
  685. IFORM=1
  686. GOTO 1172
  687. ELSE IF (ICHOr.EQ.2) THEN
  688. GOTO 1172
  689. ELSE IF (ICHOr.EQ.3) THEN
  690. IFORM=-2
  691. GOTO 1172
  692. ELSEIF (ICHOr.EQ.4) then
  693. IFORM=0
  694. GOTO 1172
  695. ENDIF
  696. CALL MESLIR(-194)
  697. CALL LIRENT(IRET,0,IRetou)
  698. IF (IRetou.NE.0) THEN
  699. IF (IRET.LE.0) CALL ERREUR(36)
  700. IF (IERR.NE.0) RETURN
  701. IORES=IRET
  702. GOTO 1
  703. ENDIF
  704. CALL LIRCHA(CHA,1,IRetou)
  705. IF (IERR.NE.0) RETURN
  706. L=LONG(CHA)
  707. IUNIT=IORES
  708. NOMRES=' '
  709. NOMRES(1:L)=CHA(1:L)
  710. C test sur le type de fichier
  711. CLOSE(UNIT=IUNIT,iostat=istat)
  712. IFORM=1
  713. IREFOR=1
  714. IFIOLD=599
  715. OPEN(UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  716. . IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  717. IF (IOS.EQ.0) THEN
  718. iretou=0
  719. iquoi=0
  720. CALL LFCDES(IORES,IQUOI,IRETOU,IFORM)
  721. C WRITE(IOIMP,*) 'apres lfcdes-1 ',iores,iquoi,iretou,iform
  722. IF (IOS.EQ.0.AND.(IQUOI.GT.0.AND.IQUOI.LT.10).AND.
  723. . IRETOU.EQ.0) THEN
  724. CALL ERREUR(-342)
  725. GOTO 3250
  726. ENDIF
  727. ENDIF
  728. IFORM=0
  729. IREFOR=0
  730. CLOSE(UNIT=IUNIT,iostat=istat)
  731. OPEN(UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  732. . IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  733. IF (IOS.EQ.0) THEN
  734. iretou=0
  735. iquoi=0
  736. CALL LFCDES (IORES,IQUOI,IRETOU,IFORM)
  737. C WRITE (IOIMP,*) 'apres lfcdes-2 ',iores,iquoi,iretou,iform
  738. IF (IOS.EQ.0.AND.(IQUOI.GT.0.AND.IQUOI.LT.10).AND.
  739. . IRETOU.EQ.0) THEN
  740. CALL ERREUR(-343)
  741. GOTO 3250
  742. ENDIF
  743. ENDIF
  744. IFORM=2
  745. IF (ixdrr.NE.0) IOS=IXDRCLOSE(ixdrr,.TRUE.)
  746. ios=initxdr(CHA(1:L),'r',.TRUE.)
  747. IF (ios.lt.0) GOTO 2000
  748. ixdrr=ios
  749. ios=IXDRSTRING(ixdrr,ICHA(1:10))
  750. C WRITE(IOIMP,*) ' option rest ',icha(1:10),ios
  751. IF (IOS.GE.0.AND.ICHA(1:10).EQ.'CASTEM XDR') THEN
  752. C WRITE (IOIMP,*) ' on va direct en 1 '
  753. IFORM=2
  754. iformx=IFORM
  755. CALL ERREUR(-344)
  756. GOTO 1
  757. ENDIF
  758. IFIOLD=424
  759. GOTO 2000
  760. 3250 iformx=IFORM
  761. IF (IFORM.EQ.1) GOTO 2201
  762. IF (IFORM.EQ.-2) GOTO 2203
  763. GOTO 2202
  764. C ---------------
  765. C Option 'ISOV'
  766. C ---------------
  767. 119 IF (ICHOI.EQ.2) THEN
  768. CALL ECRCHA(MISO(ISOTYP+1))
  769. RETURN
  770. ENDIF
  771. CALL MESLIR(-192)
  772. CALL LIRMOT(MISO,NbIso,IRET,1)
  773. IF (IRET.LE.0) CALL ERREUR(36)
  774. IF (IERR.NE.0) RETURN
  775. ISOTYP=IRET-1
  776. ICHA=MISO(IRET)
  777. GOTO 1
  778. C ---------------
  779. C Option 'OMBRE'
  780. C ---------------
  781. 120 IF (ICHOI.EQ.2) THEN
  782. LOG=.FALSE.
  783. IF (IOMBRE.EQ.1) LOG =.TRUE.
  784. CALL ECRLOG(LOG)
  785. RETURN
  786. ENDIF
  787. CALL MESLIR(-191)
  788. CALL LIRLOG(LOG,1,IRET)
  789. IF (IERR.NE.0) RETURN
  790. IF (LOG) THEN
  791. IOMBRE=1
  792. ELSE
  793. IOMBRE=0
  794. ENDIF
  795. GOTO 1
  796. C ---------------
  797. C Option 'NBP '
  798. C ---------------
  799. 121 IF (ICHOI.EQ.2) THEN
  800. IRET=mcoord
  801. CALL ECRENT(IRET)
  802. RETURN
  803. ENDIF
  804. CALL MESLIR(-190)
  805. CALL LIRENT(IRET,1,IRetou)
  806. IF (IERR.NE.0) RETURN
  807. NBPTS=MAX(0,IRET)
  808. SEGADJ MCOORD
  809. GOTO 1
  810. C ---------------
  811. C Option 'VERI'
  812. C ---------------
  813. 122 IF (ICHOI.EQ.2) THEN
  814. CALL ECRENT(IOSPI)
  815. RETURN
  816. ENDIF
  817. CALL MESLIR(-189)
  818. CALL LIRENT(IRET,1,IRetou)
  819. IF (IERR.NE.0) RETURN
  820. IOSPI=IRET
  821. GOTO 1
  822. C ---------------
  823. C Option 'ZERO'
  824. C ---------------
  825. 123 IF (ICHOI.EQ.2) THEN
  826. CALL ECRENT(IZROSF)
  827. RETURN
  828. ENDIF
  829. CALL MESLIR(-188)
  830. CALL LIRENT(IRET,1,IRetou)
  831. IF (IERR.NE.0) RETURN
  832. IZROSF=MAX(1,IRET)
  833. GOTO 1
  834. C ---------------
  835. C Option 'ACQU'
  836. C ---------------
  837. 124 IF (ICHOI.EQ.2) THEN
  838. CALL ECRENT(IOACQ)
  839. RETURN
  840. ENDIF
  841. CALL MESLIR(-187)
  842. CALL LIRENT(IRET,0,IRetou)
  843. IF (IRetou.NE.0) THEN
  844. IOACQ=IRET
  845. GOTO 1
  846. ENDIF
  847. CALL MESLIR(-186)
  848. CALL LIRCHA(CHA,1,IRetou)
  849. IF (IERR.NE.0) RETURN
  850. IUNIT=IOACQ
  851. GOTO 1201
  852. C ---------------
  853. C Option '----'
  854. C ---------------
  855. 125 CONTINUE
  856. GOTO 1
  857. C ---------------
  858. C Option 'PLAC'
  859. C ---------------
  860. 126 IF (ICHOI.EQ.2) THEN
  861. CALL ECRENT(IPLLB)
  862. RETURN
  863. ENDIF
  864. CALL MESLIR(-184)
  865. CALL LIRENT(IRET,1,IRetou)
  866. IF (IERR.NE.0) RETURN
  867. C Pourquoi mettre IPLLB en positif ?
  868. C N'etant pas sur de la valeur de IPLTOT il faut pouvoir le mettre
  869. C en negatif tres grand (voir T.C.)
  870. C IRET=MAX(1,IRET)
  871. IPLLB=IRET
  872. GOTO 1
  873. C ---------------
  874. C Option 'LANG'
  875. C ---------------
  876. 127 IF (ICHOI.EQ.2) THEN
  877. CALL ECRCHA (LANGUE)
  878. RETURN
  879. ENDIF
  880. CALL LIRCHA(ICHA,1,IRetou)
  881. IF (IERR.NE.0) RETURN
  882. LANGUE=ICHA
  883. GOTO 1
  884. C ---------------
  885. C Option 'NORM'
  886. C ---------------
  887. 128 IF (ICHOI.EQ.2) THEN
  888. CALL ERREUR(758)
  889. RETURN
  890. ENDIF
  891. C On commence par une remise a plat : tout a 0 .
  892. C On devrait liberer la place occupee eventuellement par ces segments,
  893. C mais comme on a fait SAVSEG avant. Il faudrait aussi les enlever de
  894. C la liste des non-effacables, mais comment ?
  895. NORINC=0
  896. NORVAL=0
  897. NORIND=0
  898. NORVAD=0
  899. C Lecture des mts cles eventuels
  900. CALL LIRMOT(NAUTO,NbAuto,i,0)
  901. IF (i.EQ.2) GOTO 1
  902. C Normalisation automatique
  903. IF (i.EQ.1) THEN
  904. NORINC=-1
  905. GOTO 1
  906. ENDIF
  907. CALL LIROBJ('LISTMOTS',NORINC,1,IRetou)
  908. CALL LIROBJ('LISTREEL',NORVAL,1,IRetou)
  909. IF (IERR.NE.0) THEN
  910. NORINC=0
  911. NORVAL=0
  912. GOTO 1
  913. ENDIF
  914. MLREEL=NORVAL
  915. MLMOTS=NORINC
  916. SEGACT MLREEL,MLMOTS
  917. NRE=PROG(/1)
  918. NMO=MOTS(/2)
  919. SEGDES MLREEL,MLMOTS
  920. IF (NRE.NE.NMO) THEN
  921. CALL ERREUR(212)
  922. NORINC=0
  923. NORVAL=0
  924. RETURN
  925. ENDIF
  926. C Verification s'il n'y a pas de 'LX' la dedans
  927. C La taille de mots doit etre OK si le LISTMOTS est cree par MOTS
  928. SEGACT MLMOTS
  929. DO i=1,NMO
  930. IF (MOTS(i)(1:4).EQ.'LX ') THEN
  931. CALL ERREUR( 759 )
  932. NORINC=0
  933. NORVAL=0
  934. SEGDES MLMOTS
  935. RETURN
  936. ENDIF
  937. ENDDO
  938. SEGDES MLMOTS
  939. CALL SAVSEG(MLREEL)
  940. CALL SAVSEG(MLMOTS)
  941. CALL LIROBJ('LISTMOTS',NORIND,0,IRetou)
  942. IF (IRetou.EQ.0) GOTO 1
  943. CALL LIROBJ('LISTREEL',NORVAD,1,IRetou)
  944. IF (IERR.NE.0) THEN
  945. NORIND=0
  946. NORVAD=0
  947. ENDIF
  948. MLREEL=NORVAD
  949. MLMOTS=NORIND
  950. SEGACT MLREEL,MLMOTS
  951. NRE=PROG(/1)
  952. NMO=MOTS(/2)
  953. SEGDES MLREEL,MLMOTS
  954. IF (NRE.NE.NMO) THEN
  955. CALL ERREUR(212)
  956. NORIND=0
  957. NORVAD=0
  958. RETURN
  959. ENDIF
  960. CALL SAVSEG(MLREEL)
  961. CALL SAVSEG(MLMOTS)
  962. GOTO 1
  963. C ---------------
  964. C Option 'RESO'
  965. C ---------------
  966. 129 IF (ICHOI.EQ.2) THEN
  967. CALL ECRCHA(MRESOL(NUCROU+1))
  968. RETURN
  969. ENDIF
  970. CALL MESLIR(-187)
  971. CALL LIRMOT(MRESOL,NbReso,IRetou,1)
  972. IF (IERR.NE.0) RETURN
  973. NUCROU=IRetou-1
  974. GOTO 1
  975. C ---------------
  976. C Option 'FTRA'
  977. C ---------------
  978. 130 IF (ICHOI.EQ.2) THEN
  979. IF (iogra.ge.7.and.iogra.le.9) THEN
  980. IF (IOGRA.EQ.8) THEN
  981. IUPS=97
  982. ELSE
  983. IUPS=24
  984. ENDIF
  985. INQUIRE(UNIT=IUPS,NAME=CHA)
  986. CALL ECRCHA(CHA(1:LONG(CHA)))
  987. RETURN
  988. ELSE
  989. CALL ERREUR(758)
  990. RETURN
  991. ENDIF
  992. ENDIF
  993. IF (iogra.ge.7.and.iogra.le.9) THEN
  994. c ZINIPS=.TRUE.
  995. CALL MESLIR(-209)
  996. CALL LIRCHA(CHA,1,IRetou)
  997. IF (IERR.NE.0) RETURN
  998. IF (IOGRA.EQ.8) THEN
  999. IUPS=97
  1000. ELSE
  1001. IUPS=24
  1002. ENDIF
  1003. IUNIT=IUPS
  1004. GOTO 1211
  1005. ELSE
  1006. CALL ERREUR(26)
  1007. RETURN
  1008. ENDIF
  1009. GOTO 1
  1010. C ---------------
  1011. C Option 'OEIL'
  1012. C ---------------
  1013. 131 IF (ICHOI.EQ.2) THEN
  1014. IF (IOEIL.NE.0) THEN
  1015. CALL ECROBJ('POINT',IOEIL)
  1016. ELSE
  1017. C 18 2 Point non trouve
  1018. CALL ERREUR(18)
  1019. ENDIF
  1020. RETURN
  1021. ENDIF
  1022. CALL LIROBJ('POINT',IOEIL,1,IRetou)
  1023. IF (IERR.NE.0) RETURN
  1024. GOTO 1
  1025. C ---------------
  1026. C Option 'ERMA'
  1027. C ---------------
  1028. 132 IF (ICHOI.EQ.2) THEN
  1029. CALL ECRENT(IERMAX)
  1030. RETURN
  1031. ELSE
  1032. CALL ERREUR(758)
  1033. RETURN
  1034. ENDIF
  1035. GOTO 1
  1036. C ---------------
  1037. C Option 'ASSI'
  1038. C ---------------
  1039. 133 IF (ICHOI.EQ.2) THEN
  1040. CALL ECRENT(NBESCR)
  1041. RETURN
  1042. ENDIF
  1043. IF (NBESC.NE.0) CALL ERREUR(892)
  1044. IF (IERR.NE.0) RETURN
  1045. CALL LIRENT(IRET,0,IRetou)
  1046. IF (IRetou.NE.0) THEN
  1047. IF (IRET.LT.0) CALL ERREUR(36)
  1048. IF (IRET.GT.64) CALL ERREUR(36)
  1049. if (nbesc.ne.0) call erreur(36)
  1050. if (ierr.eq.0.and.nbesc.eq.0) then
  1051. NBESCR=IRET
  1052. endif
  1053. ENDIF
  1054. GOTO 1
  1055. C ---------------
  1056. C Option 'EPTR'
  1057. C ---------------
  1058. 134 IF (ICHOI.EQ.2) THEN
  1059. CALL ECRENT(IEPTR)
  1060. RETURN
  1061. ENDIF
  1062. CALL MESLIR(-340)
  1063. CALL LIRENT(IRET,1,IRetou)
  1064. IF (IRetou.NE.0) THEN
  1065. IF (IRET.LT.0) CALL ERREUR(36)
  1066. IEPTR=IRET
  1067. ENDIF
  1068. GOTO 1
  1069. C ---------------
  1070. C Option 'NAVI'
  1071. C ---------------
  1072. 135 IF (ICHOI.EQ.2) THEN
  1073. CALL ECRCHA(NNAVI(ILNAVI))
  1074. RETURN
  1075. ENDIF
  1076. CALL MESLIR(-341)
  1077. CALL LIRMOT(NNAVI,LNNAVI,IRET,1)
  1078. IF (IERR.NE.0) RETURN
  1079. IF (IRET.LE.0) CALL ERREUR(36)
  1080. ILNAVI=IRET
  1081. ICHA=NNAVI(ILNAVI)
  1082. GOTO 1
  1083. C
  1084. C option PARA
  1085. C
  1086. 136 IF( ICHOI.EQ.2) THEN
  1087. if(lupara.eq.1) then
  1088. call ecrlog(.TRUE.)
  1089. else
  1090. call ecrlog (.FALSE.)
  1091. endif
  1092. RETURN
  1093. ELSE
  1094. CALL LIRlog(log,1,iretou)
  1095. IF (Ierr.NE.0) return
  1096. LUPARA=0
  1097. if(log) lupara=1
  1098. ENDIF
  1099. GO TO 1
  1100. C
  1101. C option SURV
  1102. C
  1103. 137 CONTINUE
  1104. IF (ICHOI.EQ.2) THEN
  1105. MSURV=MSURVE
  1106. CALL ECRENT(MSURV)
  1107. RETURN
  1108. ENDIF
  1109. CALL LIRENT(msurv,1,iretou)
  1110. if(ierr.ne.0) return
  1111. CALL OOOSUR(MSURv)
  1112. msurve=msurv
  1113. GO TO 1
  1114. C ---------------
  1115. C Option 'POLI'
  1116. C ---------------
  1117. 138 IF (ICHOI.EQ.2) THEN
  1118. CALL ECRCHA(MPOLI(IOPOLI))
  1119. RETURN
  1120. ENDIF
  1121. CALL MESLIR(-211)
  1122. CALL LIRMOT(MPOLI,NbPoli,ij,1)
  1123. IF (IERR.NE.0) RETURN
  1124. IOPOLI=ij
  1125. GOTO 1
  1126. C ---------------
  1127. C Option 'COSC'
  1128. C ---------------
  1129. 139 IF (ICHOI.EQ.2) THEN
  1130. CALL ECRCHA(MCOSC(ICOSC))
  1131. RETURN
  1132. ENDIF
  1133. CALL MESLIR(-211)
  1134. CALL LIRMOT(MCOSC,NbCosc,ij,1)
  1135. IF (IERR.NE.0) RETURN
  1136. ICOSC=ij
  1137. GOTO 1
  1138. C ---------------
  1139. C Option 'POTR'
  1140. C ---------------
  1141. 140 IF (ICHOI.EQ.2) THEN
  1142. CALL ECRCHA(MPOTR(IOPOTR))
  1143. RETURN
  1144. ENDIF
  1145. CALL MESLIR(-211)
  1146. CALL LIRMOT(MPOTR,NbPotr,ij,1)
  1147. IF (IERR.NE.0) RETURN
  1148. IOPOTR=ij
  1149. GOTO 1
  1150. C ----------------
  1151. C option debug
  1152. C ----------------
  1153. 141 IF (ICHOI.EQ.2) THEN
  1154. call ecrent (misaup)
  1155. return
  1156. ENDIF
  1157. CALL LIRENT(MISAUP,1,iretou)
  1158. IF(IERR.NE.0) RETURN
  1159. GO TO 1
  1160. C ----------------
  1161. C option 'LOCA'
  1162. C ----------------
  1163. 142 IF (ICHOI.EQ.2) THEN
  1164. CALL ECRLOG(ZLOPRO)
  1165. RETURN
  1166. ENDIF
  1167. CALL LIRLOG(ZLOPRO,1,IRETOU)
  1168. IF (IERR.NE.0) RETURN
  1169. GO TO 1
  1170. C ----------------
  1171. C option 'DENS'
  1172. C ----------------
  1173. 143 IF (ICHOI.EQ.2) THEN
  1174. XRET=DENSIT
  1175. CALL ECRREE(XRET)
  1176. RETURN
  1177. ENDIF
  1178. CALL MESLIR(-238)
  1179. CALL LIRREE(XRET,1,IRETOU)
  1180. IF (IERR.NE.0) RETURN
  1181. C sg: comme dans subden.eso on met ABS(XRET)
  1182. DENSIT=ABS(XRET)
  1183. GO TO 1
  1184. C ----------------
  1185. C option 'INCO'
  1186. C ----------------
  1187. 144 IF (ICHOI.EQ.2) THEN
  1188. JGN=4
  1189. JGM=LNOMDD
  1190. SEGINI MLMOT1
  1191. DO IGM=1,JGM
  1192. MLMOT1.MOTS(IGM)=NOMDD(IGM)
  1193. ENDDO
  1194. SEGDES MLMOT1
  1195. JGN=4
  1196. JGM=LNOMDU
  1197. SEGINI MLMOT2
  1198. DO IGM=1,JGM
  1199. MLMOT2.MOTS(IGM)=NOMDU(IGM)
  1200. ENDDO
  1201. SEGDES MLMOT2
  1202. CALL ECROBJ('LISTMOTS',MLMOT2)
  1203. CALL ECROBJ('LISTMOTS',MLMOT1)
  1204. RETURN
  1205. ENDIF
  1206. CALL LIROBJ('LISTMOTS',MLMOT1,0,IRET)
  1207. IF (IERR.NE.0) RETURN
  1208. IF (IRET.NE.0) THEN
  1209. CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET)
  1210. IF (IERR.NE.0) RETURN
  1211. SEGACT MLMOT1,MLMOT2
  1212. ELSE
  1213. JGN=LEN(CHARIN)
  1214. JGM=1
  1215. SEGINI MLMOT1,MLMOT2
  1216. CALL LIRCHA(CHARIN,1,IRET)
  1217. IF (IERR.NE.0) RETURN
  1218. MLMOT1.MOTS(1)=CHARIN
  1219. CALL LIRCHA(CHARRE,1,IRET)
  1220. IF (IERR.NE.0) RETURN
  1221. MLMOT2.MOTS(1)=CHARRE
  1222. ENDIF
  1223. Csg : copi\E9 sur modeli.eso pour le mod\E8le de diffusion
  1224. NBM1 = MLMOT1.MOTS(/2)
  1225. NBM2 = MLMOT2.MOTS(/2)
  1226. IF (NBM1.LE.0) THEN
  1227. C 1027 2
  1228. C Une donn\E9e de type %M1:8 est vide
  1229. MOTERR(1:8)='LISTMOTS'
  1230. CALL ERREUR(1027)
  1231. RETURN
  1232. ENDIF
  1233. IF (NBM1.NE.NBM2) THEN
  1234. C 854 2
  1235. C Les listes de mots doivent etre de meme longueur.
  1236. CALL ERREUR(854)
  1237. RETURN
  1238. ENDIF
  1239. DO IBM=1,NBM1
  1240. MDIINC=' '
  1241. MDIDUA=' '
  1242. CHARIN=' '
  1243. CHARRE=' '
  1244. CHARIN=MLMOT1.MOTS(IBM)
  1245. CHARRE=MLMOT2.MOTS(IBM)
  1246. C Tronquer les mots \E0 2 caract\E8res pour pouvoir nommer les gradients ?
  1247. C (,X...)
  1248. cbp IRETMA = 2
  1249. IRETMA = 4
  1250. IRETI=LONG(CHARIN)
  1251. IF (IRETI.GT.IRETMA) THEN
  1252. INTERR(1) = IRETMA
  1253. MOTERR(1:8) = CHARIN(1:IRETI)
  1254. CALL ERREUR(-353)
  1255. ENDIF
  1256. IRETI=MIN(IRETI,IRETMA)
  1257. MDIINC(1:IRETI)=CHARIN(1:IRETI)
  1258. C Pas besoin de tronquer pour la duale
  1259. cbp IRETMA = IRETMA + 2
  1260. IRETMA = 4
  1261. IRETE=LONG(CHARRE)
  1262. IF (IRETE.GT.IRETMA) THEN
  1263. INTERR(1) = IRETMA
  1264. MOTERR(1:8) = CHARRE(1:IRETE)
  1265. CALL ERREUR(-353)
  1266. ENDIF
  1267. IRETE=MIN(IRETE,IRETMA)
  1268. MDIDUA(1:IRETE)=CHARRE(1:IRETE)
  1269. c* Verification des noms de primale et duale lues
  1270. CALL VERMDI(MDIINC,MDIDUA)
  1271. IF (IERR.NE.0) RETURN
  1272. ENDDO
  1273. if(iimpi.ge.333) then
  1274. write(ioimp,*) 'DDL PRIMAL=',(NOMDD(iou),iou=1,LNOMDD)
  1275. write(ioimp,*) 'DDL DUAL =',(NOMDU(iou),iou=1,LNOMDU)
  1276. endif
  1277. SEGDES MLMOT1,MLMOT2
  1278. GO TO 1
  1279. C Recuperation du pointeur
  1280. 145 if (ichoi.eq.2) then
  1281. call cpoint
  1282. return
  1283. endif
  1284. goto 1
  1285.  
  1286. 146 if (ichoi .eq. 2) then
  1287. C Recuperation de XPETIT dans CCOPTIO
  1288. call ecrree(XPETIT)
  1289. return
  1290. elseif(ichoi.eq.1) then
  1291. C Surcharge de XPETIT dans CCOPTIO
  1292. CALL LIRREE(XVAL, 1, IRET)
  1293. IF (IERR .NE. 0) RETURN
  1294. XVAL = ABS(XVAL)
  1295. IF (XVAL/REAL(10.D0) .LT. XVAL) THEN
  1296. XPETIT = XVAL
  1297. ELSE
  1298. REAERR(1)=XVAL
  1299. CALL ERREUR(1009)
  1300. RETURN
  1301. ENDIF
  1302. else
  1303. CALL ERREUR(21)
  1304. RETURN
  1305. endif
  1306. goto 1
  1307.  
  1308. 147 if (ichoi .eq. 2) then
  1309. C Recuperation de XGRAND dans CCOPTIO
  1310. call ecrree(XGRAND)
  1311. return
  1312. elseif(ichoi .eq. 1) then
  1313. C Surcharge de XGRAND dans CCOPTIO
  1314. CALL LIRREE(XVAL, 1, IRET)
  1315. IF (IERR .NE. 0) RETURN
  1316. XVAL = ABS(XVAL)
  1317. IF (XVAL*REAL(10.D0) .GT. XVAL) THEN
  1318. XGRAND = XVAL
  1319. ELSE
  1320. REAERR(1)=XVAL
  1321. CALL ERREUR(1009)
  1322. RETURN
  1323. ENDIF
  1324. else
  1325. CALL ERREUR(21)
  1326. RETURN
  1327. endif
  1328. goto 1
  1329.  
  1330. 148 if (ichoi .eq. 2) then
  1331. C Recuperation de XZPREC dans CCOPTIO
  1332. call ecrree(XZPREC)
  1333. return
  1334. elseif(ichoi .eq. 1) then
  1335. C Surcharge de XZPREC dans CCOPTIO
  1336. CALL LIRREE(XVAL, 1, IRET)
  1337. IF (IERR .NE. 0) RETURN
  1338. XVAL = ABS(XVAL)
  1339. XTEST= REAL(1.D0) + XVAL
  1340. IF (XTEST .LE. REAL(1.D0)) THEN
  1341. REAERR(1)=XVAL
  1342. CALL ERREUR(1009)
  1343. RETURN
  1344. ELSE
  1345. XZPREC = XVAL
  1346. ENDIF
  1347. else
  1348. CALL ERREUR(21)
  1349. RETURN
  1350. endif
  1351. goto 1
  1352. C
  1353. C option ATTE
  1354. C
  1355. 149 CONTINUE
  1356. IF (ICHOI.EQ.2) THEN
  1357. MATTE=MATTEN
  1358. CALL ECRENT(MATTE)
  1359. RETURN
  1360. ENDIF
  1361. CALL LIRENT(MATTE,1,iretou)
  1362. if(ierr.ne.0) return
  1363. CALL OOOATE(MATTE)
  1364. MATTEN=MATTE
  1365. GO TO 1
  1366. C
  1367. C option SOUC
  1368. C
  1369. 150 CONTINUE
  1370. IF (ICHOI.EQ.2) THEN
  1371. ith=max(1,oothrd)
  1372. mbso = imesou(ith)
  1373. call ecrent(mbso)
  1374. RETURN
  1375. ENDIF
  1376. GO TO 1
  1377. C -----------------
  1378. C Fin des Options
  1379. C -----------------
  1380.  
  1381. C Ouverture de fichier
  1382. C ----------------------
  1383. C Option 'SGBD'
  1384. C 1200 CONTINUE
  1385. IF (IERR.NE.0) RETURN
  1386. CLOSE (UNIT=IUNIT,iostat=istat)
  1387. L=LONG(CHA)
  1388. IFIOLD=424
  1389. OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L),
  1390. . IOSTAT=IOS,ERR=2000)
  1391. IF (IOS.NE.0) GOTO 2000
  1392. GOTO 1
  1393. C Options 'DONN','LECT','ACQU'
  1394. C Verification de l'existence du fichier lors de son ouverture
  1395. 1201 IF (IERR.NE.0) RETURN
  1396. CLOSE (UNIT=IUNIT,iostat=istat)
  1397. L=LONG(CHA)
  1398. IFIOLD=599
  1399. OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  1400. . IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1401. IF (IOS.NE.0) GOTO 2000
  1402. GOTO 1
  1403. C Options 'IMPR','FTRA','SORT'
  1404. 1211 IF (IERR.NE.0) RETURN
  1405. isuit=0
  1406. CALL LIRMOT(MSUIT,Nsuit,isuit,0)
  1407. c rem : option SUIT ok pour IMPR et FTRA, mais peut ne pas fonction-
  1408. c -ner pour SORT (ex. SORT 'EXCE' le referme et le reouvre)
  1409. L=LONG(CHA)
  1410. IFIOLD=424
  1411. INQUIRE(FILE=CHA(1:L),EXIST=ZEXIS)
  1412. c -NOUVeau (par defaut)
  1413. IF ( isuit.le.1 .OR. .not.ZEXIS ) THEN
  1414. IF (IUNIT.eq.97.OR.IUNIT.eq.24) ZINIPS=.TRUE.
  1415. CLOSE (UNIT=IUNIT,iostat=istat)
  1416. OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L),
  1417. . IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1418. c -SUITe
  1419. ELSE
  1420. c est-il ouvert ?
  1421. c CLOSE (UNIT=IUNIT,iostat=istat)
  1422. INQUIRE(UNIT=IUNIT,OPENED=ZOPEN)
  1423. IF (IUNIT.eq.97.OR.IUNIT.eq.24) ZINIPS=.FALSE.
  1424. OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  1425. . ACCESS = 'SEQUENTIAL',IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1426. CALL FINFIC(IUNIT)
  1427. c rem : pour utiliser SUIT entre deux appels a cast3m, il faudrait
  1428. c recuperer le bon ipag de strini.eso et l'incrementer...
  1429. ENDIF
  1430. IF (IOS.NE.0) GOTO 2000
  1431. GOTO 1
  1432. C Option 'SAUV' 'FORMAT'
  1433. 3201 IF (IERR.NE.0) RETURN
  1434. CLOSE (UNIT=IUNIT,iostat=istat)
  1435. if (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
  1436. ixdrw=0
  1437. iformx=iform
  1438. LCHAI=LONG(NOMSAU)
  1439. IFIOLD=424
  1440. OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=NOMSAU(1:LCHAI),
  1441. & IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1442. IF (IOS.NE.0) GOTO 2000
  1443. GOTO 1
  1444. C Option 'REST' 'FORMAT'
  1445. 2201 IF (IERR.NE.0) RETURN
  1446. CLOSE (UNIT=IUNIT,iostat=istat)
  1447. if (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. )
  1448. ixdrr=0
  1449. iformx=iform
  1450. L=LONG(CHA)
  1451. IFIOLD=599
  1452. OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  1453. . IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1454. IF (IOS.NE.0) GOTO 2000
  1455. GOTO 1
  1456. C Option 'SAUV' 'BINA' (format binaire)
  1457. 1202 IF (IERR.NE.0) RETURN
  1458. C WRITE(IOIMP,*) ' sauv en binaire'
  1459. CLOSE (UNIT=IUNIT,iostat=istat)
  1460. if (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
  1461. iformx=iform
  1462. ixdrw=0
  1463. LCHAI=LONG(NOMSAU)
  1464. IFIOLD=424
  1465. OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=NOMSAU(1:LCHAI),
  1466. . IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  1467. IF (IOS.NE.0) GOTO 2000
  1468. GOTO 1
  1469. C Options 'REST' ('BINA') (format binaire)
  1470. 2202 IF (IERR.NE.0) RETURN
  1471. C WRITE(IOIMP,*) ' rest en binaire'
  1472. CLOSE (UNIT=IUNIT,iostat=istat)
  1473. if (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. )
  1474. iformx=iform
  1475. ixdrr=0
  1476. L=LONG(CHA)
  1477. IFIOLD=599
  1478. OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  1479. . IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  1480. IF (IOS.NE.0) GOTO 2000
  1481. GOTO 1
  1482. C Options 'SAUV' ('XDR') (format XDR)
  1483. 1203 IF (IERR.NE.0) RETURN
  1484. IF (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
  1485. ixdrw=0
  1486. L=LONG(NOMSAU)
  1487. IFIOLD=424
  1488. IF (iform.GT.0) THEN
  1489. ios=initxdr(NOMSAU(1:L),'w',.TRUE.)
  1490. if (ios.LT.0) GOTO 2000
  1491. ixdrw=ios
  1492. ICHA(1:10)='CASTEM XDR'
  1493. ios=IXDRSTRING( ixdrw,ICHA(1:10))
  1494. ENDIF
  1495. IF (iform.LT.0) THEN
  1496. ios=initxdr(CHA(1:L),'r',.TRUE.)
  1497. ixdrw=ios
  1498. ENDIF
  1499. iform=2
  1500. iformx=iform
  1501. IF (IOS.LT.0) GOTO 2000
  1502. GOTO 1
  1503. C Options 'REST' (format XDR)
  1504. 2203 IF (IERR.NE.0) RETURN
  1505. IF (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. )
  1506. ixdrr=0
  1507. L=LONG(CHA)
  1508. IFIOLD=424
  1509. IF (iform.GT.0) THEN
  1510. ios=initxdr(CHA(1:L),'w',.TRUE.)
  1511. if (ios.LT.0) GOTO 2000
  1512. ixdrr=ios
  1513. ICHA(1:10)='CASTEM XDR'
  1514. ios=IXDRSTRING( ixdrr,ICHA(1:10))
  1515. ENDIF
  1516. IF (iform.LT.0) THEN
  1517. IFIOLD=599
  1518. ios=initxdr(CHA(1:L),'r',.TRUE.)
  1519. ixdrr=ios
  1520. ENDIF
  1521. iform=2
  1522. iformx=iform
  1523. IF (IOS.LT.0) GOTO 2000
  1524. GOTO 1
  1525.  
  1526. C Traitement des erreurs d'ouverture des fichiers
  1527. 2000 L=LONG(CHA)
  1528. MOTERR=CHA(1:L)
  1529. INTERR(1)=IOS
  1530. CALL ERREUR(424)
  1531.  
  1532. RETURN
  1533. END
  1534.  
  1535.  
  1536.  

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