Télécharger mapr.eso

Retour à la liste

Numérotation des lignes :

  1. C MAPR SOURCE PV 20/03/26 21:16:14 10563
  2. SUBROUTINE MAPR (IRZTC)
  3. IMPLICIT INTEGER(I-N)
  4. -INC PPARAM
  5. -INC CCOPTIO
  6. -INC SMBLOC
  7. -INC CCNOYAU
  8. -INC CCASSIS
  9. SEGMENT ISEGP1
  10. INTEGER NOMMM(NIS)
  11. ENDSEGMENT
  12. SEGMENT ISEGP2
  13. CHARACTER*(8) NTYP(NIS)
  14. ENDSEGMENT
  15. SEGMENT ISEGP3
  16. INTEGER IOBLI(NIS)
  17. ENDSEGMENT
  18. SEGMENT ISEGP4
  19. CHARACTER*(8) NSSTYP(NIS)
  20. ENDSEGMENT
  21. SEGMENT ISEGP5
  22. INTEGER ILSSTY(NIS)
  23. ENDSEGMENT
  24. SEGMENT ISEG3
  25. INTEGER IRESAR(NIS)
  26. ENDSEGMENT
  27. SEGMENT IITRA
  28. integer ilevel(nlev),isino(nlev,nsi)
  29. ENDSEGMENT
  30. CHARACTER*(8) ICHA,CHAANC
  31. CHARACTER*(LONOM) CNOM,INOMP,NAM
  32. LOGICAL LOGI
  33. REAL*8 XRET
  34. DIMENSION LIRM(7)
  35. CHARACTER*4 MCLE(7), MAST(2)
  36. DATA MCLE/'REPE','FIN ','FINP','FINM','SI','SINO','FINS'/
  37. DATA MAST/'* ','/ '/
  38. C LECTURE DU NOM DE LA PROCEDURE
  39. if(iimpi.eq.1756)write(6,*)'avant appel quetyp lmnnno ',lmnnom
  40. * if(iimpi.eq.1876) write(6,*) ' mapr appel quetyp'
  41. CALL QUETYP (CHAANC ,0,IRETOU)
  42. if(iimpi.eq.1756) write(6,*)'mapr retour quetyp',chaanc ,lmnnom
  43. IF(IRETOU.EQ.0) RETURN
  44. IF(IERR.NE.0) RETURN
  45. IF(CHAANC.EQ.'ENTIER ') THEN
  46. CALL LIRENT ( II,1,IRETOU)
  47. ELSEIF(CHAANC.EQ.'FLOTTANT') THEN
  48. CALL LIRREE(XRET,1,IRETOU)
  49. ELSEIF(CHAANC.EQ.'MOT ') THEN
  50. * if(iimpi.eq.1876) write(6,*) ' mapr appel lircha'
  51. CALL LIRCHA(ICHA,1,IRETOU)
  52. ELSEIF(CHAANC.EQ.'LOGIQUE ') THEN
  53. CALL LIRLOG(LOGI,1,IRETOU)
  54. ELSE
  55. CALL LIROBJ(CHAANC,IRET,1,IRETOU)
  56. ENDIF
  57. CALL QUENOM ( CNOM)
  58. if(iimpi.eq.1756) write(6,*) ' mapr nom de la procedur' , CNOM
  59. IF(CNOM.EQ.' ') THEN
  60. CALL ERREUR(21 )
  61. RETURN
  62. ENDIF
  63. IF(IERR.NE.0) RETURN
  64. SEGINI MBLO1
  65. NVQTEM=20
  66. SEGINI ISSPOT
  67. MBLO1.ISPOTE=ISSPOT
  68. INOMP=CNOM
  69. * write(6,*) ' lmnnom avant nomobj' , lmnnom
  70. CALL NOMOBJ('PROCEDUR',INOMP,MBLO1)
  71. * write(6,*) ' lmnnom apres nomobj' , lmnnom
  72. moterr(1:8)=inomp
  73. IF(IIMPI.EQ.1754)WRITE(IOIMP,101) INOMP
  74. 101 FORMAT(' DANS MAPR NOM DE LA PROCEDURE ' ,A24)
  75. C IARG=0
  76. MBLO1.MARGUM=0
  77. NIS=0
  78. SEGINI ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5
  79. C LECTURE DES ARGUMENTS ET DE LEURS TYPE ON LES METS DANS NOMMM ET NTYP
  80. * ESSAI PV ON VERROUILLE LES TEXTES PENDANT LA LECTURE DES ARGUMENTS
  81. 1 CONTINUE
  82. ICHA=' '
  83. CALL QUETYP (CHAANC ,0,IRETOU)
  84. * WRITE(6,FMT='('' CHAANC APRES QUETYP '',A8)') CHAANC
  85. IF(IRETOU.EQ.0) GOTO 2
  86. IF(IERR.NE.0) RETURN
  87. IF(CHAANC.EQ.'ENTIER ') THEN
  88. CALL LIRENT ( II,1,IRETOU)
  89. ELSEIF(CHAANC.EQ.'FLOTTANT') THEN
  90. CALL LIRREE(XRET,1,IRETOU)
  91. ELSEIF(CHAANC.EQ.'MOT ') THEN
  92. CALL LIRCHA(ICHA,1,IRETOU)
  93. ELSEIF(CHAANC.EQ.'LOGIQUE ') THEN
  94. CALL LIRLOG(LOGI,1,IRETOU)
  95. ELSE
  96. CALL LIROBJ(CHAANC,IRET,1,IRETOU)
  97. ENDIF
  98. * WRITE(6,FMT='('' CHAANC AVANT QUENON '',A8)') CHAANC
  99. CALL QUENOM ( CNOM)
  100. DO 765 ILW=LONOM,1,-1
  101. IF(CNOM(ILW:ILW).NE.' ') GO TO 764
  102. 765 CONTINUE
  103. 764 LE=ILW
  104. CALL POSCHA(CNOM(1:LE),IPOSCH)
  105. 2 CONTINUE
  106. IF(IRETOU.NE.0) THEN
  107. NIS=NOMMM(/1)+1
  108. SEGADJ ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5
  109. NOMMM(NIS)=IPOSCH
  110. CALL LIRMOT(MAST,2,IAST,0)
  111. IF(IAST.NE.0) THEN
  112. CALL LIRCHA(ICHA,1,IRETOU)
  113. IF(IERR.NE.0) GO TO 1500
  114. NTYP(NIS)=ICHA
  115. NSSTYP(NIS)=' '
  116. ILSSTY(NIS)=0
  117. IF(IAST.EQ.1) THEN
  118. IOBLI(NIS)=1
  119. ELSE
  120. IOBLI(NIS)=0
  121. ENDIF
  122. * WRITE(6,FMT='('' ICHA TYPE DE L ARGUMENT '',A8)') ICHA
  123. IF(ICHA.EQ.'TABLE ') THEN
  124. CHAANC=' '
  125. CALL QUETYP(CHAANC,0,IRETOU)
  126. IF(CHAANC.NE.'MOT ') GO TO 1
  127. CALL LIRMOT(MAST,1,IAST,0)
  128. IF(IAST.EQ.0) GO TO 1
  129. ICHA=' '
  130. CALL LIRCHA(ICHA,1,IRETOU)
  131. * WRITE(6,FMT='('' ICHA TYPE DE LA TABLE '',A8)') ICHA
  132. IF(IERR.NE.0) GO TO 1500
  133. NSSTYP(NIS)=ICHA
  134. ILSSTY(NIS)=IRETOU
  135. ENDIF
  136. ELSE
  137. NTYP(NIS)=' '
  138. NSSTYP=' '
  139. IOBLI(NIS)=1
  140. ILSSTY(NIS)=0
  141. ENDIF
  142. GO TO 1
  143. ENDIF
  144. NARG=NOMMM(/1)
  145. * FIN VERROUILLAGE TEXTES
  146. C CREATION D'UN BLOC REPETE
  147. MTEM=MBLOC
  148. IF(MTXBL.NE.0) THEN
  149. MTXBLC=MTXBL
  150. SEGDES MTXBLC
  151. ENDIF
  152. ISSPOT=ISPOTE
  153. SEGDES ISSPOT
  154. SEGDES MBLOC
  155. MBLOC=MBLO1
  156. MBLSUP=MTEM
  157. lmnpre=lmnnom
  158. * write(6,*) ' entree dans mapr lmnnom',lmnnom
  159. MDEOBJ=LMNNOM+1
  160. NBNOMM=1200
  161. NINST=1200
  162. IPVINN=3000
  163. SEGINI MTXBLC
  164. MTXBL=MTXBLC
  165. MBLPRO=0
  166. MBFONC=1
  167. MBCOUR=0
  168. MBCONT=1
  169. C ECRITURE DES ARGUMENTS DANS LA PILE DES OBJETS POUR QUE
  170. C L'INTERPRETATION NE SOIT PAS DECALEE.
  171. IF(NARG.NE.0) THEN
  172. NN=LMNNOM
  173. N=NN+NARG +1
  174. IF(N.GT.INOOB1(/1) ) THEN
  175. N=N+50
  176. SEGADJ ITABOB,ITABOC,ITABOD
  177. ENDIF
  178. if(nbesc.ne.0) segact ipiloc
  179. DO 30 I=1,NARG
  180. LMNNOM=LMNNOM+1
  181. INOOB1(NN+I)=NOMMM(I)
  182. IOUEP2(NN+I)=0
  183. IF(IIMPI.EQ.1754) THEN
  184. IDEBCH=IPCHAR(NOMMM(I) )
  185. IFINCH= IPCHAR(NOMMM(I)+1)-1
  186. NAM = ICHARA( IDEBCH:IFINCH)
  187. * CALL NOMCHA (NAM,NAM)
  188. WRITE(IOIMP,6438) NAM,NTYP(I)
  189. 6438 FORMAT(' MAPR : ARGUMENT TYPE ',A24,2X,A8)
  190. ENDIF
  191. 30 CONTINUE
  192. * write(6,*) ' inomp avant aoppel nomobj' , inomp
  193. * ecriture du nom de la procedur
  194. c CALL NOMOBJ('PROCEDUR',INOMP,MBLO1)
  195. if (nbesc.ne.0) SEGDES,IPILOC
  196. ENDIF
  197. NN=LMNNOM
  198. N=NN+4
  199. IF(N.GT.INOOB1(/1) ) THEN
  200. N=N+50
  201. SEGADJ ITABOB,ITABOC,ITABOD
  202. ENDIF
  203. CALL NOMCHA('#1','#1')
  204. CALL NOMCHA('#2','#2')
  205. CALL NOMCHA('#3','#3')
  206. * on ecrit aussi le nom de la procedure pour pouvoir les quitter!
  207. * CALL nomobj('PROCEDUR',INOMP,MBLO1)
  208. IPTEM=0
  209. CALL NOUTRU
  210. LIRM(1)=-1
  211. C ON LIT TOUT JUSQU'AU MOT FINPROCEDURE ou FINMETHODE
  212. MTEMP=MBLOC
  213. nlev=20
  214. nsi=50
  215. segini iitra
  216. ilev=1
  217. 11 CONTINUE
  218. IF(IERR.NE.0) GO TO 1600
  219. CALL NOUTRU
  220. LECTAB=1
  221. CALL LIRMO3(MCLE,7,IRET,0,LIRM)
  222. * write(6,fmt='('' lecture repe fin finp'',i6)') iret
  223. LECTAB=0
  224. * IF (IRET.EQ.0) GOTO 11
  225. GOTO (21,22,23,23,24,25,26),IRET
  226. 21 CALL REPETE
  227. ilev=ilev+1
  228. if( ilev.gt.nlev) then
  229. nlev=nlev+20
  230. segadj iitra
  231. endif
  232. if(iimpi.eq.5) then
  233. write(6,*)'$$$$$$$$$$$$$$$ nouveau bloc de niveau ilev ' ,ilev
  234. endif
  235. C NE LIRE QU'UNE FOIS LA BOUCLE
  236. MBCONT=1
  237. GOTO 11
  238. 22 CONTINUE
  239. CALL QUETYP ( CHAANC,0,IRETI)
  240. IF(IRETI.EQ.0) GO TO 11
  241. CALL FIN
  242. if(iimpi.eq.5) then
  243. write(6,*)'$$$$$$$$$$$$$$$$ Fermeture du bloc de niveau ' , ilev
  244. endif
  245. if( ilevel(ilev).ne.0) then
  246. moterr(1:8)= inomp
  247. call erreur( 1022)
  248. return
  249. endif
  250. ilev=ilev - 1
  251. GOTO 11
  252. 24 Continue
  253. ilevel(ilev)=ilevel(ilev)+1
  254. if(ilevel(ilev).gt.nsi) then
  255. nsi=nsi+50
  256. segadj iitra
  257. endif
  258. if(iimpi.eq.5) then
  259. ip=ilevel(ilev)
  260. write(6,*) '$$$$$$$$$$$$$$$$$$ ouverture d un ',ip, ' ieme SI'
  261. endif
  262. go to 11
  263. 25 continue
  264. if( iimpi.eq.5) then
  265. ip=ilevel(ilev)
  266. write(6,*) '$$$$$$$$$$$$$$$ SINON du ',ip, 'ieme SI'
  267. endif
  268. if(ilevel(ilev).eq.0) then
  269. moterr(1:8)= inomp
  270. call erreur(1020)
  271. return
  272. endif
  273. if( isino(ilev,ilevel(ilev)).ne.0)then
  274. moterr(1:8)= inomp
  275. call erreur(1024)
  276. return
  277. endif
  278. isino(ilev,ilevel(ilev))=1
  279. go to 11
  280. 26 continue
  281. if(ilevel(ilev).le.0) then
  282. moterr(1:8)= inomp
  283. call erreur(1021)
  284. return
  285. endif
  286. if( iimpi.eq.5) then
  287. ip=ilevel(ilev)
  288. write(6,*) '$$$$$$$$$$$$$$$$ Fermeture du ',ip,' ieme SI'
  289. endif
  290. isino(ilev,ilevel(ilev))=0
  291. ilevel(ilev)=ilevel(ilev) - 1
  292. go to 11
  293. C
  294. C ON VIENT DE LIRE FINPROC
  295. C IL FAUT LIRE LES RESULTATS POUR STOCKER LEURS PLACES DANS LA PILE
  296. C OBJET
  297. C
  298. 23 CONTINUE
  299. if( ilev.ne.1. or . ilevel.(ilev).ne.0) then
  300. moterr(1:8)= inomp
  301. call erreur (1023)
  302. return
  303. endif
  304. segsup iitra
  305. * write(6,fmt='('' lecture finpro'')')
  306. IF (MBLOC.NE.MTEMP) THEN
  307. C
  308. C ON A OUBLIE DE FERMER UN BLOC
  309. C
  310. MBLOC =MTEMP
  311. SEGACT,MBLO1
  312. MOTERR=MBLO1.NCONBO
  313. SEGDES,MBLO1
  314. CALL ERREUR(154)
  315. SEGACT MBLOC*MOD
  316. MTEM =MBLSUP
  317. MTXBLC=MTXBL
  318. SEGDES MTXBLC
  319. ISSPOT=ISPOTE
  320. SEGDES ISSPOT
  321. SEGDES MBLOC
  322. MBLOC=MTEM
  323. SEGACT MBLOC*MOD
  324. ISSPOT=ISPOTE
  325. SEGACT ISSPOT*MOD
  326. MTXBLC=MTXBL
  327. IF(MTXBL.NE.0) SEGACT MTXBLC
  328. CALL NOMOBJ('ANNULE',INOMP,MBLOC)
  329. RETURN
  330. ENDIF
  331. IPTEM=0
  332. CALL NOUTRU
  333. SEGINI IARGUM
  334. MARGUM=IARGUM
  335. MTXMET=IRZTC
  336. * write(6,*) ' mappr mtxmet ', irztc
  337. IF(IIMPI.EQ.1754) WRITE(6,5911) IARGUM,NARG
  338. 5911 FORMAT(' MAPR : IARGUM NARG ',3I5)
  339. IF(NARG.NE.0) THEN
  340. DO 43 I=1,NARG
  341. ILTYPA(I)=ILSSTY(I)
  342. IOBLIG(I)=IOBLI(I)
  343. 43 CONTINUE
  344. DO 41 I=1,NARG
  345. MTYARG(I)=NTYP(I)
  346. MSTYPA(I)=NSSTYP(I)
  347. 41 CONTINUE
  348. ENDIF
  349. SEGSUP ISEGP1,ISEGP2,ISEGP3,ISEGP4,ISEGP5
  350. C MRESU=MBLOC
  351. C
  352. C ON FERME LE BLOC REPETE on ajuste mtxblc
  353. C
  354. MFIOBJ=LMNNOM
  355. JDEOBJ=MDEOBJ
  356. msapii=mdeobj
  357. MTEM=MBLSUP
  358. MTXBLC=MTXBL
  359. NINST=NINSTV+1
  360. IPVINN=MTXBA(NINST)
  361. NBNOMM=LMTXBM(NINST)
  362. IF(IIMPI.EQ.1756) WRITE(IOIMP,1788)NINST,IPVINN,NBNOMM
  363. 1788 FORMAT(' apres ajustement NINST IPVINN NBNOMM',3I8)
  364. SEGADJ MTXBLC
  365. SEGDES MTXBLC
  366. ISSPOT=ISPOTE
  367. SEGDES ISSPOT
  368. SEGDES MBLOC
  369. MBLOC=MTEM
  370. SEGACT MBLOC*MOD
  371. ISSPOT=ISPOTE
  372. SEGACT ISSPOT*MOD
  373. MTXBLC=MTXBL
  374. IF(MTXBL.NE.0) SEGACT MTXBLC
  375.  
  376. C
  377. C ON SAUVE LA VALEUR DES FLOTTANTS
  378. C
  379. NREE = 0
  380. DO 33 I=JDEOBJ,LMNNOM
  381. IF(INOOB2(I).EQ.'FLOTTANT') NREE = NREE + 1
  382. 33 CONTINUE
  383. MTXFLO=0
  384. IF(NREE.NE.0) THEN
  385. SEGINI MTXFL3
  386. MTXFLO=MTXFL3
  387. NREE=0
  388. if(nbesc.ne.0) segact ipiloc
  389. DO 34 I=JDEOBJ,LMNNOM
  390. IF(INOOB2(I).EQ.'FLOTTANT') THEN
  391. NREE = NREE + 1
  392. XTFLO(NREE)= XIFLOT(IOUEP2(I))
  393. MITFLO(NREE)=I-jdeobj+1
  394. ENDIF
  395. 34 CONTINUE
  396. if(nbesc.ne.0) SEGDES,IPILOC
  397. SEGDES MTXFL3
  398. ENDIF
  399. C
  400. C
  401. C ** EFFACEMENT DES NOMS D'OBJET DANS LA TABLE
  402. C
  403. NIIS=LMNNOM-JDEOBJ+1
  404. NIS = NIIS
  405. SEGINI MTXBI3
  406. MTXBB=MTXBI3
  407. SEGDES IARGUM
  408. if(nbesc.ne.0) segact ipiloc
  409. DO 32 I=JDEOBJ,LMNNOM
  410. MTXBI(I-JDEOBJ+1)=INOOB1(I)
  411. mtxbd(i-JDEOBJ+1)=inoob2(i)
  412. mtxbe(i-JDEOBJ+1)=iouep2(i)
  413. C IPP= INOOB1(I)
  414. IDEBCH=IPCHAR(INOOB1(I))
  415. *tc IF(ICHARA(IDEBCH:IDEBCH).EQ.'&'.AND.INOOB2(I).EQ.'ENTIER ')
  416. *tc 1 INOOB2(I)=' '
  417. INOOB1(I)=0
  418. inoob2(i)=' '
  419. iouep2(i)=-10000
  420. 32 CONTINUE
  421. if(nbesc.ne.0) SEGDES,IPILOC
  422. SEGDES MTXBI3
  423. SEGDES IARGUM
  424. lmnnom=lmnpre
  425.  
  426. RETURN
  427. C
  428. C ERREUR DETECTE APRES INITIALISATION DU BLOC,ON FERME TOUS LES BLOCS
  429. C JUSQU'A CELUI DE LA PROCEDURE
  430. 1600 CONTINUE
  431. IDER = MARGUM
  432. MTEM=MBLSUP
  433. MTXBLC=MTXBL
  434. SEGDES MTXBLC
  435. ISSPOT=ISPOTE
  436. SEGDES ISSPOT
  437. SEGDES MBLOC
  438. MBLOC=MTEM
  439. SEGACT MBLOC*MOD
  440. ISSPOT=ISPOTE
  441. SEGACT ISSPOT*MOD
  442. MTXBLC=MTXBL
  443. IF(MTXBL.NE.0) SEGACT MTXBLC
  444. IF(IDER.EQ.0) GO TO 1500
  445. IARGUM=IDER
  446. SEGDES IARGUM
  447. lmnnom=lmnpre
  448. 1500 CONTINUE
  449. C
  450. C ON A TROUVE UNE ERREUR AVANT D'OUVRIR LE BLOC
  451. C
  452. CALL NOMOBJ('ANNULE',INOMP,MBLO1)
  453. END
  454.  
  455.  
  456.  
  457.  
  458.  
  459.  

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