Télécharger option.eso

Retour à la liste

Numérotation des lignes :

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

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