Télécharger option.eso

Retour à la liste

Numérotation des lignes :

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

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