Télécharger mapr.eso

Retour à la liste

Numérotation des lignes :

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

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