Télécharger option.eso

Retour à la liste

Numérotation des lignes :

  1. C OPTION SOURCE PV 17/11/09 21:15:04 9602
  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.20)) 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. * destruction des eventuels fichiers existants
  595. lchai=min(68,long(cha))
  596. lcha=lchai
  597. nomfic(1:lcha)=cha
  598. open(file=nomfic(1:lcha),status='OLD',iostat=istat,unit=iunit)
  599. if (istat.eq.0) then
  600. close(iunit,status='DELETE')
  601. else
  602. goto 1173
  603. endif
  604. ll=lcha+1
  605. nomfic(ll:ll+1)='_1'
  606. ll=ll+1
  607. do isuit=1,10000
  608. if (isuit.lt.10) then
  609. write (nomfic(ll:ll),fmt='(I1)') isuit
  610. lcha=ll
  611. elseif (isuit.lt.100) then
  612. write (nomfic(ll:ll+1),fmt='(I2)') isuit
  613. lcha=ll+1
  614. elseif (isuit.lt.1000) then
  615. write (nomfic(ll:ll+2),fmt='(I3)') isuit
  616. lcha=ll+2
  617. elseif (isuit.lt.10000) then
  618. write (nomfic(ll:ll+3),fmt='(I4)') isuit
  619. lcha=ll+3
  620. endif
  621. open(file=nomfic(1:lcha),status='OLD',iostat=istat,unit=iunit)
  622. if (istat.eq.0) then
  623. close(iunit,status='DELETE')
  624. else
  625. goto 1173
  626. endif
  627. enddo
  628. 1173 continue
  629. nomfic=nomfic(1:lchai)
  630. IF (IFORM.EQ.1) GOTO 3201
  631. IF (IFORM.EQ.2) GOTO 1203
  632. GOTO 1202
  633. C ---------------
  634. C Option 'REST'
  635. C ---------------
  636. 118 CONTINUE
  637. IF (ICHOI.EQ.2) THEN
  638. CALL ECRENT(IORES)
  639. RETURN
  640. ENDIF
  641. IFICLE=0
  642. IFORM=0
  643. IREFOR=0
  644. CALL MESLIR(-193)
  645. 1172 CALL LIRMOT(FORMAT,nbform,ichor,0)
  646. IF (IERR.NE.0) RETURN
  647. IF (ICHOr.EQ.1) THEN
  648. IREFOR=1
  649. IFORM=1
  650. GOTO 1172
  651. ELSE IF (ICHOr.EQ.2) THEN
  652. GOTO 1172
  653. ELSE IF (ICHOr.EQ.3) THEN
  654. IFORM=-2
  655. GOTO 1172
  656. ELSEIF (ICHOr.EQ.4) then
  657. IFORM=0
  658. GOTO 1172
  659. ENDIF
  660. CALL MESLIR(-194)
  661. CALL LIRENT(IRET,0,IRetou)
  662. IF (IRetou.NE.0) THEN
  663. IF (IRET.LE.0) CALL ERREUR(36)
  664. IF (IERR.NE.0) RETURN
  665. IORES=IRET
  666. GOTO 1
  667. ENDIF
  668. CALL LIRCHA(CHA,1,IRetou)
  669. IF (IERR.NE.0) RETURN
  670. IUNIT=IORES
  671. NOMRES=CHA
  672. C test sur le type de fichier
  673. CLOSE(UNIT=IUNIT)
  674. L=LONG(CHA)
  675. IFORM=1
  676. IREFOR=1
  677. IFIOLD=599
  678. OPEN(UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  679. . IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  680. IF (IOS.EQ.0) THEN
  681. iretou=0
  682. iquoi=0
  683. CALL LFCDES(IORES,IQUOI,IRETOU,IFORM)
  684. C WRITE(IOIMP,*) 'apres lfcdes-1 ',iores,iquoi,iretou,iform
  685. IF (IOS.EQ.0.AND.(IQUOI.GT.0.AND.IQUOI.LT.10).AND.
  686. . IRETOU.EQ.0) THEN
  687. CALL ERREUR(-342)
  688. GOTO 3250
  689. ENDIF
  690. ENDIF
  691. IFORM=0
  692. IREFOR=0
  693. CLOSE(UNIT=IUNIT)
  694. OPEN(UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  695. . IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  696. IF (IOS.EQ.0) THEN
  697. iretou=0
  698. iquoi=0
  699. CALL LFCDES (IORES,IQUOI,IRETOU,IFORM)
  700. C WRITE (IOIMP,*) 'apres lfcdes-2 ',iores,iquoi,iretou,iform
  701. IF (IOS.EQ.0.AND.(IQUOI.GT.0.AND.IQUOI.LT.10).AND.
  702. . IRETOU.EQ.0) THEN
  703. CALL ERREUR(-343)
  704. GOTO 3250
  705. ENDIF
  706. ENDIF
  707. IFORM=2
  708. IF (ixdrr.NE.0) IOS=IXDRCLOSE(ixdrr,.TRUE.)
  709. ios=initxdr(CHA(1:L),'r',.TRUE.)
  710. IF (ios.lt.0) GOTO 2000
  711. ixdrr=ios
  712. ios=IXDRSTRING(ixdrr,ICHA(1:10))
  713. C WRITE(IOIMP,*) ' option rest ',icha(1:10),ios
  714. IF (IOS.GE.0.AND.ICHA(1:10).EQ.'CASTEM XDR') THEN
  715. C WRITE (IOIMP,*) ' on va direct en 1 '
  716. IFORM=2
  717. iformx=IFORM
  718. CALL ERREUR(-344)
  719. GOTO 1
  720. ENDIF
  721. IFIOLD=424
  722. GOTO 2000
  723. 3250 iformx=IFORM
  724. IF (IFORM.EQ.1) GOTO 2201
  725. IF (IFORM.EQ.-2) GOTO 2203
  726. GOTO 2202
  727. C ---------------
  728. C Option 'ISOV'
  729. C ---------------
  730. 119 IF (ICHOI.EQ.2) THEN
  731. CALL ECRCHA(MISO(ISOTYP+1))
  732. RETURN
  733. ENDIF
  734. CALL MESLIR(-192)
  735. CALL LIRMOT(MISO,NbIso,IRET,1)
  736. IF (IRET.LE.0) CALL ERREUR(36)
  737. IF (IERR.NE.0) RETURN
  738. ISOTYP=IRET-1
  739. ICHA=MISO(IRET)
  740. GOTO 1
  741. C ---------------
  742. C Option 'OMBRE'
  743. C ---------------
  744. 120 IF (ICHOI.EQ.2) THEN
  745. LOG=.FALSE.
  746. IF (IOMBRE.EQ.1) LOG =.TRUE.
  747. CALL ECRLOG(LOG)
  748. RETURN
  749. ENDIF
  750. CALL MESLIR(-191)
  751. CALL LIRLOG(LOG,1,IRET)
  752. IF (IERR.NE.0) RETURN
  753. IF (LOG) THEN
  754. IOMBRE=1
  755. ELSE
  756. IOMBRE=0
  757. ENDIF
  758. GOTO 1
  759. C ---------------
  760. C Option 'NBP '
  761. C ---------------
  762. 121 IF (ICHOI.EQ.2) THEN
  763. IRET=XCOOR(/1)/(IDIM+1)
  764. CALL ECRENT(IRET)
  765. RETURN
  766. ENDIF
  767. CALL MESLIR(-190)
  768. CALL LIRENT(IRET,1,IRetou)
  769. IF (IERR.NE.0) RETURN
  770. NBPTS=MAX(0,IRET)
  771. SEGADJ MCOORD
  772. GOTO 1
  773. C ---------------
  774. C Option 'VERI'
  775. C ---------------
  776. 122 IF (ICHOI.EQ.2) THEN
  777. CALL ECRENT(IOSPI)
  778. RETURN
  779. ENDIF
  780. CALL MESLIR(-189)
  781. CALL LIRENT(IRET,1,IRetou)
  782. IF (IERR.NE.0) RETURN
  783. IOSPI=IRET
  784. GOTO 1
  785. C ---------------
  786. C Option 'ZERO'
  787. C ---------------
  788. 123 IF (ICHOI.EQ.2) THEN
  789. CALL ECRENT(IZROSF)
  790. RETURN
  791. ENDIF
  792. CALL MESLIR(-188)
  793. CALL LIRENT(IRET,1,IRetou)
  794. IF (IERR.NE.0) RETURN
  795. IZROSF=MAX(1,IRET)
  796. GOTO 1
  797. C ---------------
  798. C Option 'ACQU'
  799. C ---------------
  800. 124 IF (ICHOI.EQ.2) THEN
  801. CALL ECRENT(IOACQ)
  802. RETURN
  803. ENDIF
  804. CALL MESLIR(-187)
  805. CALL LIRENT(IRET,0,IRetou)
  806. IF (IRetou.NE.0) THEN
  807. IOACQ=IRET
  808. GOTO 1
  809. ENDIF
  810. CALL MESLIR(-186)
  811. CALL LIRCHA(CHA,1,IRetou)
  812. IUNIT=IOACQ
  813. GOTO 1201
  814. C ---------------
  815. C Option '----'
  816. C ---------------
  817. 125 CONTINUE
  818. GOTO 1
  819. C ---------------
  820. C Option 'PLAC'
  821. C ---------------
  822. 126 IF (ICHOI.EQ.2) THEN
  823. CALL ECRENT(IPLLB)
  824. RETURN
  825. ENDIF
  826. CALL MESLIR(-184)
  827. CALL LIRENT(IRET,1,IRetou)
  828. IF (IERR.NE.0) RETURN
  829. C Pourquoi mettre IPLLB en positif ?
  830. C N'etant pas sur de la valeur de IPLTOT il faut pouvoir le mettre
  831. C en negatif tres grand (voir T.C.)
  832. C IRET=MAX(1,IRET)
  833. IPLLB=IRET
  834. GOTO 1
  835. C ---------------
  836. C Option 'LANG'
  837. C ---------------
  838. 127 IF (ICHOI.EQ.2) THEN
  839. CALL ECRCHA (LANGUE)
  840. RETURN
  841. ENDIF
  842. CALL LIRCHA(ICHA,1,IRetou)
  843. IF (IERR.NE.0) RETURN
  844. LANGUE=ICHA
  845. GOTO 1
  846. C ---------------
  847. C Option 'NORM'
  848. C ---------------
  849. 128 IF (ICHOI.EQ.2) THEN
  850. CALL ERREUR(758)
  851. RETURN
  852. ENDIF
  853. C On commence par une remise a plat : tout a 0 .
  854. C On devrait liberer la place occupee eventuellement par ces segments,
  855. C mais comme on a fait SAVSEG avant. Il faudrait aussi les enlever de
  856. C la liste des non-effacables, mais comment ?
  857. NORINC=0
  858. NORVAL=0
  859. NORIND=0
  860. NORVAD=0
  861. C Lecture des mts cles eventuels
  862. CALL LIRMOT(NAUTO,NbAuto,i,0)
  863. IF (i.EQ.2) GOTO 1
  864. C Normalisation automatique
  865. IF (i.EQ.1) THEN
  866. NORINC=-1
  867. GOTO 1
  868. ENDIF
  869. CALL LIROBJ('LISTMOTS',NORINC,1,IRetou)
  870. CALL LIROBJ('LISTREEL',NORVAL,1,IRetou)
  871. IF (IERR.NE.0) THEN
  872. NORINC=0
  873. NORVAL=0
  874. GOTO 1
  875. ENDIF
  876. MLREEL=NORVAL
  877. MLMOTS=NORINC
  878. SEGACT MLREEL,MLMOTS
  879. NRE=PROG(/1)
  880. NMO=MOTS(/2)
  881. SEGDES MLREEL,MLMOTS
  882. IF (NRE.NE.NMO) THEN
  883. CALL ERREUR(212)
  884. NORINC=0
  885. NORVAL=0
  886. RETURN
  887. ENDIF
  888. C Verification s'il n'y a pas de 'LX' la dedans
  889. C La taille de mots doit etre OK si le LISTMOTS est cree par MOTS
  890. SEGACT MLMOTS
  891. DO i=1,NMO
  892. IF (MOTS(i)(1:4).EQ.'LX ') THEN
  893. CALL ERREUR( 759 )
  894. NORINC=0
  895. NORVAL=0
  896. SEGDES MLMOTS
  897. RETURN
  898. ENDIF
  899. ENDDO
  900. SEGDES MLMOTS
  901. CALL SAVSEG(MLREEL)
  902. CALL SAVSEG(MLMOTS)
  903. CALL LIROBJ('LISTMOTS',NORIND,0,IRetou)
  904. IF (IRetou.EQ.0) GOTO 1
  905. CALL LIROBJ('LISTREEL',NORVAD,1,IRetou)
  906. IF (IERR.NE.0) THEN
  907. NORIND=0
  908. NORVAD=0
  909. ENDIF
  910. MLREEL=NORVAD
  911. MLMOTS=NORIND
  912. SEGACT MLREEL,MLMOTS
  913. NRE=PROG(/1)
  914. NMO=MOTS(/2)
  915. SEGDES MLREEL,MLMOTS
  916. IF (NRE.NE.NMO) THEN
  917. CALL ERREUR(212)
  918. NORIND=0
  919. NORVAD=0
  920. RETURN
  921. ENDIF
  922. CALL SAVSEG(MLREEL)
  923. CALL SAVSEG(MLMOTS)
  924. GOTO 1
  925. C ---------------
  926. C Option 'RESO'
  927. C ---------------
  928. 129 IF (ICHOI.EQ.2) THEN
  929. CALL ECRCHA(MRESOL(NUCROU+1))
  930. RETURN
  931. ENDIF
  932. CALL MESLIR(-187)
  933. CALL LIRMOT(MRESOL,NbReso,IRetou,1)
  934. IF (IERR.NE.0) RETURN
  935. NUCROU=IRetou-1
  936. GOTO 1
  937. C ---------------
  938. C Option 'FTRA'
  939. C ---------------
  940. 130 IF (ICHOI.EQ.2) THEN
  941. IF (iogra.ge.7.and.iogra.le.9) THEN
  942. IF (IOGRA.EQ.8) THEN
  943. IUPS=97
  944. ELSE
  945. IUPS=24
  946. ENDIF
  947. INQUIRE(UNIT=IUPS,NAME=NOMFIC)
  948. CALL ECRCHA(NOMFIC(1:LONG(NOMFIC)))
  949. RETURN
  950. ELSE
  951. CALL ERREUR(758)
  952. RETURN
  953. ENDIF
  954. ENDIF
  955. IF (iogra.ge.7.and.iogra.le.9) THEN
  956. c ZINIPS=.TRUE.
  957. CALL MESLIR(-209)
  958. CALL LIRCHA(CHA,1,IRetou)
  959. IF (IOGRA.EQ.8) THEN
  960. IUPS=97
  961. ELSE
  962. IUPS=24
  963. ENDIF
  964. IUNIT=IUPS
  965. GOTO 1211
  966. ELSE
  967. CALL ERREUR(26)
  968. RETURN
  969. ENDIF
  970. GOTO 1
  971. C ---------------
  972. C Option 'OEIL'
  973. C ---------------
  974. 131 IF (ICHOI.EQ.2) THEN
  975. IF (IOEIL.NE.0) THEN
  976. CALL ECROBJ('POINT',IOEIL)
  977. ELSE
  978. C 18 2 Point non trouve
  979. CALL ERREUR(18)
  980. ENDIF
  981. RETURN
  982. ENDIF
  983. CALL LIROBJ('POINT',IOEIL,1,IRetou)
  984. IF (IERR.NE.0) RETURN
  985. GOTO 1
  986. C ---------------
  987. C Option 'ERMA'
  988. C ---------------
  989. 132 IF (ICHOI.EQ.2) THEN
  990. CALL ECRENT(IERMAX)
  991. RETURN
  992. ELSE
  993. CALL ERREUR(758)
  994. RETURN
  995. ENDIF
  996. GOTO 1
  997. C ---------------
  998. C Option 'ASSI'
  999. C ---------------
  1000. 133 IF (ICHOI.EQ.2) THEN
  1001. CALL ECRENT(NBESCR)
  1002. RETURN
  1003. ENDIF
  1004. IF (NBESC.NE.0) CALL ERREUR(892)
  1005. IF (IERR.NE.0) RETURN
  1006. CALL LIRENT(IRET,0,IRetou)
  1007. IF (IRetou.NE.0) THEN
  1008. IF (IRET.LT.0) CALL ERREUR(36)
  1009. IF (IRET.GT.64) CALL ERREUR(36)
  1010. if (nbesc.ne.0) call erreur(36)
  1011. if (ierr.eq.0.and.nbesc.eq.0) then
  1012. NBESCR=IRET
  1013. endif
  1014. ENDIF
  1015. GOTO 1
  1016. C ---------------
  1017. C Option 'EPTR'
  1018. C ---------------
  1019. 134 IF (ICHOI.EQ.2) THEN
  1020. CALL ECRENT(IEPTR)
  1021. RETURN
  1022. ENDIF
  1023. CALL MESLIR(-340)
  1024. CALL LIRENT(IRET,1,IRetou)
  1025. IF (IRetou.NE.0) THEN
  1026. IF (IRET.LT.0) CALL ERREUR(36)
  1027. IEPTR=IRET
  1028. ENDIF
  1029. GOTO 1
  1030. C ---------------
  1031. C Option 'NAVI'
  1032. C ---------------
  1033. 135 IF (ICHOI.EQ.2) THEN
  1034. CALL ECRCHA(NNAVI(ILNAVI))
  1035. RETURN
  1036. ENDIF
  1037. CALL MESLIR(-341)
  1038. CALL LIRMOT(NNAVI,LNNAVI,IRET,1)
  1039. IF (IERR.NE.0) RETURN
  1040. IF (IRET.LE.0) CALL ERREUR(36)
  1041. ILNAVI=IRET
  1042. ICHA=NNAVI(ILNAVI)
  1043. GOTO 1
  1044. C
  1045. C option PARA
  1046. C
  1047. 136 IF( ICHOI.EQ.2) THEN
  1048. if(lupara.eq.1) then
  1049. call ecrlog(.TRUE.)
  1050. else
  1051. call ecrlog (.FALSE.)
  1052. endif
  1053. RETURN
  1054. ELSE
  1055. CALL LIRlog(log,1,iretou)
  1056. IF (Ierr.NE.0) return
  1057. LUPARA=0
  1058. if(log) lupara=1
  1059. ENDIF
  1060. GO TO 1
  1061. C
  1062. C option SURV
  1063. C
  1064. 137 CONTINUE
  1065. IF (ICHOI.EQ.2) THEN
  1066. CALL ERREUR(758)
  1067. RETURN
  1068. ENDIF
  1069. CALL LIRENT(msur,1,iretou)
  1070. if(ierr.ne.0) return
  1071. CALL OOOSUR(MSUR)
  1072. GO TO 1
  1073. C ---------------
  1074. C Option 'POLI'
  1075. C ---------------
  1076. 138 IF (ICHOI.EQ.2) THEN
  1077. CALL ECRCHA(MPOLI(IOPOLI))
  1078. RETURN
  1079. ENDIF
  1080. CALL MESLIR(-211)
  1081. CALL LIRMOT(MPOLI,NbPoli,ij,1)
  1082. IF (IERR.NE.0) RETURN
  1083. IOPOLI=ij
  1084. GOTO 1
  1085. C ---------------
  1086. C Option 'COSC'
  1087. C ---------------
  1088. 139 IF (ICHOI.EQ.2) THEN
  1089. CALL ECRCHA(MCOSC(ICOSC))
  1090. RETURN
  1091. ENDIF
  1092. CALL MESLIR(-211)
  1093. CALL LIRMOT(MCOSC,NbCosc,ij,1)
  1094. IF (IERR.NE.0) RETURN
  1095. ICOSC=ij
  1096. GOTO 1
  1097. C ---------------
  1098. C Option 'POTR'
  1099. C ---------------
  1100. 140 IF (ICHOI.EQ.2) THEN
  1101. CALL ECRCHA(MPOTR(IOPOTR))
  1102. RETURN
  1103. ENDIF
  1104. CALL MESLIR(-211)
  1105. CALL LIRMOT(MPOTR,NbPotr,ij,1)
  1106. IF (IERR.NE.0) RETURN
  1107. IOPOTR=ij
  1108. GOTO 1
  1109. C ----------------
  1110. C option debug
  1111. C ----------------
  1112. 141 IF (ICHOI.EQ.2) THEN
  1113. call ecrent (misaup)
  1114. return
  1115. ENDIF
  1116. CALL LIRENT(MISAUP,1,iretou)
  1117. IF(IERR.NE.0) RETURN
  1118. GO TO 1
  1119. C ----------------
  1120. C option 'LOCA'
  1121. C ----------------
  1122. 142 IF (ICHOI.EQ.2) THEN
  1123. CALL ECRLOG(ZLOPRO)
  1124. RETURN
  1125. ENDIF
  1126. CALL LIRLOG(ZLOPRO,1,IRETOU)
  1127. IF (IERR.NE.0) RETURN
  1128. GO TO 1
  1129. C ----------------
  1130. C option 'DENS'
  1131. C ----------------
  1132. 143 IF (ICHOI.EQ.2) THEN
  1133. XRET=DENSIT
  1134. CALL ECRREE(XRET)
  1135. RETURN
  1136. ENDIF
  1137. CALL MESLIR(-238)
  1138. CALL LIRREE(XRET,1,IRETOU)
  1139. IF (IERR.NE.0) RETURN
  1140. C sg: comme dans subden.eso on met ABS(XRET)
  1141. DENSIT=ABS(XRET)
  1142. GO TO 1
  1143. C ----------------
  1144. C option 'INCO'
  1145. C ----------------
  1146. 144 IF (ICHOI.EQ.2) THEN
  1147. JGN=4
  1148. JGM=LNOMDD
  1149. SEGINI MLMOT1
  1150. DO IGM=1,JGM
  1151. MLMOT1.MOTS(IGM)=NOMDD(IGM)
  1152. ENDDO
  1153. SEGDES MLMOT1
  1154. JGN=4
  1155. JGM=LNOMDU
  1156. SEGINI MLMOT2
  1157. DO IGM=1,JGM
  1158. MLMOT2.MOTS(IGM)=NOMDU(IGM)
  1159. ENDDO
  1160. SEGDES MLMOT2
  1161. CALL ECROBJ('LISTMOTS',MLMOT2)
  1162. CALL ECROBJ('LISTMOTS',MLMOT1)
  1163. RETURN
  1164. ENDIF
  1165. CALL LIROBJ('LISTMOTS',MLMOT1,0,IRET)
  1166. IF (IERR.NE.0) RETURN
  1167. IF (IRET.NE.0) THEN
  1168. CALL LIROBJ('LISTMOTS',MLMOT2,1,IRET)
  1169. IF (IERR.NE.0) RETURN
  1170. SEGACT MLMOT1,MLMOT2
  1171. ELSE
  1172. JGN=LEN(CHARIN)
  1173. JGM=1
  1174. SEGINI MLMOT1,MLMOT2
  1175. CALL LIRCHA(CHARIN,1,IRET)
  1176. IF (IERR.NE.0) RETURN
  1177. MLMOT1.MOTS(1)=CHARIN
  1178. CALL LIRCHA(CHARRE,1,IRET)
  1179. IF (IERR.NE.0) RETURN
  1180. MLMOT2.MOTS(1)=CHARRE
  1181. ENDIF
  1182. Csg : copi\E9 sur modeli.eso pour le mod\E8le de diffusion
  1183. NBM1 = MLMOT1.MOTS(/2)
  1184. NBM2 = MLMOT2.MOTS(/2)
  1185. IF (NBM1.LE.0) THEN
  1186. C 1027 2
  1187. C Une donn\E9e de type %M1:8 est vide
  1188. MOTERR(1:8)='LISTMOTS'
  1189. CALL ERREUR(1027)
  1190. RETURN
  1191. ENDIF
  1192. IF (NBM1.NE.NBM2) THEN
  1193. C 854 2
  1194. C Les listes de mots doivent etre de meme longueur.
  1195. CALL ERREUR(854)
  1196. RETURN
  1197. ENDIF
  1198. DO IBM=1,NBM1
  1199. MDIINC=' '
  1200. MDIDUA=' '
  1201. CHARIN=' '
  1202. CHARRE=' '
  1203. CHARIN=MLMOT1.MOTS(IBM)
  1204. CHARRE=MLMOT2.MOTS(IBM)
  1205. C Tronquer les mots \E0 2 caract\E8res pour pouvoir nommer les gradients ?
  1206. C (,X...)
  1207. cbp IRETMA = 2
  1208. IRETMA = 4
  1209. IRETI=LONG(CHARIN)
  1210. IF (IRETI.GT.IRETMA) THEN
  1211. INTERR(1) = IRETMA
  1212. MOTERR(1:8) = CHARIN(1:IRETI)
  1213. CALL ERREUR(-353)
  1214. ENDIF
  1215. IRETI=MIN(IRETI,IRETMA)
  1216. MDIINC(1:IRETI)=CHARIN(1:IRETI)
  1217. C Pas besoin de tronquer pour la duale
  1218. cbp IRETMA = IRETMA + 2
  1219. IRETMA = 4
  1220. IRETE=LONG(CHARRE)
  1221. IF (IRETE.GT.IRETMA) THEN
  1222. INTERR(1) = IRETMA
  1223. MOTERR(1:8) = CHARRE(1:IRETE)
  1224. CALL ERREUR(-353)
  1225. ENDIF
  1226. IRETE=MIN(IRETE,IRETMA)
  1227. MDIDUA(1:IRETE)=CHARRE(1:IRETE)
  1228. c* Verification des noms de primale et duale lues
  1229. CALL VERMDI(MDIINC,MDIDUA)
  1230. IF (IERR.NE.0) RETURN
  1231. ENDDO
  1232. if(iimpi.ge.333) then
  1233. write(ioimp,*) 'DDL PRIMAL=',(NOMDD(iou),iou=1,LNOMDD)
  1234. write(ioimp,*) 'DDL DUAL =',(NOMDU(iou),iou=1,LNOMDU)
  1235. endif
  1236. SEGDES MLMOT1,MLMOT2
  1237. GO TO 1
  1238. C Recuperation du pointeur
  1239. 145 if (ichoi.eq.2) then
  1240. call cpoint
  1241. return
  1242. endif
  1243. goto 1
  1244.  
  1245. 146 if (ichoi .eq. 2) then
  1246. C Recuperation de XPETIT dans CCOPTIO
  1247. call ecrree(XPETIT)
  1248. return
  1249. elseif(ichoi.eq.1) then
  1250. C Surcharge de XPETIT dans CCOPTIO
  1251. CALL LIRREE(XVAL, 1, IRET)
  1252. IF (IERR .NE. 0) RETURN
  1253. XVAL = ABS(XVAL)
  1254. IF (XVAL/REAL(10.D0) .LT. XVAL) THEN
  1255. XPETIT = XVAL
  1256. ELSE
  1257. REAERR(1)=XVAL
  1258. CALL ERREUR(1009)
  1259. RETURN
  1260. ENDIF
  1261. else
  1262. CALL ERREUR(21)
  1263. RETURN
  1264. endif
  1265. goto 1
  1266.  
  1267. 147 if (ichoi .eq. 2) then
  1268. C Recuperation de XGRAND dans CCOPTIO
  1269. call ecrree(XGRAND)
  1270. return
  1271. elseif(ichoi .eq. 1) then
  1272. C Surcharge de XGRAND dans CCOPTIO
  1273. CALL LIRREE(XVAL, 1, IRET)
  1274. IF (IERR .NE. 0) RETURN
  1275. XVAL = ABS(XVAL)
  1276. IF (XVAL*REAL(10.D0) .GT. XVAL) THEN
  1277. XGRAND = XVAL
  1278. ELSE
  1279. REAERR(1)=XVAL
  1280. CALL ERREUR(1009)
  1281. RETURN
  1282. ENDIF
  1283. else
  1284. CALL ERREUR(21)
  1285. RETURN
  1286. endif
  1287. goto 1
  1288.  
  1289. 148 if (ichoi .eq. 2) then
  1290. C Recuperation de XZPREC dans CCOPTIO
  1291. call ecrree(XZPREC)
  1292. return
  1293. elseif(ichoi .eq. 1) then
  1294. C Surcharge de XZPREC dans CCOPTIO
  1295. CALL LIRREE(XVAL, 1, IRET)
  1296. IF (IERR .NE. 0) RETURN
  1297. XVAL = ABS(XVAL)
  1298. XTEST= REAL(1.D0) + XVAL
  1299. IF (XTEST .LE. REAL(1.D0)) THEN
  1300. REAERR(1)=XVAL
  1301. CALL ERREUR(1009)
  1302. RETURN
  1303. ELSE
  1304. XZPREC = XVAL
  1305. ENDIF
  1306. else
  1307. CALL ERREUR(21)
  1308. RETURN
  1309. endif
  1310. goto 1
  1311. C -----------------
  1312. C Fin des Options
  1313. C -----------------
  1314.  
  1315. C Ouverture de fichier
  1316. C ----------------------
  1317. C Option 'SGBD'
  1318. C 1200 CONTINUE
  1319. IF (IERR.NE.0) RETURN
  1320. CLOSE (UNIT=IUNIT)
  1321. L=LONG(CHA)
  1322. IFIOLD=424
  1323. OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L),
  1324. . IOSTAT=IOS,ERR=2000)
  1325. IF (IOS.NE.0) GOTO 2000
  1326. GOTO 1
  1327. C Options 'DONN','LECT','ACQU'
  1328. C Verification de l'existence du fichier lors de son ouverture
  1329. 1201 IF (IERR.NE.0) RETURN
  1330. CLOSE (UNIT=IUNIT)
  1331. L=LONG(CHA)
  1332. IFIOLD=599
  1333. OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  1334. . IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1335. IF (IOS.NE.0) GOTO 2000
  1336. GOTO 1
  1337. C Options 'IMPR','FTRA','SORT'
  1338. 1211 IF (IERR.NE.0) RETURN
  1339. isuit=0
  1340. CALL LIRMOT(MSUIT,Nsuit,isuit,0)
  1341. c rem : option SUIT ok pour IMPR et FTRA, mais peut ne pas fonction-
  1342. c -ner pour SORT (ex. SORT 'EXCE' le referme et le reouvre)
  1343. L=LONG(CHA)
  1344. IFIOLD=424
  1345. INQUIRE(FILE=CHA(1:L),EXIST=ZEXIS)
  1346. c -NOUVeau (par defaut)
  1347. IF ( isuit.le.1 .OR. .not.ZEXIS ) THEN
  1348. IF (IUNIT.eq.97.OR.IUNIT.eq.24) ZINIPS=.TRUE.
  1349. CLOSE (UNIT=IUNIT)
  1350. OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L),
  1351. . IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1352. c -SUITe
  1353. ELSE
  1354. c est-il ouvert ?
  1355. c CLOSE (UNIT=IUNIT)
  1356. INQUIRE(UNIT=IUNIT,OPENED=ZOPEN)
  1357. IF (IUNIT.eq.97.OR.IUNIT.eq.24) ZINIPS=.FALSE.
  1358. OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  1359. . ACCESS = 'SEQUENTIAL',IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1360. CALL FINFIC(IUNIT)
  1361. c rem : pour utiliser SUIT entre deux appels a cast3m, il faudrait
  1362. c recuperer le bon ipag de strini.eso et l'incrementer...
  1363. ENDIF
  1364. IF (IOS.NE.0) GOTO 2000
  1365. GOTO 1
  1366. C Option 'SAUV' 'FORMAT'
  1367. 3201 IF (IERR.NE.0) RETURN
  1368. CLOSE (UNIT=IUNIT)
  1369. if (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
  1370. ixdrw=0
  1371. iformx=iform
  1372. L=LONG(CHA)
  1373. IFIOLD=424
  1374. OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L),
  1375. . IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1376. IF (IOS.NE.0) GOTO 2000
  1377. GOTO 1
  1378. C Option 'REST' 'FORMAT'
  1379. 2201 IF (IERR.NE.0) RETURN
  1380. CLOSE (UNIT=IUNIT)
  1381. if (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. )
  1382. ixdrr=0
  1383. iformx=iform
  1384. L=LONG(CHA)
  1385. IFIOLD=599
  1386. OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  1387. . IOSTAT=IOS,ERR=2000,FORM='FORMATTED')
  1388. IF (IOS.NE.0) GOTO 2000
  1389. GOTO 1
  1390. C Option 'SAUV' 'BINA' (format binaire)
  1391. 1202 IF (IERR.NE.0) RETURN
  1392. C WRITE(IOIMP,*) ' sauv en binaire'
  1393. CLOSE (UNIT=IUNIT)
  1394. if (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
  1395. iformx=iform
  1396. ixdrw=0
  1397. L=LONG(CHA)
  1398. IFIOLD=424
  1399. OPEN (UNIT=IUNIT,STATUS='UNKNOWN',FILE=CHA(1:L),
  1400. . IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  1401. IF (IOS.NE.0) GOTO 2000
  1402. GOTO 1
  1403. C Options 'REST' ('BINA') (format binaire)
  1404. 2202 IF (IERR.NE.0) RETURN
  1405. C WRITE(IOIMP,*) ' rest en binaire'
  1406. CLOSE (UNIT=IUNIT)
  1407. if (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. )
  1408. iformx=iform
  1409. ixdrr=0
  1410. L=LONG(CHA)
  1411. IFIOLD=599
  1412. OPEN (UNIT=IUNIT,STATUS='OLD',FILE=CHA(1:L),
  1413. . IOSTAT=IOS,ERR=2000,FORM='UNFORMATTED')
  1414. IF (IOS.NE.0) GOTO 2000
  1415. GOTO 1
  1416. C Options 'SAUV' ('XDR') (format XDR)
  1417. 1203 IF (IERR.NE.0) RETURN
  1418. IF (ixdrw.NE.0) ios=IXDRCLOSE( ixdrw,.TRUE. )
  1419. ixdrw=0
  1420. L=LONG(CHA)
  1421. IFIOLD=424
  1422. IF (iform.GT.0) THEN
  1423. ios=initxdr(CHA(1:L),'w',.TRUE.)
  1424. if (ios.LT.0) GOTO 2000
  1425. ixdrw=ios
  1426. ICHA(1:10)='CASTEM XDR'
  1427. ios=IXDRSTRING( ixdrw,ICHA(1:10))
  1428. ENDIF
  1429. IF (iform.LT.0) THEN
  1430. ios=initxdr(CHA(1:L),'r',.TRUE.)
  1431. ixdrw=ios
  1432. ENDIF
  1433. iform=2
  1434. iformx=iform
  1435. IF (IOS.LT.0) GOTO 2000
  1436. GOTO 1
  1437. C Options 'REST' (format XDR)
  1438. 2203 IF (IERR.NE.0) RETURN
  1439. IF (ixdrr.NE.0) ios=IXDRCLOSE( ixdrr,.TRUE. )
  1440. ixdrr=0
  1441. L=LONG(CHA)
  1442. IFIOLD=424
  1443. IF (iform.GT.0) THEN
  1444. ios=initxdr(CHA(1:L),'w',.TRUE.)
  1445. if (ios.LT.0) GOTO 2000
  1446. ixdrr=ios
  1447. ICHA(1:10)='CASTEM XDR'
  1448. ios=IXDRSTRING( ixdrr,ICHA(1:10))
  1449. ENDIF
  1450. IF (iform.LT.0) THEN
  1451. IFIOLD=599
  1452. ios=initxdr(CHA(1:L),'r',.TRUE.)
  1453. ixdrr=ios
  1454. ENDIF
  1455. iform=2
  1456. iformx=iform
  1457. IF (IOS.LT.0) GOTO 2000
  1458. GOTO 1
  1459.  
  1460. C Traitement des erreurs d'ouverture des fichiers
  1461. 2000 L=LONG(CHA)
  1462. MOTERR=CHA(1:L)
  1463. INTERR(1)=IOS
  1464. CALL ERREUR(424)
  1465.  
  1466. RETURN
  1467. END
  1468.  
  1469.  
  1470.  
  1471.  
  1472.  
  1473.  
  1474.  
  1475.  

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