Télécharger option.eso

Retour à la liste

Numérotation des lignes :

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

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