Télécharger proced.eso

Retour à la liste

Numérotation des lignes :

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

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