Télécharger cenv.eso

Retour à la liste

Numérotation des lignes :

  1. C CENV SOURCE PV 16/11/26 21:15:07 9205
  2. subroutine CENV(colDes,iComm)
  3. C L'operateur CENV (COLlaborateur ENVoyer) permet d'envoyer une liste d'objet en
  4. C argument au collaborateur colDes, donne également en argument
  5. CEn se basant sur le fonctionnement du sauver, le fonctionnement est le
  6. C suivant :
  7. C -Recuperer la liste des arguments
  8. C -Verifier que le type des objets est correct
  9. C -Faire un premier remplissage des piles avec la liste d'argument
  10. C -Chercher les objets nécessaires pour la liste d'argument
  11. C -Envoyer cette liste
  12. C -Recevoir la liste des objets a envoyer
  13. C -Chercher la taille du buffer et l'allouer
  14. C -Remplir le buffer
  15. C -Envoyer le buffer
  16. C -FIN
  17. C Declaration des variables
  18. character*(8) typNom
  19. integer typNum
  20. integer nArg
  21. integer iComm
  22. integer iretou,i,ipile
  23. integer iPoint,nNoeud
  24. integer colDes,colMoi
  25. integer lonBuf
  26. integer taille
  27. integer bufPos
  28. integer nitlac
  29. integer totCol
  30. integer tagPre,tagMan,tagObj
  31. C Variable pour la lecture des entiers
  32. real*8 xval
  33. integer ival
  34. character*512 cval
  35. logical logval
  36. integer iob
  37. integer nbRee,nbCha,nbMot
  38.  
  39. -INC CCOPTIO
  40. -INC COCOLL
  41. -INC SMCOORD
  42. -INC TMCOLAC
  43. -INC CCASSIS
  44. -INC CCNOYAU
  45. C Declaration des types de segment
  46. segment BUFFER
  47. character ffer(lonBuf)
  48. endsegment
  49. segment PILOC
  50. real*8 reel(nbRee)
  51. character*(nbCha) chara
  52. integer motdeb(nbMot+1)
  53. endsegment
  54. segment LISARG
  55. character*8 nom(nArg)
  56. integer adress(nArg)
  57. endsegment
  58. pointeur argume.LISARG
  59. pointeur lisMan.LISARG
  60. pointeur lisReq.LISARG
  61. c Pointeur des gestions des assistants
  62. c pointeur mestra.MESTRA
  63. pointeur piles.LISPIL
  64. pointeur jcolac.ICOLAC
  65. pointeur lcolac.ICOLAC
  66. pointeur pilReq.ICOLAC
  67. pointeur jtlacc.ITLACC
  68. pointeur jlisse.ILISSE
  69. pointeur bu.BUFFER
  70. pointeur pilLoc.PILOC
  71. if(iimpi.ge.7) then
  72. write(ioimp,*) 'Entre dans CENV'
  73. write(ioimp,*) icomm
  74. endif
  75. nbRee=0
  76. nbCha=0
  77. nbMot=0
  78. lonBuf=0
  79. colMoi=0
  80. tagPre=12
  81. tagMan=14
  82. tagObj=15
  83. totCol=0
  84. piles = piComm
  85. C write(ioimp,*) 'piComm dans cenv',piles
  86. segact piles
  87. C Il faut garder le segments piles actifs, cela permet de bloquer
  88. C en ecriture le segment et donc de bloquer les appels a cfin
  89. C avant que les envois et receptions ne soient termines
  90. C Ce blocage n'empeche pas des envois / receptions simultanee car
  91. C on active en lecture, seul cdeb et cfin activent en mod
  92. segini pilLoc
  93. pilLoc.motDeb(1)=1
  94. call mpinbc ( totCol)
  95. if(icomm.eq.mpiComCa) then
  96. if(colDes.gt.totCol.or.colDes.lt.1) then
  97. write(ioimp,*)'Le numero du destinataire n''est pas correct'
  98. write(ioimp,*) colDes
  99. moterr( 1: 8) = 'collabor'
  100. call erreur(645)
  101. return
  102. else
  103. if(iimpi.ge.6) then
  104. write(ioimp,*) 'Debut de l''envoi au collaborateur ',
  105. & (colDes)
  106. endif
  107. endif
  108. else
  109. if(iimpi.ge.6) then
  110. write(ioimp,*) 'Debut de l''envoi vers l''exterieur ',
  111. & icomm, colDes
  112. endif
  113. endif
  114. call mpirgc ( colMoi )
  115.  
  116. nArg=0
  117. segini argume
  118. C INTEXT est une variable globale (cf CCNOYAU)
  119. typNom=' '
  120. C lecture d'un possible premier argume
  121. call quetyp(typNom,0,iretou)
  122. do while(iretou.eq.1)
  123. c------- on controle la validite du type demande
  124. typNum=0
  125. call typfil (typNom,typNum)
  126. if (typNum.eq.1 ) then
  127. call lirobj(typNom,iPoint,1,iretou)
  128. elseif (typNum.eq.2 ) then
  129. call lirobj(typNom,iPoint,1,iretou)
  130. elseif (typNum.eq.3 ) then
  131. call lirobj(typNom,iPoint,1,iretou)
  132. elseif (typNum.eq.24) then
  133. call lirlog(logval,1,iretou)
  134. if(logval) then
  135. iPoint=1
  136. else
  137. iPoint=0
  138. endif
  139. elseif (typNum.eq.25) then
  140. call lirree(xval,1,iretou)
  141. nbRee=nbRee+1
  142. segadj pilLoc
  143. iPoint=nbRee
  144. pilLoc.reel(iPoint)=xval
  145. elseif (typNum.eq.26) then
  146. call lirent(ival,1,iretou)
  147. iPoint=ival
  148. elseif (typNum.eq.27) then
  149. call lircha(cval,1,ival)
  150. nbMot=nbMot+1
  151. nbCha=nbCha+ival
  152. segadj pilLoc
  153. iPoint=nbMot
  154. pilLoc.motDeb(nbMot+1)=nbCha+1
  155. pilLoc.chara(nbCha-ival+1:nbCha)=cval(1:ival)
  156. elseif (typNum.eq.32) then
  157. call lirobj(typNom,iPoint,1,iretou)
  158. elseif (typNum.eq.33) then
  159. call lirobj(typNom,iPoint,1,iretou)
  160. elseif (typNum.eq.38) then
  161. call lirobj(typNom,iPoint,1,iretou)
  162. elseif (typNum.eq.39) then
  163. call lirobj(typNom,iPoint,1,iretou)
  164. else
  165. moterr(1:8)=typNom
  166. call erreur(39)
  167. return
  168. endif
  169.  
  170. c------- le type est ok, on l'ajoute a la liste
  171. nArg=nArg+1
  172. segadj argume
  173. argume.nom(nArg)=typNom
  174. argume.adress(nArg)=iPoint
  175. if(iimpi.ge.7) then
  176. write(ioimp,*) 'Ajout d un argument de type ',typNom
  177. write(ioimp,*) 'et de pointeur ',iPoint
  178. endif
  179. C On test s'il y a encore qq ch dans la pile pour savoir si on
  180. C refait une iteration ou pas
  181. typNom=' '
  182. call quetyp(typNom,0,iretou)
  183. enddo
  184. iretou = 0
  185.  
  186. if (nArg.eq.0) then
  187. segdes argume
  188. segsup argume
  189. moterr(1:8)=' '
  190. call erreur(37)
  191. else
  192. C write(ioimp,*) 'Nombre d'objets a sauver', nArg
  193. endif
  194. C Si on est le propre destinataire, inutile d'enoyer les objets
  195. if(colMoi+1.ne.colDes.or.icomm.ne.mpicomCa) then
  196. C Premier remplissage des piles avec la liste d'arguments lus
  197. typNom=' '
  198. typNum=-1
  199. call typfil(typNom,typNum)
  200. nitlac=-typNum
  201. call crepil(pilReq,nitlac)
  202. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  203. CC * attention aux assistants ....
  204. *te if (nbesc.ne.0) then
  205. C if (iimpi .eq. 1234)
  206. c write(ioimp,*) 'il faut bloquer les assistants'
  207. C mestra=imestr
  208. C segact mestra*mod
  209. *te call threadii
  210. C call ooofrc(1)
  211. C call setass(1)
  212. *te endif
  213. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  214. call filllu(argume,pilReq)
  215. C Second remplissage avec les objets references
  216. segact argume*mod
  217. segact mcoord
  218. call fillpi(pilReq)
  219. segdes mcoord
  220. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  221. *te if (nbesc.ne.0) then
  222. C call setass(0)
  223. C call ooofrc(0)
  224. C segact mestra
  225. *te call threadis
  226. *te endif
  227. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  228. segact pilReq*mod
  229. C write(ioimp,*) 'activation du segment de comm', colDes, jcolac
  230. lcolac = piles.proc(colDes)
  231. segini,jcolac=lcolac
  232. C segact jcolac*mod
  233. jlisse = jcolac.ilissg
  234. segact jlisse*mod
  235. do ipile=1,jcolac.kcola(/1)
  236. jtlacc=jcolac.kcola(ipile)
  237. if(jtlacc.gt.0) segact jtlacc*mod
  238. enddo
  239. call cinipi(jcolac)
  240. C Ajout des piles pilReq dans jcolac et renumerotation de pilReq
  241. call cajppi(pilReq,jcolac,.true.)
  242. C write(ioimp,*) 'desactivation du segment de comm', colDes, jcolac
  243. do ipile=1,jcolac.kcola(/1)
  244. jtlacc=jcolac.kcola(ipile)
  245. if(jtlacc.gt.0) segdes jtlacc
  246. enddo
  247. segdes jlisse
  248.  
  249. C Conversion des piles pilReq et list lisReq
  250. nArg=0
  251. segini lisReq
  252. C call savseg(lisReq)
  253. call cpi2li(pilReq,lisReq)
  254. call clibpi(pilReq)
  255. if(iimpi.ge.7) then
  256. write(ioimp,*) 'Objets dans la liste des prerequis:'
  257. do i=1,lisReq.adress(/1)
  258. write(ioimp,*) i,lisReq.adress(i),lisReq.nom(i)
  259. enddo
  260. endif
  261. C Mesure de la liste lisReq
  262. lonBuf=0
  263. call cmearg(lisReq,taille)
  264. lonBuf = lonBuf + taille
  265. C Allocation du buffer
  266. segini bu
  267. bufPos=0
  268. C Paquettage de la liste des objets necessaires
  269. call cpaarg(lisReq,bu,bufPos)
  270. segsup lisReq
  271. C Envoi de la liste des objets necessaires
  272. if(iimpi.ge.6) then
  273. write(ioimp,*) 'Envoi de la liste des prerequis au coll',
  274. & colDes
  275. write(ioimp,*) 'Longueur du buffer :', bufPos
  276. endif
  277. call mpiEnv(colDes,iComm,tagPre,bu,bufPos)
  278. c Reception de la liste des objets a envoyer
  279. if(iimpi.ge.6) then
  280. write(ioimp,*) 'Attente de la liste des objets a envoyer'
  281. endif
  282. call mpiRcv(colDes,iComm,tagMan,bu)
  283. bufPos = 0
  284. nArg=0
  285. C Extraction de la liste des objets a envoyer du buffer
  286. call cuparg(bu,bufPos,lisMan)
  287. segsup bu
  288. C Conversion dans lisMan des positions dans la pile en pointeur
  289. segact jlisse
  290. do ipile=1,jcolac.kcola(/1)
  291. jtlacc=jcolac.kcola(ipile)
  292. if(ipile.lt.24.or.ipile.gt.27) then
  293. if(jtlacc.gt.0) segact jtlacc
  294. else
  295. if(jtlacc.gt.0) segact jtlacc*mod
  296. endif
  297. enddo
  298. if(iimpi.ge.6) then
  299. write(ioimp,*) 'Liste des objets manquants recus'
  300. endif
  301. call clip2s(jcolac,lisMan)
  302. C Calcul de la taille du message et allocation
  303. lonBuf=0
  304. call cmelis(lisMan,jcolac,taille)
  305. lonBuf = lonBuf + taille
  306. call cmeplo(pilLoc,taille)
  307. lonBuf = lonBuf + taille
  308. lonBuf = lonBuf + taille
  309. C write(ioimp,*) 'allocation d un buffer de taille',lonBuf
  310. segini bu
  311. bufPos=0
  312. C Paquettage des objets
  313. if(iimpi.ge.6) then
  314. write(ioimp,*) 'Paquettage des objets'
  315. endif
  316. call cpaplo(pilLoc,bu,bufPos)
  317. segsup pilLoc
  318. segact mcoord
  319. nNoeud=mcoord.xcoor(/1)/(idim+1)
  320. call cpalis(lisMan,jcolac,nNoeud,bu,bufPos)
  321. segdes mcoord
  322.  
  323. segsup lisMan
  324. C Renumerotation de la liste des arguments
  325. call clis2p(jcolac,argume)
  326. do ipile=1,jcolac.kcola(/1)
  327. jtlacc=jcolac.kcola(ipile)
  328. if(ipile.lt.24.or.ipile.gt.27) then
  329. segdes jtlacc
  330. else
  331. C call libseg(jtlacc)
  332. segsup jtlacc
  333. jcolac.kcola(ipile)=0
  334. endif
  335. enddo
  336. segdes jlisse
  337. segsup jcolac
  338.  
  339. C Paquettage des la liste des objets a retourner
  340. if(iimpi.ge.6) then
  341. write(ioimp,*) 'Paquettage de la liste des arguments'
  342. endif
  343. call cpaarg(argume,bu,bufPos)
  344. segdes argume
  345. C call libseg(argume)
  346. segsup argume
  347. C Envoi du message
  348. if(iimpi.ge.6) then
  349. write(ioimp,*) 'Envoi des objets au coll',colDes
  350. endif
  351. C if (nbesc.ne.0) then
  352. C segdes mestra
  353. C endif
  354. call mpiEnv(colDes,iComm,tagObj,bu,bufPos)
  355. if(iimpi.ge.6) then
  356. write(ioimp,*) 'Fin de l''envoi a ',colDes
  357. endif
  358. else
  359. C Cas d'un message envoyer a soi meme
  360. lonBuf = taille
  361. call cmeplo(pilLoc,taille)
  362. lonBuf = lonBuf+taille
  363. C write(ioimp,*) 'allocation d un buffer de taille',lonBuf
  364. segini bu
  365. bufPos=0
  366. call cpaplo(pilLoc,bu,bufPos)
  367. segsup pilLoc
  368. call cpaarg(argume,bu,bufPos)
  369. segdes argume
  370. segsup argume
  371. C Envoi du message
  372. if(iimpi.ge.6) then
  373. write(ioimp,*) 'Envoi du message a soi meme '
  374. endif
  375. call mpiEnv(colDes,iComm,tagObj,bu,bufPos)
  376. endif
  377. segdes piles
  378.  
  379. C L'envoi est termine, on peut debloquer le segment piles (cf
  380. C remarque lors de l'activation de ce segment)
  381. C write(ioimp,*) 'Sortie de CENV'
  382. end
  383.  
  384.  
  385.  
  386.  
  387.  

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