Télécharger proced.eso

Retour à la liste

Numérotation des lignes :

  1. C PROCED SOURCE CB215821 16/10/26 21:15:01 9138
  2. SUBROUTINE PROCED
  3. IMPLICIT INTEGER(I-N)
  4. -INC CCOPTIO
  5. -INC SMBLOC
  6. -INC CCNOYAU
  7. -INC CCREDLE
  8. -INC SMTABLE
  9. -INC CCASSIS
  10.  
  11. SEGMENT IVAL(2*NARG)
  12. SEGMENT MTYYYB
  13. CHARACTER*(8) MTYYYA(NARG)
  14. ENDSEGMENT
  15. SEGMENT ITITE3
  16. INTEGER ITITEN(NIS), IOU(NIS)
  17. CHARACTER*(8) ITITEM(NIS)
  18. ENDSEGMENT
  19. CHARACTER*8 MCOTA,cnompr,TYPOBJ,CHARRE
  20. CHARACTER*72 MTYTA
  21. REAL*8 XRE
  22. LOGICAL LOGI,LOGR1,lodes0
  23. CHARACTER*4 MDEB(2),CRET,CHA1
  24. DATA MDEB/'DEBP','DEBM'/
  25.  
  26. sredle=iredle
  27. * write(6,*) ' entreee dans proced lmnnom ' , lmnnom
  28. * if(iimpi.eq.1876) write(6,*) ' proced avant appel dune proc'
  29. CALL LIROBJ('PROCEDUR',IARGO,1,IRETOU)
  30. IARGUM= IPIPR1(IARGO)
  31. * if(iimpi.eq.1754) then
  32. call quenom(cnompr)
  33. * write(6,*) ' nom de la procedure ' , cnompr
  34. * endif
  35. MBLO1=IARGUM
  36. IF(IERR.NE.0) RETURN
  37. IF(IIMPI.EQ.1754) WRITE(IOIMP,965) IARGUM
  38. 965 FORMAT(' DANS PROCED VALEUR DE IARGUM ',I8)
  39. * LA FIN DU IF EST MISE EN COOMENTAIRE
  40. IF(IARGUM.LT.0) THEN
  41. CALL PROCPO(-IARGUM,CRET)
  42. IF(CRET.NE.'9999') CALL ERREUR(5)
  43. IF (IERR.NE.0) RETURN
  44. IOLEC=-IOLEC
  45. IECHA=IECHO
  46. IECHO=max( 0,iecho - 1)
  47. C SAUVETAGE DU TYPE DES OBJETS TEMPORAIRE
  48. ITITE=0
  49. IF(IPTEM.NE.0) THEN
  50. ITITE=1
  51. MOT(1:8)='#'
  52. IRE=3
  53. NIS=IPTEM
  54. SEGINI ITITE3
  55. DO 112 I=1,IPTEM
  56. IF(I.LT.10)THEN
  57. WRITE(MOT(2:2),FMT='(I1)')I
  58. NCAR=2
  59. ELSE
  60. WRITE(MOT(2:3),FMT='(I2)')I
  61. NCAR=3
  62. ENDIF
  63. IAVA=0
  64. CALL PRENOM(IPLAMO,IAVA,sredle)
  65. ITITEN(I)=IPLAMO
  66. ITITEM(I)=INOOB2(IPLAMO)
  67. IOU(I)=IOUEP2(IPLAMO)
  68. 112 CONTINUE
  69. ENDIF
  70. C FIN DU SAUVETAGE
  71. CALL PROCSA
  72. MBFONC=1
  73. MSABL=MBLSUP
  74. MBLSUP=0
  75. IRZTC=0
  76. * If(iimpi.eq.1876) write(6,*) ' proced avant appel lirmot'
  77. CALL LIRMOT(MDEB,2,IRET,1)
  78. * If(iimpi.eq.1876)write(6,*)' proced apres lirmot iret',iret
  79. IF(IERR.NE.0) RETURN
  80. MBLSUP=MSABL
  81. CRET=LOCERR(1:4)
  82. LOCERR(1:4)=MDEB(IRET)
  83. * write(6,*) ' appel mapr lmnnom ', lmnnom
  84. CALL MAPR(IRET)
  85. * write(6,*) ' sorteri mapr lmnnom', lmnnom
  86. LOCERR(1:4)=CRET
  87. IF(IERR.NE.0) RETURN
  88. C
  89. C *** ON REMET LES TYPES DES OBJETS TEMPORAIRES
  90. C
  91. * write(6,*) ' iouep2(/1) ',iouep2(/1)
  92. IF(ITITE.NE.0) THEN
  93. DO 113 I=1,ITITEN(/1)
  94. IPLAMO=ITITEN(I)
  95. * write(6,*) ' iplamo ' , iplamo
  96. INOOB2(IPLAMO)=ITITEM(I)
  97. IOUEP2(IPLAMO)=IOU(I)
  98. 113 CONTINUE
  99. SEGSUP ITITE3
  100. ENDIF
  101. IECHO=IECHA
  102. IOLEC=ABS(IOLEC)
  103. MBLO1=IPIPR1(IARGO)
  104. CALL PROCRE
  105. ENDIF
  106. * FIN DU IF ICI ICI ICI ICI ICI
  107. C ON ACTIVE LE SEGMENT DONNANT LES ARGUMENTS ,
  108. * write(6,*) ' lmnnom ' , lmnnom
  109. SEGACT MBLO1
  110. * write(6,*) ' mdeobj mfiobj lmnnom ' , mblo1.mdeobj,
  111. * $ mblo1.mfiobj,lmnnom
  112. IARGUM=MBLO1.MARGUM
  113. SEGACT IARGUM
  114. * write(6,*)'ent proced lmnnom mdeobj mfiobj',lmnnom,mdeobj,mfiobj
  115. C ON LIT LES ARGUMENTS ON SAUVE LEURS VALEURS DANS IVAL
  116. NARG= MTYARG(/2)
  117. IOPRME=MTXMET
  118. IF(IIMPI.EQ.1754) WRITE(6,4834) IARGUM,NARG
  119. 4834 FORMAT(' PROCED : IARGUM NARG',2I5)
  120. IF(IOPRME.EQ.2) THEN
  121. C on est en presence d'une methodeil faut lire lobjet su lequel elle
  122. C s'applique
  123. CALL LIROBJ('OBJET ', IRETCO,1,IRETOU)
  124. IF(IERR.NE.0) RETURN
  125. ENDIF
  126. IF(NARG.NE.0) THEN
  127. SEGINI IVAL ,MTYYYB
  128. DO 1 I =1,NARG
  129. II = 2 * I - 1
  130. MCOTA=MTYARG(I)
  131. MTYYYA(I)= MCOTA
  132. ICOND=IOBLIG(I)
  133.  
  134. IF(MCOTA.EQ.'FLOTTANT') THEN
  135. CALL LIRREE(XRE,ICOND,IRETOU)
  136. CALL QUERAN(IRAT,MCOTA,IRET,XRE,CHA1,LOGI,IOB)
  137.  
  138. ELSEIF(MCOTA.EQ.'TABLE ')THEN
  139. IFICHA=ILTYPA(I)
  140. IF(IFICHA.NE.0) THEN
  141. MTYTA= MSTYPA(I)
  142. CALL LIRTAB( MTYTA(1:IFICHA),IRAT,ICOND,IRETOU)
  143. ELSE
  144. CALL LIROBJ('TABLE ',IRAT,ICOND,IRETOU)
  145. ENDIF
  146.  
  147. ELSE
  148. CALL LIRTAB('ESCLAVE',IRAT,0,IRETOU)
  149. IF (IRETOU .EQ. 1)THEN
  150. C On a lu une TABLE 'ESCLAVE', vérification que le TYPE de l'OBJET est bon
  151.  
  152. MTABLE=IRAT
  153. IND=1
  154. TYPOBJ=' '
  155. lodes0 = lodesl;
  156. lodesl = .FALSE. ;
  157. CALL ACCTAB(MTABLE,'ENTIER',IND ,0.D0 ,' ',.TRUE.,0,
  158. & TYPOBJ,IVALRE,XVALRE,CHARRE,LOGR1 ,ID1)
  159. IF (IERR.NE.0) RETURN
  160. lodesl=lodes0
  161.  
  162. C Il faut que le type corresponde au type de l''objet initialement demande
  163. IF(TYPOBJ .EQ. MCOTA)THEN
  164. MTYYYA(I)= 'TABLE '
  165. ELSE
  166. MOTERR(1:8 )=MCOTA
  167. MOTERR(9:16)=TYPOBJ
  168. CALL ERREUR(1045)
  169. RETURN
  170. ENDIF
  171.  
  172. ELSE
  173. C On lit un objet normalement
  174. CALL LIRABJ(MCOTA,IRAT,ICOND,IRETOU)
  175. MTYYYA(I)= MCOTA
  176. ENDIF
  177. ENDIF
  178.  
  179. IF(IERR.NE.0) THEN
  180. SEGDES MBLO1,IARGUM
  181. RETURN
  182. ENDIF
  183. IF(IRETOU.EQ.0) THEN
  184. IVAL(II)=0
  185. ELSE
  186. IVAL(II)=1
  187. IVAL(II+1)=IRAT
  188. ENDIF
  189. IF(IIMPI.EQ.1754) THEN
  190. WRITE(IOIMP,FMT='('' ARGUMENT TYPE EXIS POINTEUR'',A8,2I6)')
  191. $ MTYARG(I),IVAL(II)
  192. ENDIF
  193. 1 CONTINUE
  194. ENDIF
  195.  
  196. MTXBI3=MTXBB
  197. MTXFL3 = MTXFLO
  198. C ON ECRIT LES ARGUMENTS DANS LA PILE DES OBJETS
  199. C AUPREALABLE SAUVETAGE LECTURE ET ACTIVATION DU BLOC
  200. CALL PROCSA
  201. MTEM=MBLOC
  202. MTXBLC=MTXBL
  203. IF(MTXBL.NE.0) SEGDES MTXBLC
  204. ISSPOT=ISPOTE
  205. SEGDES ISSPOT
  206. SEGDES MBLOC
  207. SEGINI,MBLOC=MBLO1
  208. lmnlon=mfiobj-mdeobj
  209. mdeobj=lmnnom+1
  210. mfiobj=mdeobj+lmnlon
  211. * write(6,*)'sor proced lmnlon mdeobj mfiobj',lmnnom,mdeobj,mfiobj
  212. lmnnom=mfiobj
  213. n=iouep2(/1)
  214. if( n.lt.lmnnom) then
  215. n=lmnnom+100
  216. segadj,itabob,itaboc,itabod
  217. endif
  218. ISSPOT=ISPOTE
  219. SEGDES ISSPOT
  220. NVQTEM=20
  221. SEGINI ISSPOT
  222. ISPOTE=ISSPOT
  223. SEGDES MBLO1
  224. MBLSUP=MTEM
  225. MBLPRO=MBLO1
  226. MTXBLC=MTXBL
  227.  
  228. IF(IOPRME.EQ.2) THEN
  229. MOBJCO=IRETCO
  230. ENDIF
  231. IF(MTXBL.NE.0) SEGACT MTXBLC
  232. MBFONC=0
  233. MBCOUR=0
  234. IPSI=0
  235. MBERR=0
  236. MBCONT=1
  237. C
  238. C **** ON MET DE COTE LA VALEUR DE LA PILE AFFECTEE A LA PROCEDURE
  239. C EN VUE DU RECURSIF
  240. NBMOT= MFIOBJ-MDEOBJ+1
  241. * SEGINI MSAPI3
  242. * MSAPII=MSAPI3
  243. * DO 252 J=1,NBMOT
  244. * MSAPIJ(J)=INOOB1(MDEOBJ-1+J)
  245. * MSAPIL(J)=INOOB2(MDEOBJ-1+J)
  246. * MSAPIN(J)=IOUEP2(MDEOBJ-1+J)
  247. * 252 CONTINUE
  248. * SEGDES MSAPI3
  249. C REMISE DES NOMS DES OBJETS DE LA PROCEDURE ET DE LEUR TYPES
  250. SEGACT MTXBI3
  251. J=0
  252. JLO=MTXBI(/1)
  253. * write(6,*) ' proced remise en etat de inoob1 mdeobj' , mdeobj
  254. DO 154 I=MDEOBJ,MFIOBJ
  255. J= J + 1
  256. INOOB1(I)=MTXBI(J)
  257. inoob2(i)=mtxbd(j)
  258. IOUEP2(i)=mtxbe(j)
  259. * write(6,*) ' i, inoob ' , i , inoob1(i),inoob2(i),iouep2(i)
  260. 154 CONTINUE
  261. C REMISE DES VALEURS DES FLOTTANTS
  262. IF( MTXFLO.NE.0) THEN
  263. SEGACT MTXFL3
  264. NREE = MITFLO(/1)
  265. IF ( NREE . NE . 0) THEN
  266. CALL POSCHA('##BID##',IPOSCH)
  267. DO 155 I=1,NREE
  268. NOMBID=INOOB1(MITFLO(I)+mdeobj-1)
  269. INOOB1(MITFLO(I)+mdeobj-1)=IPOSCH
  270. XRE = XTFLO(I)
  271. CALL NOMREE ('##BID##',XRE)
  272. INOOB1(MITFLO(I)+mdeobj-1)=NOMBID
  273. 155 CONTINUE
  274. ENDIF
  275. SEGDES MTXFL3
  276. ENDIF
  277. C INITIALISATION DES VARIABLES EN FONCTION DES OBJETS EXTERNES
  278. * write(6,*) ' proced appel inipro'
  279. CALL INIPRO(cnompr,mblo1)
  280. * write(6,*) ' proced sortie inipro'
  281. SEGDES MTXBI3
  282.  
  283. C RECOPIE DES ARGUMENTS DANS LA PILE
  284. IARGUM=MARGUM
  285. SEGACT IARGUM
  286. IF(NARG.NE.0) THEN
  287. DO 2 I =1,NARG
  288. II=2*I-1
  289. I5=I-1+MDEOBJ
  290. INOOB2(I5)=MTYYYA(I)
  291. IOUEP2(I5)=IVAL(II+1)
  292. IF(IVAL(II).EQ.0) THEN
  293. INOOB2(I5)='ANNULE '
  294. ENDIF
  295. 2 CONTINUE
  296. SEGSUP IVAL ,MTYYYB
  297. ENDIF
  298. SEGDES IARGUM
  299. RETURN
  300. END
  301.  
  302.  

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