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

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