Télécharger option.eso

Retour à la liste

Numérotation des lignes :

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

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