Télécharger proced.eso

Retour à la liste

Numérotation des lignes :

  1. C PROCED SOURCE CB215821 19/11/15 21:15:58 10378
  2. SUBROUTINE PROCED
  3.  
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6.  
  7. -INC CCOPTIO
  8. -INC SMBLOC
  9. -INC CCNOYAU
  10. -INC CCREDLE
  11. -INC SMTABLE
  12. -INC CCASSIS
  13. -INC TMCOLAC
  14. -INC CCPERF
  15.  
  16. SEGMENT IVAL(2*NARG)
  17. SEGMENT MTYYYB
  18. CHARACTER*(8) MTYYYA(NARG)
  19. ENDSEGMENT
  20. SEGMENT ITITE3
  21. INTEGER ITITEN(NIS), IOU(NIS)
  22. CHARACTER*(8) ITITEM(NIS)
  23. ENDSEGMENT
  24.  
  25. INTEGER ITTIME(4)
  26.  
  27. CHARACTER*8 MCOTA,TYPOBJ,CHARRE
  28. CHARACTER*(LONOM) cnompr
  29. CHARACTER*4 CHA4
  30. CHARACTER*72 MTYTA
  31. REAL*8 XRE
  32. LOGICAL LOGI,LOGR1,lodes0
  33. CHARACTER*4 MDEB(2),CHA1
  34. INTEGER CRET
  35. DATA MDEB/'DEBP','DEBM'/
  36.  
  37. sredle=iredle
  38. * write(6,*) ' entreee dans proced lmnnom ' , lmnnom
  39. * if(iimpi.eq.1876) write(6,*) ' proced avant appel dune proc'
  40. CALL LIROBJ('PROCEDUR',IARGO,1,IRETOU)
  41. IARGUM= IPIPR1(IARGO)
  42.  
  43. * if(iimpi.eq.1754) then
  44. call quenom(cnompr)
  45. * write(6,*) ' nom de la procedure ' , cnompr,IARGO
  46. * endif
  47.  
  48.  
  49. C DEBUT Duree passee dans les procedures (Voir FINPRO pour la sortie)
  50. call timespv(ittime,oothrd)
  51. IELAPS=ITTIME(1) + ITTIME(2)
  52. ICPU =ITTIME(3) + ITTIME(4)
  53.  
  54. C Initialisation eventuelle des Duree passee dans les procedures
  55. IF(ITPSPR .EQ. 0)THEN
  56. NBBLOC=1
  57. NIVMAX=10
  58. SEGINI,ITPSBL
  59. C Mise dans le COMMON SMPERF
  60. ITPSPR=ITPSBL
  61. C Protection du MENAGE
  62. CALL SAVSEG(ITPSBL)
  63. NICOU =1
  64. ITPSBL.CDPROC(NBBLOC) = cnompr
  65. II =1
  66.  
  67. ELSE
  68. ITPSBL = ITPSPR
  69. SEGACT,ITPSBL*MOD
  70. NICOU =ITPSBL.NIVCOU
  71.  
  72. IF(NICOU .GT. 0)THEN
  73. C Incremente la duree de la procedure qu'on va quitter
  74. II=ITPSBL.IPRONI(NICOU)
  75. ITPSBL.DURPRO(1,II)=ITPSBL.DURPRO(1,II) +
  76. & (IELAPS - ITPSBL.TPSPRO(1,II))
  77. ITPSBL.DURPRO(2,II)=ITPSBL.DURPRO(2,II) +
  78. & (ICPU - ITPSBL.TPSPRO(2,II))
  79. ENDIF
  80.  
  81. NICOU =NICOU + 1
  82. NBBLOC=ITPSBL.NBAPRO(/1)
  83. DO II=1,NBBLOC
  84. IF(cnompr .EQ. ITPSBL.CDPROC(II)) GOTO 11
  85. ENDDO
  86. C Ajout de la procedure
  87. NBBLOC = NBBLOC + 1
  88. NIVMAX = ITPSBL.IPRONI(/1)
  89. SEGADJ,ITPSBL
  90. ITPSBL.CDPROC(NBBLOC) = cnompr
  91. II = NBBLOC
  92.  
  93. 11 CONTINUE
  94. IF(NICOU .GT. NIVMAX)THEN
  95. NIVMAX=NICOU * 2 + 10
  96. SEGADJ,ITPSBL
  97. ENDIF
  98. ENDIF
  99.  
  100. ITPSBL.NIVCOU = NICOU
  101. ITPSBL.IPRONI(NICOU)= II
  102. ITPSBL.TPSPRO(1,II) = IELAPS
  103. ITPSBL.TPSPRO(2,II) = ICPU
  104. ITPSBL.NBAPRO(II) = ITPSBL.NBAPRO(II) + 1
  105. C FIN Duree passee dans les procedures
  106.  
  107. MBLO1=IARGUM
  108. IF(IERR.NE.0) RETURN
  109. IF(IIMPI.EQ.1754) WRITE(IOIMP,965) IARGUM
  110. 965 FORMAT(' DANS PROCED VALEUR DE IARGUM ',I8)
  111. * LA FIN DU IF EST MISE EN COMMENTAIRE
  112. IF(IARGUM.LT.0) THEN
  113. CALL PROCPO(-IARGUM,CRET)
  114. IF(CRET .NE. 9999 ) CALL ERREUR(5)
  115. IF (IERR.NE.0) RETURN
  116. IOLEC=-IOLEC
  117. IECHA=IECHO
  118. IECHO=max( 0,iecho - 1)
  119. C SAUVETAGE DU TYPE DES OBJETS TEMPORAIRE
  120. ITITE=0
  121. IF(IPTEM.NE.0) THEN
  122. ITITE=1
  123. MOT(1:8)='#'
  124. IRE=3
  125. NIS=IPTEM
  126. SEGINI ITITE3
  127. DO 112 I=1,IPTEM
  128. IF(I.LT.10)THEN
  129. WRITE(MOT(2:2),FMT='(I1)')I
  130. NCAR=2
  131. ELSE
  132. WRITE(MOT(2:3),FMT='(I2)')I
  133. NCAR=3
  134. ENDIF
  135. IAVA=0
  136. CALL PRENOM(IPLAMO,IAVA,sredle)
  137. ITITEN(I)=IPLAMO
  138. ITITEM(I)=INOOB2(IPLAMO)
  139. IOU(I)=IOUEP2(IPLAMO)
  140. 112 CONTINUE
  141. ENDIF
  142. C FIN DU SAUVETAGE
  143. CALL PROCSA
  144. IPTEM=0
  145. MBFONC=1
  146. MSABL=MBLSUP
  147. MBLSUP=0
  148. C IRZTC=0
  149. * If(iimpi.eq.1876) write(6,*) ' proced avant appel lirmot'
  150. CALL LIRMOT(MDEB,2,IRET,1)
  151. * If(iimpi.eq.1876)write(6,*)' proced apres lirmot iret',iret
  152. IF(IERR.NE.0) RETURN
  153. MBLSUP=MSABL
  154. CHA4=LOCERR(1:4)
  155. LOCERR(1:4)=MDEB(IRET)
  156. * write(6,*) ' appel mapr lmnnom ', lmnnom
  157. CALL MAPR(IRET)
  158. * write(6,*) ' sorteri mapr lmnnom', lmnnom
  159. LOCERR(1:4)=CHA4
  160. IF(IERR.NE.0) RETURN
  161. C
  162. C *** ON REMET LES TYPES DES OBJETS TEMPORAIRES
  163. C
  164. * write(6,*) ' iouep2(/1) ',iouep2(/1)
  165. IF(ITITE.NE.0) THEN
  166. DO 113 I=1,ITITEN(/1)
  167. IPLAMO=ITITEN(I)
  168. * write(6,*) ' iplamo ' , iplamo
  169. INOOB2(IPLAMO)=ITITEM(I)
  170. IOUEP2(IPLAMO)=IOU(I)
  171. 113 CONTINUE
  172. SEGSUP ITITE3
  173. ENDIF
  174. IECHO=IECHA
  175. IOLEC=ABS(IOLEC)
  176. MBLO1=IPIPR1(IARGO)
  177. CALL PROCRE
  178. ENDIF
  179. * FIN DU IF ICI ICI ICI ICI ICI
  180. C ON ACTIVE LE SEGMENT DONNANT LES ARGUMENTS ,
  181. * write(6,*) ' lmnnom ' , lmnnom
  182. SEGACT MBLO1
  183. * write(6,*) ' mdeobj mfiobj lmnnom ' , mblo1.mdeobj,
  184. * $ mblo1.mfiobj,lmnnom
  185. IARGUM=MBLO1.MARGUM
  186. SEGACT IARGUM
  187. * write(6,*)'ent proced lmnnom mdeobj mfiobj',lmnnom,mdeobj,mfiobj
  188. C ON LIT LES ARGUMENTS ON SAUVE LEURS VALEURS DANS IVAL
  189. NARG= MTYARG(/2)
  190. IOPRME=MTXMET
  191. IF(IIMPI.EQ.1754) WRITE(6,4834) IARGUM,NARG
  192. 4834 FORMAT(' PROCED : IARGUM NARG',2I5)
  193. IF(IOPRME.EQ.2) THEN
  194. C on est en presence d'une methode, il faut lire l'objet sur lequel elle
  195. C s'applique
  196. CALL LIROBJ('OBJET ', IRETCO,1,IRETOU)
  197. IF(IERR.NE.0) RETURN
  198. ENDIF
  199. IF(NARG.NE.0) THEN
  200. SEGINI IVAL ,MTYYYB
  201. DO 1 I =1,NARG
  202. II = 2 * I - 1
  203. MCOTA=MTYARG(I)
  204. MTYYYA(I)= MCOTA
  205. ICOND=IOBLIG(I)
  206.  
  207. IF(MCOTA.EQ.'FLOTTANT') THEN
  208. CALL LIRREE(XRE,ICOND,IRETOU)
  209. C CB215821 : Les arguments de type FLOTTANTS facultatifs non fournis sont NAN !!!
  210. IF(IRETOU .NE. 0) THEN
  211. CALL QUERAN(IRAT,MCOTA,IRET,XRE,CHA1,LOGI,IOB)
  212. ENDIF
  213.  
  214. ELSEIF(MCOTA.EQ.'TABLE ')THEN
  215. IFICHA=ILTYPA(I)
  216. IF(IFICHA.NE.0) THEN
  217. MTYTA= MSTYPA(I)
  218. CALL LIRTAB( MTYTA(1:IFICHA),IRAT,ICOND,IRETOU)
  219. ELSE
  220. CALL LIROBJ('TABLE ',IRAT,ICOND,IRETOU)
  221. ENDIF
  222.  
  223. ELSE
  224. CALL LIRTAB('ESCLAVE',IRAT,0,IRETOU)
  225. IF (IRETOU .EQ. 1)THEN
  226. C On a lu une TABLE 'ESCLAVE', vérification que le TYPE de l'OBJET est bon
  227.  
  228. MTABLE=IRAT
  229. IND=1
  230. TYPOBJ=' '
  231. lodes0 = lodesl
  232. lodesl = .FALSE.
  233. CALL ACCTAB(MTABLE,'ENTIER',IND ,0.D0 ,' ',.TRUE.,0,
  234. & TYPOBJ,IVALRE,XVALRE,CHARRE,LOGR1 ,ID1)
  235. IF (IERR.NE.0) RETURN
  236. lodesl=lodes0
  237.  
  238. C Il faut que le type corresponde au type de l''objet initialement demande
  239. IF(TYPOBJ .EQ. MCOTA)THEN
  240. MTYYYA(I)= 'TABLE '
  241. ELSE
  242. MOTERR(1:8 )=MCOTA
  243. MOTERR(9:16)=TYPOBJ
  244. CALL ERREUR(1045)
  245. RETURN
  246. ENDIF
  247.  
  248. ELSE
  249. C On lit un objet normalement
  250. CALL LIRABJ(MCOTA,IRAT,ICOND,IRETOU)
  251. MTYYYA(I)= MCOTA
  252. ENDIF
  253. ENDIF
  254.  
  255. IF(IERR.NE.0) THEN
  256. SEGDES MBLO1,IARGUM
  257. RETURN
  258. ENDIF
  259. IF(IRETOU.EQ.0) THEN
  260. IVAL(II)=0
  261. ELSE
  262. IVAL(II)=1
  263. IVAL(II+1)=IRAT
  264. ENDIF
  265. IF(IIMPI.EQ.1754) THEN
  266. WRITE(IOIMP,FMT='('' ARGUMENT TYPE EXIS POINTEUR'',A8,2I6)')
  267. $ MTYARG(I),IVAL(II)
  268. ENDIF
  269. 1 CONTINUE
  270. ENDIF
  271.  
  272. MTXBI3 = MTXBB
  273. MTXFL3 = MTXFLO
  274. C ON ECRIT LES ARGUMENTS DANS LA PILE DES OBJETS
  275. C AU PREALABLE SAUVETAGE LECTURE ET ACTIVATION DU BLOC
  276. CALL PROCSA
  277. MTEM =MBLOC
  278. MTXBLC=MTXBL
  279. IF(MTXBL.NE.0) SEGDES MTXBLC
  280. ISSPOT=ISPOTE
  281. SEGDES ISSPOT
  282. SEGDES MBLOC
  283. SEGINI,MBLOC=MBLO1
  284. lmnlon=mfiobj-mdeobj
  285. mdeobj=lmnnom+1
  286. mfiobj=mdeobj+lmnlon
  287. * write(6,*)'sor proced lmnlon mdeobj mfiobj',lmnnom,mdeobj,mfiobj
  288. lmnnom=mfiobj
  289. n=iouep2(/1)
  290. if( n.lt.lmnnom) then
  291. n=lmnnom+100
  292. segadj,itabob,itaboc,itabod
  293. endif
  294. ISSPOT=ISPOTE
  295. SEGDES ISSPOT
  296. NVQTEM=20
  297. SEGINI ISSPOT
  298. ISPOTE=ISSPOT
  299. SEGDES MBLO1
  300. MBLSUP=MTEM
  301. MBLPRO=MBLO1
  302. MTXBLC=MTXBL
  303. C Le nom du compteur de boucle (&BOUCLE) est utilise pour le nom de la procedure
  304. NCONBO=cnompr
  305.  
  306. IF(IOPRME.EQ.2) THEN
  307. MOBJCO=IRETCO
  308. ENDIF
  309. IF(MTXBL.NE.0) SEGACT MTXBLC
  310. MBFONC=0
  311. MBCOUR=0
  312. C IPSI =0
  313. MBERR =0
  314. MBCONT=1
  315. C
  316. C **** ON MET DE COTE LA VALEUR DE LA PILE AFFECTEE A LA PROCEDURE
  317. C EN VUE DU RECURSIF
  318. * NBMOT= MFIOBJ-MDEOBJ+1
  319. * SEGINI MSAPI3
  320. * MSAPII=MSAPI3
  321. * DO 252 J=1,NBMOT
  322. * MSAPIJ(J)=INOOB1(MDEOBJ-1+J)
  323. * MSAPIL(J)=INOOB2(MDEOBJ-1+J)
  324. * MSAPIN(J)=IOUEP2(MDEOBJ-1+J)
  325. * 252 CONTINUE
  326. * SEGDES MSAPI3
  327. C REMISE DES NOMS DES OBJETS DE LA PROCEDURE ET DE LEUR TYPES
  328. SEGACT MTXBI3
  329. J=0
  330. C JLO=MTXBI(/1)
  331. * write(6,*) ' proced remise en etat de inoob1 mdeobj' , mdeobj
  332. DO 154 I=MDEOBJ,MFIOBJ
  333. J= J + 1
  334. INOOB1(I)=MTXBI(J)
  335. inoob2(i)=mtxbd(j)
  336. IOUEP2(i)=mtxbe(j)
  337. * write(6,*) ' i, inoob ' , i , inoob1(i),inoob2(i),iouep2(i)
  338. 154 CONTINUE
  339. C REMISE DES VALEURS DES FLOTTANTS
  340. IF( MTXFLO.NE.0) THEN
  341. SEGACT MTXFL3
  342. NREE = MITFLO(/1)
  343. IF ( NREE . NE . 0) THEN
  344. CALL POSCHA('##BID##',IPOSCH)
  345. DO 155 I=1,NREE
  346. NOMBID=INOOB1(MITFLO(I)+mdeobj-1)
  347. INOOB1(MITFLO(I)+mdeobj-1)=IPOSCH
  348. XRE = XTFLO(I)
  349. CALL NOMREE ('##BID##',XRE)
  350. INOOB1(MITFLO(I)+mdeobj-1)=NOMBID
  351. 155 CONTINUE
  352. ENDIF
  353. SEGDES MTXFL3
  354. ENDIF
  355. C INITIALISATION DES VARIABLES EN FONCTION DES OBJETS EXTERNES
  356. * write(6,*) ' proced appel inipro'
  357. CALL INIPRO(cnompr,mblo1)
  358. * write(6,*) ' proced sortie inipro'
  359. SEGDES MTXBI3
  360.  
  361. C RECOPIE DES ARGUMENTS DANS LA PILE
  362. IARGUM=MARGUM
  363. SEGACT IARGUM
  364. IF(NARG.NE.0) THEN
  365. DO 2 I =1,NARG
  366. II=2*I-1
  367. I5=I-1+MDEOBJ
  368. INOOB2(I5)=MTYYYA(I)
  369. IOUEP2(I5)=IVAL(II+1)
  370. IF(IVAL(II).EQ.0) THEN
  371. INOOB2(I5)='ANNULE '
  372. ENDIF
  373. 2 CONTINUE
  374. SEGSUP IVAL ,MTYYYB
  375. ENDIF
  376. SEGDES IARGUM
  377. END
  378.  
  379.  
  380.  
  381.  
  382.  
  383.  

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