Télécharger mapr.eso

Retour à la liste

Numérotation des lignes :

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

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